wraxml (empty) → 0.3

raw patch · 26 files changed

+3711/−0 lines, 26 filesdep +HaXmldep +basedep +containerssetup-changed

Dependencies added: HaXml, base, containers, data-accessor, explicit-exception, hxt, hxt-filter, polyparse, tagsoup, tagsoup-ht, transformers, utility-ht, xml-basic

Files

• LICENSE +674/−0
• Setup.lhs +3/−0
• src/Data/Tree/BranchLeaf.hs +88/−0
• src/Data/Tree/BranchLeafLabel.hs +171/−0
• src/Text/HTML/WraXML/Document.hs +26/−0
• src/Text/HTML/WraXML/Entity.hs +14/−0
• src/Text/HTML/WraXML/String.hs +82/−0
• src/Text/HTML/WraXML/Table.hs +49/−0
• src/Text/HTML/WraXML/Tree.hs +137/−0
• src/Text/XML/WraXML/Document.hs +50/−0
• src/Text/XML/WraXML/Document/TagSoup.hs +87/−0
• src/Text/XML/WraXML/Document/TagSoupHT.hs +91/−0
• src/Text/XML/WraXML/Element.hs +160/−0
• src/Text/XML/WraXML/Position/HaXml.hs +22/−0
• src/Text/XML/WraXML/String.hs +160/−0
• src/Text/XML/WraXML/String/HXT.hs +31/−0
• src/Text/XML/WraXML/String/HaXml.hs +47/−0
• src/Text/XML/WraXML/Tree.hs +616/−0
• src/Text/XML/WraXML/Tree/HXT.hs +457/−0
• src/Text/XML/WraXML/Tree/HaXml.hs +132/−0
• src/Text/XML/WraXML/Tree/LazyParser.hs +29/−0
• src/Text/XML/WraXML/Tree/Literal.hs +54/−0
• src/Text/XML/WraXML/Tree/TagSoup.hs +207/−0
• src/Text/XML/WraXML/Tree/TagSoupHT.hs +236/−0
• src/Text/XML/WraXML/Utility.hs +4/−0
• wraxml.cabal +84/−0

@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.

@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,88 @@+module Data.Tree.BranchLeaf where++import           Data.Traversable as Traversable(Traversable(traverse))+import           Control.Applicative (Applicative, (<*>), )+import qualified Control.Applicative as App+import qualified Control.Monad as Monad+import qualified Data.List     as List++import Prelude hiding (map, mapM, )+++data T branch leaf =+     Branch branch [T branch leaf]+   | Leaf leaf+   deriving (Show)++map :: (branch0 -> branch1)+    -> (leaf0 -> leaf1)+    -> (T branch0 leaf0 -> T branch1 leaf1)+map branchF leafF = fold (Branch . branchF) (Leaf . leafF)++mapCond ::+       (branch -> Bool)+    -> (branch -> branch)+    -> (leaf -> leaf)+    -> (T branch leaf -> T branch leaf)+mapCond descend branchF leafF =+   let recourse =+          switch+             (\branch -> Branch (branchF branch) .+                if descend branch+                   then List.map recourse+                   else id)+             (Leaf . leafF)+   in  recourse++fold :: (branch -> [a] -> a)+     -> (leaf -> a)+     -> (T branch leaf -> a)+fold branchF leafF =+   let recourse =+          switch (\x -> branchF x . List.map recourse) leafF+   in  recourse++switch ::+        (branch -> [T branch leaf] -> a)+     -> (leaf -> a)+     -> (T branch leaf -> a)+switch branchF _ (Branch x subTrees) = branchF x subTrees+switch _ leafF (Leaf x)          = leafF x++allSubTrees :: T branch leaf -> [T branch leaf]+allSubTrees tree =+   tree :+   switch (const (concatMap allSubTrees)) (const []) tree++++mapA :: Applicative m =>+       (branch0 -> m branch1)+    -> (leaf0 -> m leaf1)+    -> (T branch0 leaf0 -> m (T branch1 leaf1))+mapA branchF leafF =+   foldA+      (App.liftA Branch . branchF)+      (App.liftA Leaf . leafF)++foldA :: Applicative m =>+        (branch -> m ([a] -> a))+     -> (leaf -> m a)+     -> (T branch leaf -> m a)+foldA branchF leafF =+   let recourse =+          switch (\x subTrees ->+                        branchF x <*> traverse recourse subTrees)+                   leafF+   in  recourse++foldM :: Monad m =>+        (branch -> [a] -> m a)+     -> (leaf -> m a)+     -> (T branch leaf -> m a)+foldM branchF leafF =+   let recourse =+          switch (\x subTrees ->+                        branchF x =<< Monad.mapM recourse subTrees)+                   leafF+   in  recourse

@@ -0,0 +1,171 @@+module Data.Tree.BranchLeafLabel where++import           Control.Monad.HT ((<=<))+import           Data.Traversable as Traversable(Traversable(traverse))+import           Control.Applicative (Applicative, (<*>), )+import qualified Control.Applicative as App+import qualified Control.Monad as Monad+import qualified Data.List     as List++import Prelude hiding (map, mapM, )+++type T i branch leaf = (i, Elem i branch leaf)++data Elem i branch leaf =+     Branch branch [T i branch leaf]+   | Leaf leaf+   deriving (Show)++map :: (branch0 -> branch1)+    -> (leaf0 -> leaf1)+    -> (T i branch0 leaf0 -> T i branch1 leaf1)+map branchF leafF = fold (,) (Branch . branchF) (Leaf . leafF)++mapLabel :: (i -> j)+    -> (T i branch leaf -> T j branch leaf)+mapLabel f = fold ((,) . f) Branch Leaf++mapCond ::+       (branch -> Bool)+    -> (branch -> branch)+    -> (leaf -> leaf)+    -> (T i branch leaf -> T i branch leaf)+mapCond descend branchF leafF =+   let recourse =+          switch (,)+             (\branch -> Branch (branchF branch) .+                if descend branch+                   then List.map recourse+                   else id)+             (Leaf . leafF)+   in  recourse++{- |+Process the subtrees for which the predicate holds.+If the predicate matches subtrees of a matching subtree,+the sub-subtrees are not mapped.+-}+mapSubTrees ::+       (branch -> Bool)+    -> ((branch, [T i branch leaf]) -> (branch, [T i branch leaf]))+    -> (T i branch leaf -> T i branch leaf)+mapSubTrees p f =+   let recourse =+          switch (,)+             (\branch subTrees -> uncurry Branch+                (if p branch+                   then f (branch, subTrees)+                   else (branch, List.map recourse subTrees)))+             Leaf+   in  recourse++filterBranch ::+       (branch -> Bool)+    -> (T i branch leaf -> [T i branch leaf])+filterBranch p =+   foldLabel+      (\i branch subTrees ->+         let jointSubTrees = concat subTrees+         in  if p branch+               then [(i, Branch branch jointSubTrees)]+               else jointSubTrees)+      (\i leaf -> [(i, Leaf leaf)])++fold :: (i -> a -> b)+     -> (branch -> [b] -> a)+     -> (leaf -> a)+     -> (T i branch leaf -> b)+fold iF branchF leafF =+   let recourse =+          switch iF (\x -> branchF x . List.map recourse) leafF+   in  recourse++switch ::+        (i -> a -> b)+     -> (branch -> [T i branch leaf] -> a)+     -> (leaf -> a)+     -> (T i branch leaf -> b)+switch iF branchF leafF (i,n) =+   iF i (switchElem branchF leafF n)++foldLabel ::+        (i -> branch -> [b] -> b)+     -> (i -> leaf -> b)+     -> (T i branch leaf -> b)+foldLabel branchF leafF =+   let recourse =+          switchLabel (\i x -> branchF i x . List.map recourse) leafF+   in  recourse++switchLabel ::+        (i -> branch -> [T i branch leaf] -> b)+     -> (i -> leaf -> b)+     -> (T i branch leaf -> b)+switchLabel branchF leafF (i,n) =+   switchElem (branchF i) (leafF i) n++switchElem ::+        (branch -> [T i branch leaf] -> a)+     -> (leaf -> a)+     -> (Elem i branch leaf -> a)+switchElem branchF _ (Branch x subTrees) =+   branchF x subTrees+switchElem _ leafF (Leaf x) = leafF x++allSubTrees :: T i branch leaf -> [T i branch leaf]+allSubTrees tree =+   tree :+   switch (flip const) (const (concatMap allSubTrees)) (const []) tree++++mapA :: Applicative m =>+       (branch0 -> m branch1)+    -> (leaf0 -> m leaf1)+    -> (T i branch0 leaf0 -> m (T i branch1 leaf1))+mapA branchF leafF =+   foldA+      (App.pure . (,))+      (App.liftA Branch . branchF)+      (App.liftA Leaf . leafF)++mapCondA :: Applicative m =>+       (branch -> Bool)+    -> (branch -> m branch)+    -> (leaf -> m leaf)+    -> (T i branch leaf -> m (T i branch leaf))+mapCondA descend branchF leafF =+   let recourse =+          switch+             (App.liftA . (,))+             (\branch -> App.liftA2 Branch (branchF branch) .+                if descend branch+                   then traverse recourse+                   else App.pure)+             (App.liftA Leaf . leafF)+   in  recourse++foldA :: Applicative m =>+        (i -> m (a -> b))+     -> (branch -> m ([b] -> a))+     -> (leaf -> m a)+     -> (T i branch leaf -> m b)+foldA iF branchF leafF =+   let recourse =+          switch (\i x -> iF i <*> x)+             (\x subTrees -> branchF x <*> traverse recourse subTrees)+             leafF+   in  recourse++foldM :: Monad m =>+        (i -> a -> m b)+     -> (branch -> [b] -> m a)+     -> (leaf -> m a)+     -> (T i branch leaf -> m b)+foldM iF branchF leafF =+   let recourse =+          switch ((=<<) . iF)+                   (\x -> branchF x <=< Monad.mapM recourse)+                   leafF+   in  recourse

@@ -0,0 +1,26 @@+module Text.HTML.WraXML.Document (+   XMLDoc.T(..), XMLDoc.lift, show,+   ) where++import qualified Text.HTML.WraXML.Tree    as HTMLTree+import qualified Text.XML.WraXML.Document as XMLDoc+import qualified Text.XML.WraXML.String   as XMLString+import qualified Text.XML.Basic.Name as Name++import Prelude hiding (show)+++show ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XMLDoc.T i name XMLString.T -> String+show (XMLDoc.Cons xml dtd trees) =+   let (showHTML, showXMLDecl) =+          maybe+             (HTMLTree.showsMany, id)+             (\xmlDecl ->+                 (HTMLTree.showsManyXHTML,+                  XMLDoc.showXMLDeclaration xmlDecl)) xml+   in  showXMLDecl .+       maybe id XMLDoc.showDocType dtd .+       showHTML trees $+       ""

@@ -0,0 +1,14 @@+module Text.HTML.WraXML.Entity+   (Name, HTMLEnt.mapNameToChar, mapCharToName, ) where++import qualified Text.HTML.Basic.Entity as HTMLEnt+import qualified Data.Map as Map++import Data.Tuple.HT (swap, )+++type Name = String++mapCharToName :: Map.Map Char Name+mapCharToName =+   Map.fromList $ map swap HTMLEnt.listInternetExploder

