Uwe
Schmidt
-
+
-Last modified: Tue Aug 17 15:56:59 CEST 2010
-
+Last modified: Thu Feb 3 13:27:19 CET 2011
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/xhtml/xhtml-special.ent b/examples/xhtml/xhtml-special.ent
new file mode 100644
--- /dev/null
+++ b/examples/xhtml/xhtml-special.ent
@@ -0,0 +1,79 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/xhtml/xhtml-symbol.ent b/examples/xhtml/xhtml-symbol.ent
new file mode 100644
--- /dev/null
+++ b/examples/xhtml/xhtml-symbol.ent
@@ -0,0 +1,242 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/xhtml/xhtml.xml b/examples/xhtml/xhtml.xml
new file mode 100644
--- /dev/null
+++ b/examples/xhtml/xhtml.xml
@@ -0,0 +1,1484 @@
+
+
+
+
+XHTML 1.0: The Extensible HyperText Markup
+Language
+Abstract
+
+This specification defines XHTML 1.0, a reformulation of HTML 4
+as an XML 1.0 application, and three DTDs corresponding to
+the ones defined by HTML 4. The semantics of the elements and
+their attributes are defined in the W3C Recommendation for HTML 4.
+These semantics provide the foundation for future
+extensibility of XHTML. Compatibility with existing HTML user
+agents is possible by following a small set of guidelines.
+
+Status of this document
+
+This section describes the status of this document at the time
+of its publication. Other documents may supersede this document. The
+latest status of this document series is maintained at the W3C.
+
+
+This document has been reviewed by W3C Members and other
+interested parties and has been endorsed by the Director
+as a W3C Recommendation. It is a stable document and may be
+used as reference material or cited as a normative
+reference from another document. W3C's role in making the
+Recommendation is to draw attention to the specification and
+to promote its widespread deployment. This enhances the
+functionality and interoperability of the Web.
+
+This document has been produced as part of the W3C HTML Activity . The goals of
+the HTML Working
+Group (members
+only ) are discussed in the HTML Working Group
+charter (members
+only ) .
+
+A list of current W3C Recommendations and other technical documents
+can be found at http://www.w3.org/TR .
+
+Public discussion on HTML features takes place on the mailing list www-html@w3.org (archive ).
+
+Please report errors in this document to www-html-editor@w3.org .
+
+The list of known errors in this specification is available at http://www.w3.org/2000/01/REC-xhtml1-20000126-errata .
+
+
+
+
+
+
+
+
+XHTML is a family of current and future document types and modules that
+reproduce, subset, and extend HTML 4 [HTML] . XHTML family document types are XML based,
+and ultimately are designed to work in conjunction with XML-based user agents.
+The details of this family and its evolution are
+discussed in more detail in the section on Future
+Directions .
+
+XHTML 1.0 (this specification) is the first document type in the XHTML
+family. It is a reformulation of the three HTML 4 document types as
+applications of XML 1.0 [XML] . It is intended
+to be used as a language for content that is both XML-conforming and, if some
+simple guidelines are followed,
+operates in HTML 4 conforming user agents. Developers who migrate
+their content to XHTML 1.0 will realize the following benefits:
+
+
+XHTML documents are XML conforming. As such, they are readily viewed,
+edited, and validated with standard XML tools.
+XHTML documents can be written to
+to operate as well or better than they did before in existing
+HTML 4-conforming user agents as well as in new, XHTML 1.0 conforming user
+agents.
+XHTML documents can utilize applications (e.g. scripts and applets) that rely
+upon either the HTML Document Object Model or the XML Document Object Model [DOM] .
+As the XHTML family evolves, documents conforming to XHTML 1.0 will be more
+likely to interoperate within and among various XHTML environments.
+
+
+The XHTML family is the next step in the evolution of the Internet. By
+migrating to XHTML today, content developers can enter the XML world with all
+of its attendant benefits, while still remaining confident in their
+content's backward and future compatibility.
+
+
+
+HTML 4 [HTML] is an SGML (Standard
+Generalized Markup Language) application conforming to
+International Standard ISO 8879, and is widely regarded as the
+standard publishing language of the World Wide Web.
+
+SGML is a language for describing markup languages,
+particularly those used in electronic document exchange, document
+management, and document publishing. HTML is an example of a
+language defined in SGML.
+
+SGML has been around since the middle 1980's and has remained
+quite stable. Much of this stability stems from the fact that the
+language is both feature-rich and flexible. This flexibility,
+however, comes at a price, and that price is a level of
+complexity that has inhibited its adoption in a diversity of
+environments, including the World Wide Web.
+
+HTML, as originally conceived, was to be a language for the
+exchange of scientific and other technical documents, suitable
+for use by non-document specialists. HTML addressed the problem
+of SGML complexity by specifying a small set of structural and
+semantic tags suitable for authoring relatively simple documents.
+In addition to simplifying the document structure, HTML added
+support for hypertext. Multimedia capabilities were added
+later.
+
+In a remarkably short space of time, HTML became wildly
+popular and rapidly outgrew its original purpose. Since HTML's
+inception, there has been rapid invention of new elements for use
+within HTML (as a standard) and for adapting HTML to vertical,
+highly specialized, markets. This plethora of new elements has
+led to compatibility problems for documents across different
+platforms.
+
+As the heterogeneity of both software and platforms rapidly
+proliferate, it is clear that the suitability of 'classic' HTML 4
+for use on these platforms is somewhat limited.
+
+
+
+XML™ is the shorthand for Extensible Markup
+Language, and is an acronym of Extensible Markup Language [XML] .
+
+XML was conceived as a means of regaining the power and
+flexibility of SGML without most of its complexity. Although a
+restricted form of SGML, XML nonetheless preserves most of SGML's
+power and richness, and yet still retains all of SGML's commonly
+used features.
+
+While retaining these beneficial features, XML removes many of
+the more complex features of SGML that make the authoring and
+design of suitable software both difficult and costly.
+
+
+
+The benefits of migrating to XHTML 1.0 are described above. Some of the
+benefits of migrating to XHTML in general are:
+
+
+Document developers and user agent designers are constantly
+discovering new ways to express their ideas through new markup. In XML, it is
+relatively easy to introduce new elements or additional element
+attributes. The XHTML family is designed to accommodate these extensions
+through XHTML modules and techniques for developing new XHTML-conforming
+modules (described in the forthcoming XHTML Modularization specification).
+These modules will permit the combination of existing and
+new feature sets when developing content and when designing new user
+agents.
+
+Alternate ways of accessing the Internet are constantly being
+introduced. Some estimates indicate that by the year 2002, 75% of
+Internet document viewing will be carried out on these alternate
+platforms. The XHTML family is designed with general user agent
+interoperability in mind. Through a new user agent and document profiling
+mechanism, servers, proxies, and user agents will be able to perform
+best effort content transformation. Ultimately, it will be possible to
+develop XHTML-conforming content that is usable by any XHTML-conforming
+user agent.
+
+
+
+
+
+
+
+The following terms are used in this specification. These
+terms extend the definitions in
+[RFC2119] in ways based upon similar definitions in ISO/IEC
+9945-1:1990 [POSIX.1] :
+
+
+Implementation-defined
+
+A value or behavior is implementation-defined when it is left
+to the implementation to define [and document] the corresponding
+requirements for correct document construction.
+
+May
+
+With respect to implementations, the word "may" is to be
+interpreted as an optional feature that is not required in this
+specification but can be provided. With respect to Document Conformance , the word "may" means that
+the optional feature must not be used. The term "optional" has
+the same definition as "may".
+
+Must
+
+In this specification, the word "must" is to be interpreted
+as a mandatory requirement on the implementation or on Strictly
+Conforming XHTML Documents, depending upon the context. The term
+"shall" has the same definition as "must".
+
+Reserved
+
+A value or behavior is unspecified, but it is not allowed to
+be used by Conforming Documents nor to be supported by a
+Conforming User Agents.
+
+Should
+
+With respect to implementations, the word "should" is to be
+interpreted as an implementation recommendation, but not a
+requirement. With respect to documents, the word "should" is to
+be interpreted as recommended programming practice for documents
+and a requirement for Strictly Conforming XHTML Documents.
+
+Supported
+
+Certain facilities in this specification are optional. If a
+facility is supported, it behaves as specified by this
+specification.
+
+Unspecified
+
+When a value or behavior is unspecified, the specification
+defines no portability requirements for a facility on an
+implementation even when faced with a document that uses the
+facility. A document that requires specific behavior in such an
+instance, rather than tolerating any behavior when using that
+facility, is not a Strictly Conforming XHTML Document.
+
+
+
+
+
+Attribute
+
+An attribute is a parameter to an element declared in the
+DTD. An attribute's type and value range, including a possible
+default value, are defined in the DTD.
+
+DTD
+
+A DTD, or document type definition, is a collection of XML
+declarations that, as a collection, defines the legal structure,
+elements , and
+attributes that are available for use in a document that
+complies to the DTD.
+
+Document
+
+A document is a stream of data that, after being combined
+with any other streams it references, is structured such that it
+holds information contained within
+elements that are organized as defined in the associated
+DTD . See Document
+Conformance for more information.
+
+Element
+
+An element is a document structuring unit declared in the
+DTD . The element's content model is
+defined in the DTD , and additional
+semantics may be defined in the prose description of the
+element.
+
+Facilities Functionality includes elements ,
+attributes , and the semantics
+associated with those elements and
+attributes . An implementation
+supporting that functionality is said to provide the necessary
+facilities.
+
+Implementation
+
+An implementation is a system that provides collection of
+facilities and services that supports
+this specification. See User Agent
+Conformance for more information.
+
+Parsing
+
+Parsing is the act whereby a
+document is scanned, and the information contained within
+the document is filtered into the
+context of the elements in which the
+information is structured.
+
+Rendering
+
+Rendering is the act whereby the information in a document is presented. This presentation is
+done in the form most appropriate to the environment (e.g.
+aurally, visually, in print).
+
+User Agent
+
+A user agent is an implementation
+that retrieves and processes XHTML documents. See User Agent Conformance for more information.
+
+Validation
+
+Validation is a process whereby
+documents are verified against the associated DTD , ensuring that the structure, use of elements , and use of
+attributes are consistent with the definitions in the
+DTD .
+
+Well-formed A document is well-formed when it
+is structured according to the rules defined in Section 2.1 of
+the XML 1.0 Recommendation [XML] .
+Basically, this definition states that elements, delimited by
+their start and end tags, are nested properly within one
+another.
+
+
+
+
+
+
+
+This version of XHTML provides a definition of strictly
+conforming XHTML documents, which are restricted to tags and
+attributes from the XHTML namespace. See Section 3.1.2 for information on using XHTML
+with other namespaces, for instance, to include metadata
+expressed in RDF within XHTML documents.
+
+
+
+A Strictly Conforming XHTML Document is a document that
+requires only the facilities described as mandatory in this
+specification. Such a document must meet all of the following
+criteria:
+
+
+
+It must validate against one of the three DTDs found in Appendix A .
+
+
+
+The root element of the document must be
+<html>.
+
+
+
+The root element of the document must designate the XHTML
+namespace using the xmlns attribute [XMLNAMES] . The namespace for XHTML is
+defined to be
+http://www.w3.org/1999/xhtml.
+
+
+
+There must be a DOCTYPE declaration in the document prior to
+the root element. The public identifier included in
+the DOCTYPE declaration must reference one of the three DTDs
+found in Appendix A using the respective
+Formal Public Identifier. The system identifier may be changed to reflect
+local system conventions.
+
+
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "DTD/xhtml1-strict.dtd">
+
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "DTD/xhtml1-transitional.dtd">
+
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
+ "DTD/xhtml1-frameset.dtd">
+
+
+
+
+Here is an example of a minimal XHTML document.
+
+
+
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+ <head>
+ <title>Virtual Library</title>
+ </head>
+ <body>
+ <p>Moved to <a href="http://vlib.org/">vlib.org</a>.</p>
+ </body>
+</html>
+
Note that in this example, the XML declaration is included. An XML
+declaration like the one above is
+not required in all XML documents. XHTML document authors are strongly encouraged to use XML declarations in all their documents. Such a declaration is required
+when the character encoding of the document is other than the default UTF-8 or
+UTF-16.
+
+
+
+The XHTML namespace may be used with other XML namespaces
+as per [XMLNAMES] , although such
+documents are not strictly conforming XHTML 1.0 documents as
+defined above. Future work by W3C will address ways to specify
+conformance for documents involving multiple namespaces.
+
+The following example shows the way in which XHTML 1.0 could
+be used in conjunction with the MathML Recommendation:
+
+
+
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+ <head>
+ <title>A Math Example</title>
+ </head>
+ <body>
+ <p>The following is MathML markup:</p>
+ <math xmlns="http://www.w3.org/1998/Math/MathML">
+ <apply> <log/>
+ <logbase>
+ <cn> 3 </cn>
+ </logbase>
+ <ci> x </ci>
+ </apply>
+ </math>
+ </body>
+</html>
+
+
The following example shows the way in which XHTML 1.0 markup
+could be incorporated into another XML namespace:
+
+
+
+<?xml version="1.0" encoding="UTF-8"?>
+<!-- initially, the default namespace is "books" -->
+<book xmlns='urn:loc.gov:books'
+ xmlns:isbn='urn:ISBN:0-395-36341-6' xml:lang="en" lang="en">
+ <title>Cheaper by the Dozen</title>
+ <isbn:number>1568491379</isbn:number>
+ <notes>
+ <!-- make HTML the default namespace for a hypertext commentary -->
+ <p xmlns='http://www.w3.org/1999/xhtml'>
+ This is also available <a href="http://www.w3.org/">online</a>.
+ </p>
+ </notes>
+</book>
+
+
A conforming user agent must meet all of the following
+criteria:
+
+
+In order to be consistent with the XML 1.0 Recommendation [XML] , the user agent must parse and evaluate
+an XHTML document for well-formedness. If the user agent claims
+to be a validating user agent, it must also validate documents
+against their referenced DTDs according to
+[XML] .
+
+When the user agent claims to support
+facilities defined within this specification or required by
+this specification through normative reference, it must do so in
+ways consistent with the facilities' definition.
+
+When a user agent processes an XHTML document as generic XML,
+it shall only recognize attributes of type
+ID (e.g. the id attribute on most XHTML elements)
+as fragment identifiers.
+
+If a user agent encounters an element it does not recognize,
+it must render the element's content.
+
+If a user agent encounters an attribute it does not
+recognize, it must ignore the entire attribute specification
+(i.e., the attribute and its value).
+
+If a user agent encounters an attribute value it doesn't
+recognize, it must use the default attribute value.
+
+If it encounters an entity reference (other than one
+of the predefined entities) for which the User Agent has
+processed no declaration (which could happen if the declaration
+is in the external subset which the User Agent hasn't read), the entity
+reference should be rendered as the characters (starting
+with the ampersand and ending with the semi-colon) that
+make up the entity reference.
+
+When rendering content, User Agents that encounter
+characters or character entity references that are recognized but not renderable should display the document in such a way that it is obvious to the user that normal rendering has not taken place.
+
+
+The following characters are defined in [XML] as whitespace characters:
+
+
+Space ( )
+Tab (	)
+Carriage return (
)
+Line feed (
)
+
+
+
+The XML processor normalizes different system's line end codes into one
+single line-feed character, that is passed up to the application. The XHTML
+user agent in addition, must treat the following characters as whitespace:
+
+
+
+Form feed ()
+Zero-width space (​)
+
+
+
+In elements where the 'xml:space' attribute is set to 'preserve', the user
+agent must leave all whitespace characters intact (with the exception of
+leading and trailing whitespace characters, which should be removed).
+Otherwise, whitespace
+is handled according to the following rules:
+
+
+
+
+All whitespace surrounding block elements should be removed.
+
+
+Comments are removed entirely and do not affect whitespace handling. One
+whitespace character on either side of a comment is treated as two white
+space characters.
+
+
+Leading and trailing whitespace inside a block element must be removed.
+
+Line feed characters within a block element must be converted into a
+space (except when the 'xml:space' attribute is set to 'preserve').
+
+
+A sequence of white space characters must be reduced to a single space
+character (except when the 'xml:space' attribute is set to 'preserve').
+
+
+With regard to rendition,
+the User Agent should render the content in a
+manner appropriate to the language in which the content is written.
+In languages whose primary script is Latinate, the ASCII space
+character is typically used to encode both grammatical word boundaries and
+typographic whitespace; in languages whose script is related to Nagari
+(e.g., Sanskrit, Thai, etc.), grammatical boundaries may be encoded using
+the ZW 'space' character, but will not typically be represented by
+typographic whitespace in rendered output; languages using Arabiform scripts
+may encode typographic whitespace using a space character, but may also use
+the ZW space character to delimit 'internal' grammatical boundaries (what
+look like words in Arabic to an English eye frequently encode several words,
+e.g. 'kitAbuhum' = 'kitAbu-hum' = 'book them' == their book); and languages
+in the Chinese script tradition typically neither encode such delimiters nor
+use typographic whitespace in this way.
+
+
+
+Whitespace in attribute values is processed according to [XML] .
+
+
+
+
+
+
+Due to the fact that XHTML is an XML application, certain
+practices that were perfectly legal in SGML-based HTML 4 [HTML] must be changed.
+
+
+
+Well-formedness is a new concept
+introduced by [XML] . Essentially this
+means that all elements must either have closing tags or be
+written in a special form (as described below), and that all the
+elements must nest.
+
+Although overlapping is illegal in SGML, it was widely
+tolerated in existing browsers.
+
+
+
CORRECT: nested elements.
+
+
<p>here is an emphasized
+<em>paragraph</em>.</p>
+
+
INCORRECT: overlapping elements
+
+
<p>here is an emphasized
+<em>paragraph.</p></em>
+
XHTML documents must use lower case for all HTML element and
+attribute names. This difference is necessary because XML is
+case-sensitive e.g. <li> and <LI> are different
+tags.
+
+
+
+In SGML-based HTML 4 certain elements were permitted to omit
+the end tag; with the elements that followed implying closure.
+This omission is not permitted in XML-based XHTML. All elements
+other than those declared in the DTD as EMPTY must
+have an end tag.
+
+
+
CORRECT: terminated elements
+
+
<p>here is a paragraph.</p><p>here is
+another paragraph.</p>
+
+
INCORRECT: unterminated elements
+
+
<p>here is a paragraph.<p>here is another
+paragraph.
+
All attribute values must be quoted, even those which appear
+to be numeric.
+
+
+
CORRECT: quoted attribute values
+
+
<table rows="3">
+
+
INCORRECT: unquoted attribute values
+
+
<table rows=3>
+
XML does not support attribute minimization. Attribute-value
+pairs must be written in full. Attribute names such as
+compact and checked cannot occur in elements
+without their value being specified.
+
+
+
CORRECT: unminimized attributes
+
+
<dl compact="compact">
+
+
INCORRECT: minimized attributes
+
+
<dl compact>
+
Empty elements must either have an end tag or the start tag must end with />. For instance,
+<br/> or <hr></hr>. See HTML Compatibility Guidelines for information on ways to
+ensure this is backward compatible with HTML 4 user agents.
+
+
+
CORRECT: terminated empty tags
+
+
<br/><hr/>
+
+
INCORRECT: unterminated empty tags
+
+
<br><hr>
+
In attribute values, user agents will strip leading and
+trailing whitespace from attribute values and map sequences
+of one or more whitespace characters (including line breaks) to
+a single inter-word space (an ASCII space character for western
+scripts). See
+Section 3.3.3 of [XML] .
+
+
+
+In XHTML, the script and style elements are declared as having
+#PCDATA content. As a result, < and
+& will be treated as the start of markup, and
+entities such as < and &
+will be recognized as entity references by the XML processor to
+< and & respectively. Wrapping
+the content of the script or style element within a
+CDATA marked section avoids the expansion of these
+entities.
+
+
+
+<script>
+ <![CDATA[
+ ... unescaped script content ...
+ ]]>
+ </script>
+
+
CDATA sections are recognized by the XML
+processor and appear as nodes in the Document Object Model, see
+
+Section 1.3 of the DOM Level 1 Recommendation [DOM] .
+
+An alternative is to use external script and style
+documents.
+
+
+
+SGML gives the writer of a DTD the ability to exclude specific
+elements from being contained within an element. Such
+prohibitions (called "exclusions") are not possible in XML.
+
+For example, the HTML 4 Strict DTD forbids the nesting of an
+'a' element within another 'a' element
+to any descendant depth. It is not possible to spell out such
+prohibitions in XML. Even though these prohibitions cannot be
+defined in the DTD, certain elements should not be nested. A
+summary of such elements and the elements that should not be
+nested in them is found in the normative
+Appendix B .
+
+
+
+HTML 4 defined the name attribute for the elements
+a,
+applet, form, frame,
+iframe, img, and map.
+HTML 4 also introduced
+the id attribute. Both of these attributes are designed to be
+used as fragment identifiers.
+In XML, fragment identifiers are of type ID, and
+there can only be a single attribute of type ID per element.
+Therefore, in XHTML 1.0 the id
+attribute is defined to be of type ID. In order to
+ensure that XHTML 1.0 documents are well-structured XML documents, XHTML 1.0
+documents MUST use the id attribute when defining fragment
+identifiers, even on elements that historically have also had a
+name attribute.
+See the HTML Compatibility
+Guidelines for information on ensuring such anchors are backwards
+compatible when serving XHTML documents as media type text/html.
+
+Note that in XHTML 1.0, the name attribute of these
+elements is formally deprecated, and will be removed in a
+subsequent version of XHTML.
+
+
+
+
+Although there is no requirement for XHTML 1.0 documents to be
+compatible with existing user agents, in practice this is easy to
+accomplish. Guidelines for creating compatible documents can be
+found in Appendix C .
+
+
+As of the publication of this recommendation, the general
+recommended MIME labeling for XML-based applications
+has yet to be resolved.
+
+However, XHTML Documents which follow the guidelines set forth
+in Appendix C , "HTML Compatibility Guidelines" may be
+labeled with the Internet Media Type "text/html", as they
+are compatible with most HTML browsers. This document
+makes no recommendation about MIME labeling of other
+XHTML documents.
+
+
+
+
+XHTML 1.0 provides the basis for a family of document types
+that will extend and subset XHTML, in order to support a wide
+range of new devices and applications, by defining modules and
+specifying a mechanism for combining these modules. This
+mechanism will enable the extension and sub-setting of XHTML 1.0
+in a uniform way through the definition of new modules.
+
+
+
+As the use of XHTML moves from the traditional desktop user
+agents to other platforms, it is clear that not all of the XHTML
+elements will be required on all platforms. For example a hand
+held device or a cell-phone may only support a subset of XHTML
+elements.
+
+The process of modularization breaks XHTML up into a series of
+smaller element sets. These elements can then be recombined to
+meet the needs of different communities.
+
+These modules will be defined in a later W3C document.
+
+
+
+Modularization brings with it several advantages:
+
+
+
+It provides a formal mechanism for sub-setting XHTML.
+
+
+
+It provides a formal mechanism for extending XHTML.
+
+
+
+It simplifies the transformation between document types.
+
+
+
+It promotes the reuse of modules in new document types.
+
+
+
+
+
+A document profile specifies the syntax and semantics of a set
+of documents. Conformance to a document profile provides a basis
+for interoperability guarantees. The document profile specifies
+the facilities required to process documents of that type, e.g.
+which image formats can be used, levels of scripting, style sheet
+support, and so on.
+
+For product designers this enables various groups to define
+their own standard profile.
+
+For authors this will obviate the need to write several
+different versions of documents for different clients.
+
+For special groups such as chemists, medical doctors, or
+mathematicians this allows a special profile to be built using
+standard HTML elements plus a group of elements geared to the
+specialist's needs.
+
+
+
+
+This appendix is normative.
+
+These DTDs and entity sets form a normative part of this
+specification. The complete set of DTD files together with an XML
+declaration and SGML Open Catalog is included in the zip file for this specification.
+
+
+
+These DTDs approximate the HTML 4 DTDs. It is likely that
+when the DTDs are modularized, a method of DTD construction will
+be employed that corresponds more closely to HTML 4.
+
+
+
+
+
+The XHTML entity sets are the same as for HTML 4, but have
+been modified to be valid XML 1.0 entity declarations. Note the
+entity for the Euro currency sign (€ or
+€ or €) is defined
+as part of the special characters.
+
+
+
+
+
+
+This appendix is normative.
+
+The following elements have prohibitions on which elements
+they can contain (see Section 4.9 ). This
+prohibition applies to all depths of nesting, i.e. it contains
+all the descendant elements.
+
+a
+cannot contain other a elements.
+precannot contain the img, object,
+big, small, sub, or
+sup elements.
+
+buttoncannot contain the input, select,
+textarea, label, button,
+form, fieldset, iframe or
+isindex elements.
+labelcannot contain other label elements.
+formcannot contain other form elements.
+This appendix is informative.
+
+This appendix summarizes design guidelines for authors who
+wish their XHTML documents to render on existing HTML user
+agents.
+
+C.1 Processing Instructions
+Be aware that processing instructions are rendered on some
+user agents. However, also note that when the XML declaration is not included
+in a document, the document can only use the default character encodings UTF-8
+or UTF-16.
+
+C.2 Empty Elements
+Include a space before the trailing / and
+> of empty elements, e.g.
+<br />,
+<hr /> and <img
+src="karen.jpg" alt="Karen" />. Also, use the
+minimized tag syntax for empty elements, e.g. <br />, as the alternative syntax <br></br> allowed by XML
+gives uncertain results in many existing user agents.
+
+C.3 Element Minimization and Empty Element Content
+Given an empty instance of an element whose content model is
+not EMPTY (for example, an empty title or paragraph)
+do not use the minimized form (e.g. use
+<p> </p> and not
+<p />).
+
+C.4 Embedded Style Sheets and Scripts
+Use external style sheets if your style sheet uses
+< or & or ]]> or --. Use
+external scripts if your script uses < or
+& or ]]> or --. Note that XML parsers
+are permitted to silently remove the contents of comments. Therefore, the historical
+practice of "hiding" scripts and style sheets within comments to make the
+documents backward compatible is likely to not work as expected in XML-based
+implementations.
+
+C.5 Line Breaks within Attribute Values
+Avoid line breaks and multiple whitespace characters within
+attribute values. These are handled inconsistently by user
+agents.
+
+C.6 Isindex
+Don't include more than one isindex element in
+the document head. The isindex element
+is deprecated in favor of the input element.
+
+C.7 The lang and xml:lang Attributes
+Use both the lang and xml:lang
+attributes when specifying the language of an element. The value
+of the xml:lang attribute takes precedence.
+
+C.8 Fragment Identifiers
+In XML, URIs [RFC2396 ] that end with fragment identifiers of the form
+"#foo" do not refer to elements with an attribute
+name="foo"; rather, they refer to elements with an
+attribute defined to be of type ID, e.g., the
+id attribute in HTML 4. Many existing HTML clients don't
+support the use of ID-type attributes in this way,
+so identical values may be supplied for both of these attributes to ensure
+maximum forward and backward compatibility (e.g., <a id="foo" name="foo">...</a>).
+
+Further, since the set of
+legal values for attributes of type ID is much smaller than
+for those of type CDATA, the type of the name
+attribute has been changed to NMTOKEN. This attribute is
+constrained such that it can only have the same values as type
+ID, or as the Name production in XML 1.0 Section
+2.5, production 5. Unfortunately, this constraint cannot be expressed in the
+XHTML 1.0 DTDs. Because of this change, care must be taken when
+converting existing HTML documents. The values of these attributes
+must be unique within the document, valid, and any references to these
+fragment identifiers (both
+internal and external) must be updated should the values be changed during
+conversion.
+Finally, note that XHTML 1.0 has deprecated the
+name attribute of the a, applet, form, frame, iframe, img, and map
+elements, and it will be
+removed from XHTML in subsequent versions.
+
+C.9 Character Encoding
+To specify a character encoding in the document, use both the
+encoding attribute specification on the xml declaration (e.g.
+<?xml version="1.0"
+encoding="EUC-JP"?>) and a meta http-equiv statement
+(e.g. <meta http-equiv="Content-type"
+content='text/html; charset="EUC-JP"' />). The
+value of the encoding attribute of the xml processing instruction
+takes precedence.
+
+C.10 Boolean Attributes
+Some HTML user agents are unable to interpret boolean
+attributes when these appear in their full (non-minimized) form,
+as required by XML 1.0. Note this problem doesn't affect user
+agents compliant with HTML 4. The following attributes are
+involved: compact, nowrap,
+ismap, declare, noshade,
+checked, disabled, readonly,
+multiple, selected,
+noresize, defer.
+
+C.11 Document Object Model and XHTML
+
+The Document Object Model level 1 Recommendation [DOM ]
+defines document object model interfaces for XML and HTML 4. The HTML 4
+document object model specifies that HTML element and attribute names are
+returned in upper-case. The XML document object model specifies that
+element and attribute names are returned in the case they are specified. In
+XHTML 1.0, elements and attributes are specified in lower-case. This apparent difference can be
+addressed in two ways:
+
+
+Applications that access XHTML documents served as Internet media type
+text/html
+via the DOM can use the HTML DOM,
+and can rely upon element and attribute names being returned in
+upper-case from those interfaces.
+Applications that access XHTML documents served as Internet media types
+text/xml or application/xml
+can also use the XML DOM. Elements and attributes will be returned in lower-case.
+Also, some XHTML elements may or may
+not appear
+in the object tree because they are optional in the content model
+(e.g. the tbody element within
+table). This occurs because in HTML 4 some elements were
+permitted to be minimized such that their start and end tags are both omitted
+(an SGML feature).
+This is not possible in XML. Rather than require document authors to insert
+extraneous elements, XHTML has made the elements optional.
+Applications need to adapt to this
+accordingly.
+
+
+C.12 Using Ampersands in Attribute Values
+
+When an attribute value contains an ampersand, it must be expressed as a character
+entity reference
+(e.g. "&"). For example, when the
+href attribute
+of the a element refers to a
+CGI script that takes parameters, it must be expressed as
+http://my.site.dom/cgi-bin/myscript.pl?class=guest&name=user
+rather than as
+http://my.site.dom/cgi-bin/myscript.pl?class=guest&name=user.
+
+
+C.13 Cascading Style Sheets (CSS) and XHTML
+
+The Cascading Style Sheets level 2 Recommendation [CSS2 ] defines style
+properties which are applied to the parse tree of the HTML or XML
+document. Differences in parsing will produce different visual or
+aural results, depending on the selectors used. The following hints
+will reduce this effect for documents which are served without
+modification as both media types:
+
+
+
+CSS style sheets for XHTML should use lower case element and
+attribute names.
+
+
+In tables, the tbody element will be inferred by the parser of an
+HTML user agent, but not by the parser of an XML user agent. Therefore
+you should always explicitly add a tbody element if it is referred to
+in a CSS selector.
+
+Within the XHTML name space, user agents are expected to
+recognize the "id" attribute as an attribute of type ID.
+Therefore, style sheets should be able to continue using the
+shorthand "#" selector syntax even if the user agent does not read
+the DTD.
+
+Within the XHTML name space, user agents are expected to
+recognize the "class" attribute. Therefore, style sheets should be
+able to continue using the shorthand "." selector syntax.
+
+
+CSS defines different conformance rules for HTML and XML documents;
+be aware that the HTML rules apply to XHTML documents delivered as
+HTML and the XML rules apply to XHTML documents delivered as XML.
+
+
+
+
+This appendix is informative.
+
+This specification was written with the participation of the
+members of the W3C HTML working group:
+
+
+Steven Pemberton, CWI (HTML Working Group Chair)
+
+
+
+
+
+This appendix is informative.
+
+
+
+[CSS2] "Cascading Style Sheets, level 2 (CSS2) Specification" , B.
+Bos, H. W. Lie, C. Lilley, I. Jacobs, 12 May 1998.
+http://www.w3.org/TR/REC-CSS2 [DOM] "Document Object Model (DOM) Level 1 Specification" , Lauren
+Wood et al. , 1 October 1998.
+http://www.w3.org/TR/REC-DOM-Level-1 [HTML] "HTML 4.01 Specification" , D. Raggett, A. Le Hors, I.
+Jacobs, 24 December 1999.
+http://www.w3.org/TR/html401 [POSIX.1] "ISO/IEC 9945-1:1990 Information Technology - Portable
+Operating System Interface (POSIX) - Part 1: System Application
+Program Interface (API) [C Language]", Institute of Electrical
+and Electronics Engineers, Inc, 1990.
+
+
+[RFC2046] "RFC2046: Multipurpose Internet Mail Extensions (MIME) Part
+Two: Media Types" , N. Freed and N. Borenstein, November
+1996.
+http://www.ietf.org/rfc/rfc2046.txt . Note that this RFC
+obsoletes RFC1521, RFC1522, and RFC1590.
+[RFC2119] "RFC2119: Key words for use in RFCs to Indicate Requirement
+Levels" , S. Bradner, March 1997.
+http://www.ietf.org/rfc/rfc2119.txt
+[RFC2376] "RFC2376: XML Media Types" , E. Whitehead, M. Murata, July
+1998.
+http://www.ietf.org/rfc/rfc2376.txt
+[RFC2396] "RFC2396: Uniform Resource Identifiers (URI): Generic
+Syntax" , T. Berners-Lee, R. Fielding, L. Masinter, August
+1998.
+http://www.ietf.org/rfc/rfc2396.txt [XML] "Extensible Markup Language (XML) 1.0 Specification" , T.
+Bray, J. Paoli, C. M. Sperberg-McQueen, 10 February 1998.
+http://www.w3.org/TR/REC-xml [XMLNAMES] "Namespaces in XML" , T. Bray, D. Hollander, A. Layman, 14
+January 1999.
+http://www.w3.org/TR/REC-xml-names
+
+
+
+
+
+
diff --git a/examples/xhtml/xhtml1-frameset.dtd b/examples/xhtml/xhtml1-frameset.dtd
new file mode 100644
--- /dev/null
+++ b/examples/xhtml/xhtml1-frameset.dtd
@@ -0,0 +1,1225 @@
+
+
+
+
+
+%HTMLlat1;
+
+
+%HTMLsymbol;
+
+
+%HTMLspecial;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/xhtml/xhtml1-strict.dtd b/examples/xhtml/xhtml1-strict.dtd
new file mode 100644
--- /dev/null
+++ b/examples/xhtml/xhtml1-strict.dtd
@@ -0,0 +1,988 @@
+
+
+
+
+
+%HTMLlat1;
+
+
+%HTMLsymbol;
+
+
+%HTMLspecial;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/xhtml/xhtml1-transitional.dtd b/examples/xhtml/xhtml1-transitional.dtd
new file mode 100644
--- /dev/null
+++ b/examples/xhtml/xhtml1-transitional.dtd
@@ -0,0 +1,1196 @@
+
+
+
+
+
+%HTMLlat1;
+
+
+%HTMLsymbol;
+
+
+%HTMLspecial;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/hxt.cabal b/hxt.cabal
--- a/hxt.cabal
+++ b/hxt.cabal
@@ -1,6 +1,6 @@
-- arch-tag: Haskell XML Toolbox main description file
Name: hxt
-Version: 9.0.1
+Version: 9.1.0
Synopsis: A collection of tools for processing XML with Haskell.
Description: The Haskell XML Toolbox bases on the ideas of HaXml and HXML,
but introduces a more general approach for processing XML with Haskell.
@@ -48,6 +48,7 @@
examples/arrows/HelloWorld/Mini.hs
examples/arrows/hparser/emptyElements.html
examples/arrows/hparser/example1.xml
+ examples/arrows/hparser/example1CRLF.xml
examples/arrows/hparser/HXmlParser.hs
examples/arrows/hparser/invalid1.xml
examples/arrows/hparser/invalid2.rng
@@ -63,6 +64,14 @@
examples/arrows/performance/Makefile
examples/arrows/pickle/Makefile
examples/arrows/pickle/PickleTest.hs
+ examples/xhtml/tmp.xml
+ examples/xhtml/xhtml1-frameset.dtd
+ examples/xhtml/xhtml1-strict.dtd
+ examples/xhtml/xhtml1-transitional.dtd
+ examples/xhtml/xhtml-lat1.ent
+ examples/xhtml/xhtml-special.ent
+ examples/xhtml/xhtml-symbol.ent
+ examples/xhtml/xhtml.xml
library
exposed-modules:
@@ -71,18 +80,25 @@
Control.Arrow.ArrowIf,
Control.Arrow.ArrowList,
Control.Arrow.ArrowNF,
+ Control.Arrow.ArrowNavigatableTree,
Control.Arrow.ArrowState,
Control.Arrow.ArrowTree,
Control.Arrow.IOListArrow,
Control.Arrow.IOStateListArrow,
Control.Arrow.ListArrow,
Control.Arrow.ListArrows,
+ Control.Arrow.NTreeEdit,
Control.Arrow.StateListArrow,
+ Control.FlatSeq,
Data.AssocList,
Data.Atom,
Data.Function.Selector,
Data.Tree.Class,
Data.Tree.NTree.TypeDefs,
+ Data.Tree.NTree.Edit,
+ Data.Tree.NTree.Zipper.TypeDefs,
+ Data.Tree.NavigatableTree.Class,
+ Data.Tree.NavigatableTree.XPathAxis,
Text.XML.HXT.Arrow.Binary,
Text.XML.HXT.Arrow.DTDProcessing,
Text.XML.HXT.Arrow.DocumentInput,
@@ -145,6 +161,7 @@
hs-source-dirs: src
ghc-options: -Wall
+ ghc-prof-options: -auto-all -caf-all
extensions: MultiParamTypeClasses DeriveDataTypeable FunctionalDependencies FlexibleInstances
@@ -159,6 +176,6 @@
deepseq >= 1.1 && < 2,
bytestring >= 0.9 && < 1,
binary >= 0.5 && < 1,
- hxt-charproperties >= 9 && < 10,
- hxt-unicode >= 9 && < 10,
- hxt-regex-xmlschema >= 9 && < 10
+ hxt-charproperties >= 9.1 && < 10,
+ hxt-unicode >= 9 && < 10,
+ hxt-regex-xmlschema >= 9 && < 10
diff --git a/src/Control/Arrow/ArrowExc.hs b/src/Control/Arrow/ArrowExc.hs
--- a/src/Control/Arrow/ArrowExc.hs
+++ b/src/Control/Arrow/ArrowExc.hs
@@ -31,8 +31,8 @@
catchA :: a b c -> a SomeException c -> a b c
catchA f h = tryA f
- >>>
- ( h ||| returnA )
+ >>>
+ ( h ||| returnA )
-- ------------------------------------------------------------
diff --git a/src/Control/Arrow/ArrowIO.hs b/src/Control/Arrow/ArrowIO.hs
--- a/src/Control/Arrow/ArrowIO.hs
+++ b/src/Control/Arrow/ArrowIO.hs
@@ -33,6 +33,7 @@
-- | construct an arrow from an IO action without any parameter
arrIO0 :: IO c -> a b c
arrIO0 f = arrIO (const f)
+ {-# INLINE arrIO0 #-}
-- | construction of a 2 argument arrow from a binary IO action
-- |
@@ -40,6 +41,7 @@
arrIO2 :: (b1 -> b2 -> IO c) -> a (b1, b2) c
arrIO2 f = arrIO (\ ~(x1, x2) -> f x1 x2)
+ {-# INLINE arrIO2 #-}
-- | construction of a 3 argument arrow from a 3-ary IO action
-- |
@@ -47,6 +49,7 @@
arrIO3 :: (b1 -> b2 -> b3 -> IO c) -> a (b1, (b2, b3)) c
arrIO3 f = arrIO (\ ~(x1, ~(x2, x3)) -> f x1 x2 x3)
+ {-# INLINE arrIO3 #-}
-- | construction of a 4 argument arrow from a 4-ary IO action
-- |
@@ -54,6 +57,7 @@
arrIO4 :: (b1 -> b2 -> b3 -> b4 -> IO c) -> a (b1, (b2, (b3, b4))) c
arrIO4 f = arrIO (\ ~(x1, ~(x2, ~(x3, x4))) -> f x1 x2 x3 x4)
+ {-# INLINE arrIO4 #-}
-- | the interface for converting an IO predicate into a list arrow
diff --git a/src/Control/Arrow/ArrowIf.hs b/src/Control/Arrow/ArrowIf.hs
--- a/src/Control/Arrow/ArrowIf.hs
+++ b/src/Control/Arrow/ArrowIf.hs
@@ -47,46 +47,55 @@
ifP :: (b -> Bool) -> a b d -> a b d -> a b d
ifP p = ifA (isA p)
+ {-# INLINE ifP #-}
-- | negation: @ neg f = ifA f none this @
neg :: a b c -> a b b
neg f = ifA f none this
+ {-# INLINE neg #-}
-- | @ f \`when\` g @ : when the predicate g holds, f is applied, else the identity filter this
when :: a b b -> a b c -> a b b
f `when` g = ifA g f this
+ {-# INLINE when #-}
-- | shortcut: @ f \`whenP\` p = f \`when\` (isA p) @
whenP :: a b b -> (b -> Bool) -> a b b
f `whenP` g = ifP g f this
+ {-# INLINE whenP #-}
-- | @ f \`whenNot\` g @ : when the predicate g does not hold, f is applied, else the identity filter this
whenNot :: a b b -> a b c -> a b b
f `whenNot` g = ifA g this f
+ {-# INLINE whenNot #-}
-- | like 'whenP'
whenNotP :: a b b -> (b -> Bool) -> a b b
f `whenNotP` g = ifP g this f
+ {-# INLINE whenNotP #-}
-- | @ g \`guards\` f @ : when the predicate g holds, f is applied, else none
guards :: a b c -> a b d -> a b d
f `guards` g = ifA f g none
+ {-# INLINE guards #-}
-- | like 'whenP'
guardsP :: (b -> Bool) -> a b d -> a b d
f `guardsP` g = ifP f g none
+ {-# INLINE guardsP #-}
-- | shortcut for @ f `guards` this @
filterA :: a b c -> a b b
filterA f = ifA f this none
+ {-# INLINE filterA #-}
-- | @ f \`containing\` g @ : keep only those results from f for which g holds
--
@@ -94,6 +103,7 @@
containing :: a b c -> a c d -> a b c
f `containing` g = f >>> g `guards` this
+ {-# INLINE containing #-}
-- | @ f \`notContaining\` g @ : keep only those results from f for which g does not hold
--
@@ -101,6 +111,7 @@
notContaining :: a b c -> a c d -> a b c
f `notContaining` g = f >>> ifA g none this
+ {-# INLINE notContaining #-}
-- | @ f \`orElse\` g @ : directional choice: if f succeeds, the result of f is the result, else g is applied
orElse :: a b c -> a b c -> a b c
diff --git a/src/Control/Arrow/ArrowList.hs b/src/Control/Arrow/ArrowList.hs
--- a/src/Control/Arrow/ArrowList.hs
+++ b/src/Control/Arrow/ArrowList.hs
@@ -39,7 +39,7 @@
-- | The interface for list arrows
--
--- Only 'mkA', 'arr2A', 'isA' '(>>.)' don't have default implementations
+-- Only 'mkA', 'isA' '(>>.)' don't have default implementations
class (Arrow a, ArrowPlus a, ArrowZero a, ArrowApply a) => ArrowList a where
@@ -49,6 +49,7 @@
arr2 :: (b1 -> b2 -> c) -> a (b1, b2) c
arr2 = arr . uncurry
+ {-# INLINE arr2 #-}
-- | construction of a 3 argument arrow from a 3-ary function
-- |
@@ -56,6 +57,7 @@
arr3 :: (b1 -> b2 -> b3 -> c) -> a (b1, (b2, b3)) c
arr3 f = arr (\ ~(x1, ~(x2, x3)) -> f x1 x2 x3)
+ {-# INLINE arr3 #-}
-- | construction of a 4 argument arrow from a 4-ary function
-- |
@@ -63,10 +65,13 @@
arr4 :: (b1 -> b2 -> b3 -> b4 -> c) -> a (b1, (b2, (b3, b4))) c
arr4 f = arr (\ ~(x1, ~(x2, ~(x3, x4))) -> f x1 x2 x3 x4)
+ {-# INLINE arr4 #-}
-- | construction of a 2 argument arrow from a singe argument arrow
arr2A :: (b -> a c d) -> a (b, c) d
+ arr2A f = first (arr f) >>> app
+ {-# INLINE arr2A #-}
-- | constructor for a list arrow from a function with a list as result
@@ -76,16 +81,19 @@
arr2L :: (b -> c -> [d]) -> a (b, c) d
arr2L = arrL . uncurry
+ {-# INLINE arr2L #-}
-- | constructor for a const arrow: @ constA = arr . const @
constA :: c -> a b c
constA = arr . const
+ {-# INLINE constA #-}
-- | constructor for a const arrow: @ constL = arrL . const @
constL :: [c] -> a b c
constL = arrL . const
+ {-# INLINE constL #-}
-- | builds an arrow from a predicate.
-- If the predicate holds, the single list containing the input is returned, else the empty list
@@ -104,6 +112,7 @@
(>.) :: a b c -> ([c] -> d ) -> a b d
af >. f = af >>. ((:[]) . f)
+ {-# INLINE (>.) #-}
-- | combinator for converting an arrow into a determinstic version with all results collected in a single element list
--
@@ -119,6 +128,7 @@
listA :: a b c -> a b [c]
listA af = af >>. (:[])
+ {-# INLINE listA #-}
-- | the inverse of 'listA'
--
@@ -128,16 +138,19 @@
unlistA :: a [b] b
unlistA = arrL id
+ {-# INLINE unlistA #-}
-- | the identity arrow, alias for returnA
this :: a b b
this = returnA
+ {-# INLINE this #-}
-- | the zero arrow, alias for zeroArrow
none :: a b c
none = zeroArrow
+ {-# INLINE none #-}
-- | converts an arrow, that may fail, into an arrow that always succeeds
--
@@ -145,6 +158,7 @@
withDefault :: a b c -> c -> a b c
withDefault a d = a >>. \ x -> if null x then [d] else x
+ {-# INLINE withDefault #-}
-- | makes a list arrow deterministic, the number of results is at most 1
--
@@ -327,6 +341,7 @@
perform :: a b c -> a b b
perform f = listA f &&& this >>> arr snd
+ {-# INLINE perform #-}
-- | generalization of arrow combinator '<+>'
--
@@ -334,6 +349,7 @@
catA :: [a b c] -> a b c
catA = foldl (<+>) none
+ {-# INLINE catA #-}
-- | generalization of arrow combinator '>>>'
--
@@ -341,5 +357,6 @@
seqA :: [a b b] -> a b b
seqA = foldl (>>>) this
+ {-# INLINE seqA #-}
-- ------------------------------------------------------------
diff --git a/src/Control/Arrow/ArrowNF.hs b/src/Control/Arrow/ArrowNF.hs
--- a/src/Control/Arrow/ArrowNF.hs
+++ b/src/Control/Arrow/ArrowNF.hs
@@ -2,7 +2,7 @@
{- |
Module : Control.Arrow.ArrowNF
- Copyright : Copyright (C) 2005-8 Uwe Schmidt
+ Copyright : Copyright (C) 2011 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
@@ -19,7 +19,10 @@
where
import Control.Arrow
+import Control.Arrow.ArrowList
+
import Control.DeepSeq
+import Control.FlatSeq
-- |
-- complete evaluation of an arrow result using 'Control.DeepSeq'
@@ -32,7 +35,27 @@
strictA = arr $ \ x -> deepseq x x
class (Arrow a) => ArrowNF a where
- rnfA :: (NFData c) => a b c -> a b c
- rnfA f = f >>> strictA
+ rnfA :: (NFData c) => a b c -> a b c
+ rnfA f = f >>^ (\ x -> deepseq x x)
+ {-# INLINE rnfA #-}
+
+-- |
+-- partial evaluation of an arrow result using 'Control.FlatSeq'
+--
+-- There are tow arrows with force the partial evaluation. By convention
+-- the 2. should be less lazy than the 1.
+--
+-- These arrows are sometimes useful for preventing space leaks, especially when parsing
+-- complex data structures. In many cases the evaluated AST is more space efficient
+-- than the unevaluaded with a lot of closures.
+
+class (Arrow a, ArrowList a) => ArrowWNF a where
+ rwnfA :: (WNFData c) => a b c -> a b c
+ rwnfA f = f >>. \ x -> rlnf rwnf x `seq` x
+ {-# INLINE rwnfA #-}
+
+ rwnf2A :: (WNFData c) => a b c -> a b c
+ rwnf2A f = f >>. \ x -> rlnf rwnf2 x `seq` x
+ {-# INLINE rwnf2A #-}
-- ------------------------------------------------------------
diff --git a/src/Control/Arrow/ArrowNavigatableTree.hs b/src/Control/Arrow/ArrowNavigatableTree.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Arrow/ArrowNavigatableTree.hs
@@ -0,0 +1,313 @@
+-- ------------------------------------------------------------
+
+{- |
+ Module : Control.Arrow.ArrowNavigatableTree
+ Copyright : Copyright (C) 2010 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ List arrows for navigatable trees
+
+ Trees that implement the "Data.Tree.NavigatableTree.Class" interface, can be processed
+ with these arrows.
+-}
+
+-- ------------------------------------------------------------
+
+module Control.Arrow.ArrowNavigatableTree
+where
+
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Arrow.ArrowIf
+
+import Data.Maybe
+
+import Data.Tree.NavigatableTree.Class ( NavigatableTree
+ , NavigatableTreeToTree
+ , NavigatableTreeModify
+ )
+import qualified Data.Tree.NavigatableTree.Class as T
+import qualified Data.Tree.NavigatableTree.XPathAxis as T
+
+-- ------------------------------------------------------------
+
+-- | The interface for navigatable tree arrows
+--
+-- all functions have default implementations
+
+class (ArrowList a) => ArrowNavigatableTree a where
+
+ -- move one step towards the root
+ moveUp :: NavigatableTree t => a (t b) (t b)
+ moveUp = arrL $ maybeToList . T.mvUp
+
+ -- descend one step to the leftmost child
+ moveDown :: NavigatableTree t => a (t b) (t b)
+ moveDown = arrL $ maybeToList . T.mvDown
+
+ -- move to the left neighbour
+ moveLeft :: NavigatableTree t => a (t b) (t b)
+ moveLeft = arrL $ maybeToList . T.mvLeft
+
+ -- move to the right neighbour
+ moveRight :: NavigatableTree t => a (t b) (t b)
+ moveRight = arrL $ maybeToList . T.mvRight
+
+-- derived functions
+
+parentAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+parentAxis = arrL T.parentAxis
+
+-- | XPath axis: ancestor
+
+ancestorAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+ancestorAxis = arrL T.ancestorAxis
+
+-- | XPath axis: ancestor or self
+
+ancestorOrSelfAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+ancestorOrSelfAxis = arrL T.ancestorOrSelfAxis
+
+-- | XPath axis: child
+
+childAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+childAxis = arrL T.childAxis
+
+-- | XPath axis: descendant
+
+descendantAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+descendantAxis = arrL T.descendantAxis
+
+-- | XPath axis: descendant or self
+
+descendantOrSelfAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+descendantOrSelfAxis = arrL T.descendantOrSelfAxis
+
+-- | not an XPath axis but useful: descendant or following
+
+descendantOrFollowingAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+descendantOrFollowingAxis = descendantAxis <+> followingAxis
+
+-- | not an official XPath axis but useful: reverse descendant or self, used in preceding axis
+
+revDescendantOrSelfAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+revDescendantOrSelfAxis = arrL T.revDescendantOrSelfAxis
+
+-- | XPath axis: following sibling
+
+followingSiblingAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+followingSiblingAxis = arrL T.followingSiblingAxis
+
+-- | XPath axis: preceeding sibling
+
+precedingSiblingAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+precedingSiblingAxis = arrL T.precedingSiblingAxis
+
+-- | XPath axis: self
+
+selfAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+selfAxis = arrL T.selfAxis
+
+-- | XPath axis: following
+
+followingAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+followingAxis = arrL T.followingAxis
+
+-- | XPath axis: preceding
+
+precedingAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+precedingAxis = arrL T.precedingAxis
+
+-- ------------------------------------------------------------
+
+-- | move to the root
+
+moveToRoot :: (Arrow a, NavigatableTree t) => a (t b) (t b)
+moveToRoot = arr T.mvToRoot
+
+isAtRoot :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
+isAtRoot = isA (null . T.ancestorAxis)
+
+-- ------------------------------------------------------------
+
+-- | Conversion from a tree into a navigatable tree
+
+addNav :: ( ArrowList a
+ , NavigatableTreeToTree nt t
+ ) =>
+ a (t b) (nt b)
+addNav = arr T.fromTree
+
+
+-- | Conversion from a navigatable tree into an ordinary tree
+
+remNav :: ( ArrowList a
+ , NavigatableTreeToTree nt t
+ ) =>
+ a (nt b) (t b)
+remNav = arr T.toTree
+
+-- | apply an operation using navigation to an ordinary tree
+--
+-- This root and all children may be visited in arbitrary order
+
+withNav :: ( ArrowList a
+ , NavigatableTreeToTree nt t
+ ) =>
+ a (nt b) (nt c) -> a (t b) (t c)
+withNav f = addNav >>> f >>> remNav
+
+
+-- | apply a simple operation without use of navigation to a navigatable tree
+--
+-- This enables to apply arbitrary tree operations to navigatable trees
+
+withoutNav :: ( ArrowList a
+ , NavigatableTreeToTree nt t
+ , NavigatableTreeModify nt t
+ ) =>
+ a (t b) (t b) -> a (nt b) (nt b)
+withoutNav f = ( (remNav >>> f) -- apply the simple arrow to the tree
+ &&&
+ this -- remember the navigation context
+ )
+ >>> arr (uncurry T.substThisTree) -- resore the context
+
+-- ------------------------------------------------------------
+
+-- | Filter an axis with an ordinary tree predicate
+--
+-- Example: In a tree of Ints find all nodes in the subtrees (in preorder) that have label 42
+--
+-- > descendantAxis >>> filterAxis (hasNode (== 42))
+--
+-- Example: In an XML Tree find the following nodes of a node with attribute id and value 42
+--
+-- > descendantAxis >>> filterAxis (hasAttrValue "id" (=="42")) >>> followingAxis
+
+filterAxis :: ( ArrowIf a
+ , NavigatableTreeToTree nt t
+ ) =>
+ a (t b) c -> a (nt b) (nt b)
+
+filterAxis p = (remNav >>> p) `guards` this
+{-# INLINE filterAxis #-}
+
+
+-- | Move to the next tree on a given axis. Deterministic arrow
+--
+-- Example: Move to the next node in a preorder visit: next child or else next following
+--
+-- > moveOn descendantOrFollowingAxis
+
+moveOn :: ( ArrowList a
+ , NavigatableTree t
+ ) =>
+ a (t b) (t b) -> a (t b) (t b)
+moveOn axis = single $ axis
+{-# INLINE moveOn #-}
+
+-- ------------------------------------------------------------
+
+-- | Change the current subtree of a navigatable tree.
+--
+-- The arrow for computing the changes should be deterministic. If it fails
+-- nothing is changed.
+
+changeThisTree :: ( ArrowList a
+ , ArrowIf a
+ , NavigatableTreeToTree nt t
+ , NavigatableTreeModify nt t
+ ) =>
+ a (t b) (t b) -> a (nt b) (nt b)
+changeThisTree cf = withoutNav $ single cf `orElse` this
+
+-- | Substitute the current subtree of a navigatable tree by a given tree
+
+substThisTree :: ( ArrowList a
+ , ArrowIf a
+ , NavigatableTreeToTree nt t
+ , NavigatableTreeModify nt t
+ ) =>
+ t b -> a (nt b) (nt b)
+substThisTree t = changeThisTree (constA t)
+
+-- ------------------------------------------------------------
+
+-- | apply an ordinary arrow to the current subtree of a navigatabe tree and add the result trees in front of the current tree.
+--
+-- If this arrow is applied to the root, it will fail, because we want a tree as result, not a forest.
+
+addToTheLeft :: ( ArrowList a
+ , NavigatableTreeToTree nt t
+ , NavigatableTreeModify nt t
+ ) =>
+ a (t b) (t b) -> a (nt b) (nt b)
+addToTheLeft = addToOneSide $
+ foldl (\ acc t -> acc >>= T.addTreeLeft t)
+{-# INLINE addToTheLeft #-}
+
+-- | apply an ordinary arrow to the current subtree of a navigatabe tree and add the result trees behind the current tree.
+--
+-- If this arrow is applied to the root, it will fail, because we want a tree as result, not a forest.
+
+addToTheRight :: ( ArrowList a
+ , NavigatableTreeToTree nt t
+ , NavigatableTreeModify nt t
+ ) =>
+ a (t b) (t b) -> a (nt b) (nt b)
+addToTheRight = addToOneSide $
+ foldr (\ t acc -> acc >>= T.addTreeRight t)
+{-# INLINE addToTheRight #-}
+
+
+-- | addToOneSide does the real work for 'addToTheLeft' and 'addToTheRight'
+
+addToOneSide :: ( ArrowList a
+ , NavigatableTreeToTree nt t
+ , NavigatableTreeModify nt t
+ ) =>
+ ( Maybe (nt b) -> [t b] -> Maybe (nt b) ) ->
+ a (t b) (t b) ->
+ a (nt b) (nt b)
+addToOneSide side f = ( ( remNav >>> listA f )
+ &&&
+ this
+ )
+ >>>
+ arrL ( uncurry (\ ts nt -> side (Just nt) ts)
+ >>>
+ maybeToList
+ )
+
+-- ------------------------------------------------------------
+
+-- | drop the direct left sibling tree of the given navigatable tree
+--
+-- If this arrow is applied to the root or a leftmost tree, it will fail, because there is nothing to remove
+
+dropFromTheLeft :: ( ArrowList a
+ -- , NavigatableTreeToTree nt t
+ , NavigatableTreeModify nt t
+ ) =>
+ a (nt b) (nt b)
+dropFromTheLeft = arrL $ T.dropTreeLeft >>> maybeToList
+{-# INLINE dropFromTheLeft #-}
+
+-- | drop the direct left sibling tree of the given navigatable tree
+--
+-- If this arrow is applied to the root or a rightmost tree, it will fail, because there is nothing to remove
+
+dropFromTheRight :: ( ArrowList a
+ , NavigatableTreeModify nt t
+ ) =>
+ a (nt b) (nt b)
+dropFromTheRight = arrL $ T.dropTreeRight >>> maybeToList
+{-# INLINE dropFromTheRight #-}
+
+-- ------------------------------------------------------------
+
diff --git a/src/Control/Arrow/ArrowState.hs b/src/Control/Arrow/ArrowState.hs
--- a/src/Control/Arrow/ArrowState.hs
+++ b/src/Control/Arrow/ArrowState.hs
@@ -50,12 +50,14 @@
getState :: a b s
getState = accessState (\ s _x -> s)
+ {-# INLINE getState #-}
-- | overwrite the old state
--
-- definition: @ setState = changeState (\\ s x -> x) @
setState :: a s s
setState = changeState (\ _s x -> x) -- changeState (const id)
+ {-# INLINE setState #-}
-- | change state (and ignore input) and return new state
--
diff --git a/src/Control/Arrow/ArrowTree.hs b/src/Control/Arrow/ArrowTree.hs
--- a/src/Control/Arrow/ArrowTree.hs
+++ b/src/Control/Arrow/ArrowTree.hs
@@ -44,41 +44,55 @@
mkLeaf :: Tree t => b -> a c (t b)
mkLeaf = constA . T.mkLeaf
+ {-# INLINE mkLeaf #-}
-- | construct an inner node
mkTree :: Tree t => b -> [t b] -> a c (t b)
mkTree n = constA . T.mkTree n
+ {-# INLINE mkTree #-}
-- | select the children of the root of a tree
getChildren :: Tree t => a (t b) (t b)
getChildren = arrL T.getChildren
+ {-# INLINE getChildren #-}
- -- | select the attribute of the root of a tree
+ -- | select the node info of the root of a tree
getNode :: Tree t => a (t b) b
getNode = arr T.getNode
+ {-# INLINE getNode #-}
+ -- | select the attribute of the root of a tree
+
+ hasNode :: Tree t => (b -> Bool) -> a (t b) (t b)
+ hasNode p = (getNode >>> isA p) `guards` this
+ {-# INLINE hasNode #-}
+
-- | substitute the children of the root of a tree
setChildren :: Tree t => [t b] -> a (t b) (t b)
setChildren cs = arr (T.setChildren cs)
+ {-# INLINE setChildren #-}
-- | substitute the attribute of the root of a tree
setNode :: Tree t => b -> a (t b) (t b)
setNode n = arr (T.setNode n)
+ {-# INLINE setNode #-}
-- | edit the children of the root of a tree
changeChildren :: Tree t => ([t b] -> [t b]) -> a (t b) (t b)
changeChildren csf = arr (T.changeChildren csf)
+ {-# INLINE changeChildren #-}
-- | edit the attribute of the root of a tree
changeNode :: Tree t => (b -> b) -> a (t b) (t b)
changeNode nf = arr (T.changeNode nf)
+ {-# INLINE changeNode #-}
-- compound arrows
@@ -122,6 +136,7 @@
(/>) :: Tree t => a b (t c) -> a (t c) d -> a b d
f /> g = f >>> getChildren >>> g
+ {-# INLINE (/>) #-}
-- |
-- pronounced \"double slash\", meaning g arbitrarily deep inside f
@@ -138,6 +153,7 @@
(//>) :: Tree t => a b (t c) -> a (t c) d -> a b d
f //> g = f >>> getChildren >>> deep g
+ {-# INLINE (//>) #-}
-- |
@@ -147,6 +163,7 @@
( a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)
f >> g)
+ {-# INLINE ( do
- res <- try' $ runIOLA f x
- return $ case res of
- Left er -> [Left er]
- Right ys -> [Right x' | x' <- ys]
- where
- try' :: IO a -> IO (Either SomeException a)
- try' = try
+ tryA f = IOLA $ \ x -> do
+ res <- try' $ runIOLA f x
+ return $
+ case res of
+ Left er -> [Left er]
+ Right ys -> [Right x' | x' <- ys]
+ where
+ try' :: IO a -> IO (Either SomeException a)
+ try' = try
instance ArrowIOIf IOLA where
isIOA p = IOLA $ \x -> do
@@ -138,9 +140,14 @@
instance ArrowTree IOLA
+instance ArrowNavigatableTree IOLA
+
instance ArrowNF IOLA where
rnfA (IOLA f) = IOLA $ \ x -> do
res <- f x
deepseq res $ return res
+
+
+instance ArrowWNF IOLA
-- ------------------------------------------------------------
diff --git a/src/Control/Arrow/IOStateListArrow.hs b/src/Control/Arrow/IOStateListArrow.hs
--- a/src/Control/Arrow/IOStateListArrow.hs
+++ b/src/Control/Arrow/IOStateListArrow.hs
@@ -35,6 +35,7 @@
import Control.Arrow.ArrowList
import Control.Arrow.ArrowNF
import Control.Arrow.ArrowTree
+import Control.Arrow.ArrowNavigatableTree
import Control.Arrow.ArrowState
import Control.DeepSeq
@@ -50,6 +51,7 @@
instance Category (IOSLA s) where
id = IOSLA $ \ s x -> return (s, [x]) -- don't defined id = arr id, this gives loops during optimization
+ {-# INLINE id #-}
IOSLA g . IOSLA f = IOSLA $ \ s x -> do
(s1, ys) <- f s x
@@ -63,6 +65,7 @@
instance Arrow (IOSLA s) where
arr f = IOSLA $ \ s x -> return (s, [f x])
+ {-# INLINE arr #-}
first (IOSLA f) = IOSLA $ \ s (x1, x2) -> do
(s', ys1) <- f s x1
@@ -89,6 +92,7 @@
instance ArrowZero (IOSLA s) where
zeroArrow = IOSLA $ \ s -> const (return (s, []))
+ {-# INLINE zeroArrow #-}
instance ArrowPlus (IOSLA s) where
@@ -114,19 +118,27 @@
instance ArrowApply (IOSLA s) where
app = IOSLA $ \ s (IOSLA f, x) -> f s x
+ {-# INLINE app #-}
instance ArrowList (IOSLA s) where
arrL f = IOSLA $ \ s x -> return (s, (f x))
+ {-# INLINE arrL #-}
arr2A f = IOSLA $ \ s (x, y) -> runIOSLA (f x) s y
+ {-# INLINE arr2A #-}
constA c = IOSLA $ \ s -> const (return (s, [c]))
+ {-# INLINE constA #-}
isA p = IOSLA $ \ s x -> return (s, if p x then [x] else [])
+ {-# INLINE isA #-}
IOSLA f >>. g = IOSLA $ \ s x -> do
(s1, ys) <- f s x
return (s1, g ys)
+ {-# INLINE (>>.) #-}
+
-- just for efficency
perform (IOSLA f) = IOSLA $ \ s x -> do
(s1, _ys) <- f s x
return (s1, [x])
+ {-# INLINE perform #-}
instance ArrowIf (IOSLA s) where
ifA (IOSLA p) ta ea = IOSLA $ \ s x -> do
@@ -148,6 +160,7 @@
arrIO cmd = IOSLA $ \ s x -> do
res <- cmd x
return (s, [res])
+ {-# INLINE arrIO #-}
instance ArrowExc (IOSLA s) where
tryA f = IOSLA $ \ s x -> do
@@ -163,10 +176,13 @@
isIOA p = IOSLA $ \ s x -> do
res <- p x
return (s, if res then [x] else [])
+ {-# INLINE isIOA #-}
instance ArrowState s (IOSLA s) where
changeState cf = IOSLA $ \ s x -> let s' = cf s x in return (seq s' s', [x])
+ {-# INLINE changeState #-}
accessState af = IOSLA $ \ s x -> return (s, [af s x])
+ {-# INLINE accessState #-}
-- ------------------------------------------------------------
@@ -200,9 +216,13 @@
instance ArrowTree (IOSLA s)
+instance ArrowNavigatableTree (IOSLA s)
+
instance (NFData s) => ArrowNF (IOSLA s) where
rnfA (IOSLA f) = IOSLA $ \ s x -> do
res <- f s x
deepseq res $ return res
+
+instance ArrowWNF (IOSLA s)
-- ------------------------------------------------------------
diff --git a/src/Control/Arrow/ListArrow.hs b/src/Control/Arrow/ListArrow.hs
--- a/src/Control/Arrow/ListArrow.hs
+++ b/src/Control/Arrow/ListArrow.hs
@@ -30,6 +30,7 @@
import Control.Arrow.ArrowList
import Control.Arrow.ArrowNF
import Control.Arrow.ArrowTree
+import Control.Arrow.ArrowNavigatableTree
import Control.DeepSeq
@@ -43,10 +44,13 @@
instance Category LA where
id = LA $ (:[])
+ {-# INLINE id #-}
LA g . LA f = LA $ concatMap g . f
+ {-# INLINE (.) #-}
instance Arrow LA where
arr f = LA $ \ x -> [f x]
+ {-# INLINE arr #-}
first (LA f) = LA $ \ ~(x1, x2) -> [ (y1, x2) | y1 <- f x1 ]
-- just for efficiency
@@ -57,11 +61,12 @@
instance ArrowZero LA where
zeroArrow = LA $ const []
+ {-# INLINE zeroArrow #-}
instance ArrowPlus LA where
LA f <+> LA g = LA $ \ x -> f x ++ g x
-
+ {-# INLINE (<+>) #-}
instance ArrowChoice LA where
left (LA f) = LA $ either (map Left . f) ((:[]) . Right)
@@ -72,20 +77,25 @@
instance ArrowApply LA where
app = LA $ \ (LA f, x) -> f x
+ {-# INLINE app #-}
instance ArrowList LA where
- arrL = LA
+ arrL = LA
+ {-# INLINE arrL #-}
arr2A f = LA $ \ ~(x, y) -> runLA (f x) y
+ {-# INLINE arr2A #-}
isA p = LA $ \ x -> if p x then [x] else []
+ {-# INLINE isA #-}
LA f >>. g = LA $ g . f
+ {-# INLINE (>>.) #-}
withDefault a d = a >>. \ x -> if null x then [d] else x
-
instance ArrowIf LA where
ifA (LA p) t e = LA $ \ x -> runLA ( if null (p x)
then e
else t
) x
+ {-# INLINE ifA #-}
(LA f) `orElse` (LA g)
= LA $ \ x -> ( let
@@ -95,6 +105,7 @@
then g x
else res
)
+ {-# INLINE orElse #-}
spanA p = LA $ (:[]) . span (not . null . runLA p)
@@ -102,11 +113,15 @@
instance ArrowTree LA
+instance ArrowNavigatableTree LA
+
instance ArrowNF LA where
rnfA (LA f) = LA $ \ x -> let res = f x
in
deepseq res res
+instance ArrowWNF LA
+
-- ------------------------------------------------------------
-- | conversion of pure list arrows into other possibly more complex
@@ -114,6 +129,7 @@
fromLA :: ArrowList a => LA b c -> a b c
fromLA f = arrL (runLA f)
+{-# INLINE fromLA #-}
-- ------------------------------------------------------------
diff --git a/src/Control/Arrow/ListArrows.hs b/src/Control/Arrow/ListArrows.hs
--- a/src/Control/Arrow/ListArrows.hs
+++ b/src/Control/Arrow/ListArrows.hs
@@ -21,6 +21,7 @@
, module Control.Arrow.ArrowIf
, module Control.Arrow.ArrowIO
, module Control.Arrow.ArrowList
+ , module Control.Arrow.ArrowNavigatableTree
, module Control.Arrow.ArrowNF
, module Control.Arrow.ArrowState
, module Control.Arrow.ArrowTree
@@ -29,6 +30,8 @@
, module Control.Arrow.StateListArrow
, module Control.Arrow.IOListArrow
, module Control.Arrow.IOStateListArrow
+
+ , module Control.Arrow.NTreeEdit -- extra arrows
)
where
@@ -36,6 +39,7 @@
import Control.Arrow.ArrowExc
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf
+import Control.Arrow.ArrowNavigatableTree
import Control.Arrow.ArrowNF
import Control.Arrow.ArrowState
import Control.Arrow.ArrowTree
@@ -45,5 +49,7 @@
import Control.Arrow.StateListArrow
import Control.Arrow.IOListArrow
import Control.Arrow.IOStateListArrow
+
+import Control.Arrow.NTreeEdit -- extra arrows
-- ------------------------------------------------------------
diff --git a/src/Control/Arrow/NTreeEdit.hs b/src/Control/Arrow/NTreeEdit.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Arrow/NTreeEdit.hs
@@ -0,0 +1,46 @@
+-- ------------------------------------------------------------
+
+{- |
+ Module : Control.Arrow.NTreeEdit
+ Copyright : Copyright (C) 2011 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ arrows for efficient editing of rose trees
+
+-}
+
+-- ------------------------------------------------------------
+
+module Control.Arrow.NTreeEdit
+where
+
+import Control.Arrow
+import Control.Arrow.ArrowIf
+import Control.Arrow.ArrowList
+import Control.Arrow.ListArrow
+
+import Data.Maybe
+import Data.Tree.NTree.TypeDefs
+import Data.Tree.NTree.Edit
+
+-- ------------------------------------------------------------
+
+-- | Edit parts of a rose tree
+--
+-- The subtrees to be modified are selected by the first part of the IfThen pairs
+-- The modification by the second part
+
+editNTreeA :: [IfThen (LA (NTree b) c) (LA (NTree b) (NTree b))] ->
+ LA (NTree b) (NTree b)
+editNTreeA cs = arrL $ editNTreeBottomUp ef
+ where
+ ef = listToMaybe . (runLA . foldr (\ (g :-> h) -> ifA g (listA h)) none $ cs)
+
+fmapNTreeA :: (b -> Maybe b) -> LA (NTree b) (NTree b)
+fmapNTreeA f = arr $ mapNTree' f
+
+-- eof ------------------------------------------------------------
diff --git a/src/Control/Arrow/StateListArrow.hs b/src/Control/Arrow/StateListArrow.hs
--- a/src/Control/Arrow/StateListArrow.hs
+++ b/src/Control/Arrow/StateListArrow.hs
@@ -4,7 +4,7 @@
{- |
Module : Control.Arrow.StateListArrow
- Copyright : Copyright (C) 2005-8 Uwe Schmidt
+ Copyright : Copyright (C) 2010 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
@@ -33,6 +33,7 @@
import Control.Arrow.ArrowNF
import Control.Arrow.ArrowState
import Control.Arrow.ArrowTree
+import Control.Arrow.ArrowNavigatableTree
import Control.DeepSeq
@@ -44,6 +45,7 @@
instance Category (SLA s) where
id = SLA $ \ s x -> (s, [x])
+ {-# INLINE id #-}
SLA g . SLA f = SLA $ \ s x -> let
~(s1, ys) = f s x
@@ -60,6 +62,7 @@
instance Arrow (SLA s) where
arr f = SLA $ \ s x -> (s, [f x])
+ {-# INLINE arr #-}
first (SLA f) = SLA $ \ s ~(x1, x2) -> let
~(s', ys1) = f s x1
@@ -89,6 +92,7 @@
instance ArrowZero (SLA s) where
zeroArrow = SLA $ \ s -> const (s, [])
+ {-# INLINE zeroArrow #-}
instance ArrowPlus (SLA s) where
@@ -118,22 +122,29 @@
instance ArrowApply (SLA s) where
app = SLA $ \ s (SLA f, x) -> f s x
+ {-# INLINE app #-}
instance ArrowList (SLA s) where
arrL f = SLA $ \ s x -> (s, (f x))
+ {-# INLINE arrL #-}
arr2A f = SLA $ \ s ~(x, y) -> runSLA (f x) s y
+ {-# INLINE arr2A #-}
constA c = SLA $ \ s -> const (s, [c])
+ {-# INLINE constA #-}
isA p = SLA $ \ s x -> (s, if p x then [x] else [])
+ {-# INLINE isA #-}
SLA f >>. g = SLA $ \ s x -> let
~(s1, ys) = f s x
in
(s1, g ys)
+ {-# INLINE (>>.) #-}
-- just for efficency
perform (SLA f) = SLA $ \ s x -> let
~(s1, _ys) = f s x
in
(s1, [x])
+ {-# INLINE perform #-}
instance ArrowIf (SLA s) where
ifA (SLA p) ta ea = SLA $ \ s x -> let
@@ -155,15 +166,21 @@
instance ArrowState s (SLA s) where
changeState cf = SLA $ \ s x -> (cf s x, [x])
+ {-# INLINE changeState #-}
accessState af = SLA $ \ s x -> (s, [af s x])
+ {-# INLINE accessState #-}
instance ArrowTree (SLA s)
+instance ArrowNavigatableTree (SLA s)
+
instance (NFData s) => ArrowNF (SLA s) where
rnfA (SLA f) = SLA $ \ s x -> let res = f s x
in
deepseq res res
+instance ArrowWNF (SLA s)
+
-- ------------------------------------------------------------
-- | conversion of state list arrows into arbitray other
@@ -180,6 +197,7 @@
fromSLA :: ArrowList a => s -> SLA s b c -> a b c
fromSLA s f = arrL (snd . (runSLA f s))
+{-# INLINE fromSLA #-}
-- ------------------------------------------------------------
diff --git a/src/Control/FlatSeq.hs b/src/Control/FlatSeq.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/FlatSeq.hs
@@ -0,0 +1,90 @@
+-- ------------------------------------------------------------
+
+{- |
+ Module : Control.FlatSeq
+ Copyright : Copyright (C) 2011 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ Force evaluation like deepseq in Control.DeepSeq,
+ but control the depth of evaluation.
+ flatseq may evaluate more than seq but less than deepseq
+
+-}
+
+-- ------------------------------------------------------------
+
+module Control.FlatSeq
+where
+
+import Data.Word
+
+-- ------------------------------------------------------------
+
+infixr 0 $!!
+
+($!!) :: WNFData a => (a -> b) -> a -> b
+f $!! x = rwnf x `seq` f x
+{-# INLINE ($!!) #-}
+
+flatseq :: WNFData a => a -> b -> b
+flatseq a b = rwnf a `seq` b
+{-# INLINE flatseq #-}
+
+rlnf :: (a -> ()) -> [a] -> ()
+rlnf _ [] = ()
+rlnf r (x:xs) = r x `seq` rlnf r xs
+{-# INLINE rlnf #-}
+
+-- | A class of types that can be partially evaluated, but evaluation can be propagated deeper than WHNF
+
+class WNFData a where
+ -- | Default for rwnf is reduction to WHNF
+ rwnf :: a -> ()
+ rwnf a = a `seq` ()
+ {-# INLINE rwnf #-}
+
+ -- | Default for rwnf2 is rwnf
+ rwnf2 :: a -> ()
+ rwnf2 = rwnf
+ {-# INLINE rwnf2 #-}
+
+instance WNFData Int
+instance WNFData Integer
+instance WNFData Float
+instance WNFData Double
+
+instance WNFData Char
+instance WNFData Bool
+instance WNFData ()
+
+instance WNFData Word
+instance WNFData Word8
+instance WNFData Word16
+instance WNFData Word32
+instance WNFData Word64
+
+instance WNFData a => WNFData [a] where
+ rwnf [] = ()
+ rwnf (x:xs) = x `seq` rwnf xs
+ {-# INLINE rwnf #-}
+
+instance (WNFData a, WNFData b) => WNFData (a,b) where
+ rwnf (x,y) = rwnf x `seq` rwnf y
+ {-# INLINE rwnf #-}
+
+instance (WNFData a, WNFData b, WNFData c) => WNFData (a,b,c) where
+ rwnf (x,y,z) = rwnf x `seq` rwnf y `seq` rwnf z
+ {-# INLINE rwnf #-}
+
+instance (WNFData a, WNFData b, WNFData c, WNFData d) => WNFData (a,b,c,d) where
+ rwnf (x1,x2,x3,x4) = rwnf x1 `seq`
+ rwnf x2 `seq`
+ rwnf x3 `seq`
+ rwnf x4
+ {-# INLINE rwnf #-}
+
+-- ------------------------------------------------------------
diff --git a/src/Data/Function/Selector.hs b/src/Data/Function/Selector.hs
--- a/src/Data/Function/Selector.hs
+++ b/src/Data/Function/Selector.hs
@@ -3,7 +3,7 @@
module Data.Function.Selector
where
-import Prelude hiding (id,(.))
+import Prelude hiding (id,(.))
import Control.Arrow
import Control.Category
@@ -16,44 +16,44 @@
-- for reading and updating parts of a composite type
data Selector s a = S { getS :: s -> a
- , setS :: a -> s -> s
- }
+ , setS :: a -> s -> s
+ }
-chgS :: Selector s a -> (a -> a) -> (s -> s)
-chgS sel f s = setS sel x s
- where
- x = f . getS sel $ s
+chgS :: Selector s a -> (a -> a) -> (s -> s)
+chgS sel f s = setS sel x s
+ where
+ x = f . getS sel $ s
-chgM :: (Monad m) => Selector s a -> (a -> m a) -> (s -> m s)
-chgM sel f s = do
- y <- f x
- return $ setS sel y s
- where
- x = getS sel $ s
+chgM :: (Monad m) => Selector s a -> (a -> m a) -> (s -> m s)
+chgM sel f s = do
+ y <- f x
+ return $ setS sel y s
+ where
+ x = getS sel $ s
-- | Alias for constructor S
-mkSelector :: (s -> a) -> (a -> s -> s) -> Selector s a
-mkSelector = S
+mkSelector :: (s -> a) -> (a -> s -> s) -> Selector s a
+mkSelector = S
-- (.), (>>>), (<<<)
instance Category Selector where
- id = S { getS = id
- , setS = const
- }
- (S g2 s2) . (S g1 s1) = S { getS = g2 . g1
- , setS = \ x s ->
- let x1 = g1 s in
- let x1' = s2 x x1 in
- s1 x1' s
- }
+ id = S { getS = id
+ , setS = const
+ }
+ (S g2 s2) . (S g1 s1) = S { getS = g2 . g1
+ , setS = \ x s ->
+ let x1 = g1 s in
+ let x1' = s2 x x1 in
+ s1 x1' s
+ }
-idS :: Selector s s
-idS = id
+idS :: Selector s s
+idS = id
-(.&&&.) :: Selector s a -> Selector s b -> Selector s (a, b)
-(.&&&.) (S g1 s1) (S g2 s2) = S { getS = g1 &&& g2
+(.&&&.) :: Selector s a -> Selector s b -> Selector s (a, b)
+(.&&&.) (S g1 s1) (S g2 s2) = S { getS = g1 &&& g2
, setS = \ (x, y) -> s2 y . s1 x
}
@@ -110,30 +110,30 @@
-- | Selectors for pairs and 3-tuples: comp1, comp2, comp3,
-- this can be extended to n-tuples
-class Comp1 s a | s -> a where comp1 :: Selector s a
-class Comp2 s a | s -> a where comp2 :: Selector s a
-class Comp3 s a | s -> a where comp3 :: Selector s a
+class Comp1 s a | s -> a where comp1 :: Selector s a
+class Comp2 s a | s -> a where comp2 :: Selector s a
+class Comp3 s a | s -> a where comp3 :: Selector s a
-instance Comp1 (a, b) a where comp1 = S { getS = fst
- , setS = \ x1 (_, x2) -> (x1, x2)
- }
+instance Comp1 (a, b) a where comp1 = S { getS = fst
+ , setS = \ x1 (_, x2) -> (x1, x2)
+ }
-instance Comp2 (a, b) b where comp2 = S { getS = snd
- , setS = \ x2 (x1, _) -> (x1, x2)
- }
+instance Comp2 (a, b) b where comp2 = S { getS = snd
+ , setS = \ x2 (x1, _) -> (x1, x2)
+ }
-instance Comp1 (a, b, c) a where comp1 = S { getS = \ (x1, _, _) -> x1
- , setS = \ x1 (_, x2, x3) -> (x1, x2, x3)
- }
+instance Comp1 (a, b, c) a where comp1 = S { getS = \ (x1, _, _) -> x1
+ , setS = \ x1 (_, x2, x3) -> (x1, x2, x3)
+ }
-instance Comp2 (a, b, c) b where comp2 = S { getS = \ (_, x2, _) -> x2
- , setS = \ x2 (x1, _, x3) -> (x1, x2, x3)
- }
+instance Comp2 (a, b, c) b where comp2 = S { getS = \ (_, x2, _) -> x2
+ , setS = \ x2 (x1, _, x3) -> (x1, x2, x3)
+ }
-instance Comp3 (a, b, c) c where comp3 = S { getS = \ (_, _, x3) -> x3
- , setS = \ x3 (x1, x2, _) -> (x1, x2, x3)
- }
+instance Comp3 (a, b, c) c where comp3 = S { getS = \ (_, _, x3) -> x3
+ , setS = \ x3 (x1, x2, _) -> (x1, x2, x3)
+ }
-- ------------------------------------------------------------
diff --git a/src/Data/Tree/Class.hs b/src/Data/Tree/Class.hs
--- a/src/Data/Tree/Class.hs
+++ b/src/Data/Tree/Class.hs
@@ -30,16 +30,19 @@
mkLeaf :: a -> t a
mkLeaf n = mkTree n []
+ {-# INLINE mkLeaf #-}
-- | leaf test: list of children empty?
isLeaf :: t a -> Bool
isLeaf = null . getChildren
+ {-# INLINE isLeaf #-}
-- | innner node test: @ not . isLeaf @
isInner :: t a -> Bool
isInner = not . isLeaf
+ {-# INLINE isInner #-}
-- | select node attribute
@@ -61,11 +64,13 @@
setNode :: a -> t a -> t a
setNode n = changeNode (const n)
+ {-# INLINE setNode #-}
-- | substitute children: @ setChildren cl = changeChildren (const cl) @
setChildren :: [t a] -> t a -> t a
setChildren cl = changeChildren (const cl)
+ {-# INLINE setChildren #-}
-- | fold for trees
@@ -74,19 +79,61 @@
-- | all nodes of a tree
nodesTree :: t a -> [a]
+ nodesTree = foldTree (\ n rs -> n : concat rs)
+ {-# INLINE nodesTree #-}
-- | depth of a tree
depthTree :: t a -> Int
+ depthTree = foldTree (\ _ rs -> 1 + maximum (0 : rs))
-- | number of nodes in a tree
cardTree :: t a -> Int
+ cardTree = foldTree (\ _ rs -> 1 + sum rs)
-- | format tree for readable trace output
--
-- a /graphical/ representation of the tree in text format
formatTree :: (a -> String) -> t a -> String
+ formatTree nf n = formatNTree' nf (showString "---") (showString " ") n ""
-- ------------------------------------------------------------
+-- |
+-- convert a tree into a pseudo graphical string representation
+
+formatNTree' :: Tree t => (a -> String) -> (String -> String) -> (String -> String) -> t a -> String -> String
+
+formatNTree' node2String pf1 pf2 tree
+ = formatNode
+ . formatChildren pf2 l
+ where
+ n = getNode tree
+ l = getChildren tree
+ formatNode = pf1 . foldr (.) id (map trNL (node2String n)) . showNL
+ trNL '\n' = showNL . pf2
+ trNL c = showChar c
+ showNL = showChar '\n'
+ formatChildren _ []
+ = id
+ formatChildren pf (t:ts)
+ | null ts
+ = pfl'
+ . formatTr pf2' t
+ | otherwise
+ = pfl'
+ . formatTr pf1' t
+ . formatChildren pf ts
+ where
+ pf0' = pf . showString indent1
+ pf1' = pf . showString indent2
+ pf2' = pf . showString indent3
+ pfl' = pf . showString indent4
+ formatTr = formatNTree' node2String pf0'
+ indent1 = "+---"
+ indent2 = "| "
+ indent3 = " "
+ indent4 = "|\n"
+
+-- eof ------------------------------------------------------------
diff --git a/src/Data/Tree/NTree/Edit.hs b/src/Data/Tree/NTree/Edit.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Tree/NTree/Edit.hs
@@ -0,0 +1,98 @@
+-- ------------------------------------------------------------
+
+{- |
+ Module :
+ Copyright : Copyright (C) 2011 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ Space and time efficient editing of rose trees
+-}
+
+-- ------------------------------------------------------------
+
+module Data.Tree.NTree.Edit
+where
+
+import Data.Maybe
+
+import Data.Tree.NTree.TypeDefs
+
+-- import Debug.Trace
+
+
+-- | editNTreeBottomUp is a space optimized tree edit function
+--
+-- The nodes in a tree are visited bottom up. An edit function is applied to
+-- all nodes. A Nothing result of the editing function indicates no changes.
+-- This is used to share the input tree within the resulting tree.
+--
+-- The following law holds:
+--
+-- > editNTreeBottomUp (const Nothing) t == [t]
+--
+-- In this case the resulting tree does not only represent the same value
+-- but it is the same machine value (relative to some evaluations of closures
+-- during the tree walk
+--
+-- With a simple fold like editing function the whole tree would be reconstructed
+-- in memory
+
+editNTreeBottomUp :: (NTree a -> Maybe [NTree a]) -> NTree a -> [NTree a]
+editNTreeBottomUp f t0 = maybe [t0] id . editNTreeBU $ t0
+ where
+
+ -- editNTreeBU :: NTree a -> Maybe [NTree a]
+ editNTreeBU t@(NTree n cs)
+ | isNothing r'
+ &&
+ isJust cl' = Just [t'] -- children have been change but not the node itself
+ | otherwise = r' -- nothing has been changes or node has been changed
+ where
+ cl' = editNTreesBU cs -- the edited children
+ t' = case cl' of -- the node to be processed with f
+ Nothing -> t -- possibly with the new children (bottom up)
+ Just cs' -> NTree n cs'
+ r' = f t' -- the edited result
+
+ -- editNTreesBU :: [NTree a] -> Maybe [NTree a]
+ editNTreesBU [] = Nothing
+ editNTreesBU (t : ts) = mergeRes
+ (editNTreeBU t )
+ (editNTreesBU ts)
+ where
+ mergeRes r' = case r' of
+ Nothing -> maybe Nothing (Just . (t :))
+ Just ts' -> Just . (ts' ++) . fromMaybe ts
+
+
+-- | A space optimized map for NTrees
+--
+-- Subtrees, that are not changed are reused in the resulting tree
+-- See also: editNTreeBottomUp
+
+mapNTree' :: (a -> Maybe a) -> NTree a -> NTree a
+mapNTree' f t0 = maybe t0 id . map' $ t0
+ where
+
+ -- map' :: NTree a -> Maybe (NTree a)
+ map' (NTree n cs) = mergeRes (f n) (maps' cs)
+ where
+ mergeRes Nothing Nothing = Nothing
+ mergeRes Nothing (Just cs') = Just (NTree n cs')
+ mergeRes (Just n') cl = Just (NTree n' (fromMaybe cs cl))
+
+ -- maps' :: [NTree a] -> Maybe [NTree a]
+ maps' [] = Nothing
+ maps' (t : ts) = mergeRes
+ (map' t )
+ (maps' ts)
+ where
+ mergeRes r' = case r' of
+ Nothing -> maybe Nothing (Just . (t :))
+ Just t' -> Just . (t' :) . fromMaybe ts
+
+-- eof ------------------------------------------------------------
diff --git a/src/Data/Tree/NTree/TypeDefs.hs b/src/Data/Tree/NTree/TypeDefs.hs
--- a/src/Data/Tree/NTree/TypeDefs.hs
+++ b/src/Data/Tree/NTree/TypeDefs.hs
@@ -4,11 +4,11 @@
{- |
Module : Data.Tree.NTree.TypeDefs
- Copyright : Copyright (C) 2005-2008 Uwe Schmidt
+ Copyright : Copyright (C) 2005-2010 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
- Stability : experimental
+ Stability : stable
Portability: portable
Interface definition for trees
@@ -20,17 +20,17 @@
-- ------------------------------------------------------------
module Data.Tree.NTree.TypeDefs
- ( module Data.Tree.Class
- , module Data.Tree.NTree.TypeDefs
- )
where
import Control.DeepSeq
+import Control.FlatSeq
import Data.Binary
import Data.Tree.Class
import Data.Typeable
+-- ------------------------------------------------------------
+
-- | n-ary ordered tree (rose trees)
--
-- a tree consists of a node and a possible empty list of children.
@@ -51,7 +51,18 @@
instance (NFData a) => NFData (NTree a) where
rnf (NTree n cl) = rnf n `seq` rnf cl
+ {-# INLINE rnf #-}
+instance (WNFData a) => WNFData (NTree a) where
+ rwnf (NTree n cl) = rwnf n `seq` rwnf cl
+ {-# INLINE rwnf #-}
+
+ -- | Evaluate a tree 2 steps deep, the top node and all children are evaluated with rwnf
+ rwnf2 (NTree n cl) = rwnf n `seq` rlnf rwnf cl
+ {-# INLINE rwnf2 #-}
+
+-- ------------------------------------------------------------
+
instance (Binary a) => Binary (NTree a) where
put (NTree n cs) = put n >> put cs
get = do
@@ -59,63 +70,33 @@
cs <- get
return (NTree n cs)
+-- ------------------------------------------------------------
+
-- | NTree implements class Functor
instance Functor NTree where
fmap f ~(NTree n cl) = NTree (f n) (map (fmap f) cl)
+ {-# INLINE fmap #-}
+-- ------------------------------------------------------------
-- | Implementation of "Data.Tree.Class" interface for rose trees
instance Tree NTree where
mkTree n cl = NTree n cl
+ {-# INLINE mkTree #-}
getNode ~(NTree n _ ) = n
+ {-# INLINE getNode #-}
getChildren ~(NTree _ cl) = cl
+ {-# INLINE getChildren #-}
changeNode cf ~(NTree n cl) = NTree (cf n) cl
+ {-# INLINE changeNode #-}
changeChildren cf ~(NTree n cl) = NTree n (cf cl)
+ {-# INLINE changeChildren #-}
foldTree f ~(NTree n cs) = f n (map (foldTree f) cs)
-
- nodesTree = foldTree (\ n rs -> n : concat rs)
- depthTree = foldTree (\ _ rs -> 1 + maximum (0 : rs))
- cardTree = foldTree (\ _ rs -> 1 + sum rs)
- formatTree nf n = formatNTreeF nf (showString "---") (showString " ") n ""
-
--- ------------------------------------------------------------
--- |
--- convert a tree into a pseudo graphical string reprsentation
-
-formatNTreeF :: (node -> String) -> (String -> String) -> (String -> String) -> NTree node -> String -> String
-
-formatNTreeF node2String pf1 pf2 (NTree n l)
- = formatNode
- . formatChildren pf2 l
- where
- formatNode = pf1 . foldr (.) id (map trNL (node2String n)) . showNL
- trNL '\n' = showNL . pf2
- trNL c = showChar c
- showNL = showChar '\n'
- formatChildren _ []
- = id
- formatChildren pf (t:ts)
- | null ts
- = pfl'
- . formatTr pf2' t
- | otherwise
- = pfl'
- . formatTr pf1' t
- . formatChildren pf ts
- where
- pf0' = pf . showString indent1
- pf1' = pf . showString indent2
- pf2' = pf . showString indent3
- pfl' = pf . showString indent4
- formatTr = formatNTreeF node2String pf0'
- indent1 = "+---"
- indent2 = "| "
- indent3 = " "
- indent4 = "|\n"
+ {-# INLINE foldTree #-}
-- eof ------------------------------------------------------------
diff --git a/src/Data/Tree/NTree/Zipper/TypeDefs.hs b/src/Data/Tree/NTree/Zipper/TypeDefs.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Tree/NTree/Zipper/TypeDefs.hs
@@ -0,0 +1,240 @@
+{-# OPTIONS -fno-warn-orphans #-}
+
+-- ------------------------------------------------------------
+
+{- |
+ Module : Data.Tree.NTree.Zipper.TypeDefs
+ Copyright : Copyright (C) 2010 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : stable
+ Portability: portable
+
+ Implementation of navigateble trees for
+ rose trees. The implementation is done with zippers.
+ A description and introductory tutorial about zippers
+ can be found in
+-}
+
+-- ------------------------------------------------------------
+
+module Data.Tree.NTree.Zipper.TypeDefs
+{-
+ ( NTZipper
+ , NTree
+ , toNTZipper
+ , fromNTZipper
+ )
+-}
+where
+
+import Data.Tree.Class
+
+import Data.Tree.NavigatableTree.Class
+import Data.Tree.NavigatableTree.XPathAxis ( childAxis )
+
+import Data.Tree.NTree.TypeDefs
+
+-- ------------------------------------------------------------
+
+-- | Zipper for rose trees
+--
+-- A zipper consist of the current tree and the branches on the way back to the root
+
+data NTZipper a = NTZ
+ { ntree :: (NTree a)
+ , context :: (NTBreadCrumbs a)
+ }
+ deriving (Show)
+
+-- | The list of unzipped nodes from a current tree back to the root
+
+type NTBreadCrumbs a = [NTCrumb a]
+
+-- | One unzipped step consists of the left siblings, the node info and the right siblings
+
+data NTCrumb a = NTC
+ (NTrees a) -- left side
+ a -- node
+ (NTrees a) -- right side
+ deriving (Show)
+
+-- ------------------------------------------------------------
+
+-- | Conversion of a rose tree into a navigatable rose tree
+
+toNTZipper :: NTree a -> NTZipper a
+toNTZipper t = NTZ t []
+
+{-# INLINE toNTZipper #-}
+
+-- | Conversion of a navigatable rose tree into an ordinary rose tree.
+--
+-- The context, the parts for moving up to the root are just removed from the tree.
+-- So when transforming a navigatable tree by moving around and by changing some nodes,
+-- one has to navigate back
+-- to the root, else that parts are removed from the result
+
+fromNTZipper :: NTZipper a -> NTree a
+fromNTZipper = ntree
+
+{-# INLINE fromNTZipper #-}
+
+-- ------------------------------------------------------------
+
+up :: NTZipper a -> Maybe (NTZipper a)
+up z
+ | isTop z = Nothing
+ | otherwise = Just $ NTZ (up1 t bc) bcs
+ where
+ NTZ t (bc : bcs) = z
+
+{-# INLINE up #-}
+
+down :: NTZipper a -> Maybe (NTZipper a)
+down (NTZ (NTree n cs) bcs)
+ | null cs = Nothing
+ | otherwise = Just $ NTZ (head cs) (NTC [] n (tail cs) : bcs)
+
+{-# INLINE down #-}
+
+toTheRight :: NTZipper a -> Maybe (NTZipper a)
+toTheRight z
+ | isTop z
+ ||
+ null rs = Nothing
+ | otherwise = Just $ NTZ t' (bc' : bcs)
+ where
+ (NTZ t (bc : bcs)) = z
+ (NTC ls n rs) = bc
+ t' = head rs
+ bc' = NTC (t : ls) n (tail rs)
+
+{-# INLINE toTheRight #-}
+
+toTheLeft :: NTZipper a -> Maybe (NTZipper a)
+toTheLeft z
+ | isTop z
+ ||
+ null ls = Nothing
+ | otherwise = Just $ NTZ t' (bc' : bcs)
+ where
+ (NTZ t (bc : bcs)) = z
+ (NTC ls n rs) = bc
+ t' = head ls
+ bc' = NTC (tail ls) n (t : rs)
+
+{-# INLINE toTheLeft #-}
+
+addToTheLeft :: NTree a -> NTZipper a -> Maybe (NTZipper a)
+addToTheLeft t z
+ | isTop z = Nothing
+ | otherwise = Just $ NTZ t' (NTC (t:ls) n rs : bcs)
+ where
+ (NTZ t' (bc : bcs)) = z
+ (NTC ls n rs) = bc
+{-# INLINE addToTheLeft #-}
+
+addToTheRight :: NTree a -> NTZipper a -> Maybe (NTZipper a)
+addToTheRight t z
+ | isTop z = Nothing
+ | otherwise = Just $ NTZ t' (NTC ls n (t:rs) : bcs)
+ where
+ (NTZ t' (bc : bcs)) = z
+ (NTC ls n rs) = bc
+{-# INLINE addToTheRight #-}
+
+dropFromTheLeft :: NTZipper a -> Maybe (NTZipper a)
+dropFromTheLeft z
+ | isTop z = Nothing
+ | null ls = Nothing
+ | otherwise = Just $ NTZ t' (NTC (tail ls) n rs : bcs)
+ where
+ (NTZ t' (bc : bcs)) = z
+ (NTC ls n rs) = bc
+{-# INLINE dropFromTheLeft #-}
+
+dropFromTheRight :: NTZipper a -> Maybe (NTZipper a)
+dropFromTheRight z
+ | isTop z = Nothing
+ | null rs = Nothing
+ | otherwise = Just $ NTZ t' (NTC ls n (tail rs) : bcs)
+ where
+ (NTZ t' (bc : bcs)) = z
+ (NTC ls n rs) = bc
+{-# INLINE dropFromTheRight #-}
+
+-- ------------------------------------------------------------
+
+isTop :: NTZipper a -> Bool
+isTop = null . context
+
+{-# INLINE isTop #-}
+
+up1 :: NTree a -> NTCrumb a -> NTree a
+up1 t (NTC ls n rs) = NTree n (foldl (flip (:)) (t : rs) ls)
+
+{-# INLINE up1 #-}
+
+-- ------------------------------------------------------------
+
+instance Functor NTZipper where
+ fmap f (NTZ t xs) = NTZ (fmap f t) (map (fmap f) xs)
+ {-# INLINE fmap #-}
+
+instance Functor NTCrumb where
+ fmap f (NTC xs x ys)= NTC (map (fmap f) xs) (f x) (map (fmap f) ys)
+ {-# INLINE fmap #-}
+
+instance Tree NTZipper where
+ mkTree n cl = toNTZipper . mkTree n $ map ntree cl
+
+ getNode = getNode . ntree
+ {-# INLINE getNode #-}
+ getChildren = childAxis
+ {-# INLINE getChildren #-}
+
+ changeNode cf t = t { ntree = changeNode cf (ntree t) }
+ changeChildren cf t = t { ntree = setChildren (map ntree . cf . childAxis $ t) (ntree t) }
+
+ foldTree f = foldTree f . ntree
+ {-# INLINE foldTree #-}
+
+instance NavigatableTree NTZipper where
+ mvDown = down
+ {-# INLINE mvDown #-}
+
+ mvUp = up
+ {-# INLINE mvUp #-}
+
+ mvLeft = toTheLeft
+ {-# INLINE mvLeft #-}
+
+ mvRight = toTheRight
+ {-# INLINE mvRight #-}
+
+instance NavigatableTreeToTree NTZipper NTree where
+ fromTree = toNTZipper
+ {-# INLINE fromTree #-}
+
+ toTree = fromNTZipper
+ {-# INLINE toTree #-}
+
+instance NavigatableTreeModify NTZipper NTree where
+ addTreeLeft = addToTheLeft
+ {-# INLINE addTreeLeft #-}
+
+ addTreeRight = addToTheRight
+ {-# INLINE addTreeRight #-}
+
+ dropTreeLeft = dropFromTheLeft
+ {-# INLINE dropTreeLeft #-}
+
+ dropTreeRight = dropFromTheRight
+ {-# INLINE dropTreeRight #-}
+
+ substThisTree t nt = nt { ntree = t }
+ {-# INLINE substThisTree #-}
+
+-- ------------------------------------------------------------
diff --git a/src/Data/Tree/NavigatableTree/Class.hs b/src/Data/Tree/NavigatableTree/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Tree/NavigatableTree/Class.hs
@@ -0,0 +1,77 @@
+-- ------------------------------------------------------------
+
+{- |
+ Module : Data.Tree.NavigatableTree.Class
+ Copyright : Copyright (C) 2010 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ Interface definition for navigatable trees.
+ Navigatable trees need to have operations to move up, down, left and right.
+ With these elementary operations, most of the XPath axises can be defined.
+-}
+
+-- ------------------------------------------------------------
+
+module Data.Tree.NavigatableTree.Class
+where
+
+-- ------------------------------------------------------------
+
+-- | The interface for navigatable trees
+
+class NavigatableTree t where
+ -- | move one step towards the root
+ mvUp :: t a -> Maybe (t a)
+
+ -- | descend one step to the leftmost child
+ mvDown :: t a -> Maybe (t a)
+
+ -- | move to the left neighbour
+ mvLeft :: t a -> Maybe (t a)
+
+ -- | move to the right neighbour
+ mvRight :: t a -> Maybe (t a)
+
+-- ------------------------------------------------------------
+
+-- | Conversion between trees and navigatable trees,
+--
+-- There is only a single navigatable tree implementation for a given tree allowed
+-- (see the functional dependencies)
+
+class NavigatableTreeToTree nt t | t -> nt, nt -> t where
+ -- | construct a navigatable tree
+ fromTree :: t a -> nt a
+
+ -- | remove navigation
+ toTree :: nt a -> t a
+
+-- ------------------------------------------------------------
+
+-- | Edit operation on navigatable trees
+--
+-- There is only a single navigatable tree implementation for a given tree allowed
+-- (see the functional dependencies)
+
+class NavigatableTreeModify nt t | t -> nt, nt -> t where
+
+ -- | add an ordinary tree in front of the given navigatable tree
+ addTreeLeft :: t a -> nt a -> Maybe (nt a)
+
+ -- | add an ordinary tree behind of the given navigatable tree
+ addTreeRight :: t a -> nt a -> Maybe (nt a)
+
+ -- | drop the direct left sibling tree of the given navigatable tree
+ dropTreeLeft :: nt a -> Maybe (nt a)
+
+ -- | drop the direct right sibling tree of the given navigatable tree
+ dropTreeRight :: nt a -> Maybe (nt a)
+
+ -- | change the tree but remain the navigation
+ substThisTree :: t a -> nt a -> nt a
+
+-- ------------------------------------------------------------
diff --git a/src/Data/Tree/NavigatableTree/XPathAxis.hs b/src/Data/Tree/NavigatableTree/XPathAxis.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Tree/NavigatableTree/XPathAxis.hs
@@ -0,0 +1,128 @@
+-- ------------------------------------------------------------
+
+{- |
+ Module : Data.Tree.NavigatableTree.XPathAxis
+ Copyright : Copyright (C) 2010 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ Navigatable trees need to have operations to move up, down, left and right.
+ With these elementary operations, the XPath axises can be defined.
+-}
+
+-- ------------------------------------------------------------
+
+module Data.Tree.NavigatableTree.XPathAxis
+where
+
+import Data.Maybe ( maybeToList )
+import Data.Tree.NavigatableTree.Class
+
+import Control.Arrow ( (>>>) )
+import Control.Monad ( (>=>) )
+
+-- ------------------------------------------------------------
+--
+-- mothers little helpers
+
+-- | collect all trees by moving into one direction, starting tree is included
+
+maybeStar :: (a -> Maybe a) -> (a -> [a])
+maybeStar f x = x : maybe [] (maybeStar f) (f x)
+
+-- | collect all trees by moving into one direction, starting tree is not included
+
+maybePlus :: (a -> Maybe a) -> (a -> [a])
+maybePlus f x = maybe [] (maybeStar f) (f x)
+
+{-# INLINE maybePlus #-}
+
+-- ------------------------------------------------------------
+-- XPath axis
+
+-- | XPath axis: parent
+
+parentAxis :: NavigatableTree t => t a -> [t a]
+parentAxis = maybeToList . mvUp
+{-# INLINE parentAxis #-}
+
+-- | XPath axis: ancestor
+
+ancestorAxis :: NavigatableTree t => t a -> [t a]
+ancestorAxis = maybePlus mvUp
+{-# INLINE ancestorAxis #-}
+
+-- | XPath axis: ancestor or self
+
+ancestorOrSelfAxis :: NavigatableTree t => t a -> [t a]
+ancestorOrSelfAxis = maybeStar mvUp
+{-# INLINE ancestorOrSelfAxis #-}
+
+-- | XPath axis: child
+
+childAxis :: NavigatableTree t => t a -> [t a]
+childAxis = (mvDown >>> maybeToList) >=> maybeStar mvRight
+{-# INLINE childAxis #-}
+
+-- | XPath axis: descendant
+
+descendantAxis :: NavigatableTree t => t a -> [t a]
+descendantAxis = descendantOrSelfAxis >>> tail
+{-# INLINE descendantAxis #-}
+
+-- | XPath axis: descendant or self
+
+descendantOrSelfAxis :: NavigatableTree t => t a -> [t a]
+descendantOrSelfAxis = visit []
+ where
+ visit k t = t : maybe k (visit' k) (mvDown t)
+ visit' k t = visit (maybe k (visit' k) (mvRight t)) t
+
+-- | not an official XPath axis but useful: reverse descendant or self, used in preceding axis
+
+revDescendantOrSelfAxis :: NavigatableTree t => t a -> [t a]
+revDescendantOrSelfAxis t
+ = t : concatMap revDescendantOrSelfAxis (reverse $ childAxis t)
+
+-- | XPath axis: following sibling
+
+followingSiblingAxis :: NavigatableTree t => t a -> [t a]
+followingSiblingAxis = maybePlus mvRight
+{-# INLINE followingSiblingAxis #-}
+
+-- | XPath axis: preceeding sibling
+
+precedingSiblingAxis :: NavigatableTree t => t a -> [t a]
+precedingSiblingAxis = maybePlus mvLeft
+{-# INLINE precedingSiblingAxis #-}
+
+-- | XPath axis: self
+
+selfAxis :: NavigatableTree t => t a -> [t a]
+selfAxis = (:[])
+{-# INLINE selfAxis #-}
+
+-- | XPath axis: following
+
+followingAxis :: NavigatableTree t => t a -> [t a]
+followingAxis = ancestorOrSelfAxis >=> followingSiblingAxis >=> descendantOrSelfAxis
+
+-- | XPath axis: preceding
+
+precedingAxis :: NavigatableTree t => t a -> [t a]
+precedingAxis = ancestorOrSelfAxis >=> precedingSiblingAxis >=> revDescendantOrSelfAxis
+
+-- | move to the root
+
+mvToRoot :: NavigatableTree t => t a -> t a
+mvToRoot = ancestorOrSelfAxis >>> last
+{-# INLINE mvToRoot #-}
+
+isAtRoot :: NavigatableTree t => t a -> Bool
+isAtRoot = null . ancestorAxis
+{-# INLINE isAtRoot #-}
+
+-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Arrow/DTDProcessing.hs b/src/Text/XML/HXT/Arrow/DTDProcessing.hs
--- a/src/Text/XML/HXT/Arrow/DTDProcessing.hs
+++ b/src/Text/XML/HXT/Arrow/DTDProcessing.hs
@@ -128,25 +128,14 @@
>>>
setSysAttrString a_standalone ""
>>>
- ( addDocType
- `whenNot`
- ( getChildren >>> isDTDDoctype )
- )
- >>>
processChildren substParamEntities
>>>
setDocumentStatusFromSystemState "in XML DTD processing"
+ >>>
+ traceMsg 1 ("processDTD: parameter entities processed")
)
`when`
documentStatusOk
- where
- addDocType
- = replaceChildren ( (getChildren >>> isXmlPi)
- <+>
- mkDTDDoctype [] none
- <+>
- (getChildren >>> neg isXmlPi)
- )
substParamEntities :: IOStateArrow s XmlTree XmlTree
substParamEntities
@@ -214,8 +203,10 @@
>>>
parseXmlDTDdecl
>>>
- substRefsInEntityValue
+ substPeRefsInEntityValue
>>>
+ traceDTD "ENTITY declaration after PE substitution"
+ >>>
processEntityDecl
>>>
traceDTD "ENTITY declaration after DTD declaration parsing"
@@ -259,17 +250,24 @@
processExternalEntity -- only the current base uri must be remembered
= setDTDAttrValue a_url $< ( getDTDAttrValue k_system >>> mkAbsURI )
- processInternalEntity :: DTDStateArrow XmlTree XmlTree -- just combine all parts of the entity value
- processInternalEntity -- into one string
- = replaceChildren (xshow getChildren >>> mkText)
+ processInternalEntity :: DTDStateArrow XmlTree XmlTree
+ processInternalEntity
+ = this -- everything is already done in substPeRefsInEntityValue
processParamEntity :: String -> DTDStateArrow XmlTree XmlTree
processParamEntity peName
= ifA (constA peName >>> getPeValue)
- ( issueWarn ("parameter entity " ++ show peName ++ " already defined") )
+ ( issueWarn ("parameter entity " ++ show peName ++ " already defined")
+ >>>
+ none -- second def must be ignored
+ )
( ( ifA ( hasDTDAttr k_system ) -- is external param entity ?
- ( runInLocalURIContext getExternalParamEntityValue )
- ( replaceChildren (xshow getChildren >>> mkText) ) -- just combine all parts of the entity value into one string
+ ( setDTDAttrValue a_url $< -- store absolut url
+ ( getDTDAttrValue k_system >>> mkAbsURI )
+ )
+ -- this is too early, pe may be not referenced and file may be not there
+ -- ( runInLocalURIContext getExternalParamEntityValue )
+ ( this ) -- everything is already done in substPeRefsInEntityValue
)
>>>
addPe peName
@@ -278,32 +276,50 @@
substPERef :: String -> DTDStateArrow XmlTree XmlTree
substPERef pn
= choiceA
- [ isInternalRef :-> issueErr ("a parameter entity reference of " ++ show pn ++ " occurs in the internal subset of the DTD")
- , isUndefinedRef :-> issueErr ("parameter entity " ++ show pn ++ " not found (forward reference?)")
+ [ isUndefinedRef :-> issueErr ("parameter entity " ++ show pn ++ " not found (forward reference?)")
+ , isInternalRef :-> issueErr ("a parameter entity reference of " ++ show pn ++ " occurs in the internal subset of the DTD")
+ , isUnreadExternalRef :-> ( perform
+ ( peVal -- load the external pe value
+ >>> -- update the pe env
+ getExternalParamEntityValue pn -- and try again
+ >>>
+ addPe pn
+ )
+ >>>
+ substPERef pn
+ )
, this :-> substPE
]
`when`
isDTDPERef
where
- isInternalRef = isA (const (loc == Internal))
- peVal = constA pn >>> getPeValue
+ peVal = constA pn >>> getPeValue
+
+ isUnreadExternalRef = ( peVal
+ >>>
+ getDTDAttrValue a_url
+ >>>
+ isA (not . null)
+ )
+ `guards`
+ this
+
+ isInternalRef = none -- isA (const (loc == Internal)) -- TODO: check this restriction, it seams rather meaningless
isUndefinedRef = neg peVal
- substPE
- = replaceChildren (peVal >>> getChildren) -- store PE value in children component
- >>>
- ( ( setBase $< (peVal >>> getDTDAttrValue a_url) ) -- store base uri for external refs
- `orElse`
- this
- )
- where
- setBase uri = setDTDAttrValue a_url uri
+ substPE = replaceChildren (peVal >>> getChildren) -- store PE value in children component
- substRefsInEntityValue :: DTDStateArrow XmlTree XmlTree
- substRefsInEntityValue
- = ( ( processChildren ( transfCharRef
- >>>
- substPeRefsInValue []
- )
+ substPeRefsInEntityValue :: DTDStateArrow XmlTree XmlTree
+ substPeRefsInEntityValue
+ = ( ( replaceChildren
+ ( xshow ( getChildren -- substitute char entites
+ >>> -- and parameter references
+ transfCharRef -- combine all pieces to a single string
+ >>> -- as the new entity value
+ substPeRefsInValue []
+ )
+ >>>
+ mkText
+ )
)
`whenNot`
hasDTDAttr k_system -- only apply for internal entities
@@ -365,8 +381,8 @@
>>>
parseXmlDTDEntityValue
>>>
- transfCharRef
- >>>
+ -- transfCharRef this must be done somewhere else
+ -- >>>
substPeRefsInValue (pn : recl)
substPeRefsInCondSect :: RecList -> DTDStateArrow XmlTree XmlTree
@@ -473,36 +489,30 @@
>>>
getChildren
-getExternalParamEntityValue :: DTDStateArrow XmlTree XmlTree
-getExternalParamEntityValue
+getExternalParamEntityValue :: String -> DTDStateArrow XmlTree XmlTree
+getExternalParamEntityValue pn
= isDTDPEntity
`guards`
- ( setEntityValue $<<< ( getDTDAttrl
- &&&
- listA ( getEntityValue $< getDTDAttrl )
- &&&
- getBaseURI
- )
- )
+ ( setEntityValue $< ( listA ( getEntityValue $< getDTDAttrValue a_url ) ) )
where
- getEntityValue :: Attributes -> DTDStateArrow XmlTree XmlTree
- getEntityValue al
- = root [sattr a_source (lookup1 k_system al){- <+> catA (map (uncurry sattr) al)-}] []
+ getEntityValue :: String -> DTDStateArrow XmlTree XmlTree
+ getEntityValue url
+ = root [sattr a_source url] []
>>>
- getXmlEntityContents
+ runInLocalURIContext getXmlEntityContents
>>>
- traceMsg 2 "getExternalParamEntityValue: contents read"
+ traceMsg 2 ("getExternalParamEntityValue: contents read for " ++ show pn ++ " from " ++ show url)
>>>
getChildren
- setEntityValue :: Attributes -> XmlTrees -> String -> DTDStateArrow XmlTree XmlTree
- setEntityValue al res base
+ setEntityValue :: XmlTrees -> DTDStateArrow XmlTree XmlTree
+ setEntityValue res
| null res
- = issueErr ("illegal external parameter entity value for entity %" ++ peName ++";")
+ = issueErr ("illegal external parameter entity value for entity %" ++ pn ++";")
| otherwise
- = mkDTDElem PENTITY ((a_url, base) : al) (arrL $ const res)
- where
- peName = lookup1 a_name al
+ = replaceChildren (constL res)
+ >>>
+ setDTDAttrValue a_url "" -- mark entity as read
traceDTD :: String -> DTDStateArrow XmlTree XmlTree
traceDTD msg = traceMsg 3 msg >>> traceTree
diff --git a/src/Text/XML/HXT/Arrow/DocumentInput.hs b/src/Text/XML/HXT/Arrow/DocumentInput.hs
--- a/src/Text/XML/HXT/Arrow/DocumentInput.hs
+++ b/src/Text/XML/HXT/Arrow/DocumentInput.hs
@@ -129,7 +129,7 @@
>>>
( arr (uncurry addInputError) -- io error occured
|||
- arr addTxtContent -- content read
+ arr addTxtContent -- content read
)
)
@@ -159,9 +159,9 @@
uriToMime mtt
= arr $ ( \ uri -> extensionToMimeType (drop 1 . takeExtension $ uri) mtt )
-addTxtContent :: String -> IOStateArrow s XmlTree XmlTree
-addTxtContent c
- = replaceChildren (txt c)
+addTxtContent :: Blob -> IOStateArrow s XmlTree XmlTree
+addTxtContent bc
+ = replaceChildren (blb bc)
>>>
addAttr transferMessage "OK"
>>>
@@ -260,11 +260,23 @@
getXmlEntityContents :: IOStateArrow s XmlTree XmlTree
getXmlEntityContents
- = getXmlContents' parseXmlEntityEncodingSpec
+ = traceMsg 2 "getXmlEntityContents"
>>>
- processChildren removeEncodingSpec
+ addAttr transferMimeType text_xml_external_parsed_entity -- the default transfer mimetype
>>>
+ getXmlContents' parseXmlEntityEncodingSpec
+ >>>
+ addAttr transferMimeType text_xml_external_parsed_entity
+ >>>
+ processChildren
+ ( removeEncodingSpec
+ >>>
+ changeText normalizeNL -- newline normalization must be done here
+ ) -- the following calls of the parsers don't do this
+ >>>
setBaseURIFromDoc
+ >>>
+ traceMsg 2 "getXmlEntityContents done"
getXmlContents' :: IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree
getXmlContents' parseEncodingSpec
@@ -286,9 +298,7 @@
traceValue 1 (("getXmlContents: content read and decoded for " ++) . show)
)
>>>
- traceTree
- >>>
- traceSource
+ traceDoc "getXmlContents'"
)
`when`
isRoot
@@ -334,13 +344,21 @@
decodeDocument :: IOStateArrow s XmlTree XmlTree
decodeDocument
= choiceA
- [ ( isRoot >>> isXmlHtmlDoc ) :-> ( decodeArr normalizeNL $< getEncoding )
- , ( isRoot >>> isTextDoc ) :-> ( decodeArr id $< getTextEncoding )
+ [ ( isRoot >>> isXmlHtmlDoc ) :-> ( decodeX $< getSysVar theExpat)
+ , ( isRoot >>> isTextDoc ) :-> ( decodeArr $< getTextEncoding )
, this :-> this
]
where
- decodeArr :: (String -> String) -> String -> IOStateArrow s XmlTree XmlTree
- decodeArr normalizeNewline enc
+ decodeX :: Bool -> IOStateArrow s XmlTree XmlTree
+ decodeX False = decodeArr $< getEncoding
+ decodeX True = noDecode $< getEncoding -- parse with expat
+
+ noDecode enc = traceMsg 2 ("no decoding (done by expat): encoding is " ++ show enc)
+ >>>
+ addAttr transferEncoding enc
+
+ decodeArr :: String -> IOStateArrow s XmlTree XmlTree
+ decodeArr enc
= maybe notFound found . getDecodingFct $ enc
where
found df
@@ -355,13 +373,17 @@
>>>
setDocumentStatusFromSystemState "decoding document"
+{- just for performance test
+ decodeText _ _ = this
+-}
decodeText df withEncErrors
= processChildren
( getText -- get the document content
+ -- the following 3 lines
+ -- don't seem to raise the space problem in decodeText
+ -- space is allocated in blobToString and in parsec
>>> arr df -- decode the text, result is (string, [errMsg])
- >>> ( ( (fst >>> normalizeNewline) -- take decoded string, normalize newline and build text node
- ^>> mkText
- )
+ >>> ( ( fst ^>> mkText ) -- take decoded string and build text node
<+>
( if withEncErrors
then
diff --git a/src/Text/XML/HXT/Arrow/DocumentOutput.hs b/src/Text/XML/HXT/Arrow/DocumentOutput.hs
--- a/src/Text/XML/HXT/Arrow/DocumentOutput.hs
+++ b/src/Text/XML/HXT/Arrow/DocumentOutput.hs
@@ -31,9 +31,14 @@
import Control.Arrow.ArrowIO
import Control.Arrow.ListArrow
-import Data.String.Unicode ( getOutputEncodingFct )
+import qualified
+ Data.ByteString.Lazy as BS
+import Data.Maybe
+import Data.String.Unicode ( getOutputEncodingFct' )
import Text.XML.HXT.DOM.Interface
+import qualified
+ Text.XML.HXT.DOM.ShowXml as XS
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.Edit ( addHeadlineToXmlDoc
@@ -42,6 +47,8 @@
, indentDoc
, numberLinesInXmlDoc
, treeRepOfXmlDoc
+ , escapeHtmlRefs
+ , escapeXmlRefs
)
import Text.XML.HXT.Arrow.XmlState
import Text.XML.HXT.Arrow.XmlState.TypeDefs
@@ -59,16 +66,31 @@
-- ------------------------------------------------------------
--
--- output arrows
+-- | Write the contents of a document tree into an output stream (file or stdout).
+--
+-- If textMode is set, writing is done with Haskell string output, else (default)
+-- writing is done with lazy ByteString output
putXmlDocument :: Bool -> String -> IOStateArrow s XmlTree XmlTree
putXmlDocument textMode dst
= perform putDoc
where
putDoc
- = xshow getChildren
- >>>
- arrIO (\ s -> try ( hPutDocument (\h -> hPutStrLn h s)))
+ = ( if textMode
+ then ( xshow getChildren
+ >>>
+ arrIO (\ s -> try ( hPutDocument (\h -> hPutStrLn h s)))
+ )
+ else ( xshowBlob getChildren
+ >>>
+ arrIO (\ s -> try ( hPutDocument (\h -> do
+ BS.hPutStr h s
+ BS.hPutStr h (stringToBlob "\n")
+ )
+ )
+ )
+ )
+ )
>>>
( ( traceMsg 1 ("io error, document not written to " ++ outFile)
>>>
@@ -77,7 +99,7 @@
filterErrorMsg
)
|||
- ( traceMsg 2 ("document written to " ++ outFile)
+ ( traceMsg 2 ("document written to " ++ outFile ++ ", textMode = " ++ show textMode)
>>>
none
)
@@ -149,14 +171,14 @@
where
getEC enc' = fromLA $ getOutputEncoding' defaultEnc enc'
-encodeDocument :: Bool -> String -> IOStateArrow s XmlTree XmlTree
-encodeDocument supressXmlPi defaultEnc
+encodeDocument :: Bool -> Bool -> String -> IOStateArrow s XmlTree XmlTree
+encodeDocument quoteXml supressXmlPi defaultEnc
= encode $< getOutputEncoding defaultEnc
where
encode enc
= traceMsg 2 ("encodeDocument: encoding is " ++ show enc)
>>>
- ( encodeDocument' supressXmlPi enc
+ ( encodeDocument' quoteXml supressXmlPi enc
`orElse`
( issueFatal ("encoding scheme not supported: " ++ show enc)
>>>
@@ -166,9 +188,21 @@
-- ------------------------------------------------------------
+isBinaryDoc :: LA XmlTree XmlTree
+isBinaryDoc = ( ( getAttrValue transferMimeType >>^ stringToLower )
+ >>>
+ isA (\ t -> not (null t || isTextMimeType t || isXmlMimeType t))
+ )
+ `guards` this
+
getOutputEncoding' :: String -> String -> LA XmlTree String
getOutputEncoding' defaultEnc defaultEnc2
- = catA [ getChildren -- 1. guess: evaluate
+ = catA [ isBinaryDoc
+ >>> -- 0. guess: binary data found: no encoding at all
+ constA isoLatin1 -- the content should usually be a blob
+ -- this handling is like the decoding in DocumentInput,
+ -- there nothing is decoded for non text or non xml contents
+ , getChildren -- 1. guess: evaluate
>>>
( ( isPi >>> hasName t_xml )
`guards`
@@ -180,29 +214,66 @@
]
>. (head . filter (not . null)) -- make the filter deterministic: take 1. entry from list of guesses
-encodeDocument' :: ArrowXml a => Bool -> String -> a XmlTree XmlTree
-encodeDocument' supressXmlPi defaultEnc
+encodeDocument' :: ArrowXml a => Bool -> Bool -> String -> a XmlTree XmlTree
+encodeDocument' quoteXml supressXmlPi defaultEnc
= fromLA (encode $< getOutputEncoding' defaultEnc utf8)
where
encode :: String -> LA XmlTree XmlTree
encode encodingScheme
- = case getOutputEncodingFct encodingScheme of
- Nothing -> none
- Just ef -> ( if supressXmlPi
- then processChildren (none `when` isXmlPi)
- else ( addXmlPi
- >>>
- addXmlPiEncoding encodingScheme
- )
- )
- >>>
- replaceChildren ( xshow getChildren
- >>>
- arr ef
- >>>
- mkText
- )
- >>>
- addAttr a_output_encoding encodingScheme
+ | encodingScheme == unicodeString
+ = replaceChildren
+ ( (getChildren >. XS.xshow'' cQuot aQuot)
+ >>>
+ mkText
+ )
+ | isNothing encodeFct
+ = none
+ | otherwise
+ = ( if supressXmlPi
+ then processChildren (none `when` isXmlPi)
+ else ( addXmlPi
+ >>>
+ addXmlPiEncoding encodingScheme
+ )
+ )
+ >>>
+ ( isLatin1Blob
+ `orElse`
+ encodeDoc (fromJust encodeFct)
+ )
+ >>>
+ addAttr a_output_encoding encodingScheme
+ where
+ (cQuot, aQuot)
+ | quoteXml = escapeXmlRefs
+ | otherwise = escapeHtmlRefs
+
+ encodeFct = getOutputEncodingFct' encodingScheme
+
+ encodeDoc ef = replaceChildren
+ ( xshowBlobWithEnc cQuot aQuot ef getChildren
+ >>>
+ mkBlob
+ )
+ xshowBlobWithEnc cenc aenc enc f
+ = f >. XS.xshow' cenc aenc enc
+
+ -- if encoding scheme is isolatin1 and the contents is a single blob (bytestring)
+ -- the encoding is the identity.
+ -- This optimization enables processing (copying) of none XML contents
+ -- without any conversions from and to strings
+ isLatin1Blob
+ | encodingScheme /= isoLatin1
+ = none
+ | otherwise = childIsSingleBlob `guards` this
+ where
+ childIsSingleBlob
+ = listA getChildren
+ >>>
+ isA (length >>> (== 1))
+ >>>
+ unlistA
+ >>>
+ isBlob
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Arrow/Edit.hs b/src/Text/XML/HXT/Arrow/Edit.hs
--- a/src/Text/XML/HXT/Arrow/Edit.hs
+++ b/src/Text/XML/HXT/Arrow/Edit.hs
@@ -2,7 +2,7 @@
{- |
Module : Text.XML.HXT.Arrow.Edit
- Copyright : Copyright (C) 2006-9 Uwe Schmidt
+ Copyright : Copyright (C) 2011 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
@@ -24,8 +24,8 @@
, xshowEscapeXml
- , escapeXmlDoc
- , escapeHtmlDoc
+ , escapeXmlRefs
+ , escapeHtmlRefs
, haskellRepOfXmlDoc
, treeRepOfXmlDoc
@@ -65,19 +65,21 @@
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowTree
import Control.Arrow.ListArrow
+import Control.Arrow.NTreeEdit
import Data.Char.Properties.XMLCharProps ( isXmlSpaceChar )
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.DOM.Interface
-import qualified Text.XML.HXT.DOM.XmlNode as XN
+import qualified Text.XML.HXT.DOM.XmlNode as XN
+import qualified Text.XML.HXT.DOM.ShowXml as XS
import Text.XML.HXT.DOM.FormatXmlTree ( formatXmlTree )
import Text.XML.HXT.Parser.HtmlParsec ( emptyHtmlTags )
import Text.XML.HXT.Parser.XmlEntities ( xmlEntities )
import Text.XML.HXT.Parser.XhtmlEntities ( xhtmlEntities )
import Data.List ( isPrefixOf )
-import qualified Data.Map as M
+import qualified Data.Map as M
import Data.Maybe
-- ------------------------------------------------------------
@@ -103,29 +105,69 @@
canonicalizeTree' :: LA XmlTree XmlTree -> LA XmlTree XmlTree
canonicalizeTree' toBeRemoved
- = processChildren (none `when` isText)
+ = processChildren
+ ( (none `when` (isText <+> isXmlPi)) -- remove XML PI and all text around XML root element
+ >>>
+ (deep isPi `when` isDTD) -- remove DTD parts, except PIs whithin DTD
+ )
>>>
- processBottomUp canonicalize1Node
- where
- canonicalize1Node :: LA XmlTree XmlTree
- canonicalize1Node
- = (deep isPi `when` isDTD) -- remove DTD parts, except PIs
- >>>
- (none `when` toBeRemoved) -- remove uninteresting nodes
- >>>
- ( processAttrl ( processChildren transfCharRef
- >>>
- collapseXText
- )
- `when` isElem
- )
- >>>
- transfCdata -- CDATA -> text
- >>>
- transfCharRef -- Char refs -> text
- >>>
- collapseXText -- combine text
+ canonicalizeNodes toBeRemoved
+{-
+canonicalize1Node :: LA XmlTree XmlTree -> LA XmlTree XmlTree
+canonicalize1Node toBeRemoved
+ = choiceA
+ [ toBeRemoved :-> none
+ , isElem :-> ( processAttrl
+ ( processChildren transfCharRef
+ >>>
+ collapseXText' -- combine text in attribute values
+ )
+ >>>
+ collapseXText' -- combine text in content
+ )
+ , isCharRef :-> ( getCharRef
+ >>>
+ arr (\ i -> [toEnum i])
+ >>>
+ mkText
+ )
+ , isCdata :-> ( getCdata
+ >>>
+ mkText
+ )
+ , this :-> this
+ ]
+-}
+canonicalizeNodes :: LA XmlTree XmlTree -> LA XmlTree XmlTree
+canonicalizeNodes toBeRemoved
+ = editNTreeA $
+ [ toBeRemoved :-> none
+ , ( isElem >>> getAttrl >>> getChildren >>> isCharRef ) -- canonicalize attribute list
+ :-> ( processAttrl
+ ( processChildren transfCharRef
+ >>>
+ collapseXText' -- combine text in attribute values
+ )
+ >>>
+ ( collapseXText' -- and combine text in content
+ `when`
+ (getChildren >>. has2XText)
+ )
+ )
+ , ( isElem >>> (getChildren >>. has2XText) )
+ :-> collapseXText' -- combine text in content
+ , isCharRef :-> ( getCharRef
+ >>>
+ arr (\ i -> [toEnum i])
+ >>>
+ mkText
+ )
+ , isCdata :-> ( getCdata
+ >>>
+ mkText
+ )
+ ]
-- |
-- Applies some "Canonical XML" rules to a document tree.
@@ -147,12 +189,9 @@
-- - Special characters in attribute values and character content are replaced by character references
canonicalizeAllNodes :: ArrowList a => a XmlTree XmlTree
-canonicalizeAllNodes
- = fromLA $
- canonicalizeTree' ( isCmt -- remove comment
- <+>
- isXmlPi -- remove xml declaration
- )
+canonicalizeAllNodes = fromLA $
+ canonicalizeTree' isCmt -- remove comment
+{-# INLINE canonicalizeAllNodes #-}
-- |
-- Canonicalize a tree for XPath
@@ -161,9 +200,8 @@
-- see 'canonicalizeAllNodes'
canonicalizeForXPath :: ArrowList a => a XmlTree XmlTree
-canonicalizeForXPath
- = fromLA $
- canonicalizeTree' isXmlPi
+canonicalizeForXPath = fromLA $ canonicalizeTree' none -- comment remains there
+{-# INLINE canonicalizeForXPath #-}
-- |
-- Canonicalize the contents of a document
@@ -175,27 +213,20 @@
-- see 'canonicalizeAllNodes'
canonicalizeContents :: ArrowList a => a XmlTree XmlTree
-canonicalizeContents
- = fromLA $
- processBottomUp canonicalize1Node
- where
- canonicalize1Node :: LA XmlTree XmlTree
- canonicalize1Node
- = ( processAttrl ( processChildren transfCharRef
- >>>
- collapseXText
- )
- `when` isElem
- )
- >>>
- transfCdata -- CDATA -> text
- >>>
- transfCharRef -- Char refs -> text
- >>>
- collapseXText -- combine text
+canonicalizeContents = fromLA $
+ canonicalizeNodes none
+{-# INLINE canonicalizeContents #-}
-- ------------------------------------------------------------
+has2XText :: XmlTrees -> XmlTrees
+has2XText ts0@(t1 : ts1@(t2 : ts2))
+ | XN.isText t1 = if XN.isText t2
+ then ts0
+ else has2XText ts2
+ | otherwise = has2XText ts1
+has2XText _ = []
+
collapseXText' :: LA XmlTree XmlTree
collapseXText'
= replaceChildren ( listA getChildren >>> arrL (foldr mergeText' []) )
@@ -217,9 +248,7 @@
-- This is useful, e.g. after char and entity reference substitution
collapseXText :: ArrowList a => a XmlTree XmlTree
-collapseXText
- = fromLA $
- collapseXText'
+collapseXText = fromLA collapseXText'
-- |
-- Applies collapseXText recursively.
@@ -228,9 +257,7 @@
-- see also : 'collapseXText'
collapseAllXText :: ArrowList a => a XmlTree XmlTree
-collapseAllXText
- = fromLA $
- processBottomUp collapseXText'
+collapseAllXText = fromLA $ processBottomUp collapseXText'
-- ------------------------------------------------------------
@@ -242,10 +269,10 @@
--
-- So the following law holds
--
--- > xshowEscape f >>> xread == f
+-- > xshowEscapeXml f >>> xread == f
xshowEscapeXml :: ArrowXml a => a n XmlTree -> a n String
-xshowEscapeXml f = xshow (f >>> escapeXmlDoc)
+xshowEscapeXml f = f >. (uncurry XS.xshow'' escapeXmlRefs)
-- ------------------------------------------------------------
@@ -258,131 +285,72 @@
xmlEntityRefTable
, xhtmlEntityRefTable :: EntityRefTable
-xmlEntityRefTable = buildEntityRefTable $ xmlEntities
-xhtmlEntityRefTable = buildEntityRefTable $ xhtmlEntities
+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'' escChar isEsc t
- = maybe [t] escape' . XN.getText $ t
- where
- escape' "" = [t] -- empty text nodes remain empty text nodes
- escape' s = escape s -- they do not disapear
-
- escape ""
- = []
- escape (c:s1)
- | isEsc c
- = escChar c : escape s1
- escape s
- = XN.mkText s1 : escape s2
- where
- (s1, s2) = break isEsc s
-
-{-
-escapeCharRef :: Char -> XmlTree
-escapeCharRef = XN.mkCharRef . fromEnum
--}
-
-escapeEntityRef :: EntityRefTable -> Char -> XmlTree
-escapeEntityRef entityTable c
- = maybe (XN.mkCharRef c') XN.mkEntityRef . M.lookup c' $ entityTable
- where
- c' = fromEnum c
-
-escapeXmlEntityRef :: Char -> XmlTree
-escapeXmlEntityRef = escapeEntityRef xmlEntityRefTable
-
-escapeHtmlEntityRef :: Char -> XmlTree
-escapeHtmlEntityRef = escapeEntityRef xhtmlEntityRefTable
-
-- ------------------------------------------------------------
--- |
--- 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 :: ArrowList a => a XmlTree XmlTree
-escapeXmlDoc
- = fromLA $ escapeDoc escXmlText escXmlAttrValue
+escapeXmlRefs :: (Char -> String -> String, Char -> String -> String)
+escapeXmlRefs = (cquote, aquote)
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
-
--- ------------------------------------------------------------
+ cquote c
+ | c `elem` "<&" = ('&' :)
+ . ((lookupRef c xmlEntityRefTable) ++)
+ . (';' :)
+ | otherwise = (c :)
+ aquote c
+ | c `elem` "<>\"\'&\n\r\t"
+ = ('&' :)
+ . ((lookupRef c xmlEntityRefTable) ++)
+ . (';' :)
+ | otherwise = (c :)
-escapeHtmlDoc :: ArrowList a => a XmlTree XmlTree
-escapeHtmlDoc
- = fromLA $ escapeDoc escHtmlText escHtmlAttrValue
+escapeHtmlRefs :: (Char -> String -> String, Char -> String -> String)
+escapeHtmlRefs = (cquote, aquote)
where
- escHtmlText
- = arrL $ escapeText'' escapeHtmlEntityRef isHtmlTextEsc
- escHtmlAttrValue
- = arrL $ escapeText'' escapeHtmlEntityRef isHtmlAttrEsc
-
- isHtmlTextEsc c
- = c >= toEnum(128) || ( c `elem` "<&" )
- isHtmlAttrEsc c
- = c >= toEnum(128) || ( c `elem` "<>\"\'&\n\r\t" )
+ cquote c
+ | isHtmlTextEsc c
+ = ('&' :)
+ . ((lookupRef c xhtmlEntityRefTable) ++)
+ . (';' :)
+ | otherwise = (c :)
+ aquote c
+ | isHtmlAttrEsc c
+ = ('&' :)
+ . ((lookupRef c xhtmlEntityRefTable) ++)
+ . (';' :)
+ | otherwise = (c :)
--- ------------------------------------------------------------
+ isHtmlTextEsc c = c >= toEnum(128) || ( c `elem` "<&" )
+ isHtmlAttrEsc c = c >= toEnum(128) || ( c `elem` "<>\"\'&\n\r\t" )
-escapeDoc :: LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
-escapeDoc escText escAttr
- = escape
- where
- escape
- = choiceA
- [ isElem :-> ( processChildren escape
- >>>
- processAttrl escVal
- )
- , isText :-> escText
- -- , isCmt :-> escCmt
- , isDTD :-> processTopDown escDTD
- , this :-> this
- ]
- escVal = processChildren escAttr
- escDTD = escVal `when` ( isDTDEntity <+> isDTDPEntity )
+lookupRef :: Char -> EntityRefTable -> String
+lookupRef c = fromMaybe ('#' : show (fromEnum c))
+ . M.lookup (fromEnum c)
+{-# INLINE lookupRef #-}
-- ------------------------------------------------------------
preventEmptyElements :: ArrowList a => [String] -> Bool -> a XmlTree XmlTree
preventEmptyElements ns isHtml
- = fromLA $ insertDummyElem
+ = fromLA $
+ editNTreeA [ ( isElem
+ >>>
+ isNoneEmpty
+ >>>
+ neg getChildren
+ )
+ :-> replaceChildren (txt "")
+ ]
where
isNoneEmpty
| not (null ns) = hasNameWith (localPart >>> (`elem` ns))
| isHtml = hasNameWith (localPart >>> (`notElem` emptyHtmlTags))
| otherwise = this
- insertDummyElem
- = processBottomUp
- ( replaceChildren (txt "")
- `when`
- ( isElem
- >>>
- isNoneEmpty
- >>>
- neg getChildren
- )
- )
-
-- ------------------------------------------------------------
-- |
@@ -441,25 +409,19 @@
-- ------------------------------------------------------------
-removeComment' :: LA XmlTree XmlTree
-removeComment' = none `when` isCmt
-
-- |
--- remove Comments: @none `when` isCmt@
+-- remove a Comment node
removeComment :: ArrowXml a => a XmlTree XmlTree
-removeComment = fromLA $ removeComment'
+removeComment = none `when` isCmt
-- |
--- remove all comments recursively
+-- remove all comments in a tree recursively
removeAllComment :: ArrowXml a => a XmlTree XmlTree
-removeAllComment = fromLA $ processBottomUp removeComment'
-
--- ----------
+removeAllComment = fromLA $ editNTreeA [isCmt :-> none]
-removeWhiteSpace' :: LA XmlTree XmlTree
-removeWhiteSpace' = none `when` isWhiteSpace
+-- ------------------------------------------------------------
-- |
-- simple filter for removing whitespace.
@@ -470,7 +432,7 @@
-- see also : 'removeAllWhiteSpace', 'removeDocWhiteSpace'
removeWhiteSpace :: ArrowXml a => a XmlTree XmlTree
-removeWhiteSpace = fromLA $ removeWhiteSpace'
+removeWhiteSpace = fromLA $ none `when` isWhiteSpace
-- |
-- simple recursive filter for removing all whitespace.
@@ -481,8 +443,11 @@
-- see also : 'removeWhiteSpace', 'removeDocWhiteSpace'
removeAllWhiteSpace :: ArrowXml a => a XmlTree XmlTree
-removeAllWhiteSpace = fromLA $ processBottomUp removeWhiteSpace'
+removeAllWhiteSpace = fromLA $ editNTreeA [isWhiteSpace :-> none]
+ -- fromLA $ processBottomUp removeWhiteSpace' -- less efficient
+-- ------------------------------------------------------------
+
-- |
-- filter for removing all not significant whitespace.
--
@@ -673,43 +638,33 @@
-- ------------------------------------------------------------
-transfCdata' :: LA XmlTree XmlTree
-transfCdata' = (getCdata >>> mkText) `when` isCdata
-
-- |
--- converts a CDATA section node into a normal text node
+-- converts a CDATA section into normal text nodes
transfCdata :: ArrowXml a => a XmlTree XmlTree
transfCdata = fromLA $
- transfCdata'
+ (getCdata >>> mkText) `when` isCdata
-- |
-- converts CDATA sections in whole document tree into normal text nodes
transfAllCdata :: ArrowXml a => a XmlTree XmlTree
-transfAllCdata = fromLA $
- processBottomUp transfCdata'
-
---
-
-transfCharRef' :: LA XmlTree XmlTree
-transfCharRef' = ( getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText )
- `when`
- isCharRef
+transfAllCdata = fromLA $ editNTreeA [isCdata :-> (getCdata >>> mkText)]
-- |
--- converts character references to normal text
+-- converts a character reference to normal text
transfCharRef :: ArrowXml a => a XmlTree XmlTree
transfCharRef = fromLA $
- transfCharRef'
+ ( getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText )
+ `when`
+ isCharRef
-- |
-- recursively converts all character references to normal text
transfAllCharRef :: ArrowXml a => a XmlTree XmlTree
-transfAllCharRef = fromLA $
- processBottomUp transfCharRef'
+transfAllCharRef = fromLA $ editNTreeA [isCharRef :-> (getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText)]
-- ------------------------------------------------------------
@@ -741,7 +696,7 @@
<+>
txt "\n"
<+>
- ( getChildren >>> (none `when` isDTDDoctype) ) -- remove old DTD stuff
+ ( getChildren >>> (none `when` isDTDDoctype) ) -- remove old DTD decl
)
-- ------------------------------------------------------------
@@ -762,7 +717,7 @@
addXmlPi :: ArrowXml a => a XmlTree XmlTree
addXmlPi
= fromLA
- ( insertChildrenAt 0 ( ( mkPi (mkSNsName t_xml) none
+ ( insertChildrenAt 0 ( ( mkPi (mkName t_xml) none
>>>
addAttr a_version "1.0"
)
diff --git a/src/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs b/src/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs
--- a/src/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs
+++ b/src/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs
@@ -30,8 +30,8 @@
import Text.XML.HXT.Arrow.XmlState
import Text.XML.HXT.Arrow.ParserInterface
- ( parseXmlAttrValue
- , parseXmlGeneralEntityValue
+ ( parseXmlEntityValueAsAttrValue
+ , parseXmlEntityValueAsContent
)
import Text.XML.HXT.Arrow.Edit
@@ -71,7 +71,7 @@
emptyGeEnv :: GEEnv
emptyGeEnv = GEEnv M.empty
-lookupGeEnv :: String -> GEEnv -> Maybe GESubstArrow
+lookupGeEnv :: String -> GEEnv -> Maybe GESubstArrow
lookupGeEnv k (GEEnv env)
= M.lookup k env
@@ -108,10 +108,10 @@
>>>
processChildren (processGeneralEntity context recl)
)
+ , isEntityRef :-> substEntityRef
, isDTDDoctype :-> processChildren (processGeneralEntity context recl)
, isDTDEntity :-> addEntityDecl
, isDTDAttlist :-> substEntitiesInAttrDefaultValue
- , isEntityRef :-> substEntityRef
, this :-> this
]
where
@@ -129,45 +129,35 @@
addInternalEntity :: GEArrow XmlTree b
addInternalEntity
- = ( ( getDTDAttrValue a_name
+ = insertInternal $<<
+ ( ( getDTDAttrValue a_name
>>>
traceValue 2 (("processGeneralEntity: general entity definition for " ++) . show)
)
&&&
xshow (getChildren >>> isText)
)
- >>>
- applyA ( arr2 $ \ entity str ->
- listA ( ( ( txt str
- >>>
- parseXmlGeneralEntityValue ("general internal entity" ++ show entity)
- >>>
- filterErrorMsg
- )
- `orElse` txt ""
- )
- >>>
- processGeneralEntity ReferenceInEntityValue (entity : recl)
- )
- >>>
- applyA (arr $ \ ts -> insertEntity (substInternal ts) entity)
- )
- >>>
- none
+ where
+ insertInternal entity contents
+ = insertEntity (substInternal contents) entity
+ >>>
+ none
addExternalEntity :: GEArrow XmlTree b
addExternalEntity
- = ( ( getDTDAttrValue a_name
+ = insertExternal $<<
+ ( ( getDTDAttrValue a_name
>>>
traceValue 2 (("processGeneralEntity: external entity definition for " ++) . show)
)
&&&
getDTDAttrValue a_url -- the absolute URL, not the relative in attr: k_system
)
- >>>
- applyA (arr2 $ \ entity uri -> insertEntity (substExternalParsed1Time uri) entity)
- >>>
- none
+ where
+ insertExternal entity uri
+ = insertEntity (substExternalParsed1Time uri) entity
+ >>>
+ none
addUnparsedEntity :: GEArrow XmlTree b
addUnparsedEntity
@@ -194,6 +184,8 @@
ok = this
alreadyDefined _
= issueWarn ("entity " ++ show entity ++ " already defined, repeated definition ignored")
+ >>>
+ none
addEntity :: (String -> GESubstArrow) -> String -> GEArrow b b
addEntity fct entity
@@ -207,8 +199,8 @@
>>> -- substitute entities
mkText -- and convert value into a string
>>>
- parseXmlAttrValue "default value of attribute"
- >>>
+ parseXmlEntityValueAsAttrValue "default value of attribute"
+ >>>
filterErrorMsg
>>>
substEntitiesInAttrValue
@@ -244,7 +236,6 @@
) >>>
arr2 substA
)
- `orElse` this
where
substA :: String -> GEEnv -> GEArrow XmlTree XmlTree
substA entity geEnv
@@ -268,45 +259,43 @@
>>>
runInLocalURIContext ( root [sattr a_source uri] [] -- uri must be an absolute uri
>>> -- abs uri is computed during parameter entity handling
- listA ( getXmlEntityContents
- >>>
- processExternalEntityContents
- )
+ getXmlEntityContents
+ >>>
+ processExternalEntityContents
)
>>>
- applyA ( arr $ \ ts -> addEntity (substExternalParsed ts) entity )
+ applyA ( arr $ \ s -> addEntity (substExternalParsed s) entity )
)
>>>
processGeneralEntity cx rl
where
- processExternalEntityContents :: IOStateArrow s XmlTree XmlTree
+ processExternalEntityContents :: IOStateArrow s XmlTree String
processExternalEntityContents
- = ( ( documentStatusOk -- reading entity succeeded
- >>> -- with content stored in a text node
- (getChildren >>> isText)
- )
- `guards`
- ( getChildren
- >>>
- parseXmlGeneralEntityValue ("external parsed entity " ++ show entity)
- >>>
- filterErrorMsg
+ = ( ( ( documentStatusOk -- reading entity succeeded
+ >>> -- with content stored in a text node
+ (getChildren >>> isText)
+ )
+ `guards`
+ this
)
+ `orElse`
+ issueErr ("illegal value for external parsed entity " ++ show entity)
)
- `orElse`
- issueErr ("illegal value for external parsed entity " ++ show entity)
+ >>>
+ xshow (getChildren >>> isText)
- substExternalParsed :: XmlTrees -> String -> GESubstArrow
- substExternalParsed ts entity ReferenceInContent rl = includedIfValidating ts rl entity
- substExternalParsed _ entity ReferenceInAttributeValue _
+
+ substExternalParsed :: String -> String -> GESubstArrow
+ substExternalParsed s entity ReferenceInContent rl = includedIfValidating s rl entity
+ substExternalParsed _ entity ReferenceInAttributeValue _
= forbidden entity "external parsed general" "in attribute value"
- substExternalParsed _ _ ReferenceInEntityValue _
+ substExternalParsed _ _ ReferenceInEntityValue _
= bypassed
- substInternal :: XmlTrees -> String -> GESubstArrow
- substInternal ts entity ReferenceInContent rl = included ts rl entity
- substInternal ts entity ReferenceInAttributeValue rl= includedInLiteral ts rl entity
- substInternal _ _ ReferenceInEntityValue _ = bypassed
+ substInternal :: String -> String -> GESubstArrow
+ substInternal s entity ReferenceInContent rl = included s rl entity
+ substInternal s entity ReferenceInAttributeValue rl = includedInLiteral s rl entity
+ substInternal _ _ ReferenceInEntityValue _ = bypassed
substUnparsed :: String -> GESubstArrow
substUnparsed entity ReferenceInContent _ = forbidden entity "unparsed" "content"
@@ -314,27 +303,37 @@
substUnparsed entity ReferenceInEntityValue _ = forbidden entity "unparsed" "entity value"
-- XML 1.0 chapter 4.4.2
- included :: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree
- included ts rl entity
- = arrL (const ts)
+ included :: String -> RecList -> String -> GEArrow XmlTree XmlTree
+ included s rl entity
+ = traceMsg 3 ("substituting general entity " ++ show entity ++ " with value " ++ show s)
>>>
+ txt s
+ >>>
+ parseXmlEntityValueAsContent ("substituting general entity " ++ show entity ++ " in contents")
+ >>>
+ filterErrorMsg
+ >>>
processGeneralEntity context (entity : rl)
-- XML 1.0 chapter 4.4.3
- includedIfValidating :: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree
+ includedIfValidating :: String -> RecList -> String -> GEArrow XmlTree XmlTree
includedIfValidating
= included
-
-- XML 1.0 chapter 4.4.4
forbidden :: String -> String -> String -> GEArrow XmlTree XmlTree
forbidden entity msg cx
= issueErr ("reference of " ++ msg ++ show entity ++ " forbidden in " ++ cx)
-- XML 1.0 chapter 4.4.5
- includedInLiteral :: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree
- includedInLiteral
- = included
-
+ includedInLiteral :: String -> RecList -> String -> GEArrow XmlTree XmlTree
+ includedInLiteral s rl entity
+ = txt s
+ >>>
+ parseXmlEntityValueAsAttrValue ("substituting general entity " ++ show entity ++ " in attribute value")
+ >>>
+ filterErrorMsg
+ >>>
+ processGeneralEntity context (entity : rl)
-- XML 1.0 chapter 4.4.7
bypassed :: GEArrow XmlTree XmlTree
bypassed
diff --git a/src/Text/XML/HXT/Arrow/Namespace.hs b/src/Text/XML/HXT/Arrow/Namespace.hs
--- a/src/Text/XML/HXT/Arrow/Namespace.hs
+++ b/src/Text/XML/HXT/Arrow/Namespace.hs
@@ -53,6 +53,7 @@
isNamespaceDeclAttr
= fromLA $
(getAttrName >>> isA isNameSpaceName) `guards` this
+{-# INLINE isNamespaceDeclAttr #-}
-- | get the namespace prefix and the namespace URI out of
-- an attribute tree with a namespace declaration (see 'isNamespaceDeclAttr')
@@ -114,9 +115,9 @@
--
-- Calls 'cleanupNamespaces' with 'collectNamespaceDecl'
-uniqueNamespaces :: ArrowXml a => a XmlTree XmlTree
-uniqueNamespaces = fromLA $
- cleanupNamespaces' collectNamespaceDecl
+uniqueNamespaces :: ArrowXml a => a XmlTree XmlTree
+uniqueNamespaces = fromLA $
+ cleanupNamespaces' collectNamespaceDecl
-- | generate unique namespaces and add all namespace declarations for all prefix-uri pairs in all qualified names
--
@@ -125,20 +126,20 @@
uniqueNamespacesFromDeclAndQNames :: ArrowXml a => a XmlTree XmlTree
uniqueNamespacesFromDeclAndQNames = fromLA $
- cleanupNamespaces' ( collectNamespaceDecl
- <+>
- collectPrefixUriPairs
- )
+ cleanupNamespaces' ( collectNamespaceDecl
+ <+>
+ collectPrefixUriPairs
+ )
-cleanupNamespaces' :: LA XmlTree (String, String) -> LA XmlTree XmlTree
-cleanupNamespaces' collectNamespaces = processTopDownUntil
- ( hasNamespaceDecl `guards` cleanupNamespaces collectNamespaces )
+cleanupNamespaces' :: LA XmlTree (String, String) -> LA XmlTree XmlTree
+cleanupNamespaces' collectNamespaces = processTopDownUntil
+ ( hasNamespaceDecl `guards` cleanupNamespaces collectNamespaces )
where
- hasNamespaceDecl = isElem
- >>>
- getAttrl
- >>>
- isNamespaceDeclAttr
+ hasNamespaceDecl = isElem
+ >>>
+ getAttrl
+ >>>
+ isNamespaceDeclAttr
-- | does the real work for namespace cleanup.
--
@@ -273,11 +274,11 @@
nsDeclToAttr :: (XName, XName) -> LA XmlTree XmlTree
nsDeclToAttr (n, uri)
- = mkAttr qn (txt (show uri))
+ = mkAttr qn (txt (unXN uri))
where
qn :: QName
- qn | isNullXName n = mkQName' nullXName xmlnsXName xmlnsNamespaceXName
- | otherwise = mkQName' xmlnsXName n xmlnsNamespaceXName
+ qn | isNullXName n = newQName xmlnsXName nullXName xmlnsNamespaceXName
+ | otherwise = newQName n xmlnsXName xmlnsNamespaceXName
-- -----------------------------------------------------------------------------
@@ -374,7 +375,7 @@
, ( getQName >>> isA (not . isWellformedNSDecl )
)
- `guards` nsError (\ n -> "illegal namespace declaration for name " ++ n ++ " starting with reserved prefix " ++ show "xml" )
+ `guards` nsError (\ n -> "illegal namespace declaration for name " ++ show n ++ " starting with reserved prefix " ++ show "xml" )
]
, isDTD :-> catA [ isDTDDoctype <+> isDTDAttlist <+> isDTDElement <+> isDTDName
@@ -413,11 +414,11 @@
]
]
where
- nsError :: (String -> String) -> LA XmlTree XmlTree
+ nsError :: (QName -> String) -> LA XmlTree XmlTree
nsError msg
- = (getQName >>> arr show) >>> nsErr msg
+ = getQName >>> nsErr msg
- nsErr :: (String -> String) -> LA String XmlTree
+ nsErr :: (a -> String) -> LA a XmlTree
nsErr msg = arr msg >>> mkError c_err
doubleOcc :: String -> LA XmlTree XmlTree
diff --git a/src/Text/XML/HXT/Arrow/ParserInterface.hs b/src/Text/XML/HXT/Arrow/ParserInterface.hs
--- a/src/Text/XML/HXT/Arrow/ParserInterface.hs
+++ b/src/Text/XML/HXT/Arrow/ParserInterface.hs
@@ -18,15 +18,8 @@
( module Text.XML.HXT.Arrow.ParserInterface )
where
-import Control.Arrow
import Control.Arrow.ArrowList
-import Control.Arrow.ArrowIf
-import Control.Arrow.ArrowTree
-import Control.Arrow.ListArrow
-import Text.XML.HXT.Parser.XmlEntities ( xmlEntities )
-import Text.XML.HXT.Parser.XhtmlEntities( xhtmlEntities )
-
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.Arrow.XmlArrow
@@ -63,12 +56,11 @@
parseXmlDTDEntityValue :: ArrowXml a => a XmlTree XmlTree
parseXmlDTDEntityValue = arrL DP.parseXmlDTDEntityValue
-parseXmlAttrValue :: ArrowXml a => String -> a XmlTree XmlTree
-parseXmlAttrValue context = arrL (XP.parseXmlAttrValue context)
+parseXmlEntityValueAsContent :: ArrowXml a => String -> a XmlTree XmlTree
+parseXmlEntityValueAsContent = arrL . XP.parseXmlEntityValueAsContent
-parseXmlGeneralEntityValue :: ArrowXml a => String -> a XmlTree XmlTree
-parseXmlGeneralEntityValue context
- = arrL (XP.parseXmlGeneralEntityValue context)
+parseXmlEntityValueAsAttrValue :: ArrowXml a => String -> a XmlTree XmlTree
+parseXmlEntityValueAsAttrValue = arrL . XP.parseXmlEntityValueAsAttrValue
-- ------------------------------------------------------------
@@ -77,49 +69,5 @@
parseHtmlContent :: ArrowList a => a String XmlTree
parseHtmlContent = arrL HP.parseHtmlContent
-
--- ------------------------------------------------------------
-
--- | 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.
---
--- Unknown entity refs remain unchanged
-
-substHtmlEntityRefs :: ArrowList a => a XmlTree XmlTree
-substHtmlEntityRefs = substEntityRefs xhtmlEntities
-
-
--- | substitution of the five predefined XMT entities, works like 'substHtmlEntityRefs'
-
-substXmlEntityRefs :: ArrowList a => a XmlTree XmlTree
-substXmlEntityRefs = substEntityRefs xmlEntities
-
--- | the entity substitution arrow called from 'substXmlEntityRefs' and 'substHtmlEntityRefs'
-
-substEntityRefs :: ArrowList a => [(String, Int)] -> a XmlTree XmlTree
-substEntityRefs entities
- = fromLA substEntities
- where
- substEntities :: LA XmlTree XmlTree
- substEntities
- = choiceA
- [ isEntityRef :-> ( substEntity $< getEntityRef )
- , isElem :-> ( processAttrl (processChildren substEntities)
- >>>
- processChildren substEntities
- )
- , this :-> this
- ]
- where
- substEntity en
- = case (lookup en entities) of
- Just i
- -> txt [toEnum i] -- constA i >>> mkCharRef
- Nothing
- -> this
-
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Arrow/Pickle.hs b/src/Text/XML/HXT/Arrow/Pickle.hs
--- a/src/Text/XML/HXT/Arrow/Pickle.hs
+++ b/src/Text/XML/HXT/Arrow/Pickle.hs
@@ -96,6 +96,7 @@
, xpOption
, xpPair
, xpPrim
+ , xpInt
, xpSeq
, xpText
, xpText0
@@ -157,10 +158,10 @@
>>>
ifA ( getSysAttr a_addDTD >>> isA (== v_1) )
( replaceChildren ( (constA undefined >>> xpickleDTD xp >>> getChildren)
- <+>
- getChildren
+ <+>
+ getChildren
)
- )
+ )
this
>>>
writeDocument [] dest
@@ -257,8 +258,12 @@
-- | The arrow version of the unpickler function
xunpickleVal :: ArrowXml a => PU b -> a XmlTree b
-xunpickleVal xp = arrL (maybeToList . unpickleDoc xp)
-
+xunpickleVal xp = ( processChildren (none `whenNot` isElem) -- remove all stuff surrounding the root element
+ `when`
+ isRoot
+ )
+ >>>
+ arrL (maybeToList . unpickleDoc xp)
-- | Compute the associated DTD of a pickler
diff --git a/src/Text/XML/HXT/Arrow/Pickle/DTD.hs b/src/Text/XML/HXT/Arrow/Pickle/DTD.hs
--- a/src/Text/XML/HXT/Arrow/Pickle/DTD.hs
+++ b/src/Text/XML/HXT/Arrow/Pickle/DTD.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+
-- ------------------------------------------------------------
{- |
diff --git a/src/Text/XML/HXT/Arrow/Pickle/Xml.hs b/src/Text/XML/HXT/Arrow/Pickle/Xml.hs
--- a/src/Text/XML/HXT/Arrow/Pickle/Xml.hs
+++ b/src/Text/XML/HXT/Arrow/Pickle/Xml.hs
@@ -42,6 +42,8 @@
import Control.Arrow.ListArrows
+import Data.Char (isDigit)
+import Data.List (foldl')
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as M
@@ -475,6 +477,7 @@
xpText :: PU String
xpText = xpTextDT scString1
+{-# INLINE xpText #-}
-- | Pickle a string into an XML text node
--
@@ -506,6 +509,7 @@
xpText0 :: PU String
xpText0 = xpText0DT scString1
+{-# INLINE xpText0 #-}
-- | Pickle a possibly empty string with a datatype description into an XML node.
--
@@ -536,6 +540,17 @@
val [(x,"")] = Just x
val _ = Nothing
+-- | Pickle an unsigned
+xpInt :: PU Int
+xpInt
+ = xpWrapMaybe (readMaybe, show) xpText
+ where
+ readMaybe xs
+ | all isDigit xs = Just . foldl' (\ r c -> 10 * r + (fromEnum c - fromEnum '0')) 0 $ xs
+ readMaybe ('-' : xs) = fmap (0 -) . readMaybe $ xs
+ readMaybe ('+' : xs) = readMaybe $ xs
+ readMaybe _ = Nothing
+
-- ------------------------------------------------------------
-- | Pickle an XmlTree by just adding it
@@ -641,7 +656,7 @@
xpList1 :: PU a -> PU [a]
xpList1 pa
= ( xpWrap (\ (x, xs) -> x : xs
- ,\ (x : xs) -> (x, xs)
+ ,\ x -> (head x, tail x)
) $
xpPair pa (xpList pa)
) { theSchema = scList1 (theSchema pa) }
diff --git a/src/Text/XML/HXT/Arrow/ProcessDocument.hs b/src/Text/XML/HXT/Arrow/ProcessDocument.hs
--- a/src/Text/XML/HXT/Arrow/ProcessDocument.hs
+++ b/src/Text/XML/HXT/Arrow/ProcessDocument.hs
@@ -2,7 +2,7 @@
{- |
Module : Text.XML.HXT.Arrow.ProcessDocument
- Copyright : Copyright (C) 2005 Uwe Schmidt
+ Copyright : Copyright (C) 2011 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
@@ -18,6 +18,7 @@
module Text.XML.HXT.Arrow.ProcessDocument
( parseXmlDocument
+ , parseXmlDocumentWithExpat
, parseHtmlDocument
, validateDocument
, propagateAndValidateNamespaces
@@ -31,6 +32,7 @@
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowTree
import Control.Arrow.ListArrow ( fromLA )
+import Control.Arrow.NTreeEdit
import Text.XML.HXT.DOM.Interface
@@ -40,7 +42,6 @@
import Text.XML.HXT.Arrow.ParserInterface ( parseXmlDoc
, parseHtmlDoc
- , substHtmlEntityRefs
)
import Text.XML.HXT.Arrow.Edit ( transfAllCharRef
@@ -61,6 +62,7 @@
)
import Text.XML.HXT.DTDValidation.Validation ( validate
, getDTDSubset
+ , generalEntitiesDefined
, transform
)
@@ -99,21 +101,59 @@
>>>
setDocumentStatusFromSystemState "parse XML document"
>>>
- processDTD
- >>>
- processGeneralEntities
- >>>
- transfAllCharRef
- >>>
- ( if validate'
- then validateDocument
- else this
+ ( ifA (fromLA getDTDSubset)
+ ( processDTD
+ >>>
+ ( processGeneralEntities -- DTD contains general entity definitions
+ `when`
+ fromLA generalEntitiesDefined
+ )
+ >>>
+ transfAllCharRef
+ >>>
+ ( if validate' -- validation only possible if DTD there
+ then validateDocument
+ else this
+ )
+ )
+ ( if validate' -- validation only consists of checking for undefined entity refs
+ -- predefined XML entity refs are substituted in the XML parser into char refs
+ -- so there is no need for an entity substitution
+ then traceMsg 2 "checkUndefinedEntityRefs: looking for undefined entity refs"
+ >>>
+ perform checkUndefinedEntityRefs
+ >>>
+ traceMsg 2 "checkUndefinedEntityRefs: looking for undefined entity refs done"
+ >>>
+ setDocumentStatusFromSystemState "decoding document"
+ else this
+ )
)
)
`when` documentStatusOk
+checkUndefinedEntityRefs :: IOStateArrow s XmlTree XmlTree
+checkUndefinedEntityRefs
+ = deep isEntityRef
+ >>>
+ getEntityRef
+ >>>
+ arr (\ en -> "general entity reference \"&" ++ en ++ ";\" is undefined")
+ >>>
+ mkError c_err
+ >>>
+ filterErrorMsg
+
-- ------------------------------------------------------------
+parseXmlDocumentWithExpat :: IOStateArrow s XmlTree XmlTree
+parseXmlDocumentWithExpat
+ = ( withoutUserState $< getSysVar theExpatParser
+ )
+ `when` documentStatusOk
+
+-- ------------------------------------------------------------
+
{- |
HTML parser
@@ -132,10 +172,9 @@
parseHtmlDocument
= ( perform ( getAttrValue a_source >>> traceValue 1 (("parseHtmlDoc: parse HTML document " ++) . show) )
>>>
- ( parseHtml $< getSysVar theTagSoup )
+ ( parseHtml $< getSysVar (theTagSoup .&&&. theExpat) )
>>>
- ( removeWarnings $< getSysVar (theWarnings .&&&. theTagSoup )
- )
+ ( removeWarnings $< getSysVar (theWarnings .&&&. theTagSoup) )
>>>
setDocumentStatusFromSystemState "parse HTML document"
>>>
@@ -150,9 +189,11 @@
)
`when` documentStatusOk
where
- parseHtml withTagSoup'
- | withTagSoup' = withoutUserState $< getSysVar theTagSoupParser -- withoutUserState parseHtmlTagSoup
+ parseHtml (withTagSoup', withExpat')
+ | withExpat' = withoutUserState $< getSysVar theExpatParser
+ | withTagSoup' = withoutUserState $< getSysVar theTagSoupParser
+
| otherwise = traceMsg 1 ("parse document with parsec HTML parser")
>>>
replaceChildren
@@ -161,23 +202,17 @@
xshow getChildren
) -- get string to be parsed
>>>
- parseHtmlDoc -- run parser
+ parseHtmlDoc -- run parser, entity substituion is done in parser
)
- >>>
- substHtmlEntityRefs -- substitute entity refs
removeWarnings (warnings, withTagSoup')
- | withTagSoup'
- &&
- not warnings = this
- | otherwise = processTopDownWithAttrl
- ( if warnings -- remove warnings inserted by parser and entity subst
- then filterErrorMsg
- else ( none
- `when`
- isError
- )
- )
+ | warnings = processTopDownWithAttrl -- remove warnings inserted by parser and entity subst
+ filterErrorMsg
+ | withTagSoup' = this -- warnings are not generated in tagsoup
+
+ | otherwise = fromLA $
+ editNTreeA [isError :-> none] -- remove all warnings from document
+
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Arrow/ReadDocument.hs b/src/Text/XML/HXT/Arrow/ReadDocument.hs
--- a/src/Text/XML/HXT/Arrow/ReadDocument.hs
+++ b/src/Text/XML/HXT/Arrow/ReadDocument.hs
@@ -39,6 +39,7 @@
import Text.XML.HXT.Arrow.ParserInterface
import Text.XML.HXT.Arrow.ProcessDocument ( getDocumentContents
, parseXmlDocument
+ , parseXmlDocumentWithExpat
, parseHtmlDocument
, propagateAndValidateNamespaces
, andValidateNamespaces
@@ -168,10 +169,10 @@
>>>
readD $< getSysVar theWithCache
where
- readD True = constA undefined -- just for generalizing the signature to: IOStateArrow s b XmlTree
+ readD True = constA undefined -- just for generalizing the signature to: IOStateArrow s b XmlTree
>>> -- instead of IOStateArrow s XmlTree XmlTree
(withoutUserState $< (getSysVar theCacheRead >>^ ($ src)))
- readD False = readDocument'' src
+ readD False = readDocument'' src
readDocument'' :: String -> IOStateArrow s b XmlTree
readDocument'' src
@@ -207,7 +208,8 @@
( replaceChildren none ) -- empty response, e.g. in if-modified-since request
( ( parse $< getSysVar (theValidate .&&&.
theIgnoreNoneXmlContents .&&&.
- theTagSoup
+ theTagSoup .&&&.
+ theExpat
)
)
>>>
@@ -270,28 +272,31 @@
(mi == mis || mis == "*")
)
|| r
- parse (validate, (removeNoneXml, withTagSoup'))
- | not isXmlOrHtml = if removeNoneXml
- then replaceChildren none -- don't parse, if mime type is not XML nor HTML
- else this -- but remove contents when option is set
+ parse (validate, (removeNoneXml, (withTagSoup', withExpat')))
+ | not isXmlOrHtml = if removeNoneXml
+ then replaceChildren none -- don't parse, if mime type is not XML nor HTML
+ else this -- but remove contents when option is set
| isHtml
- ||
+ ||
withTagSoup' = configSysVar (setS theLowerCaseNames isHtml)
>>>
parseHtmlDocument -- parse as HTML or with tagsoup XML
- | isXml = parseXmlDocument (not validateWithRelax && validate) -- parse as XML
+ | isXml = if withExpat'
+ then parseXmlDocumentWithExpat
+ else parseXmlDocument (not validateWithRelax && validate)
+ -- parse as XML
| otherwise = this -- suppress warning
checknamespaces (withNamespaces, withTagSoup')
| withNamespaces
- &&
- withTagSoup' = andValidateNamespaces -- propagation is done in tagsoup
+ &&
+ withTagSoup' = andValidateNamespaces -- propagation is done in tagsoup
| withNamespaces
||
- validateWithRelax = propagateAndValidateNamespaces -- RelaxNG requires correct namespaces
+ validateWithRelax = propagateAndValidateNamespaces -- RelaxNG requires correct namespaces
| otherwise = this
@@ -315,18 +320,18 @@
| otherwise = this
isHtml = ( not parseByMimeType && parseHtml ) -- force HTML
- ||
- ( parseByMimeType && isHtmlMimeType mimeType )
+ ||
+ ( parseByMimeType && isHtmlMimeType mimeType )
isXml = ( not parseByMimeType && not parseHtml )
- ||
- ( parseByMimeType
- &&
- ( isXmlMimeType mimeType
- ||
- null mimeType
- ) -- mime type is XML or not known
- )
+ ||
+ ( parseByMimeType
+ &&
+ ( isXmlMimeType mimeType
+ ||
+ null mimeType
+ ) -- mime type is XML or not known
+ )
isXmlOrHtml = isHtml || isXml
@@ -336,7 +341,7 @@
-- the arrow version of 'readDocument', the arrow input is the source URI
readFromDocument :: SysConfigList -> IOStateArrow s String XmlTree
-readFromDocument config = applyA ( arr $ readDocument config )
+readFromDocument config = applyA ( arr $ readDocument config )
-- ------------------------------------------------------------
@@ -348,9 +353,9 @@
--
-- Default encoding: No encoding is done, the String argument is taken as Unicode string
-readString :: SysConfigList -> String -> IOStateArrow s b XmlTree
+readString :: SysConfigList -> String -> IOStateArrow s b XmlTree
readString config content
- = readDocument (withInputEncoding unicodeString : config)
+ = readDocument (withInputEncoding unicodeString : config)
(stringProtocol ++ content)
-- ------------------------------------------------------------
@@ -358,9 +363,8 @@
-- |
-- the arrow version of 'readString', the arrow input is the source URI
-readFromString :: SysConfigList -> IOStateArrow s String XmlTree
-readFromString config
- = applyA ( arr $ readString config )
+readFromString :: SysConfigList -> IOStateArrow s String XmlTree
+readFromString config = applyA ( arr $ readString config )
-- ------------------------------------------------------------
@@ -372,26 +376,21 @@
-- Does not run in the IO monad
hread :: ArrowXml a => a String XmlTree
-hread
- = parseHtmlContent
- >>>
- substHtmlEntityRefs
- >>>
- processTopDown ( none `when` isError )
- >>>
- canonicalizeContents
+hread = fromLA $
+ parseHtmlContent -- substHtmlEntityRefs is done in parser
+ >>>
+ editNTreeA [isError :-> none] -- ignore all errors
+ >>>
+ canonicalizeContents
-- |
-- parse a string as XML content, substitute all predefined XML entity refs and canonicalize tree
-- (substitute char refs, ...)
xread :: ArrowXml a => a String XmlTree
-xread
- = parseXmlContent
- >>>
- substXmlEntityRefs
- >>>
- canonicalizeContents
+xread = parseXmlContent -- substXmlEntityRefs is done in parser
+ >>>
+ canonicalizeContents
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Arrow/WriteDocument.hs b/src/Text/XML/HXT/Arrow/WriteDocument.hs
--- a/src/Text/XML/HXT/Arrow/WriteDocument.hs
+++ b/src/Text/XML/HXT/Arrow/WriteDocument.hs
@@ -36,9 +36,7 @@
import Text.XML.HXT.Arrow.XmlState.RunIOStateArrow
( initialSysState
)
-import Text.XML.HXT.Arrow.Edit ( escapeHtmlDoc
- , escapeXmlDoc
- , haskellRepOfXmlDoc
+import Text.XML.HXT.Arrow.Edit ( haskellRepOfXmlDoc
, indentDoc
, addDefaultDTDecl
, preventEmptyElements
@@ -153,7 +151,7 @@
> )
-}
-writeDocument :: SysConfigList -> String -> IOStateArrow s XmlTree XmlTree
+writeDocument :: SysConfigList -> String -> IOStateArrow s XmlTree XmlTree
writeDocument config dst
= localSysEnv
$
@@ -161,12 +159,14 @@
>>>
perform ( (flip writeDocument') dst $< getSysVar theTextMode )
-writeDocument' :: Bool -> String -> IOStateArrow s XmlTree XmlTree
+writeDocument' :: Bool -> String -> IOStateArrow s XmlTree XmlTree
writeDocument' textMode dst
= ( traceMsg 1 ("writeDocument: destination is " ++ show dst)
>>>
( (flip prepareContents) encodeDocument $< getSysVar idS )
>>>
+ traceDoc "document after encoding"
+ >>>
putXmlDocument textMode dst
>>>
traceMsg 1 "writeDocument: finished"
@@ -204,7 +204,7 @@
-- |
-- indent and format output
-prepareContents :: ArrowXml a => XIOSysState -> (Bool -> String -> a XmlTree XmlTree) -> a XmlTree XmlTree
+prepareContents :: ArrowXml a => XIOSysState -> (Bool -> Bool -> String -> a XmlTree XmlTree) -> a XmlTree XmlTree
prepareContents config encodeDoc
= indent
>>>
@@ -212,7 +212,7 @@
>>>
format
where
- indent' = getS theIndent config
+ indent' = getS theIndent config
removeWS' = getS theRemoveWS config
showTree' = getS theShowTree config
showHaskell' = getS theShowHaskell config
@@ -237,26 +237,20 @@
| showHaskell' = haskellRepOfXmlDoc
| outHtml' = preventEmptyElements noEEsFor' True
>>>
- escapeHtmlDoc -- escape al XML and HTML chars >= 128
- >>>
encodeDoc -- convert doc into text with respect to output encoding with ASCII as default
- noPi' ( if null outEnc' then usAscii else outEnc' )
+ False noPi' ( if null outEnc' then usAscii else outEnc' )
| outXhtml' = preventEmptyElements noEEsFor' True
>>>
- escapeXmlDoc -- escape lt, gt, amp, quot,
- >>>
encodeDoc -- convert doc into text with respect to output encoding
- noPi' outEnc'
+ True noPi' outEnc'
| outXml' = ( if null noEEsFor'
then this
else preventEmptyElements noEEsFor' False
)
>>>
- escapeXmlDoc -- escape lt, gt, amp, quot,
- >>>
encodeDoc -- convert doc into text with respect to output encoding
- noPi' outEnc'
+ True noPi' outEnc'
| otherwise = this
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Arrow/XmlArrow.hs b/src/Text/XML/HXT/Arrow/XmlArrow.hs
--- a/src/Text/XML/HXT/Arrow/XmlArrow.hs
+++ b/src/Text/XML/HXT/Arrow/XmlArrow.hs
@@ -2,7 +2,7 @@
{- |
Module : Text.XML.HXT.Arrow.XmlArrow
- Copyright : Copyright (C) 2005-9 Uwe Schmidt
+ Copyright : Copyright (C) 2011 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
@@ -63,26 +63,36 @@
-- | test for text nodes
isText :: a XmlTree XmlTree
isText = isA XN.isText
+ {-# INLINE isText #-}
+ isBlob :: a XmlTree XmlTree
+ isBlob = isA XN.isBlob
+ {-# INLINE isBlob #-}
+
-- | test for char reference, used during parsing
isCharRef :: a XmlTree XmlTree
isCharRef = isA XN.isCharRef
+ {-# INLINE isCharRef #-}
-- | test for entity reference, used during parsing
isEntityRef :: a XmlTree XmlTree
isEntityRef = isA XN.isEntityRef
+ {-# INLINE isEntityRef #-}
-- | test for comment
isCmt :: a XmlTree XmlTree
isCmt = isA XN.isCmt
+ {-# INLINE isCmt #-}
-- | test for CDATA section, used during parsing
isCdata :: a XmlTree XmlTree
isCdata = isA XN.isCdata
+ {-# INLINE isCdata #-}
-- | test for processing instruction
isPi :: a XmlTree XmlTree
isPi = isA XN.isPi
+ {-# INLINE isPi #-}
-- | test for processing instruction \
isXmlPi :: a XmlTree XmlTree
@@ -91,22 +101,27 @@
-- | test for element
isElem :: a XmlTree XmlTree
isElem = isA XN.isElem
+ {-# INLINE isElem #-}
-- | test for DTD part, used during parsing
isDTD :: a XmlTree XmlTree
isDTD = isA XN.isDTD
+ {-# INLINE isDTD #-}
-- | test for attribute tree
isAttr :: a XmlTree XmlTree
isAttr = isA XN.isAttr
+ {-# INLINE isAttr #-}
-- | test for error message
isError :: a XmlTree XmlTree
isError = isA XN.isError
+ {-# INLINE isError #-}
-- | test for root node (element with name \"\/\")
isRoot :: a XmlTree XmlTree
isRoot = isA XN.isRoot
+ {-# INLINE isRoot #-}
-- | test for text nodes with text, for which a predicate holds
--
@@ -121,52 +136,61 @@
isWhiteSpace :: a XmlTree XmlTree
isWhiteSpace = hasText (all isXmlSpaceChar)
+ {-# INLINE isWhiteSpace #-}
-- |
-- test whether a node (element, attribute, pi) has a name with a special property
hasNameWith :: (QName -> Bool) -> a XmlTree XmlTree
hasNameWith p = (getQName >>> isA p) `guards` this
+ {-# INLINE hasNameWith #-}
-- |
-- test whether a node (element, attribute, pi) has a specific qualified name
-- useful only after namespace propagation
hasQName :: QName -> a XmlTree XmlTree
hasQName n = (getQName >>> isA (== n)) `guards` this
+ {-# INLINE hasQName #-}
-- |
-- test whether a node has a specific name (prefix:localPart ore localPart),
-- generally useful, even without namespace handling
hasName :: String -> a XmlTree XmlTree
hasName n = (getName >>> isA (== n)) `guards` this
+ {-# INLINE hasName #-}
-- |
-- test whether a node has a specific name as local part,
-- useful only after namespace propagation
hasLocalPart :: String -> a XmlTree XmlTree
hasLocalPart n = (getLocalPart >>> isA (== n)) `guards` this
+ {-# INLINE hasLocalPart #-}
-- |
-- test whether a node has a specific name prefix,
-- useful only after namespace propagation
hasNamePrefix :: String -> a XmlTree XmlTree
hasNamePrefix n = (getNamePrefix >>> isA (== n)) `guards` this
+ {-# INLINE hasNamePrefix #-}
-- |
-- test whether a node has a specific namespace URI
-- useful only after namespace propagation
hasNamespaceUri :: String -> a XmlTree XmlTree
hasNamespaceUri n = (getNamespaceUri >>> isA (== n)) `guards` this
+ {-# INLINE hasNamespaceUri #-}
-- |
-- test whether an element node has an attribute node with a specific name
hasAttr :: String -> a XmlTree XmlTree
hasAttr n = (getAttrl >>> hasName n) `guards` this
+ {-# INLINE hasAttr #-}
-- |
-- test whether an element node has an attribute node with a specific qualified name
hasQAttr :: QName -> a XmlTree XmlTree
hasQAttr n = (getAttrl >>> hasQName n) `guards` this
+ {-# INLINE hasQAttr #-}
-- |
-- test whether an element node has an attribute with a specific value
@@ -183,22 +207,32 @@
-- | text node construction arrow
mkText :: a String XmlTree
mkText = arr XN.mkText
+ {-# INLINE mkText #-}
+ -- | blob node construction arrow
+ mkBlob :: a Blob XmlTree
+ mkBlob = arr XN.mkBlob
+ {-# INLINE mkBlob #-}
+
-- | char reference construction arrow, useful for document output
mkCharRef :: a Int XmlTree
mkCharRef = arr XN.mkCharRef
+ {-# INLINE mkCharRef #-}
-- | entity reference construction arrow, useful for document output
mkEntityRef :: a String XmlTree
mkEntityRef = arr XN.mkEntityRef
+ {-# INLINE mkEntityRef #-}
-- | comment node construction, useful for document output
mkCmt :: a String XmlTree
mkCmt = arr XN.mkCmt
+ {-# INLINE mkCmt #-}
-- | CDATA construction, useful for document output
mkCdata :: a String XmlTree
mkCdata = arr XN.mkCdata
+ {-# INLINE mkCdata #-}
-- | error node construction, useful only internally
mkError :: Int -> a String XmlTree
@@ -211,6 +245,7 @@
mkElement n af cf = (listA af &&& listA cf)
>>>
arr2 (\ al cl -> XN.mkElement n al cl)
+
-- | attribute node construction:
-- | the attribute value is computed by applying an arrow to the input
mkAttr :: QName -> a n XmlTree -> a n XmlTree
@@ -235,164 +270,208 @@
mkqelem :: QName -> [a n XmlTree] -> [a n XmlTree] -> a n XmlTree
mkqelem n afs cfs = mkElement n (catA afs) (catA cfs)
+ {-# INLINE mkqelem #-}
-- | convenient arrow for element construction with strings instead of qualified names as element names, see also 'mkElement' and 'mkelem'
mkelem :: String -> [a n XmlTree] -> [a n XmlTree] -> a n XmlTree
mkelem n afs cfs = mkElement (mkName n) (catA afs) (catA cfs)
+ {-# INLINE mkelem #-}
-- | convenient arrow for element constrution with attributes but without content, simple variant of 'mkelem' and 'mkElement'
aelem :: String -> [a n XmlTree] -> a n XmlTree
aelem n afs = catA afs >. \ al -> XN.mkElement (mkName n) al []
+ {-# INLINE aelem #-}
-- | convenient arrow for simple element constrution without attributes, simple variant of 'mkelem' and 'mkElement'
selem :: String -> [a n XmlTree] -> a n XmlTree
selem n cfs = catA cfs >. XN.mkElement (mkName n) []
+ {-# INLINE selem #-}
-- | convenient arrow for constrution of empty elements without attributes, simple variant of 'mkelem' and 'mkElement'
eelem :: String -> a n XmlTree
eelem n = constA (XN.mkElement (mkName n) [] [])
+ {-# INLINE eelem #-}
-- | construction of an element node with name \"\/\" for document roots
root :: [a n XmlTree] -> [a n XmlTree] -> a n XmlTree
root = mkelem t_root
+ {-# INLINE root #-}
-- | alias for 'mkAttr'
qattr :: QName -> a n XmlTree -> a n XmlTree
qattr = mkAttr
+ {-# INLINE qattr #-}
-- | convenient arrow for attribute constrution, simple variant of 'mkAttr'
attr :: String -> a n XmlTree -> a n XmlTree
attr = mkAttr . mkName
+ {-# INLINE attr #-}
-- constant arrows (ignoring the input) for tree construction ------------------------------
-- | constant arrow for text nodes
txt :: String -> a n XmlTree
txt = constA . XN.mkText
+ {-# INLINE txt #-}
+ -- | constant arrow for blob nodes
+ blb :: Blob -> a n XmlTree
+ blb = constA . XN.mkBlob
+ {-# INLINE blb #-}
+
-- | constant arrow for char reference nodes
charRef :: Int -> a n XmlTree
charRef = constA . XN.mkCharRef
+ {-# INLINE charRef #-}
-- | constant arrow for entity reference nodes
entityRef :: String -> a n XmlTree
entityRef = constA . XN.mkEntityRef
+ {-# INLINE entityRef #-}
-- | constant arrow for comment
cmt :: String -> a n XmlTree
cmt = constA . XN.mkCmt
+ {-# INLINE cmt #-}
-- | constant arrow for warning
warn :: String -> a n XmlTree
warn = constA . (XN.mkError c_warn)
+ {-# INLINE warn #-}
-- | constant arrow for errors
err :: String -> a n XmlTree
err = constA . (XN.mkError c_err)
+ {-# INLINE err #-}
-- | constant arrow for fatal errors
fatal :: String -> a n XmlTree
fatal = constA . (XN.mkError c_fatal)
+ {-# INLINE fatal #-}
-- | constant arrow for simple processing instructions, see 'mkPi'
spi :: String -> String -> a n XmlTree
- spi piName piCont = constA (XN.mkPi (mkName piName) [XN.mkText piCont])
+ spi piName piCont = constA (XN.mkPi (mkName piName) [XN.mkAttr (mkName a_value) [XN.mkText piCont]])
+ {-# INLINE spi #-}
-- | constant arrow for attribute nodes, attribute name is a qualified name and value is a text,
-- | see also 'mkAttr', 'qattr', 'attr'
sqattr :: QName -> String -> a n XmlTree
sqattr an av = constA (XN.mkAttr an [XN.mkText av])
+ {-# INLINE sqattr #-}
-- | constant arrow for attribute nodes, attribute name and value are
-- | given by parameters, see 'mkAttr'
sattr :: String -> String -> a n XmlTree
sattr an av = constA (XN.mkAttr (mkName an) [XN.mkText av])
+ {-# INLINE sattr #-}
-- selector arrows --------------------------------------------------
-- | select the text of a text node
getText :: a XmlTree String
getText = arrL (maybeToList . XN.getText)
+ {-# INLINE getText #-}
-- | select the value of a char reference
getCharRef :: a XmlTree Int
getCharRef = arrL (maybeToList . XN.getCharRef)
+ {-# INLINE getCharRef #-}
-- | select the name of a entity reference node
getEntityRef :: a XmlTree String
getEntityRef = arrL (maybeToList . XN.getEntityRef)
+ {-# INLINE getEntityRef #-}
-- | select the comment of a comment node
getCmt :: a XmlTree String
getCmt = arrL (maybeToList . XN.getCmt)
+ {-# INLINE getCmt #-}
-- | select the content of a CDATA node
getCdata :: a XmlTree String
getCdata = arrL (maybeToList . XN.getCdata)
+ {-# INLINE getCdata #-}
-- | select the name of a processing instruction
getPiName :: a XmlTree QName
getPiName = arrL (maybeToList . XN.getPiName)
+ {-# INLINE getPiName #-}
-- | select the content of a processing instruction
getPiContent :: a XmlTree XmlTree
getPiContent = arrL (fromMaybe [] . XN.getPiContent)
+ {-# INLINE getPiContent #-}
-- | select the name of an element node
getElemName :: a XmlTree QName
getElemName = arrL (maybeToList . XN.getElemName)
+ {-# INLINE getElemName #-}
-- | select the attribute list of an element node
getAttrl :: a XmlTree XmlTree
getAttrl = arrL (fromMaybe [] . XN.getAttrl)
+ {-# INLINE getAttrl #-}
-- | select the DTD type of a DTD node
getDTDPart :: a XmlTree DTDElem
getDTDPart = arrL (maybeToList . XN.getDTDPart)
+ {-# INLINE getDTDPart #-}
-- | select the DTD attributes of a DTD node
getDTDAttrl :: a XmlTree Attributes
getDTDAttrl = arrL (maybeToList . XN.getDTDAttrl)
+ {-# INLINE getDTDAttrl #-}
-- | select the name of an attribute
getAttrName :: a XmlTree QName
getAttrName = arrL (maybeToList . XN.getAttrName)
+ {-# INLINE getAttrName #-}
-- | select the error level (c_warn, c_err, c_fatal) from an error node
getErrorLevel :: a XmlTree Int
getErrorLevel = arrL (maybeToList . XN.getErrorLevel)
+ {-# INLINE getErrorLevel #-}
-- | select the error message from an error node
getErrorMsg :: a XmlTree String
getErrorMsg = arrL (maybeToList . XN.getErrorMsg)
+ {-# INLINE getErrorMsg #-}
-- | select the qualified name from an element, attribute or pi
getQName :: a XmlTree QName
getQName = arrL (maybeToList . XN.getName)
+ {-# INLINE getQName #-}
-- | select the prefix:localPart or localPart from an element, attribute or pi
getName :: a XmlTree String
getName = arrL (maybeToList . XN.getQualifiedName)
+ {-# INLINE getName #-}
-- | select the univeral name ({namespace URI} ++ localPart)
getUniversalName :: a XmlTree String
getUniversalName = arrL (maybeToList . XN.getUniversalName)
+ {-# INLINE getUniversalName #-}
-- | select the univeral name (namespace URI ++ localPart)
getUniversalUri :: a XmlTree String
getUniversalUri = arrL (maybeToList . XN.getUniversalUri)
+ {-# INLINE getUniversalUri #-}
-- | select the local part
getLocalPart :: a XmlTree String
getLocalPart = arrL (maybeToList . XN.getLocalPart)
+ {-# INLINE getLocalPart #-}
-- | select the name prefix
getNamePrefix :: a XmlTree String
getNamePrefix = arrL (maybeToList . XN.getNamePrefix)
+ {-# INLINE getNamePrefix #-}
-- | select the namespace URI
getNamespaceUri :: a XmlTree String
getNamespaceUri = arrL (maybeToList . XN.getNamespaceUri)
+ {-# INLINE getNamespaceUri #-}
-- | select the value of an attribute of an element node,
-- always succeeds with empty string as default value \"\"
@@ -418,6 +497,10 @@
changeText :: (String -> String) -> a XmlTree XmlTree
changeText cf = arr (XN.changeText cf) `when` isText
+ -- | edit the blob of a blob node
+ changeBlob :: (Blob -> Blob) -> a XmlTree XmlTree
+ changeBlob cf = arr (XN.changeBlob cf) `when` isBlob
+
-- | edit the comment string of a comment node
changeCmt :: (String -> String) -> a XmlTree XmlTree
changeCmt cf = arr (XN.changeCmt cf) `when` isCmt
@@ -461,30 +544,37 @@
-- | replace an element, attribute or pi name
setQName :: QName -> a XmlTree XmlTree
setQName n = changeQName (const n)
+ {-# INLINE setQName #-}
-- | replace an element name
setElemName :: QName -> a XmlTree XmlTree
setElemName n = changeElemName (const n)
+ {-# INLINE setElemName #-}
-- | replace an attribute name
setAttrName :: QName -> a XmlTree XmlTree
setAttrName n = changeAttrName (const n)
+ {-# INLINE setAttrName #-}
-- | replace an element name
setPiName :: QName -> a XmlTree XmlTree
setPiName n = changePiName (const n)
+ {-# INLINE setPiName #-}
-- | replace an atribute list of an element node
setAttrl :: a XmlTree XmlTree -> a XmlTree XmlTree
setAttrl = changeAttrl (const id) -- (\ x y -> y)
+ {-# INLINE setAttrl #-}
-- | add a list of attributes to an element
addAttrl :: a XmlTree XmlTree -> a XmlTree XmlTree
addAttrl = changeAttrl (XN.mergeAttrl)
+ {-# INLINE addAttrl #-}
-- | add (or replace) an attribute
addAttr :: String -> String -> a XmlTree XmlTree
addAttr an av = addAttrl (sattr an av)
+ {-# INLINE addAttr #-}
-- | remove an attribute
removeAttr :: String -> a XmlTree XmlTree
@@ -551,9 +641,20 @@
| otherwise
= XN.changeChildren (++ [c]) t
+
-- | apply an arrow to the input and convert the resulting XML trees into a string representation
+
xshow :: a n XmlTree -> a n String
xshow f = f >. XS.xshow
+ {-# INLINE xshow #-}
+
+
+ -- | apply an arrow to the input and convert the resulting XML trees into a string representation
+
+ xshowBlob :: a n XmlTree -> a n Blob
+ xshowBlob f = f >. XS.xshowBlob
+ {-# INLINE xshowBlob #-}
+
{- | Document Type Definition arrows
diff --git a/src/Text/XML/HXT/Arrow/XmlRegex.hs b/src/Text/XML/HXT/Arrow/XmlRegex.hs
--- a/src/Text/XML/HXT/Arrow/XmlRegex.hs
+++ b/src/Text/XML/HXT/Arrow/XmlRegex.hs
@@ -133,8 +133,8 @@
mkPrimA :: LA XmlTree XmlTree -> XmlRegex
mkPrimA a = mkPrim (not . null . runLA a)
-mkDot :: XmlRegex
-mkDot = Dot
+mkDot :: XmlRegex
+mkDot = Dot
mkStar :: XmlRegex -> XmlRegex
mkStar (Zero _) = mkUnit -- {}* == ()
diff --git a/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs b/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs
--- a/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs
+++ b/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs
@@ -18,6 +18,7 @@
where
import Control.Arrow -- arrow classes
+import Control.Arrow.ArrowList
import Control.Arrow.IOStateListArrow
import Text.XML.HXT.DOM.Interface
@@ -74,6 +75,10 @@
initialSysWriter = XIOwrt
{ xioErrorStatus = c_ok
, xioErrorMsgList = []
+ , xioExpatErrors = none
+ , xioRelaxNoOfErrors = 0
+ , xioRelaxDefineId = 0
+ , xioRelaxAttrList = []
}
initialSysEnv :: XIOSysEnv
@@ -121,6 +126,8 @@
, xioCanonicalize = True
, xioIgnoreNoneXmlContents = False
, xioTagSoupParser = dummyTagSoupParser
+ , xioExpat = False
+ , xioExpatParser = dummyExpatParser
}
initialOutputConfig :: XIOOutputConfig
@@ -144,9 +151,6 @@
, xioRelaxValidateExtRef = True
, xioRelaxValidateInclude = True
, xioRelaxCollectErrors = True
- , xioRelaxNoOfErrors = 0
- , xioRelaxDefineId = 0
- , xioRelaxAttrList = []
, xioRelaxValidator = dummyRelaxValidator
}
@@ -183,6 +187,14 @@
[ "TagSoup parser not configured,"
, "please install package hxt-tagsoup"
, " and use 'withTagSoup' parser config option from this package"
+ ]
+
+dummyExpatParser :: IOSArrow b b
+dummyExpatParser = issueFatal $
+ unlines $
+ [ "Expat parser not configured,"
+ , "please install package hxt-expat"
+ , " and use 'withExpat' parser config option from this package"
]
dummyRelaxValidator :: IOSArrow b b
diff --git a/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs b/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs
--- a/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs
+++ b/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs
@@ -162,6 +162,10 @@
data XIOSysWriter = XIOwrt { xioErrorStatus :: ! Int
, xioErrorMsgList :: ! XmlTrees
+ , xioExpatErrors :: IOSArrow XmlTree XmlTree
+ , xioRelaxNoOfErrors :: ! Int
+ , xioRelaxDefineId :: ! Int
+ , xioRelaxAttrList :: AssocList String XmlTrees
}
data XIOSysEnv = XIOEnv { xioTraceLevel :: ! Int
@@ -203,6 +207,8 @@
, xioIgnoreNoneXmlContents :: ! Bool
, xioTagSoup :: ! Bool
, xioTagSoupParser :: IOSArrow XmlTree XmlTree
+ , xioExpat :: ! Bool
+ , xioExpatParser :: IOSArrow XmlTree XmlTree
}
data XIOOutputConfig = XIOOcfg { xioIndent :: ! Bool
@@ -224,10 +230,7 @@
, xioRelaxValidateExtRef :: ! Bool
, xioRelaxValidateInclude :: ! Bool
, xioRelaxCollectErrors :: ! Bool
- , xioRelaxNoOfErrors :: ! Int
- , xioRelaxDefineId :: ! Int
- , xioRelaxAttrList :: AssocList String XmlTrees
- , xioRelaxValidator :: IOSArrow XmlTree XmlTree
+ , xioRelaxValidator :: IOSArrow XmlTree XmlTree
}
data XIOCacheConfig = XIOCch { xioBinaryCompression :: CompressionFct
@@ -278,6 +281,27 @@
, setS = \ x s -> s { xioErrorMsgList = x }
}
+theRelaxNoOfErrors :: Selector XIOSysState Int
+theRelaxNoOfErrors = theSysWriter
+ >>>
+ S { getS = xioRelaxNoOfErrors
+ , setS = \ x s -> s { xioRelaxNoOfErrors = x}
+ }
+
+theRelaxDefineId :: Selector XIOSysState Int
+theRelaxDefineId = theSysWriter
+ >>>
+ S { getS = xioRelaxDefineId
+ , setS = \ x s -> s { xioRelaxDefineId = x}
+ }
+
+theRelaxAttrList :: Selector XIOSysState (AssocList String XmlTrees)
+theRelaxAttrList = theSysWriter
+ >>>
+ S { getS = xioRelaxAttrList
+ , setS = \ x s -> s { xioRelaxAttrList = x}
+ }
+
-- ----------------------------------------
theSysEnv :: Selector XIOSysState XIOSysEnv
@@ -464,27 +488,6 @@
, setS = \ x s -> s { xioRelaxCollectErrors = x}
}
-theRelaxNoOfErrors :: Selector XIOSysState Int
-theRelaxNoOfErrors = theRelaxConfig
- >>>
- S { getS = xioRelaxNoOfErrors
- , setS = \ x s -> s { xioRelaxNoOfErrors = x}
- }
-
-theRelaxDefineId :: Selector XIOSysState Int
-theRelaxDefineId = theRelaxConfig
- >>>
- S { getS = xioRelaxDefineId
- , setS = \ x s -> s { xioRelaxDefineId = x}
- }
-
-theRelaxAttrList :: Selector XIOSysState (AssocList String XmlTrees)
-theRelaxAttrList = theRelaxConfig
- >>>
- S { getS = xioRelaxAttrList
- , setS = \ x s -> s { xioRelaxAttrList = x}
- }
-
theRelaxValidator :: Selector XIOSysState (IOSArrow XmlTree XmlTree)
theRelaxValidator = theRelaxConfig
>>>
@@ -663,6 +666,27 @@
>>>
S { getS = xioTagSoupParser
, setS = \ x s -> s { xioTagSoupParser = x }
+ }
+
+theExpat :: Selector XIOSysState Bool
+theExpat = theParseConfig
+ >>>
+ S { getS = xioExpat
+ , setS = \ x s -> s { xioExpat = x }
+ }
+
+theExpatParser :: Selector XIOSysState (IOSArrow XmlTree XmlTree)
+theExpatParser = theParseConfig
+ >>>
+ S { getS = xioExpatParser
+ , setS = \ x s -> s { xioExpatParser = x }
+ }
+
+theExpatErrors :: Selector XIOSysState (IOSArrow XmlTree XmlTree)
+theExpatErrors = theSysWriter
+ >>>
+ S { getS = xioExpatErrors
+ , setS = \ x s -> s { xioExpatErrors = x }
}
-- ----------------------------------------
diff --git a/src/Text/XML/HXT/DOM/FormatXmlTree.hs b/src/Text/XML/HXT/DOM/FormatXmlTree.hs
--- a/src/Text/XML/HXT/DOM/FormatXmlTree.hs
+++ b/src/Text/XML/HXT/DOM/FormatXmlTree.hs
@@ -21,12 +21,12 @@
)
where
+import Data.Maybe
+
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.DOM.ShowXml
import Text.XML.HXT.DOM.XmlNode
-import Data.Maybe
-
-- ------------------------------------------------------------
@@ -49,7 +49,7 @@
where
showName :: XNode -> String
-showName = maybe "" showQn . getName
+showName = maybe "" show . getName
showAtts :: XNode -> String
showAtts = concatMap showAl . fromMaybe [] . getAttrl
@@ -57,18 +57,9 @@
showAl :: XmlTree -> String
showAl t -- (NTree (XAttr an) av)
| isAttr t
- = "\n| " ++ (maybe "" showQn . getName $ t) ++ "=" ++ show (xshow . getChildren $ t)
+ = "\n| " ++ (maybe "" show . getName $ t) ++ "=" ++ show (xshow . getChildren $ t)
| otherwise
= show t
-
-showQn :: QName -> String
-showQn n
- | null ns
- = show $ qualifiedName n
- | otherwise
- = show $ "{" ++ ns ++ "}" ++ qualifiedName n
- where
- ns = namespaceUri n
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/DOM/Interface.hs b/src/Text/XML/HXT/DOM/Interface.hs
--- a/src/Text/XML/HXT/DOM/Interface.hs
+++ b/src/Text/XML/HXT/DOM/Interface.hs
@@ -30,6 +30,7 @@
import Text.XML.HXT.DOM.TypeDefs -- XML Tree types
import Text.XML.HXT.DOM.Util
import Text.XML.HXT.DOM.MimeTypes -- mime types related stuff
+
import Data.String.EncodingNames -- char encoding names for readDocument
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/DOM/MimeTypes.hs b/src/Text/XML/HXT/DOM/MimeTypes.hs
--- a/src/Text/XML/HXT/DOM/MimeTypes.hs
+++ b/src/Text/XML/HXT/DOM/MimeTypes.hs
@@ -47,6 +47,7 @@
text_html,
text_pdf,
text_plain,
+ text_xdtd,
text_xml,
text_xml_external_parsed_entity :: String
@@ -58,6 +59,7 @@
text_html = "text/html"
text_pdf = "text/pdf"
text_plain = "text/plain"
+text_xdtd = "text/x-dtd"
text_xml = "text/xml"
text_xml_external_parsed_entity = "text/xml-external-parsed-entity"
@@ -74,6 +76,7 @@
, application_xml_dtd
, text_xml
, text_xml_external_parsed_entity
+ , text_xdtd
]
||
"+xml" `isSuffixOf` t -- application/mathml+xml
diff --git a/src/Text/XML/HXT/DOM/QualifiedName.hs b/src/Text/XML/HXT/DOM/QualifiedName.hs
--- a/src/Text/XML/HXT/DOM/QualifiedName.hs
+++ b/src/Text/XML/HXT/DOM/QualifiedName.hs
@@ -4,14 +4,14 @@
{- |
Module : Text.XML.HXT.DOM.QualifiedName
- Copyright : Copyright (C) 2008 Uwe Schmidt
+ Copyright : Copyright (C) 2011 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
Stability : stable
Portability: portable
- The core data types of the HXT DOM.
+ The types and functions for qualified names
-}
@@ -19,7 +19,7 @@
module Text.XML.HXT.DOM.QualifiedName
( QName
- , XName
+ , XName(unXN)
, NsEnv
, mkQName
@@ -39,6 +39,7 @@
, newXName
, nullXName
, isNullXName
+ , newQName
, mkQName'
, namePrefix'
@@ -50,6 +51,7 @@
, setNamespaceUri'
, qualifiedName
+ , qualifiedName'
, universalName
, universalUri
, buildUniversalName
@@ -84,6 +86,7 @@
import Control.Concurrent.MVar
import Control.DeepSeq
+import Control.FlatSeq
import Data.AssocList
import Data.Binary
@@ -110,9 +113,46 @@
-- Names are always reduced to normal form, and they are stored internally in a name cache
-- for sharing equal names by the same data structure
-type XName = Atom
+data XName = XN { _idXN :: ! Int -- for optimization of equality test, see Eq instance
+ , unXN :: String
+ }
+ deriving (Typeable)
+instance Eq XName where
+ (XN id1 _) == (XN id2 _) = id1 == id2
+
+instance Ord XName where
+ compare (XN _ n1) (XN _ n2) = compare n1 n2
+{-
+instance Read XName where
+ readsPrec p str = [ (newXName x, y) | (x, y) <- readsPrec p str ]
+
+instance Show XName where
+ show (XN _ s) = show s
+-}
+instance NFData XName where
+ rnf (XN _ s) = rnf s
+
+instance WNFData XName where
+ rwnf (XN _ s) = rnf s
+
+instance Binary XName where
+ put (XN _ s) = put s
+ get = do
+ s <- get
+ return $! newXName s
+
+-----------------------------------------------------------------------------
+
-- |
+-- Type for the namespace association list, used when propagating namespaces by
+-- modifying the 'QName' values in a tree
+
+type NsEnv = AssocList XName XName
+
+-----------------------------------------------------------------------------
+
+-- |
-- Namespace support for element and attribute names.
--
-- A qualified name consists of a name prefix, a local name
@@ -121,120 +161,81 @@
-- When dealing with namespaces, the document tree must be processed by 'Text.XML.HXT.Arrow.Namespace.propagateNamespaces'
-- to split names of structure \"prefix:localPart\" and label the name with the apropriate namespace uri
-data QName = LP ! XName
- | PX ! XName ! QName
- | NS ! XName ! QName
- deriving (Ord, Show, Read, Typeable)
-
--- |
--- Type for the namespace association list, used when propagating namespaces by
--- modifying the 'QName' values in a tree
-
-type NsEnv = AssocList XName XName
+data QName = QN { localPart' :: ! XName
+ , namePrefix' :: ! XName
+ , namespaceUri' :: ! XName
+ }
+ deriving (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
+-- local parts are equal
instance Eq QName where
- (LP lp1) == (LP lp2) = lp1 == lp2
- (PX px1 qn1) == (PX px2 qn2) = px1 == px2 && qn1== qn2
- (NS ns1 qn1) == (NS ns2 qn2) = ns1 == ns2 && localPart' qn1 == localPart' qn2
- n1@(PX _ _) == n2@(LP _) = qualifiedName n1 == qualifiedName n2
- n1@(LP _) == n2@(PX _ _) = qualifiedName n1 == qualifiedName n2
- _ == _ = False
+ (QN lp1 px1 ns1) == (QN lp2 px2 ns2)
+ | ns1 /= ns2 = False -- namespaces are set and differ
+ | not (isNullXName ns1) = lp1 == lp2 -- namespaces are set and are equal: local parts must be equal
+ | otherwise = lp1 == lp2 -- no namespaces are set: local parts must be equal
+ && -- and prefixes are not set or they are equal
+ px1 == px2
--- the 4. and 5. rule are only neccessary when someone
--- uses XML names not in a systematical way
--- and does things like "mkName("x:y") == mkPrefixLocalPart("x","y")
+instance NFData QName
+instance WNFData QName
-instance NFData QName where
+instance Show QName where
+ show = showQN
+-- -----------------------------------------------------------------------------
+
instance Binary QName where
- put qn = let
- px = namePrefix qn
- lp = localPart qn
- ns = namespaceUri qn
- in
- put px >> put lp >> put ns
+ put (QN lp px ns) = put (unXN px) >>
+ put (unXN lp) >>
+ put (unXN ns)
get = do
px <- get
lp <- get
ns <- get
- return $ mkQName px lp ns
+ return $! newNsName lp px ns
+ -- ^^
+ -- strict apply !!!
+ -- build the QNames strict, else the name sharing optimization will not be in effect
-- -----------------------------------------------------------------------------
-newXName :: String -> XName
-newXName = newAtom
-
isNullXName :: XName -> Bool
isNullXName = (== nullXName)
-
-nullXName :: XName
-nullXName = newXName ""
-
--- | access name prefix
-
-namePrefix' :: QName -> XName
-namePrefix' (LP _) = nullXName
-namePrefix' (PX px _) = px
-namePrefix' (NS _ n) = namePrefix' n
-
--- | access local part
-
-localPart' :: QName -> XName
-localPart' (LP lp) = lp
-localPart' (PX _ n) = localPart' n
-localPart' (NS _ n) = localPart' n
-
--- | access namespace uri
-
-namespaceUri' :: QName -> XName
-namespaceUri' (NS ns _) = ns
-namespaceUri' _ = nullXName
+{-# INLINE isNullXName #-}
namePrefix :: QName -> String
-namePrefix = show . namePrefix'
+namePrefix = unXN . namePrefix'
+{-# INLINE namePrefix #-}
localPart :: QName -> String
-localPart = show . localPart'
+localPart = unXN . localPart'
+{-# INLINE localPart #-}
namespaceUri :: QName -> String
-namespaceUri = show . namespaceUri'
+namespaceUri = unXN . namespaceUri'
+{-# INLINE namespaceUri #-}
-- ------------------------------------------------------------
-- | set name prefix
-setNamespaceUri' :: XName -> QName -> QName
-setNamespaceUri' ns (NS _ n) = if isNullXName ns
- then n
- else NS ns n
-setNamespaceUri' ns n = if isNullXName ns
- then n
- else NS ns n
+setNamespaceUri' :: XName -> QName -> QName
+setNamespaceUri' ns (QN lp px _ns) = newQName lp px ns
-- | set local part
-setLocalPart' :: XName -> QName -> QName
-setLocalPart' lp (LP _) = LP lp
-setLocalPart' lp (PX px n) = PX px (setLocalPart' lp n)
-setLocalPart' lp (NS ns n) = NS ns (setLocalPart' lp n)
+setLocalPart' :: XName -> QName -> QName
+setLocalPart' lp (QN _lp px ns) = newQName lp px ns
-- | set name prefix
-setNamePrefix' :: XName -> QName -> QName
-setNamePrefix' px (PX _ n) = if px == nullXName
- then n
- else PX px n
-setNamePrefix' px n@(LP _) = if px == nullXName
- then n
- else PX px n
-setNamePrefix' px (NS ns n) = NS ns (setNamePrefix' px n)
-
+setNamePrefix' :: XName -> QName -> QName
+setNamePrefix' px (QN lp _px ns) = newQName lp px ns
-- ------------------------------------------------------------
@@ -242,10 +243,17 @@
-- builds the full name \"prefix:localPart\", if prefix is not null, else the local part is the result
qualifiedName :: QName -> String
-qualifiedName (LP lp) = show lp
-qualifiedName (PX px n) = show px ++ (':' : qualifiedName n)
-qualifiedName (NS _ n) = qualifiedName n
+qualifiedName (QN lp px _ns)
+ | isNullXName px = unXN lp
+ | otherwise = unXN px ++ (':' : unXN lp)
+-- | functional list version of qualifiedName used in xshow
+
+qualifiedName' :: QName -> String -> String
+qualifiedName' (QN lp px _ns)
+ | isNullXName px = (unXN lp ++)
+ | otherwise = (unXN px ++) . (':' :) . (unXN lp ++)
+
-- |
-- builds the \"universal\" name, that is the namespace uri surrounded with \"{\" and \"}\" followed by the local part
-- (specialisation of 'buildUniversalName')
@@ -266,21 +274,24 @@
-- namespace uri and local part are combined with the combining function given by the first parameter
buildUniversalName :: (String -> String -> String) -> QName -> String
-buildUniversalName bf (NS ns n) = show ns `bf` localPart n
-buildUniversalName _ n = localPart n
+buildUniversalName bf n@(QN _lp _px ns)
+ | isNullXName ns = localPart n
+ | otherwise = unXN ns `bf` localPart n
+showQN :: QName -> String
+showQN n
+ | null ns = show $ qualifiedName n
+ | otherwise = show $ "{" ++ ns ++ "}" ++ qualifiedName n
+ where
+ ns = namespaceUri n
+
-- ------------------------------------------------------------
--
-- internal XName functions
mkQName' :: XName -> XName -> XName -> QName
-mkQName' px lp ns
- | isNullXName ns = px_lp
- | otherwise = NS ns px_lp
- where
- px_lp
- | isNullXName px = LP lp
- | otherwise = PX px (LP lp)
+mkQName' px lp ns = newQName lp px ns
+{-# DEPRECATED mkQName' "use newQName instead with lp px ns param seq " #-}
-- ------------------------------------------------------------
@@ -291,10 +302,8 @@
mkPrefixLocalPart :: String -> String -> QName
mkPrefixLocalPart px lp
- | null px = n1
- | otherwise = PX (newXName px) n1
- where
- n1 = LP (newXName lp)
+ | null px = newLpName lp
+ | otherwise = newPxName lp px
-- |
-- constructs a simple, namespace unaware name.
@@ -307,10 +316,10 @@
| (':' `elem` n)
&&
not (null px) -- more restrictive: isWellformedQualifiedName n
- = mkPrefixLocalPart px lp
- | otherwise = mkPrefixLocalPart "" n
+ = newPxName lp px
+ | otherwise = newLpName n
where
- (px, (_:lp)) = span (/= ':') n
+ (px, (_ : lp)) = span (/= ':') n
-- |
-- constructs a complete qualified name with 'namePrefix', 'localPart' and 'namespaceUri'.
@@ -320,10 +329,8 @@
mkQName :: String -> String -> String -> QName
mkQName px lp ns
- | null ns = n1
- | otherwise = NS (newXName ns) n1
- where
- n1 = mkPrefixLocalPart px lp
+ | null ns = mkPrefixLocalPart px lp
+ | otherwise = newNsName lp px ns
-- ------------------------------------------------------------
@@ -332,6 +339,7 @@
mkSNsName :: String -> QName
mkSNsName = mkName
+{-# DEPRECATED mkSNsName "use mkName instead" #-}
-- |
-- constructs a simple, namespace aware name, with prefix:localPart as first parameter,
@@ -339,10 +347,18 @@
--
-- see also 'mkName', 'mkPrefixLocalPart'
-mkNsName :: String -> String -> QName
+{-
+mkNsName :: String -> String -> QName
+mkNsName n ns = trace ("mkNsName: " ++ show n ++ " " ++ show ns) (mkNsName' n ns)
+-}
+
+mkNsName :: String -> String -> QName
mkNsName n ns
- | null ns = mkName n
- | otherwise = NS (newXName ns) (mkName n)
+ | null ns = qn
+ | otherwise = setNamespaceUri' ns' qn
+ where
+ qn = mkName n
+ ns' = newXName ns
-- ------------------------------------------------------------
@@ -388,27 +404,8 @@
-- see 'isWellformedQName' and 'isWellformedQualifiedName' for error checking.
setNamespace :: NsEnv -> QName -> QName
-setNamespace env n@(PX px _) = attachNS env px n -- none empty prefix found
-setNamespace env n@(LP _) = attachNS env nullXName n -- use default namespace uri
-setNamespace env (NS _ n) = setNamespace env n
-
-attachNS :: NsEnv -> XName -> QName -> QName
-attachNS env px n1 = maybe n1 (\ ns -> NS ns n1) . lookup px $ env
-
-xmlnsNamespaceXName :: XName
-xmlnsNamespaceXName = newXName xmlnsNamespace
-
-xmlnsXName :: XName
-xmlnsXName = newXName a_xmlns
-
-xmlnsQN :: QName
-xmlnsQN = NS xmlnsNamespaceXName (LP xmlnsXName)
-
-xmlNamespaceXName :: XName
-xmlNamespaceXName = newXName xmlNamespace
-
-xmlXName :: XName
-xmlXName = newXName a_xml
+setNamespace env n@(QN lp px _ns)
+ = maybe n (\ ns -> newQName lp px ns) . lookup px $ env
-- -----------------------------------------------------------------------------
--
@@ -440,11 +437,13 @@
-- predicate is used in filter 'valdateNamespaces'.
isWellformedQName :: QName -> Bool
-isWellformedQName (LP lp) = isNCName . show $ lp -- rule [8] XML Namespaces
-isWellformedQName (PX px n) = (isNCName . show) px -- rule [7] XML Namespaces
+isWellformedQName (QN lp px _ns)
+ = (isNCName . unXN) lp -- rule [8] XML Namespaces
&&
- isWellformedQName n
-isWellformedQName (NS _ n) = isWellformedQName n
+ ( isNullXName px
+ ||
+ (isNCName . unXN) px -- rule [7] XML Namespaces
+ )
-- |
-- test whether an attribute name is a namesapce declaration name.
@@ -454,47 +453,44 @@
-- predicate is used in filter 'valdateNamespaces'.
isWellformedNSDecl :: QName -> Bool
-isWellformedNSDecl n = not (isNameSpaceName n)
+isWellformedNSDecl n
+ = not (isNameSpaceName n)
||
isWellformedNameSpaceName n
-- |
-- test for a namespace name to be well formed
-isWellformedNameSpaceName :: QName -> Bool
-isWellformedNameSpaceName (LP lp) = lp == xmlnsXName
-isWellformedNameSpaceName (PX px n) = px == xmlnsXName
- &&
- not (null lp')
- &&
- not (a_xml `isPrefixOf` lp')
- where
- lp' = localPart n
-isWellformedNameSpaceName (NS _ n) = isWellformedNSDecl n
+isWellformedNameSpaceName :: QName -> Bool
+isWellformedNameSpaceName n@(QN lp px _ns)
+ | isNullXName px = lp == xmlnsXName
+ | otherwise = px == xmlnsXName
+ &&
+ not (null lp')
+ &&
+ not (a_xml `isPrefixOf` lp')
+ where
+ lp' = localPart n
+
-- |
-- test whether a name is a namespace declaration attribute name
-isNameSpaceName :: QName -> Bool
-isNameSpaceName (LP lp) = lp == xmlnsXName
-isNameSpaceName (PX px _) = px == xmlnsXName
-isNameSpaceName (NS _ n) = isNameSpaceName n
+isNameSpaceName :: QName -> Bool
+isNameSpaceName (QN lp px _ns)
+ | isNullXName px = lp == xmlnsXName
+ | otherwise = px == xmlnsXName
-- |
--
-- predicate is used in filter 'valdateNamespaces'.
-isDeclaredNamespace :: QName -> Bool
-isDeclaredNamespace (NS ns n) = isNS ns n
-isDeclaredNamespace n = isNS nullXName n
-
-isNS :: XName -> QName -> Bool
-isNS _ (LP _) = True -- no namespace used
-isNS ns (PX px _)
- | px == xmlnsXName = ns == xmlnsNamespaceXName -- "xmlns" has a predefined namespace uri
- | px == xmlXName = ns == xmlNamespaceXName -- "xml" has a predefiend namespace"
- | otherwise = ns /= nullXName -- namespace values are not empty
-isNS ns (NS _ n) = isNS ns n -- this does not occur, but warning is prevented
+isDeclaredNamespace :: QName -> Bool
+isDeclaredNamespace (QN _lp px ns)
+ | isNullXName px = True -- no namespace used
+ | px == xmlnsXName = ns == xmlnsNamespaceXName -- "xmlns" has a predefined namespace uri
+ | px == xmlXName = ns == xmlNamespaceXName -- "xml" has a predefiend namespace"
+ | otherwise = not (isNullXName ns) -- namespace values are not empty
-- -----------------------------------------------------------------------------
@@ -503,50 +499,127 @@
-- -----------------------------------------------------------------------------
--- the name cache, same implementation strategy as in Data.Atom,
--- but conversion to and from ByteString prevented
+-- the name and string cache
-type Atoms = M.Map String String
+data NameCache = NC { _newXN :: ! Int -- next free name id
+ , _xnCache :: ! (M.Map String XName)
+ , _qnCache :: ! (M.Map (XName, XName, XName) QName) -- we need another type than QName
+ } -- for the key because of the unusable
+ -- Eq instance of QName
+type ChangeNameCache r = NameCache -> (NameCache, r)
-newtype Atom = A String
- deriving (Eq, Ord, Typeable)
+-- ------------------------------------------------------------
+-- | the internal cache for QNames (and name strings)
+
+theNameCache :: MVar NameCache
+theNameCache = unsafePerformIO (newMVar $ initialCache)
+{-# NOINLINE theNameCache #-}
+
+initialXNames :: [XName]
+
+nullXName
+ , xmlnsNamespaceXName
+ , xmlnsXName
+ , xmlNamespaceXName
+ , xmlXName :: XName
+
+initialXNames@
+ [ nullXName
+ , xmlnsNamespaceXName
+ , xmlnsXName
+ , xmlNamespaceXName
+ , xmlXName
+ ] = zipWith XN [0..] $
+ [ ""
+ , xmlnsNamespace
+ , a_xmlns
+ , xmlNamespace
+ , a_xml
+ ]
+
+initialQNames :: [QName]
+
+xmlnsQN :: QName
+
+initialQNames@
+ [xmlnsQN] = [QN xmlnsXName nullXName xmlnsNamespaceXName]
+
+initialCache :: NameCache
+initialCache = NC
+ (length initialXNames)
+ (M.fromList $ map (\ xn -> (unXN xn, xn)) initialXNames)
+ (M.fromList $ map (\ qn@(QN lp px ns) -> ((lp, px, ns), qn)) initialQNames)
+
-- ------------------------------------------------------------
--- | the internal cache for the strings
+changeNameCache :: NFData r => ChangeNameCache r -> r
+changeNameCache action = unsafePerformIO changeNameCache'
+ where
+ changeNameCache' = do
+ -- putStrLn "takeMVar"
+ c <- takeMVar theNameCache
+ let (c', res) = action c
+ c' `seq` -- rnf res `seq`
+ putMVar theNameCache c'
+ -- putStrLn "putMVar"
+ return res
-theAtoms :: MVar Atoms
-theAtoms = unsafePerformIO (newMVar M.empty)
-{-# NOINLINE theAtoms #-}
+{-# NOINLINE changeNameCache #-}
--- | insert a bytestring into the atom cache
+newXName' :: String -> ChangeNameCache XName
+newXName' n c@(NC nxn xm qm)
+ = case M.lookup n xm of
+ Just xn -> (c, xn)
+ Nothing -> let nxn' = nxn + 1 in
+ let xn = (XN nxn n) in
+ let xm' = M.insert n xn xm in
+ -- trace ("newXName: XN " ++ show nxn ++ " " ++ show n) $
+ rnf xn `seq` (NC nxn' xm' qm, xn)
-insertAtom :: String -> Atoms -> (Atoms, Atom)
-insertAtom s m = maybe (M.insert {- (trace (show s) s) -} s s m, deepseq s (A s))
- (\ s' -> (m, A s'))
- .
- M.lookup s $ m
+newQName' :: XName -> XName -> XName -> ChangeNameCache QName
+newQName' lp px ns c@(NC nxn xm qm)
+ = case M.lookup q' qm of
+ Just qn -> -- trace ("oldQName: " ++ show qn) $ -- log evaluation sequence
+ (c, qn)
+ Nothing -> let qm' = M.insert q' q qm in
+ -- trace ("newQName: " ++ show q) $ -- log insertion of a new QName
+ q `seq` (NC nxn xm qm', q)
+ where
+ q' = (lp, px, ns)
+ q = QN lp px ns
--- | creation of an @Atom@ from a @String@
+andThen :: ChangeNameCache r1 ->
+ (r1 -> ChangeNameCache r2) -> ChangeNameCache r2
+andThen a1 a2 c0 = let (c1, r1) = a1 c0 in
+ (a2 r1) c1
-newAtom :: String -> Atom
-newAtom = unsafePerformIO . newAtom'
-{-# NOINLINE newAtom #-}
+newXName :: String -> XName
+newXName n = changeNameCache $
+ newXName' n
--- | The internal operation running in the IO monad
-newAtom' :: String -> IO Atom
-newAtom' s = do
- m <- takeMVar theAtoms
- let (m', a) = insertAtom s m
- putMVar theAtoms m'
- return a
+newQName :: XName -> XName -> XName -> QName
+newQName lp px ns = lp `seq` px `seq` ns `seq` -- XNames must be evaluated, else MVar blocks
+ ( changeNameCache $
+ newQName' lp px ns
+ )
-instance Read Atom where
- readsPrec p str = [ (newAtom x, y) | (x, y) <- readsPrec p str ]
+newLpName :: String -> QName
+newLpName lp = changeNameCache $
+ newXName' lp `andThen` \ lp' ->
+ newQName' lp' nullXName nullXName
-instance Show Atom where
- show (A s) = s
+newPxName :: String -> String -> QName
+newPxName lp px = changeNameCache $
+ newXName' lp `andThen` \ lp' ->
+ newXName' px `andThen` \ px' ->
+ newQName' lp' px' nullXName
-instance NFData Atom where
+newNsName :: String -> String -> String -> QName
+newNsName lp px ns = changeNameCache $
+ newXName' lp `andThen` \ lp' ->
+ newXName' px `andThen` \ px' ->
+ newXName' ns `andThen` \ ns' ->
+ newQName' lp' px' ns'
-----------------------------------------------------------------------------
diff --git a/src/Text/XML/HXT/DOM/ShowXml.hs b/src/Text/XML/HXT/DOM/ShowXml.hs
--- a/src/Text/XML/HXT/DOM/ShowXml.hs
+++ b/src/Text/XML/HXT/DOM/ShowXml.hs
@@ -17,11 +17,16 @@
module Text.XML.HXT.DOM.ShowXml
( xshow
- , showElemType
+ , xshowBlob
+ , xshow'
+ , xshow''
)
where
+import Prelude hiding (showChar, showString)
+
import Data.Maybe
+import Data.Tree.Class
import Data.Tree.NTree.TypeDefs
import Text.XML.HXT.DOM.TypeDefs -- XML Tree types
@@ -35,371 +40,407 @@
-- the toString conversion functions
-- |
--- convert the result of a filter into a string
+-- convert a list of trees into a string
--
-- see also : 'xmlTreesToText' for filter version, 'Text.XML.HXT.Parser.XmlParsec.xread' for the inverse operation
-xshow :: XmlTrees -> String
+xshow :: XmlTrees -> String
xshow [(NTree (XText s) _)] = s -- special case optimisation
-xshow ts = showXmlTrees ts ""
+xshow [(NTree (XBlob b) _)] = blobToString b -- special case optimisation
+xshow ts = showXmlTrees showString showString ts ""
--- ------------------------------------------------------------
+-- | convert an XML tree into a binary large object (a bytestring)
-showXmlTree :: XmlTree -> String -> String
+xshowBlob :: XmlTrees -> Blob
+xshowBlob [(NTree (XBlob b) _)] = b -- special case optimisation
+xshowBlob [(NTree (XText s) _)] = stringToBlob s -- special case optimisation
+xshowBlob ts = stringToBlob $ xshow ts
-showXmlTree (NTree (XText s) _)
- = showString s
+-- |
+-- convert a list of trees into a blob.
+--
+-- Apply a quoting function for XML quoting of content,
+-- a 2. quoting funtion for attribute values
+-- and an encoding function after tree conversion
-showXmlTree (NTree (XCharRef i) _)
- = showString "&#" . showString (show i) . showChar ';'
+xshow' :: (Char -> StringFct) -> (Char -> StringFct) -> (Char -> StringFct) -> XmlTrees -> Blob
+xshow' cquot aquot enc ts = stringToBlob $ (concatMap' enc (showTrees ts "")) ""
+ where
+ showTrees = showXmlTrees (concatMap' cquot) (concatMap' aquot)
-showXmlTree (NTree (XEntityRef r) _)
- = showString "&" . showString r . showChar ';'
+xshow'' :: (Char -> StringFct) -> (Char -> StringFct) -> XmlTrees -> String
+xshow'' cquot aquot ts = showTrees ts ""
+ where
+ showTrees = showXmlTrees (concatMap' cquot) (concatMap' aquot)
-showXmlTree (NTree (XCmt c) _)
- = showString ""
+-- ------------------------------------------------------------
-showXmlTree (NTree (XCdata d) _)
- = showString ""
+type StringFct = String -> String
-showXmlTree (NTree (XPi n al) _)
- = showString ""
+-- ------------------------------------------------------------
+
+showXmlTrees :: (String -> StringFct) -> (String -> StringFct) -> XmlTrees -> StringFct
+showXmlTrees cf af
+ = showTrees
where
- showPiAttr :: XmlTree -> String -> String
- showPiAttr a@(NTree (XAttr an) cs)
- | qualifiedName an == a_value
- = showBlank . showXmlTrees cs
- | otherwise
- = showXmlTree a
- showPiAttr _
- = id
-showXmlTree (NTree (XTag t al) [])
- = showLt . showQName t . showXmlTrees al . showSlash . showGt
+ -- ------------------------------------------------------------
-showXmlTree (NTree (XTag t al) cs)
- = showLt . showQName t . showXmlTrees al . showGt
- . showXmlTrees cs
- . showLt . showSlash . showQName t . showGt
+ showTrees :: XmlTrees -> StringFct
+ showTrees = foldr (.) id . map showXmlTree
+ {-# INLINE showTrees #-}
-showXmlTree (NTree (XDTD de al) cs)
- = showXmlDTD de al cs
+ showTrees' :: XmlTrees -> StringFct
+ showTrees' = foldr (\ x y -> x . showNL . y) id . map showXmlTree
+ {-# INLINE showTrees' #-}
-showXmlTree (NTree (XAttr an) cs)
- = showBlank . showQName an . showEq . showQuoteString (xshow cs)
+ -- ------------------------------------------------------------
-showXmlTree (NTree (XError l e) _)
- = showString ""
+ showXmlTree :: XmlTree -> StringFct
+ showXmlTree (NTree (XText s) _) -- common cases first
+ = cf s
--- ------------------------------------------------------------
+ showXmlTree (NTree (XTag t al) [])
+ = showLt . showQName t . showTrees al . showSlash . showGt
-showXmlTrees :: XmlTrees -> String -> String
-showXmlTrees = foldr (.) id . map showXmlTree
+ showXmlTree (NTree (XTag t al) cs)
+ = showLt . showQName t . showTrees al . showGt
+ . showTrees cs
+ . showLt . showSlash . showQName t . showGt
-showXmlTrees' :: XmlTrees -> String -> String
-showXmlTrees' = foldr (\ x y -> x . showNL . y) id . map showXmlTree
+ showXmlTree (NTree (XAttr an) cs)
+ = showBlank
+ . showQName an
+ . showEq
+ . showQuot
+ . af (xshow cs)
+ . showQuot
--- ------------------------------------------------------------
+ showXmlTree (NTree (XBlob b) _)
+ = cf . blobToString $ b
-showQName :: QName -> String -> String
-showQName
- = showString . qualifiedName
+ showXmlTree (NTree (XCharRef i) _)
+ = showString "&#" . showString (show i) . showChar ';'
--- ------------------------------------------------------------
+ showXmlTree (NTree (XEntityRef r) _)
+ = showString "&" . showString r . showChar ';'
-showQuoteString :: String -> String -> String
-showQuoteString s
- | '\"' `elem` s
- = showApos . showString s . showApos
- | otherwise
- = showQuot . showString s . showQuot
+ showXmlTree (NTree (XCmt c) _)
+ = showString ""
+ showXmlTree (NTree (XCdata d) _)
+ = showString ""
--- ------------------------------------------------------------
+ showXmlTree (NTree (XPi n al) _)
+ = showString ""
+ where
+ showPiAttr :: XmlTree -> StringFct
+ showPiAttr a@(NTree (XAttr an) cs)
+ | qualifiedName an == a_value
+ = showBlank . showTrees cs
+ | otherwise
+ = showXmlTree a
+ showPiAttr a
+ = showXmlTree a -- id
-showAttr :: String -> Attributes -> String -> String
-showAttr k al
- = showString (fromMaybe "" . lookup k $ al)
+ showXmlTree (NTree (XDTD de al) cs)
+ = showXmlDTD de al cs
--- ------------------------------------------------------------
+ showXmlTree (NTree (XError l e) _)
+ = showString ""
-showPEAttr :: Attributes -> String -> String
-showPEAttr al
- = showPE (lookup a_peref al)
- where
- showPE (Just pe) = showChar '%' . showString pe . showChar ';'
- showPE Nothing = id
+ -- ------------------------------------------------------------
--- ------------------------------------------------------------
+ showXmlDTD :: DTDElem -> Attributes -> XmlTrees -> StringFct
-showExternalId :: Attributes -> String -> String
-showExternalId al
- = id2Str (lookup k_system al) (lookup k_public al)
- where
- id2Str Nothing Nothing = id
- id2Str (Just s) Nothing = showBlank . showString k_system . showBlank . showQuoteString s
- id2Str Nothing (Just p) = showBlank . showString k_public . showBlank . showQuoteString p
- id2Str (Just s) (Just p) = showBlank . showString k_public . showBlank . showQuoteString p . showBlank . showQuoteString s
+ showXmlDTD DOCTYPE al cs = showString ""
+ where
+ showInternalDTD [] = id
+ showInternalDTD ds = showString " [\n"
+ . showTrees' ds
+ . showChar ']'
--- ------------------------------------------------------------
+ showXmlDTD ELEMENT al cs = showString ""
-showNData :: Attributes -> String -> String
-showNData al
- = nd2Str (lookup k_ndata al)
- where
- nd2Str Nothing = id
- nd2Str (Just v) = showBlank . showString k_ndata . showBlank . showString v
+ showXmlDTD ATTLIST al cs = showString " ( showPEAttr
+ . fromMaybe [] . getDTDAttrl
+ . head
+ ) cs
+ Just a -> ( showString a
+ . showAttrType (lookup1 a_type al)
+ . showAttrKind (lookup1 a_kind al)
+ )
+ )
+ )
+ . showString " >"
+ where
+ showAttrType t
+ | t == k_peref
+ = showBlank . showPEAttr al
+ | t == k_enumeration
+ = showAttrEnum
+ | t == k_notation
+ = showBlank . showString k_notation . showAttrEnum
+ | otherwise
+ = showBlank . showString t
--- ------------------------------------------------------------
+ showAttrEnum
+ = showString " ("
+ . foldr1
+ (\ s1 s2 -> s1 . showString " | " . s2)
+ (map (getEnum . fromMaybe [] . getDTDAttrl) cs)
+ . showString ")"
+ where
+ getEnum :: Attributes -> StringFct
+ getEnum l = showAttr a_name l . showPEAttr l
-showXmlDTD :: DTDElem -> Attributes -> XmlTrees -> String -> String
+ showAttrKind k
+ | k == k_default
+ = showBlank
+ . showQuoteString (lookup1 a_default al)
+ | k == k_fixed
+ = showBlank
+ . showString k_fixed
+ . showBlank
+ . showQuoteString (lookup1 a_default al)
+ | k == ""
+ = id
+ | otherwise
+ = showBlank
+ . showString k
-showXmlDTD DOCTYPE al cs
- = showString ""
- where
- showInternalDTD [] = id
- showInternalDTD ds = showString " [\n" . showXmlTrees' ds . showChar ']'
+ showXmlDTD NOTATION al _cs
+ = showString ""
-showXmlDTD ELEMENT al cs
- = showString ""
+ showXmlDTD PENTITY al cs = showEntity "% " al cs
-showXmlDTD ATTLIST al cs
- = showString " ( showPEAttr
- . fromMaybe [] . getDTDAttrl
- . head
- ) cs
- Just a -> ( showString a
- .
- showAttrType (lookup1 a_type al)
- .
- showAttrKind (lookup1 a_kind al)
- )
- )
- )
- .
- showString " >"
- where
- showAttrType t
- | t == k_peref
- = showBlank . showPEAttr al
- | t == k_enumeration
- = showAttrEnum
- | t == k_notation
- = showBlank . showString k_notation . showAttrEnum
- | otherwise
- = showBlank . showString t
+ showXmlDTD ENTITY al cs = showEntity "" al cs
- showAttrEnum
- = showString " ("
- .
- foldr1 (\ s1 s2 -> s1 . showString " | " . s2) (map (getEnum . fromMaybe [] . getDTDAttrl) cs)
- .
- showString ")"
- where
- getEnum :: Attributes -> String -> String
- getEnum l = showAttr a_name l . showPEAttr l
+ showXmlDTD PEREF al _cs = showPEAttr al
- showAttrKind k
- | k == k_default
- = showBlank . showQuoteString (lookup1 a_default al)
- | k == k_fixed
- = showBlank . showString k_fixed
- .
- showBlank . showQuoteString (lookup1 a_default al)
- | k == ""
- = id
- | otherwise
- = showBlank . showString k
+ showXmlDTD CONDSECT _ (c1 : cs)
+ = showString ""
-showXmlDTD NOTATION al _cs
- = showString ""
+ showXmlDTD CONTENT al cs = showContent (mkDTDElem CONTENT al cs)
-showXmlDTD PENTITY al cs
- = showEntity "% " al cs
+ showXmlDTD NAME al _cs = showAttr a_name al
-showXmlDTD ENTITY al cs
- = showEntity "" al cs
+ showXmlDTD de al _cs = showString "NOT YET IMPLEMETED: "
+ . showString (show de)
+ . showBlank
+ . showString (show al)
+ . showString " [...]\n"
-showXmlDTD PEREF al _cs
- = showPEAttr al
+ -- ------------------------------------------------------------
-showXmlDTD CONDSECT _ (c1 : cs)
- = showString ""
+ showEntity :: String -> Attributes -> XmlTrees -> StringFct
+ showEntity kind al cs = showString ""
-showXmlDTD CONTENT al cs
- = showContent (mkDTDElem CONTENT al cs)
-showXmlDTD NAME al _cs
- = showAttr a_name al
+ showEntityValue :: XmlTrees -> StringFct
+ showEntityValue [] = id
+ showEntityValue cs = showBlank
+ . showQuot
+ . af (xshow cs)
+ . showQuot
-showXmlDTD de al _cs
- = showString "NOT YET IMPLEMETED: " . showString (show de) . showBlank . showString (show al) . showString " [...]\n"
+ -- ------------------------------------------------------------
--- ------------------------------------------------------------
+ showContent :: XmlTree -> StringFct
+ showContent (NTree (XDTD de al) cs)
+ = cont2String de
+ where
+ cont2String :: DTDElem -> StringFct
+ cont2String NAME = showAttr a_name al
+ cont2String PEREF = showPEAttr al
+ cont2String CONTENT = showLpar
+ . foldr1
+ (combine (lookup1 a_kind al))
+ (map showContent cs)
+ . showRpar
+ . showAttr a_modifier al
+ cont2String n = error ("cont2string " ++ show n ++ " is undefined")
+ combine k s1 s2 = s1
+ . showString ( if k == v_seq
+ then ", "
+ else " | "
+ )
+ . s2
-showElemType :: String -> XmlTrees -> String -> String
-showElemType t cs
- | t == v_pcdata
- = showLpar . showString v_pcdata . showRpar
+ showContent n = showXmlTree n
- | t == v_mixed && (not . null) cs
- = showLpar
- .
- showString v_pcdata
- .
- ( foldr (.) id . map (mixedContent . selAttrl . getNode) ) cs1
- .
- showRpar
- .
- showAttr a_modifier al1
- | t == v_mixed -- incorrect tree, e.g. after erronius pe substitution
- = showLpar
- .
- showRpar
- | t == v_children && (not . null) cs
- = showContent (head cs)
- | t == v_children
- = showLpar
- . showRpar
- | t == k_peref
- = foldr (.) id . map showContent $ cs
- | otherwise
- = showString t
- where
- [(NTree (XDTD CONTENT al1) cs1)] = cs
+ -- ------------------------------------------------------------
- mixedContent :: Attributes -> String -> String
- mixedContent l
- = showString " | " . showAttr a_name l . showPEAttr l
+ showElemType :: String -> XmlTrees -> StringFct
+ showElemType t cs
+ | t == v_pcdata = showLpar . showString v_pcdata . showRpar
+ | t == v_mixed
+ &&
+ (not . null) cs = showLpar
+ . showString v_pcdata
+ . ( foldr (.) id
+ . map (mixedContent . selAttrl . getNode)
+ ) cs1
+ . showRpar
+ . showAttr a_modifier al1
+ | t == v_mixed -- incorrect tree, e.g. after erronius pe substitution
+ = showLpar
+ . showRpar
+ | t == v_children
+ &&
+ (not . null) cs = showContent (head cs)
+ | t == v_children = showLpar
+ . showRpar
+ | t == k_peref = foldr (.) id
+ . map showContent $ cs
+ | otherwise = showString t
+ where
+ [(NTree (XDTD CONTENT al1) cs1)] = cs
- selAttrl (XDTD _ as) = as
- selAttrl (XText tex) = [(a_name, tex)]
- selAttrl _ = []
+ mixedContent :: Attributes -> StringFct
+ mixedContent l = showString " | " . showAttr a_name l . showPEAttr l
+ selAttrl (XDTD _ as) = as
+ selAttrl (XText tex) = [(a_name, tex)]
+ selAttrl _ = []
+
-- ------------------------------------------------------------
-showContent :: XmlTree -> String -> String
-showContent (NTree (XDTD de al) cs)
- = cont2String de
- where
- cont2String :: DTDElem -> String -> String
- cont2String NAME
- = showAttr a_name al
- cont2String PEREF
- = showPEAttr al
- cont2String CONTENT
- = showLpar
- .
- foldr1 (combine (lookup1 a_kind al)) (map showContent cs)
- .
- showRpar
- .
- showAttr a_modifier al
- cont2String n
- = error ("cont2string " ++ show n ++ " is undefined")
- combine k s1 s2
- = s1
- .
- showString ( if k == v_seq
- then ", "
- else " | "
- )
- .
- s2
+showQName :: QName -> StringFct
+showQName = qualifiedName'
+{-# INLINE showQName #-}
-showContent n
- = showXmlTree n
+-- ------------------------------------------------------------
+showQuoteString :: String -> StringFct
+showQuoteString s = showQuot . showString s . showQuot
+
-- ------------------------------------------------------------
-showEntity :: String -> Attributes -> XmlTrees -> String -> String
+showAttr :: String -> Attributes -> StringFct
+showAttr k al = showString (fromMaybe "" . lookup k $ al)
-showEntity kind al cs
- = showString ""
+-- ------------------------------------------------------------
+showPEAttr :: Attributes -> StringFct
+showPEAttr al = showPE (lookup a_peref al)
+ where
+ showPE (Just pe) = showChar '%'
+ . showString pe
+ . showChar ';'
+ showPE Nothing = id
+
-- ------------------------------------------------------------
-showEntityValue :: XmlTrees -> String -> String
+showExternalId :: Attributes -> StringFct
+showExternalId al = id2Str (lookup k_system al) (lookup k_public al)
+ where
+ id2Str Nothing Nothing = id
+ id2Str (Just s) Nothing = showBlank
+ . showString k_system
+ . showBlank
+ . showQuoteString s
+ id2Str Nothing (Just p) = showBlank
+ . showString k_public
+ . showBlank
+ . showQuoteString p
+ id2Str (Just s) (Just p) = showBlank
+ . showString k_public
+ . showBlank
+ . showQuoteString p
+ . showBlank
+ . showQuoteString s
-showEntityValue []
- = id
+-- ------------------------------------------------------------
-showEntityValue cs
- = showBlank . showQuoteString (xshow cs)
+showNData :: Attributes -> StringFct
+showNData al = nd2Str (lookup k_ndata al)
+ where
+ nd2Str Nothing = id
+ nd2Str (Just v) = showBlank
+ . showString k_ndata
+ . showBlank
+ . showString v
-- ------------------------------------------------------------
showBlank,
- showEq, showLt, showGt, showSlash, showApos, showQuot, showLpar, showRpar, showNL :: String -> String
+ showEq, showLt, showGt, showSlash, showQuot, showLpar, showRpar, showNL :: StringFct
showBlank = showChar ' '
+{-# INLINE showBlank #-}
+
showEq = showChar '='
+{-# INLINE showEq #-}
+
showLt = showChar '<'
+{-# INLINE showLt #-}
+
showGt = showChar '>'
+{-# INLINE showGt #-}
+
showSlash = showChar '/'
-showApos = showChar '\''
+{-# INLINE showSlash #-}
+
showQuot = showChar '\"'
+{-# INLINE showQuot #-}
+
showLpar = showChar '('
+{-# INLINE showLpar #-}
+
showRpar = showChar ')'
+{-# INLINE showRpar #-}
+
showNL = showChar '\n'
+{-# INLINE showNL #-}
+showChar :: Char -> StringFct
+showChar = (:)
+{-# INLINE showChar #-}
+
+showString :: String -> StringFct
+showString = (++)
+{-# INLINE showString #-}
+
+concatMap' :: (Char -> StringFct) -> String -> StringFct
+concatMap' f = foldr (\ x r -> f x . r) id
+{-# INLINE concatMap' #-}
+
-- -----------------------------------------------------------------------------
+
diff --git a/src/Text/XML/HXT/DOM/TypeDefs.hs b/src/Text/XML/HXT/DOM/TypeDefs.hs
--- a/src/Text/XML/HXT/DOM/TypeDefs.hs
+++ b/src/Text/XML/HXT/DOM/TypeDefs.hs
@@ -4,7 +4,7 @@
{- |
Module : Text.XML.HXT.DOM.TypeDefs
- Copyright : Copyright (C) 2008 Uwe Schmidt
+ Copyright : Copyright (C) 2008-2010 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
@@ -25,39 +25,55 @@
where
-import Control.DeepSeq
+import Control.DeepSeq
+import Control.FlatSeq
-import Data.AssocList
-import Data.Binary
-import Data.Tree.NTree.TypeDefs
-import Data.Typeable
+import Data.AssocList
-import Text.XML.HXT.DOM.QualifiedName
+import Data.Binary
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy.Char8 as CS
+import Data.Tree.NTree.TypeDefs
+import Data.Tree.NTree.Zipper.TypeDefs
+
+import Data.Typeable
+
+import Text.XML.HXT.DOM.QualifiedName
+
-- -----------------------------------------------------------------------------
--
-- Basic types for xml tree and filters
--- | Node of xml tree representation
+-- | Rose tree with XML nodes (XNode)
type XmlTree = NTree XNode
--- | List of nodes of xml tree representation
+-- | List of rose trees with XML nodes
type XmlTrees = NTrees XNode
+-- | Navigatable rose tree with XML nodes
+
+type XmlNavTree = NTZipper XNode
+
+-- | List of navigatable rose trees with XML nodes
+
+type XmlNavTrees = [NTZipper XNode]
+
-- -----------------------------------------------------------------------------
--
-- XNode
-- | Represents elements
-data XNode = XText String -- ^ ordinary text (leaf)
- | XCharRef Int -- ^ character reference (leaf)
- | XEntityRef String -- ^ entity reference (leaf)
- | XCmt String -- ^ comment (leaf)
- | XCdata String -- ^ CDATA section (leaf)
- | XPi QName XmlTrees -- ^ Processing Instr with qualified name (leaf)
+data XNode = XText String -- ^ ordinary text (leaf)
+ | XBlob Blob -- ^ text represented more space efficient as bytestring (leaf)
+ | XCharRef Int -- ^ character reference (leaf)
+ | XEntityRef String -- ^ entity reference (leaf)
+ | XCmt String -- ^ comment (leaf)
+ | XCdata String -- ^ CDATA section (leaf)
+ | XPi QName XmlTrees -- ^ 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
@@ -65,54 +81,76 @@
| XDTD DTDElem Attributes -- ^ DTD element with assoc list for dtd element features
| XAttr QName -- ^ attribute with qualified name, the attribute value is stored in children
| XError Int String -- ^ error message with level and text
- deriving (Eq, Ord, Show, Read, Typeable)
+ deriving (Eq, Show, Typeable)
instance NFData XNode where
rnf (XText s) = rnf s
+ rnf (XTag qn cs) = rnf qn `seq` rnf cs
+ rnf (XAttr qn) = rnf qn
rnf (XCharRef i) = rnf i
rnf (XEntityRef n) = rnf n
rnf (XCmt c) = rnf c
rnf (XCdata s) = rnf s
rnf (XPi qn ts) = rnf qn `seq` rnf ts
- rnf (XTag qn cs) = rnf qn `seq` rnf cs
rnf (XDTD de al) = rnf de `seq` rnf al
- rnf (XAttr qn) = rnf qn
+ rnf (XBlob b) = BS.length b `seq` ()
rnf (XError n e) = rnf n `seq` rnf e
+instance WNFData XNode where
+ rwnf (XText s) = rwnf s
+ rwnf (XTag qn cs) = rwnf qn `seq` rwnf cs
+ rwnf (XAttr qn) = rwnf qn
+ rwnf (XCharRef i) = i `seq` ()
+ rwnf (XEntityRef n) = rwnf n
+ rwnf (XCmt c) = rwnf c
+ rwnf (XCdata s) = rwnf s
+ rwnf (XPi qn ts) = rwnf qn `seq` rwnf ts
+ rwnf (XDTD de al) = rwnf de `seq` rwnfAttributes al
+ rwnf (XBlob _b) = () -- BS.length b `seq` () -- lazy bytestrings are not evaluated
+ rwnf (XError n e) = n `seq` rwnf e
+
+-- | Evaluate an assoc list of strings
+rwnfAttributes :: Attributes -> ()
+rwnfAttributes [] = ()
+rwnfAttributes ((k, v) : as) = rwnf k `seq` rwnf v `seq` rwnfAttributes as
+
+
instance Binary XNode where
- put (XText s) = put (0::Word8) >> put s
- put (XCharRef i) = put (1::Word8) >> put i
- put (XEntityRef n) = put (2::Word8) >> put n
- put (XCmt c) = put (3::Word8) >> put c
- put (XCdata s) = put (4::Word8) >> put s
- put (XPi qn ts) = put (5::Word8) >> put qn >> put ts
- put (XTag qn cs) = put (6::Word8) >> put qn >> put cs
- put (XDTD de al) = put (7::Word8) >> put de >> put al
- put (XAttr qn) = put (8::Word8) >> put qn
- put (XError n e) = put (9::Word8) >> put n >> put e
+ put (XText s) = put ( 0::Word8) >> put s
+ put (XTag qn cs) = put ( 6::Word8) >> put qn >> put cs
+ put (XAttr qn) = put ( 8::Word8) >> put qn
+ put (XCharRef i) = put ( 1::Word8) >> put i
+ put (XEntityRef n) = put ( 2::Word8) >> put n
+ put (XCmt c) = put ( 3::Word8) >> put c
+ put (XCdata s) = put ( 4::Word8) >> put s
+ put (XPi qn ts) = put ( 5::Word8) >> put qn >> put ts
+ put (XDTD de al) = put ( 7::Word8) >> put de >> put al
+ put (XError n e) = put ( 9::Word8) >> put n >> put e
+ put (XBlob b) = put (10::Word8) >> put b
get = do
tag <- getWord8
case tag of
- 0 -> get >>= return . XText
- 1 -> get >>= return . XCharRef
- 2 -> get >>= return . XEntityRef
- 3 -> get >>= return . XCmt
- 4 -> get >>= return . XCdata
- 5 -> do
- qn <- get
- get >>= return . XPi qn
- 6 -> do
- qn <- get
- get >>= return . XTag qn
- 7 -> do
- de <- get
- get >>= return . XDTD de
- 8 -> get >>= return . XAttr
- 9 -> do
- n <- get
- get >>= return . XError n
- _ -> error "XNode.get: error while decoding XNode"
+ 0 -> get >>= return . XText
+ 1 -> get >>= return . XCharRef
+ 2 -> get >>= return . XEntityRef
+ 3 -> get >>= return . XCmt
+ 4 -> get >>= return . XCdata
+ 5 -> do
+ qn <- get
+ get >>= return . XPi qn
+ 6 -> do
+ qn <- get
+ get >>= return . XTag qn
+ 7 -> do
+ de <- get
+ get >>= return . XDTD de
+ 8 -> get >>= return . XAttr
+ 9 -> do
+ n <- get
+ get >>= return . XError n
+ 10 -> get >>= return . XBlob
+ _ -> error "XNode.get: error while decoding XNode"
-- -----------------------------------------------------------------------------
--
@@ -156,22 +194,27 @@
deriving (Eq, Ord, Enum, Show, Read, Typeable)
instance NFData DTDElem
+instance WNFData DTDElem
instance Binary DTDElem where
put de = put ((toEnum . fromEnum $ de)::Word8) -- DTDElem is not yet instance of Enum
get = do
tag <- getWord8
- return . toEnum . fromEnum $ tag
-{-
- put de = let
- i = fromJust . elemIndex de $ dtdElems
- in
- put ((toEnum i)::Word8)
+ return $! (toEnum . fromEnum $ tag)
- get = do
- tag <- getWord8
- return $ dtdElems !! (fromEnum tag)
--}
+-- -----------------------------------------------------------------------------
+
+-- | Binary large object implemented as a lazy bytestring
+
+type Blob = BS.ByteString
+
+blobToString :: Blob -> String
+blobToString = CS.unpack
+{-# INLINE blobToString #-}
+
+stringToBlob :: String -> Blob
+stringToBlob = CS.pack
+{-# INLINE stringToBlob #-}
-- -----------------------------------------------------------------------------
diff --git a/src/Text/XML/HXT/DOM/XmlNode.hs b/src/Text/XML/HXT/DOM/XmlNode.hs
--- a/src/Text/XML/HXT/DOM/XmlNode.hs
+++ b/src/Text/XML/HXT/DOM/XmlNode.hs
@@ -25,15 +25,18 @@
module Text.XML.HXT.DOM.XmlNode
( module Text.XML.HXT.DOM.XmlNode
+ , module Data.Tree.Class
, module Data.Tree.NTree.TypeDefs
)
where
import Control.Monad
+import Control.FlatSeq
+import Data.Maybe
+import Data.Tree.Class
import Data.Tree.NTree.TypeDefs
-import Data.Maybe
import Text.XML.HXT.DOM.Interface
@@ -41,6 +44,7 @@
-- discriminating predicates
isText :: a -> Bool
+ isBlob :: a -> Bool
isCharRef :: a -> Bool
isEntityRef :: a -> Bool
isCmt :: a -> Bool
@@ -55,6 +59,7 @@
-- constructor functions for leave nodes
mkText :: String -> a
+ mkBlob :: Blob -> a
mkCharRef :: Int -> a
mkEntityRef :: String -> a
mkCmt :: String -> a
@@ -65,6 +70,7 @@
-- selectors
getText :: a -> Maybe String
+ getBlob :: a -> Maybe Blob
getCharRef :: a -> Maybe Int
getEntityRef :: a -> Maybe String
getCmt :: a -> Maybe String
@@ -92,6 +98,7 @@
-- "modifier" functions
changeText :: (String -> String) -> a -> a
+ changeBlob :: (Blob -> Blob) -> a -> a
changeCmt :: (String -> String) -> a -> a
changeName :: (QName -> QName) -> a -> a
changeElemName :: (QName -> QName) -> a -> a
@@ -101,6 +108,7 @@
changeDTDAttrl :: (Attributes -> Attributes) -> a -> a
setText :: String -> a -> a
+ setBlob :: Blob -> a -> a
setCmt :: String -> a -> a
setName :: QName -> a -> a
setElemName :: QName -> a -> a
@@ -112,45 +120,58 @@
-- default implementations
getName n = getElemName n `mplus` getAttrName n `mplus` getPiName n
- getQualifiedName n = getName n >>= \ n' -> return (qualifiedName n')
- getUniversalName n = getName n >>= \ n' -> return (universalName n')
- getUniversalUri n = getName n >>= \ n' -> return (universalUri n')
- getLocalPart n = getName n >>= \ n' -> return (localPart n')
- getNamePrefix n = getName n >>= \ n' -> return (namePrefix n')
- getNamespaceUri n = getName n >>= \ n' -> return (namespaceUri n')
+ getQualifiedName n = getName n >>= return . qualifiedName
+ getUniversalName n = getName n >>= return . universalName
+ getUniversalUri n = getName n >>= return . universalUri
+ getLocalPart n = getName n >>= return . localPart
+ getNamePrefix n = getName n >>= return . namePrefix
+ getNamespaceUri n = getName n >>= return . namespaceUri
- setText t = changeText (const t)
- setCmt c = changeCmt (const c)
- setName n = changeName (const n)
- setElemName n = changeElemName (const n)
- setElemAttrl al = changeAttrl (const al)
- setAttrName n = changeAttrName (const n)
- setPiName n = changePiName (const n)
- setDTDAttrl al = changeDTDAttrl (const al)
+ setText = changeText . const
+ setBlob = changeBlob . const
+ setCmt = changeCmt . const
+ setName = changeName . const
+ setElemName = changeElemName . const
+ setElemAttrl = changeAttrl . const
+ setAttrName = changeAttrName . const
+ setPiName = changePiName . const
+ setDTDAttrl = changeDTDAttrl . const
-- XNode and XmlTree are instances of XmlNode
instance XmlNode XNode where
isText (XText _) = True
+ isText (XBlob _) = True
isText _ = False
+ {-# INLINE isText #-}
+ isBlob (XBlob _) = True
+ isBlob _ = False
+ {-# INLINE isBlob #-}
+
isCharRef (XCharRef _) = True
isCharRef _ = False
+ {-# INLINE isCharRef #-}
isEntityRef (XEntityRef _) = True
isEntityRef _ = False
+ {-# INLINE isEntityRef #-}
isCmt (XCmt _) = True
isCmt _ = False
+ {-# INLINE isCmt #-}
isCdata (XCdata _) = True
isCdata _ = False
+ {-# INLINE isCdata #-}
isPi (XPi _ _) = True
isPi _ = False
+ {-# INLINE isPi #-}
isElem (XTag _ _) = True
isElem _ = False
+ {-# INLINE isElem #-}
isRoot t = isElem t
&&
@@ -158,155 +179,253 @@
isDTD (XDTD _ _) = True
isDTD _ = False
+ {-# INLINE isDTD #-}
isAttr (XAttr _) = True
isAttr _ = False
+ {-# INLINE isAttr #-}
isError (XError _ _) = True
isError _ = False
+ {-# INLINE isError #-}
- mkText t = XText t
- mkCharRef c = XCharRef c
- mkEntityRef e = XEntityRef e
- mkCmt c = XCmt c
- mkCdata d = XCdata d
- mkPi n c = XPi n (if null c then [] else [mkAttr (mkName a_value) c])
- mkError l msg = XError l msg
+ mkText = XText
+ {-# INLINE mkText #-}
+ mkBlob = XBlob
+ {-# INLINE mkBlob #-}
+ mkCharRef = XCharRef
+ {-# INLINE mkCharRef #-}
+ mkEntityRef = XEntityRef
+ {-# INLINE mkEntityRef #-}
+ mkCmt = XCmt
+ {-# INLINE mkCmt #-}
+ mkCdata = XCdata
+ {-# INLINE mkCdata #-}
+ mkPi = XPi
+ {-# INLINE mkPi #-}
+ mkError = XError
+ {-# INLINE mkError #-}
- getText (XText t) = Just t
+
+ getText (XText t) = Just t
+ getText (XBlob b) = Just . blobToString $ b
getText _ = Nothing
+ {-# INLINE getText #-}
+ getBlob (XBlob b) = Just b
+ getBlob _ = Nothing
+ {-# INLINE getBlob #-}
+
getCharRef (XCharRef c) = Just c
getCharRef _ = Nothing
+ {-# INLINE getCharRef #-}
getEntityRef (XEntityRef e) = Just e
getEntityRef _ = Nothing
+ {-# INLINE getEntityRef #-}
getCmt (XCmt c) = Just c
getCmt _ = Nothing
+ {-# INLINE getCmt #-}
getCdata (XCdata d) = Just d
getCdata _ = Nothing
+ {-# INLINE getCdata #-}
getPiName (XPi n _) = Just n
getPiName _ = Nothing
+ {-# INLINE getPiName #-}
getPiContent (XPi _ c) = Just c
getPiContent _ = Nothing
+ {-# INLINE getPiContent #-}
getElemName (XTag n _) = Just n
getElemName _ = Nothing
+ {-# INLINE getElemName #-}
getAttrl (XTag _ al) = Just al
getAttrl (XPi _ al) = Just al
getAttrl _ = Nothing
+ {-# INLINE getAttrl #-}
getDTDPart (XDTD p _) = Just p
getDTDPart _ = Nothing
+ {-# INLINE getDTDPart #-}
getDTDAttrl (XDTD _ al) = Just al
getDTDAttrl _ = Nothing
+ {-# INLINE getDTDAttrl #-}
getAttrName (XAttr n) = Just n
getAttrName _ = Nothing
+ {-# INLINE getAttrName #-}
getErrorLevel (XError l _) = Just l
getErrorLevel _ = Nothing
+ {-# INLINE getErrorLevel #-}
getErrorMsg (XError _ m) = Just m
getErrorMsg _ = Nothing
+ {-# INLINE getErrorMsg #-}
- changeText cf (XText t) = XText (cf t)
+ changeText cf (XText t) = XText . cf $ t
+ changeText cf (XBlob b) = XText . cf . blobToString $ b
changeText _ _ = error "changeText undefined"
+ {-# INLINE changeText #-}
- changeCmt cf (XCmt c) = XCmt (cf c)
+ changeBlob cf (XBlob b) = XBlob . cf $ b
+ changeBlob _ _ = error "changeBlob undefined"
+ {-# INLINE changeBlob #-}
+
+ changeCmt cf (XCmt c) = XCmt . cf $ c
changeCmt _ _ = error "changeCmt undefined"
+ {-# INLINE changeCmt #-}
- changeName cf (XTag n al) = XTag (cf n) al
- changeName cf (XAttr n) = XAttr (cf n)
- changeName cf (XPi n al) = XPi (cf n) al
+ changeName cf (XTag n al) = XTag (cf n) al
+ changeName cf (XAttr n) = XAttr . cf $ n
+ changeName cf (XPi n al) = XPi (cf n) al
changeName _ _ = error "changeName undefined"
+ {-# INLINE changeName #-}
- changeElemName cf (XTag n al) = XTag (cf n) al
+ changeElemName cf (XTag n al) = XTag (cf n) al
changeElemName _ _ = error "changeElemName undefined"
+ {-# INLINE changeElemName #-}
changeAttrl cf (XTag n al) = XTag n (cf al)
changeAttrl cf (XPi n al) = XPi n (cf al)
changeAttrl _ _ = error "changeAttrl undefined"
+ {-# INLINE changeAttrl #-}
- changeAttrName cf (XAttr n) = XAttr (cf n)
+ changeAttrName cf (XAttr n) = XAttr . cf $ n
changeAttrName _ _ = error "changeAttrName undefined"
+ {-# INLINE changeAttrName #-}
- changePiName cf (XPi n al) = XPi (cf n) al
+ changePiName cf (XPi n al) = XPi (cf n) al
changePiName _ _ = error "changeAttrName undefined"
+ {-# INLINE changePiName #-}
changeDTDAttrl cf (XDTD p al) = XDTD p (cf al)
changeDTDAttrl _ _ = error "changeDTDAttrl undefined"
+ {-# INLINE changeDTDAttrl #-}
mkElementNode :: QName -> XmlTrees -> XNode
mkElementNode = XTag
+{-# INLINE mkElementNode #-}
mkAttrNode :: QName -> XNode
mkAttrNode = XAttr
+{-# INLINE mkAttrNode #-}
mkDTDNode :: DTDElem -> Attributes -> XNode
mkDTDNode = XDTD
+{-# INLINE mkDTDNode #-}
-instance XmlNode a => XmlNode (NTree a) where
+instance (XmlNode a, Tree t) => XmlNode (t a) where
isText = isText . getNode
+ {-# INLINE isText #-}
+ isBlob = isBlob . getNode
+ {-# INLINE isBlob #-}
isCharRef = isCharRef . getNode
+ {-# INLINE isCharRef #-}
isEntityRef = isEntityRef . getNode
+ {-# INLINE isEntityRef #-}
isCmt = isCmt . getNode
+ {-# INLINE isCmt #-}
isCdata = isCdata . getNode
+ {-# INLINE isCdata #-}
isPi = isPi . getNode
+ {-# INLINE isPi #-}
isElem = isElem . getNode
+ {-# INLINE isElem #-}
isRoot = isRoot . getNode
+ {-# INLINE isRoot #-}
isDTD = isDTD . getNode
+ {-# INLINE isDTD #-}
isAttr = isAttr . getNode
+ {-# INLINE isAttr #-}
isError = isError . getNode
+ {-# INLINE isError #-}
mkText = mkLeaf . mkText
+ {-# INLINE mkText #-}
+ mkBlob = mkLeaf . mkBlob
+ {-# INLINE mkBlob #-}
mkCharRef = mkLeaf . mkCharRef
+ {-# INLINE mkCharRef #-}
mkEntityRef = mkLeaf . mkEntityRef
+ {-# INLINE mkEntityRef #-}
mkCmt = mkLeaf . mkCmt
+ {-# INLINE mkCmt #-}
mkCdata = mkLeaf . mkCdata
+ {-# INLINE mkCdata #-}
mkPi n = mkLeaf . mkPi n
+ {-# INLINE mkPi #-}
mkError l = mkLeaf . mkError l
+ {-# INLINE mkError #-}
getText = getText . getNode
+ {-# INLINE getText #-}
+ getBlob = getBlob . getNode
+ {-# INLINE getBlob #-}
getCharRef = getCharRef . getNode
+ {-# INLINE getCharRef #-}
getEntityRef = getEntityRef . getNode
+ {-# INLINE getEntityRef #-}
getCmt = getCmt . getNode
+ {-# INLINE getCmt #-}
getCdata = getCdata . getNode
+ {-# INLINE getCdata #-}
getPiName = getPiName . getNode
+ {-# INLINE getPiName #-}
getPiContent = getPiContent . getNode
+ {-# INLINE getPiContent #-}
getElemName = getElemName . getNode
+ {-# INLINE getElemName #-}
getAttrl = getAttrl . getNode
+ {-# INLINE getAttrl #-}
getDTDPart = getDTDPart . getNode
+ {-# INLINE getDTDPart #-}
getDTDAttrl = getDTDAttrl . getNode
+ {-# INLINE getDTDAttrl #-}
getAttrName = getAttrName . getNode
+ {-# INLINE getAttrName #-}
getErrorLevel = getErrorLevel . getNode
+ {-# INLINE getErrorLevel #-}
getErrorMsg = getErrorMsg . getNode
+ {-# INLINE getErrorMsg #-}
- changeText cf = changeNode (changeText cf)
- changeCmt cf = changeNode (changeCmt cf)
- changeName cf = changeNode (changeName cf)
- changeElemName cf = changeNode (changeElemName cf)
- changeAttrl cf = changeNode (changeAttrl cf)
- changeAttrName cf = changeNode (changeAttrName cf)
- changePiName cf = changeNode (changePiName cf)
- changeDTDAttrl cf = changeNode (changeDTDAttrl cf)
+ changeText = changeNode . changeText
+ {-# INLINE changeText #-}
+ changeBlob = changeNode . changeBlob
+ {-# INLINE changeBlob #-}
+ changeCmt = changeNode . changeCmt
+ {-# INLINE changeCmt #-}
+ changeName = changeNode . changeName
+ {-# INLINE changeName #-}
+ changeElemName = changeNode . changeElemName
+ {-# INLINE changeElemName #-}
+ changeAttrl = changeNode . changeAttrl
+ {-# INLINE changeAttrl #-}
+ changeAttrName = changeNode . changeAttrName
+ {-# INLINE changeAttrName #-}
+ changePiName = changeNode . changePiName
+ {-# INLINE changePiName #-}
+ changeDTDAttrl = changeNode . changeDTDAttrl
+ {-# INLINE changeDTDAttrl #-}
mkElement :: QName -> XmlTrees -> XmlTrees -> XmlTree
mkElement n al = mkTree (mkElementNode n al)
+{-# INLINE mkElement #-}
mkRoot :: XmlTrees -> XmlTrees -> XmlTree
mkRoot al = mkTree (mkElementNode (mkName t_root) al)
mkAttr :: QName -> XmlTrees -> XmlTree
mkAttr n = mkTree (mkAttrNode n)
+{-# INLINE mkAttr #-}
mkDTDElem :: DTDElem -> Attributes -> XmlTrees -> XmlTree
mkDTDElem e al = mkTree (mkDTDNode e al)
@@ -329,5 +448,53 @@
mergeAttrl :: XmlTrees -> XmlTrees -> XmlTrees
mergeAttrl = foldr addAttr
+
+-- ------------------------------------------------------------
+
+-- | weak normalform versions of constructors
+
+mkElement' :: QName -> XmlTrees -> XmlTrees -> XmlTree
+mkElement' n al cl = id $!! mkElement n al cl
+{-# INLINE mkElement' #-}
+
+mkRoot' :: XmlTrees -> XmlTrees -> XmlTree
+mkRoot' al cl = id $!! mkRoot al cl
+{-# INLINE mkRoot' #-}
+
+mkAttr' :: QName -> XmlTrees -> XmlTree
+mkAttr' n av = id $!! mkAttr n av
+{-# INLINE mkAttr' #-}
+
+mkText' :: String -> XmlTree
+mkText' t = id $!! mkText t
+{-# INLINE mkText' #-}
+
+mkCharRef' :: Int -> XmlTree
+mkCharRef' i = id $!! mkCharRef i
+{-# INLINE mkCharRef' #-}
+
+mkEntityRef' :: String -> XmlTree
+mkEntityRef' n = id $!! mkEntityRef n
+{-# INLINE mkEntityRef' #-}
+
+mkCmt' :: String -> XmlTree
+mkCmt' c = id $!! mkCmt c
+{-# INLINE mkCmt' #-}
+
+mkCdata' :: String -> XmlTree
+mkCdata' d = id $!! mkCdata d
+{-# INLINE mkCdata' #-}
+
+mkPi' :: QName -> XmlTrees -> XmlTree
+mkPi' n v = id $!! mkPi n v
+{-# INLINE mkPi' #-}
+
+mkError' :: Int -> String -> XmlTree
+mkError' l m = id $!! mkError l m
+{-# INLINE mkError' #-}
+
+mkDTDElem' :: DTDElem -> Attributes -> XmlTrees -> XmlTree
+mkDTDElem' e al cl = id $!! mkDTDElem e al cl
+{-# INLINE mkDTDElem' #-}
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/DTDValidation/DocTransformation.hs b/src/Text/XML/HXT/DTDValidation/DocTransformation.hs
--- a/src/Text/XML/HXT/DTDValidation/DocTransformation.hs
+++ b/src/Text/XML/HXT/DTDValidation/DocTransformation.hs
@@ -82,9 +82,9 @@
traverseTree :: TransEnvTable -> XmlArrow
traverseTree transEnv
= processTopDown ( (transFct $< getName)
- `when`
- isElem
- )
+ `when`
+ isElem
+ )
where
transFct :: String -> XmlArrow
transFct name = fromMaybe this . M.lookup name $ transEnv
diff --git a/src/Text/XML/HXT/DTDValidation/Validation.hs b/src/Text/XML/HXT/DTDValidation/Validation.hs
--- a/src/Text/XML/HXT/DTDValidation/Validation.hs
+++ b/src/Text/XML/HXT/DTDValidation/Validation.hs
@@ -26,6 +26,7 @@
module Text.XML.HXT.DTDValidation.Validation
( getDTDSubset
+ , generalEntitiesDefined
, validate
, validateDTD
, validateDoc
@@ -126,5 +127,9 @@
>>>
( filterA $ isDTDDoctype >>> getDTDAttrl >>> isA (hasEntry a_name) )
+generalEntitiesDefined :: XmlArrow
+generalEntitiesDefined = getDTDSubset
+ >>>
+ deep isDTDEntity
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/IO/GetFILE.hs b/src/Text/XML/HXT/IO/GetFILE.hs
--- a/src/Text/XML/HXT/IO/GetFILE.hs
+++ b/src/Text/XML/HXT/IO/GetFILE.hs
@@ -22,18 +22,11 @@
where
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy as B
import Network.URI ( unEscapeString
)
-import System.IO ( IOMode(..)
- , openBinaryFile
- -- , getContents is defined in the prelude
- , hGetContents
- )
-
import System.IO.Error ( ioeGetErrorString
, try
)
@@ -46,15 +39,14 @@
-- ------------------------------------------------------------
-getStdinCont :: Bool -> IO (Either ([(String, String)], String)
- String)
+getStdinCont :: Bool -> IO (Either ([(String, String)], String) B.ByteString)
getStdinCont strictInput
= do
- c <- try ( if strictInput
- then do
- cb <- B.getContents
- return (C.unpack cb)
- else getContents
+ c <- try ( do
+ cb <- B.getContents
+ if strictInput
+ then B.length cb `seq` return cb
+ else return cb
)
return (either readErr Right c)
where
@@ -68,8 +60,7 @@
msg = "stdin read error: " ++ es
es = ioeGetErrorString e
-getCont :: Bool -> String -> IO (Either ([(String, String)], String)
- String)
+getCont :: Bool -> String -> IO (Either ([(String, String)], String) B.ByteString)
getCont strictInput source
= do -- preliminary
source'' <- checkFile source'
@@ -81,13 +72,11 @@
then return $ fileErr "file not readable"
else do
c <- try $
+ do
+ cb <- B.readFile fn
if strictInput
- then do
- cb <- B.readFile fn
- return (C.unpack cb)
- else do
- h <- openBinaryFile fn ReadMode
- hGetContents h
+ then B.length `seq` return cb
+ else return cb
return (either readErr Right c)
where
source' = drivePath $ source
diff --git a/src/Text/XML/HXT/Parser/HtmlParsec.hs b/src/Text/XML/HXT/Parser/HtmlParsec.hs
--- a/src/Text/XML/HXT/Parser/HtmlParsec.hs
+++ b/src/Text/XML/HXT/Parser/HtmlParsec.hs
@@ -33,84 +33,84 @@
where
-import Text.XML.HXT.DOM.Interface
-
-import Text.XML.HXT.DOM.XmlNode
- ( mkText
- , mkError
- , mkCmt
- , mkElement
- , mkAttr
- , mkDTDElem
- )
-
-import Text.ParserCombinators.Parsec
- ( Parser
- , SourcePos
- , anyChar
- , between
- , char
- , eof
- , getPosition
- , many
- , noneOf
- , option
- , parse
- , satisfy
- , string
- , try
- , (<|>)
- )
-
-import Text.XML.HXT.Parser.XmlTokenParser
- ( allBut
- , dq
- , eq
- , gt
- , name
- , pubidLiteral
- , skipS
- , skipS0
- , sq
- , systemLiteral
-
- , singleCharsT
- , referenceT
- )
-
-import Text.XML.HXT.Parser.XmlParsec
- ( cDSect
- , charData'
- , misc
- , parseXmlText
- , pI
- , xMLDecl'
- )
-
-import Text.XML.HXT.Parser.XmlCharParser
- ( xmlChar
- )
+import Data.Char ( toLower
+ , toUpper
+ )
+import Data.Char.Properties.XMLCharProps ( isXmlChar
+ )
+import Data.Maybe ( fromMaybe
+ , fromJust
+ )
+import qualified Data.Map as M
-import Data.Maybe
- ( fromMaybe
- )
+import Text.ParserCombinators.Parsec ( SourcePos
+ , anyChar
+ , between
+ -- , char
+ , eof
+ , getPosition
+ , many
+ , many1
+ , noneOf
+ , option
+ , runParser
+ , satisfy
+ , string
+ , try
+ , (<|>)
+ )
-import Data.Char
- ( toLower
- , toUpper
- )
+import Text.XML.HXT.DOM.Interface
+import Text.XML.HXT.DOM.XmlNode ( mkText'
+ , mkError'
+ , mkCdata'
+ , mkCmt'
+ , mkCharRef'
+ , mkElement'
+ , mkAttr'
+ , mkDTDElem'
+ , mkPi'
+ , isEntityRef
+ , getEntityRef
+ )
+import Text.XML.HXT.Parser.XmlTokenParser ( allBut
+ , amp
+ , dq
+ , eq
+ , gt
+ , lt
+ , name
+ , pubidLiteral
+ , skipS
+ , skipS0
+ , sPace
+ , sq
+ , systemLiteral
+ , checkString
+ , singleCharsT
+ , referenceT
+ )
+import Text.XML.HXT.Parser.XmlParsec ( misc
+ , parseXmlText
+ , xMLDecl'
+ )
+import Text.XML.HXT.Parser.XmlCharParser ( xmlChar
+ , SimpleXParser
+ , withNormNewline
+ )
+import Text.XML.HXT.Parser.XhtmlEntities ( xhtmlEntities
+ )
-- ------------------------------------------------------------
-parseHtmlText :: String -> XmlTree -> XmlTrees
-parseHtmlText loc t
- = parseXmlText htmlDocument loc $ t
+parseHtmlText :: String -> XmlTree -> XmlTrees
+parseHtmlText loc t = parseXmlText htmlDocument (withNormNewline ()) loc $ t
-- ------------------------------------------------------------
-parseHtmlFromString :: Parser XmlTrees -> String -> String -> XmlTrees
+parseHtmlFromString :: SimpleXParser XmlTrees -> String -> String -> XmlTrees
parseHtmlFromString parser loc
- = either ((:[]) . mkError c_err . (++ "\n") . show) id . parse parser loc
+ = either ((:[]) . mkError' c_err . (++ "\n") . show) id . runParser parser (withNormNewline ()) loc
parseHtmlDocument :: String -> String -> XmlTrees
parseHtmlDocument = parseHtmlFromString htmlDocument
@@ -120,7 +120,15 @@
-- ------------------------------------------------------------
-htmlDocument :: Parser XmlTrees
+type Context = (XmlTreeFl, OpenTags)
+
+type XmlTreeFl = XmlTrees -> XmlTrees
+
+type OpenTags = [(String, XmlTrees, XmlTreeFl)]
+
+-- ------------------------------------------------------------
+
+htmlDocument :: SimpleXParser XmlTrees
htmlDocument
= do
pl <- htmlProlog
@@ -128,7 +136,7 @@
eof
return (pl ++ el)
-htmlProlog :: Parser XmlTrees
+htmlProlog :: SimpleXParser XmlTrees
htmlProlog
= do
xml <- option []
@@ -136,8 +144,8 @@
<|>
( do
pos <- getPosition
- _ <- try (string "
( do
pos <- getPosition
- _ <- try (upperCaseString "')
+ = between (upperCaseString "\"")
- .
- addHtmlTag tn al body
- $
- (body1, restOpen)
- )
+ = closeTags pos'
+ ( addHtmlWarn (show pos' ++ ": no closing tag found for \"<" ++ tn ++ " ...>\"")
+ .
+ addHtmlTag tn al body
+ $
+ (body1, restOpen)
+ )
-type OpenTags = [(String, XmlTrees, XmlTrees)]
-type Context = (XmlTrees, OpenTags)
+-- ------------------------------------------------------------
-hElement :: Context -> Parser Context
+hElement :: Context -> SimpleXParser Context
hElement context
= ( do
t <- hSimpleData
- return (addHtmlElems [t] context)
+ return (addHtmlElem t context)
)
<|>
- hOpenTag context
- <|>
hCloseTag context
<|>
+ hOpenTag context
+ <|>
( do -- wrong tag, take it as text
pos <- getPosition
c <- xmlChar
return ( addHtmlWarn (show pos ++ " markup char " ++ show c ++ " not allowed in this context")
.
- addHtmlElems [mkText [c]]
+ addHtmlElem (mkText' [c])
$
context
)
@@ -235,54 +243,57 @@
)
-hSimpleData :: Parser XmlTree
+hSimpleData :: SimpleXParser XmlTree
hSimpleData
- = charData'
+ = charData''
<|>
- try referenceT
+ hReference'
<|>
- try hComment
+ hComment
<|>
- try pI
+ hpI
<|>
- try cDSect
+ hcDSect
+ where
+ charData''
+ = do
+ t <- many1 (satisfy (\ x -> isXmlChar x && not (x == '<' || x == '&')))
+ return (mkText' t)
-hCloseTag :: Context -> Parser Context
+hCloseTag :: Context -> SimpleXParser Context
hCloseTag context
= do
- n <- try ( do
- _ <- string " in tag \" Parser Context
+hOpenTag :: Context -> SimpleXParser Context
hOpenTag context
= ( do
- pos <- getPosition
e <- hOpenTagStart
- hOpenTagRest pos e context
+ hOpenTagRest e context
)
-hOpenTagStart :: Parser (String, XmlTrees)
+hOpenTagStart :: SimpleXParser ((SourcePos, String), XmlTrees)
hOpenTagStart
= do
- n <- try ( do
- _ <- char '<'
- n <- lowerCaseName
- return n
- )
+ np <- try ( do
+ lt
+ pos <- getPosition
+ n <- lowerCaseName
+ return (pos, n)
+ )
skipS0
as <- hAttrList
- return (n, as)
+ return (np, as)
-hOpenTagRest :: SourcePos -> (String, XmlTrees) -> Context -> Parser Context
-hOpenTagRest pos (tn, al) context
+hOpenTagRest :: ((SourcePos, String), XmlTrees) -> Context -> SimpleXParser Context
+hOpenTagRest ((pos, tn), al) context
= ( do
- _ <- try $ string "/>"
- return (addHtmlTag tn al [] context)
+ checkString "/>"
+ return (addHtmlTag tn al id context)
)
<|>
( do
@@ -290,13 +301,13 @@
return ( let context2 = closePrevTag pos tn context1
in
( if isEmptyHtmlTag tn
- then addHtmlTag tn al []
+ then addHtmlTag tn al id
else openTag tn al
) context2
)
)
-hAttrList :: Parser XmlTrees
+hAttrList :: SimpleXParser XmlTrees
hAttrList
= many (try hAttribute)
where
@@ -305,18 +316,14 @@
n <- lowerCaseName
v <- hAttrValue
skipS0
- return $ mkAttr (mkName n) v
+ return $ mkAttr' (mkName n) v
-hAttrValue :: Parser XmlTrees
+hAttrValue :: SimpleXParser XmlTrees
hAttrValue
= option []
- ( try ( do
- eq
- hAttrValue'
- )
- )
+ ( eq >> hAttrValue' )
-hAttrValue' :: Parser XmlTrees
+hAttrValue' :: SimpleXParser XmlTrees
hAttrValue'
= try ( between dq dq (hAttrValue'' "&\"") )
<|>
@@ -324,76 +331,157 @@
<|>
( do -- HTML allows unquoted attribute values
cs <- many (noneOf " \r\t\n>\"\'")
- return [mkText cs]
+ return [mkText' cs]
)
-hAttrValue'' :: String -> Parser XmlTrees
+hAttrValue'' :: String -> SimpleXParser XmlTrees
hAttrValue'' notAllowed
= many ( hReference' <|> singleCharsT notAllowed)
-hReference' :: Parser XmlTree
+hReference' :: SimpleXParser XmlTree
hReference'
- = try referenceT
+ = try hReferenceT
<|>
( do
- _ <- char '&'
- return (mkText "&")
+ amp
+ return (mkText' "&")
)
-hContent :: Context -> Parser Context
+hReferenceT :: SimpleXParser XmlTree
+hReferenceT
+ = do
+ r <- referenceT
+ return ( if isEntityRef r
+ then substRef r
+ else r
+ )
+ where
+ -- optimization: HTML entity refs are substituted by char refs, so a later entity ref substituion isn't required
+ substRef r
+ = case (lookup en xhtmlEntities) of
+ Just i -> mkCharRef' i
+ Nothing -> r -- not found: the entity ref remains as it is
+ -- this is also done in the XML parser
+{- alternative def
+ Nothing -> mkText' ("&" ++ en ++ ";") -- not found: the entity ref is taken as text
+-}
+ where
+ en = fromJust . getEntityRef $ r
+
+hContent :: Context -> SimpleXParser Context
hContent context
= option context
- ( do
- context1 <- hElement context
- hContent context1
+ ( hElement context
+ >>=
+ hContent
)
+-- ------------------------------------------------------------
+
-- hComment allows "--" in comments
-- comment from XML spec does not
-hComment :: Parser XmlTree
+hComment :: SimpleXParser XmlTree
hComment
= do
- c <- between (try $ string "") (allBut many "-->")
- return (mkCmt c)
+ checkString ""
+ closeCmt pos c
+ where
+ closeCmt pos c
+ = ( do
+ checkString "-->"
+ return (mkCmt' c)
+ )
+ <|>
+ ( return $
+ mkError' c_warn (show pos ++ " no closing comment sequence \"-->\" found")
+ )
-checkSymbol :: Parser a -> String -> Context -> Parser Context
-checkSymbol p msg context
+-- ------------------------------------------------------------
+
+hpI :: SimpleXParser XmlTree
+hpI = checkString ">
+ ( try ( do
+ n <- name
+ p <- sPace >> allBut many "?>"
+ string "?>" >>
+ return (mkPi' (mkName n) [mkAttr' (mkName a_value) [mkText' p]])
+ )
+ <|>
+ ( do
+ pos <- getPosition
+ return $
+ mkError' c_warn (show pos ++ " illegal PI found")
+ )
+ )
+
+-- ------------------------------------------------------------
+
+hcDSect :: SimpleXParser XmlTree
+hcDSect
= do
+ checkString ""
+ closeCD pos t
+ where
+ closeCD pos t
+ = ( do
+ checkString "]]>"
+ return (mkCdata' t)
+ )
+ <|>
+ ( return $
+ mkError' c_warn (show pos ++ " no closing CDATA sequence \"]]>\" found")
+ )
-lowerCaseName :: Parser String
+-- ------------------------------------------------------------
+
+checkSymbol :: SimpleXParser () -> String -> Context -> SimpleXParser Context
+checkSymbol p msg context
+ = ( p
+ >>
+ return context
+ )
+ <|>
+ ( do
+ pos <- getPosition
+ return $ addHtmlWarn (show pos ++ " " ++ msg) context
+ )
+
+lowerCaseName :: SimpleXParser String
lowerCaseName
= do
n <- name
return (map toLower n)
-upperCaseString :: String -> Parser String
-upperCaseString
- = sequence . map (\ c -> satisfy (( == c) . toUpper))
+upperCaseString :: String -> SimpleXParser ()
+upperCaseString s
+ = try (sequence (map (\ c -> satisfy (( == c) . toUpper)) s)) >> return ()
-- ------------------------------------------------------------
-addHtmlTag :: String -> XmlTrees -> XmlTrees -> Context -> Context
-addHtmlTag tn al body (body1, openTags)
- = ([mkElement (mkName tn) al (reverse body)] ++ body1, openTags)
+addHtmlTag :: String -> XmlTrees -> XmlTreeFl -> Context -> Context
+addHtmlTag tn al body context
+ = e `seq`
+ addHtmlElem e context
+ where
+ e = mkElement' (mkName tn) al (body [])
addHtmlWarn :: String -> Context -> Context
addHtmlWarn msg
- = addHtmlElems [mkError c_warn msg]
+ = addHtmlElem (mkError' c_warn msg)
-addHtmlElems :: XmlTrees -> Context -> Context
-addHtmlElems elems (body, openTags)
- = (reverse elems ++ body, openTags)
+addHtmlElem :: XmlTree -> Context -> Context
+addHtmlElem elem' (body, openTags)
+ = (body . (elem' :), openTags)
openTag :: String -> XmlTrees -> Context -> Context
openTag tn al (body, openTags)
- = ([], (tn, al, body) : openTags)
+ = (id, (tn, al, body) : openTags)
closeTag :: SourcePos -> String -> Context -> Context
closeTag pos n context
@@ -402,7 +490,7 @@
| otherwise
= addHtmlWarn (show pos ++ " no opening tag found for ")
.
- addHtmlTag n [] []
+ addHtmlTag n [] id
$
context
where
@@ -427,7 +515,7 @@
closePrevTag _pos _n context@(_body, [])
= context
closePrevTag pos n context@(body, (n1, al1, body1) : restOpen)
- | n `closes` n1
+ | n `closesHtmlTag` n1
= closePrevTag pos n
( addHtmlWarn (show pos ++ " tag \"<" ++ n1 ++ " ...>\" implicitly closed by opening tag \"<" ++ n ++ " ...>\"")
.
@@ -461,6 +549,7 @@
, "meta"
, "param"
]
+{-# INLINE emptyHtmlTags #-}
isInnerHtmlTagOf :: String -> String -> Bool
n `isInnerHtmlTagOf` tn
@@ -487,11 +576,52 @@
]
)
-closesHtmlTag
- , closes :: String -> String -> Bool
+-- a bit more efficient implementation of closes
+closesHtmlTag :: String -> String -> Bool
+closesHtmlTag t t2
+ = fromMaybe False . fmap ($ t) . M.lookup t2 $ closedByTable
+{-# INLINE closesHtmlTag #-}
+
+closedByTable :: M.Map String (String -> Bool)
+closedByTable
+ = M.fromList $
+ [ ("a", (== "a"))
+ , ("li", (== "li" ))
+ , ("th", (`elem` ["th", "td", "tr"] ))
+ , ("td", (`elem` ["th", "td", "tr"] ))
+ , ("tr", (== "tr"))
+ , ("dt", (`elem` ["dt", "dd"] ))
+ , ("dd", (`elem` ["dt", "dd"] ))
+ , ("p", (`elem` ["hr"
+ , "h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
+ , ("colgroup", (`elem` ["colgroup", "thead", "tfoot", "tbody"] ))
+ , ("form", (`elem` ["form"] ))
+ , ("label", (`elem` ["label"] ))
+ , ("map", (`elem` ["map"] ))
+ , ("option", const True)
+ , ("script", const True)
+ , ("style", const True)
+ , ("textarea", const True)
+ , ("title", const True)
+ , ("select", ( /= "option"))
+ , ("thead", (`elem` ["tfoot","tbody"] ))
+ , ("tbody", (== "tbody" ))
+ , ("tfoot", (== "tbody" ))
+ , ("h1", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
+ , ("h2", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
+ , ("h3", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
+ , ("h4", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
+ , ("h5", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
+ , ("h6", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
+ ]
+
+{-
+closesHtmlTag :: String -> String -> Bool
closesHtmlTag = closes
+closes :: String -> String -> Bool
+
"a" `closes` "a" = True
"li" `closes` "li" = True
"th" `closes` t | t `elem` ["th","td"] = True
@@ -533,5 +663,6 @@
,"p" -- not "div"
] = True
_ `closes` _ = False
+-}
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Parser/XmlCharParser.hs b/src/Text/XML/HXT/Parser/XmlCharParser.hs
--- a/src/Text/XML/HXT/Parser/XmlCharParser.hs
+++ b/src/Text/XML/HXT/Parser/XmlCharParser.hs
@@ -15,30 +15,53 @@
-- ------------------------------------------------------------
module Text.XML.HXT.Parser.XmlCharParser
- ( xmlChar -- xml char parsers
+ ( XParser
+ , SimpleXParser
+ , XPState(..)
+ , withNormNewline
+ , withoutNormNewline
+
+ , xmlChar -- xml char parsers
, xmlNameChar
, xmlNameStartChar
, xmlNCNameChar
, xmlNCNameStartChar
, xmlLetter
, xmlSpaceChar
+ , xmlCRLFChar
)
where
-import Data.Char.Properties.XMLCharProps( isXmlChar
- , isXmlNameChar
- , isXmlNameStartChar
- , isXmlNCNameChar
- , isXmlNCNameStartChar
- , isXmlLetter
- , isXmlSpaceChar
- )
+import Data.Char.Properties.XMLCharProps ( isXmlCharCR
+ , isXmlNameChar
+ , isXmlNameStartChar
+ , isXmlNCNameChar
+ , isXmlNCNameStartChar
+ , isXmlLetter
+ , isXmlSpaceCharCR
+ )
import Data.String.Unicode
import Text.ParserCombinators.Parsec
-- ------------------------------------------------------------
+
+type XParser s a = GenParser Char (XPState s) a
+type SimpleXParser a = XParser () a
+
+data XPState s = XPState
+ { xps_normalizeNewline :: ! Bool
+ , xps_userState :: s
+ }
+
+withNormNewline :: a -> XPState a
+withNormNewline x = XPState True x
+
+withoutNormNewline :: a -> XPState a
+withoutNormNewline x = XPState False x
+
+-- ------------------------------------------------------------
--
-- Char (2.2)
--
@@ -46,50 +69,77 @@
-- |
-- parse a single Unicode character
-xmlChar :: GenParser Char state Unicode
-xmlChar = satisfy isXmlChar "legal XML character"
+xmlChar :: XParser s Unicode
+xmlChar = ( satisfy isXmlCharCR
+ <|>
+ xmlCRLFChar
+ )
+ "legal XML character"
+{-# INLINE xmlChar #-}
-- |
-- parse a XML name character
-xmlNameChar :: GenParser Char state Unicode
+xmlNameChar :: XParser s Unicode
xmlNameChar = satisfy isXmlNameChar "legal XML name character"
+{-# INLINE xmlNameChar #-}
-- |
-- parse a XML name start character
-xmlNameStartChar :: GenParser Char state Unicode
+xmlNameStartChar :: XParser s Unicode
xmlNameStartChar = satisfy isXmlNameStartChar "legal XML name start character"
+{-# INLINE xmlNameStartChar #-}
-- |
-- parse a XML NCName character
-xmlNCNameChar :: GenParser Char state Unicode
+xmlNCNameChar :: XParser s Unicode
xmlNCNameChar = satisfy isXmlNCNameChar "legal XML NCName character"
+{-# INLINE xmlNCNameChar #-}
-- |
-- parse a XML NCName start character
-xmlNCNameStartChar :: GenParser Char state Unicode
+xmlNCNameStartChar :: XParser s Unicode
xmlNCNameStartChar = satisfy isXmlNCNameStartChar "legal XML NCName start character"
+{-# INLINE xmlNCNameStartChar #-}
-- |
-- parse a XML letter character
-xmlLetter :: GenParser Char state Unicode
+xmlLetter :: XParser s Unicode
xmlLetter = satisfy isXmlLetter "legal XML letter"
+{-# INLINE xmlLetter #-}
-- |
-- White Space (2.3)
--
+-- end of line handling (2.11) will be done before or with 'xmlCRLFChar' parser
+
+xmlSpaceChar :: XParser s Char
+xmlSpaceChar = ( satisfy isXmlSpaceCharCR
+ <|>
+ xmlCRLFChar
+ )
+ "white space"
+{-# INLINE xmlSpaceChar #-}
+
+-- |
+-- White Space Normalization
+--
-- 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 :: GenParser Char state Char
-xmlSpaceChar = satisfy isXmlSpaceChar "white space"
+xmlCRLFChar :: XParser s Char
+xmlCRLFChar = ( do
+ _ <- char '\r'
+ s <- getState
+ if xps_normalizeNewline s
+ then option '\n' (char '\n')
+ else return '\r'
+ )
+ "newline"
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Parser/XmlDTDParser.hs b/src/Text/XML/HXT/Parser/XmlDTDParser.hs
--- a/src/Text/XML/HXT/Parser/XmlDTDParser.hs
+++ b/src/Text/XML/HXT/Parser/XmlDTDParser.hs
@@ -33,27 +33,33 @@
import Text.XML.HXT.DOM.Interface
-
-
import Text.XML.HXT.DOM.ShowXml
( xshow
)
-import Text.XML.HXT.DOM.XmlNode
- ( mkDTDElem
- , mkText
- , mkError
- , isText
- , isDTD
- , getText
- , getDTDPart
- , getDTDAttrl
- , getChildren
- , setChildren
- )
+import Text.XML.HXT.DOM.XmlNode ( mkDTDElem'
+ , mkText'
+ , mkError'
+ , isText
+ , isDTD
+ , getText
+ , getDTDPart
+ , getDTDAttrl
+ , getChildren
+ , setChildren
+ )
import qualified Text.XML.HXT.Parser.XmlTokenParser as XT
-import qualified Text.XML.HXT.Parser.XmlCharParser as XC ( xmlSpaceChar )
-import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD ( dtdToken )
+import Text.XML.HXT.Parser.XmlCharParser ( XParser
+ , XPState(..)
+ , withoutNormNewline
+ )
+
+import qualified Text.XML.HXT.Parser.XmlCharParser as XC
+ ( xmlSpaceChar )
+
+import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD
+ ( dtdToken )
+
-----------------------------------------------------------
--
-- all parsers dealing with whitespace will be redefined
@@ -61,21 +67,25 @@
type LocalState = (Int, [(Int, String, SourcePos)])
-type SParser a = GenParser Char LocalState a
+type SParser a = XParser LocalState a
-initialLocalState :: SourcePos -> LocalState
-initialLocalState p = (0, [(0, sourceName p, p)])
+initialState :: SourcePos -> XPState LocalState
+initialState p = withoutNormNewline (0, [(0, sourceName p, p)])
+updateLocalState :: (LocalState -> LocalState) -> SParser ()
+updateLocalState upd
+ = updateState $ \ xps -> xps { xps_userState = upd $ xps_userState xps }
+
pushPar :: String -> SParser ()
pushPar n = do
p <- getPosition
- updateState (\ (i, s) -> (i+1, (i+1, n, p) : s))
+ updateLocalState (\ (i, s) -> (i+1, (i+1, n, p) : s))
setPosition ( newPos (sourceName p ++ " (line " ++ show (sourceLine p) ++ ", column " ++ show (sourceColumn p) ++ ") in content of parameter entity ref %" ++ n ++ ";") 1 1)
popPar :: SParser ()
popPar = do
oldPos <- getPos
- updateState pop
+ updateLocalState pop
setPosition oldPos
where
pop (i, [(_, s, p)]) = (i+1, [(i+1, s, p)]) -- if param entity substitution is correctly implemented, this case does not occur
@@ -84,12 +94,14 @@
getParNo :: SParser Int
getParNo = do
- (_i, (top, _n, _p) : _s) <- getState
+ s <- getState
+ let (_i, (top, _n, _p) : _s) = xps_userState s
return top
getPos :: SParser SourcePos
getPos = do
- (_i, (_top, _n, p) : _s) <- getState
+ s <- getState
+ let (_i, (_top, _n, p) : _s) = xps_userState s
return p
delPE :: SParser ()
@@ -129,8 +141,8 @@
-- ------------------------------------------------------------
xmlSpaceChar :: SParser ()
-xmlSpaceChar = ( do
- _ <- XC.xmlSpaceChar
+xmlSpaceChar = ( XC.xmlSpaceChar
+ >>
return ()
)
<|>
@@ -141,27 +153,27 @@
skipS :: SParser ()
skipS
- = do
- skipMany1 xmlSpaceChar
+ = skipMany1 xmlSpaceChar
+ >>
return ()
skipS0 :: SParser ()
skipS0
- = do
- skipMany xmlSpaceChar
+ = skipMany xmlSpaceChar
+ >>
return ()
name :: SParser XmlTree
name
= do
n <- XT.name
- return (mkDTDElem NAME [(a_name, n)] [])
+ return (mkDTDElem' NAME [(a_name, n)] [])
nmtoken :: SParser XmlTree
nmtoken
= do
n <- XT.nmtoken
- return (mkDTDElem NAME [(a_name, n)] [])
+ return (mkDTDElem' NAME [(a_name, n)] [])
-- ------------------------------------------------------------
--
@@ -179,7 +191,7 @@
skipS
(al, cl) <- contentspec
skipS0
- return [mkDTDElem ELEMENT ((a_name, n) : al) cl]
+ return [mkDTDElem' ELEMENT ((a_name, n) : al) cl]
contentspec :: SParser (Attributes, XmlTrees)
contentspec
@@ -206,7 +218,7 @@
= ( do
(al, cl) <- choiceOrSeq
modifier <- optOrRep
- return ([(a_type, v_children)], [mkDTDElem CONTENT (modifier ++ al) cl])
+ return ([(a_type, v_children)], [mkDTDElem' CONTENT (modifier ++ al) cl])
)
"element content"
@@ -261,14 +273,14 @@
m <- optOrRep
return ( case m of
[(_, "")] -> n
- _ -> mkDTDElem CONTENT (m ++ [(a_kind, v_seq)]) [n]
+ _ -> mkDTDElem' CONTENT (m ++ [(a_kind, v_seq)]) [n]
)
)
<|>
( do
(al, cl) <- choiceOrSeq
m <- optOrRep
- return (mkDTDElem CONTENT (m ++ al) cl)
+ return (mkDTDElem' CONTENT (m ++ al) cl)
)
-- ------------------------------------------------------------
@@ -296,7 +308,7 @@
else do
_ <- char '*' "closing parent for mixed content (\")*\")"
return ( [ (a_type, v_mixed) ]
- , [ mkDTDElem CONTENT [ (a_modifier, "*")
+ , [ mkDTDElem' CONTENT [ (a_modifier, "*")
, (a_kind, v_choice)
] nl
]
@@ -322,7 +334,7 @@
return (map (mkDTree n) al)
where
mkDTree n' (al, cl)
- = mkDTDElem ATTLIST ((a_name, n') : al) cl
+ = mkDTDElem' ATTLIST ((a_name, n') : al) cl
attDef :: SParser (Attributes, XmlTrees)
attDef
@@ -426,7 +438,7 @@
skipS
(al, cl) <- entityDef
skipS0
- return [mkDTDElem ENTITY ((a_name, n) : al) cl]
+ return [mkDTDElem' ENTITY ((a_name, n) : al) cl]
entityDef :: SParser (Attributes, XmlTrees)
entityDef
@@ -450,7 +462,7 @@
skipS
(al, cs) <- peDef
skipS0
- return [mkDTDElem PENTITY ((a_name, n) : al) cs]
+ return [mkDTDElem' PENTITY ((a_name, n) : al) cs]
peDef :: SParser (Attributes, XmlTrees)
peDef
@@ -460,7 +472,7 @@
al <- externalID
return (al, [])
-entityValue :: GenParser Char state (Attributes, XmlTrees)
+entityValue :: XParser s (Attributes, XmlTrees)
entityValue
= do
v <- XT.entityValueT
@@ -520,7 +532,7 @@
publicID
)
skipS0
- return [mkDTDElem NOTATION ((a_name, n) : eid) []]
+ return [mkDTDElem' NOTATION ((a_name, n) : eid) []]
publicID :: SParser Attributes
publicID
@@ -540,7 +552,7 @@
skipS0
let n' = stringToUpper n
if n' `elem` [k_include, k_ignore]
- then return [mkText n']
+ then return [mkText' n']
else fail $ "INCLUDE or IGNORE expected in conditional section"
-- ------------------------------------------------------------
@@ -579,13 +591,13 @@
parseXmlDTDEntityValue t -- (NTree (XDTD PEREF al) cl)
| isDTDPEref t
= ( either
- ( (:[]) . mkError c_err . (++ "\n") . show )
+ ( (:[]) . mkError' c_err . (++ "\n") . show )
( \cl' -> if null cl'
- then [mkText ""]
+ then [mkText' ""]
else cl'
)
.
- parse parser source
+ runParser parser (withoutNormNewline ()) source
) input
| otherwise
= []
@@ -608,10 +620,10 @@
= ( (:[])
.
either
- ( mkError c_err . (++ "\n") . show )
+ ( mkError' c_err . (++ "\n") . show )
( flip setChildren $ t ) -- \ cl' -> setChildren cl' t)
.
- parse parser source
+ runParser parser (withoutNormNewline ()) source
) input
| otherwise
= []
@@ -640,9 +652,9 @@
parseXmlDTDdecl :: XmlTree -> XmlTrees
parseXmlDTDdecl t -- (NTree (XDTD dtdElem al) cl)
| isDTD t
- = ( either ((:[]) . mkError c_err . (++ "\n") . show) id
+ = ( either ((:[]) . mkError' c_err . (++ "\n") . show) id
.
- runParser parser (initialLocalState pos) source
+ runParser parser (initialState pos) source
) input
| otherwise
= []
diff --git a/src/Text/XML/HXT/Parser/XmlDTDTokenParser.hs b/src/Text/XML/HXT/Parser/XmlDTDTokenParser.hs
--- a/src/Text/XML/HXT/Parser/XmlDTDTokenParser.hs
+++ b/src/Text/XML/HXT/Parser/XmlDTDTokenParser.hs
@@ -20,24 +20,25 @@
import Text.ParserCombinators.Parsec
import Text.XML.HXT.DOM.Interface
-import Text.XML.HXT.DOM.XmlNode ( mkDTDElem
- , mkText
+import Text.XML.HXT.DOM.XmlNode ( mkDTDElem'
+ , mkText'
)
import qualified Text.XML.HXT.Parser.XmlTokenParser as XT
+import Text.XML.HXT.Parser.XmlCharParser ( XParser )
-- ------------------------------------------------------------
--
-- DTD declaration tokenizer
-dtdDeclTokenizer :: GenParser Char state XmlTree
+dtdDeclTokenizer :: XParser s XmlTree
dtdDeclTokenizer
= do
(dcl, al) <- dtdDeclStart
content <- many1 dtdToken
dtdDeclEnd
- return $! mkDTDElem dcl al content
+ return $ mkDTDElem' dcl al content
-dtdDeclStart :: GenParser Char state (DTDElem, Attributes)
+dtdDeclStart :: XParser s (DTDElem, Attributes)
dtdDeclStart
= foldr1 (<|>) $
map (uncurry dtdStart) $
@@ -47,7 +48,7 @@
, ("NOTATION", NOTATION)
]
where
- dtdStart :: String -> DTDElem -> GenParser Char state (DTDElem, Attributes)
+ dtdStart :: String -> DTDElem -> XParser s (DTDElem, Attributes)
dtdStart dcl element
= try ( do
_ <- string "
- attrValue
+ entityValue
<|>
try peReference -- first try parameter entity ref %xxx;
<|>
percent -- else % may be indicator for parameter entity declaration
"DTD token"
-peReference :: GenParser Char state XmlTree
+peReference :: XParser s XmlTree
peReference
= do
r <- XT.peReference
- return $! (mkDTDElem PEREF [(a_peref, r)] [])
+ return $! (mkDTDElem' PEREF [(a_peref, r)] [])
-attrValue :: GenParser Char state XmlTree
-attrValue
+entityValue :: XParser s XmlTree
+entityValue
= do
- v <- XT.attrValue
- return $! mkText v
+ v <- XT.entityValue
+ return $ mkText' v
-dtdChars :: GenParser Char state XmlTree
+dtdChars :: XParser s XmlTree
dtdChars
= do
v <- many1 (XT.singleChar "%\"'<>[]") -- everything except string constants, < and >, [ and ] (for cond sections)
- return $! mkText v -- all illegal chars will be detected later during declaration parsing
+ return $ mkText' v -- all illegal chars will be detected later during declaration parsing
-percent :: GenParser Char state XmlTree
+percent :: XParser s XmlTree
percent
= do
c <- char '%'
- return $! mkText [c]
+ return $ mkText' [c]
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Parser/XmlParsec.hs b/src/Text/XML/HXT/Parser/XmlParsec.hs
--- a/src/Text/XML/HXT/Parser/XmlParsec.hs
+++ b/src/Text/XML/HXT/Parser/XmlParsec.hs
@@ -38,14 +38,15 @@
, encodingDecl
, xread
- , parseXmlAttrValue
, parseXmlContent
, parseXmlDocEncodingSpec
, parseXmlDocument
, parseXmlDTDPart
, parseXmlEncodingSpec
, parseXmlEntityEncodingSpec
- , parseXmlGeneralEntityValue
+ , parseXmlEntityValueAsAttrValue
+ , parseXmlEntityValueAsContent
+
, parseXmlPart
, parseXmlText
@@ -56,103 +57,121 @@
)
where
-import Text.ParserCombinators.Parsec
- ( GenParser
- , Parser
- , parse
- , (), (<|>)
- , char
- , string
- , eof
- , between
- , many, many1
- , option
- , try
- , unexpected
- , getPosition
- , getInput
- , sourceName
- )
-
-import Text.XML.HXT.DOM.ShowXml
- ( xshow
- )
+import Text.ParserCombinators.Parsec ( runParser
+ , (), (<|>)
+ , char
+ , string
+ , eof
+ , between
+ , many
+ , many1
+ , notFollowedBy
+ , option
+ , try
+ , unexpected
+ , getPosition
+ , getInput
+ , sourceName
+ )
+import Text.XML.HXT.DOM.ShowXml ( xshow
+ )
import Text.XML.HXT.DOM.Interface
-
-import Text.XML.HXT.DOM.XmlNode
- ( mkElement
- , mkAttr
- , mkRoot
- , mkDTDElem
- , mkText
- , mkCmt
- , mkCdata
- , mkError
- , mkPi
- , isText
- , isRoot
- , getText
- , getChildren
- , getAttrl
- , getAttrName
- , changeAttrl
- , mergeAttrl
- )
-
-import Text.XML.HXT.Parser.XmlCharParser
- ( xmlChar
- )
+import Text.XML.HXT.DOM.XmlNode ( mkElement'
+ , mkAttr'
+ , mkRoot'
+ , mkDTDElem'
+ , mkText'
+ , mkCmt'
+ , mkCdata'
+ , mkError'
+ , mkPi'
+ , isText
+ , isRoot
+ , getText
+ , getChildren
+ , getAttrl
+ , getAttrName
+ , changeAttrl
+ , mergeAttrl
+ )
+import Text.XML.HXT.Parser.XmlCharParser ( xmlChar
+ , XParser
+ , SimpleXParser
+ , XPState
+ , withNormNewline
+ , withoutNormNewline
+ )
import qualified Text.XML.HXT.Parser.XmlTokenParser as XT
import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD
-import Data.Char (toLower)
+import Control.FlatSeq
+
+import Data.Char (toLower)
import Data.Maybe
+-- import Debug.Trace
+
-- ------------------------------------------------------------
--
-- Character Data (2.4)
-charData :: GenParser Char state XmlTrees
+charData :: XParser s XmlTrees
charData
= many (charData' <|> XT.referenceT)
-charData' :: GenParser Char state XmlTree
+charData' :: XParser s XmlTree
charData'
- = try ( do
- t <- XT.allBut1 many1 (\ c -> not (c `elem` "<&")) "]]>"
- return (mkText $! t)
- )
+ = do
+ t <- XT.allBut1 many1 (\ c -> not (c `elem` "<&")) "]]>"
+ return (mkText' t)
-- ------------------------------------------------------------
--
-- Comments (2.5)
-comment :: GenParser Char state XmlTree
-
+comment :: XParser s XmlTree
comment
+ = comment'' $ XT.checkString "") (XT.allBut many "--")
- return (mkCmt $! c)
+ c <- between op (string ("-->")) (XT.allBut many "--")
+ return (mkCmt' c)
) "comment"
-- ------------------------------------------------------------
--
-- Processing Instructions
-pI :: GenParser Char state XmlTree
-pI
- = between (try $ string "")
+pI :: XParser s XmlTree
+pI = pI'' $ XT.checkString "> return ())
+
+pI'' :: XParser s () -> XParser s XmlTree
+pI'' op
+ = between op (string "?>")
( do
n <- pITarget
- p <- option "" (do
- _ <- XT.sPace
+ p <- option "" (XT.sPace
+ >>
XT.allBut many "?>"
)
- return $ mkPi (mkName n) [mkAttr (mkName a_value) [mkText p]]
+ return (mkPi' (mkName n) [mkAttr' (mkName a_value) [mkText' p]])
) "processing instruction"
where
- pITarget :: GenParser Char state String
+ pITarget :: XParser s String
pITarget = ( do
n <- XT.name
if map toLower n == t_xml
@@ -164,28 +183,38 @@
--
-- CDATA Sections (2.7)
-cDSect :: GenParser Char state XmlTree
-
+cDSect :: XParser s XmlTree
cDSect
+ = cDSect'' $ XT.checkString "> return ())
+
+cDSect'' :: XParser s () -> XParser s XmlTree
+cDSect'' op
= do
- t <- between ( try $ string "") (XT.allBut many "]]>")
- return (mkCdata $! t)
+ t <- between op (string "]]>") (XT.allBut many "]]>")
+ return (mkCdata' t)
"CDATA section"
-- ------------------------------------------------------------
--
-- Document (2.1) and Prolog (2.8)
-document :: GenParser Char state XmlTree
+document :: XParser s XmlTree
document
= do
pos <- getPosition
dl <- document'
- return $ mkRoot [ mkAttr (mkName a_source) [mkText (sourceName pos)]
- , mkAttr (mkName a_status) [mkText (show c_ok)]
+ return (mkRoot' [ mkAttr' (mkName a_source) [mkText' (sourceName pos)]
+ , mkAttr' (mkName a_status) [mkText' (show c_ok)]
] dl
+ )
-document' :: GenParser Char state XmlTrees
+document' :: XParser s XmlTrees
document'
= do
pl <- prolog
@@ -194,7 +223,7 @@
eof
return (pl ++ [el] ++ ml)
-prolog :: GenParser Char state XmlTrees
+prolog :: XParser s XmlTrees
prolog
= do
xml <- option [] xMLDecl'
@@ -203,7 +232,7 @@
misc2 <- many misc
return (xml ++ misc1 ++ dtdPart ++ misc2)
-xMLDecl :: GenParser Char state XmlTrees
+xMLDecl :: XParser s XmlTrees
xMLDecl
= between (try $ string "")
( do
@@ -215,32 +244,34 @@
)
"xml declaration"
-xMLDecl' :: GenParser Char state XmlTrees
+xMLDecl' :: XParser s XmlTrees
xMLDecl'
= do
al <- xMLDecl
- return [mkPi (mkName t_xml) al]
+ return [mkPi' (mkName t_xml) al]
-xMLDecl'' :: GenParser Char state XmlTree
+xMLDecl'' :: XParser s XmlTree
xMLDecl''
= do
al <- option [] (try xMLDecl)
- return (mkRoot al [])
+ return (mkRoot' al [])
-versionInfo :: GenParser Char state XmlTrees
+versionInfo :: XParser s XmlTrees
versionInfo
= ( do
- _ <- try ( do
- XT.skipS
- XT.keyword a_version
- )
+ try ( XT.skipS
+ >>
+ XT.keyword a_version
+ >>
+ return ()
+ )
XT.eq
vi <- XT.quoted XT.versionNum
- return [mkAttr (mkName a_version) [mkText vi]]
+ return [mkAttr' (mkName a_version) [mkText' vi]]
)
"version info (with quoted version number)"
-misc :: GenParser Char state XmlTree
+misc :: XParser s XmlTree
misc
= comment
<|>
@@ -248,7 +279,7 @@
<|>
( ( do
ws <- XT.sPace
- return (mkText ws)
+ return (mkText' ws)
) ""
)
@@ -256,7 +287,7 @@
--
-- Document Type definition (2.8)
-doctypedecl :: GenParser Char state XmlTrees
+doctypedecl :: XParser s XmlTrees
doctypedecl
= between (try $ string "')
( do
@@ -274,10 +305,10 @@
XT.skipS0
return m
)
- return [mkDTDElem DOCTYPE ((a_name, n) : exId) markup]
+ return [mkDTDElem' DOCTYPE ((a_name, n) : exId) markup]
)
-markupOrDeclSep :: GenParser Char state XmlTrees
+markupOrDeclSep :: XParser s XmlTrees
markupOrDeclSep
= ( do
ll <- many ( markupdecl
@@ -289,7 +320,7 @@
return (concat ll)
)
-declSep :: GenParser Char state XmlTrees
+declSep :: XParser s XmlTrees
declSep
= XT.mkList XT.peReferenceT
<|>
@@ -298,7 +329,7 @@
return []
)
-markupdecl :: GenParser Char state XmlTrees
+markupdecl :: XParser s XmlTrees
markupdecl
= XT.mkList
( pI
@@ -312,41 +343,44 @@
--
-- Standalone Document Declaration (2.9)
-sDDecl :: GenParser Char state XmlTrees
+sDDecl :: XParser s XmlTrees
sDDecl
= do
- _ <- try (do
- XT.skipS
- XT.keyword a_standalone
- )
+ try ( XT.skipS
+ >>
+ XT.keyword a_standalone
+ >>
+ return ()
+ )
XT.eq
sd <- XT.quoted (XT.keywords [v_yes, v_no])
- return [mkAttr (mkName a_standalone) [mkText sd]]
+ return [mkAttr' (mkName a_standalone) [mkText' sd]]
-- ------------------------------------------------------------
--
-- element, tags and content (3, 3.1)
-element :: GenParser Char state XmlTree
+element :: XParser s XmlTree
element
+ = char '<'
+ >>
+ element'
+
+element' :: XParser s XmlTree
+element'
= ( do
e <- elementStart
- elementRest e
+ rwnf e `seq` elementRest e -- evaluate name and attribute list before parsing contents
) "element"
-elementStart :: GenParser Char state (String, [(String, XmlTrees)])
+
+elementStart :: XParser s (QName, XmlTrees)
elementStart
= do
- n <- ( try ( do
- _ <- char '<'
- n <- XT.name
- return n
- )
- "start tag"
- )
- ass <- attrList
+ n <- XT.name
+ al <- attrList
XT.skipS0
- return (n, ass)
+ return (mkName n, al)
where
attrList
= option [] ( do
@@ -357,49 +391,53 @@
= option [] ( do
a1 <- attribute
al <- attrList
- let (n, _v) = a1
- if isJust . lookup n $ al
- then unexpected ("attribute name " ++ show n ++ " occurs twice in attribute list")
+ let n = fromJust . getAttrName $ a1
+ if n `elem` map (fromJust . getAttrName) al
+ then unexpected
+ ( "attribute name " ++
+ show (qualifiedName n) ++
+ " occurs twice in attribute list"
+ )
else return (a1 : al)
)
-elementRest :: (String, [(String, XmlTrees)]) -> GenParser Char state XmlTree
+elementRest :: (QName, XmlTrees) -> XParser s XmlTree
elementRest (n, al)
= ( do
- _ <- try $ string "/>"
- return $! (mkElement (mkName n) (map (mkA $!) al) [])
+ XT.checkString "/>"
+ return $ mkElement' n al []
)
<|>
( do
- _ <- XT.gt
+ XT.gt
c <- content
eTag n
- return $! (mkElement (mkName n) (map (mkA $!) al) $! c)
+ return $ mkElement' n al c
)
"proper attribute list followed by \"/>\" or \">\""
- where
- mkA (n', ts') = mkAttr (mkName n') ts'
-eTag :: String -> GenParser Char state ()
+eTag :: QName -> XParser s ()
eTag n'
= do
- _ <- try ( string " ""
+ XT.checkString " ""
n <- XT.name
XT.skipS0
- _ <- XT.gt
- if n == n'
+ XT.gt
+ if n == qualifiedName n'
then return ()
- else unexpected ("illegal end tag found, expected")
+ else unexpected ("illegal end tag found, expected")
-attribute :: GenParser Char state (String, XmlTrees)
+attribute :: XParser s XmlTree
attribute
= do
n <- XT.name
XT.eq
v <- XT.attrValueT
- return (n, v)
+ return $ mkAttr' (mkName n) v
-content :: GenParser Char state XmlTrees
+{- this parser corresponds to the XML spec but it's inefficent because of more than 1 char lookahead
+
+content :: XParser s XmlTrees
content
= do
c1 <- charData
@@ -417,11 +455,45 @@
return (l : c)
)
return (c1 ++ concat cl)
+-}
-contentWithTextDecl :: GenParser Char state XmlTrees
+-- this simpler content parser does not need more than a single lookahead
+-- so no try parsers (inefficient) are neccessary
+
+content :: XParser s XmlTrees
+content
+ = many $
+ ( do -- parse markup but no closing tags
+ try ( XT.lt
+ >>
+ notFollowedBy (char '/')
+ >>
+ return ()
+ )
+ markup
+ )
+ <|>
+ charData'
+ <|>
+ XT.referenceT
+ where
+ markup
+ = element'
+ <|>
+ pI'
+ <|>
+ ( char '!'
+ >>
+ ( comment'
+ <|>
+ cDSect'
+ )
+ )
+
+contentWithTextDecl :: XParser s XmlTrees
contentWithTextDecl
- = do
- _ <- option [] textDecl
+ = option [] textDecl
+ >>
content
-- ------------------------------------------------------------
@@ -432,25 +504,25 @@
-- first the whole content is detected,
-- and then, after PE substitution include sections are parsed again
-conditionalSect :: GenParser Char state XmlTree
+conditionalSect :: XParser s XmlTree
conditionalSect
= do
- _ <- try $ string ""
+ = ( XT.checkString "]]>"
+ >>
return ""
)
<|>
( do
- _ <- try $ string "" ++ cs2)
@@ -466,7 +538,7 @@
--
-- External Entities (4.2.2)
-externalID :: GenParser Char state Attributes
+externalID :: XParser s Attributes
externalID
= ( do
_ <- XT.keyword k_system
@@ -490,7 +562,7 @@
--
-- Text Declaration (4.3.1)
-textDecl :: GenParser Char state XmlTrees
+textDecl :: XParser s XmlTrees
textDecl
= between (try $ string "")
( do
@@ -502,26 +574,28 @@
"text declaration"
-textDecl'' :: GenParser Char state XmlTree
+textDecl'' :: XParser s XmlTree
textDecl''
= do
al <- option [] (try textDecl)
- return (mkRoot al [])
+ return (mkRoot' al [])
-- ------------------------------------------------------------
--
-- Encoding Declaration (4.3.3)
-encodingDecl :: GenParser Char state XmlTrees
+encodingDecl :: XParser s XmlTrees
encodingDecl
= do
- _ <- try ( do
- XT.skipS
- XT.keyword a_encoding
- )
+ try ( XT.skipS
+ >>
+ XT.keyword a_encoding
+ >>
+ return ()
+ )
XT.eq
ed <- XT.quoted XT.encName
- return [mkAttr (mkName a_encoding) [mkText ed]]
+ return [mkAttr' (mkName a_encoding) [mkText' ed]]
-- ------------------------------------------------------------
--
@@ -540,7 +614,7 @@
xread :: String -> XmlTrees
xread str
- = parseXmlFromString parser loc str
+ = parseXmlFromString parser (withNormNewline ()) loc str
where
loc = "string: " ++ show (if length str > 40 then take 40 str ++ "..." else str)
parser = do
@@ -559,16 +633,16 @@
-- a more general version of 'parseXmlContent'.
-- The parser to be used and the context are extra parameter
-parseXmlText :: Parser XmlTrees -> String -> XmlTree -> XmlTrees
-parseXmlText p loc = parseXmlFromString p loc . xshow . (:[])
+parseXmlText :: SimpleXParser XmlTrees -> XPState () -> String -> XmlTree -> XmlTrees
+parseXmlText p s0 loc = parseXmlFromString p s0 loc . xshow . (:[])
parseXmlDocument :: String -> String -> XmlTrees
-parseXmlDocument = parseXmlFromString document'
-
+parseXmlDocument = parseXmlFromString document' (withNormNewline ())
-parseXmlFromString :: Parser XmlTrees -> String -> String -> XmlTrees
-parseXmlFromString parser loc
- = either ((:[]) . mkError c_err . (++ "\n") . show) id . parse parser loc
+parseXmlFromString :: SimpleXParser XmlTrees -> XPState () -> String -> String -> XmlTrees
+parseXmlFromString parser s0 loc
+ = either ((:[]) . mkError' c_err . (++ "\n") . show) id
+ . runParser parser s0 loc
-- ------------------------------------------------------------
--
@@ -576,17 +650,17 @@
removeEncodingSpec :: XmlTree -> XmlTrees
removeEncodingSpec t
| isText t
- = ( either ((:[]) . mkError c_err . (++ "\n") . show) ((:[]) . mkText)
- . parse parser "remove encoding spec"
+ = ( either ((:[]) . mkError' c_err . (++ "\n") . show) ((:[]) . mkText')
+ . runParser parser (withNormNewline ()) "remove encoding spec"
. fromMaybe ""
. getText
) t
| otherwise
= [t]
where
- parser :: Parser String
- parser = do
- _ <- option [] textDecl
+ parser :: XParser s String
+ parser = option [] textDecl
+ >>
getInput
-- ------------------------------------------------------------
@@ -594,13 +668,14 @@
-- |
-- general parser for parsing arbitray parts of a XML document
-parseXmlPart :: Parser XmlTrees -> String -> String -> XmlTree -> XmlTrees
+parseXmlPart :: SimpleXParser XmlTrees -> String -> String -> XmlTree -> XmlTrees
parseXmlPart parser expected context t
- = parseXmlText ( do
- res <- parser
- eof expected
- return res
- ) context
+ = parseXmlText
+ ( do
+ res <- parser
+ eof expected
+ return res
+ ) (withoutNormNewline ()) context
$ t
-- ------------------------------------------------------------
@@ -617,17 +692,17 @@
-- |
-- Parser for general entites
-parseXmlGeneralEntityValue :: String -> XmlTree -> XmlTrees
-parseXmlGeneralEntityValue
+parseXmlEntityValueAsContent :: String -> XmlTree -> XmlTrees
+parseXmlEntityValueAsContent
= parseXmlPart content "general entity value"
-- ------------------------------------------------------------
-- |
--- Parser for attribute values
+-- Parser for entity substitution within attribute values
-parseXmlAttrValue :: String -> XmlTree -> XmlTrees
-parseXmlAttrValue
+parseXmlEntityValueAsAttrValue :: String -> XmlTree -> XmlTrees
+parseXmlEntityValueAsAttrValue
= parseXmlPart (XT.attrValueT' "<&") "attribute value"
-- ------------------------------------------------------------
@@ -663,7 +738,7 @@
-- in case of a valid encoding spec
-- else the unchanged tree
-parseXmlEncodingSpec :: Parser XmlTree -> XmlTree -> XmlTrees
+parseXmlEncodingSpec :: SimpleXParser XmlTree -> XmlTree -> XmlTrees
parseXmlEncodingSpec encDecl x
= (:[]) .
( if isRoot x
@@ -672,14 +747,24 @@
) $ x
where
parseEncSpec r
- = case ( parse encDecl source . xshow . getChildren $ r ) of
+ = case ( runParser encDecl (withNormNewline ()) source
+ . xshow
+ . getChildren
+ $ r
+ ) of
Right t
-> changeAttrl (mergeAttrl . fromMaybe [] . getAttrl $ t) r
Left _
-> r
where
-- arrow \"getAttrValue a_source\" programmed on the tree level (oops!)
- source = xshow . concat . map getChildren . filter ((== a_source) . maybe "" qualifiedName . getAttrName) . fromMaybe [] . getAttrl $ r
+ source = xshow
+ . concat
+ . map getChildren
+ . filter ((== a_source)
+ . maybe "" qualifiedName . getAttrName)
+ . fromMaybe []
+ . getAttrl $ r
parseXmlEntityEncodingSpec :: XmlTree -> XmlTrees
parseXmlEntityEncodingSpec = parseXmlEncodingSpec textDecl''
diff --git a/src/Text/XML/HXT/Parser/XmlTokenParser.hs b/src/Text/XML/HXT/Parser/XmlTokenParser.hs
--- a/src/Text/XML/HXT/Parser/XmlTokenParser.hs
+++ b/src/Text/XML/HXT/Parser/XmlTokenParser.hs
@@ -18,10 +18,13 @@
module Text.XML.HXT.Parser.XmlTokenParser
( allBut
, allBut1
+ , amp
, asciiLetter
+ , attrChar
, attrValue
, bar
, charRef
+ , checkString
, comma
, dq
, encName
@@ -78,30 +81,28 @@
)
where
-import Data.Char.Properties.XMLCharProps
- ( isXmlChar
- )
-import Data.String.Unicode
- ( intToCharRef
- , intToCharRefHex
- )
-
+import Data.Char.Properties.XMLCharProps ( isXmlChar
+ , isXmlCharCR
+ )
+import Data.String.Unicode ( intToCharRef
+ , intToCharRefHex
+ )
import Text.ParserCombinators.Parsec
import Text.XML.HXT.DOM.Interface
-import Text.XML.HXT.DOM.XmlNode
- ( mkDTDElem
- , mkText
- , mkCharRef
- , mkEntityRef
- )
-import Text.XML.HXT.Parser.XmlCharParser
- ( xmlNameChar
- , xmlNameStartChar
- , xmlNCNameChar
- , xmlNCNameStartChar
- , xmlSpaceChar
- )
+import Text.XML.HXT.DOM.XmlNode ( mkDTDElem'
+ , mkText'
+ , mkCharRef'
+ , mkEntityRef'
+ )
+import Text.XML.HXT.Parser.XmlCharParser ( xmlNameChar
+ , xmlNameStartChar
+ , xmlNCNameChar
+ , xmlNCNameStartChar
+ , xmlSpaceChar
+ , xmlCRLFChar
+ , XParser
+ )
-- ------------------------------------------------------------
--
@@ -111,19 +112,19 @@
-- ------------------------------------------------------------
-sPace :: GenParser Char state String
+sPace :: XParser s String
sPace
= many1 xmlSpaceChar
-sPace0 :: GenParser Char state String
+sPace0 :: XParser s String
sPace0
= many xmlSpaceChar
-skipS :: GenParser Char state ()
+skipS :: XParser s ()
skipS
= skipMany1 xmlSpaceChar
-skipS0 :: GenParser Char state ()
+skipS0 :: XParser s ()
skipS0
= skipMany xmlSpaceChar
@@ -131,55 +132,53 @@
--
-- Names and Tokens (2.3)
-asciiLetter :: GenParser Char state Char
+asciiLetter :: XParser s Char
asciiLetter
= satisfy (\ c -> ( c >= 'A' && c <= 'Z' ||
c >= 'a' && c <= 'z' )
)
"ASCII letter"
-name :: GenParser Char state String
+name :: XParser s String
name
- = try ( do
- s1 <- xmlNameStartChar
- sl <- many xmlNameChar
- return (s1 : sl)
- )
+ = do
+ s1 <- xmlNameStartChar
+ sl <- many xmlNameChar
+ return (s1 : sl)
"Name"
-- Namespaces in XML: Rules [4-5] NCName:
-ncName :: GenParser Char state String
+ncName :: XParser s String
ncName
- = try ( do
- s1 <- xmlNCNameStartChar
- sl <- many xmlNCNameChar
- return (s1 : sl)
- )
+ = do
+ s1 <- xmlNCNameStartChar
+ sl <- many xmlNCNameChar
+ return (s1 : sl)
"NCName"
-- Namespaces in XML: Rules [6-8] QName:
-qName :: GenParser Char state (String, String)
+qName :: XParser s (String, String)
qName
= do
s1 <- ncName
- s2 <- option "" ( do
- _ <- char ':'
- ncName
- )
- return ( if null s2 then (s2, s1) else (s1, s2) )
+ s2 <- option "" (char ':' >> ncName)
+ return ( if null s2
+ then (s2, s1)
+ else (s1, s2)
+ )
-nmtoken :: GenParser Char state String
+nmtoken :: XParser s String
nmtoken
= try (many1 xmlNameChar)
"Nmtoken"
-names :: GenParser Char state [String]
+names :: XParser s [String]
names
= sepBy1 name sPace
-nmtokens :: GenParser Char state [String]
+nmtokens :: XParser s [String]
nmtokens
= sepBy1 nmtoken sPace
@@ -187,27 +186,38 @@
--
-- Literals (2.3)
-singleChar :: String -> GenParser Char state Char
+singleChar :: String -> XParser s Char
singleChar notAllowed
- = satisfy (\ c -> isXmlChar c && not (c `elem` notAllowed))
+ = satisfy (\ c -> isXmlCharCR c && c `notElem` notAllowed)
+ <|>
+ xmlCRLFChar
-singleChars :: String -> GenParser Char state String
+singleChars :: String -> XParser s String
singleChars notAllowed
= many1 (singleChar notAllowed)
-entityValue :: GenParser Char state String
+entityValue :: XParser s String
entityValue
- = attrValue
+ = ( do
+ v <- entityValueDQ
+ return ("\"" ++ v ++ "\"")
+ )
+ <|>
+ ( do
+ v <- entityValueSQ
+ return ("'" ++ v ++ "'")
+ )
+ "entity value (in quotes)"
-attrValueDQ :: GenParser Char state String
-attrValueDQ
- = between dq dq (concRes $ many $ attrChar "<&\"")
+entityValueDQ :: XParser s String
+entityValueDQ
+ = between dq dq (concRes $ many $ attrChar "&\"")
-attrValueSQ :: GenParser Char state String
-attrValueSQ
- = between sq sq (concRes $ many $ attrChar "<&\'")
+entityValueSQ :: XParser s String
+entityValueSQ
+ = between sq sq (concRes $ many $ attrChar "&\'")
-attrValue :: GenParser Char state String
+attrValue :: XParser s String
attrValue
= ( do
v <- attrValueDQ
@@ -220,29 +230,36 @@
)
"attribute value (in quotes)"
-attrChar :: String -> GenParser Char state String
+attrValueDQ :: XParser s String
+attrValueDQ
+ = between dq dq (concRes $ many $ attrChar "<&\"")
+
+attrValueSQ :: XParser s String
+attrValueSQ
+ = between sq sq (concRes $ many $ attrChar "<&\'")
+
+attrChar :: String -> XParser s String
attrChar notAllowed
= reference
<|>
mkList (singleChar notAllowed)
- "legal attribute character or reference"
-
+ ("legal attribute or entity character or reference (not allowed: " ++ show notAllowed ++ " )")
-systemLiteral :: GenParser Char state String
+systemLiteral :: XParser s String
systemLiteral
= between dq dq (many $ noneOf "\"")
<|>
between sq sq (many $ noneOf "\'")
"system literal (in quotes)"
-pubidLiteral :: GenParser Char state String
+pubidLiteral :: XParser s String
pubidLiteral
= between dq dq (many $ pubidChar "\'")
<|>
between sq sq (many $ pubidChar "")
"pubid literal (in quotes)"
where
- pubidChar :: String -> GenParser Char state Char
+ pubidChar :: String -> XParser s Char
pubidChar quoteChars
= asciiLetter
<|>
@@ -258,7 +275,7 @@
--
-- Character and Entity References (4.1)
-reference :: GenParser Char state String
+reference :: XParser s String
reference
= ( do
i <- charRef
@@ -270,8 +287,7 @@
return ("&" ++ n ++ ";")
)
-
-checkCharRef :: Int -> GenParser Char state Int
+checkCharRef :: Int -> XParser s Int
checkCharRef i
= if ( i <= fromEnum (maxBound::Char)
&& isXmlChar (toEnum i)
@@ -279,37 +295,36 @@
then return i
else unexpected ("illegal value in character reference: " ++ intToCharRef i ++ " , in hex: " ++ intToCharRefHex i)
-charRef :: GenParser Char state Int
+charRef :: XParser s Int
charRef
= do
- _ <- try (string "&#x")
+ checkString "&#x"
d <- many1 hexDigit
- _ <- semi
+ semi
checkCharRef (hexStringToInt d)
<|>
do
- _ <- try (string "&#")
+ checkString "&#"
d <- many1 digit
- _ <- semi
+ semi
checkCharRef (decimalStringToInt d)
"character reference"
-
-entityRef :: GenParser Char state String
+entityRef :: XParser s String
entityRef
= do
- _ <- char '&'
+ amp
n <- name
- _ <- semi
+ semi
return n
"entity reference"
-peReference :: GenParser Char state String
+peReference :: XParser s String
peReference
= try ( do
_ <- char '%'
n <- name
- _ <- semi
+ semi
return n
)
"parameter-entity reference"
@@ -318,14 +333,14 @@
--
-- 4.3
-encName :: GenParser Char state String
+encName :: XParser s String
encName
= do
c <- asciiLetter
r <- many (asciiLetter <|> digit <|> oneOf "._-")
return (c:r)
-versionNum :: GenParser Char state String
+versionNum :: XParser s String
versionNum
= many1 xmlNameChar
@@ -334,7 +349,7 @@
--
-- keywords
-keyword :: String -> GenParser Char state String
+keyword :: String -> XParser s String
keyword kw
= try ( do
n <- name
@@ -344,7 +359,7 @@
)
kw
-keywords :: [String] -> GenParser Char state String
+keywords :: [String] -> XParser s String
keywords
= foldr1 (<|>) . map keyword
@@ -352,7 +367,7 @@
--
-- parser for quoted attribute values
-quoted :: GenParser Char state a -> GenParser Char state a
+quoted :: XParser s a -> XParser s a
quoted p
= between dq dq p
<|>
@@ -362,15 +377,23 @@
--
-- simple char parsers
-dq, sq, lt, gt, semi :: GenParser Char state Char
+dq, sq, lt, gt, semi, amp :: XParser s ()
-dq = char '\"'
-sq = char '\''
-lt = char '<'
-gt = char '>'
-semi = char ';'
+dq = char '\"' >> return ()
+sq = char '\'' >> return ()
+lt = char '<' >> return ()
+gt = char '>' >> return ()
+semi = char ';' >> return ()
+amp = char '&' >> return ()
-separator :: Char -> GenParser Char state ()
+{-# INLINE dq #-}
+{-# INLINE sq #-}
+{-# INLINE lt #-}
+{-# INLINE gt #-}
+{-# INLINE semi #-}
+{-# INLINE amp #-}
+
+separator :: Char -> XParser s ()
separator c
= do
_ <- try ( do
@@ -380,42 +403,45 @@
skipS0
[c]
-bar, comma, eq, lpar, rpar :: GenParser Char state ()
+bar, comma, eq, lpar, rpar :: XParser s ()
bar = separator '|'
comma = separator ','
eq = separator '='
-lpar
- = do
- _ <- char '('
- skipS0
+{-# INLINE bar #-}
+{-# INLINE comma #-}
+{-# INLINE eq #-}
-rpar
- = do
- skipS0
- _ <- char ')'
- return ()
+lpar = char '(' >> skipS0
+{-# INLINE lpar #-}
+rpar = skipS0 >> char ')' >> return ()
+{-# INLINE rpar #-}
+checkString :: String -> XParser s ()
+checkString s
+ = try $ string s >> return ()
+{-# INLINE checkString #-}
+
-- ------------------------------------------------------------
--
-- all chars but not a special substring
-allBut :: (GenParser Char state Char -> GenParser Char state String) -> String -> GenParser Char state String
+allBut :: (XParser s Char -> XParser s String) -> String -> XParser s String
allBut p str
= allBut1 p (const True) str
-allBut1 :: (GenParser Char state Char -> GenParser Char state String) -> (Char -> Bool) -> String -> GenParser Char state String
+allBut1 :: (XParser s Char -> XParser s String) -> (Char -> Bool) -> String -> XParser s String
allBut1 p prd (c:rest)
- = p ( satisfy (\ x -> isXmlChar x && prd x && not (x == c) )
+ = p ( satisfy (\ x -> isXmlCharCR x && prd x && not (x == c) )
<|>
- try ( do
- _ <- char c
- notFollowedBy ( do
- _ <- try (string rest)
- return c
- )
+ xmlCRLFChar
+ <|>
+ try ( char c
+ >>
+ notFollowedBy (try (string rest) >> return c)
+ >>
return c
)
)
@@ -427,13 +453,13 @@
--
-- concatenate parse results
-concRes :: GenParser Char state [[a]] -> GenParser Char state [a]
+concRes :: XParser s [[a]] -> XParser s [a]
concRes p
= do
sl <- p
return (concat sl)
-mkList :: GenParser Char state a -> GenParser Char state [a]
+mkList :: XParser s a -> XParser s [a]
mkList p
= do
r <- p
@@ -447,20 +473,20 @@
--
-- Literals (2.3)
-nameT :: GenParser Char state XmlTree
+nameT :: XParser s XmlTree
nameT
= do
n <- name
- return (mkDTDElem NAME [(a_name, n)] [])
+ return (mkDTDElem' NAME [(a_name, n)] [])
-nmtokenT :: GenParser Char state XmlTree
+nmtokenT :: XParser s XmlTree
nmtokenT
= do
n <- nmtoken
- return (mkDTDElem NAME [(a_name, n)] [])
+ return (mkDTDElem' NAME [(a_name, n)] [])
-entityValueT :: GenParser Char state XmlTrees
+entityValueT :: XParser s XmlTrees
entityValueT
= do
sl <- between dq dq (entityTokensT "%&\"")
@@ -471,11 +497,11 @@
return sl
"entity value (in quotes)"
-entityTokensT :: String -> GenParser Char state XmlTrees
+entityTokensT :: String -> XParser s XmlTrees
entityTokensT notAllowed
= many (entityCharT notAllowed)
-entityCharT :: String -> GenParser Char state XmlTree
+entityCharT :: String -> XParser s XmlTree
entityCharT notAllowed
= peReferenceT
<|>
@@ -485,59 +511,74 @@
<|>
( do
cs <- many1 (singleChar notAllowed)
- return (mkText cs)
+ return (mkText' cs)
)
-attrValueT :: GenParser Char state XmlTrees
+attrValueT :: XParser s XmlTrees
attrValueT
= between dq dq (attrValueT' "<&\"")
<|>
between sq sq (attrValueT' "<&\'")
"attribute value (in quotes)"
-attrValueT' :: String -> GenParser Char state XmlTrees
+attrValueT' :: String -> XParser s XmlTrees
attrValueT' notAllowed
= many ( referenceT <|> singleCharsT notAllowed)
-singleCharsT :: String -> GenParser Char state XmlTree
+singleCharsT :: String -> XParser s XmlTree
singleCharsT notAllowed
= do
cs <- singleChars notAllowed
- return (mkText cs)
+ return (mkText' cs)
-- ------------------------------------------------------------
--
-- Character and Entity References (4.1)
-referenceT :: GenParser Char state XmlTree
+referenceT :: XParser s XmlTree
referenceT
= charRefT
<|>
entityRefT
-charRefT :: GenParser Char state XmlTree
+charRefT :: XParser s XmlTree
charRefT
= do
i <- charRef
- return $! (mkCharRef $! i)
+ return (mkCharRef' i)
-entityRefT :: GenParser Char state XmlTree
+entityRefT :: XParser s XmlTree
entityRefT
= do
n <- entityRef
- return $! (mkEntityRef $! n)
+ return $! (maybe (mkEntityRef' n) mkCharRef' . lookup n $ predefinedXmlEntities)
-bypassedEntityRefT :: GenParser Char state XmlTree
+-- optimization: predefined XML entity refs are converted into equivalent char refs
+-- so there is no need for an entitiy substitution phase, if there is no DTD
+-- Attention: entityRefT must only be called from within XML/HTML content
+-- in DTD parsing this optimization is not allowed because of different semantics
+-- of charRefs and entityRefs during substitution of entites in ENTITY definitions
+
+predefinedXmlEntities :: [(String, Int)]
+predefinedXmlEntities
+ = [ ("lt", 60)
+ , ("gt", 62)
+ , ("amp", 38)
+ , ("apos", 39)
+ , ("quot", 34)
+ ]
+
+bypassedEntityRefT :: XParser s XmlTree
bypassedEntityRefT
= do
n <- entityRef
- return $! (mkText ("&" ++ n ++ ";"))
+ return $! (mkText' ("&" ++ n ++ ";"))
-peReferenceT :: GenParser Char state XmlTree
+peReferenceT :: XParser s XmlTree
peReferenceT
= do
r <- peReference
- return $! (mkDTDElem PEREF [(a_peref, r)] [])
+ return $! (mkDTDElem' PEREF [(a_peref, r)] [])
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Version.hs b/src/Text/XML/HXT/Version.hs
--- a/src/Text/XML/HXT/Version.hs
+++ b/src/Text/XML/HXT/Version.hs
@@ -1,4 +1,4 @@
module Text.XML.HXT.Version
where
hxt_version :: String
-hxt_version = "8.5.1"
+hxt_version = "9.1.0"