@@ -0,0 +1,82 @@+module Text.HTML.WraXML.String where++import qualified Text.XML.WraXML.String as XmlString+import qualified Text.HTML.Basic.Character as HTMLChar+import qualified Data.Char as Char+import qualified Text.XML.HXT.DOM.Unicode as Unicode++import qualified Control.Monad.Exception.Synchronous as Exc++import Text.XML.WraXML.Utility (compose, )+++type T = [Atom]++type Atom = HTMLChar.T+++{- |+Literal translation from pure strings.+This can only work, if the string does not contain special characters.+-}+fromString :: String -> T+fromString = map HTMLChar.fromUnicode++{- |+default routine+-}+fromUnicodeString :: String -> T+fromUnicodeString = map HTMLChar.asciiFromUnicode++fromUnicodeStringInternetExploder :: String -> T+fromUnicodeStringInternetExploder =+   map HTMLChar.asciiFromUnicodeInternetExploder+++toUnicodeStringOrFormat :: T -> String+toUnicodeStringOrFormat =+   flip compose "" .+   map HTMLChar.toUnicodeOrFormat++toUnicodeString :: T -> String+toUnicodeString = XmlString.toUnicodeString++++{- |+Decode plain characters using the given decoder,+and decode entities by HXT's XML entity table.+Decoding errors for both conversions are embedded where they occur.+-}+toUnicodeStringDecodingEmbedError ::+   Unicode.DecodingFctEmbedErrors -> T -> XmlString.EmbeddedExceptions+toUnicodeStringDecodingEmbedError f =+   concat .+   HTMLChar.switchUnicodeRuns+      (map Exc.fromEither . f)+      ((:[]) . HTMLChar.toUnicode . HTMLChar.fromCharRef)+      ((:[]) . HTMLChar.toUnicode . HTMLChar.fromEntityRef)++++{- |+Convert characters to lower case.+This uses ISO latin encoding and may fail for exotic characters.+-}+toLower :: T -> T+toLower = map HTMLChar.toLower++toUpper :: T -> T+toUpper = map HTMLChar.toUpper+++toCanonicalUnicodeString :: T -> String+toCanonicalUnicodeString = map Char.toLower . toUnicodeString++equalIgnoreCase :: T -> T -> Bool+equalIgnoreCase x y =+   toCanonicalUnicodeString x == toCanonicalUnicodeString y++elemIgnoreCase :: T -> [T] -> Bool+elemIgnoreCase x ys =+   elem (toCanonicalUnicodeString x) (map toCanonicalUnicodeString ys)

@@ -0,0 +1,49 @@+module Text.HTML.WraXML.Table where++-- import qualified Text.HTML.WraXML.Tree as HTMLTree+import qualified Text.XML.WraXML.Tree    as XMLTree+import qualified Text.XML.WraXML.Element as Elem++import qualified Text.XML.Basic.Name as Name++import           Data.Maybe(mapMaybe)+++type T i name str = [[[XMLTree.T i name str]]]++{- |+Ignores all non-table-row-tags and all non-table-cell-tags.+-}+simpleFromRows ::+   (Name.Tag name, Eq name) =>+   [XMLTree.T i name str] ->  T i name str+simpleFromRows =+   map (simpleFromRow . snd) .+   filter (Elem.checkName (Name.match "tr") . fst) .+   mapMaybe XMLTree.maybeTag++simpleFromRow ::+   (Name.Tag name, Eq name) =>+   [XMLTree.T i name str] ->  [[XMLTree.T i name str]]+simpleFromRow =+   map snd .+   filter (Elem.checkName (Name.matchAny ["th","td"]) . fst) .+   mapMaybe XMLTree.maybeTag+++{-+data CellType = Heading | Cell++fromRows :: [XMLTree.T i name str] ->  [[(CellType, [XMLTree.T i name str])]]+fromRows =+   map fromRow .+   filter (XMLTree.checkTagName ("tr"==) . fst) .+   mapMaybe XMLTree.maybeTag++fromRow :: [XMLTree.T i name str] ->  [(CellType, [XMLTree.T i name str])]+fromRow =+   mapMaybe (\tag ->+      if XMLTree.checkTagName ("td"==) tag+        then Just) .+   mapMaybe XMLTree.maybeTag+-}

@@ -0,0 +1,137 @@+module Text.HTML.WraXML.Tree where++import qualified Data.Tree.BranchLeafLabel as Tree+import qualified Text.XML.WraXML.Tree    as XmlTree+import qualified Text.XML.WraXML.String  as XmlString+import qualified Data.Char               as Char++import qualified Text.HTML.Basic.Tag as Tag+import qualified Text.XML.WraXML.Element as Elem+import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name  as Name++import Text.XML.WraXML.Tree (showLeaf, )+import qualified Text.XML.Basic.Format as ShowXML++import           Data.List.HT (takeWhileRev, )+import           Data.Tuple.HT (mapFst, )+import           Control.Monad (liftM2, )+import           Data.Maybe (mapMaybe, fromMaybe, )++-- import qualified Text.Show as Show++import Prelude hiding (show, shows, )++++{- * Character decoding -}++findMetaEncoding ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   XmlTree.T i name String -> Maybe String+findMetaEncoding =+   fmap (map Char.toLower . takeWhileRev ('='/=)) .+   lookup "content-type" .+   map (mapFst (map Char.toLower)) .+   getMetaHTTPHeaders++{- |+Extract META tags which contain HTTP-EQUIV attribute+and present these values like HTTP headers.+-}+getMetaHTTPHeaders ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   XmlTree.T i name String -> [(String, String)]+getMetaHTTPHeaders =+   mapMaybe (\attrs ->+      liftM2 (,)+         (Attr.lookupLit "http-equiv" attrs)+         (Attr.lookupLit "content" attrs)) .+   map Elem.attributes_ .+   filter (Elem.checkName (Name.match "meta")) .+   map fst .+   mapMaybe XmlTree.maybeTag .+   concatMap snd .+   XmlTree.filterTagsFlatten (Elem.checkName (Name.match "head"))+++{-# DEPRECATED decodeSpecialCharsMetaEncoding "XMLChar.Unicode constructors must contain unicode characters and not encoded ones. Decode characters before parsing!" #-}++{- |+Convert special characters of XmlString into Unicode+according to the encoding given in a META HTTP-EQUIV tag.+-}+decodeSpecialCharsMetaEncoding ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   XmlTree.T i name XmlString.T -> [XmlTree.T i name String]+decodeSpecialCharsMetaEncoding tree =+   let unicodeTree = XmlTree.unescape tree+   in  fromMaybe+          [unicodeTree]+          (flip XmlTree.maybeDecodeSpecialChars tree+               =<< findMetaEncoding unicodeTree)++++{- * Formatting -}+++show ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.T i name XmlString.T -> String+show leaf = shows leaf ""++showsMany ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   [XmlTree.T i name XmlString.T] -> ShowS+showsMany = ShowXML.many shows++-- cf. src/Text/XML/HXT/DOM/XmlTreeFunctions.hs+shows ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.T i name XmlString.T -> ShowS+shows =+   Tree.fold (flip const) showBranch showLeaf .+   XmlTree.unwrap++showBranch ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.Branch name XmlString.T -> [ShowS] -> ShowS+showBranch = showBranchGen False+++showsManyXHTML ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   [XmlTree.T i name XmlString.T] -> ShowS+showsManyXHTML = ShowXML.many showsXHTML++-- cf. src/Text/XML/HXT/DOM/XmlTreeFunctions.hs+showsXHTML ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.T i name XmlString.T -> ShowS+showsXHTML =+   Tree.fold (flip const) showBranchXHTML showLeaf .+   XmlTree.unwrap++showBranchXHTML ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.Branch name XmlString.T -> [ShowS] -> ShowS+showBranchXHTML = showBranchGen True+++{- |+@not xhtml@: show @<br>@+@xhtml@: show @<br/>@+Unfortunately we cannot generally merge @<tag></tag>@ to @<tag/>@+since browsers expect e.g. separated @<div></div>@.+-}+showBranchGen ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   Bool -> XmlTree.Branch name XmlString.T -> [ShowS] -> ShowS+showBranchGen xhtml branch showSubTrees =+   case branch of+      XmlTree.Tag elm ->+         Elem.format+            (\tagName -> null showSubTrees && Tag.isEmpty tagName)+            (if xhtml then ShowXML.slash else id)+            elm showSubTrees

@@ -0,0 +1,50 @@+module Text.XML.WraXML.Document where++import qualified Text.XML.WraXML.Tree    as XmlTree+import qualified Text.XML.WraXML.String  as XmlString+import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name as Name+import qualified Text.XML.Basic.Format as ShowXML++++data T i name str = Cons {+   xmlDeclaration :: Maybe [Attr.T name str],+   docType :: Maybe String,+   content :: [XmlTree.T i name str]}+     deriving Show++instance+   (Name.Tag name, Name.Attribute name, Ord name) =>+      Functor (T i name) where+   fmap f = lift f (map (fmap f))++lift ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   (str0 -> str1) ->+   ([XmlTree.T i name str0] -> [XmlTree.T i name str1]) ->+   T i name str0 -> T i name str1+lift g f (Cons xml dtd trees) =+   Cons (fmap (map (fmap g)) xml) dtd $ f trees+++showXMLDeclaration ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   [Attr.T name XmlString.T] -> ShowS+showXMLDeclaration attrs =+   showString "<?xml" . Attr.formatListBlankHead attrs . showString "?>" .+   ShowXML.nl++showDocType :: String -> ShowS+showDocType dtdStr =+   showString "<!DOCTYPE " . showString dtdStr . showString ">" .+   ShowXML.nl++show ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   T i name XmlString.T -> String+show (Cons xml dtd trees) =+   maybe id showXMLDeclaration xml .+   maybe id showDocType dtd .+   XmlTree.showsMany trees $+   ""

@@ -0,0 +1,87 @@+module Text.XML.WraXML.Document.TagSoup where++import qualified Text.XML.WraXML.Tree.TagSoup as TreeTagSoup+import qualified Text.XML.WraXML.Document as XmlDoc+-- import qualified Text.XML.WraXML.Tree     as XmlTree++import Text.XML.WraXML.Tree.TagSoup (PosTag, )++import qualified Text.HTML.TagSoup as Tag++import Text.HTML.TagSoup (Tag(..), )++import qualified Text.XML.Basic.Position as Position++import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name.MixedCase as NameMC+import qualified Text.XML.Basic.Name.LowerCase as NameLC+import qualified Text.XML.Basic.Name as Name++import Control.Monad.Trans.State (State, state, evalState, modify, gets, )++import Data.Char (isSpace, )++++dropSpace ::[PosTag] -> [PosTag]+dropSpace =+   dropWhile+      (\tag ->+          case snd tag of+             Tag.TagText text -> all isSpace text+             _ -> False)++withoutLeadingSpace ::+   ([PosTag] -> (a, [PosTag])) ->+   State [PosTag] a+withoutLeadingSpace f =+   modify dropSpace >> state f++toXmlDocument ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   [Tag] -> XmlDoc.T Position.T name String+toXmlDocument ts =+   flip evalState+      (TreeTagSoup.removeMetaPos+          (TreeTagSoup.attachPos+              (Tag.canonicalizeTags ts))) $+   do xml <- withoutLeadingSpace $ \ts0 ->+         case ts0 of+            (_, Tag.TagOpen "?xml" attrs):ts1 ->+                 (Just (map (uncurry Attr.new) attrs), ts1)+            _ -> (Nothing, ts0)+      docType <- withoutLeadingSpace $ \ts0 ->+         case ts0 of+            (_, Tag.TagOpen "!DOCTYPE" dtd):ts1 ->+                 (Just (Attr.formatListBlankHead+                         (map (Attr.fromPair :: (String,String) -> Attr.T NameMC.T String) dtd) ""), ts1)+            _ -> (Nothing, ts0)+      gets (XmlDoc.Cons xml docType . TreeTagSoup.toXmlTreesAux)++{-+toXmlDocument =+   Tag.canonicalizeTags .+   XmlDoc.Cons Nothing .+   TreeTagSoup.toXmlTreesAux+-}++toXmlDocumentString ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   [Tag] -> XmlDoc.T Position.T name String+toXmlDocumentString =+   toXmlDocument+{- this would only work for String, because of isSpace+   let cts = Tag.canonicalizePosTags ts+   in  case dropWhile (Match.tagText (all isSpace) . snd) cts of+          (_, Tag.TagSpecial "DOCTYPE" dtd):rest ->+               XmlDoc.Cons (Just dtd) (TreeTagSoup.toXmlTreesAux rest)+          _ -> XmlDoc.Cons Nothing    (TreeTagSoup.toXmlTreesAux cts)+-}+++example :: IO ()+example =+  print .+  (toXmlDocumentString :: [Tag] -> XmlDoc.T Position.T NameLC.T String) .+  Tag.parseTagsOptions TreeTagSoup.parseOptions+    =<< readFile "/home/thielema/public_html/index.html"

@@ -0,0 +1,91 @@+module Text.XML.WraXML.Document.TagSoupHT where++import qualified Text.XML.WraXML.Tree.TagSoupHT as TreeTagSoup+import qualified Text.XML.WraXML.Document as XmlDoc+-- import qualified Text.XML.WraXML.Tree     as XmlTree++import qualified Text.HTML.TagSoup.HT.Parser      as TagParser+import qualified Text.HTML.TagSoup.HT.Tag         as Tag+import qualified Text.HTML.TagSoup.HT.PositionTag as PosTag+import qualified Text.XML.Basic.Position    as Position+import qualified Text.HTML.Basic.Tag as TagH+import qualified Text.HTML.Basic.Character    as HTMLChar++import qualified Text.XML.Basic.Name.LowerCase as NameLC+import qualified Text.XML.Basic.Name           as Name+import qualified Text.XML.Basic.ProcessingInstruction as PI++import Data.List.HT (viewL, )+import Data.Maybe (fromMaybe, )+import Control.Monad (guard, )++import Control.Monad.Trans.State (State, state, evalState, modify, gets, )++import qualified Data.Char as Char++++type XmlDoc = XmlDoc.T Position.T+++class TagParser.CharType char => CharSpace char where+   isSpace :: char -> Bool++instance CharSpace Char where+   isSpace = Char.isSpace++instance CharSpace HTMLChar.T where+   isSpace c =+      case c of+         HTMLChar.Unicode chr -> Char.isSpace chr+         HTMLChar.EntityRef "nbsp" -> True+         _ -> False++class StringSpace string where+   isAllSpace :: string -> Bool++instance CharSpace char => StringSpace [char] where+   isAllSpace = all isSpace+++dropSpace :: StringSpace string =>+   [PosTag.T name string] -> [PosTag.T name string]+dropSpace =+   dropWhile+      (\tag ->+          case PosTag.tag_ tag of+             Tag.Text text -> isAllSpace text+             _ -> False)++withoutLeadingSpace :: (StringSpace string) =>+   ([PosTag.T name string] -> (a, [PosTag.T name string])) ->+   State [PosTag.T name string] a+withoutLeadingSpace f =+   modify dropSpace >> state f++toXmlDocument ::+   (Name.Tag name, Name.Attribute name, Ord name, StringSpace string) =>+   [PosTag.T name string] -> XmlDoc name string+toXmlDocument ts =+   flip evalState ts $+   do xml <- withoutLeadingSpace $ \ts0 ->+         fromMaybe (Nothing, ts0) $+         do (t,ts1) <- viewL ts0+            (name, PI.Known attrs) <- Tag.maybeProcessing (PosTag.tag_ t)+            guard (Name.match "xml" name)+            return (Just attrs, ts1)+      docType <- withoutLeadingSpace $ \ts0 ->+         fromMaybe (Nothing, ts0) $+         do (t,ts1) <- viewL ts0+            (name, dtd) <- Tag.maybeSpecial (PosTag.tag_ t)+            guard (Name.match TagH.doctypeString name)+            return (Just dtd, ts1)+      gets (XmlDoc.Cons xml docType . TreeTagSoup.toXmlTrees)+++example :: IO ()+example =+  print .+  (toXmlDocument :: [PosTag.T NameLC.T String] -> XmlDoc NameLC.T String) .+  TagParser.runSoupWithPositions+    =<< readFile "/home/thielema/public_html/index.html"

@@ -0,0 +1,160 @@+module Text.XML.WraXML.Element where++import qualified Text.XML.WraXML.String  as XmlString++import qualified Text.XML.Basic.Tag as Tag+import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name as Name++import qualified Data.Accessor.Basic as Accessor++import           Data.Foldable as Foldable(Foldable(foldMap))+import           Data.Traversable as Traversable(Traversable(traverse))+import           Control.Applicative (Applicative, )+import qualified Control.Applicative as App+import           Data.Monoid (mconcat, )++import qualified Text.XML.Basic.Format as ShowXML+import qualified Text.Show as Show+++data T name str =+   Cons {+      name_       :: Tag.Name name,+      attributes_ :: [Attr.T name str]+   } deriving (Show)++++name :: Accessor.T (T name str) (Tag.Name name)+name = Accessor.fromSetGet (\n p -> p{name_ = n}) name_++attributes :: Accessor.T (T name str) [Attr.T name str]+attributes = Accessor.fromSetGet (\n p -> p{attributes_ = n}) attributes_+++-- * tests++checkName :: (Tag.Name name -> Bool) -> (T name str -> Bool)+checkName p (Cons tagName _) = p tagName++checkAttributes :: ([Attr.T name str] -> Bool) -> (T name str -> Bool)+checkAttributes p (Cons _ attrs) = p attrs+++-- * modification++instance Functor (T name) where+   fmap f (Cons tagName attrs) =+      Cons tagName (Attr.mapValues f attrs)+++lift ::+   (Tag.Name name -> [Attr.T name str] -> (Tag.Name name, [Attr.T name str])) ->+   (T name str -> T name str)+lift f (Cons tagName attrs) =+   uncurry Cons (f tagName attrs)+++-- | process the attribute list of a specific tag+processAttrs ::+   (Name.Tag name, Name.Attribute name) =>+   (Tag.Name name -> Bool) ->+   ([Attr.T name str] -> [Attr.T name str]) ->+   (T name str -> T name str)+processAttrs p f =+   lift (\tagName ->+      (,) tagName . if p tagName then f else id)++processAttrValue ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Tag.Name name, Attr.Name name) ->+   (str -> str) ->+   (T name str -> T name str)+processAttrValue (tagName,attrName) f =+   processAttrs (tagName ==)+      (Attr.adjustOn (attrName ==) f)++processAttrValueCond ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Tag.Name name, Attr.Name name) ->+   ([Attr.T name str] -> Bool) ->+   (str -> str) ->+   (T name str -> T name str)+processAttrValueCond (tagName,attrName) cond f =+   processAttrs (tagName ==)+      (\attrs -> Attr.adjustOn (attrName ==)+         (if cond attrs then f else id)+         attrs)++++instance Foldable (T name) where+   foldMap f (Cons _tagName attrs) =+      mconcat $ map (foldMap f) attrs++instance Traversable (T name) where+   traverse f (Cons tagName attrs) =+      App.liftA (Cons tagName) (Attr.mapValuesA f attrs)++++-- * monadic modification++-- | process the attribute list of a specific tag+processAttrsA ::+   (Name.Tag name, Name.Attribute name, Eq name, Applicative m) =>+   (Tag.Name name -> Bool) ->+   ([Attr.T name str] -> m [Attr.T name str]) ->+   (T name str -> m (T name str))+processAttrsA p f =+   liftA (\tagName ->+      App.liftA ((,) tagName) .+      if p tagName then f else App.pure)++processAttrValueA ::+   (Name.Tag name, Name.Attribute name, Eq name, Applicative m) =>+   (Tag.Name name, Attr.Name name) ->+   (str -> m str) ->+   (T name str -> m (T name str))+processAttrValueA (tagName,attrName) f =+   processAttrsA (tagName==)+      (Attr.adjustOnA (attrName==) f)++processAttrValueCondA ::+   (Name.Tag name, Name.Attribute name, Eq name, Applicative m) =>+   (Tag.Name name, Attr.Name name) ->+   ([Attr.T name str] -> Bool) ->+   (str -> m str) ->+   (T name str -> m (T name str))+processAttrValueCondA (tagName,attrName) cond f =+   processAttrsA (tagName==)+      (\attrs -> Attr.adjustOnA (attrName==)+         (if cond attrs then f else App.pure)+         attrs)++liftA ::+   (Name.Tag name, Name.Attribute name, Eq name, Applicative m) =>+   (Tag.Name name -> [Attr.T name str] ->+      m (Tag.Name name, [Attr.T name str])) ->+   (T name str -> m (T name str))+liftA f (Cons tagName attrs) =+   App.liftA (uncurry Cons) (f tagName attrs)++++-- * format++format ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   (Tag.Name name -> Bool) -> ShowS -> T name XmlString.T -> [ShowS] -> ShowS+format isCondensed trailingSlash (Cons tagName attrs) showSubTrees =+   let t = Name.toString tagName+   in  if isCondensed tagName+         then ShowXML.angle+               (showString t . Attr.formatListBlankHead attrs+                 . trailingSlash)+         else ShowXML.angle+               (showString t . Attr.formatListBlankHead attrs)+               . foldr (.) id showSubTrees+               . ShowXML.angle (ShowXML.slash . showString t)

@@ -0,0 +1,22 @@+{- |+Conversion from HaXml position to our Position type.+We cannot convert back efficiently,+since we would have to increment the line number repeatedly.+Thus such a conversion is missing.+-}+module Text.XML.WraXML.Position.HaXml where++import           Text.XML.HaXml.Posn (Posn, posnColumn, posnLine, posnFilename, )++import qualified Text.XML.Basic.Position as Pos+++{-+fromPosition :: Pos.T -> Posn+fromPosition p =+   Pn (Pos.fileName p) (Pos.row p) (Pos.column p) Nothing+-}++toPosition :: Posn -> Pos.T+toPosition p =+   Pos.new (posnFilename p) (pred $ posnLine p) (pred $ posnColumn p)

@@ -0,0 +1,160 @@+module Text.XML.WraXML.String where++import qualified Text.XML.HXT.DOM.Unicode as Unicode++import qualified Text.XML.Basic.Character as XMLChar++import Control.Applicative (Applicative, liftA, )+import qualified Numeric+import qualified Data.Char as Char+import Text.XML.WraXML.Utility (compose, )+import Data.Tuple.HT (mapFst, )++import qualified Control.Monad.Exception.Synchronous as Exc+++type T = [Atom]+type EmbeddedExceptions = [Exc.Exceptional String Char]++type Atom = XMLChar.T+++{- |+Literal translation from pure strings.+This can only work, if the string does not contain special characters.+-}+fromString :: String -> T+fromString = map XMLChar.fromUnicode++diffFromString :: String -> T -> T+diffFromString =+   flip (foldr (\c -> (XMLChar.fromUnicode c :)))++{- |+default routine+-}+fromUnicodeString :: String -> T+fromUnicodeString = map XMLChar.asciiFromUnicode+++toUnicodeStringOrFormat :: T -> String+toUnicodeStringOrFormat =+   flip compose "" .+   map XMLChar.toUnicodeOrFormat++toUnicodeStringEmbedMessage :: T -> String+toUnicodeStringEmbedMessage =+   flip compose "" .+   map+      (Exc.switch (\err ->+         showString "(decoding error: " . showString err . showString ")")+         (:)) .+   toUnicodeStringEmbedException++{- |+Errors in on resolution of references yield undefined elements.+-}+toUnicodeString :: T -> String+toUnicodeString =+   map (Exc.resolve error) . toUnicodeStringEmbedException++toUnicodeStringEmbedException :: T -> EmbeddedExceptions+toUnicodeStringEmbedException =+   map XMLChar.toUnicode+++{-# DEPRECATED utf8ToUnicodeString, isoLatin1ToUnicodeString, replaceUTF8ByUnicode, uStringWithErrorsMergePlainChars "XMLChar.Unicode constructors must contain unicode characters and not encoded ones. Decode characters before parsing!" #-}+{- |+Interpret the XML string as mixture of ISO-Latin-1 characters and XML entities+and convert that to a Unicode string.+-}+isoLatin1ToUnicodeString :: T -> String+isoLatin1ToUnicodeString = toUnicodeString++{- |+Interpret the XML string as mixture of UTF-8 characters and XML entities+and convert that to a Unicode string.+-}+utf8ToUnicodeString :: T -> String+utf8ToUnicodeString = toUnicodeString . replaceUTF8ByUnicode+++readHex :: (Num a) => String -> a+readHex str =+   case Numeric.readHex str of+      [(n,"")] -> n+      _ -> error "readHex: no parse"++{- |+Caution: There is a memory leak for the case that entity references are huge.+-}+parse :: String -> T+parse ('&':'#':'x':xs) =+   parseAux Char.isHexDigit (XMLChar.fromCharRef . readHex) "&#x" xs+parse ('&':'#':xs) =+   parseAux Char.isDigit (XMLChar.fromCharRef . read) "&#" xs+parse ('&':xs) =+   parseAux Char.isAlphaNum XMLChar.fromEntityRef "&" xs+parse (x:xs) = XMLChar.fromUnicode x : parse xs+parse [] = []+-- use unfoldr?++parseAux ::+   (Char -> Bool)         ->+   (String -> XMLChar.T)  ->+   String                 ->+   String                 ->+   T+parseAux check ref prefix xs =+   let (name,rest0) = span check xs+   in  case rest0 of+          ';':rest1 -> ref name : parse rest1+          _ -> map XMLChar.fromUnicode (prefix++name) ++ parse rest0+++reduceRefs :: T -> T+reduceRefs = map XMLChar.reduceRef++{- |+Consider the XmlString as a mixture of XML entities and UTF-8 characters.+Replace UTF-8 characters by Unicode representations.+-}+replaceUTF8ByUnicode :: T -> T+replaceUTF8ByUnicode =+   mapUnicodeRuns (fst . Unicode.utf8ToUnicode)++mapUnicodeRuns :: (String -> String) -> T -> T+mapUnicodeRuns f =+   flip compose [] .+   XMLChar.switchUnicodeRuns+--      (\s -> fromString (f s) ++)+      (diffFromString . f)+      ((:) . XMLChar.fromCharRef)+      ((:) . XMLChar.fromEntityRef)++++uStringWithErrorsMergePlainChars ::+   EmbeddedExceptions -> [Exc.Exceptional String String]+uStringWithErrorsMergePlainChars =+   foldr (\x ys ->+      case x of+         Exc.Exception err -> Exc.Exception err : ys+         Exc.Success c  ->+            uncurry (:) $+            mapFst Exc.Success $+            mapFst (c:) $+               case ys of+                  Exc.Success cs : ys0 -> (cs, ys0)+                  _ -> ([], ys))+      []++++liftFromUnicode :: (String -> String) -> (T -> T)+liftFromUnicode f =+   fromUnicodeString . f . toUnicodeString++liftFromUnicodeA :: Applicative m => (String -> m String) -> (T -> m T)+liftFromUnicodeA f =+   liftA fromUnicodeString . f . toUnicodeString

@@ -0,0 +1,31 @@+module Text.XML.WraXML.String.HXT where++import qualified Text.XML.HXT.DOM.TypeDefs as HXT+import qualified Data.Tree.NTree.TypeDefs  as HXTTree++import qualified Text.XML.WraXML.String  as XmlString+import qualified Text.XML.Basic.Character as XMLChar+++toXmlString :: HXT.XmlTrees -> XmlString.T+toXmlString = concatMap toXmlString'++toXmlString' :: HXT.XmlTree -> XmlString.T+toXmlString' (HXTTree.NTree label subTrees) =+   if null subTrees+     then+        case label of+           HXT.XText str -> XmlString.fromString str+           HXT.XCharRef ref -> [XMLChar.fromCharRef ref]+           HXT.XEntityRef ref -> [XMLChar.fromEntityRef ref]+           _ -> error "HXT: illegal part of HXT string"+     else error "HXT: parts of a string must not contain sub-strings"+++fromXmlString :: XmlString.T -> HXT.XmlTrees+fromXmlString =+   map (flip HXTTree.NTree []) .+   XMLChar.switchUnicodeRuns+      HXT.XText+      HXT.XCharRef+      HXT.XEntityRef

@@ -0,0 +1,47 @@+module Text.XML.WraXML.String.HaXml where++import Text.XML.HaXml(AttValue(AttValue), Reference, )+import qualified Text.XML.HaXml as HaXml++import qualified Text.XML.WraXML.String  as XmlString+import qualified Text.XML.Basic.Character as XMLChar++import Data.Maybe.HT (alternatives, (?->), )+++toXmlString :: AttValue -> XmlString.T+toXmlString (AttValue s) =+   concatMap (either XmlString.fromString ((:[]) . refToXmlAtom)) s++fromXmlString :: XmlString.T -> AttValue+fromXmlString =+   AttValue .+   XMLChar.switchUnicodeRuns+      Left+      (Right . HaXml.RefChar)+      (Right . HaXml.RefEntity)++lift :: (XmlString.T -> XmlString.T) -> (AttValue -> AttValue)+lift f = fromXmlString . f . toXmlString++refToXmlAtom :: HaXml.Reference -> XmlString.Atom+refToXmlAtom ref =+   case ref of+      HaXml.RefChar   num  -> XMLChar.fromCharRef   num+      HaXml.RefEntity name -> XMLChar.fromEntityRef name++charFromXmlAtom' :: XMLChar.T -> Either Char Reference+charFromXmlAtom' c =+   case c of+      XMLChar.Unicode   char -> Left char+      XMLChar.EntityRef name -> Right (HaXml.RefEntity name)+      XMLChar.CharRef   num  -> Right (HaXml.RefChar   num)++charFromXmlAtom :: XMLChar.T -> Either Char Reference+charFromXmlAtom c =+   alternatives+      (error "HaXml.charFromXmlAtom: unsupported constructor in XMLChar.T") $+      XMLChar.maybeUnicode   c ?-> Left :+      XMLChar.maybeEntityRef c ?-> Right . HaXml.RefEntity :+      XMLChar.maybeCharRef   c ?-> Right . HaXml.RefChar :+      []

@@ -0,0 +1,616 @@+module Text.XML.WraXML.Tree where++import qualified Text.XML.WraXML.Element as Elem++import qualified Data.Tree.BranchLeafLabel as Tree+import qualified Text.XML.WraXML.String  as XmlString+import qualified Text.HTML.WraXML.String as HtmlString++import qualified Text.XML.Basic.Tag as Tag+import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name as Name+import qualified Text.XML.Basic.ProcessingInstruction as PI++import qualified Text.XML.HXT.DOM.Unicode as Unicode+import qualified Data.Char               as Char++import Control.Monad.Trans.Writer (Writer, writer, runWriter, censor, )++import qualified Control.Monad.Exception.Synchronous as Exc++import           Data.Foldable as Foldable(Foldable(foldMap))+import           Data.Traversable as Traversable(Traversable(traverse))+import           Control.Applicative (Applicative, )+import qualified Control.Applicative as App+import           Data.List.HT (unzipEithers, )+import           Data.Tuple.HT (mapFst, mapSnd, mapPair, swap, )+import           Data.Maybe (mapMaybe, fromMaybe, )+import           Data.Monoid (Monoid, mempty, mappend, mconcat, )++import qualified Text.XML.Basic.Format as ShowXML+import qualified Text.Show as Show++import Prelude hiding (show, shows)+++{- * data structures -}++newtype T i name str =+   Cons {unwrap :: Tree.T i (Branch name str) (Leaf name str)}+   deriving (Show)++data Branch name str =+     Tag    {getElement :: Elem.T name str}+   deriving (Show)++{-+It is disputable whether comments (and warnings)+shall have type String or 'str'.+Can a comment contain non-ASCII characters and XML entities?+This is important for finding the comment ending "-->" properly.+What about scripts enclosed in comment delimiters?+Mozilla and Firefox don't do any encoding in the SCRIPT tag at all.+This seems to be wrong, since scripts frequently contain strings+with tag descriptions, like '<BR>'.+-}+data Leaf name str =+     Text    Bool {- is whitespace significant -} str+   | Comment String  -- better 'str'?+   | CData   String+   | PI      (Tag.Name name) (PI.T name str)+   | Warning String  -- better 'str'?+++type AttributePlain = (String, String)+++instance (Name.Attribute name, Show name, Show str) =>+      Show (Leaf name str) where+   showsPrec prec x =+      showParen (prec>=10) $+      case x of+         Text   _ str -> Show.showString "Text "    . Show.showsPrec 11 str+         Comment  str -> Show.showString "Comment " . Show.showsPrec 11 str+         CData    str -> Show.showString "CData "   . Show.showsPrec 11 str+         PI target p  ->+--            Show.showString "ProcessingInstruction " .+            Show.showString "PI " .+            Show.showsPrec 11 target . Show.showString " " .+            Show.showsPrec 11 p+         {- Maybe it is better to attach warnings to malicious tags+            instead of throwing them into the tag soup.+            But how to tell the position of the error then? -}+         Warning  str -> Show.showString "Warning " . Show.showsPrec 11 str+++{- * Name data type -}++{-+A name can only consist of (7-bit) ASCII characters.+It is used both for tag names and for attribute names.+newtype Name = Name String+   deriving (Show, Eq, Ord)++nameFromString :: String -> Name+nameFromString x =+   if all Char.isAscii x+     then Name $ map Char.toLower x+     else error ("XMLTree.nameFromString: '" ++ x +++                 "' contains non-ASCII characters.")++nameToString :: Name -> String+nameToString (Name x) = x+-}++++{- * generators -}++wrap :: Tree.T i (Branch name str) (Leaf name str) -> T i name str+wrap = Cons++wrap2 :: i -> Tree.Elem i (Branch name str) (Leaf name str) -> T i name str+wrap2 = curry wrap++lift ::+   (Tree.T i (Branch name str0) (Leaf name str0) ->+    Tree.T j (Branch name str1) (Leaf name str1)) ->+   (T i name str0 -> T j name str1)+lift f = wrap . f . unwrap++liftA :: Applicative m =>+   (Tree.T i (Branch name str0) (Leaf name str0) ->+    m (Tree.T i (Branch name str1) (Leaf name str1))) ->+   (T i name str0 -> m (T i name str1))+liftA f = App.liftA wrap . f . unwrap+++-- | Build some textual content.+literal :: str -> T i name str+literal = literalIndex (error "literal: no index given")++literalIndex :: i -> str -> T i name str+literalIndex i =+   wrap2 i .+   Tree.Leaf . Text False+++comment :: String -> T i name str+comment = commentIndex (error "comment: no index given")++commentIndex :: i -> String -> T i name str+commentIndex i =+   wrap2 i .+   Tree.Leaf . Comment++warning :: String -> T i name str+warning = warningIndex (error "warning: no index given")++warningIndex :: i -> String -> T i name str+warningIndex i =+   wrap2 i .+   Tree.Leaf . Warning++cdata :: String -> T i name str+cdata = cdataIndex (error "cdata: no index given")++cdataIndex :: i -> String -> T i name str+cdataIndex i =+   wrap2 i .+   Tree.Leaf . CData++processing :: Tag.Name name -> PI.T name str -> T i name str+processing = processingIndex (error "processing: no index given")++processingIndex :: i -> Tag.Name name -> PI.T name str -> T i name str+processingIndex i target =+   wrap2 i .+   Tree.Leaf . PI target++tag :: Tag.Name name -> [T i name str] -> T i name str+tag name = tagAttr name []++tagAttr :: Tag.Name name -> [Attr.T name str] -> [T i name str] -> T i name str+tagAttr = tagIndexAttr (error "tagAttr: no index given")++tagIndexAttr :: i -> Tag.Name name -> [Attr.T name str] -> [T i name str] -> T i name str+tagIndexAttr index name attrs =+   wrap2 index .+   Tree.Branch (Tag (Elem.Cons name attrs)) .+   map unwrap+++{- * Conversions -}++maybeTag :: T i name str -> Maybe (Elem.T name str, [T i name str])+maybeTag (Cons (_,t)) =+   case t of+      Tree.Branch (Tag elm) subTrees ->+           Just (elm, map wrap subTrees)+      _ -> Nothing++maybeText :: T i name str -> Maybe str+maybeText (Cons (_,t)) =+   case t of+      Tree.Leaf l -> maybeTextLeaf l+      _           -> Nothing++maybeTextLeaf :: Leaf name str -> Maybe str+maybeTextLeaf t =+   case t of+      Text _ s -> Just s+      _        -> Nothing++liftTrans :: (a -> b) -> (a -> [b])+liftTrans f = (:[]) . f++liftText :: (String -> String) -> (Leaf name String -> Leaf name String)+liftText f leaf =+   case leaf of+      Text b s -> Text b (f s)+      CData s  -> CData (f s)+      _ -> leaf++liftTextA :: Applicative m => (String -> m String) -> (Leaf name String -> m (Leaf name String))+liftTextA f leaf =+   case leaf of+      Text b s -> App.liftA (Text b) (f s)+      CData s  -> App.liftA CData $ f s+      _ -> App.pure leaf++++instance Functor (Leaf name) where+   fmap f leaf =+      case leaf of+         Text b s  -> Text b (f s)+         Comment s -> Comment s+         Warning s -> Warning s+         CData s   -> CData s+         PI t p    -> PI t $ fmap f p++{- this instance is quite useless but required by Traversable -}+instance Foldable (Leaf name) where+   foldMap f leaf =+      case leaf of+         Text _b s -> f s+         PI _t p   -> foldMap f p+         _ -> mempty++instance Traversable (Leaf name) where+   traverse f leaf =+      case leaf of+         Text b s  -> App.liftA (Text b) (f s)+         Comment s -> App.pure $ Comment s+         Warning s -> App.pure $ Warning s+         CData s   -> App.pure $ CData s+         PI t p    -> App.liftA (PI t) $ traverse f p++++liftElement :: (Elem.T name str0 -> Elem.T name str1) -> (Branch name str0 -> Branch name str1)+liftElement f (Tag elm) = Tag (f elm)++liftElementA :: Applicative m =>+   (Elem.T name str0 -> m (Elem.T name str1)) -> (Branch name str0 -> m (Branch name str1))+liftElementA f (Tag elm) = App.liftA Tag (f elm)+++{- * Tests -}++{- |+If the Tree is a Leaf, then return False.+Otherwise return the result of the predicate.+-}+checkTreeTag :: (Elem.T name str -> Bool) -> (T i name str -> Bool)+checkTreeTag p =+   Tree.switch (flip const) (const . p . getElement) (const False)+    . unwrap++++{- * types of processors -}++type Filter i name str = T i name str -> T i name str++type FilterA m i name str = T i name str -> m (T i name str)+++{- * tree processors -}+++instance Functor (T i name) where+   fmap f =+      lift $+      Tree.map+         (liftElement $ fmap f)+         (fmap f)+++mapText ::+   (String -> String) ->+   (T i name String -> T i name String)+mapText f =+   lift $+   Tree.map+      (liftElement $ fmap f)+      (liftText f)+++mapIndex :: (i -> j) -> T i name str -> T j name str+mapIndex f =+   lift $ Tree.mapLabel f+++mapTag ::+   (Elem.T name str -> Elem.T name str) ->+   (Filter i name str)+mapTag f =+   lift $+   Tree.map (liftElement f) id++{- |+You can e.g. filter @text1 <b> text2 </b> text3@+to @text1  text2  text3@ by+@filterTag (checkTagName ("b"\/=))@.+-}+filterTag ::+   (Elem.T name str -> Bool) ->+   (T i name str -> [T i name str])+filterTag p =+   map wrap .+   Tree.filterBranch (p . getElement) .+   unwrap++mapCond ::+   (Elem.T name str -> Bool) ->+   (Elem.T name str -> Elem.T name str) ->+   (Leaf name str -> Leaf name str) ->+   (Filter i name str)+mapCond descend elemF txtF =+   lift $+   Tree.mapCond (descend . getElement) (liftElement elemF) txtF++{-+mapTextCond ::+   (Elem.T name String -> Bool) ->+   (Elem.T name String -> Elem.T name String) ->+   (String -> String) ->+   (Filter i name String)+mapTextCond descend elemF txtF =+   lift $+   Tree.mapCond (descend . getElement) (liftElement elemF) (liftText txtF)+-}+++{- |+Find all branches where the predicate applies and+return a list of matching sub-trees in depth-first order.++Example: @filterTagsFlatten (checkTagName ("meta"==))@+-}+filterTagsFlatten ::+   (Elem.T name str -> Bool) -> T i name str -> [(Elem.T name str, [T i name str])]+filterTagsFlatten p =+   filter (p . fst) .+   mapMaybe maybeTag .+   allSubTrees++filterElementsFlatten :: (Elem.T name str -> Bool) -> T i name str -> [Elem.T name str]+filterElementsFlatten p =+   Tree.fold+      (flip const)+      (\branch xs -> filter p [getElement branch] ++ concat xs)+      (const []) .+   unwrap++allSubTrees :: T i name str -> [T i name str]+allSubTrees =+   map wrap . Tree.allSubTrees . unwrap++{- | merge subsequent string leafs -}+mergeStrings :: (Monoid str) => Filter i name str+mergeStrings =+   processAllSubTrees mergeTopStrings+++mergeTopStrings :: (Monoid str) => [T i name str] -> [T i name str]+mergeTopStrings =+   let prepend (i, Tree.Leaf (Text w0 t0)) rest =+          mapFst (\ ~(w1,t1) -> (i, Tree.Leaf $ Text (w0||w1) (mappend t0 t1))) $+          case rest of+             (_, Tree.Leaf (Text w1 t1)) : ss -> ((w1,t1), ss)+             _ -> ((False,mempty), rest)+       prepend x rest = (x, rest)+   in  map wrap.+       foldr (\x -> uncurry (:) . prepend x) [] .+       map unwrap+++{- |+Process all sub-tree lists in bottom-up order.+-}+processAllSubTrees ::+   ([T i name str] -> [T i name str]) ->+   Filter i name str+processAllSubTrees f =+   lift $+   Tree.fold+      (,)+      (\branch -> Tree.Branch branch . map unwrap . f . map wrap)+      Tree.Leaf++processSubTrees :: (Tag.Name name -> Bool) ->+   ([T i name str] -> [T i name str]) -> Filter i name str+processSubTrees p f =+   lift $+   Tree.mapSubTrees+      (\(Tag (Elem.Cons name _)) -> p name)+      (mapSnd (map unwrap . f . map wrap))++processSubTreesAttrs :: (Tag.Name name -> Bool) ->+   (([Attr.T name str], [T i name str]) ->+    ([Attr.T name str], [T i name str])) ->+   Filter i name str+processSubTreesAttrs p f =+   lift $+   Tree.mapSubTrees+      (\(Tag (Elem.Cons name _)) -> p name)+      (\(Tag (Elem.Cons name attrs), subTrees) ->+          mapPair (Tag . Elem.Cons name, map unwrap) $+          f (attrs, map wrap subTrees))++++{- * monadic tree processors -}++instance Foldable (T i name) where+   foldMap f =+      Tree.fold+         (const id) (const mconcat) (maybe mempty f . maybeTextLeaf) .+      unwrap+++instance Traversable (T i name) where+   traverse f =+      liftA $+      Tree.mapA+         (liftElementA $ traverse  f)+         (traverse f)+++mapTextA :: Applicative m =>+   (String -> m String) ->+   (T i name String -> m (T i name String))+mapTextA f =+   liftA $+   Tree.mapA+      (liftElementA $ traverse  f)+      (liftTextA f)+++mapCondA :: Applicative m =>+   (Elem.T name str -> Bool) ->+   (Elem.T name str -> m (Elem.T name str)) ->+   (Leaf name str -> m (Leaf name str)) ->+   (FilterA m i name str)+mapCondA descend elemF txtF =+   liftA $+   Tree.mapCondA (descend . getElement) (liftElementA elemF) txtF++{-+mapTextCondA :: Applicative m =>+   (Elem.T name String -> Bool) ->+   (Elem.T name String -> m (Elem.T name String)) ->+   (String -> m String) ->+   (FilterA m i name String)+mapTextCondA descend elemF txtF =+   liftA $+   Tree.mapCondA (descend . getElement) (liftElementA elemF) (liftTextA txtF)+-}+++{- * Character decoding -}++unescape :: T i name XmlString.T -> T i name String+unescape = fmap XmlString.toUnicodeString++escape :: T i name String -> T i name XmlString.T+escape = fmap XmlString.fromUnicodeString++{-# DEPRECATED decodeSpecialChars, maybeDecodeSpecialChars, decodeSpecialCharsDecoder, decodeAttrs, decodeAttr, maybeDecodeUTF8Chars "XMLChar.Unicode constructors must contain unicode characters and not encoded ones. Decode characters before parsing!" #-}++{- |+Decode characters like those from UTF-8 scheme.+-}+decodeSpecialChars ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   String -> T i name XmlString.T -> [T i name String]+decodeSpecialChars enc tree =+   fromMaybe+      [unescape tree]+      (maybeDecodeSpecialChars enc tree)++maybeDecodeSpecialChars ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   String -> T i name XmlString.T -> Maybe [T i name String]+maybeDecodeSpecialChars enc tree =+   fmap (flip decodeSpecialCharsDecoder tree) $+   Unicode.getDecodingFctEmbedErrors enc++{- test:+-- decodeSpecialChars "utf-8" $ literalIndex 0 (XmlString.fromEntString "tr&am;e")++traverse (putStrLn . showHTML . escape) $ decodeSpecialChars "utf-8" $ mapText XmlString.fromEntString $ tagIndexAttr 0 "br" [("href","urlö"), ("target","_blank")] [literalIndex 0 "\195tr&am;eü"]+-}++{- |+Conversion errors are appended as warnings to the tree.+-}+decodeSpecialCharsDecoder ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   Unicode.DecodingFctEmbedErrors -> T i name XmlString.T -> [T i name String]+decodeSpecialCharsDecoder decode =+   let xmlDecode =+          HtmlString.toUnicodeStringDecodingEmbedError decode+       mergeDecode =+          XmlString.uStringWithErrorsMergePlainChars . xmlDecode+   in  Tree.foldLabel+          (\i branch subTrees ->+              case branch of+                 Tag (Elem.Cons name attrs) ->+                    let (newAttrs,warnings) =+                           runWriter $+                           decodeAttrs xmlDecode attrs+                    in  [tagIndexAttr i name newAttrs+                           (map (warningIndex i) warnings ++ concat subTrees)])+          (\i leaf -> map (wrap2 i . Tree.Leaf) $+              case leaf of+                 Text  b str ->+                    map+                      (Exc.switch Warning (Text b))+                      (mergeDecode str)+                 Comment   cmt   -> [Comment cmt]+                 Warning   str   -> [Warning str]+                 CData     str   -> [CData str]+                 PI target instr0 ->+                    let (instr1,warnings) =+                           runWriter $+                           PI.mapAttributesA (decodeAttrs xmlDecode) instr0+                    in  PI target instr1 : map Warning warnings) .+       unwrap++decodeAttrs ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   (XmlString.T -> XmlString.EmbeddedExceptions) ->+   [Attr.T name XmlString.T] -> Writer [String] [Attr.T name String]+decodeAttrs xmlDecode =+   traverse+      (\attr ->+         traverse  (decodeAttr xmlDecode (Attr.name_ attr)) attr)++decodeAttr ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   (XmlString.T -> XmlString.EmbeddedExceptions) ->+   Attr.Name name -> XmlString.T -> Writer [String] String+decodeAttr decode name =+   censor (map (showString $ "in attribute \"" ++ Name.toString name ++ "\": ")) .+   writer . swap . unzipEithers . map Exc.toEither . decode+++maybeDecodeUTF8Chars :: String -> T i name XmlString.T -> Maybe (T i name String)+maybeDecodeUTF8Chars enc tree =+   case map Char.toLower enc of+      "utf-8" -> Just (fmap XmlString.utf8ToUnicodeString tree)+      _ -> Nothing+++{- * Formatting -}+++show ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   T i name XmlString.T -> String+show leaf = shows leaf ""++showsMany ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   [T i name XmlString.T] -> ShowS+showsMany = ShowXML.many shows++-- cf. src/Text/XML/HXT/DOM/XmlTreeFunctions.hs+shows ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   T i name XmlString.T -> ShowS+shows =+   Tree.fold (flip const) showBranch showLeaf . unwrap++showBranch ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   Branch name XmlString.T -> [ShowS] -> ShowS+showBranch branch showSubTrees =+   case branch of+      Tag elm ->+         Elem.format+            (\_tagName -> null showSubTrees)+            ShowXML.slash+            elm showSubTrees++showLeaf ::+   (Name.Tag name, Name.Attribute name, Eq name) =>+   Leaf name XmlString.T -> ShowS+showLeaf leaf =+   case leaf of+      Text _ str -> ShowXML.run str+      Comment c ->+         showString "<!--" . showString c . showString "-->"+      Warning e ->+         showString "<!-- Warning: " . showString e . showString " -->"+      CData str ->+         showString "<![CDATA[" . showString str . showString "]]>"+      PI target p ->+         ShowXML.angle $+         ShowXML.quest .+         ShowXML.name target .+         ShowXML.run p .+         ShowXML.quest

@@ -0,0 +1,457 @@+module Text.XML.WraXML.Tree.HXT+   (fromXmlTree, toXmlTree, lift, liftFilterToDocument,+    tidyHTML, showHTML, fromHTMLString, fromHTMLStringMetaEncoding,+    errorAnnFromHTMLStringMetaEncoding,+    errorAnnFromHTMLStringOpt, ErrorMsg,+    getMetaHTTPHeaders) where++import qualified Text.XML.HXT.DOM.TypeDefs as HXT+-- import qualified Text.XML.HXT.DOM.XmlTreeFunctions as HXTTreeFunc+import qualified Data.Tree.NTree.TypeDefs  as HXTTree++import Text.XML.WraXML.Tree+   (Branch(Tag), Leaf(Text, PI, Comment, Warning, CData), )+import qualified Text.XML.WraXML.Element as Elem++import qualified Text.HTML.WraXML.Tree   as HTMLTree+import qualified Text.XML.WraXML.Tree    as XmlTree+import qualified Data.Tree.BranchLeafLabel as Tree++import qualified Text.XML.WraXML.String     as XmlString+import qualified Text.XML.WraXML.String.HXT as HXTString++import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name.LowerCase as NameLC+import qualified Text.XML.Basic.Name as Name+import qualified Text.XML.Basic.ProcessingInstruction as PI++import qualified Text.XML.Basic.Character as XMLChar+import qualified Text.XML.Basic.Format    as ShowXML++-- needed for code copies from HXT at the of the file+import Text.XML.HXT.DOM.XmlTree hiding (cmt)+import Text.XML.HXT.DOM.XmlState+import Text.XML.HXT.Parser.XmlParser  (parseXmlDocEncodingSpec)+import Text.XML.HXT.Parser.XmlInput   (guessDocEncoding)+import Text.XML.HXT.Parser.XmlOutput  (traceTree, traceSource, traceMsg)+import Text.XML.HXT.Parser.HtmlParser (parseHtmlDoc)+import Text.XML.HXT.Parser.HtmlParsec (isEmptyHtmlTag)+import Text.XML.HXT.DOM.EditFilters   (escapeXmlDoc)+import Text.XML.HXT.DOM.ShowXml       (xshow, {- showXmlTree, showQName, -})+import Text.XML.HXT.DOM.QualifiedName (qualifiedName)+import Data.Tree.NTree.Filter         (liftMf)++import Control.Monad (msum, )+import Data.Maybe (fromMaybe, )+++{- * conversion from our XML tree to HXT tree -}++fromXmlTree ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.T i name XmlString.T -> HXT.XmlTree+fromXmlTree x =+   case multiFromXmlTree x of+      [y] -> y+      _   -> error "top branch can't be a string"+++mkHXTName :: (Name.C name) => name -> QName+mkHXTName = HXT.mkName . Name.toString++mkHXTAttrs :: (Name.Attribute name) =>+   [Attr.T name XmlString.T] -> [NTree XNode]+mkHXTAttrs =+   map (\a ->+            HXTTree.mkTree+               (HXT.XAttr (mkHXTName $ Attr.name_ a))+               (HXTString.fromXmlString $ Attr.value_ a))++multiFromXmlTree ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.T i name XmlString.T -> [HXT.XmlTree]+multiFromXmlTree =+   Tree.fold+      (\i f -> f i)+      (\x subs _ ->+          case x of+             Tag (Elem.Cons name attrs) ->+                [HXTTree.mkTree+                    (HXT.XTag (mkHXTName name) (mkHXTAttrs attrs))+                    (concat subs)])+      (\x _ ->+          case x of+             Text _ {- whitespace -} str -> HXTString.fromXmlString str+             Comment str ->+                [HXTTree.mkTree (HXT.XCmt str) []]+             CData str ->+                [HXTTree.mkTree (HXT.XCdata str) []]+             PI target proc ->+                let (attrTree,subTrees) =+                       case proc of+                          PI.Known attrs -> (mkHXTAttrs attrs, [])+                          PI.Unknown str -> ([], [HXTTree.mkTree (HXT.XText str) []])+                in  [HXTTree.mkTree+                        (HXT.XPi (mkHXTName target) attrTree)+                        subTrees]+             Warning str ->+                [HXTTree.mkTree (HXT.XError 0 str) []])+    . XmlTree.unwrap+++{- * conversion from HXT tree to our XML tree -}++toXmlTree, toXmlTree' ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   HXT.XmlTree -> XmlTree.T () name XmlString.T+toXmlTree = XmlTree.mergeStrings . toXmlTree'+++toXmlTree' (HXTTree.NTree label subTrees) = XmlTree.wrap $ (,) () $+   let leaf x =+          if null subTrees+            then Tree.Leaf x+            else error "HXT to WraXML: Leaf must not contain sub trees."++       fromHXTName = Name.fromString . HXT.qualifiedName++       convAttr (HXTTree.NTree x value) =+          case x of+             HXT.XAttr name ->+                Attr.new (HXT.qualifiedName name) (HXTString.toXmlString value)+             _ -> error "HXT.XAttr expected"++   in  case label of+          HXT.XTag name attrs ->+             Tree.Branch+                (Tag (Elem.Cons+                          (fromHXTName name)+                          (map convAttr attrs)))+                (map (XmlTree.unwrap . toXmlTree') subTrees)+          HXT.XText str ->+             leaf (Text True (XmlString.fromString str))+          HXT.XCharRef ref ->+             leaf (Text False [XMLChar.fromCharRef ref])+          HXT.XEntityRef ref ->+             leaf (Text False [XMLChar.fromEntityRef ref])+          HXT.XCmt cmt ->+             leaf (Comment cmt)+          HXT.XPi target proc ->+             Tree.Leaf $ PI (fromHXTName target) $+             case subTrees of+                [] -> PI.Known $ map convAttr proc+                [HXTTree.NTree (HXT.XText str) []] ->+                      PI.Unknown str+                _ ->  error "from HXT: processing instruction - there must be no children or a single text child"+          HXT.XAttr _    -> error "from HXT: attribute not allowed in normal text"+          HXT.XDTD _ _   -> error "from HXT: document type descriptor not allowed in normal text"+          HXT.XCdata x   -> leaf (CData x)+          HXT.XError lev x -> leaf (Warning ("Level: " ++ show lev ++ ": " ++ x))++++{- * lift our XML filters to HXT filters -}++lift ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.Filter () name XmlString.T -> (HXT.XmlTree -> HXT.XmlTree)+lift f = fromXmlTree . f . toXmlTree+++{- |+Lift our XML filters to HXT document processors.+-}+liftFilterToDocument ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+      String  {- ^ Name of root tag for processing, e.g. "html".+                   That tag must be in the first level.+                   It is an unchecked run-time error+                   if it is missing or occurs more than once. -}+   -> XmlTree.Filter () name XmlString.T+   -> (HXT.XmlTree -> HXT.XmlTree)+liftFilterToDocument tagName f =+   HXTTree.changeChildren $ \subTrees ->+      let (pre,x:post) =+              break (checkTagName tagName . HXTTree.getNode) subTrees+      in  pre ++ lift f x : post++checkTagName :: String -> HXT.XNode -> Bool+checkTagName tagName tree =+   case tree of+      (HXT.XTag name _)  ->  HXT.qualifiedName name == tagName+      _  ->  False+++{-+The HTML parser of the Haskell XML toolbox HXT+is great in parsing lousy HTML.+However its API is extremely weakly typed.+Everything is a monadic function, even simple XML trees.+This design was done in order to reduce the combinators essentially to .>>++That's why I decided to use HXT as a parser and pretty printer,+but not using its XML tree structure for manipulations.+This way I hope I can keep in sync with the main development path+while not interfering with HXT's typing style.+-}++++{- |+Tidy a piece of HTML code.+&   ->   &amp;+<   ->   &lt;+unquoted tag attribute values: size=-1   ->   size="-1"+insert omitted closing tags+-}+tidyHTML :: String -> IO String+tidyHTML input =+   -- escapeXmlDoc replaces < by &lt; and so on+   -- XmlParsec.substXmlEntities similar to escapeXmlDoc ?+   fmap (($"") . showHTMLTrees . (escapeXmlDoc .> getChildren))+        (fromHTMLString input)+++{- |+Like 'Text.XML.HXT.DOM.XmlTreeFunctions.xshow'+but it shows empty tags the HTML way.+E.g. it emits @<br>@ instead of @<br\/>@,+@<noscript><\/noscript>@ instead of @<noscript\/>@.+Many browsers prefer that.+-}+showHTML :: HXT.XmlTree -> String+showHTML leaf = showHTMLTrees (HXTTree.getChildren leaf) ""++showHTMLTrees	:: HXT.XmlTrees -> ShowS+showHTMLTrees	= foldr (.) id . map showHTMLTree+++-- cf. src/Text/XML/HXT/DOM/XmlTreeFunctions.hs+showHTMLTree	:: HXT.XmlTree -> ShowS+showHTMLTree leaf =+   case leaf of+      (NTree (XPi n al) _) ->+         showString "<?"+         .+         showQName n+         .+         (foldr (.) id . map showPiAttr) al+         .+         showString "?>"+           where+             showPiAttr :: HXT.XmlTree -> String -> String+             showPiAttr a@(NTree (XAttr an) cs) =+	         if aName an == a_value+	           then ShowXML.blank . showHTMLTrees cs+	           else showHTMLTree a+             showPiAttr _ = id+      (NTree (XTag t al) cs) ->+         if null cs && isEmptyHtmlTag (HXT.qualifiedName t)+           then ShowXML.lt . showQName t . showHTMLTrees al . ShowXML.gt+           else ShowXML.lt . showQName t . showHTMLTrees al . ShowXML.gt+                 . showHTMLTrees cs+                 . ShowXML.lt . ShowXML.slash . showQName t . ShowXML.gt+      (NTree (XAttr an) cs) ->+         ShowXML.blank . showQName an . ShowXML.eq . ShowXML.stringQuoted (showHTMLTrees cs "")+      (NTree (XError l e) _) ->+         showString "<!-- ERROR (" . showString (show l) . showString "):\n"+          . showString e . showString "\n-->"+      _ -> (xshow [leaf] ++) -- showXmlTree leaf+++showQName :: QName -> ShowS+showQName = showString . qualifiedName++++{- |+An input handler alternative+to Text.XML.HXT.Parser.ProtocolHandlerFile.+It returns the argument string as something+that can be further processed by HXT functions.+-}+getStringContents :: String -> XmlStateFilter a+getStringContents contents =+   return . replaceChildren (xtext contents)+   .>>+   {- We must attach some encoding info to the tree+      which is processed by the HTML parser.+      Using this encoding information+      the HTML parser converts e.g. UTF-8 characters to Unicode characters.+      Cf. Parser.XmlInput.getXmlContents -}+   liftF parseXmlDocEncodingSpec+   .>>+   guessDocEncoding+++{- |+Search for a META tag for the encoding of the HTML text.+-}+findMetaEncoding :: String -> IO (Maybe String)+findMetaEncoding str =+   do htmlTrees <- xmlTreesFromHTMLString str+      return (msum (map HTMLTree.findMetaEncoding (htmlTrees :: [XmlTree.T () NameLC.T String])))++getMetaHTTPHeaders :: String -> IO [(String, String)]+getMetaHTTPHeaders str =+   do htmlTrees <- xmlTreesFromHTMLString str+      return (concatMap HTMLTree.getMetaHTTPHeaders (htmlTrees :: [XmlTree.T () NameLC.T String]))++xmlTreesFromHTMLString ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   String -> IO [XmlTree.T () name String]+xmlTreesFromHTMLString str =+   do hxtTree <- fromHTMLString str+      -- it will hopefully be only one HTML tree+      return $+         map (XmlTree.unescape . toXmlTree)+             (filter (checkTagName "html" . HXTTree.getNode)+                     (HXTTree.getChildren hxtTree))+++{- |+Guess the encoding from the META-HTTP-EQUIV attribute, if available.+Otherwise fall back to ISO-Latin-1.+-}+fromHTMLStringMetaEncoding :: String -> IO HXT.XmlTree+fromHTMLStringMetaEncoding str =+   do enc <- findMetaEncoding str+      fromHTMLStringOpt [(a_encoding, fromMaybe isoLatin1 enc)] str++{-+With no encoding option given,+utf8ToUnicode fails when trying to interpret ISO-Latin characters as UTF-8 characters+-}+fromHTMLString :: String -> IO HXT.XmlTree+fromHTMLString = fromHTMLStringOpt [(a_encoding, isoLatin1)]++fromHTMLStringOpt :: Attributes -> String -> IO HXT.XmlTree+fromHTMLStringOpt options input =+   do (tree,_,_) <- errorAnnFromHTMLStringOpt options input+      return tree++type ErrorMsg = (Int,String)++errorAnnFromHTMLStringMetaEncoding ::+   String -> IO (HXT.XmlTree, [ErrorMsg], Int)+errorAnnFromHTMLStringMetaEncoding str =+   do enc <- findMetaEncoding str+      errorAnnFromHTMLStringOpt [(a_encoding, fromMaybe isoLatin1 enc)] str++{- |+Adaption of Text.XML.HXT.Parser.MainFunctions.getXmlDocument+-}+errorAnnFromHTMLStringOpt ::+   Attributes -> String -> IO (HXT.XmlTree, [ErrorMsg], Int)+errorAnnFromHTMLStringOpt options contents =+   do+      let options' =+             (a_collect_errors, v_1) :	-- collect errors+	     (a_issue_errors,   v_0) :	-- but don't issue+	    				-- can be overwritten by supporting other values in options+             options+      (root:errs) <- run' $ parseDocument options' contents emptyRoot+      let elvl = intValueOf a_status root+      let errMsgs = map ((\(XError level msg) -> (level, msg)) . getNode) errs+      return (root, errMsgs, elvl)++++{- |+Adaption of Text.XML.HXT.Parser.MainFunctions.parseDocument+-}+parseDocument :: Attributes -> String -> XmlStateFilter state+parseDocument userOptions contents+    = processDocument userOptions defaultOptions+      ( traceMsg 1 "parseDocument: options added, start processing"+	.>>+	traceTree+	.>>+	getStringContents contents		-- get the content as text+	.>>+	parseHtmlDoc				-- parse everything as HTML+	.>>+--        liftMf canonicalizeForXPath+--	.>>+	traceMsg 1 "parseDocument: document processed"	-- trace output+	.>>+	traceSource+	.>>+	traceTree+      )+    where+    defaultOptions+	= [ ( a_parse_html,		v_1 )+	  , ( a_validate,		v_1 )+	  , ( a_issue_errors,		v_1 )+	  , ( a_issue_warnings,		v_1 )+	  , ( a_check_namespaces,	v_0 )+	  , ( a_canonicalize,		v_1 )+	  , ( a_preserve_comment,	v_0 )+	  , ( a_remove_whitespace,	v_0 )+	  ]+++{- |+Copy of Text.XML.HXT.Parser.MainFunctions.addOptions add addDefaultOptions+-}+addOptions	  :: Attributes -> XmlFilter+addOptions+    = seqF . map (uncurry addAttr)++addDefaultOptions :: Attributes -> XmlFilter+addDefaultOptions+    = seqF . map (\ (n,v) -> addAttr n v `whenNot` hasAttr n)+++{- |+Copy of Text.XML.HXT.Parser.MainFunctions.processDocument+-}+processDocument	:: Attributes -> Attributes -> XmlStateFilter state -> XmlStateFilter state+processDocument userOptions defaultOptions processFilter+    = liftMf isRoot+      .>>+      liftMf (addOptions userOptions+	      .>+	      addOptions [(a_status, show c_ok)]+	     )+      .>>+      liftMf (addDefaultOptions defaultOptions)+      .>>+      setSystemParams							-- store options in system state+      .>>+      choiceM+      [ hasOption a_propagate_errors					-- error handling is set by calling environment+		:-> thisM++      , hasOption a_collect_errors+	.>+	hasOption a_issue_errors+		:-> performAction (\ _ -> setSysErrorHandler (errorMsgLogging.>> errorMsgToStderr)	)++      , hasOption a_collect_errors+		:-> performAction (\ _ -> setSysErrorHandler errorMsgLogging	)++      , hasOption a_issue_errors+		:-> performAction (\ _ -> setSysErrorHandler errorMsgToStderr	)++      , this+		:-> performAction (\ _ -> setSysErrorHandler noneM		)+      ]+      .>>+      processFilter+      .>>+      ( thisM+        +++>>+	( hasOption a_collect_errors+          `guardsM`+	  getErrorMsg+	)+      )+++{-+putStr . xshow =<< run' (Text.XML.HXT.Parser.MainFunctions.parseDocument [(a_source,"lousy.html"), (a_parse_html,v_1)] emptyRoot)++readFile "lousy.html" >>= tidy >>= putStr+-}

@@ -0,0 +1,132 @@+module Text.XML.WraXML.Tree.HaXml where++import qualified Text.XML.HaXml as HaXml+import           Text.XML.HaXml.Posn(Posn, posInNewCxt)++import Text.XML.WraXML.Tree+   (Branch(Tag), Leaf(Text, PI, Comment, CData, Warning), )+import qualified Text.XML.WraXML.Element as Elem++import qualified Text.XML.WraXML.Tree         as XmlTree+import qualified Text.XML.WraXML.Tree.Literal as XmlTreeL++import qualified Data.Tree.BranchLeafLabel as Tree++import qualified Text.XML.WraXML.String       as XmlString+import qualified Text.XML.WraXML.String.HaXml as HaXmlString+import qualified Text.XML.Basic.Character as XMLChar++import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name as Name+import qualified Text.XML.Basic.ProcessingInstruction as PI++import Data.Tuple.HT (mapSnd, )+++{- * conversion from our XML tree to HaXml tree -}++fromXmlTree ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.T i name XmlString.T -> HaXml.Content i+fromXmlTree x =+   case multiFromXmlTree x of+      [y] -> y+      _   -> error "top branch can't be a string"++multiFromXmlTree ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.T i name XmlString.T -> [HaXml.Content i]+multiFromXmlTree =+   Tree.fold+      (\i f -> f i)+      (\x subs i ->+          case x of+             Tag (Elem.Cons name attrs) ->+               [HaXml.CElem (HaXml.Elem (Name.toString name)+                  (map (mapSnd HaXmlString.fromXmlString . Attr.toPair) attrs)+                  (concat subs)) i])+      (\x i ->+          case x of+             Text whitespace str0 ->+                XMLChar.switchUnicodeRuns+                   (flip (HaXml.CString whitespace) i)+                   (flip HaXml.CRef i . HaXml.RefChar)+                   (flip HaXml.CRef i . HaXml.RefEntity)+                   str0+             Comment str ->+                [HaXml.CMisc (HaXml.Comment str) i]+             CData str ->+                [HaXml.CString True str i]+             PI target p ->+                [HaXml.CMisc (HaXml.PI (Name.toString target,+                   case p of+                      PI.Known attrs -> Attr.formatListBlankHead attrs ""+                      PI.Unknown str -> str)) i]+             Warning str ->+                [HaXml.CMisc (HaXml.Comment ("Warning: " ++ str)) i]) .+    XmlTree.unwrap+++{- * conversion from HaXml tree to our XML tree -}++toXmlTree, toXmlTree' ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   HaXml.Content i -> XmlTree.T i name XmlString.T+toXmlTree = XmlTree.mergeStrings . toXmlTree'+++toXmlTree' x =+   case x of+      HaXml.CElem (HaXml.Elem name attrs subTrees) i ->+         XmlTreeL.tagIndexAttr i+            name+            (map (mapSnd HaXmlString.toXmlString) attrs)+            (map toXmlTree' subTrees)+      HaXml.CString whitespace str i ->+         XmlTree.wrap2 i $+         Tree.Leaf (Text whitespace (XmlString.fromString str))+      HaXml.CRef ref i ->+         XmlTree.literalIndex i [HaXmlString.refToXmlAtom ref]+      HaXml.CMisc misc i ->+         XmlTree.wrap2 i $+         Tree.Leaf (case misc of+            HaXml.Comment str -> Comment str+            HaXml.PI (target, p) ->+               PI (Name.fromString target) $ PI.Unknown p)+++{- * lift our XML filters to HaXml filters -}++lift ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.Filter i name XmlString.T -> (HaXml.Content i -> HaXml.Content i)+lift f = fromXmlTree . f . toXmlTree+++{- |+Lift a filter of HaXml trees to a processor of a HaXml document.++cf. 'Text.XML.HaXml.Wrappers.onContent'+-}+onContent ::+   FilePath ->+   (HaXml.Content  Posn -> HaXml.Content  Posn) ->+   (HaXml.Document Posn -> HaXml.Document Posn)+onContent file f (HaXml.Document p s e m) =+    case f (HaXml.CElem e (posInNewCxt file Nothing)) of+        HaXml.CElem e' _ -> HaXml.Document p s e' m+        _                -> error "produced wrong output"++liftFilterToDocument ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   FilePath -> XmlTree.Filter Posn name XmlString.T ->+      (HaXml.Document Posn -> HaXml.Document Posn)+liftFilterToDocument file =+   onContent file . lift++++processWith ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.Filter Posn name XmlString.T -> IO ()+processWith = HaXml.processXmlWith . XmlTree.liftTrans . lift

@@ -0,0 +1,29 @@+module Text.XML.WraXML.Tree.LazyParser where++import qualified Text.ParserCombinators.PolyLazy as Parser+import Text.ParserCombinators.PolyLazy (Parser, )++import Control.Monad (liftM2, )+++force :: Parser t a -> Parser t a+force = Parser.apply (return id)++{-+Like Parser.manyFinally,+but a matching terminator parser has precedence+to a successful element parser.+-}+manyFinallyAppend :: Parser t [a] -> a ->+   Parser t a -> Parser t [a]+manyFinallyAppend terminator eofWarn p =+   let recourse = force $+          terminator `Parser.onFail`+          liftM2 (:) p recourse `Parser.onFail`+          return [eofWarn]+   in  recourse++manyLazy :: Parser t a -> Parser t [a]+manyLazy p =+   let recourse = force $ liftM2 (:) p recourse `Parser.onFail` return []+   in  recourse

@@ -0,0 +1,54 @@+{- |+This module allows construction of XML trees+using String literals instead of names.+-}+module Text.XML.WraXML.Tree.Literal (+   XmlTree.T,+   processing, processingIndex,+   tag, tagAttr, tagIndexAttr,+   XmlTree.literal, XmlTree.literalIndex,+   XmlTree.comment, XmlTree.commentIndex,+   XmlTree.warning, XmlTree.warningIndex,+   XmlTree.cdata,   XmlTree.cdataIndex,+   ) where++import qualified Text.XML.WraXML.Tree as XmlTree++import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name as Name+import qualified Text.XML.Basic.ProcessingInstruction as PI++import Prelude hiding (show, shows)++++processing ::+   (Name.Tag name, Name.Attribute name) =>+   String -> PI.T name str -> XmlTree.T i name str+processing =+   XmlTree.processing . Name.fromString++processingIndex ::+   (Name.Tag name, Name.Attribute name) =>+   i -> String -> PI.T name str -> XmlTree.T i name str+processingIndex i =+   XmlTree.processingIndex i . Name.fromString++tag ::+   (Name.Tag name, Name.Attribute name) =>+   String -> [XmlTree.T i name str] -> XmlTree.T i name str+tag = XmlTree.tag . Name.fromString++tagAttr ::+   (Name.Tag name, Name.Attribute name) =>+   String -> [(String,str)] -> [XmlTree.T i name str] -> XmlTree.T i name str+tagAttr name attrs =+   XmlTree.tagAttr (Name.fromString name)+      (map (uncurry Attr.new) attrs)++tagIndexAttr ::+   (Name.Tag name, Name.Attribute name) =>+   i -> String -> [(String,str)] -> [XmlTree.T i name str] -> XmlTree.T i name str+tagIndexAttr i name attrs =+   XmlTree.tagIndexAttr i (Name.fromString name)+      (map (uncurry Attr.new) attrs)

@@ -0,0 +1,207 @@+{- |+Very lazy HTML tree parser using TagSoup as lexer.+-}+module Text.XML.WraXML.Tree.TagSoup where++import qualified Text.HTML.TagSoup as Tag+import Text.HTML.TagSoup (Tag(..), )++import qualified Text.XML.WraXML.Tree.Literal as XmlTree++import qualified Text.HTML.TagSoup.Match as Match++import qualified Text.HTML.Basic.Tag as TagH+import qualified Text.XML.Basic.Position as Position+import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.ProcessingInstruction as PI++-- import qualified Text.XML.WraXML.String         as XmlString+-- import qualified Text.XML.WraXML.String.TagSoup as XmlStringTagSoup++import qualified Text.XML.Basic.Name.LowerCase as NameLC+import qualified Text.XML.Basic.Name           as Name++import qualified Text.XML.WraXML.Tree.LazyParser as ParserU+import qualified Text.ParserCombinators.PolyLazy as Parser++import Data.Bool.HT (select, )+import Control.Monad (liftM, )+import qualified Data.List as List+++type PosTag = (Position.T, Tag)+-- data PosTag = PosTag !Position.T Tag+++defaultFilename :: String+defaultFilename = "input"++attachPos :: [Tag] -> [PosTag]+attachPos =+   snd .+   List.mapAccumL+      (\pos t ->+          let newPos =+                  case t of+                     Tag.TagPosition setRow setColumn ->+                          Position.new defaultFilename setRow setColumn+                     _ -> pos+          in  (newPos, (newPos, t)))+--          in  (newPos, PosTag newPos t))+      (Position.initialize defaultFilename)++removeMetaPos :: [PosTag] -> [PosTag]+removeMetaPos =+   filter (\(_pos,tag) -> case tag of+               TagPosition _ _ -> False+               _ -> True)+++type XmlTree name string = XmlTree.T Position.T name string++{- |+A TagSoup could represent multiple HTML trees,+e.g. with some introducing comments.+-}+{-+toXmlTrees ::+   [Tag XMLChar] -> [XmlTree name String]+toXmlTrees =+   toXmlTreesAux .+   Tag.canonicalizeTags+-}++toXmlTreesString ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   [Tag] -> [XmlTree name String]+toXmlTreesString =+   toXmlTreesAux .+   removeMetaPos .+   attachPos .+   Tag.canonicalizeTags  -- must remain for Match.tagCloseLit+--   toXmlTrees+++toXmlTreesAux ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   [PosTag] -> [XmlTree name String]+toXmlTreesAux =+   fst . Parser.runParser (ParserU.manyLazy parseBranch)++++type Parser i a = Parser.Parser (i, Tag) a+++parseBranch ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   Parser i (XmlTree.T i name String)+parseBranch =+   do (ti,t) <- Parser.next+      case t of+         TagText text -> return (XmlTree.literalIndex ti text)+         TagOpen ('?':target) attrs ->+            return $+               XmlTree.processingIndex ti target $+               case attrs of+                  [("",str)] ->+                     PI.Unknown str+                  _ ->+                     PI.Known $+                     map (uncurry Attr.new) attrs+         TagOpen "![CDATA[" [("",str)] ->+            return (XmlTree.cdataIndex ti str)+         TagOpen name attrs ->+            liftM+               (XmlTree.tagIndexAttr ti name attrs)+               (parseSubTrees+                  (XmlTree.warningIndex ti+                      "unexpected end of file") (Name.fromString name))+         TagClose name ->+            let makeWarning ::+                   (Name.Tag name, Ord name) =>+                   i -> TagH.Name name -> XmlTree.T i name String+                makeWarning i n =+                   XmlTree.warningIndex i $+                   if TagH.isSloppy n+                     then "misplaced sloppy closing tag </" ++ name ++ ">"+                     else "isolated closing tag </" ++ name ++ ">"+            in  return $ makeWarning ti $ Name.fromString name+         TagComment cmt ->+            return (XmlTree.commentIndex ti cmt)+         TagWarning msg ->+            return (XmlTree.warningIndex ti msg)+         TagPosition _ _ ->+            error "Unexpected position information. Please filter it out!"+{-+         TagSpecial name _ ->+            return $ XmlTree.warningIndex ti $+               "Special tag " ++ name ++ " not allowed within a HTML document"+-}+++parseSubTrees ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.T i name String -> TagH.Name name -> Parser i [XmlTree.T i name String]+parseSubTrees warn name =+   ParserU.force $+   if TagH.isEmpty name+     then+       (Parser.satisfy (Match.tagCloseLit (Name.toString name) . snd) >> return [])+         `Parser.onFail` return []+     else+       ParserU.manyFinallyAppend+          (parseTerminator name)+          warn parseBranch+++parseTerminator ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   TagH.Name name -> Parser i [XmlTree.T i name String]+parseTerminator name =+   do c@(ci,ct) <- Parser.next+      let retry warns = Parser.reparse [c] >> return warns+      case ct of+         TagClose closeName_ ->+            let closeName = Name.fromString closeName_+            in  flip select+                   ((TagH.isEmpty closeName,+                        fail $ "the tag <" ++ closeName_ ++ "> closes nothing.") :+                    (name `TagH.isInnerOf` closeName, retry []) :+                    (name==closeName, return []) :+                    (TagH.isSloppy name,+                     retry [XmlTree.warningIndex ci $+                               "sloppy tag <"+                               ++ Name.toString name ++ "> closed by </"+                               ++ closeName_ ++ ">"]) :+                    (TagH.isSloppy closeName,+                     fail $ "ignore sloppy closing tag </" ++ Name.toString name ++ ">") :+                    [])+                   (return [XmlTree.warningIndex ci $+                                "open tag <" ++ Name.toString name +++                                "> and close tag </" ++ Name.toString closeName +++                                "> do not match"])+         TagOpen openName _ ->+            if Name.fromString openName `TagH.closes` name+              then retry []+              else fail $+                      "open tag <" ++ openName +++                      "> does not close tag <" ++ Name.toString name ++ ">"+         _ -> fail $ "not a termination of a tag"+++parseOptions :: Tag.ParseOptions+parseOptions =+   Tag.parseOptions+      {Tag.optTagPosition = True,+       Tag.optTagWarning = True}++example :: [XmlTree NameLC.T String]+example =+   toXmlTreesString $+   Tag.parseTagsOptions parseOptions $+--   "<html><head>blub<meta/></head><br><body>bla</body></html>"+--   "<html><head>blub<meta/></head><br><body>bla<UL><li>1.<li>2.</OL><TABLE border=1></TABLE></body></html>"+--   "<html><head><meta>too much</meta>blub<meta/></head><br><body>bla<UL><li>1.<li>2.</UL><TABLE border=1></TABLE></bo"++undefined++"dy></html>"+--    "<b><font>test</b></font>"+    "<html><b><font>test</b></font></html>"

@@ -0,0 +1,236 @@+{- |+Very lazy HTML tree parser using TagSoup as lexer.+-}+module Text.XML.WraXML.Tree.TagSoupHT (+   toXmlTrees,+   fromXmlTree,+   fromElement, fromLeaf,+   liftElementFilter, liftElementCheck,+   example,+   ) where++import qualified Text.HTML.TagSoup.HT.Parser      as TagParser+import qualified Text.HTML.TagSoup.HT.Tag         as Tag+import qualified Text.HTML.TagSoup.HT.PositionTag as PosTag+import qualified Text.HTML.TagSoup.HT.Tag.Match   as MatchTag++import qualified Text.XML.WraXML.Element          as Elem+import qualified Text.XML.WraXML.Tree             as XmlTree+import qualified Data.Tree.BranchLeafLabel        as Tree++import qualified Text.HTML.Basic.Tag as TagH++import qualified Text.XML.Basic.Position    as Position+import qualified Text.XML.Basic.Name.LowerCase as NameLC+import qualified Text.XML.Basic.Name           as Name++-- import Control.Monad.Trans.State (evalState, put, get, gets, )+import Control.Monad.Trans.Writer (runWriter, writer, )++import Data.Monoid (Last(Last, getLast), )+import Data.Maybe (fromMaybe, )+import Data.Bool.HT (select, )++import qualified Text.XML.WraXML.Tree.LazyParser as ParserU+import qualified Text.ParserCombinators.PolyLazy as Parser++import Control.Monad (liftM, )+++-- we don't use XmlTree synonym in the exported functions for documentation purposes+type XmlTree name string = XmlTree.T Position.T name string+++{-+-- FIXME: how to get rid of 'error' ?+fromXmlTree' ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.T Position.T name string -> [PosTag.T name string]+fromXmlTree' =+   flip evalState (error "position not initialised, yet") .+   Tree.fold+      (\pos x -> put pos >> x)+      (\branch subTreesM ->+          do pos <- get+             subTrees <- sequence subTreesM+             lastPos <- get+             +             let elm = XmlTree.getElement branch+                 openTag =+                    PosTag.cons pos $ fromElement elm+                 closeTag =+                    PosTag.cons lastPos $+                    Tag.Close $ Elem.name_ elm+             return $ openTag : concat subTrees ++ [closeTag])++      (\leaf ->+          gets (\pos -> [PosTag.cons pos $ fromLeaf leaf]))+   .+   XmlTree.unwrap+-}++fromXmlTree ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.T Position.T name string -> [PosTag.T name string]+fromXmlTree =+   fst . runWriter .+   Tree.foldLabel+      (\pos branch subTreesM ->+          let (subTrees, lastSubPos) = runWriter $ sequence subTreesM+              lastPos = fromMaybe pos $ getLast lastSubPos+              elm = XmlTree.getElement branch+              openTag =+                 PosTag.cons pos $ fromElement elm+              closeTag =+                 PosTag.cons lastPos $+                 Tag.Close $ Elem.name_ elm+          in  writer (openTag : concat subTrees ++ [closeTag],+                      Last $ Just lastPos))+      (\pos leaf ->+          writer $ flip (,) (Last $ Just pos) $+          [PosTag.cons pos $ fromLeaf leaf])+   .+   XmlTree.unwrap++fromElement ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   Elem.T name string -> Tag.T name string+fromElement elm =+   Tag.Open (Elem.name_ elm) (Elem.attributes_ elm)++fromLeaf ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree.Leaf name string -> Tag.T name string+fromLeaf leaf =+   case leaf of+      XmlTree.Text  _ text -> Tag.Text text+      XmlTree.Comment text -> Tag.Comment text+      XmlTree.CData   text -> Tag.Special TagH.cdata text+      XmlTree.PI      name instr -> Tag.Processing name instr+      XmlTree.Warning text -> Tag.Warning text+++liftElementFilter ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   (Elem.T name str -> Elem.T name str) ->+   Tag.T name str -> Tag.T name str+liftElementFilter f tag =+   flip (maybe tag) (Tag.maybeOpen tag) $+   fromElement . f . uncurry Elem.Cons++liftElementCheck :: (Elem.T name string -> Bool) -> (Tag.T name string -> Bool)+liftElementCheck f tag =+   flip (maybe False) (Tag.maybeOpen tag) $+   f . uncurry Elem.Cons++++{- |+A TagSoup could represent multiple HTML trees,+e.g. with some introducing comments.+-}+toXmlTrees ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   [PosTag.T name string] -> [XmlTree.T Position.T name string]+toXmlTrees =+   fst . Parser.runParser (ParserU.manyLazy parseBranch)+++type Parser name string a = Parser.Parser (PosTag.T name string) a+++parseBranch ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   Parser name string (XmlTree name string)+parseBranch =+   do nt <- Parser.next+      let ti = PosTag.position_ nt+      case PosTag.tag_ nt of+         Tag.Text text -> return (XmlTree.literalIndex ti text)+         Tag.Open name attrs ->+            liftM+               (XmlTree.tagIndexAttr ti name attrs)+               (parseSubTrees+                  (XmlTree.warningIndex ti+                      "unexpected end of file") name)+         Tag.Close name ->+            return $ XmlTree.warningIndex ti $+            if TagH.isSloppy name+              then "misplaced sloppy closing tag </" ++ Name.toString name ++ ">"+              else "isolated closing tag </" ++ Name.toString name ++ ">"+         Tag.Comment cmt ->+            return (XmlTree.commentIndex ti cmt)+         Tag.Warning msg ->+            return (XmlTree.warningIndex ti msg)+         Tag.Processing target p ->+            return (XmlTree.processingIndex ti target p)+         Tag.Special name str ->+            return $+            if Name.match TagH.cdataString name+              then XmlTree.cdataIndex ti str+              else XmlTree.warningIndex ti $+                      "Special tag " ++ Name.toString name +++                      " not allowed within a HTML document"+++parseSubTrees ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   XmlTree name string -> TagH.Name name ->+   Parser name string [XmlTree name string]+parseSubTrees warn name =+   ParserU.force $+   if TagH.isEmpty name+     then+       (Parser.satisfy (MatchTag.close (name==) . PosTag.tag_) >> return [])+         `Parser.onFail` return []+     else+       ParserU.manyFinallyAppend+          (parseTerminator name)+          warn parseBranch+++parseTerminator ::+   (Name.Tag name, Name.Attribute name, Ord name) =>+   TagH.Name name -> Parser name string [XmlTree name string]+parseTerminator name =+   do c <- Parser.next+      let ci = PosTag.position_ c+          retry warns = Parser.reparse [c] >> return warns+      case PosTag.tag_ c of+         Tag.Close closeName ->+            flip select+               ((TagH.isEmpty closeName,+                    fail $ "the tag <" ++ Name.toString closeName ++ "> closes nothing.") :+                (name `TagH.isInnerOf` closeName, retry []) :+                (name==closeName, return []) :+                (TagH.isSloppy name,+                 retry [XmlTree.warningIndex ci $+                           "sloppy tag <"+                           ++ Name.toString name ++ "> closed by </"+                           ++ Name.toString closeName ++ ">"]) :+                (TagH.isSloppy closeName,+                 fail $ "ignore sloppy closing tag </" ++ Name.toString name ++ ">") :+                [])+               (return [XmlTree.warningIndex ci $+                            "open tag <" ++ Name.toString name +++                            "> and close tag </" ++ Name.toString closeName +++                            "> do not match"])+         Tag.Open openName _ ->+            if openName `TagH.closes` name+              then retry []+              else fail $+                      "open tag <" ++ Name.toString openName +++                      "> does not close tag <" ++ Name.toString name ++ ">"+         _ -> fail $ "not a termination of a tag"+++example ::+   [XmlTree NameLC.T String]+example =+   toXmlTrees $+   TagParser.runSoupWithPositions $+--   "<html><head>blub<meta/></head><br><body>bla</body></html>"+--   "<html><head>blub<meta/></head><br><body>bla<UL><li>1.<li>2.</OL><TABLE border=1></TABLE></body></html>"+--   "<html><head><meta>too much</meta>blub<meta/></head><br><body>bla<UL><li>1.<li>2.</UL><TABLE border=1></TABLE></bo"++undefined++"dy></html>"+--    "<b><font>test</b></font>"+    "<html><b><font>test</b></font></html>"

@@ -0,0 +1,4 @@+module Text.XML.WraXML.Utility where++compose :: [a -> a] -> a -> a+compose = flip (foldr ($))

@@ -0,0 +1,84 @@+Name:           wraxml+Version:        0.3+License:        GPL+License-File:   LICENSE+Author:         Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:     Henning Thielemann <haskell@henning-thielemann.de>+Homepage:       http://darcs.haskell.org/wraxml/+Category:       Text+Build-Depends:+  polyparse >=1.1,+  tagsoup >=0.6 && <0.7,+  tagsoup-ht >=0.3 && <0.4,+  xml-basic >=0.0.1 && <0.1,+  HaXml >=1.19.4, hxt >=8.1.0 && <9,+  hxt-filter >=8.1.1 && <9,+  transformers >=0.1 && <0.2,+  utility-ht >=0.0.4 && <0.1,+  explicit-exception >=0.1.3 && <0.2,+  data-accessor >=0.2 && <0.3,+  containers >=0.1 && <0.3,+  base >=3 && <4+Synopsis:   Lazy wrapper to HaXML, HXT, TagSoup via custom XML tree structure+Description:+  This is a wrapper to HaXML and HXT (Haskell XML Toolbox).+  It's my work-around for the unfortunate situation that both toolboxes+  have different functionality,+  none is the superset of the other.+  Both of them rely on data structures, which look unnatural to me.+  Additionally they provide combinator functions that are actually weakly typed,+  they are all of type @(a -> [a])@,+  instead of being differentiated into @(a -> Bool)@, @(a -> a)@ and @(a -> [a])@.+  HXT is even weaker in type safety than HaXML+  since it allows complete XML trees even in attribute values.+  I didn't want to write another XML toolbox with parsers, HTML support and so on,+  however in the meantime I came close to it.+  .+  I decided to do some wrapping in order to use as much as possible functionality+  from HaXML and HXT.+  I provide my own XML tree data structure with according operations.+  Conversions between HaXML or HXT trees and my own ones are implemented.+  So I can use the parser and pretty printer of both HaXML and HXT+  while processing trees the way I find more natural.+  TagSoups can also be converted to XML trees.+  All conversions are lazy.+  .+  I have a special XML string structure.+  ("Text.XML.WraXML.String")+  XML strings consist of ASCII characters and XML references.+  My XML tree is built on top of a very general tree structure,+  which distinguishs between leafs and inner branches.+  ("Data.Tree.BranchLeafLabel")+  Each element of a tree is labeled with some information.+  Branches are then used for tags,+  leafs for XML strings and special tags,+  and the labels for pointers to positions in the source file.+  ("Text.XML.WraXML.Tree")+GHC-Options:    -Wall+Build-Type:     Simple+Hs-source-dirs: src+Exposed-modules:+  Data.Tree.BranchLeafLabel+  Data.Tree.BranchLeaf+  Text.HTML.WraXML.Document+  Text.HTML.WraXML.Table+  Text.HTML.WraXML.Tree+  Text.HTML.WraXML.String+  Text.HTML.WraXML.Entity+  Text.XML.WraXML.Position.HaXml+  Text.XML.WraXML.String+  Text.XML.WraXML.String.HaXml+  Text.XML.WraXML.String.HXT+  Text.XML.WraXML.Element+  Text.XML.WraXML.Tree+  Text.XML.WraXML.Tree.HaXml+  Text.XML.WraXML.Tree.HXT+  Text.XML.WraXML.Tree.TagSoup+  Text.XML.WraXML.Tree.TagSoupHT+  Text.XML.WraXML.Tree.Literal+  Text.XML.WraXML.Document+  Text.XML.WraXML.Document.TagSoup+  Text.XML.WraXML.Document.TagSoupHT+Other-Modules:+  Text.XML.WraXML.Utility+  Text.XML.WraXML.Tree.LazyParser