HaXml-1.23.3/0000755000062000006210000000000011767644706012073 5ustar 1341796mkpasswdHaXml-1.23.3/COPYRIGHT0000755000062000006210000000250011767644706013366 0ustar 1341796mkpasswdThe HaXml library and tools were written by and are copyright to (c) copyright 1998-1999 Malcolm Wallace and Colin Runciman (c) copyright 2000-2012 Malcolm Wallace The HaXml library is licensed under the terms of the GNU Lesser General Public Licence (LGPL), which can be found in the file called LICENCE-LGPL, with the following special exception: ---- As a relaxation of clause 6 of the LGPL, the copyright holders of this library give permission to use, copy, link, modify, and distribute, binary-only object-code versions of an executable linked with the original unmodified Library, without requiring the supply of any mechanism to modify or replace the Library and relink (clauses 6a, 6b, 6c, 6d, 6e), provided that all the other terms of clause 6 are complied with. ---- The HaXml tools Xtract, Validate, DtdToHaskell, XsdToHaskell, and MkOneOf, are licensed under the terms of the GNU General Public Licence (GPL), which can be found in the file called LICENCE-GPL. This library and toolset 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 Licences for more details. If these licensing terms are not acceptable to you, please contact me for negotiation. :-) Malcolm.Wallace@me.com HaXml-1.23.3/HaXml.cabal0000755000062000006210000000740411767644706014100 0ustar 1341796mkpasswdname: HaXml version: 1.23.3 license: LGPL license-file: COPYRIGHT author: Malcolm Wallace maintainer: author homepage: http://www.cs.york.ac.uk/fp/HaXml/ category: Text, XML synopsis: Utilities for manipulating XML documents description: Haskell utilities for parsing, filtering, transforming and generating XML documents. build-type: Simple cabal-version: >=1.2 extra-source-files: LICENCE-GPL, LICENCE-LGPL flag splitBase default: True flag bytestringInBase default: False library exposed-modules: Text.XML.HaXml, Text.XML.HaXml.ByteStringPP, Text.XML.HaXml.Combinators, Text.XML.HaXml.DtdToHaskell.Convert, Text.XML.HaXml.DtdToHaskell.Instance, Text.XML.HaXml.DtdToHaskell.TypeDef, Text.XML.HaXml.Escape, Text.XML.HaXml.Html.Generate, Text.XML.HaXml.Html.Parse, Text.XML.HaXml.Html.ParseLazy, Text.XML.HaXml.Html.Pretty, Text.XML.HaXml.Lex, Text.XML.HaXml.Namespaces, Text.XML.HaXml.OneOfN, Text.XML.HaXml.Parse, Text.XML.HaXml.ParseLazy, Text.XML.HaXml.Posn, Text.XML.HaXml.Pretty, Text.XML.HaXml.SAX, Text.XML.HaXml.Schema.Parse, Text.XML.HaXml.Schema.XSDTypeModel, Text.XML.HaXml.Schema.HaskellTypeModel, Text.XML.HaXml.Schema.NameConversion, Text.XML.HaXml.Schema.TypeConversion, Text.XML.HaXml.Schema.PrettyHaskell, Text.XML.HaXml.Schema.PrettyHsBoot, Text.XML.HaXml.Schema.PrimitiveTypes, Text.XML.HaXml.Schema.Environment, Text.XML.HaXml.ShowXmlLazy, Text.XML.HaXml.Types, Text.XML.HaXml.TypeMapping, Text.XML.HaXml.Util, Text.XML.HaXml.Validate, Text.XML.HaXml.Verbatim, Text.XML.HaXml.Wrappers, Text.XML.HaXml.XmlContent, Text.XML.HaXml.XmlContent.Parser, Text.XML.HaXml.XmlContent.Haskell, Text.XML.HaXml.Xtract.Combinators, Text.XML.HaXml.Xtract.Lex, Text.XML.HaXml.Xtract.Parse if impl(ghc) exposed-modules: Text.XML.HaXml.Schema.Schema hs-source-dirs: src build-depends: polyparse >= 1.5, filepath if flag(splitBase) build-depends: base >= 3 && < 6, pretty, random, containers else build-depends: base < 3 if flag(bytestringInBase) build-depends: base >= 2 && < 3 else build-depends: base < 2 || >= 3, bytestring extensions: CPP, ExistentialQuantification cpp-options: -DMAJOR=1 -DMINOR=23 nhc98-options: -K10M Executable Canonicalise GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: Canonicalise.hs Executable CanonicaliseLazy GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: CanonicaliseLazy.hs Executable Xtract GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: Xtract.hs Executable Validate GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: Validate.hs Executable MkOneOf GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: MkOneOf.hs Executable DtdToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: DtdToHaskell.hs Executable XsdToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: XsdToHaskell.hs Executable FpMLToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools, src cpp-options: -DMAJOR=1 -DMINOR=23 Main-Is: FpMLToHaskell.hs build-depends: directory HaXml-1.23.3/LICENCE-GPL0000755000062000006210000004311211767644706013504 0ustar 1341796mkpasswd GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) 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 this service 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 make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. 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. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute 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 and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), 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 distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the 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 a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, 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. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE 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. 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 convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 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 2 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, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision 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, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This 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 Library General Public License instead of this License. HaXml-1.23.3/LICENCE-LGPL0000755000062000006210000006363411767644706013633 0ustar 1341796mkpasswd GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, 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 this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), 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 distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser 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 Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "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 LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY 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 LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library 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 Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! HaXml-1.23.3/Setup.hs0000755000062000006210000000005611767644706013533 0ustar 1341796mkpasswdimport Distribution.Simple main = defaultMain HaXml-1.23.3/src/0000755000062000006210000000000011767644706012662 5ustar 1341796mkpasswdHaXml-1.23.3/src/Text/0000755000062000006210000000000011767644706013606 5ustar 1341796mkpasswdHaXml-1.23.3/src/Text/XML/0000755000062000006210000000000011767644706014246 5ustar 1341796mkpasswdHaXml-1.23.3/src/Text/XML/HaXml/0000755000062000006210000000000011767644706015257 5ustar 1341796mkpasswdHaXml-1.23.3/src/Text/XML/HaXml/ByteStringPP.hs0000755000062000006210000003552311767644706020160 0ustar 1341796mkpasswd-- | This is a fast non-pretty-printer for turning the internal representation -- of generic structured XML documents into Lazy ByteStrings. -- Like in Text.Xml.HaXml.Pretty, there is one pp function for each type in -- Text.Xml.HaXml.Types, so you can pretty-print as much or as little -- of the document as you wish. module Text.XML.HaXml.ByteStringPP ( -- * Pretty-print a whole document document -- ** Just one content , content -- ** Just one tagged element , element -- * Pretty-print just a DTD , doctypedecl -- ** The prolog , prolog -- ** A content particle description , cp ) where import Prelude hiding (maybe,either,elem,concat) import Data.Maybe hiding (maybe) import Data.List (intersperse) --import Data.ByteString.Lazy hiding (pack,map,head,any,singleton,intersperse,join) import Data.ByteString.Lazy.Char8 (ByteString(), concat, pack, singleton , intercalate, append, elem, empty) import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1 either f _ (Left x) = f x either _ g (Right x) = g x maybe :: (t -> ByteString) -> Maybe t -> ByteString maybe _ Nothing = empty maybe f (Just x) = f x -- A simple implementation of the pretty-printing combinator interface, -- but for plain ByteStrings: infixl 6 <> infixl 6 <+> infixl 5 $$ (<>) :: ByteString -> ByteString -> ByteString -- Beside hcat :: [ByteString] -> ByteString -- List version of <> (<+>) :: ByteString -> ByteString -> ByteString -- Beside, separated by space hsep :: [ByteString] -> ByteString -- List version of <+> ($$) :: ByteString -> ByteString -> ByteString -- Above; if there is no -- overlap, it "dovetails" vcat :: [ByteString] -> ByteString -- List version of $$ -- cat :: [ByteString] -> ByteString -- Either hcat or vcat sep :: [ByteString] -> ByteString -- Either hsep or vcat -- fcat :: [ByteString] -> ByteString -- ``Paragraph fill'' version of cat fsep :: [ByteString] -> ByteString -- ``Paragraph fill'' version of sep nest :: Int -> ByteString -> ByteString -- Nested (<>) b1 b2 = b1 `append` b2 (<+>) b1 b2 = b1 <> pack " " <> b2 ($$) b1 b2 = b1 <> pack "\n" <> b2 -- ($+$) = ($$) hcat = Data.ByteString.Lazy.Char8.concat hsep = Data.ByteString.Lazy.Char8.intercalate (singleton ' ') vcat = Data.ByteString.Lazy.Char8.intercalate (singleton '\n') -- cat = hcat sep = hsep text :: [Char] -> ByteString text = pack -- fsep = cat fsep = sep nest _ b = pack " " <> b parens :: ByteString -> ByteString parens p = pack "(" <> p <> pack ")" ---- -- Now for the XML pretty-printing interface. -- (Basically copied direct from Text.XML.HaXml.Pretty). document :: Document i -> ByteString prolog :: Prolog -> ByteString xmldecl :: XMLDecl -> ByteString misc :: Misc -> ByteString sddecl :: Bool -> ByteString doctypedecl :: DocTypeDecl -> ByteString markupdecl :: MarkupDecl -> ByteString -- extsubset :: ExtSubset -> ByteString -- extsubsetdecl :: ExtSubsetDecl -> ByteString cp :: CP -> ByteString element :: Element i -> ByteString attribute :: Attribute -> ByteString content :: Content i -> ByteString ---- document (Document p _ e m)= prolog p $$ element e $$ vcat (Prelude.map misc m) prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$ vcat (Prelude.map misc m1) $$ maybe doctypedecl dtd $$ vcat (Prelude.map misc m2) xmldecl (XMLDecl v e sd) = text " text v <> text "'" <+> maybe encodingdecl e <+> maybe sddecl sd <+> text "?>" misc (Comment s) = text "" misc (PI (n,s)) = text " text n <+> text s <+> text "?>" sddecl sd | sd = text "standalone='yes'" | otherwise = text "standalone='no'" doctypedecl (DTD n eid ds) = if Prelude.null ds then hd <> text ">" else hd <+> text " [" $$ vcat (Prelude.map markupdecl ds) $$ text "]>" where hd = text " qname n <+> maybe externalid eid markupdecl (Element e) = elementdecl e markupdecl (AttList a) = attlistdecl a markupdecl (Entity e) = entitydecl e markupdecl (Notation n) = notationdecl n markupdecl (MarkupMisc m) = misc m --markupdecl (MarkupPE p m) = peref p -- _ (ExtSubset t ds) = maybe textdecl t $$ -- vcat (Prelude.map extsubsetdecl ds) -- _ (ExtMarkupDecl m) = markupdecl m -- extsubsetdecl (ExtConditionalSect c) = conditionalsect c --extsubsetdecl (ExtPEReference p e) = peref p element (Elem n as []) = text "<" <> qname n <+> fsep (Prelude.map attribute as) <> text "/>" element e@(Elem n as cs) -- | any isText cs = text "<" <> text n <+> fsep (map attribute as) <> -- text ">" <> hcat (map content cs) <> -- text " qname n <> text ">" | isText (head cs) = text "<" <> qname n <+> fsep (Prelude.map attribute as) <> text ">" <> hcat (Prelude.map content cs) <> text " qname n <> text ">" | otherwise = let (d,c) = carryelem e empty in d <> c isText :: Content t -> Bool isText (CString _ _ _) = True isText (CRef _ _) = True isText _ = False carryelem :: Element t -> ByteString -> (ByteString, ByteString) carryelem (Elem n as []) c = ( c <> text "<" <> qname n <+> fsep (Prelude.map attribute as) , text "/>") carryelem (Elem n as cs) c -- | any isText cs = ( c <> element e, empty) | otherwise = let (cs0,d0) = carryscan carrycontent cs (text ">") in ( c <> text "<" <> qname n <+> fsep (Prelude.map attribute as) $$ nest 2 (vcat cs0) <> --- $$ d0 <> text " qname n , text ">") carrycontent :: Content t -> ByteString -> (ByteString, ByteString) carrycontent (CElem e _) c = carryelem e c carrycontent (CString False s _) c = (c <> chardata s, empty) carrycontent (CString True s _) c = (c <> cdsect s, empty) carrycontent (CRef r _) c = (c <> reference r, empty) carrycontent (CMisc m _) c = (c <> misc m, empty) carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c) carryscan _ [] c = ([],c) carryscan f (a:as) c = let (b, c0) = f a c (bs,c1) = carryscan f as c0 in (b:bs, c1) --carryelem e@(Elem n as cs) c -- | isText (head cs) = -- ( start <> -- text ">" <> hcat (map content cs) <> text " text n -- , text ">") -- | otherwise = -- let (d,c0) = foldl carrycontent (start, text ">") cs in -- ( d <> c0 <> text " text n -- , text ">") -- where start = c <> text "<" <> text n <+> fsep (map attribute as) -- --carrycontent (d,c) (CElem e) = let (d',c') = carryelem e c in -- (d $$ nest 2 d', c') --carrycontent (d,c) (CString _ s) = (d <> c <> chardata s, empty) --carrycontent (d,c) (CRef r) = (d <> c <> reference r,empty) --carrycontent (d,c) (CMisc m) = (d $$ c <> misc m, empty) attribute (n,v) = text (printableName n) <> text "=" <> attvalue v content (CElem e _) = element e content (CString False s _) = chardata s content (CString True s _) = cdsect s content (CRef r _) = reference r content (CMisc m _) = misc m elementdecl :: ElementDecl -> ByteString elementdecl (ElementDecl n cs) = text " qname n <+> contentspec cs <> text ">" contentspec :: ContentSpec -> ByteString contentspec EMPTY = text "EMPTY" contentspec ANY = text "ANY" contentspec (Mixed m) = mixed m contentspec (ContentSpec c) = cp c --contentspec (ContentPE p cs) = peref p cp (TagName n m) = qname n <> modifier m cp (Choice cs m) = parens (hcat (intersperse (text "|") (Prelude.map cp cs))) <> modifier m cp (Seq cs m) = parens (hcat (intersperse (text ",") (Prelude.map cp cs))) <> modifier m --cp (CPPE p c) = peref p modifier :: Modifier -> ByteString modifier None = empty modifier Query = text "?" modifier Star = text "*" modifier Plus = text "+" mixed :: Mixed -> ByteString mixed PCDATA = text "(#PCDATA)" mixed (PCDATAplus ns) = text "(#PCDATA |" <+> hcat (intersperse (text "|") (Prelude.map qname ns)) <> text ")*" attlistdecl :: AttListDecl -> ByteString attlistdecl (AttListDecl n ds) = text " qname n <+> fsep (Prelude.map attdef ds) <> text ">" attdef :: AttDef -> ByteString attdef (AttDef n t d) = qname n <+> atttype t <+> defaultdecl d atttype :: AttType -> ByteString atttype StringType = text "CDATA" atttype (TokenizedType t) = tokenizedtype t atttype (EnumeratedType t) = enumeratedtype t tokenizedtype :: TokenizedType -> ByteString tokenizedtype ID = text "ID" tokenizedtype IDREF = text "IDREF" tokenizedtype IDREFS = text "IDREFS" tokenizedtype ENTITY = text "ENTITY" tokenizedtype ENTITIES = text "ENTITIES" tokenizedtype NMTOKEN = text "NMTOKEN" tokenizedtype NMTOKENS = text "NMTOKENS" enumeratedtype :: EnumeratedType -> ByteString enumeratedtype (NotationType n)= notationtype n enumeratedtype (Enumeration e) = enumeration e notationtype :: [[Char]] -> ByteString notationtype ns = text "NOTATION" <+> parens (hcat (intersperse (text "|") (Prelude.map text ns))) enumeration :: [[Char]] -> ByteString enumeration ns = parens (hcat (intersperse (text "|") (Prelude.map nmtoken ns))) defaultdecl :: DefaultDecl -> ByteString defaultdecl REQUIRED = text "#REQUIRED" defaultdecl IMPLIED = text "#IMPLIED" defaultdecl (DefaultTo a f) = maybe (const (text "#FIXED")) f <+> attvalue a --_ (IncludeSect i)= text " -- vcat (Prelude.map extsubsetdecl i) <+> text "]]>" -- conditionalsect (IgnoreSect i) = text " -- fsep (Prelude.map ignoresectcontents i) <+> text "]]>" -- -- _ (Ignore) = empty -- ignoresectcontents :: IgnoreSectContents -> ByteString -- _ (IgnoreSectContents i is) -- = ignore i <+> vcat (Prelude.map internal is) -- where internal (ics,i) = text " -- ignoresectcontents ics <+> -- text "]]>" <+> ignore i reference :: Reference -> ByteString reference (RefEntity er) = entityref er reference (RefChar cr) = charref cr entityref :: [Char] -> ByteString entityref n = text "&" <> text n <> text ";" charref :: (Show a) => a -> ByteString charref c = text "&#" <> text (show c) <> text ";" entitydecl :: EntityDecl -> ByteString entitydecl (EntityGEDecl d) = gedecl d entitydecl (EntityPEDecl d) = pedecl d gedecl :: GEDecl -> ByteString gedecl (GEDecl n ed) = text " text n <+> entitydef ed <> text ">" pedecl :: PEDecl -> ByteString pedecl (PEDecl n pd) = text " text n <+> pedef pd <> text ">" entitydef :: EntityDef -> ByteString entitydef (DefEntityValue ew) = entityvalue ew entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd pedef :: PEDef -> ByteString pedef (PEDefEntityValue ew) = entityvalue ew pedef (PEDefExternalID eid) = externalid eid externalid :: ExternalID -> ByteString externalid (SYSTEM sl) = text "SYSTEM" <+> systemliteral sl externalid (PUBLIC i sl) = text "PUBLIC" <+> pubidliteral i <+> systemliteral sl ndatadecl :: NDataDecl -> ByteString ndatadecl (NDATA n) = text "NDATA" <+> text n -- _ (TextDecl vi ed) = text " maybe text vi <+> -- encodingdecl ed <> text "?>" -- extparsedent :: ExtParsedEnt t -> ByteString -- _ (ExtParsedEnt t c)= maybe textdecl t <+> content c -- _ (ExtPE t esd) = maybe textdecl t <+> -- vcat (Prelude.map extsubsetdecl esd) notationdecl :: NotationDecl -> ByteString notationdecl (NOTATION n e) = text " text n <+> either externalid publicid e <> text ">" publicid :: PublicID -> ByteString publicid (PUBLICID p) = text "PUBLICID" <+> pubidliteral p encodingdecl :: EncodingDecl -> ByteString encodingdecl (EncodingDecl s) = text "encoding='" <> text s <> text "'" nmtoken :: [Char] -> ByteString nmtoken s = text s attvalue :: AttValue -> ByteString attvalue (AttValue esr) = text "\"" <> hcat (Prelude.map (either text reference) esr) <> text "\"" entityvalue :: EntityValue -> ByteString entityvalue (EntityValue evs) | containsDoubleQuote evs = text "'" <> hcat (Prelude.map ev evs) <> text "'" | otherwise = text "\"" <> hcat (Prelude.map ev evs) <> text "\"" ev :: EV -> ByteString ev (EVString s) = text s --ev (EVPERef p e) = peref p ev (EVRef r) = reference r pubidliteral :: PubidLiteral -> ByteString pubidliteral (PubidLiteral s) | toWord8 '"' `elem` (pack s) = text "'" <> text s <> text "'" | otherwise = text "\"" <> text s <> text "\"" systemliteral :: SystemLiteral -> ByteString systemliteral (SystemLiteral s) | toWord8 '"' `elem` (pack s) = text "'" <> text s <> text "'" | otherwise = text "\"" <> text s <> text "\"" chardata, cdsect :: [Char] -> ByteString chardata s = {-if all isSpace s then empty else-} text s cdsect c = text " chardata c <> text "]]>" qname n = text (printableName n) -- toWord8 :: Char -> Word8 toWord8 :: (Enum a, Enum a1) => a1 -> a toWord8 = toEnum . fromEnum containsDoubleQuote :: [EV] -> Bool containsDoubleQuote evs = any csq evs where csq (EVString s) = toWord8 '"' `elem` (pack s) csq _ = False HaXml-1.23.3/src/Text/XML/HaXml/Combinators.hs0000755000062000006210000003354611767644706020111 0ustar 1341796mkpasswd-------------------------------------------- -- | This module defines the notion of filters and filter combinators -- for processing XML documents. -- -- These XML transformation combinators are described in the paper -- ``Haskell and XML: Generic Combinators or Type-Based Translation?'' -- Malcolm Wallace and Colin Runciman, Proceedings ICFP'99. -------------------------------------------- module Text.XML.HaXml.Combinators (-- * The content filter type. CFilter -- * Simple filters. -- ** Selection filters. -- $selection , keep, none, children, childrenBy, position -- ** Predicate filters. -- $pred , elm, txt, tag, attr, attrval, tagWith -- ** Search filters. , find, iffind, ifTxt -- * Filter combinators -- ** Basic combinators. , o, union, cat, andThen , (|>|), with, without , (/>), () -- * Filters with labelled results. , LabelFilter -- ** Using and combining labelled filters. , oo, x -- ** Some label-generating filters. , numbered, interspersed, tagged, attributed, textlabelled, extracted ) where import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces import Data.Maybe (fromMaybe) infixl 6 `with`, `without` infixr 5 `o`, `oo`, `union`, `andThen` -- , `orelse` infixl 5 />, | infixr 4 `when`, `guards` infixr 3 ?>, :> -- THE CONTENT FILTER TYPE -- | All document transformations are /content filters/. -- A filter takes a single XML 'Content' value and returns a sequence -- of 'Content' values, possibly empty. type CFilter i = Content i -> [Content i] -- BASIC SELECTION FILTERS -- $selection -- In the algebra of combinators, @none@ is the zero, and @keep@ the identity. -- (They have a more general type than just CFilter.) keep :: a->[a] keep = \x->[x] none :: a->[b] none = \x->[] -- | Throw away current node, keep just the (unprocessed) children. children :: CFilter i children (CElem (Elem _ _ cs) _) = cs children _ = [] -- | Select the @n@'th positional result of a filter. position :: Int -> CFilter i -> CFilter i position n f = (\cs-> [cs!!n]) . f -- BASIC PREDICATE FILTERS -- $pred -- These filters either keep or throw away some content based on -- a simple test. For instance, @elm@ keeps only a tagged element, -- @txt@ keeps only non-element text, @tag@ keeps only an element -- with the named tag, @attr@ keeps only an element with the named -- attribute, @attrval@ keeps only an element with the given -- attribute value, @tagWith@ keeps only an element whose tag name -- satisfies the given predicate. elm, txt :: CFilter i tag :: String -> CFilter i attr :: String -> CFilter i attrval :: Attribute -> CFilter i tagWith :: (String->Bool) -> CFilter i elm x@(CElem _ _) = [x] elm _ = [] txt x@(CString _ _ _) = [x] txt x@(CRef _ _) = [x] txt _ = [] tag t x@(CElem (Elem n _ _) _) | t==printableName n = [x] tag _ _ = [] tagWith p x@(CElem (Elem n _ _) _) | p (printableName n) = [x] tagWith _ _ = [] attr n x@(CElem (Elem _ as _) _) | n `elem` (map (printableName.fst) as) = [x] attr _ _ = [] attrval av x@(CElem (Elem _ as _) _) | av `elem` as = [x] attrval _ _ = [] -- SEARCH FILTERS -- | For a mandatory attribute field, @find key cont@ looks up the value of -- the attribute name @key@, and applies the continuation @cont@ to -- the value. find :: String -> (String->CFilter i) -> CFilter i find key cont c@(CElem (Elem _ as _) _) = cont (show (lookfor (N key) as)) c where lookfor x = fromMaybe (error ("missing attribute: "++key)) . lookup x -- 'lookfor' has the more general type :: (Eq a,Show a) => a -> [(a,b)] -> b -- | When an attribute field may be absent, use @iffind key yes no@ to lookup -- its value. If the attribute is absent, it acts as the @no@ filter, -- otherwise it applies the @yes@ filter. iffind :: String -> (String->CFilter i) -> CFilter i -> CFilter i iffind key yes no c@(CElem (Elem _ as _) _) = case (lookup (N key) as) of Nothing -> no c (Just v@(AttValue _)) -> yes (show v) c iffind _key _yes no other = no other -- | @ifTxt yes no@ processes any textual content with the @yes@ filter, -- but otherwise is the same as the @no@ filter. ifTxt :: (String->CFilter i) -> CFilter i -> CFilter i ifTxt yes _no c@(CString _ s _) = yes s c ifTxt _yes no c = no c -- C-LIKE CONDITIONALS -- -- $cond -- These definitions provide C-like conditionals, lifted to the filter level. -- -- The @(cond ? yes : no)@ style in C becomes @(cond ?> yes :> no)@ in Haskell. -- | Conjoin the two branches of a conditional. data ThenElse a = a :> a -- | Select between the two branches of a joined conditional. (?>) :: (a->[b]) -> ThenElse (a->[b]) -> (a->[b]) p ?> (f :> g) = \c-> if (not.null.p) c then f c else g c -- FILTER COMBINATORS -- | Sequential (/Irish/,/backwards/) composition o :: CFilter i -> CFilter i -> CFilter i f `o` g = concatMap f . g -- | Binary parallel composition. Each filter uses a copy of the input, -- rather than one filter using the result of the other. -- (Has a more general type than just CFilter.) union :: (a->[b]) -> (a->[b]) -> (a->[b]) union = lift (++) -- in Haskell 98: union = lift List.union where lift :: (a->b->d) -> (c->a) -> (c->b) -> c -> d lift f g h = \x-> f (g x) (h x) -- | Glue a list of filters together. (A list version of union; -- also has a more general type than just CFilter.) cat :: [a->[b]] -> (a->[b]) -- Specification: cat fs = \e-> concat [ f e | f <- fs ] -- more efficient implementation below: cat [] = const [] cat fs = foldr1 union fs -- | A special form of filter composition where the second filter -- works over the same data as the first, but also uses the -- first's result. andThen :: (a->c) -> (c->a->b) -> (a->b) andThen f g = \x-> g (f x) x -- lift g f id -- | Process children using specified filters. childrenBy :: CFilter i -> CFilter i childrenBy f = f `o` children -- | Directional choice: -- in @f |>| g@ give g-productions only if no f-productions (|>|) :: (a->[b]) -> (a->[b]) -> (a->[b]) f |>| g = \x-> let fx = f x in if null fx then g x else fx -- f |>| g = f ?> f :> g -- | Pruning: in @f `with` g@, -- keep only those f-productions which have at least one g-production with :: CFilter i -> CFilter i -> CFilter i f `with` g = filter (not.null.g) . f -- | Pruning: in @f `without` g@, -- keep only those f-productions which have no g-productions without :: CFilter i -> CFilter i -> CFilter i f `without` g = filter (null.g) . f -- | Pronounced /slash/, @f \/> g@ means g inside f (/>) :: CFilter i -> CFilter i -> CFilter i f /> g = g `o` children `o` f -- | Pronounced /outside/, @f \<\/ g@ means f containing g ( CFilter i -> CFilter i f CFilter i) -> CFilter i -> CFilter i et f g = (f `oo` tagged elm) |>| (g `o` txt) -- | Express a list of filters like an XPath query, e.g. -- @path [children, tag \"name1\", attr \"attr1\", children, tag \"name2\"]@ -- is like the XPath query @\/name1[\@attr1]\/name2@. path :: [CFilter i] -> CFilter i path fs = foldr (flip (o)) keep fs -- RECURSIVE SEARCH -- $recursive -- Recursive search has three variants: @deep@ does a breadth-first -- search of the tree, @deepest@ does a depth-first search, @multi@ returns -- content at all tree-levels, even those strictly contained within results -- that have already been returned. deep, deepest, multi :: CFilter i -> CFilter i deep f = f |>| (deep f `o` children) deepest f = (deepest f `o` children) |>| f multi f = f `union` (multi f `o` children) -- | Interior editing: -- @f `when` g@ applies @f@ only when the predicate @g@ succeeds, -- otherwise the content is unchanged. when :: CFilter i -> CFilter i -> CFilter i -- | Interior editing: -- @g `guards` f@ applies @f@ only when the predicate @g@ succeeds, -- otherwise the content is discarded. guards :: CFilter i -> CFilter i -> CFilter i f `when` g = g ?> f :> keep g `guards` f = g ?> f :> none -- = f `o` (keep `with` g) -- | Process CHildren In Place. The filter is applied to any children -- of an element content, and the element rebuilt around the results. chip :: CFilter i -> CFilter i chip f (CElem (Elem n as cs) i) = [ CElem (Elem n as (concatMap f cs)) i ] chip _f c = [c] -- chip f = inplace (f `o` children) -- | Process an element In Place. The filter is applied to the element -- itself, and then the original element rebuilt around the results. inplace :: CFilter i -> CFilter i inplace f c@(CElem (Elem name as _) i) = [ CElem (Elem name as (f c)) i ] inplace _f c = [c] -- | Recursive application of filters: a fold-like operator. Defined -- as @f `o` chip (foldXml f)@. foldXml :: CFilter i -> CFilter i foldXml f = f `o` chip (foldXml f) -- CONSTRUCTIVE CONTENT FILTERS -- | Build an element with the given tag name - its content is the results -- of the given list of filters. mkElem :: String -> [CFilter i] -> CFilter i mkElem h cfs = \t-> [ CElem (Elem (N h) [] (cat cfs t)) undefined ] -- | Build an element with the given name, attributes, and content. mkElemAttr :: String -> [(String,CFilter i)] -> [CFilter i] -> CFilter i mkElemAttr h as cfs = \t-> [ CElem (Elem (N h) (map (attr t) as) (cat cfs t)) undefined ] where attr t (n,vf) = let v = concat [ s | (CString _ s _) <- (deep txt `o` vf) t ] in (N n, AttValue [Left v]) -- | Build some textual content. literal :: String -> CFilter i literal s = const [CString False s undefined] -- | Build some CDATA content. cdata :: String -> CFilter i cdata s = const [CString True s undefined] -- | Rename an element tag (leaving attributes in place). replaceTag :: String -> CFilter i replaceTag n (CElem (Elem _ as cs) i) = [CElem (Elem (N n) as cs) i] replaceTag _ _ = [] -- | Replace the attributes of an element (leaving tag the same). replaceAttrs :: [(String,String)] -> CFilter i replaceAttrs as (CElem (Elem n _ cs) i) = [CElem (Elem n as' cs) i] where as' = map (\(n,v)-> (N n, AttValue [Left v])) as replaceAttrs _ _ = [] -- LABELLING -- | A LabelFilter is like a CFilter except that it pairs up a polymorphic -- value (label) with each of its results. type LabelFilter i a = Content i -> [(a,Content i)] -- | Compose a label-processing filter with a label-generating filter. oo :: (a->CFilter i) -> LabelFilter i a -> CFilter i f `oo` g = concatMap (uncurry f) . g {- -- | Process the information labels (very nearly monadic bind). oo :: (b -> CFilter b c) -> CFilter a b -> CFilter a c f `oo` g = concatMap info . g where info c@(CElem _ i) = f i c info c@(CString _ _ i) = f i c info c@(CRef _ i) = f i c info c = [c] -} -- | Combine labels. Think of this as a pair-wise zip on labels. -- e.g. @(numbered `x` tagged)@ x :: (CFilter i->LabelFilter i a) -> (CFilter i->LabelFilter i b) -> (CFilter i->LabelFilter i (a,b)) f `x` g = \cf c-> let gs = map fst (g cf c) fs = map fst (f cf c) in zip (zip fs gs) (cf c) -- Some basic label-generating filters. -- | Number the results from 1 upwards. numbered :: CFilter i -> LabelFilter i Int numbered f = zip [1..] . f -- | In @interspersed a f b@, label each result of @f@ with the string @a@, -- except for the last one which is labelled with the string @b@. interspersed :: String -> CFilter i -> String -> LabelFilter i String interspersed a f b = (\xs-> zip (replicate (len xs) a ++ [b]) xs) . f where len [] = 0 len xs = length xs - 1 -- | Label each element in the result with its tag name. Non-element -- results get an empty string label. tagged :: CFilter i -> LabelFilter i String tagged f = extracted name f where name (CElem (Elem n _ _) _) = printableName n name _ = "" -- | Label each element in the result with the value of the named attribute. -- Elements without the attribute, and non-element results, get an -- empty string label. attributed :: String -> CFilter i -> LabelFilter i String attributed key f = extracted att f where att (CElem (Elem _ as _) _) = case (lookup (N key) as) of Nothing -> "" (Just v@(AttValue _)) -> show v att _ = "" -- | Label each textual part of the result with its text. Element -- results get an empty string label. textlabelled :: CFilter i -> LabelFilter i (Maybe String) textlabelled f = extracted text f where text (CString _ s _) = Just s text _ = Nothing -- | Label each content with some information extracted from itself. extracted :: (Content i->a) -> CFilter i -> LabelFilter i a extracted proj f = concatMap (\c->[(proj c, c)]) . f {- -- MISC -- | I haven't yet remembered \/ worked out what this does. combine :: (Read a,Show a) => ([a]->a) -> LabelFilter String -> CFilter combine f lf = \c-> [ CString False (show (f [ read l | (l,_) <- lf c ])) ] -} {- OLD STUFF - OBSOLETE -- Keep an element by its numbered position (starting at 1). position :: Int -> [Content] -> [Content] position n | n>0 = (:[]) . (!!(n-1)) | otherwise = const [] -- Chop and remove the root portions of trees to depth n. layer :: Int -> [Content] -> [Content] layer n = apply n (concatMap lay) where lay (CElem (Elem _ _ cs)) = cs lay _ = [] apply 0 f xs = xs apply n f xs = apply (n-1) f (f xs) combine :: (Read a, Show a) => ([a]->a) -> [Content] -> [Content] combine f = \cs-> [ CString False (show (f [ read s | CString _ s <- cs ])) ] -} HaXml-1.23.3/src/Text/XML/HaXml/DtdToHaskell/0000755000062000006210000000000011767644706017601 5ustar 1341796mkpasswdHaXml-1.23.3/src/Text/XML/HaXml/DtdToHaskell/Convert.hs0000755000062000006210000001311311767644706021557 0ustar 1341796mkpasswd-- | This module performs the translation of a parsed XML DTD into the -- internal representation of corresponding Haskell data\/newtypes. -- -- Note that dtdToTypeDef is partial - it will crash if you resolve -- qualified names (namespaces) to URIs beforehand. It will only work -- on the original literal name forms "prefix:name". module Text.XML.HaXml.DtdToHaskell.Convert ( dtd2TypeDef ) where import Data.List (intersperse,nub) import Text.XML.HaXml.Types hiding (Name) import Text.XML.HaXml.DtdToHaskell.TypeDef ---- Internal representation for database of DTD decls ---- data Record = R [AttDef] ContentSpec -- type Db = [(QName,Record)] ---- Build a database of DTD decls then convert them to typedefs ---- ---- (Done in two steps because we need to merge ELEMENT and ATTLIST decls.) ---- Apparently multiple ATTLIST decls for the same element are permitted, ---- although only one ELEMENT decl for it is allowed. dtd2TypeDef :: [MarkupDecl] -> [TypeDef] dtd2TypeDef mds = (concatMap convert . reverse . database []) mds where database db [] = db database db (m:ms) = case m of (Element (ElementDecl n cs)) -> case lookup n db of Nothing -> database ((n, R [] cs):db) ms (Just (R as _)) -> database (replace n (R as cs) db) ms (AttList (AttListDecl n as)) -> case lookup n db of Nothing -> database ((n, R as EMPTY):db) ms (Just (R a cs)) -> database (replace n (R (nub (a++as)) cs) db) ms -- (MarkupPE _ m') -> database db (m':ms) _ -> database db ms replace _ _ [] = error "dtd2TypeDef.replace: no element to replace" replace n v (x@(n0,_):db) | n==n0 = (n,v): db | otherwise = x: replace n v db ---- Convert DTD record to typedef ---- convert :: (QName, Record) -> [TypeDef] convert (N n, R as cs) = case cs of EMPTY -> modifier None [] ANY -> modifier None [[Any]] --error "NYI: contentspec of ANY" (Mixed PCDATA) -> modifier None [[String]] (Mixed (PCDATAplus ns)) -> modifier Star ([StringMixed] : map ((:[]) . Defined . name . \(N n)->n) ns) (ContentSpec cp) -> case cp of (TagName (N n') m) -> modifier m [[Defined (name n')]] (Choice cps m) -> modifier m (map ((:[]).inner) cps) (Seq cps m) -> modifier m [map inner cps] ++ concatMap (mkAttrDef (N n)) as where attrs :: AttrFields attrs = map (mkAttrField (N n)) as modifier None sts = mkData sts attrs False (name n) modifier m [[st]] = mkData [[modf m st]] attrs False (name n) modifier m sts = mkData [[modf m (Defined (name_ n))]] attrs False (name n) ++ mkData sts [] True (name_ n) inner :: CP -> StructType inner (TagName (N n') m) = modf m (Defined (name n')) inner (Choice cps m) = modf m (OneOf (map inner cps)) inner (Seq cps None) = Tuple (map inner cps) inner (Seq cps m) = modf m (Tuple (map inner cps)) modf None x = x modf Query x = Maybe x modf Star x = List x modf Plus x = List1 x mkData :: [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef] mkData [] fs aux n = [DataDef aux n fs []] mkData [ts] fs aux n = [DataDef aux n fs [(n, ts)]] mkData tss fs aux n = [DataDef aux n fs (map (mkConstr n) tss)] where mkConstr m ts = (mkConsName m ts, ts) mkConsName (Name x m) sts = Name x (m++concat (intersperse "_" (map flatten sts))) flatten (Maybe st) = {-"Maybe_" ++ -} flatten st flatten (List st) = {-"List_" ++ -} flatten st flatten (List1 st) = {-"List1_" ++ -} flatten st flatten (Tuple sts) = {-"Tuple" ++ show (length sts) ++ "_" ++ -} concat (intersperse "_" (map flatten sts)) flatten StringMixed = "Str" flatten String = "Str" flatten (OneOf sts) = {-"OneOf" ++ show (length sts) ++ "_" ++ -} concat (intersperse "_" (map flatten sts)) flatten Any = "Any" flatten (Defined (Name _ m)) = m mkAttrDef :: QName -> AttDef -> [TypeDef] mkAttrDef _ (AttDef _ StringType _) = [] mkAttrDef _ (AttDef _ (TokenizedType _) _) = [] -- mkData [[String]] [] False (name n) mkAttrDef (N e) (AttDef (N n) (EnumeratedType (NotationType nt)) _) = [EnumDef (name_a e n) (map (name_ac e n) nt)] mkAttrDef (N e) (AttDef (N n) (EnumeratedType (Enumeration es)) _) = [EnumDef (name_a e n) (map (name_ac e n) es)] -- Default attribute values not handled here mkAttrField :: QName -> AttDef -> (Name,StructType) mkAttrField (N e) (AttDef (N n) typ req) = (name_f e n, mkType typ req) where mkType StringType REQUIRED = String mkType StringType IMPLIED = Maybe String mkType StringType (DefaultTo v@(AttValue _) _) = Defaultable String (show v) mkType (TokenizedType _) REQUIRED = String mkType (TokenizedType _) IMPLIED = Maybe String mkType (TokenizedType _) (DefaultTo v@(AttValue _) _) = Defaultable String (show v) mkType (EnumeratedType _) REQUIRED = Defined (name_a e n) mkType (EnumeratedType _) IMPLIED = Maybe (Defined (name_a e n)) mkType (EnumeratedType _) (DefaultTo v@(AttValue _) _) = Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v))) HaXml-1.23.3/src/Text/XML/HaXml/DtdToHaskell/Instance.hs0000755000062000006210000004104411767644706021707 0ustar 1341796mkpasswdmodule Text.XML.HaXml.DtdToHaskell.Instance ( mkInstance ) where import Data.List (intersperse) import Text.XML.HaXml.DtdToHaskell.TypeDef import Text.PrettyPrint.HughesPJ -- | Convert typedef to appropriate instance declaration, either @XmlContent@, -- @XmlAttributes@, or @XmlAttrType@. mkInstance :: TypeDef -> Doc -- no constructors - represents an element with empty content but attributes. mkInstance (DataDef _ n fs []) = let (_, frattr, topat, toattr) = attrpats fs frretval = if null fs then ppHName n else frattr topatval = if null fs then ppHName n else topat in text "instance HTypeable" <+> ppHName n <+> text "where" $$ nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" ) $$ text "instance XmlContent" <+> ppHName n <+> text "where" $$ nest 4 ( text "toContents" <+> topatval <+> text "=" $$ nest 4 (text "[CElem (Elem (N \"" <> ppXName n <> text "\")" <+> toattr <+> text "[]) ()]") $$ text "parseContents = do" $$ nest 4 (text "{ (Elem _ as []) <- element [\"" <> ppXName n <> text "\"]" $$ text "; return" <+> frretval $$ text "} `adjustErr` (\"in <" <> ppXName n <> text ">, \"++)" ) ) $$ mkInstanceAttrs Same n fs -- single constructor, "real" (non-auxiliary) type mkInstance (DataDef False n fs [(n0,sts)]) = let vs = nameSupply sts (frpat, frattr, topat, toattr) = attrpats fs in text "instance HTypeable" <+> ppHName n <+> text "where" $$ nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" ) $$ text "instance XmlContent" <+> ppHName n <+> text "where" $$ nest 4 ( text "toContents" <+> parens (mkCpat n0 topat vs) <+> text "=" $$ nest 4 (text "[CElem (Elem (N \"" <> ppXName n <> text "\")" <+> toattr <+> parens (mkToElem sts vs) <> text ") ()]") $$ text "parseContents = do" $$ nest 4 (text "{ e@(Elem _"<+> frpat <+> text "_) <- element [\"" <> ppXName n <> text "\"]" $$ text "; interior e $" <+> (mkParseConstr frattr (n0,sts)) $$ text "} `adjustErr` (\"in <" <> ppXName n <> text ">, \"++)") ) $$ mkInstanceAttrs Extended n fs -- single constructor, auxiliary type (i.e. no corresponding element tag) -- cannot be attributes here? mkInstance (DataDef True n [] [(n0,sts)]) = let vs = nameSupply sts in text "instance HTypeable" <+> ppHName n <+> text "where" $$ nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" ) $$ text "instance XmlContent" <+> ppHName n <+> text "where" $$ nest 4 ( text "toContents" <+> parens (mkCpat n0 empty vs) <+> text "=" $$ nest 4 (parens (mkToElem sts vs)) $$ text "parseContents =" <+> mkParseConstr empty (n0,sts) ) -- multiple constructors (real) mkInstance (DataDef False n fs cs) = let _ = nameSupply cs (frpat, frattr, topat, toattr) = attrpats fs _ = if null fs then False else True in text "instance HTypeable" <+> ppHName n <+> text "where" $$ nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" ) $$ text "instance XmlContent" <+> ppHName n <+> text "where" $$ nest 4 ( vcat (map (mkToMult n topat toattr) cs) $$ text "parseContents = do " $$ nest 4 (text "{ e@(Elem _"<+> frpat <+> text "_) <- element [\"" <> ppXName n <> text "\"]" $$ text "; interior e $ oneOf" $$ nest 4 ( text "[" <+> mkParseConstr frattr (head cs) $$ vcat (map (\c-> text "," <+> mkParseConstr frattr c) (tail cs)) $$ text "] `adjustErr` (\"in <" <> ppXName n <> text ">, \"++)" ) $$ text "}" ) ) $$ mkInstanceAttrs Extended n fs -- multiple constructors (auxiliary) mkInstance (DataDef True n fs cs) = let _ = nameSupply cs (_, frattr, _, _) = attrpats fs mixattrs = if null fs then False else True in text "instance HTypeable" <+> ppHName n <+> text "where" $$ nest 4 ( text "toHType x = Defined \"" <> ppXName n <> text "\" [] []" ) $$ text "instance XmlContent" <+> ppHName n <+> text "where" $$ nest 4 ( vcat (map (mkToAux mixattrs) cs) $$ text "parseContents = oneOf" $$ nest 4 ( text "[" <+> mkParseConstr frattr (head cs) $$ vcat (map (\c-> text "," <+> mkParseConstr frattr c) (tail cs)) $$ text "] `adjustErr` (\"in <" <> ppXName n <> text ">, \"++)" ) ) $$ mkInstanceAttrs Extended n fs -- enumeration of attribute values mkInstance (EnumDef n es) = text "instance XmlAttrType" <+> ppHName n <+> text "where" $$ nest 4 ( text "fromAttrToTyp n (N n',v)" $$ nest 4 (text "| n==n' = translate (attr2str v)" $$ text "| otherwise = Nothing") $$ nest 2 (text "where" <+> mkTranslate es) $$ vcat (map mkToAttr es) ) data SameName = Same | Extended mkInstanceAttrs :: SameName -> Name -> AttrFields -> Doc mkInstanceAttrs _ _ [] = empty mkInstanceAttrs s n fs = let ppName = case s of { Same-> ppHName; Extended-> ppAName; } in text "instance XmlAttributes" <+> ppName n <+> text "where" $$ nest 4 ( text "fromAttrs as =" $$ nest 4 ( ppName n $$ nest 2 (vcat ((text "{" <+> mkFrFld n (head fs)): map (\x-> comma <+> mkFrFld n x) (tail fs)) $$ text "}")) $$ text "toAttrs v = catMaybes " $$ nest 4 (vcat ((text "[" <+> mkToFld (head fs)): map (\x-> comma <+> mkToFld x) (tail fs)) $$ text "]") ) -- respectively (frpat,frattr,topat,toattr) attrpats :: AttrFields -> (Doc,Doc,Doc,Doc) attrpats fs = if null fs then (text "[]", empty, empty, text "[]") else (text "as", parens (text "fromAttrs as"), text "as", parens (text "toAttrs as")) -- mkFrElem :: Name -> [StructType] -> [Doc] -> Doc -> Doc -- mkFrElem n sts vs inner = -- foldr (frElem n) inner (zip3 sts vs cvs) -- where -- cvs = let ns = nameSupply2 vs -- in zip ns (text "c0": init ns) -- frElem _ (st,v,(cvi,cvo)) inner = -- parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$ -- nest 2 inner) $$ -- parens ( -- case st of -- (Maybe String) -> text "fromText" <+> cvo -- (Maybe _) -> text "fromElem" <+> cvo -- (List String) -> text "many fromText" <+> cvo -- (List _) -> text "many fromElem" <+> cvo -- (List1 s) -> text "definite fromElem" -- <+> text "\"" <> text (show s)<> text "+\"" -- <+> text "\"" <> ppXName n <> text "\"" -- <+> cvo -- (Tuple ss) -> text "definite fromElem" -- <+> text "\"(" <> hcat (intersperse (text ",") -- (map (text.show) ss)) -- <> text ")\"" -- <+> text "\"" <> ppXName n <> text "\"" -- <+> cvo -- (OneOf _) -> text "definite fromElem" -- <+> text "\"OneOf\"" -- <+> text "\"" <> ppXName n <> text "\"" -- <+> cvo -- (String) -> text "definite fromText" <+> text "\"text\" \"" <> -- ppXName n <> text "\"" <+> cvo -- (Any) -> text "definite fromElem" <+> text "\"ANY\" \"" <> -- ppXName n <> text "\"" <+> cvo -- (Defined m) -> text "definite fromElem" <+> -- text "\"<" <> ppXName m <> text ">\" \"" <> -- ppXName m <> text "\"" <+> cvo -- (Defaultable _ _) -> text "nyi_fromElem_Defaultable" <+> cvo -- ) -- {- mkParseContents :: Name -> [StructType] -> [Doc] -> Doc -> Doc mkParseContents n sts vs inner = foldr (frElem n) inner (zip3 sts vs cvs) where cvs = let ns = nameSupply2 vs in zip ns (text "c0": init ns) frElem n (st,v,(cvi,cvo)) inner = parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$ nest 2 inner) $$ parens ( ) -} mkParseConstr :: Doc -> (Name, [StructType]) -> Doc mkParseConstr frattr (c,sts) = fsep (text "return" <+> parens (ppHName c <+> frattr) : map mkParseContents sts) mkParseContents :: StructType -> Doc mkParseContents st = let ap = text "`apply`" in case st of (Maybe String) -> ap <+> text "optional text" (Maybe _) -> ap <+> text "optional parseContents" (List String) -> ap <+> text "many text" (List _) -> ap <+> text "many parseContents" (List1 _) -> ap <+> text "parseContents" (Tuple _) -> ap <+> text "parseContents" (OneOf _) -> ap <+> text "parseContents" (StringMixed) -> ap <+> text "text" (String) -> ap <+> text "(text `onFail` return \"\")" (Any) -> ap <+> text "parseContents" (Defined _) -> ap <+> text "parseContents" (Defaultable _ _) -> ap <+> text "nyi_fromElem_Defaultable" -- mkToElem :: [StructType] -> [Doc] -> Doc mkToElem [] [] = text "[]" mkToElem sts vs = fsep (intersperse (text "++") (zipWith toElem sts vs)) where toElem st v = case st of (Maybe String) -> text "maybe [] toText" <+> v (Maybe _) -> text "maybe [] toContents" <+> v (List String) -> text "concatMap toText" <+> v (List _) -> text "concatMap toContents" <+> v (List1 _) -> text "toContents" <+> v (Tuple _) -> text "toContents" <+> v (OneOf _) -> text "toContents" <+> v (StringMixed) -> text "toText" <+> v (String) -> text "toText" <+> v (Any) -> text "toContents" <+> v (Defined _) -> text "toContents" <+> v (Defaultable _ _) -> text "nyi_toElem_Defaultable" <+> v -- mkRpat :: [Doc] -> Doc -- mkRpat [v] = v -- mkRpat vs = (parens . hcat . intersperse comma) vs mkCpat :: Name -> Doc -> [Doc] -> Doc mkCpat n i vs = ppHName n <+> i <+> fsep vs nameSupply :: [b] -> [Doc] nameSupply ss = take (length ss) (map char ['a'..'z'] ++ map text [ a:n:[] | n <- ['0'..'9'] , a <- ['a'..'z'] ]) -- nameSupply2 ss = take (length ss) [ text ('c':v:[]) | v <- ['a'..]] mkTranslate :: [Name] -> Doc mkTranslate es = vcat (map trans es) $$ text "translate _ = Nothing" where trans n = text "translate \"" <> ppXName n <> text "\" =" <+> text "Just" <+> ppHName n mkToAttr :: Name -> Doc mkToAttr n = text "toAttrFrTyp n" <+> ppHName n <+> text "=" <+> text "Just (N n, str2attr" <+> doubleQuotes (ppXName n) <> text ")" mkFrFld :: Name -> (Name,StructType) -> Doc mkFrFld tag (n,st) = ppHName n <+> text "=" <+> ( case st of (Defaultable String s) -> text "defaultA fromAttrToStr" <+> doubleQuotes (text s) (Defaultable _ s) -> text "defaultA fromAttrToTyp" <+> text s (Maybe String) -> text "possibleA fromAttrToStr" (Maybe _) -> text "possibleA fromAttrToTyp" String -> text "definiteA fromAttrToStr" <+> doubleQuotes (ppXName tag) _ -> text "definiteA fromAttrToTyp" <+> doubleQuotes (ppXName tag) ) <+> doubleQuotes (ppXName n) <+> text "as" mkToFld :: (Name,StructType) -> Doc mkToFld (n,st) = ( case st of (Defaultable String _) -> text "defaultToAttr toAttrFrStr" (Defaultable _ _) -> text "defaultToAttr toAttrFrTyp" (Maybe String) -> text "maybeToAttr toAttrFrStr" (Maybe _) -> text "maybeToAttr toAttrFrTyp" String -> text "toAttrFrStr" _ -> text "toAttrFrTyp" ) <+> doubleQuotes (ppXName n) <+> parens (ppHName n <+> text "v") -- mkFrAux :: Bool -> Doc -> [(Name,[StructType])] -> Doc -- mkFrAux keeprest attrs cs = foldr frAux inner cs -- where -- inner = text "(Nothing, c0)" -- rest = if keeprest then text "rest" else text "_" -- frAux (n,sts) innr = -- let vs = nameSupply sts in -- nest 4 (text "case" <+> blah sts vs <+> text "of" $$ -- succpat sts vs <+> text "-> (Just" <+> -- parens (mkCpat n attrs vs) <> text ", rest)" -- $$ -- failpat sts <+> text "->" $$ nest 4 innr -- ) -- blah [st] [_] = -- blahblahblah st (text "c0") -- blah sts vs = -- let ns = nameSupply2 vs -- cvs = zip ns (text "c0": init ns) -- blahblah (st,v,(cvi,cvo)) innr = -- parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$ -- nest 2 innr) $$ -- blahblahblah st cvo -- in -- foldr blahblah (mkRpat (vs++[last ns])) (zip3 sts vs cvs) -- blahblahblah st cvo = parens ( -- case st of -- (Maybe String) -> text "fromText" <+> cvo -- (Maybe _) -> text "fromElem" <+> cvo -- (List String) -> text "many fromText" <+> cvo -- (List _) -> text "many fromElem" <+> cvo -- (List1 _) -> text "fromElem" <+> cvo -- (Tuple _) -> text "fromElem" <+> cvo -- ?? -- (OneOf _) -> text "fromElem" <+> cvo -- (String) -> text "fromText" <+> cvo -- (Any) -> text "fromElem" <+> cvo -- (Defined _) -> text "fromElem" <+> cvo -- ) -- failpat sts = -- let fp st = -- case st of -- (Maybe _) -> text "Nothing" -- (List _) -> text "[]" -- (List1 _) -> text "_" -- (Tuple _) -> text "_" -- (OneOf _) -> text "_" -- (String) -> text "_" -- (Any) -> text "_" -- (Defined _) -> text "_" -- in parens (hcat (intersperse comma (map fp sts++[text "_"]))) -- succpat sts vs = -- let sp st v = -- case st of -- (Maybe _) -> v -- (List _) -> v -- (List1 _) -> text "Just" <+> v -- (Tuple _) -> text "Just" <+> v -- (OneOf _) -> text "Just" <+> v -- (String) -> text "Just" <+> v -- (Any) -> text "Just" <+> v -- (Defined _) -> text "Just" <+> v -- in parens (hcat (intersperse comma (zipWith sp sts vs++[rest]))) mkToAux :: Bool -> (Name,[StructType]) -> Doc mkToAux mixattrs (n,sts) = let vs = nameSupply sts attrs = if mixattrs then text "as" else empty in text "toContents" <+> parens (mkCpat n attrs vs) <+> text "=" <+> mkToElem sts vs mkToMult :: Name -> Doc -> Doc -> (Name,[StructType]) -> Doc mkToMult tag attrpat attrexp (n,sts) = let vs = nameSupply sts in text "toContents" <+> parens (mkCpat n attrpat vs) <+> text "=" $$ nest 4 (text "[CElem (Elem (N \"" <> ppXName tag <> text "\")"<+> attrexp <+> parens (mkToElem sts vs) <+> text ") ()]") HaXml-1.23.3/src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs0000755000062000006210000002104511767644706021502 0ustar 1341796mkpasswd-- | Defines an internal representation of Haskell data\/newtype definitions -- that correspond to the XML DTD types, and provides pretty-printers to -- convert these types into the 'Doc' type of "Text.PrettyPrint.HughesPJ". module Text.XML.HaXml.DtdToHaskell.TypeDef ( -- * Internal representation of types TypeDef(..) , Constructors , AttrFields , StructType(..) -- * Pretty-print a TypeDef , ppTypeDef , ppHName , ppXName , ppAName -- * Name mangling , Name(..) , name, name_, name_a, name_ac, name_f, mangle, manglef ) where import Data.Char (isLower, isUpper, toLower, toUpper, isDigit) import Data.List (intersperse) import Text.PrettyPrint.HughesPJ ---- Internal representation for typedefs ---- -- | Need to keep both the XML and Haskell versions of a name. data Name = Name { xName :: String -- ^ original XML name , hName :: String -- ^ mangled Haskell name } deriving Eq data TypeDef = DataDef Bool Name AttrFields Constructors -- ^ Bool for main\/aux. | EnumDef Name [Name] deriving Eq type Constructors = [(Name,[StructType])] type AttrFields = [(Name, StructType)] data StructType = Maybe StructType | Defaultable StructType String -- ^ String holds default value. | List StructType | List1 StructType -- ^ Non-empty lists. | Tuple [StructType] | OneOf [StructType] | Any -- ^ XML's contentspec allows ANY | StringMixed -- ^ mixed (#PCDATA | ... )* | String -- ^ string only (#PCDATA) | Defined Name deriving Eq -- used for converting StructType (roughly) back to an XML content model instance Show StructType where showsPrec p (Maybe s) = showsPrec (p+1) s . showChar '?' showsPrec _ (Defaultable s _) = shows s showsPrec p (List s) = showsPrec (p+1) s . showChar '*' showsPrec p (List1 s) = showsPrec (p+1) s . showChar '+' showsPrec _ (Tuple ss) = showChar '(' . foldr1 (.) (intersperse (showChar ',') (map shows ss)) . showChar ')' showsPrec _ (OneOf ss) = showChar '(' . foldr1 (.) (intersperse (showChar '|') (map shows ss)) . showChar ')' showsPrec _ (Any) = showString "ANY" showsPrec _ (StringMixed) = showString "#PCDATA" showsPrec _ (String) = showString "#PCDATA" showsPrec _ (Defined (Name n _)) = showString n ---- Pretty-printing typedefs ---- ppTypeDef :: TypeDef -> Doc -- no attrs, no constructors ppTypeDef (DataDef _ n [] []) = let nme = ppHName n in text "data" <+> nme <+> text "=" <+> nme <+> text "\t\t" <> derives -- no attrs, single constructor ppTypeDef (DataDef _ n [] [c@(_,[_])]) = text "newtype" <+> ppHName n <+> text "=" <+> ppC c <+> text "\t\t" <> derives -- no attrs, multiple constrs ppTypeDef (DataDef _ n [] cs) = text "data" <+> ppHName n <+> ( text "=" <+> ppC (head cs) $$ vcat (map (\c-> text "|" <+> ppC c) (tail cs)) $$ derives ) -- nonzero attrs, no constructors ppTypeDef (DataDef _ n fs []) = let nme = ppHName n in text "data" <+> nme <+> text "=" <+> nme $$ nest 4 ( text "{" <+> ppF (head fs) $$ vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$ text "}" <+> derives ) -- nonzero attrs, one or more constrs ppTypeDef (DataDef _ n fs cs) = let attr = ppAName n in text "data" <+> ppHName n <+> ( text "=" <+> ppAC attr (head cs) $$ vcat (map (\c-> text "|" <+> ppAC attr c) (tail cs)) $$ derives ) $$ text "data" <+> attr <+> text "=" <+> attr $$ nest 4 ( text "{" <+> ppF (head fs) $$ vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$ text "}" <+> derives ) -- enumerations (of attribute values) ppTypeDef (EnumDef n es) = text "data" <+> ppHName n <+> ( text "=" <+> fsep (intersperse (text " | ") (map ppHName es)) $$ derives ) ppST :: StructType -> Doc ppST (Defaultable st _) = parens (text "Defaultable" <+> ppST st) ppST (Maybe st) = parens (text "Maybe" <+> ppST st) ppST (List st) = text "[" <> ppST st <> text "]" ppST (List1 st) = parens (text "List1" <+> ppST st) ppST (Tuple sts) = parens (commaList (map ppST sts)) ppST (OneOf sts) = parens (text "OneOf" <> text (show (length sts)) <+> hsep (map ppST sts)) ppST StringMixed= text "String" ppST String = text "String" ppST Any = text "ANYContent" ppST (Defined n) = ppHName n -- constructor and components ppC :: (Name,[StructType]) -> Doc ppC (n,sts) = ppHName n <+> fsep (map ppST sts) -- attribute (fieldname and type) ppF :: (Name,StructType) -> Doc ppF (n,st) = ppHName n <+> text "::" <+> ppST st -- constructor and components with initial attr-type ppAC :: Doc -> (Name,[StructType]) -> Doc ppAC atype (n,sts) = ppHName n <+> fsep (atype: map ppST sts) -- | Pretty print Haskell name. ppHName :: Name -> Doc ppHName (Name _ s) = text s -- | Pretty print XML name. ppXName :: Name -> Doc ppXName (Name s _) = text s -- | Pretty print Haskell attributes name. ppAName :: Name -> Doc ppAName (Name _ s) = text s <> text "_Attrs" derives :: Doc derives = text "deriving" <+> parens (commaList (map text ["Eq","Show"])) ---- Some operations on Names ---- -- | Make a type name valid in both XML and Haskell. name :: String -> Name name n = Name { xName = n , hName = mangle n } -- | Append an underscore to the Haskell version of the name. name_ :: String -> Name name_ n = Name { xName = n , hName = mangle n ++ "_" } -- | Prefix an attribute enumeration type name with its containing element -- name. name_a :: String -> String -> Name name_a e n = Name { xName = n , hName = mangle e ++ "_" ++ map decolonify n } -- | Prefix an attribute enumeration constructor with its element-tag name, -- and its enumeration type name. name_ac :: String -> String -> String -> Name name_ac e t n = Name { xName = n , hName = mangle e ++ "_" ++ map decolonify t ++ "_" ++ map decolonify n } -- | Prefix a field name with its enclosing element name. name_f :: String -> String -> Name name_f e n = Name { xName = n , hName = manglef e ++ mangle n } ---- obsolete -- elementname_at :: String -> Name -- elementname_at n = Name n (mangle n ++ "_Attrs") -- | Convert an XML name to a Haskell conid. mangle :: String -> String mangle (n:ns) | isLower n = notPrelude (toUpper n: map decolonify ns) | isDigit n = 'I': n: map decolonify ns | otherwise = notPrelude (n: map decolonify ns) -- | Ensure a generated name does not conflict with a standard haskell one. notPrelude :: String -> String notPrelude "Bool" = "ABool" notPrelude "Bounded" = "ABounded" notPrelude "Char" = "AChar" notPrelude "Double" = "ADouble" notPrelude "Either" = "AEither" notPrelude "Enum" = "AEnum" notPrelude "Eq" = "AEq" notPrelude "FilePath"= "AFilePath" notPrelude "Float" = "AFloat" notPrelude "Floating"= "AFloating" notPrelude "Fractional"= "AFractional" notPrelude "Functor" = "AFunctor" notPrelude "IO" = "AIO" notPrelude "IOError" = "AIOError" notPrelude "Int" = "AInt" notPrelude "Integer" = "AInteger" notPrelude "Integral"= "AIntegral" notPrelude "List1" = "AList1" -- part of HaXml notPrelude "Maybe" = "AMaybe" notPrelude "Monad" = "AMonad" notPrelude "Num" = "ANum" notPrelude "Ord" = "AOrd" notPrelude "Ordering"= "AOrdering" notPrelude "Rational"= "ARational" notPrelude "Read" = "ARead" notPrelude "ReadS" = "AReadS" notPrelude "Real" = "AReal" notPrelude "RealFloat" = "ARealFloat" notPrelude "RealFrac"= "ARealFrac" notPrelude "Show" = "AShow" notPrelude "ShowS" = "AShowS" notPrelude "String" = "AString" notPrelude n = n -- | Convert an XML name to a Haskell varid. manglef :: String -> String manglef (n:ns) | isUpper n = toLower n: map decolonify ns | isDigit n = '_': n: map decolonify ns | otherwise = n: map decolonify ns -- | Convert colon to prime, hyphen to underscore. decolonify :: Char -> Char decolonify ':' = '\'' -- TODO: turn namespaces into qualified identifiers decolonify '-' = '_' decolonify '.' = '_' decolonify c = c commaList :: [Doc] -> Doc commaList = hcat . intersperse comma HaXml-1.23.3/src/Text/XML/HaXml/Escape.hs0000755000062000006210000002350111767644706017017 0ustar 1341796mkpasswd{- This module contains code for escaping/unescaping text in attributes and elements in the HaXml Element type, replacing characters by character references or vice-versa. Two uses are envisaged for this: (1) stopping HaXml generating incorrect XML when a character is included which is also the appropriate XML terminating character, for example when an attribute includes a double quote. (2) representing XML which contains non-ASCII characters as ASCII. -} module Text.XML.HaXml.Escape( xmlEscape, -- :: XmlEscaper -> Element i -> Element i xmlUnEscape, -- :: XmlEscaper -> Element i -> Element i xmlEscapeContent, -- :: XmlEscaper -> [Content i] -> [Content i] xmlUnEscapeContent, -- :: XmlEscaper -> [Content i] -> [Content i] XmlEscaper, -- Something describing a particular set of escapes. stdXmlEscaper, -- Standard boilerplate escaper, escaping everything that is -- nonprintable, non-ASCII, or might conceivably cause problems by -- parsing XML, for example quotes, < signs, and ampersands. mkXmlEscaper, -- :: [(Char,String)] -> (Char -> Bool) -> XmlEscaper -- The first argument contains a list of characters, with their -- corresponding character reference names. -- For example [('\60',"lt"),('\62',"gt"),('\38',"amp"), -- ('\39',"apos"),('\34',"quot")] will give you the "standard" -- XML escapes listed in section 4.6 of the XML standard, so that -- """ will automatically get translated into a double -- quotation mark. -- -- It's the caller's responsibility to see that the reference -- names ("lt","gt","amp","apos" and "quot" in the above example) -- are valid XML reference names. A sequence of letters, digits, -- "." or ":" characters should be fine so long as the first one -- isn't a digit. -- -- The second argument is a function applied to each text character. -- If it returns True, that means we should escape this character. -- Policy: on escaping, we expand all characters for which the -- (Char -> Bool) function returns True, either giving the corresponding -- character reference name if one was supplied, or else using a -- hexadecimal CharRef. -- -- on unescaping, we translate all the references we understand -- (hexadecimal,decimal, and the ones in the [(Char,String)] list, -- and leave the others alone. ) where import Data.Char -- import Numeric import Text.XML.HaXml.Types #if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__) -- emulate older finite map interface using Data.Map, if it is available import qualified Data.Map as Map type FiniteMap a b = Map.Map a b listToFM :: Ord a => [(a,b)] -> FiniteMap a b listToFM = Map.fromList lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b lookupFM = flip Map.lookup #elif __GLASGOW_HASKELL__ >= 504 || __NHC__ > 114 -- real finite map, if it is available import Data.FiniteMap #else -- otherwise, a very simple and inefficient implementation of a finite map type FiniteMap a b = [(a,b)] listToFM :: Eq a => [(a,b)] -> FiniteMap a b listToFM = id lookupFM :: Eq a => FiniteMap a b -> a -> Maybe b lookupFM fm k = lookup k fm #endif -- ------------------------------------------------------------------------ -- Data types -- ------------------------------------------------------------------------ data XmlEscaper = XmlEscaper { toEscape :: FiniteMap Char String, fromEscape :: FiniteMap String Char, isEscape :: Char -> Bool } -- ------------------------------------------------------------------------ -- Escaping -- ------------------------------------------------------------------------ xmlEscape :: XmlEscaper -> Element i -> Element i xmlEscape xmlEscaper element = compressElement (escapeElement xmlEscaper element) xmlEscapeContent :: XmlEscaper -> [Content i] -> [Content i] xmlEscapeContent xmlEscaper cs = compressContent (escapeContent xmlEscaper cs) escapeElement :: XmlEscaper -> Element i -> Element i escapeElement xmlEscaper (Elem name attributes content) = Elem name (escapeAttributes xmlEscaper attributes) (escapeContent xmlEscaper content) escapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute] escapeAttributes xmlEscaper atts = map (\ (name,av) -> (name,escapeAttValue xmlEscaper av)) atts escapeAttValue :: XmlEscaper -> AttValue -> AttValue escapeAttValue xmlEscaper (AttValue attValList) = AttValue ( concat ( map (\ av -> case av of Right _ -> [av] Left s -> map (\ c -> if isEscape xmlEscaper c then Right (mkEscape xmlEscaper c) else Left [c] ) s ) attValList ) ) escapeContent :: XmlEscaper -> [Content i] -> [Content i] escapeContent xmlEscaper contents = concat (map (\ content -> case content of (CString b str i) -> map (\ c -> if isEscape xmlEscaper c then CRef (mkEscape xmlEscaper c) i else CString b [c] i ) str (CElem element i) -> [CElem (escapeElement xmlEscaper element) i] _ -> [content] ) contents ) mkEscape :: XmlEscaper -> Char -> Reference mkEscape (XmlEscaper {toEscape = toescape}) ch = case lookupFM toescape ch of Nothing -> RefChar (ord ch) Just str -> RefEntity str -- where -- _ = showIntAtBase 16 intToDigit -- -- It should be, but in GHC it isn't. -- ------------------------------------------------------------------------ -- Unescaping -- ------------------------------------------------------------------------ xmlUnEscape :: XmlEscaper -> Element i -> Element i xmlUnEscape xmlEscaper element = compressElement (unEscapeElement xmlEscaper element) xmlUnEscapeContent :: XmlEscaper -> [Content i] -> [Content i] xmlUnEscapeContent xmlEscaper cs = compressContent (unEscapeContent xmlEscaper cs) unEscapeElement :: XmlEscaper -> Element i -> Element i unEscapeElement xmlEscaper (Elem name attributes content) = Elem name (unEscapeAttributes xmlEscaper attributes) (unEscapeContent xmlEscaper content) unEscapeAttributes :: XmlEscaper -> [Attribute] -> [Attribute] unEscapeAttributes xmlEscaper atts = map (\ (name,av) -> (name,unEscapeAttValue xmlEscaper av)) atts unEscapeAttValue :: XmlEscaper -> AttValue -> AttValue unEscapeAttValue xmlEscaper (AttValue attValList) = AttValue ( map (\ av -> case av of Left _ -> av Right ref -> case unEscapeChar xmlEscaper ref of Just c -> Left [c] Nothing -> av ) attValList ) unEscapeContent :: XmlEscaper -> [Content i] -> [Content i] unEscapeContent xmlEscaper content = map (\ cntnt -> case cntnt of CRef ref i -> case unEscapeChar xmlEscaper ref of Just c -> CString False [c] i Nothing -> cntnt CElem element i -> CElem (unEscapeElement xmlEscaper element) i _ -> cntnt ) content unEscapeChar :: XmlEscaper -> Reference -> Maybe Char unEscapeChar xmlEscaper ref = case ref of RefChar i -> Just (chr i) RefEntity name -> lookupFM (fromEscape xmlEscaper) name -- ------------------------------------------------------------------------ -- After escaping and unescaping we rebuild the lists, compressing -- adjacent identical character data. -- ------------------------------------------------------------------------ compressElement :: Element i -> Element i compressElement (Elem name attributes content) = Elem name (compressAttributes attributes) (compressContent content) compressAttributes :: [(QName,AttValue)] -> [(QName,AttValue)] compressAttributes atts = map (\ (name,av) -> (name,compressAttValue av)) atts compressAttValue :: AttValue -> AttValue compressAttValue (AttValue l) = AttValue (compress l) where compress :: [Either String Reference] -> [Either String Reference] compress [] = [] compress (Right ref : es) = Right ref : (compress es) compress ( (ls @ (Left s1)) : es) = case compress es of (Left s2 : es2) -> Left (s1 ++ s2) : es2 es2 -> ls : es2 compressContent :: [Content i] -> [Content i] compressContent [] = [] compressContent ((csb @ (CString b1 s1 i1)) : cs) = case compressContent cs of (CString b2 s2 _) : cs2 | b1 == b2 -> CString b1 (s1 ++ s2) i1: cs2 cs2 -> csb : cs2 compressContent (CElem element i : cs) = CElem (compressElement element) i : compressContent cs compressContent (c : cs) = c : compressContent cs -- ------------------------------------------------------------------------ -- Making XmlEscaper values. -- ------------------------------------------------------------------------ stdXmlEscaper :: XmlEscaper stdXmlEscaper = mkXmlEscaper [('\60',"lt"),('\62',"gt"),('\38',"amp"),('\39',"apos"),('\34',"quot")] (\ ch -> let i = ord ch in i < 10 || (10= 127 || case ch of '\'' -> True '\"' -> True '&' -> True '<' -> True '>' -> True _ -> False ) mkXmlEscaper :: [(Char,String)] -> (Char -> Bool) -> XmlEscaper mkXmlEscaper escapes isescape = XmlEscaper { toEscape = listToFM escapes, fromEscape = listToFM (map (\ (c,str) -> (str,c)) escapes), isEscape = isescape } HaXml-1.23.3/src/Text/XML/HaXml/Html/0000755000062000006210000000000011767644706016163 5ustar 1341796mkpasswdHaXml-1.23.3/src/Text/XML/HaXml/Html/Generate.hs0000755000062000006210000001306311767644706020257 0ustar 1341796mkpasswd-- | These are just some common abbreviations for generating HTML -- content within the XML transformation framework defined -- by "Text.Xml.HaXml.Combinators". module Text.XML.HaXml.Html.Generate ( -- * HTML construction filters -- ** Containers html , hhead , htitle , hbody , h1, h2, h3, h4 , hpara , hdiv, hspan, margin -- ** Anchors , anchor, makehref, anchorname -- ** Text style , hpre , hcentre , hem, htt, hbold , parens, bullet -- ** Tables , htable, hrow, hcol -- ** Breaks, lines , hbr, hhr -- ** Attributes , showattr, (!), (?) -- * A simple HTML pretty-printer , htmlprint ) where import Data.Char (isSpace) import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces import Text.XML.HaXml.Combinators import qualified Text.PrettyPrint.HughesPJ as Pretty ---- Constructor functions html, hhead, htitle, hbody, h1, h2, h3, h4, hpara, hpre, hcentre, hem, htt, hbold, htable, hrow, hcol, hdiv, hspan, margin :: [CFilter i] -> CFilter i html = mkElem "html" hhead = mkElem "head" htitle = mkElem "title" hbody = mkElem "body" h1 = mkElem "h1" h2 = mkElem "h2" h3 = mkElem "h3" h4 = mkElem "h4" hpara = mkElem "p" hpre = mkElem "pre" hcentre = mkElem "center" hem = mkElem "em" htt = mkElem "tt" hbold = mkElem "b" htable = mkElem "table" hrow = mkElem "tr" hcol = mkElem "td" hdiv = mkElem "div" hspan = mkElem "span" margin = mkElemAttr "div" [("margin-left",("2em"!)), ("margin-top", ("1em"!))] anchor :: [(String, CFilter i)] -> [CFilter i] -> CFilter i anchor = mkElemAttr "a" makehref, anchorname :: CFilter i -> [CFilter i] -> CFilter i makehref r = anchor [ ("href",r) ] anchorname n = anchor [ ("name",n) ] hbr, hhr :: CFilter i hbr = mkElem "br" [] hhr = mkElem "hr" [] showattr, (!), (?) :: String -> CFilter i showattr n = find n literal (!) = literal (?) = showattr parens :: CFilter i -> CFilter i parens f = cat [ literal "(", f, literal ")" ] bullet :: [CFilter i] -> CFilter i bullet = cat . (literal "M-^U":) ---- Printing function -- htmlprint :: [Content] -> String -- htmlprint = concatMap cprint -- where -- cprint (CElem e _) = elem e -- cprint (CString _ s) = s -- cprint (CMisc m) = "" -- -- elem (Elem n as []) = "\n<"++n++attrs as++" />" -- elem (Elem n as cs) = "\n<"++n++attrs as++">"++htmlprint cs++"\n" -- -- attrs = concatMap attr -- attr (n,v) = " "++n++"='"++v++"'" htmlprint :: [Content i] -> Pretty.Doc htmlprint = Pretty.cat . map cprint . foldrefs where foldrefs [] = [] foldrefs (CString ws s1 i:CRef r _:CString _ s2 _:cs) = CString ws (s1++"&"++ref r++";"++s2) i: foldrefs cs foldrefs (c:cs) = c : foldrefs cs --ref (RefEntity (EntityRef n)) = n -- Actually, should look-up symtable. --ref (RefChar (CharRef s)) = s ref (RefEntity n) = n -- Actually, should look-up symtable. ref (RefChar s) = show s cprint (CElem e _) = element e cprint (CString ws s _) = Pretty.cat (map Pretty.text (fmt 60 ((if ws then id else deSpace) s))) cprint (CRef r _) = Pretty.text ("&"++ref r++";") cprint (CMisc _ _) = Pretty.empty element (Elem n as []) = Pretty.text "<" Pretty.<> Pretty.text (printableName n) Pretty.<> attrs as Pretty.<> Pretty.text " />" element (Elem n as cs) = -- ( Pretty.text "<" Pretty.<> -- Pretty.text n Pretty.<> -- attrs as Pretty.<> -- Pretty.text ">") Pretty.$$ -- Pretty.nest 6 (htmlprint cs) Pretty.$$ -- ( Pretty.text " -- Pretty.text n Pretty.<> -- Pretty.text ">" ) Pretty.fcat [ ( Pretty.text "<" Pretty.<> Pretty.text (printableName n) Pretty.<> attrs as Pretty.<> Pretty.text ">") , Pretty.nest 4 (htmlprint cs) , ( Pretty.text " Pretty.text (printableName n) Pretty.<> Pretty.text ">" ) ] attrs = Pretty.cat . map attribute attribute (n,v@(AttValue _)) = Pretty.text " " Pretty.<> Pretty.text (printableName n) Pretty.<> Pretty.text "='" Pretty.<> Pretty.text (show v) Pretty.<> Pretty.text "'" fmt _ [] = [] fmt n s = let (top,bot) = splitAt n s (word,left) = keepUntil isSpace (reverse top) in if length top < n then [s] else if not (null left) then reverse left: fmt n (word++bot) else let (big,rest) = keepUntil isSpace s in reverse big: fmt n rest deSpace [] = [] deSpace (c:cs) | c=='\n' = deSpace (' ':cs) | isSpace c = c : deSpace (dropWhile isSpace cs) | otherwise = c : deSpace cs keepUntil p xs = select p ([],xs) where select _ (ls,[]) = (ls,[]) select q (ls,(y:ys)) | q y = (ls,y:ys) | otherwise = select q (y:ls,ys) HaXml-1.23.3/src/Text/XML/HaXml/Html/Parse.hs0000755000062000006210000005725011767644706017605 0ustar 1341796mkpasswd-- | This is a parser for HTML documents. Unlike for XML documents, it -- must include a certain amount of error-correction to account for -- HTML features like self-terminating tags, unterminated tags, and -- incorrect nesting. The input is tokenised by the -- XML lexer (a separate lexer is not required for HTML). -- It uses a slightly extended version of the Hutton/Meijer parser -- combinators. module Text.XML.HaXml.Html.Parse ( htmlParse , htmlParse' ) where import Prelude hiding (either,maybe,sequence) import qualified Prelude (either) import Data.Maybe hiding (maybe) import Data.Char (toLower, {-isSpace,-} isDigit, isHexDigit) import Numeric (readDec,readHex) import Control.Monad import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces import Text.XML.HaXml.Lex import Text.XML.HaXml.Posn import Text.ParserCombinators.Poly.Plain -- #define DEBUG #if defined(DEBUG) # if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \ ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__) import Debug.Trace(trace) # elif defined(__GLASGOW_HASKELL__) import IOExts(trace) # elif defined(__NHC__) || defined(__HBC__) import NonStdTrace # endif debug :: Monad m => String -> m () debug s = trace s (return ()) #else debug :: Monad m => String -> m () debug _ = return () #endif -- | The first argument is the name of the file, the second is the string -- contents of the file. The result is the generic representation of -- an XML document. Any errors cause program failure with message to stderr. htmlParse :: String -> String -> Document Posn htmlParse file = Prelude.either error id . htmlParse' file -- | The first argument is the name of the file, the second is the string -- contents of the file. The result is the generic representation of -- an XML document. Any parsing errors are returned in the @Either@ type. htmlParse' :: String -> String -> Either String (Document Posn) htmlParse' file = Prelude.either Left (Right . simplify) . fst . runParser document . xmlLex file ---- Document simplification ---- simplify :: Document i -> Document i simplify (Document p st (Elem n avs cs) ms) = Document p st (Elem n avs (deepfilter simp cs)) ms where simp (CElem (Elem (N "null") [] []) _) = False simp (CElem (Elem t _ []) _) | localName t `elem` ["font","p","i","b","em","tt","big","small"] = False -- simp (CString False s _) | all isSpace s = False simp _ = True deepfilter f = filter f . map (\c-> case c of CElem (Elem t avs cs) i -> CElem (Elem t avs (deepfilter f cs)) i _ -> c) -- opening any of these, they close again immediately selfclosingtags :: [String] selfclosingtags = ["img","hr","br","meta","col","link","base" ,"param","area","frame","input"] -- closing this, implicitly closes any of those which are contained in it closeInnerTags :: [(String,[String])] closeInnerTags = [ ("ul", ["li"]) , ("ol", ["li"]) , ("dl", ["dt","dd"]) , ("tr", ["th","td"]) , ("div", ["p"]) , ("thead", ["th","tr","td"]) , ("tfoot", ["th","tr","td"]) , ("tbody", ["th","tr","td"]) , ("table", ["th","tr","td","thead","tfoot","tbody"]) , ("caption", ["p"]) , ("th", ["p"]) , ("td", ["p"]) , ("li", ["p"]) , ("dt", ["p"]) , ("dd", ["p"]) , ("object", ["p"]) , ("map", ["p"]) , ("body", ["p"]) ] -- opening this, implicitly closes that closes :: Name -> Name -> Bool "a" `closes` "a" = True "li" `closes` "li" = True "th" `closes` t | t `elem` ["th","td"] = True "td" `closes` t | t `elem` ["th","td"] = True "tr" `closes` t | t `elem` ["th","td","tr"] = True "dt" `closes` t | t `elem` ["dt","dd"] = True "dd" `closes` t | t `elem` ["dt","dd"] = True "form" `closes` "form" = True "label" `closes` "label" = True _ `closes` "option" = True "thead" `closes` t | t `elem` ["colgroup"] = True "tfoot" `closes` t | t `elem` ["thead","colgroup"] = True "tbody" `closes` t | t `elem` ["tbody","tfoot","thead","colgroup"] = True "colgroup" `closes` "colgroup" = True t `closes` "p" | t `elem` ["p","h1","h2","h3","h4","h5","h6" ,"hr","div","ul","dl","ol","table"] = True _ `closes` _ = False ---- Auxiliary Parsing Functions ---- type HParser a = Parser (Posn,TokenT) a tok :: TokenT -> HParser TokenT tok t = do (p,t') <- next case t' of TokError _ -> report failBad (show t) p t' _ | t'==t -> return t | otherwise -> report fail (show t) p t' qname :: HParser QName qname = fmap N name name :: HParser Name --name = do {(p,TokName s) <- next; return s} name = do (p,tok) <- next case tok of TokName s -> return s TokError _ -> report failBad "a name" p tok _ -> report fail "a name" p tok string, freetext :: HParser String string = do (p,t) <- next case t of TokName s -> return s _ -> report fail "text" p t freetext = do (p,t) <- next case t of TokFreeText s -> return s _ -> report fail "text" p t maybe :: HParser a -> HParser (Maybe a) maybe p = ( p >>= return . Just) `onFail` ( return Nothing) either :: HParser a -> HParser b -> HParser (Either a b) either p q = ( p >>= return . Left) `onFail` ( q >>= return . Right) word :: String -> HParser () word s = do { x <- next ; case x of (_p,TokName n) | s==n -> return () (_p,TokFreeText n) | s==n -> return () ( p,t@(TokError _)) -> report failBad (show s) p t ( p,t) -> report fail (show s) p t } posn :: HParser Posn posn = do { x@(p,_) <- next ; reparse [x] ; return p } `onFail` return noPos nmtoken :: HParser NmToken nmtoken = (string `onFail` freetext) failP, failBadP :: String -> HParser a failP msg = do { p <- posn; fail (msg++"\n at "++show p) } failBadP msg = do { p <- posn; failBad (msg++"\n at "++show p) } report :: (String->HParser a) -> String -> Posn -> TokenT -> HParser a report fail expect p t = fail ("Expected "++show expect++" but found "++show t ++"\n at "++show p) adjustErrP :: HParser a -> (String->String) -> HParser a p `adjustErrP` f = p `onFail` do pn <- posn (p `adjustErr` f) `adjustErr` (++show pn) ---- XML Parsing Functions ---- document :: HParser (Document Posn) document = do p <- prolog `adjustErr` ("unrecognisable XML prolog\n"++) ht <- many1 (element "HTML document") ms <- many misc return (Document p emptyST (case map snd ht of [e] -> e es -> Elem (N "html") [] (map mkCElem es)) ms) where mkCElem e = CElem e noPos comment :: HParser Comment comment = do bracket (tok TokCommentOpen) (tok TokCommentClose) freetext processinginstruction :: HParser ProcessingInstruction processinginstruction = do tok TokPIOpen commit $ do n <- string `onFail` failP "processing instruction has no target" f <- freetext (tok TokPIClose `onFail` tok TokAnyClose) `onFail` failP "missing ?> or >" return (n, f) cdsect :: HParser CDSect cdsect = do tok TokSectionOpen bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata prolog :: HParser Prolog prolog = do x <- maybe xmldecl m1 <- many misc dtd <- maybe doctypedecl m2 <- many misc return (Prolog x m1 dtd m2) xmldecl :: HParser XMLDecl xmldecl = do tok TokPIOpen (word "xml" `onFail` word "XML") p <- posn s <- freetext tok TokPIClose `onFail` failBadP "missing ?> in " (Prelude.either failP return . fst . runParser aux . xmlReLex p) s where aux = do v <- versioninfo `onFail` failP "missing XML version info" e <- maybe encodingdecl s <- maybe sddecl return (XMLDecl v e s) versioninfo :: HParser VersionInfo versioninfo = do (word "version" `onFail` word "VERSION") tok TokEqual bracket (tok TokQuote) (tok TokQuote) freetext misc :: HParser Misc misc = oneOf' [ ("", comment >>= return . Comment) , ("", processinginstruction >>= return . PI) ] -- Question: for HTML, should we disallow in-line DTDs, allowing only externals? -- Answer: I think so. doctypedecl :: HParser DocTypeDecl doctypedecl = do tok TokSpecialOpen tok (TokSpecial DOCTYPEx) commit $ do n <- qname eid <- maybe externalid -- es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)) (many markupdecl) tok TokAnyClose `onFail` failP "missing > in DOCTYPE decl" -- return (DTD n eid (case es of { Nothing -> []; Just e -> e })) return (DTD n eid []) --markupdecl :: HParser MarkupDecl --markupdecl = -- ( elementdecl >>= return . Element) `onFail` -- ( attlistdecl >>= return . AttList) `onFail` -- ( entitydecl >>= return . Entity) `onFail` -- ( notationdecl >>= return . Notation) `onFail` -- ( misc >>= return . MarkupMisc) `onFail` -- PEREF(MarkupPE,markupdecl) -- --extsubset :: HParser ExtSubset --extsubset = do -- td <- maybe textdecl -- ds <- many extsubsetdecl -- return (ExtSubset td ds) -- --extsubsetdecl :: HParser ExtSubsetDecl --extsubsetdecl = -- ( markupdecl >>= return . ExtMarkupDecl) `onFail` -- ( conditionalsect >>= return . ExtConditionalSect) `onFail` -- PEREF(ExtPEReference,extsubsetdecl) sddecl :: HParser SDDecl sddecl = do (word "standalone" `onFail` word "STANDALONE") commit $ do tok TokEqual `onFail` failP "missing = in 'standalone' decl" bracket (tok TokQuote) (tok TokQuote) ( (word "yes" >> return True) `onFail` (word "no" >> return False) `onFail` failP "'standalone' decl requires 'yes' or 'no' value" ) ---- -- VERY IMPORTANT NOTE: The stack returned here contains those tags which -- have been closed implicitly and need to be reopened again at the -- earliest opportunity. type Stack = [(Name,[Attribute])] element :: Name -> HParser (Stack,Element Posn) element ctx = do tok TokAnyOpen (ElemTag (N e) avs) <- elemtag ( if e `closes` ctx then -- insert the missing close-tag, fail forward, and reparse. ( do debug ("/") unparse ([TokEndOpen, TokName ctx, TokAnyClose, TokAnyOpen, TokName e] ++ reformatAttrs avs) return ([], Elem (N "null") [] [])) else if e `elem` selfclosingtags then -- complete the parse straightaway. ( do tok TokEndClose -- self-closing debug (e++"[+]") return ([], Elem (N e) avs [])) `onFail` -- ( do tok TokAnyClose -- sequence (**not HTML?**) -- debug (e++"[+") -- n <- bracket (tok TokEndOpen) (tok TokAnyClose) qname -- debug "]" -- if e == (map toLower n :: Name) -- then return ([], Elem e avs []) -- else return (error "no nesting in empty tag")) `onFail` ( do tok TokAnyClose -- with no close (e.g. ) debug (e++"[+]") return ([], Elem (N e) avs [])) else (( do tok TokEndClose debug (e++"[]") return ([], Elem (N e) avs [])) `onFail` ( do tok TokAnyClose `onFail` failP "missing > or /> in element tag" debug (e++"[") -- zz <- many (content e) -- n <- bracket (tok TokEndOpen) (tok TokAnyClose) qname zz <- manyFinally (content e) (tok TokEndOpen) (N n) <- qname commit (tok TokAnyClose) debug "]" let (ss,cs) = unzip zz let s = if null ss then [] else last ss ( if e == (map toLower n :: Name) then do unparse (reformatTags (closeInner e s)) debug "^" return ([], Elem (N e) avs cs) else do unparse [TokEndOpen, TokName n, TokAnyClose] debug "-" return (((e,avs):s), Elem (N e) avs cs)) ) `onFail` failP ("failed to repair non-matching tags in context: "++ctx))) closeInner :: Name -> [(Name,[Attribute])] -> [(Name,[Attribute])] closeInner c ts = case lookup c closeInnerTags of (Just these) -> filter ((`notElem` these).fst) ts Nothing -> ts unparse :: [TokenT] -> Parser (Posn, TokenT) () unparse ts = do p <- posn reparse (zip (repeat p) ts) reformatAttrs :: [(QName, AttValue)] -> [TokenT] reformatAttrs avs = concatMap f0 avs where f0 (a, v@(AttValue _)) = [ TokName (printableName a), TokEqual , TokQuote, TokFreeText (show v), TokQuote ] reformatTags :: [(String, [(QName, AttValue)])] -> [TokenT] reformatTags ts = concatMap f0 ts where f0 (t,avs) = [TokAnyOpen, TokName t]++reformatAttrs avs++[TokAnyClose] content :: Name -> HParser (Stack,Content Posn) content ctx = do { p <- posn ; content' p } where content' p = oneOf' [ ( "element", element ctx >>= \(s,e)-> return (s, CElem e p)) , ( "chardata", chardata >>= \s-> return ([], CString False s p)) , ( "reference", reference >>= \r-> return ([], CRef r p)) , ( "cdsect", cdsect >>= \c-> return ([], CString True c p)) , ( "misc", misc >>= \m-> return ([], CMisc m p)) ] `adjustErrP` ("when looking for a content item,\n"++) ---- elemtag :: HParser ElemTag elemtag = do (N n) <- qname `adjustErrBad` ("malformed element tag\n"++) as <- many attribute return (ElemTag (N $ map toLower n) as) attribute :: HParser Attribute attribute = do (N n) <- qname v <- (do tok TokEqual attvalue) `onFail` (return (AttValue [Left "TRUE"])) return (N $ map toLower n, v) --elementdecl :: HParser ElementDecl --elementdecl = do -- tok TokSpecialOpen -- tok (TokSpecial ELEMENTx) -- n <- qname `onFail` failP "missing identifier in ELEMENT decl" -- c <- contentspec `onFail` failP "missing content spec in ELEMENT decl" -- tok TokAnyClose `onFail` failP "expected > terminating ELEMENT decl" -- return (ElementDecl n c) -- --contentspec :: HParser ContentSpec --contentspec = -- ( word "EMPTY" >> return EMPTY) `onFail` -- ( word "ANY" >> return ANY) `onFail` -- ( mixed >>= return . Mixed) `onFail` -- ( cp >>= return . ContentSpec) `onFail` -- PEREF(ContentPE,contentspec) -- --choice :: HParser [CP] --choice = do -- bracket (tok TokBraOpen) (tok TokBraClose) -- (cp `sepby1` (tok TokPipe)) -- --sequence :: HParser [CP] --sequence = do -- bracket (tok TokBraOpen) (tok TokBraClose) -- (cp `sepby1` (tok TokComma)) -- --cp :: HParser CP --cp = -- ( do n <- qname -- m <- modifier -- return (TagName n m)) `onFail` -- ( do ss <- sequence -- m <- modifier -- return (Seq ss m)) `onFail` -- ( do cs <- choice -- m <- modifier -- return (Choice cs m)) `onFail` -- PEREF(CPPE,cp) -- --modifier :: HParser Modifier --modifier = -- ( tok TokStar >> return Star) `onFail` -- ( tok TokQuery >> return Query) `onFail` -- ( tok TokPlus >> return Plus) `onFail` -- ( return None) -- --mixed :: HParser Mixed --mixed = do -- tok TokBraOpen -- tok TokHash -- word "PCDATA" -- cont -- where -- cont = ( tok TokBraClose >> return PCDATA) `onFail` -- ( do cs <- many ( do tok TokPipe -- n <- qname -- return n) -- tok TokBraClose -- tok TokStar -- return (PCDATAplus cs)) -- --attlistdecl :: HParser AttListDecl --attlistdecl = do -- tok TokSpecialOpen -- tok (TokSpecial ATTLISTx) -- n <- qname `onFail` failP "missing identifier in ATTLIST" -- ds <- many attdef -- tok TokAnyClose `onFail` failP "missing > terminating ATTLIST" -- return (AttListDecl n ds) -- --attdef :: HParser AttDef --attdef = do -- n <- qname -- t <- atttype `onFail` failP "missing attribute type in attlist defn" -- d <- defaultdecl -- return (AttDef n t d) -- --atttype :: HParser AttType --atttype = -- ( word "CDATA" >> return StringType) `onFail` -- ( tokenizedtype >>= return . TokenizedType) `onFail` -- ( enumeratedtype >>= return . EnumeratedType) -- --tokenizedtype :: HParser TokenizedType --tokenizedtype = -- ( word "ID" >> return ID) `onFail` -- ( word "IDREF" >> return IDREF) `onFail` -- ( word "IDREFS" >> return IDREFS) `onFail` -- ( word "ENTITY" >> return ENTITY) `onFail` -- ( word "ENTITIES" >> return ENTITIES) `onFail` -- ( word "NMTOKEN" >> return NMTOKEN) `onFail` -- ( word "NMTOKENS" >> return NMTOKENS) -- --enumeratedtype :: HParser EnumeratedType --enumeratedtype = -- ( notationtype >>= return . NotationType) `onFail` -- ( enumeration >>= return . Enumeration) -- --notationtype :: HParser NotationType --notationtype = do -- word "NOTATION" -- bracket (tok TokBraOpen) (tok TokBraClose) -- (name `sepby1` (tok TokPipe)) -- --enumeration :: HParser Enumeration --enumeration = -- bracket (tok TokBraOpen) (tok TokBraClose) -- (nmtoken `sepby1` (tok TokPipe)) -- --defaultdecl :: HParser DefaultDecl --defaultdecl = -- ( tok TokHash >> word "REQUIRED" >> return REQUIRED) `onFail` -- ( tok TokHash >> word "IMPLIED" >> return IMPLIED) `onFail` -- ( do f <- maybe (tok TokHash >> word "FIXED" >> return FIXED) -- a <- attvalue -- return (DefaultTo a f)) -- --conditionalsect :: HParser ConditionalSect --conditionalsect = -- ( do tok TokSectionOpen -- tok (TokSection INCLUDEx) -- tok TokSqOpen `onFail` failP "missing [ after INCLUDE" -- i <- extsubsetdecl `onFail` failP "missing ExtSubsetDecl in INCLUDE" -- tok TokSectionClose `onFail` failP "missing ] after INCLUDE" -- return (IncludeSect i)) `onFail` -- ( do tok TokSectionOpen -- tok (TokSection IGNOREx) -- tok TokSqOpen `onFail` failP "missing [ after IGNORE" -- i <- many ignoresectcontents -- tok TokSectionClose `onFail` failP "missing ] after IGNORE" -- return (IgnoreSect i)) -- --ignoresectcontents :: HParser IgnoreSectContents --ignoresectcontents = do -- i <- ignore -- is <- many (do tok TokSectionOpen -- ic <- ignoresectcontents -- tok TokSectionClose -- ig <- ignore -- return (ic,ig)) -- return (IgnoreSectContents i is) -- --ignore :: HParser Ignore --ignore = freetext >>= return . Ignore reference :: HParser Reference reference = do bracket (tok TokAmp) (tok TokSemi) (freetext >>= val) where val ('#':'x':i) | all isHexDigit i = return . RefChar . fst . head . readHex $ i val ('#':i) | all isDigit i = return . RefChar . fst . head . readDec $ i val ent = return . RefEntity $ ent {- reference :: HParser Reference reference = ( charref >>= return . RefChar) `onFail` ( entityref >>= return . RefEntity) entityref :: HParser EntityRef entityref = do n <- bracket (tok TokAmp) (tok TokSemi) name return n charref :: HParser CharRef charref = do bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal) where readCharVal ('#':'x':i) = return . fst . head . readHex $ i readCharVal ('#':i) = return . fst . head . readDec $ i readCharVal _ = mzero -} --pereference :: HParser PEReference --pereference = do -- bracket (tok TokPercent) (tok TokSemi) nmtoken -- --entitydecl :: HParser EntityDecl --entitydecl = -- ( gedecl >>= return . EntityGEDecl) `onFail` -- ( pedecl >>= return . EntityPEDecl) -- --gedecl :: HParser GEDecl --gedecl = do -- tok TokSpecialOpen -- tok (TokSpecial ENTITYx) -- n <- name -- e <- entitydef `onFail` failP "missing entity defn in G ENTITY decl" -- tok TokAnyClose `onFail` failP "expected > terminating G ENTITY decl" -- return (GEDecl n e) -- --pedecl :: HParser PEDecl --pedecl = do -- tok TokSpecialOpen -- tok (TokSpecial ENTITYx) -- tok TokPercent -- n <- name -- e <- pedef `onFail` failP "missing entity defn in P ENTITY decl" -- tok TokAnyClose `onFail` failP "expected > terminating P ENTITY decl" -- return (PEDecl n e) -- --entitydef :: HParser EntityDef --entitydef = -- ( entityvalue >>= return . DefEntityValue) `onFail` -- ( do eid <- externalid -- ndd <- maybe ndatadecl -- return (DefExternalID eid ndd)) -- --pedef :: HParser PEDef --pedef = -- ( entityvalue >>= return . PEDefEntityValue) `onFail` -- ( externalid >>= return . PEDefExternalID) externalid :: HParser ExternalID externalid = ( do word "SYSTEM" s <- systemliteral return (SYSTEM s)) `onFail` ( do word "PUBLIC" p <- pubidliteral s <- (systemliteral `onFail` return (SystemLiteral "")) return (PUBLIC p s)) --ndatadecl :: HParser NDataDecl --ndatadecl = do -- word "NDATA" -- n <- name -- return (NDATA n) --textdecl :: HParser TextDecl --textdecl = do -- tok TokPIOpen -- (word "xml" `onFail` word "XML") -- v <- maybe versioninfo -- e <- encodingdecl -- tok TokPIClose `onFail` failP "expected ?> terminating text decl" -- return (TextDecl v e) --extparsedent :: HParser ExtParsedEnt --extparsedent = do -- t <- maybe textdecl -- (_,c) <- (content "") -- return (ExtParsedEnt t c) -- --extpe :: HParser ExtPE --extpe = do -- t <- maybe textdecl -- e <- extsubsetdecl -- return (ExtPE t e) encodingdecl :: HParser EncodingDecl encodingdecl = do (word "encoding" `onFail` word "ENCODING") tok TokEqual `onFail` failBadP "expected = in 'encoding' decl" f <- bracket (tok TokQuote) (tok TokQuote) freetext return (EncodingDecl f) --notationdecl :: HParser NotationDecl --notationdecl = do -- tok TokSpecialOpen -- word "NOTATION" -- n <- name -- e <- either externalid publicid -- tok TokAnyClose `onFail` failP "expected > terminating NOTATION decl" -- return (NOTATION n e) --publicid :: HParser PublicID --publicid = do -- word "PUBLICID" -- p <- pubidliteral -- return (PUBLICID p) --entityvalue :: HParser EntityValue --entityvalue = do -- evs <- bracket (tok TokQuote) (tok TokQuote) (many ev) -- return (EntityValue evs) --ev :: HParser EV --ev = -- ( freetext >>= return . EVString) `onFail` -- -- PEREF(EVPERef,ev) `onFail` -- ( reference >>= return . EVRef) attvalue :: HParser AttValue attvalue = ( do avs <- bracket (tok TokQuote) (tok TokQuote) (many (either freetext reference)) return (AttValue avs) ) `onFail` ( do v <- nmtoken s <- (tok TokPercent >> return "%") `onFail` return "" return (AttValue [Left (v++s)]) ) `onFail` ( do s <- oneOf [ tok TokPlus >> return "+" , tok TokHash >> return "#" ] v <- nmtoken return (AttValue [Left (s++v)]) ) `onFail` failP "Badly formatted attribute value" systemliteral :: HParser SystemLiteral systemliteral = do s <- bracket (tok TokQuote) (tok TokQuote) freetext return (SystemLiteral s) -- note: need to fold &...; escapes pubidliteral :: HParser PubidLiteral pubidliteral = do s <- bracket (tok TokQuote) (tok TokQuote) freetext return (PubidLiteral s) -- note: need to fold &...; escapes chardata :: HParser CharData chardata = freetext -- >>= return . CharData HaXml-1.23.3/src/Text/XML/HaXml/Html/ParseLazy.hs0000755000062000006210000005753311767644706020451 0ustar 1341796mkpasswd-- | This is a parser for HTML documents. Unlike for XML documents, it -- must include a certain amount of error-correction to account for -- HTML features like self-terminating tags, unterminated tags, and -- incorrect nesting. The input is tokenised by the -- XML lexer (a separate lexer is not required for HTML). -- It uses a slightly extended version of the Hutton/Meijer parser -- combinators. module Text.XML.HaXml.Html.ParseLazy ( htmlParse ) where import Prelude hiding (either,maybe,sequence) --import qualified Prelude (either) import Data.Maybe hiding (maybe) import Data.Char (toLower, {-isSpace,-} isDigit, isHexDigit) import Numeric (readDec,readHex) import Control.Monad import Text.XML.HaXml.Types import Text.XML.HaXml.Lex import Text.XML.HaXml.Posn import Text.ParserCombinators.Poly.Lazy -- #define DEBUG #if defined(DEBUG) # if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \ ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__) import Debug.Trace(trace) # elif defined(__GLASGOW_HASKELL__) import IOExts(trace) # elif defined(__NHC__) || defined(__HBC__) import NonStdTrace # endif debug :: Monad m => String -> m () debug s = trace s (return ()) #else debug :: Monad m => String -> m () debug _ = return () #endif -- | The first argument is the name of the file, the second is the string -- contents of the file. The result is the generic representation of -- an XML document. Any errors cause program failure with message to stderr. htmlParse :: String -> String -> Document Posn htmlParse file = {-simplify .-} fst . runParser document . xmlLex file {- -- | The first argument is the name of the file, the second is the string -- contents of the file. The result is the generic representation of -- an XML document. Any parsing errors are returned in the @Either@ type. htmlParse' :: String -> String -> Either String (Document Posn) htmlParse' file = Prelude.either Left (Right . simplify) . fst . runParser document . xmlLex file -} ---- Document simplification ---- --simplify :: Document i -> Document i --simplify (Document p st (Elem n avs cs) ms) = -- Document p st (Elem n avs (deepfilter simp cs)) ms -- where -- simp (CElem (Elem "null" [] []) _) = False -- simp (CElem (Elem n _ []) _) | n `elem` ["font","p","i","b","em" -- ,"tt","big","small"] = False -- -- simp (CString False s _) | all isSpace s = False -- simp _ = True -- deepfilter p = -- filter p . map (\c-> case c of -- CElem (Elem n avs cs) i -- -> CElem (Elem n avs (deepfilter p cs)) i -- _ -> c) -- opening any of these, they close again immediately selfclosingtags :: [String] selfclosingtags = ["img","hr","br","meta","col","link","base" ,"param","area","frame","input"] --closing this, implicitly closes any of those which are contained in it closeInnerTags :: [(String,[String])] closeInnerTags = [ ("ul", ["li"]) , ("ol", ["li"]) , ("dl", ["dt","dd"]) , ("tr", ["th","td"]) , ("div", ["p"]) , ("thead", ["th","tr","td"]) , ("tfoot", ["th","tr","td"]) , ("tbody", ["th","tr","td"]) , ("table", ["th","tr","td","thead","tfoot","tbody"]) , ("caption", ["p"]) , ("th", ["p"]) , ("td", ["p"]) , ("li", ["p"]) , ("dt", ["p"]) , ("dd", ["p"]) , ("object", ["p"]) , ("map", ["p"]) , ("body", ["p"]) ] --opening this, implicitly closes that closes :: String -> String -> Bool "a" `closes` "a" = True "li" `closes` "li" = True "th" `closes` t | t `elem` ["th","td"] = True "td" `closes` t | t `elem` ["th","td"] = True "tr" `closes` t | t `elem` ["th","td","tr"] = True "dt" `closes` t | t `elem` ["dt","dd"] = True "dd" `closes` t | t `elem` ["dt","dd"] = True "form" `closes` "form" = True "label" `closes` "label" = True _ `closes` "option" = True "thead" `closes` t | t `elem` ["colgroup"] = True "tfoot" `closes` t | t `elem` ["thead","colgroup"] = True "tbody" `closes` t | t `elem` ["tbody","tfoot","thead","colgroup"] = True "colgroup" `closes` "colgroup" = True t `closes` "p" | t `elem` ["p","h1","h2","h3","h4","h5","h6" ,"hr","div","ul","dl","ol","table"] = True _ `closes` _ = False ---- Auxiliary Parsing Functions ---- type HParser a = Parser (Posn,TokenT) a tok :: TokenT -> HParser TokenT tok t = do (p,t') <- next case t' of TokError _ -> report failBad (show t) p t' _ | t'==t -> return t | otherwise -> report fail (show t) p t' qname :: HParser QName qname = fmap N name name :: HParser Name --name = do {(p,TokName s) <- next; return s} name = do (p,tok) <- next case tok of TokName s -> return s TokError _ -> report failBad "a name" p tok _ -> report fail "a name" p tok string, freetext :: HParser String string = do (p,t) <- next case t of TokName s -> return s _ -> report fail "text" p t freetext = do (p,t) <- next case t of TokFreeText s -> return s _ -> report fail "text" p t maybe :: HParser a -> HParser (Maybe a) maybe p = ( p >>= return . Just) `onFail` ( return Nothing) either :: HParser a -> HParser b -> HParser (Either a b) either p q = ( p >>= return . Left) `onFail` ( q >>= return . Right) word :: String -> HParser () word s = do { x <- next ; case x of (_p,TokName n) | s==n -> return () (_p,TokFreeText n) | s==n -> return () ( p,t@(TokError _)) -> report failBad (show s) p t ( p,t) -> report fail (show s) p t } posn :: HParser Posn posn = do { x@(p,_) <- next ; reparse [x] ; return p } `onFail` return noPos nmtoken :: HParser NmToken nmtoken = (string `onFail` freetext) failP, failBadP :: String -> HParser a failP msg = do { p <- posn; fail (msg++"\n at "++show p) } failBadP msg = do { p <- posn; failBad (msg++"\n at "++show p) } report :: (String->HParser a) -> String -> Posn -> TokenT -> HParser a report fail expect p t = fail ("Expected "++show expect++" but found "++show t ++"\n at "++show p) adjustErrP :: HParser a -> (String->String) -> HParser a p `adjustErrP` f = p `onFail` do pn <- posn (p `adjustErr` f) `adjustErr` (++show pn) ---- XML Parsing Functions ---- document :: HParser (Document Posn) document = do return Document `apply` (prolog `adjustErr` ("unrecognisable XML prolog\n"++)) `apply` (return emptyST) `apply` (do ht <- many1 (element (N "HTML document")) return (case map snd ht of [e] -> e es -> Elem (N "html") [] (map mkCElem es))) `apply` (many misc) where mkCElem e = CElem e noPos comment :: HParser Comment comment = do bracket (tok TokCommentOpen) (tok TokCommentClose) freetext processinginstruction :: HParser ProcessingInstruction processinginstruction = do tok TokPIOpen commit $ do n <- string `onFail` failP "processing instruction has no target" f <- freetext (tok TokPIClose `onFail` tok TokAnyClose) `onFail` failP "missing ?> or >" return (n, f) cdsect :: HParser CDSect cdsect = do tok TokSectionOpen bracket (tok (TokSection CDATAx)) (tok TokSectionClose) chardata prolog :: HParser Prolog prolog = do x <- maybe xmldecl m1 <- many misc dtd <- maybe doctypedecl m2 <- many misc return (Prolog x m1 dtd m2) xmldecl :: HParser XMLDecl xmldecl = do tok TokPIOpen (word "xml" `onFail` word "XML") p <- posn s <- freetext tok TokPIClose `onFail` failBadP "missing ?> in " (return . fst . runParser aux . xmlReLex p) s where aux = do v <- versioninfo `onFail` failP "missing XML version info" e <- maybe encodingdecl s <- maybe sddecl return (XMLDecl v e s) versioninfo :: HParser VersionInfo versioninfo = do (word "version" `onFail` word "VERSION") tok TokEqual bracket (tok TokQuote) (tok TokQuote) freetext misc :: HParser Misc misc = oneOf' [ ("", comment >>= return . Comment) , ("", processinginstruction >>= return . PI) ] -- Question: for HTML, should we disallow in-line DTDs, allowing only externals? -- Answer: I think so. doctypedecl :: HParser DocTypeDecl doctypedecl = do tok TokSpecialOpen tok (TokSpecial DOCTYPEx) commit $ do n <- qname eid <- maybe externalid -- es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose)) (many markupdecl) tok TokAnyClose `onFail` failP "missing > in DOCTYPE decl" -- return (DTD n eid (case es of { Nothing -> []; Just e -> e })) return (DTD n eid []) --markupdecl :: HParser MarkupDecl --markupdecl = -- ( elementdecl >>= return . Element) `onFail` -- ( attlistdecl >>= return . AttList) `onFail` -- ( entitydecl >>= return . Entity) `onFail` -- ( notationdecl >>= return . Notation) `onFail` -- ( misc >>= return . MarkupMisc) `onFail` -- PEREF(MarkupPE,markupdecl) -- --extsubset :: HParser ExtSubset --extsubset = do -- td <- maybe textdecl -- ds <- many extsubsetdecl -- return (ExtSubset td ds) -- --extsubsetdecl :: HParser ExtSubsetDecl --extsubsetdecl = -- ( markupdecl >>= return . ExtMarkupDecl) `onFail` -- ( conditionalsect >>= return . ExtConditionalSect) `onFail` -- PEREF(ExtPEReference,extsubsetdecl) sddecl :: HParser SDDecl sddecl = do (word "standalone" `onFail` word "STANDALONE") commit $ do tok TokEqual `onFail` failP "missing = in 'standalone' decl" bracket (tok TokQuote) (tok TokQuote) ( (word "yes" >> return True) `onFail` (word "no" >> return False) `onFail` failP "'standalone' decl requires 'yes' or 'no' value" ) ---- -- VERY IMPORTANT NOTE: The stack returned here contains those tags which -- have been closed implicitly and need to be reopened again at the -- earliest opportunity. type Stack = [(Name,[Attribute])] element :: QName -> HParser (Stack,Element Posn) element (N ctx) = do tok TokAnyOpen (ElemTag (N e) avs) <- elemtag ( if e `closes` ctx then -- insert the missing close-tag, fail forward, and reparse. ( do debug ("/") unparse ([TokEndOpen, TokName ctx, TokAnyClose, TokAnyOpen, TokName e] ++ reformatAttrs avs) return ([], Elem (N "null") [] [])) else if e `elem` selfclosingtags then -- complete the parse straightaway. ( do tok TokEndClose -- self-closing debug (e++"[+]") return ([], Elem (N e) avs [])) `onFail` -- ( do tok TokAnyClose -- sequence (**not HTML?**) -- debug (e++"[+") -- n <- bracket (tok TokEndOpen) (tok TokAnyClose) qname -- debug "]" -- if e == (map toLower n :: Name) -- then return ([], Elem e avs []) -- else return (error "no nesting in empty tag")) `onFail` ( do tok TokAnyClose -- with no close (e.g. ) debug (e++"[+]") return ([], Elem (N e) avs [])) else (( do tok TokEndClose debug (e++"[]") return ([], Elem (N e) avs [])) `onFail` ( do tok TokAnyClose `onFail` failP "missing > or /> in element tag" debug (e++"[") return (\ interior-> let (stack,contained) = interior in (stack, Elem (N e) avs contained)) `apply` (do zz <- manyFinally (content e) (tok TokEndOpen) (N n) <- qname commit (tok TokAnyClose) debug "]" let (ss,cs) = unzip zz let s = if null ss then [] else last ss ( if e == (map toLower n :: Name) then do unparse (reformatTags (closeInner e s)) debug "^" return ([], cs) else do unparse [TokEndOpen, TokName n, TokAnyClose] debug "-" return (((e,avs):s), cs))) ) `onFail` failP ("failed to repair non-matching tags in context: "++ctx))) closeInner :: Name -> [(Name,[Attribute])] -> [(Name,[Attribute])] closeInner c ts = case lookup c closeInnerTags of (Just these) -> filter ((`notElem` these).fst) ts Nothing -> ts unparse :: [TokenT] -> Parser (Posn, TokenT) () unparse ts = do p <- posn reparse (zip (repeat p) ts) reformatAttrs :: [(QName, AttValue)] -> [TokenT] reformatAttrs avs = concatMap f0 avs where f0 (N a, v@(AttValue _)) = [TokName a, TokEqual, TokQuote, TokFreeText (show v), TokQuote] reformatTags :: [(Name, [(QName, AttValue)])] -> [TokenT] reformatTags ts = concatMap f0 ts where f0 (t,avs) = [TokAnyOpen, TokName t]++reformatAttrs avs ++[TokAnyClose] content :: Name -> HParser (Stack,Content Posn) content ctx = do { p <- posn ; content' p } where content' p = oneOf' [ ( "element", element (N ctx) >>= \(s,e)-> return (s, CElem e p)) , ( "chardata", chardata >>= \s-> return ([], CString False s p)) , ( "reference", reference >>= \r-> return ([], CRef r p)) , ( "cdsect", cdsect >>= \c-> return ([], CString True c p)) , ( "misc", misc >>= \m-> return ([], CMisc m p)) ] `adjustErrP` ("when looking for a content item,\n"++) ---- elemtag :: HParser ElemTag elemtag = do (N n) <- qname `adjustErrBad` ("malformed element tag\n"++) as <- many attribute return (ElemTag (N (map toLower n)) as) attribute :: HParser Attribute attribute = do (N n) <- qname v <- (do tok TokEqual attvalue) `onFail` (return (AttValue [Left "TRUE"])) return (N (map toLower n), v) --elementdecl :: HParser ElementDecl --elementdecl = do -- tok TokSpecialOpen -- tok (TokSpecial ELEMENTx) -- n <- qname `onFail` failP "missing identifier in ELEMENT decl" -- c <- contentspec `onFail` failP "missing content spec in ELEMENT decl" -- tok TokAnyClose `onFail` failP "expected > terminating ELEMENT decl" -- return (ElementDecl n c) -- --contentspec :: HParser ContentSpec --contentspec = -- ( word "EMPTY" >> return EMPTY) `onFail` -- ( word "ANY" >> return ANY) `onFail` -- ( mixed >>= return . Mixed) `onFail` -- ( cp >>= return . ContentSpec) `onFail` -- PEREF(ContentPE,contentspec) -- --choice :: HParser [CP] --choice = do -- bracket (tok TokBraOpen) (tok TokBraClose) -- (cp `sepby1` (tok TokPipe)) -- --sequence :: HParser [CP] --sequence = do -- bracket (tok TokBraOpen) (tok TokBraClose) -- (cp `sepby1` (tok TokComma)) -- --cp :: HParser CP --cp = -- ( do n <- qname -- m <- modifier -- return (TagName n m)) `onFail` -- ( do ss <- sequence -- m <- modifier -- return (Seq ss m)) `onFail` -- ( do cs <- choice -- m <- modifier -- return (Choice cs m)) `onFail` -- PEREF(CPPE,cp) -- --modifier :: HParser Modifier --modifier = -- ( tok TokStar >> return Star) `onFail` -- ( tok TokQuery >> return Query) `onFail` -- ( tok TokPlus >> return Plus) `onFail` -- ( return None) -- --mixed :: HParser Mixed --mixed = do -- tok TokBraOpen -- tok TokHash -- word "PCDATA" -- cont -- where -- cont = ( tok TokBraClose >> return PCDATA) `onFail` -- ( do cs <- many ( do tok TokPipe -- n <- qname -- return n) -- tok TokBraClose -- tok TokStar -- return (PCDATAplus cs)) -- --attlistdecl :: HParser AttListDecl --attlistdecl = do -- tok TokSpecialOpen -- tok (TokSpecial ATTLISTx) -- n <- qname `onFail` failP "missing identifier in ATTLIST" -- ds <- many attdef -- tok TokAnyClose `onFail` failP "missing > terminating ATTLIST" -- return (AttListDecl n ds) -- --attdef :: HParser AttDef --attdef = do -- n <- qname -- t <- atttype `onFail` failP "missing attribute type in attlist defn" -- d <- defaultdecl -- return (AttDef n t d) -- --atttype :: HParser AttType --atttype = -- ( word "CDATA" >> return StringType) `onFail` -- ( tokenizedtype >>= return . TokenizedType) `onFail` -- ( enumeratedtype >>= return . EnumeratedType) -- --tokenizedtype :: HParser TokenizedType --tokenizedtype = -- ( word "ID" >> return ID) `onFail` -- ( word "IDREF" >> return IDREF) `onFail` -- ( word "IDREFS" >> return IDREFS) `onFail` -- ( word "ENTITY" >> return ENTITY) `onFail` -- ( word "ENTITIES" >> return ENTITIES) `onFail` -- ( word "NMTOKEN" >> return NMTOKEN) `onFail` -- ( word "NMTOKENS" >> return NMTOKENS) -- --enumeratedtype :: HParser EnumeratedType --enumeratedtype = -- ( notationtype >>= return . NotationType) `onFail` -- ( enumeration >>= return . Enumeration) -- --notationtype :: HParser NotationType --notationtype = do -- word "NOTATION" -- bracket (tok TokBraOpen) (tok TokBraClose) -- (name `sepby1` (tok TokPipe)) -- --enumeration :: HParser Enumeration --enumeration = -- bracket (tok TokBraOpen) (tok TokBraClose) -- (nmtoken `sepby1` (tok TokPipe)) -- --defaultdecl :: HParser DefaultDecl --defaultdecl = -- ( tok TokHash >> word "REQUIRED" >> return REQUIRED) `onFail` -- ( tok TokHash >> word "IMPLIED" >> return IMPLIED) `onFail` -- ( do f <- maybe (tok TokHash >> word "FIXED" >> return FIXED) -- a <- attvalue -- return (DefaultTo a f)) -- --conditionalsect :: HParser ConditionalSect --conditionalsect = -- ( do tok TokSectionOpen -- tok (TokSection INCLUDEx) -- tok TokSqOpen `onFail` failP "missing [ after INCLUDE" -- i <- extsubsetdecl `onFail` failP "missing ExtSubsetDecl in INCLUDE" -- tok TokSectionClose `onFail` failP "missing ] after INCLUDE" -- return (IncludeSect i)) `onFail` -- ( do tok TokSectionOpen -- tok (TokSection IGNOREx) -- tok TokSqOpen `onFail` failP "missing [ after IGNORE" -- i <- many ignoresectcontents -- tok TokSectionClose `onFail` failP "missing ] after IGNORE" -- return (IgnoreSect i)) -- --ignoresectcontents :: HParser IgnoreSectContents --ignoresectcontents = do -- i <- ignore -- is <- many (do tok TokSectionOpen -- ic <- ignoresectcontents -- tok TokSectionClose -- ig <- ignore -- return (ic,ig)) -- return (IgnoreSectContents i is) -- --ignore :: HParser Ignore --ignore = freetext >>= return . Ignore reference :: HParser Reference reference = do bracket (tok TokAmp) (tok TokSemi) (freetext >>= val) where val ('#':'x':i) | all isHexDigit i = return . RefChar . fst . head . readHex $ i val ('#':i) | all isDigit i = return . RefChar . fst . head . readDec $ i val ent = return . RefEntity $ ent {- reference :: HParser Reference reference = ( charref >>= return . RefChar) `onFail` ( entityref >>= return . RefEntity) entityref :: HParser EntityRef entityref = do n <- bracket (tok TokAmp) (tok TokSemi) name return n charref :: HParser CharRef charref = do bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal) where readCharVal ('#':'x':i) = return . fst . head . readHex $ i readCharVal ('#':i) = return . fst . head . readDec $ i readCharVal _ = mzero -} --pereference :: HParser PEReference --pereference = do -- bracket (tok TokPercent) (tok TokSemi) nmtoken -- --entitydecl :: HParser EntityDecl --entitydecl = -- ( gedecl >>= return . EntityGEDecl) `onFail` -- ( pedecl >>= return . EntityPEDecl) -- --gedecl :: HParser GEDecl --gedecl = do -- tok TokSpecialOpen -- tok (TokSpecial ENTITYx) -- n <- name -- e <- entitydef `onFail` failP "missing entity defn in G ENTITY decl" -- tok TokAnyClose `onFail` failP "expected > terminating G ENTITY decl" -- return (GEDecl n e) -- --pedecl :: HParser PEDecl --pedecl = do -- tok TokSpecialOpen -- tok (TokSpecial ENTITYx) -- tok TokPercent -- n <- name -- e <- pedef `onFail` failP "missing entity defn in P ENTITY decl" -- tok TokAnyClose `onFail` failP "expected > terminating P ENTITY decl" -- return (PEDecl n e) -- --entitydef :: HParser EntityDef --entitydef = -- ( entityvalue >>= return . DefEntityValue) `onFail` -- ( do eid <- externalid -- ndd <- maybe ndatadecl -- return (DefExternalID eid ndd)) -- --pedef :: HParser PEDef --pedef = -- ( entityvalue >>= return . PEDefEntityValue) `onFail` -- ( externalid >>= return . PEDefExternalID) externalid :: HParser ExternalID externalid = ( do word "SYSTEM" s <- systemliteral return (SYSTEM s)) `onFail` ( do word "PUBLIC" p <- pubidliteral s <- (systemliteral `onFail` return (SystemLiteral "")) return (PUBLIC p s)) --ndatadecl :: HParser NDataDecl --ndatadecl = do -- word "NDATA" -- n <- name -- return (NDATA n) --textdecl :: HParser TextDecl --textdecl = do -- tok TokPIOpen -- (word "xml" `onFail` word "XML") -- v <- maybe versioninfo -- e <- encodingdecl -- tok TokPIClose `onFail` failP "expected ?> terminating text decl" -- return (TextDecl v e) --extparsedent :: HParser ExtParsedEnt --extparsedent = do -- t <- maybe textdecl -- (_,c) <- (content "") -- return (ExtParsedEnt t c) -- --extpe :: HParser ExtPE --extpe = do -- t <- maybe textdecl -- e <- extsubsetdecl -- return (ExtPE t e) encodingdecl :: HParser EncodingDecl encodingdecl = do (word "encoding" `onFail` word "ENCODING") tok TokEqual `onFail` failBadP "expected = in 'encoding' decl" f <- bracket (tok TokQuote) (tok TokQuote) freetext return (EncodingDecl f) --notationdecl :: HParser NotationDecl --notationdecl = do -- tok TokSpecialOpen -- word "NOTATION" -- n <- name -- e <- either externalid publicid -- tok TokAnyClose `onFail` failP "expected > terminating NOTATION decl" -- return (NOTATION n e) --publicid :: HParser PublicID --publicid = do -- word "PUBLICID" -- p <- pubidliteral -- return (PUBLICID p) --entityvalue :: HParser EntityValue --entityvalue = do -- evs <- bracket (tok TokQuote) (tok TokQuote) (many ev) -- return (EntityValue evs) --ev :: HParser EV --ev = -- ( freetext >>= return . EVString) `onFail` -- -- PEREF(EVPERef,ev) `onFail` -- ( reference >>= return . EVRef) attvalue :: HParser AttValue attvalue = ( do avs <- bracket (tok TokQuote) (tok TokQuote) (many (either freetext reference)) return (AttValue avs) ) `onFail` ( do v <- nmtoken s <- (tok TokPercent >> return "%") `onFail` return "" return (AttValue [Left (v++s)]) ) `onFail` ( do s <- oneOf [ tok TokPlus >> return "+" , tok TokHash >> return "#" ] v <- nmtoken return (AttValue [Left (s++v)]) ) `onFail` failP "Badly formatted attribute value" systemliteral :: HParser SystemLiteral systemliteral = do s <- bracket (tok TokQuote) (tok TokQuote) freetext return (SystemLiteral s) -- note: need to fold &...; escapes pubidliteral :: HParser PubidLiteral pubidliteral = do s <- bracket (tok TokQuote) (tok TokQuote) freetext return (PubidLiteral s) -- note: need to fold &...; escapes chardata :: HParser CharData chardata = freetext -- >>= return . CharData HaXml-1.23.3/src/Text/XML/HaXml/Html/Pretty.hs0000755000062000006210000002674311767644706020025 0ustar 1341796mkpasswd-- | This is a separate pretty-printer for HTML documents, recognising -- some of the differences between HTML and true XML. module Text.XML.HaXml.Html.Pretty ( document , element , attribute , content ) where import Prelude hiding (maybe,either) import Data.Maybe hiding (maybe) import Data.List (intersperse) import Data.Char (isSpace) import Text.PrettyPrint.HughesPJ import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces either :: (a->c) -> (b->c) -> Either a b -> c either f _g (Left x) = f x either _f g (Right x) = g x maybe :: (a->Doc) -> Maybe a -> Doc maybe _f Nothing = empty maybe f (Just x) = f x --peref p = text "%" <> text p <> text ";" ---- document :: Document i -> Doc prolog :: Prolog -> Doc xmldecl :: XMLDecl -> Doc misc :: Misc -> Doc sddecl :: Bool -> Doc doctypedecl :: DocTypeDecl -> Doc markupdecl :: MarkupDecl -> Doc --extsubset :: ExtSubset -> Doc --extsubsetdecl :: ExtSubsetDecl -> Doc element :: Element i -> Doc attribute :: Attribute -> Doc --etc content :: Content i -> Doc ---- document (Document p _ e m)= prolog p $$ element e $$ vcat (map misc m) prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$ vcat (map misc m1) $$ maybe doctypedecl dtd $$ vcat (map misc m2) xmldecl (XMLDecl v e sd) = text " text v <> text "'" <+> maybe encodingdecl e <+> maybe sddecl sd <+> text "?>" misc (Comment s) = text "" misc (PI (n,s)) = text " text n <+> text s <+> text "?>" sddecl sd | sd = text "standalone='yes'" | otherwise = text "standalone='no'" doctypedecl (DTD n eid ds) = if null ds then hd <> text ">" else hd <+> text " [" $$ vcat (map markupdecl ds) $$ text "]>" where hd = text " qname n <+> maybe externalid eid markupdecl (Element e) = elementdecl e markupdecl (AttList a) = attlistdecl a markupdecl (Entity e) = entitydecl e markupdecl (Notation n) = notationdecl n markupdecl (MarkupMisc m) = misc m --markupdecl (MarkupPE p m) = peref p --extsubset (ExtSubset t ds) = maybe textdecl t $$ -- vcat (map extsubsetdecl ds) --extsubsetdecl (ExtMarkupDecl m) = markupdecl m --extsubsetdecl (ExtConditionalSect c) = conditionalsect c -- --extsubsetdecl (ExtPEReference p e) = peref p element (Elem n as []) = text "<" <> qname n <+> fsep (map attribute as) <> text "/>" element e@(Elem n as cs) -- | any isText cs = text "<" <> qname n <+> fsep (map attribute as) <> -- text ">" <> hcat (map content cs) <> -- text " qname n <> text ">" | isText (head cs) = text "<" <> qname n <+> fsep (map attribute as) <> text ">" <> hcat (map content cs) <> text " qname n <> text ">" | otherwise = let (d,c) = carryelem e empty in d <> c isText :: Content i -> Bool isText (CString _ _ _) = True isText (CRef _ _) = True isText _ = False carryelem :: Element i -> Doc -> (Doc, Doc) carryelem (Elem n as []) c = ( c <> text "<" <> qname n <+> fsep (map attribute as) , text "/>") --carryelem e@(Elem n as cs) c ---- | any isText cs = ( c <> element e, empty) -- | otherwise = let (cs',d') = carryscan carrycontent cs (text ">") -- in -- ( c <> -- text "<" <> qname n <+> fsep (map attribute as) $$ -- nest 2 (vcat cs') <> -- $$ -- c' <> text " qname n -- , text ">") --carrycontent (CElem e) c = carryelem e c --carrycontent (CString _ s) c = (c <> chardata s, empty) --carrycontent (CRef r) c = (c <> reference r, empty) --carrycontent (CMisc m) c = (c <> misc m, empty) -- --carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c) --carryscan f [] c = ([],c) --carryscan f (a:as) c = let (b, c') = f a c -- (bs,c'') = carryscan f as c' -- in (b:bs, c'') carryelem (Elem n as cs) c | isText (head cs) = ( start <> text ">" <> hcat (map content cs) <> text " qname n , text ">") | otherwise = let (d,c') = foldl carrycontent (start, text ">") cs in ( d <> c' <> text " qname n , text ">") where start = c <> text "<" <> qname n <+> fsep (map attribute as) carrycontent :: (Doc, Doc) -> Content i -> (Doc, Doc) carrycontent (d,c) (CElem e _) = let (d',c') = carryelem e c in (d $$ nest 2 d', c') carrycontent (d,c) (CString _ s _) = (d <> c <> chardata s, empty) carrycontent (d,c) (CRef r _) = (d <> c <> reference r,empty) carrycontent (d,c) (CMisc m _) = (d $$ c <> misc m, empty) attribute (n,v) = qname n <> text "=" <> attvalue v content (CElem e _) = element e content (CString _ s _) = chardata s content (CRef r _) = reference r content (CMisc m _) = misc m elementdecl :: ElementDecl -> Doc contentspec :: ContentSpec -> Doc cp :: CP -> Doc modifier :: Modifier -> Doc mixed :: Mixed -> Doc attlistdecl :: AttListDecl -> Doc attdef :: AttDef -> Doc atttype :: AttType -> Doc tokenizedtype :: TokenizedType -> Doc enumeratedtype :: EnumeratedType -> Doc notationtype :: [String] -> Doc enumeration :: [String] -> Doc defaultdecl :: DefaultDecl -> Doc reference :: Reference -> Doc entityref :: String -> Doc charref :: (Show a) => a -> Doc entitydecl :: EntityDecl -> Doc gedecl :: GEDecl -> Doc pedecl :: PEDecl -> Doc entitydef :: EntityDef -> Doc pedef :: PEDef -> Doc externalid :: ExternalID -> Doc ndatadecl :: NDataDecl -> Doc notationdecl :: NotationDecl -> Doc publicid :: PublicID -> Doc encodingdecl :: EncodingDecl -> Doc nmtoken :: String -> Doc attvalue :: AttValue -> Doc entityvalue :: EntityValue -> Doc ev :: EV -> Doc pubidliteral :: PubidLiteral -> Doc systemliteral :: SystemLiteral -> Doc chardata :: [Char] -> Doc elementdecl (ElementDecl n cs) = text " qname n <+> contentspec cs <> text ">" contentspec EMPTY = text "EMPTY" contentspec ANY = text "ANY" contentspec (Mixed m) = mixed m contentspec (ContentSpec c) = cp c --contentspec (ContentPE p cs) = peref p cp (TagName n m) = qname n <> modifier m cp (Choice cs m) = parens (hcat (intersperse (text "|") (map cp cs))) <> modifier m cp (Seq cs m) = parens (hcat (intersperse (text ",") (map cp cs))) <> modifier m --cp (CPPE p c) = peref p modifier None = empty modifier Query = text "?" modifier Star = text "*" modifier Plus = text "+" mixed PCDATA = text "(#PCDATA)" mixed (PCDATAplus ns) = text "(#PCDATA |" <+> hcat (intersperse (text "|") (map qname ns)) <> text ")*" attlistdecl (AttListDecl n ds) = text " qname n <+> fsep (map attdef ds) <> text ">" attdef (AttDef n t d) = qname n <+> atttype t <+> defaultdecl d atttype StringType = text "CDATA" atttype (TokenizedType t) = tokenizedtype t atttype (EnumeratedType t) = enumeratedtype t tokenizedtype ID = text "ID" tokenizedtype IDREF = text "IDREF" tokenizedtype IDREFS = text "IDREFS" tokenizedtype ENTITY = text "ENTITY" tokenizedtype ENTITIES = text "ENTITIES" tokenizedtype NMTOKEN = text "NMTOKEN" tokenizedtype NMTOKENS = text "NMTOKENS" enumeratedtype (NotationType n)= notationtype n enumeratedtype (Enumeration e) = enumeration e notationtype ns = text "NOTATION" <+> parens (hcat (intersperse (text "|") (map text ns))) enumeration ns = parens (hcat (intersperse (text "|") (map nmtoken ns))) defaultdecl REQUIRED = text "#REQUIRED" defaultdecl IMPLIED = text "#IMPLIED" defaultdecl (DefaultTo a f) = maybe (const (text "#FIXED")) f <+> attvalue a --conditionalsect (IncludeSect i)= text " -- vcat (map extsubsetdecl i) <+> text "]]>" --conditionalsect (IgnoreSect i) = text " -- fsep (map ignoresectcontents i) <+> text "]]>" --ignore (Ignore) = empty --ignoresectcontents (IgnoreSectContents i is) -- = ignore i <+> vcat (map internal is) -- where internal (ics,i) = text " -- ignoresectcontents ics <+> -- text "]]>" <+> ignore i reference (RefEntity er) = entityref er reference (RefChar cr) = charref cr entityref n = text "&" <> text n <> text ";" charref c = text "&#" <> text (show c) <> text ";" entitydecl (EntityGEDecl d) = gedecl d entitydecl (EntityPEDecl d) = pedecl d gedecl (GEDecl n ed) = text " text n <+> entitydef ed <> text ">" pedecl (PEDecl n pd) = text " text n <+> pedef pd <> text ">" entitydef (DefEntityValue ev) = entityvalue ev entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd pedef (PEDefEntityValue ev) = entityvalue ev pedef (PEDefExternalID eid) = externalid eid externalid (SYSTEM sl) = text "SYSTEM" <+> systemliteral sl externalid (PUBLIC i sl) = text "PUBLIC" <+> pubidliteral i <+> systemliteral sl ndatadecl (NDATA n) = text "NDATA" <+> text n --textdecl (TextDecl vi ed) = text " maybe text vi <+> -- encodingdecl ed <> text "?>" --extparsedent (ExtParsedEnt t c)= maybe textdecl t <+> content c --extpe (ExtPE t esd) = maybe textdecl t <+> -- vcat (map extsubsetdecl esd) notationdecl (NOTATION n e) = text " text n <+> either externalid publicid e <> text ">" publicid (PUBLICID p) = text "PUBLICID" <+> pubidliteral p encodingdecl (EncodingDecl s) = text "encoding='" <> text s <> text "'" nmtoken s = text s attvalue (AttValue esr) = text "\"" <> hcat (map (either text reference) esr) <> text "\"" entityvalue (EntityValue evs) = text "'" <> hcat (map ev evs) <> text "'" ev (EVString s) = text s --ev (EVPERef p e) = peref p ev (EVRef r) = reference r pubidliteral (PubidLiteral s) = text "'" <> text s <> text "'" systemliteral (SystemLiteral s)= text "'" <> text s <> text "'" chardata s = if all isSpace s then empty else text s --cdsect c = text " chardata c <> text "]]>" qname n = text (printableName n) ---- HaXml-1.23.3/src/Text/XML/HaXml/Lex.hs0000755000062000006210000003557211767644706016362 0ustar 1341796mkpasswd-- | You don't normally need to use this Lex module directly - it is -- called automatically by the parser. (This interface is only exposed -- for debugging purposes.) -- -- This is a hand-written lexer for tokenising the text of an XML -- document so that it is ready for parsing. It attaches position -- information in (line,column) format to every token. The main -- entry point is 'xmlLex'. A secondary entry point, 'xmlReLex', is -- provided for when the parser needs to stuff a string back onto -- the front of the text and re-tokenise it (typically when expanding -- macros). -- -- As one would expect, the lexer is essentially a small finite -- state machine. module Text.XML.HaXml.Lex ( -- * Entry points to the lexer xmlLex -- :: String -> String -> [Token] , xmlReLex -- :: Posn -> String -> [Token] , reLexEntityValue -- :: (String->Maybe String) -> Posn -> String -> [Token] -- * Token types , Token , TokenT(..) , Special(..) , Section(..) ) where import Data.Char import Text.XML.HaXml.Posn data Where = InTag String | NotInTag deriving (Eq) -- | All tokens are paired up with a source position. -- Lexical errors are passed back as a special @TokenT@ value. type Token = (Posn, TokenT) -- | The basic token type. data TokenT = TokCommentOpen -- ^ \ | TokPIOpen -- ^ \ | TokSectionOpen -- ^ \ | TokSection Section -- ^ CDATA INCLUDE IGNORE etc | TokSpecialOpen -- ^ \ | TokAnyOpen -- ^ \< | TokAnyClose -- ^ > | TokSqOpen -- ^ \[ | TokSqClose -- ^ \] | TokEqual -- ^ = | TokQuery -- ^ ? | TokStar -- ^ \* | TokPlus -- ^ + | TokAmp -- ^ & | TokSemi -- ^ ; | TokHash -- ^ # | TokBraOpen -- ^ ( | TokBraClose -- ^ ) | TokPipe -- ^ | | TokPercent -- ^ % | TokComma -- ^ , | TokQuote -- ^ \'\' or \"\" | TokName String -- ^ begins with letter, no spaces | TokFreeText String -- ^ any character data | TokNull -- ^ fake token | TokError String -- ^ lexical error deriving (Eq) data Special = DOCTYPEx | ELEMENTx | ATTLISTx | ENTITYx | NOTATIONx deriving (Eq,Show) data Section = CDATAx | INCLUDEx | IGNOREx deriving (Eq,Show) instance Show TokenT where showsPrec _p TokCommentOpen = showString "" showsPrec _p TokPIOpen = showString "" showsPrec _p TokSectionOpen = showString "" showsPrec p (TokSection s) = showsPrec p s showsPrec _p TokSpecialOpen = showString "" showsPrec _p TokAnyOpen = showString "<" showsPrec _p TokAnyClose = showString ">" showsPrec _p TokSqOpen = showString "[" showsPrec _p TokSqClose = showString "]" showsPrec _p TokEqual = showString "=" showsPrec _p TokQuery = showString "?" showsPrec _p TokStar = showString "*" showsPrec _p TokPlus = showString "+" showsPrec _p TokAmp = showString "&" showsPrec _p TokSemi = showString ";" showsPrec _p TokHash = showString "#" showsPrec _p TokBraOpen = showString "(" showsPrec _p TokBraClose = showString ")" showsPrec _p TokPipe = showString "|" showsPrec _p TokPercent = showString "%" showsPrec _p TokComma = showString "," showsPrec _p TokQuote = showString "' or \"" showsPrec _p (TokName s) = showString s showsPrec _p (TokFreeText s) = showString s showsPrec _p TokNull = showString "(null)" showsPrec _p (TokError s) = showString s --trim, revtrim :: String -> String --trim = f . f where f = reverse . dropWhile isSpace --revtrim = f.reverse.f where f = dropWhile isSpace --revtrim = reverse . dropWhile (=='\n') -- most recently used defn. emit :: TokenT -> Posn -> Token emit tok p = forcep p `seq` (p,tok) lexerror :: String -> Posn -> [Token] lexerror s p = [(p, TokError ("Lexical error:\n "++s))] skip :: Int -> Posn -> String -> (Posn->String->[Token]) -> [Token] skip n p s k = k (addcol n p) (drop n s) blank :: ([Where]->Posn->String->[Token]) -> [Where]-> Posn-> String-> [Token] blank _ (InTag t:_) p [] = lexerror ("unexpected EOF within "++t) p blank _ _ _ [] = [] blank k w p (' ': s) = blank k w (addcol 1 p) s blank k w p ('\t':s) = blank k w (tab p) s blank k w p ('\n':s) = blank k w (newline p) s blank k w p ('\r':s) = blank k w p s blank k w p ('\xa0': s) = blank k w (addcol 1 p) s blank k w p s = k w p s prefixes :: String -> String -> Bool [] `prefixes` _ = True (x:xs) `prefixes` (y:ys) = x==y && xs `prefixes` ys (_:_) `prefixes` [] = False --error "unexpected EOF in prefix" textUntil, textOrRefUntil :: [Char] -> TokenT -> [Char] -> Posn -> Posn -> [Char] -> (Posn->String->[Token]) -> [Token] textUntil close _tok _acc pos p [] _k = lexerror ("unexpected EOF while looking for closing token "++close ++"\n to match the opening token in "++show pos) p textUntil close tok acc pos p (s:ss) k | close `prefixes` (s:ss) = emit (TokFreeText (reverse acc)) pos: emit tok p: skip (length close-1) (addcol 1 p) ss k | isSpace s = textUntil close tok (s:acc) pos (white s p) ss k | otherwise = textUntil close tok (s:acc) pos (addcol 1 p) ss k textOrRefUntil close _tok _acc pos p [] _k = lexerror ("unexpected EOF while looking for closing token "++close ++"\n to match the opening token in "++show pos) p textOrRefUntil close tok acc pos p (s:ss) k | close `prefixes` (s:ss) = emit (TokFreeText (reverse acc)) pos: emit tok p: skip (length close-1) (addcol 1 p) ss k | s=='&' = (if not (null acc) then (emit (TokFreeText (reverse acc)) pos:) else id) (emit TokAmp p: textUntil ";" TokSemi "" p (addcol 1 p) ss (\p' i-> textOrRefUntil close tok "" p p' i k)) | isSpace s = textOrRefUntil close tok (s:acc) pos (white s p) ss k | otherwise = textOrRefUntil close tok (s:acc) pos (addcol 1 p) ss k ---- -- | The first argument to 'xmlLex' is the filename (used for source positions, -- especially in error messages), and the second is the string content of -- the XML file. xmlLex :: String -> String -> [Token] xmlLex filename = xmlAny [] (posInNewCxt filename Nothing) -- | 'xmlReLex' is used when the parser expands a macro (PE reference). -- The expansion of the macro must be re-lexed as if for the first time. xmlReLex :: Posn -> String -> [Token] xmlReLex p s | "INCLUDE" `prefixes` s = emit (TokSection INCLUDEx) p: k 7 | "IGNORE" `prefixes` s = emit (TokSection IGNOREx) p: k 6 | otherwise = blank xmlAny [] p s where k n = skip n p s (blank xmlAny []) -- | 'reLexEntityValue' is used solely within parsing an entityvalue. -- Normally, a PERef is logically separated from its surroundings by -- whitespace. But in an entityvalue, a PERef can be juxtaposed to -- an identifier, so the expansion forms a new identifier. -- Thus the need to rescan the whole text for possible PERefs. reLexEntityValue :: (String->Maybe String) -> Posn -> String -> [Token] reLexEntityValue lookup p s = textOrRefUntil "%" TokNull [] p p (expand s++"%") (xmlAny []) where expand [] = [] expand ('%':xs) = let (sym,rest) = break (==';') xs in case lookup sym of Just val -> expand val ++ expand (tail rest) Nothing -> "%"++sym++";"++ expand (tail rest) -- hmmm expand (x:xs) = x: expand xs --xmltop :: Posn -> String -> [Token] --xmltop p [] = [] --xmltop p s -- | ""]) -- | "" TokCommentClose "" p p s (blank xmlAny w) -- Note: the order of the clauses in xmlAny is very important. -- Some matches must precede the NotInTag test, the rest must follow it. xmlAny (InTag t:_) p [] = lexerror ("unexpected EOF within "++t) p xmlAny _ _ [] = [] xmlAny w p s@('<':ss) | "?" `prefixes` ss = emit TokPIOpen p: skip 2 p s (xmlPI (InTag "":w)) | "!--" `prefixes` ss = emit TokCommentOpen p: skip 4 p s (xmlComment w) | "![" `prefixes` ss = emit TokSectionOpen p: skip 3 p s (xmlSection w) | "!" `prefixes` ss = emit TokSpecialOpen p: skip 2 p s (xmlSpecial (InTag "":w)) | "/" `prefixes` ss = emit TokEndOpen p: skip 2 p s (xmlTag (InTag "":tail w)) | otherwise = emit TokAnyOpen p: skip 1 p s (xmlTag (InTag "<...>":NotInTag:w)) xmlAny (_:_:w) p s@('/':ss) | ">" `prefixes` ss = emit TokEndClose p: skip 2 p s (xmlAny w) xmlAny w p ('&':ss) = emit TokAmp p: textUntil ";" TokSemi "" p (addcol 1 p) ss (xmlAny w) xmlAny w@(NotInTag:_) p s = xmlContent "" w p p s -- everything below here is implicitly InTag. xmlAny w p ('>':ss) = emit TokAnyClose p: xmlAny (tail w) (addcol 1 p) ss xmlAny w p ('[':ss) = emit TokSqOpen p: blank xmlAny (InTag "[...]":w) (addcol 1 p) ss xmlAny w p (']':ss) | "]>" `prefixes` ss = emit TokSectionClose p: skip 3 p (']':ss) (xmlAny (tail w)) | otherwise = emit TokSqClose p: blank xmlAny (tail w) (addcol 1 p) ss xmlAny w p ('(':ss) = emit TokBraOpen p: blank xmlAny (InTag "(...)":w) (addcol 1 p) ss xmlAny w p (')':ss) = emit TokBraClose p: blank xmlAny (tail w) (addcol 1 p) ss xmlAny w p ('=':ss) = emit TokEqual p: blank xmlAny w (addcol 1 p) ss xmlAny w p ('*':ss) = emit TokStar p: blank xmlAny w (addcol 1 p) ss xmlAny w p ('+':ss) = emit TokPlus p: blank xmlAny w (addcol 1 p) ss xmlAny w p ('?':ss) = emit TokQuery p: blank xmlAny w (addcol 1 p) ss xmlAny w p ('|':ss) = emit TokPipe p: blank xmlAny w (addcol 1 p) ss xmlAny w p ('%':ss) = emit TokPercent p: blank xmlAny w (addcol 1 p) ss xmlAny w p (';':ss) = emit TokSemi p: blank xmlAny w (addcol 1 p) ss xmlAny w p (',':ss) = emit TokComma p: blank xmlAny w (addcol 1 p) ss xmlAny w p ('#':ss) = emit TokHash p: blank xmlAny w (addcol 1 p) ss xmlAny w p ('"':ss) = emit TokQuote p: textOrRefUntil "\"" TokQuote "" p1 p1 ss (xmlAny w) where p1 = addcol 1 p xmlAny w p ('\'':ss) = emit TokQuote p: textOrRefUntil "'" TokQuote "" p1 p1 ss (xmlAny w) where p1 = addcol 1 p xmlAny w p s | isSpace (head s) = blank xmlAny w p s | isAlphaNum (head s) || (head s)`elem`":_" = xmlName p s "some kind of name" (blank xmlAny w) | otherwise = lexerror ("unrecognised token: "++take 4 s) p xmlTag w p s = xmlName p s "tagname for element in < >" (blank xmlAny w) xmlSection = blank xmlSection0 where xmlSection0 w p s | "CDATA[" `prefixes` s = emit (TokSection CDATAx) p: accum w p s 6 | "INCLUDE" `prefixes` s = emit (TokSection INCLUDEx) p: k w p s 7 | "IGNORE" `prefixes` s = emit (TokSection IGNOREx) p: k w p s 6 | "%" `prefixes` s = emit TokPercent p: k w p s 1 | otherwise = lexerror ("expected CDATA, IGNORE, or INCLUDE, but got " ++take 7 s) p accum w p s n = let p0 = addcol n p in textUntil "]]>" TokSectionClose "" p0 p0 (drop n s) (blank xmlAny w) k w p s n = skip n p s (xmlAny ({-InTag "": -}w)) xmlSpecial w p s | "DOCTYPE" `prefixes` s = emit (TokSpecial DOCTYPEx) p: k 7 | "ELEMENT" `prefixes` s = emit (TokSpecial ELEMENTx) p: k 7 | "ATTLIST" `prefixes` s = emit (TokSpecial ATTLISTx) p: k 7 | "ENTITY" `prefixes` s = emit (TokSpecial ENTITYx) p: k 6 | "NOTATION" `prefixes` s = emit (TokSpecial NOTATIONx) p: k 8 | otherwise = lexerror ("expected DOCTYPE, ELEMENT, ENTITY, ATTLIST, or NOTATION," ++" but got "++take 7 s) p where k n = skip n p s (blank xmlAny w) xmlName :: Posn -> [Char] -> [Char] -> (Posn->[Char]->[Token]) -> [Token] xmlName p (s:ss) cxt k | isAlphaNum s || s==':' || s=='_' = gatherName (s:[]) p (addcol 1 p) ss k | otherwise = lexerror ("expected a "++cxt++", but got char "++show s) p where gatherName acc pos p [] k = emit (TokName (reverse acc)) pos: k p [] -- lexerror ("unexpected EOF in name at "++show pos) p gatherName acc pos p (s:ss) k | isAlphaNum s || s `elem` ".-_:" = gatherName (s:acc) pos (addcol 1 p) ss k | otherwise = emit (TokName (reverse acc)) pos: k p (s:ss) xmlName p [] cxt _ = lexerror ("expected a "++cxt++", but got end of input") p xmlContent :: [Char] -> [Where] -> Posn -> Posn -> [Char] -> [Token] xmlContent acc _w _pos p [] = if all isSpace acc then [] else lexerror "unexpected EOF between tags" p xmlContent acc w pos p (s:ss) | elem s "<&" = {- if all isSpace acc then xmlAny w p (s:ss) else -} emit (TokFreeText (reverse acc)) pos: xmlAny w p (s:ss) | isSpace s = xmlContent (s:acc) w pos (white s p) ss | otherwise = xmlContent (s:acc) w pos (addcol 1 p) ss --ident :: (String->TokenT) -> -- Posn -> String -> [String] -> -- (Posn->String->[String]->[Token]) -> [Token] --ident tok p s ss k = -- let (name,s0) = span (\c-> isAlphaNum c || c `elem` "`-_#.'/\\") s -- in emit (tok name) p: skip (length name) p s ss k HaXml-1.23.3/src/Text/XML/HaXml/Namespaces.hs0000755000062000006210000002033311767644706017676 0ustar 1341796mkpasswd{-# LANGUAGE PatternGuards #-} module Text.XML.HaXml.Namespaces ( nullNamespace , expandedName , namespaceName , localName , printableName , qualify , deQualify , qualifyExceptLocal , initNamespaceEnv , augmentNamespaceEnv , resolveAllNames ) where import Prelude hiding (lookup) import Text.XML.HaXml.Types import Data.Map as Map (Map, insert, lookup, empty) import Data.List (isPrefixOf) -- | The null Namespace (no prefix, no URI). nullNamespace :: Namespace nullNamespace = Namespace { nsPrefix="", nsURI="" } -- | Every Name can be split into a Namespace and local Name. The Namespace -- might of course be missing. expandedName :: QName -> (Maybe Namespace, String) expandedName n = (namespaceName n, localName n) -- | Return the (possibly absent) Namespace component of a Name. namespaceName :: QName -> Maybe Namespace namespaceName (N _) = Nothing namespaceName (QN ns _) = Just ns -- | Return the local component of a Name, without its Namespace. localName :: QName -> String --localName (N n) | ':'`elem`n = tail $ dropWhile (/=':') n localName (N n) = n localName (QN _ n) = n -- | Return the printable string for a Name, i.e. attaching a prefix -- for its namespace (if it has one). printableName :: QName -> String printableName (N n) = n printableName (QN ns n) | null (nsPrefix ns) = n | otherwise = nsPrefix ns++':':n -- | 'qualify' splits a Name of the form "pr:nm" into the -- prefix "pr" and local name "nm", and looks up the prefix in the -- given environment to determine its Namespace. There may also be a -- default namespace (the first argument) for unqualified names. -- In the absence of a default Namespace, a Name that does not have -- a prefix remains unqualified. A prefix that is not known in the -- environment becomes a fresh namespace with null URI. A Name that is -- already qualified is passed unchanged, unless its URI was null, in -- which case we check afresh for that prefix in the environment. qualify :: Maybe Namespace -> Map String Namespace -> QName -> QName qualify def env (N n) | ':'`elem`n = let (pre,':':nm) = span (/=':') n in QN (maybe nullNamespace{nsPrefix=pre} id (Map.lookup pre env)) nm | Just d <- def = QN d n | otherwise = N n qualify _ env qn@(QN ns n) | null (nsURI ns) = QN (maybe ns id (Map.lookup (nsPrefix ns) env)) n | otherwise = qn -- | 'deQualify' has the same signature as 'qualify', but ignores the -- arguments for default namespace and environment, and simply removes any -- pre-existing qualification. deQualify :: Maybe Namespace -> Map String Namespace -> QName -> QName deQualify _ _ (QN _ n) = N n deQualify _ _ (N n) = N n -- | 'qualifyExceptLocal' converts names to qualified names, except where -- an existing qualification matches the default namespace, in which case -- the qualification is removed. (This is useful when translating QNames -- to Haskell, because Haskell qualified names cannot use the current -- module name.) qualifyExceptLocal :: Maybe Namespace -> Map String Namespace -> QName -> QName qualifyExceptLocal Nothing env qn = qualify Nothing env qn qualifyExceptLocal (Just def) env (N n) | ':'`elem`n = let (pre,':':nm) = span (/=':') n in if nsPrefix def == pre then N nm else QN (maybe nullNamespace{nsPrefix=pre} id (Map.lookup pre env)) nm | otherwise = N n qualifyExceptLocal (Just def) env qn@(QN ns n) | def==ns = N n | null (nsURI ns) = QN (maybe ns id (Map.lookup (nsPrefix ns) env)) n | otherwise = qn -- | The initial Namespace environment. It always has bindings for the -- prefixes 'xml' and 'xmlns'. initNamespaceEnv :: Map String Namespace initNamespaceEnv = Map.insert "xmlns" Namespace{nsPrefix="xmlns" ,nsURI="http://www.w3.org/2000/xmlns/"} $ Map.insert "xml" Namespace{nsPrefix="xml" ,nsURI="http://www.w3.org/XML/1998/namespace"} $ Map.empty -- | Add a fresh Namespace into the Namespace environment. It is not -- permitted to rebind the prefixes 'xml' or 'xmlns', but that is not -- checked here. augmentNamespaceEnv :: Namespace -> Map String Namespace -> Map String Namespace augmentNamespaceEnv ns env = Map.insert (nsPrefix ns) ns env {- augmentNamespaceEnv :: Namespace -> Map String Namespace -> Either String (Map String Namespace) augmentNamespaceEnv ns env | nsPrefix ns == "xml" = Left "cannot rebind the 'xml' namespace" | nsPrefix ns == "xmlns" = Left "cannot rebind the 'xmlns' namespace" | otherwise = Right (Map.insert (nsPrefix ns) ns env) -} -- | resolveAllNames in a document, causes every name to be properly -- qualified with its namespace. There is a default namespace for any -- name that was originally unqualified. This is likely only useful when -- dealing with parsed document, less useful when generating a document -- from scratch. resolveAllNames :: (Maybe Namespace -> Map String Namespace -> QName -> QName) -> Document i -> Document i resolveAllNames qualify (Document prolog entities elm misc) = Document (walkProlog prolog) entities (walkElem Nothing initNamespaceEnv elm) misc where qualifyInDTD = qualify Nothing initNamespaceEnv walkProlog (Prolog xml misc0 mDTD misc1) = Prolog xml misc0 (maybe Nothing (Just . walkDTD) mDTD) misc1 walkDTD (DTD qn ext mds) = DTD (qualifyInDTD qn) ext (map walkMD mds) -- walkMD (Element ed) = Element (walkED ed) walkMD (AttList ald) = AttList (walkALD ald) walkMD md = md -- walkED (ElementDecl qn cs) = ElementDecl (qualifyInDTD qn) (walkCS cs) -- walkCS (ContentSpec cp) = ContentSpec (walkCP cp) walkCS (Mixed m) = Mixed (walkM m) walkCS cs = cs -- walkCP (TagName qn m) = TagName (qualifyInDTD qn) m walkCP cp = cp -- walkM (PCDATAplus qns) = PCDATAplus (map qualifyInDTD qns) walkM PCDATA = PCDATA -- walkALD (AttListDecl qn ads) = AttListDecl (qualifyInDTD qn) (map walkAD ads) -- walkAD (AttDef qn at dd) = AttDef (qualifyInDTD qn) at dd -- walkElem def env (Elem qn attrs conts) = Elem (qualify def' env' qn) (map (\ (a,v)-> (qualify Nothing env' a, v)) attrs) (map (walkContent def' env') conts) where def' = foldr const def -- like "maybe def head", but for lists (map defNamespace (matching (=="xmlns") attrs)) env' = foldr augmentNamespaceEnv env (map mkNamespace (matching ("xmlns:"`isPrefixOf`) attrs)) defNamespace :: Attribute -> Maybe Namespace defNamespace (_ {-N "xmlns"-}, atv) | null (show atv) = Nothing | otherwise = Just nullNamespace{nsURI=show atv} mkNamespace :: Attribute -> Namespace mkNamespace (N n, atv) = let (_,':':nm) = span (/=':') n in Namespace{nsPrefix=nm,nsURI=show atv} matching :: (String->Bool) -> [Attribute] -> [Attribute] matching p = filter (p . printableName . fst) -- walkContent def env (CElem e i) = CElem (walkElem def env e) i walkContent _ _ content = content -- Notes: we DO NOT CHECK some of the Namespace well-formedness conditions: -- Prefix Declared -- No Prefix Undeclaring -- Attributes Unique -- The functions defNamespace and mkNamespace are partial - they do not -- handle the QN case - but this is OK because they are only called from -- def' and env', which check the precondition HaXml-1.23.3/src/Text/XML/HaXml/OneOfN.hs0000755000062000006210000013044111767644706016745 0ustar 1341796mkpasswdmodule Text.XML.HaXml.OneOfN where import Text.XML.HaXml.XmlContent -- | Somewhat of a nonsense - a choice of a single item. But sometimes it -- occurs in auto-generated code. data OneOf1 a = OneOf1 a deriving (Eq,Show) instance (HTypeable a) => HTypeable (OneOf1 a) where toHType _ = Defined "OneOf1" [] [] -- toHType m = Defined "OneOf1" [a] [] -- where a = toHType $ (\ (OneOf1 a)->a) $ m instance (XmlContent a) => XmlContent (OneOf1 a) where parseContents = (choice OneOf1 $ fail "OneOf1") toContents (OneOf1 x) = toContents x foldOneOf1 :: (a->z) -> OneOf1 a -> z foldOneOf1 a (OneOf1 z) = a z ---- -- | Equivalent to the Either type, but using the regular naming -- scheme of this module. data OneOf2 a b = OneOf2 a | TwoOf2 b deriving (Eq,Show) instance (HTypeable a,HTypeable b) => HTypeable (OneOf2 a b) where toHType _ = Defined "OneOf2" [] [] -- toHType m = Defined "OneOf2" [a,b] [] -- where a = toHType $ (\ (OneOf2 a)->a) $ m -- b = toHType $ (\ (TwoOf2 b)->b) $ m instance (XmlContent a,XmlContent b) => XmlContent (OneOf2 a b) where parseContents = (choice OneOf2 $ choice TwoOf2 $ fail "OneOf2") toContents (OneOf2 x) = toContents x toContents (TwoOf2 x) = toContents x foldOneOf2 :: (a->z) -> (b->z) -> OneOf2 a b -> z foldOneOf2 a b (OneOf2 z) = a z foldOneOf2 a b (TwoOf2 z) = b z ---- data OneOf3 a b c = OneOf3 a | TwoOf3 b | ThreeOf3 c deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c) => HTypeable (OneOf3 a b c) where toHType _ = Defined "OneOf3" [] [] instance (XmlContent a,XmlContent b,XmlContent c) => XmlContent (OneOf3 a b c) where parseContents = (choice OneOf3 $ choice TwoOf3 $ choice ThreeOf3 $ fail "OneOf3") toContents (OneOf3 x) = toContents x toContents (TwoOf3 x) = toContents x toContents (ThreeOf3 x) = toContents x foldOneOf3 :: (a->z) -> (b->z) -> (c->z) -> OneOf3 a b c -> z foldOneOf3 a b c (OneOf3 z) = a z foldOneOf3 a b c (TwoOf3 z) = b z foldOneOf3 a b c (ThreeOf3 z) = c z ---- data OneOf4 a b c d = OneOf4 a | TwoOf4 b | ThreeOf4 c | FourOf4 d deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d) => HTypeable (OneOf4 a b c d) where toHType _ = Defined "OneOf4" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d) => XmlContent (OneOf4 a b c d) where parseContents = (choice OneOf4 $ choice TwoOf4 $ choice ThreeOf4 $ choice FourOf4 $ fail "OneOf4") toContents (OneOf4 x) = toContents x toContents (TwoOf4 x) = toContents x toContents (ThreeOf4 x) = toContents x toContents (FourOf4 x) = toContents x foldOneOf4 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> OneOf4 a b c d -> z foldOneOf4 a b c d (OneOf4 z) = a z foldOneOf4 a b c d (TwoOf4 z) = b z foldOneOf4 a b c d (ThreeOf4 z) = c z foldOneOf4 a b c d (FourOf4 z) = d z ---- data OneOf5 a b c d e = OneOf5 a | TwoOf5 b | ThreeOf5 c | FourOf5 d | FiveOf5 e deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e) => HTypeable (OneOf5 a b c d e) where toHType _ = Defined "OneOf5" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e) => XmlContent (OneOf5 a b c d e) where parseContents = (choice OneOf5 $ choice TwoOf5 $ choice ThreeOf5 $ choice FourOf5 $ choice FiveOf5 $ fail "OneOf5") toContents (OneOf5 x) = toContents x toContents (TwoOf5 x) = toContents x toContents (ThreeOf5 x) = toContents x toContents (FourOf5 x) = toContents x toContents (FiveOf5 x) = toContents x foldOneOf5 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> OneOf5 a b c d e -> z foldOneOf5 a b c d e (OneOf5 z) = a z foldOneOf5 a b c d e (TwoOf5 z) = b z foldOneOf5 a b c d e (ThreeOf5 z) = c z foldOneOf5 a b c d e (FourOf5 z) = d z foldOneOf5 a b c d e (FiveOf5 z) = e z ---- data OneOf6 a b c d e f = OneOf6 a | TwoOf6 b | ThreeOf6 c | FourOf6 d | FiveOf6 e | SixOf6 f deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f) => HTypeable (OneOf6 a b c d e f) where toHType _ = Defined "OneOf6" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f) => XmlContent (OneOf6 a b c d e f) where parseContents = (choice OneOf6 $ choice TwoOf6 $ choice ThreeOf6 $ choice FourOf6 $ choice FiveOf6 $ choice SixOf6 $ fail "OneOf6") toContents (OneOf6 x) = toContents x toContents (TwoOf6 x) = toContents x toContents (ThreeOf6 x) = toContents x toContents (FourOf6 x) = toContents x toContents (FiveOf6 x) = toContents x toContents (SixOf6 x) = toContents x foldOneOf6 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> OneOf6 a b c d e f -> z foldOneOf6 a b c d e f (OneOf6 z) = a z foldOneOf6 a b c d e f (TwoOf6 z) = b z foldOneOf6 a b c d e f (ThreeOf6 z) = c z foldOneOf6 a b c d e f (FourOf6 z) = d z foldOneOf6 a b c d e f (FiveOf6 z) = e z foldOneOf6 a b c d e f (SixOf6 z) = f z ---- data OneOf7 a b c d e f g = OneOf7 a | TwoOf7 b | ThreeOf7 c | FourOf7 d | FiveOf7 e | SixOf7 f | SevenOf7 g deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g) => HTypeable (OneOf7 a b c d e f g) where toHType _ = Defined "OneOf7" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g) => XmlContent (OneOf7 a b c d e f g) where parseContents = (choice OneOf7 $ choice TwoOf7 $ choice ThreeOf7 $ choice FourOf7 $ choice FiveOf7 $ choice SixOf7 $ choice SevenOf7 $ fail "OneOf7") toContents (OneOf7 x) = toContents x toContents (TwoOf7 x) = toContents x toContents (ThreeOf7 x) = toContents x toContents (FourOf7 x) = toContents x toContents (FiveOf7 x) = toContents x toContents (SixOf7 x) = toContents x toContents (SevenOf7 x) = toContents x foldOneOf7 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> OneOf7 a b c d e f g -> z foldOneOf7 a b c d e f g (OneOf7 z) = a z foldOneOf7 a b c d e f g (TwoOf7 z) = b z foldOneOf7 a b c d e f g (ThreeOf7 z) = c z foldOneOf7 a b c d e f g (FourOf7 z) = d z foldOneOf7 a b c d e f g (FiveOf7 z) = e z foldOneOf7 a b c d e f g (SixOf7 z) = f z foldOneOf7 a b c d e f g (SevenOf7 z) = g z ---- data OneOf8 a b c d e f g h = OneOf8 a | TwoOf8 b | ThreeOf8 c | FourOf8 d | FiveOf8 e | SixOf8 f | SevenOf8 g | EightOf8 h deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h) => HTypeable (OneOf8 a b c d e f g h) where toHType _ = Defined "OneOf8" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h) => XmlContent (OneOf8 a b c d e f g h) where parseContents = (choice OneOf8 $ choice TwoOf8 $ choice ThreeOf8 $ choice FourOf8 $ choice FiveOf8 $ choice SixOf8 $ choice SevenOf8 $ choice EightOf8 $ fail "OneOf8") toContents (OneOf8 x) = toContents x toContents (TwoOf8 x) = toContents x toContents (ThreeOf8 x) = toContents x toContents (FourOf8 x) = toContents x toContents (FiveOf8 x) = toContents x toContents (SixOf8 x) = toContents x toContents (SevenOf8 x) = toContents x toContents (EightOf8 x) = toContents x foldOneOf8 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> OneOf8 a b c d e f g h -> z foldOneOf8 a b c d e f g h (OneOf8 z) = a z foldOneOf8 a b c d e f g h (TwoOf8 z) = b z foldOneOf8 a b c d e f g h (ThreeOf8 z) = c z foldOneOf8 a b c d e f g h (FourOf8 z) = d z foldOneOf8 a b c d e f g h (FiveOf8 z) = e z foldOneOf8 a b c d e f g h (SixOf8 z) = f z foldOneOf8 a b c d e f g h (SevenOf8 z) = g z foldOneOf8 a b c d e f g h (EightOf8 z) = h z ---- data OneOf9 a b c d e f g h i = OneOf9 a | TwoOf9 b | ThreeOf9 c | FourOf9 d | FiveOf9 e | SixOf9 f | SevenOf9 g | EightOf9 h | NineOf9 i deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i) => HTypeable (OneOf9 a b c d e f g h i) where toHType _ = Defined "OneOf9" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i) => XmlContent (OneOf9 a b c d e f g h i) where parseContents = (choice OneOf9 $ choice TwoOf9 $ choice ThreeOf9 $ choice FourOf9 $ choice FiveOf9 $ choice SixOf9 $ choice SevenOf9 $ choice EightOf9 $ choice NineOf9 $ fail "OneOf9") toContents (OneOf9 x) = toContents x toContents (TwoOf9 x) = toContents x toContents (ThreeOf9 x) = toContents x toContents (FourOf9 x) = toContents x toContents (FiveOf9 x) = toContents x toContents (SixOf9 x) = toContents x toContents (SevenOf9 x) = toContents x toContents (EightOf9 x) = toContents x toContents (NineOf9 x) = toContents x foldOneOf9 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> OneOf9 a b c d e f g h i -> z foldOneOf9 a b c d e f g h i (OneOf9 z) = a z foldOneOf9 a b c d e f g h i (TwoOf9 z) = b z foldOneOf9 a b c d e f g h i (ThreeOf9 z) = c z foldOneOf9 a b c d e f g h i (FourOf9 z) = d z foldOneOf9 a b c d e f g h i (FiveOf9 z) = e z foldOneOf9 a b c d e f g h i (SixOf9 z) = f z foldOneOf9 a b c d e f g h i (SevenOf9 z) = g z foldOneOf9 a b c d e f g h i (EightOf9 z) = h z foldOneOf9 a b c d e f g h i (NineOf9 z) = i z ---- data OneOf10 a b c d e f g h i j = OneOf10 a | TwoOf10 b | ThreeOf10 c | FourOf10 d | FiveOf10 e | SixOf10 f | SevenOf10 g | EightOf10 h | NineOf10 i | TenOf10 j deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j) => HTypeable (OneOf10 a b c d e f g h i j) where toHType _ = Defined "OneOf10" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j) => XmlContent (OneOf10 a b c d e f g h i j) where parseContents = (choice OneOf10 $ choice TwoOf10 $ choice ThreeOf10 $ choice FourOf10 $ choice FiveOf10 $ choice SixOf10 $ choice SevenOf10 $ choice EightOf10 $ choice NineOf10 $ choice TenOf10 $ fail "OneOf10") toContents (OneOf10 x) = toContents x toContents (TwoOf10 x) = toContents x toContents (ThreeOf10 x) = toContents x toContents (FourOf10 x) = toContents x toContents (FiveOf10 x) = toContents x toContents (SixOf10 x) = toContents x toContents (SevenOf10 x) = toContents x toContents (EightOf10 x) = toContents x toContents (NineOf10 x) = toContents x toContents (TenOf10 x) = toContents x foldOneOf10 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> OneOf10 a b c d e f g h i j -> z foldOneOf10 a b c d e f g h i j (OneOf10 z) = a z foldOneOf10 a b c d e f g h i j (TwoOf10 z) = b z foldOneOf10 a b c d e f g h i j (ThreeOf10 z) = c z foldOneOf10 a b c d e f g h i j (FourOf10 z) = d z foldOneOf10 a b c d e f g h i j (FiveOf10 z) = e z foldOneOf10 a b c d e f g h i j (SixOf10 z) = f z foldOneOf10 a b c d e f g h i j (SevenOf10 z) = g z foldOneOf10 a b c d e f g h i j (EightOf10 z) = h z foldOneOf10 a b c d e f g h i j (NineOf10 z) = i z foldOneOf10 a b c d e f g h i j (TenOf10 z) = j z ---- data OneOf11 a b c d e f g h i j k = OneOf11 a | TwoOf11 b | ThreeOf11 c | FourOf11 d | FiveOf11 e | SixOf11 f | SevenOf11 g | EightOf11 h | NineOf11 i | TenOf11 j | ElevenOf11 k deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j ,HTypeable k) => HTypeable (OneOf11 a b c d e f g h i j k) where toHType _ = Defined "OneOf11" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j ,XmlContent k) => XmlContent (OneOf11 a b c d e f g h i j k) where parseContents = (choice OneOf11 $ choice TwoOf11 $ choice ThreeOf11 $ choice FourOf11 $ choice FiveOf11 $ choice SixOf11 $ choice SevenOf11 $ choice EightOf11 $ choice NineOf11 $ choice TenOf11 $ choice ElevenOf11 $ fail "OneOf11") toContents (OneOf11 x) = toContents x toContents (TwoOf11 x) = toContents x toContents (ThreeOf11 x) = toContents x toContents (FourOf11 x) = toContents x toContents (FiveOf11 x) = toContents x toContents (SixOf11 x) = toContents x toContents (SevenOf11 x) = toContents x toContents (EightOf11 x) = toContents x toContents (NineOf11 x) = toContents x toContents (TenOf11 x) = toContents x toContents (ElevenOf11 x) = toContents x foldOneOf11 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> OneOf11 a b c d e f g h i j k -> z foldOneOf11 a b c d e f g h i j k (OneOf11 z) = a z foldOneOf11 a b c d e f g h i j k (TwoOf11 z) = b z foldOneOf11 a b c d e f g h i j k (ThreeOf11 z) = c z foldOneOf11 a b c d e f g h i j k (FourOf11 z) = d z foldOneOf11 a b c d e f g h i j k (FiveOf11 z) = e z foldOneOf11 a b c d e f g h i j k (SixOf11 z) = f z foldOneOf11 a b c d e f g h i j k (SevenOf11 z) = g z foldOneOf11 a b c d e f g h i j k (EightOf11 z) = h z foldOneOf11 a b c d e f g h i j k (NineOf11 z) = i z foldOneOf11 a b c d e f g h i j k (TenOf11 z) = j z foldOneOf11 a b c d e f g h i j k (ElevenOf11 z) = k z ---- data OneOf12 a b c d e f g h i j k l = OneOf12 a | TwoOf12 b | ThreeOf12 c | FourOf12 d | FiveOf12 e | SixOf12 f | SevenOf12 g | EightOf12 h | NineOf12 i | TenOf12 j | ElevenOf12 k | TwelveOf12 l deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j ,HTypeable k,HTypeable l) => HTypeable (OneOf12 a b c d e f g h i j k l) where toHType _ = Defined "OneOf12" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j ,XmlContent k,XmlContent l) => XmlContent (OneOf12 a b c d e f g h i j k l) where parseContents = (choice OneOf12 $ choice TwoOf12 $ choice ThreeOf12 $ choice FourOf12 $ choice FiveOf12 $ choice SixOf12 $ choice SevenOf12 $ choice EightOf12 $ choice NineOf12 $ choice TenOf12 $ choice ElevenOf12 $ choice TwelveOf12 $ fail "OneOf12") toContents (OneOf12 x) = toContents x toContents (TwoOf12 x) = toContents x toContents (ThreeOf12 x) = toContents x toContents (FourOf12 x) = toContents x toContents (FiveOf12 x) = toContents x toContents (SixOf12 x) = toContents x toContents (SevenOf12 x) = toContents x toContents (EightOf12 x) = toContents x toContents (NineOf12 x) = toContents x toContents (TenOf12 x) = toContents x toContents (ElevenOf12 x) = toContents x toContents (TwelveOf12 x) = toContents x foldOneOf12 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> OneOf12 a b c d e f g h i j k l -> z foldOneOf12 a b c d e f g h i j k l (OneOf12 z) = a z foldOneOf12 a b c d e f g h i j k l (TwoOf12 z) = b z foldOneOf12 a b c d e f g h i j k l (ThreeOf12 z) = c z foldOneOf12 a b c d e f g h i j k l (FourOf12 z) = d z foldOneOf12 a b c d e f g h i j k l (FiveOf12 z) = e z foldOneOf12 a b c d e f g h i j k l (SixOf12 z) = f z foldOneOf12 a b c d e f g h i j k l (SevenOf12 z) = g z foldOneOf12 a b c d e f g h i j k l (EightOf12 z) = h z foldOneOf12 a b c d e f g h i j k l (NineOf12 z) = i z foldOneOf12 a b c d e f g h i j k l (TenOf12 z) = j z foldOneOf12 a b c d e f g h i j k l (ElevenOf12 z) = k z foldOneOf12 a b c d e f g h i j k l (TwelveOf12 z) = l z ---- data OneOf13 a b c d e f g h i j k l m = OneOf13 a | TwoOf13 b | ThreeOf13 c | FourOf13 d | FiveOf13 e | SixOf13 f | SevenOf13 g | EightOf13 h | NineOf13 i | TenOf13 j | ElevenOf13 k | TwelveOf13 l | ThirteenOf13 m deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j ,HTypeable k,HTypeable l,HTypeable m) => HTypeable (OneOf13 a b c d e f g h i j k l m) where toHType _ = Defined "OneOf13" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j ,XmlContent k,XmlContent l,XmlContent m) => XmlContent (OneOf13 a b c d e f g h i j k l m) where parseContents = (choice OneOf13 $ choice TwoOf13 $ choice ThreeOf13 $ choice FourOf13 $ choice FiveOf13 $ choice SixOf13 $ choice SevenOf13 $ choice EightOf13 $ choice NineOf13 $ choice TenOf13 $ choice ElevenOf13 $ choice TwelveOf13 $ choice ThirteenOf13 $ fail "OneOf13") toContents (OneOf13 x) = toContents x toContents (TwoOf13 x) = toContents x toContents (ThreeOf13 x) = toContents x toContents (FourOf13 x) = toContents x toContents (FiveOf13 x) = toContents x toContents (SixOf13 x) = toContents x toContents (SevenOf13 x) = toContents x toContents (EightOf13 x) = toContents x toContents (NineOf13 x) = toContents x toContents (TenOf13 x) = toContents x toContents (ElevenOf13 x) = toContents x toContents (TwelveOf13 x) = toContents x toContents (ThirteenOf13 x) = toContents x foldOneOf13 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> (m->z) -> OneOf13 a b c d e f g h i j k l m -> z foldOneOf13 a b c d e f g h i j k l m (OneOf13 z) = a z foldOneOf13 a b c d e f g h i j k l m (TwoOf13 z) = b z foldOneOf13 a b c d e f g h i j k l m (ThreeOf13 z) = c z foldOneOf13 a b c d e f g h i j k l m (FourOf13 z) = d z foldOneOf13 a b c d e f g h i j k l m (FiveOf13 z) = e z foldOneOf13 a b c d e f g h i j k l m (SixOf13 z) = f z foldOneOf13 a b c d e f g h i j k l m (SevenOf13 z) = g z foldOneOf13 a b c d e f g h i j k l m (EightOf13 z) = h z foldOneOf13 a b c d e f g h i j k l m (NineOf13 z) = i z foldOneOf13 a b c d e f g h i j k l m (TenOf13 z) = j z foldOneOf13 a b c d e f g h i j k l m (ElevenOf13 z) = k z foldOneOf13 a b c d e f g h i j k l m (TwelveOf13 z) = l z foldOneOf13 a b c d e f g h i j k l m (ThirteenOf13 z) = m z ---- data OneOf14 a b c d e f g h i j k l m n = OneOf14 a | TwoOf14 b | ThreeOf14 c | FourOf14 d | FiveOf14 e | SixOf14 f | SevenOf14 g | EightOf14 h | NineOf14 i | TenOf14 j | ElevenOf14 k | TwelveOf14 l | ThirteenOf14 m | FourteenOf14 n deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j ,HTypeable k,HTypeable l,HTypeable m,HTypeable n) => HTypeable (OneOf14 a b c d e f g h i j k l m n) where toHType _ = Defined "OneOf14" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j ,XmlContent k,XmlContent l,XmlContent m,XmlContent n) => XmlContent (OneOf14 a b c d e f g h i j k l m n) where parseContents = (choice OneOf14 $ choice TwoOf14 $ choice ThreeOf14 $ choice FourOf14 $ choice FiveOf14 $ choice SixOf14 $ choice SevenOf14 $ choice EightOf14 $ choice NineOf14 $ choice TenOf14 $ choice ElevenOf14 $ choice TwelveOf14 $ choice ThirteenOf14 $ choice FourteenOf14 $ fail "OneOf14") toContents (OneOf14 x) = toContents x toContents (TwoOf14 x) = toContents x toContents (ThreeOf14 x) = toContents x toContents (FourOf14 x) = toContents x toContents (FiveOf14 x) = toContents x toContents (SixOf14 x) = toContents x toContents (SevenOf14 x) = toContents x toContents (EightOf14 x) = toContents x toContents (NineOf14 x) = toContents x toContents (TenOf14 x) = toContents x toContents (ElevenOf14 x) = toContents x toContents (TwelveOf14 x) = toContents x toContents (ThirteenOf14 x) = toContents x toContents (FourteenOf14 x) = toContents x foldOneOf14 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> (m->z) -> (n->z) -> OneOf14 a b c d e f g h i j k l m n -> z foldOneOf14 a b c d e f g h i j k l m n (OneOf14 z) = a z foldOneOf14 a b c d e f g h i j k l m n (TwoOf14 z) = b z foldOneOf14 a b c d e f g h i j k l m n (ThreeOf14 z) = c z foldOneOf14 a b c d e f g h i j k l m n (FourOf14 z) = d z foldOneOf14 a b c d e f g h i j k l m n (FiveOf14 z) = e z foldOneOf14 a b c d e f g h i j k l m n (SixOf14 z) = f z foldOneOf14 a b c d e f g h i j k l m n (SevenOf14 z) = g z foldOneOf14 a b c d e f g h i j k l m n (EightOf14 z) = h z foldOneOf14 a b c d e f g h i j k l m n (NineOf14 z) = i z foldOneOf14 a b c d e f g h i j k l m n (TenOf14 z) = j z foldOneOf14 a b c d e f g h i j k l m n (ElevenOf14 z) = k z foldOneOf14 a b c d e f g h i j k l m n (TwelveOf14 z) = l z foldOneOf14 a b c d e f g h i j k l m n (ThirteenOf14 z) = m z foldOneOf14 a b c d e f g h i j k l m n (FourteenOf14 z) = n z ---- data OneOf15 a b c d e f g h i j k l m n o = OneOf15 a | TwoOf15 b | ThreeOf15 c | FourOf15 d | FiveOf15 e | SixOf15 f | SevenOf15 g | EightOf15 h | NineOf15 i | TenOf15 j | ElevenOf15 k | TwelveOf15 l | ThirteenOf15 m | FourteenOf15 n | FifteenOf15 o deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o) => HTypeable (OneOf15 a b c d e f g h i j k l m n o) where toHType _ = Defined "OneOf15" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o) => XmlContent (OneOf15 a b c d e f g h i j k l m n o) where parseContents = (choice OneOf15 $ choice TwoOf15 $ choice ThreeOf15 $ choice FourOf15 $ choice FiveOf15 $ choice SixOf15 $ choice SevenOf15 $ choice EightOf15 $ choice NineOf15 $ choice TenOf15 $ choice ElevenOf15 $ choice TwelveOf15 $ choice ThirteenOf15 $ choice FourteenOf15 $ choice FifteenOf15 $ fail "OneOf15") toContents (OneOf15 x) = toContents x toContents (TwoOf15 x) = toContents x toContents (ThreeOf15 x) = toContents x toContents (FourOf15 x) = toContents x toContents (FiveOf15 x) = toContents x toContents (SixOf15 x) = toContents x toContents (SevenOf15 x) = toContents x toContents (EightOf15 x) = toContents x toContents (NineOf15 x) = toContents x toContents (TenOf15 x) = toContents x toContents (ElevenOf15 x) = toContents x toContents (TwelveOf15 x) = toContents x toContents (ThirteenOf15 x) = toContents x toContents (FourteenOf15 x) = toContents x toContents (FifteenOf15 x) = toContents x foldOneOf15 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> (m->z) -> (n->z) -> (o->z) -> OneOf15 a b c d e f g h i j k l m n o -> z foldOneOf15 a b c d e f g h i j k l m n o (OneOf15 z) = a z foldOneOf15 a b c d e f g h i j k l m n o (TwoOf15 z) = b z foldOneOf15 a b c d e f g h i j k l m n o (ThreeOf15 z) = c z foldOneOf15 a b c d e f g h i j k l m n o (FourOf15 z) = d z foldOneOf15 a b c d e f g h i j k l m n o (FiveOf15 z) = e z foldOneOf15 a b c d e f g h i j k l m n o (SixOf15 z) = f z foldOneOf15 a b c d e f g h i j k l m n o (SevenOf15 z) = g z foldOneOf15 a b c d e f g h i j k l m n o (EightOf15 z) = h z foldOneOf15 a b c d e f g h i j k l m n o (NineOf15 z) = i z foldOneOf15 a b c d e f g h i j k l m n o (TenOf15 z) = j z foldOneOf15 a b c d e f g h i j k l m n o (ElevenOf15 z) = k z foldOneOf15 a b c d e f g h i j k l m n o (TwelveOf15 z) = l z foldOneOf15 a b c d e f g h i j k l m n o (ThirteenOf15 z) = m z foldOneOf15 a b c d e f g h i j k l m n o (FourteenOf15 z) = n z foldOneOf15 a b c d e f g h i j k l m n o (FifteenOf15 z) = o z ---- data OneOf16 a b c d e f g h i j k l m n o p = OneOf16 a | TwoOf16 b | ThreeOf16 c | FourOf16 d | FiveOf16 e | SixOf16 f | SevenOf16 g | EightOf16 h | NineOf16 i | TenOf16 j | ElevenOf16 k | TwelveOf16 l | ThirteenOf16 m | FourteenOf16 n | FifteenOf16 o | SixteenOf16 p deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o ,HTypeable p) => HTypeable (OneOf16 a b c d e f g h i j k l m n o p) where toHType _ = Defined "OneOf16" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o ,XmlContent p) => XmlContent (OneOf16 a b c d e f g h i j k l m n o p) where parseContents = (choice OneOf16 $ choice TwoOf16 $ choice ThreeOf16 $ choice FourOf16 $ choice FiveOf16 $ choice SixOf16 $ choice SevenOf16 $ choice EightOf16 $ choice NineOf16 $ choice TenOf16 $ choice ElevenOf16 $ choice TwelveOf16 $ choice ThirteenOf16 $ choice FourteenOf16 $ choice FifteenOf16 $ choice SixteenOf16 $ fail "OneOf16") toContents (OneOf16 x) = toContents x toContents (TwoOf16 x) = toContents x toContents (ThreeOf16 x) = toContents x toContents (FourOf16 x) = toContents x toContents (FiveOf16 x) = toContents x toContents (SixOf16 x) = toContents x toContents (SevenOf16 x) = toContents x toContents (EightOf16 x) = toContents x toContents (NineOf16 x) = toContents x toContents (TenOf16 x) = toContents x toContents (ElevenOf16 x) = toContents x toContents (TwelveOf16 x) = toContents x toContents (ThirteenOf16 x) = toContents x toContents (FourteenOf16 x) = toContents x toContents (FifteenOf16 x) = toContents x toContents (SixteenOf16 x) = toContents x foldOneOf16 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> (m->z) -> (n->z) -> (o->z) -> (p->z) -> OneOf16 a b c d e f g h i j k l m n o p -> z foldOneOf16 a b c d e f g h i j k l m n o p (OneOf16 z) = a z foldOneOf16 a b c d e f g h i j k l m n o p (TwoOf16 z) = b z foldOneOf16 a b c d e f g h i j k l m n o p (ThreeOf16 z) = c z foldOneOf16 a b c d e f g h i j k l m n o p (FourOf16 z) = d z foldOneOf16 a b c d e f g h i j k l m n o p (FiveOf16 z) = e z foldOneOf16 a b c d e f g h i j k l m n o p (SixOf16 z) = f z foldOneOf16 a b c d e f g h i j k l m n o p (SevenOf16 z) = g z foldOneOf16 a b c d e f g h i j k l m n o p (EightOf16 z) = h z foldOneOf16 a b c d e f g h i j k l m n o p (NineOf16 z) = i z foldOneOf16 a b c d e f g h i j k l m n o p (TenOf16 z) = j z foldOneOf16 a b c d e f g h i j k l m n o p (ElevenOf16 z) = k z foldOneOf16 a b c d e f g h i j k l m n o p (TwelveOf16 z) = l z foldOneOf16 a b c d e f g h i j k l m n o p (ThirteenOf16 z) = m z foldOneOf16 a b c d e f g h i j k l m n o p (FourteenOf16 z) = n z foldOneOf16 a b c d e f g h i j k l m n o p (FifteenOf16 z) = o z foldOneOf16 a b c d e f g h i j k l m n o p (SixteenOf16 z) = p z ---- data OneOf17 a b c d e f g h i j k l m n o p q = OneOf17 a | TwoOf17 b | ThreeOf17 c | FourOf17 d | FiveOf17 e | SixOf17 f | SevenOf17 g | EightOf17 h | NineOf17 i | TenOf17 j | ElevenOf17 k | TwelveOf17 l | ThirteenOf17 m | FourteenOf17 n | FifteenOf17 o | SixteenOf17 p | SeventeenOf17 q deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o ,HTypeable p,HTypeable q) => HTypeable (OneOf17 a b c d e f g h i j k l m n o p q) where toHType _ = Defined "OneOf17" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o ,XmlContent p,XmlContent q) => XmlContent (OneOf17 a b c d e f g h i j k l m n o p q) where parseContents = (choice OneOf17 $ choice TwoOf17 $ choice ThreeOf17 $ choice FourOf17 $ choice FiveOf17 $ choice SixOf17 $ choice SevenOf17 $ choice EightOf17 $ choice NineOf17 $ choice TenOf17 $ choice ElevenOf17 $ choice TwelveOf17 $ choice ThirteenOf17 $ choice FourteenOf17 $ choice FifteenOf17 $ choice SixteenOf17 $ choice SeventeenOf17 $ fail "OneOf17") toContents (OneOf17 x) = toContents x toContents (TwoOf17 x) = toContents x toContents (ThreeOf17 x) = toContents x toContents (FourOf17 x) = toContents x toContents (FiveOf17 x) = toContents x toContents (SixOf17 x) = toContents x toContents (SevenOf17 x) = toContents x toContents (EightOf17 x) = toContents x toContents (NineOf17 x) = toContents x toContents (TenOf17 x) = toContents x toContents (ElevenOf17 x) = toContents x toContents (TwelveOf17 x) = toContents x toContents (ThirteenOf17 x) = toContents x toContents (FourteenOf17 x) = toContents x toContents (FifteenOf17 x) = toContents x toContents (SixteenOf17 x) = toContents x toContents (SeventeenOf17 x) = toContents x foldOneOf17 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> OneOf17 a b c d e f g h i j k l m n o p q -> z foldOneOf17 a b c d e f g h i j k l m n o p q (OneOf17 z) = a z foldOneOf17 a b c d e f g h i j k l m n o p q (TwoOf17 z) = b z foldOneOf17 a b c d e f g h i j k l m n o p q (ThreeOf17 z) = c z foldOneOf17 a b c d e f g h i j k l m n o p q (FourOf17 z) = d z foldOneOf17 a b c d e f g h i j k l m n o p q (FiveOf17 z) = e z foldOneOf17 a b c d e f g h i j k l m n o p q (SixOf17 z) = f z foldOneOf17 a b c d e f g h i j k l m n o p q (SevenOf17 z) = g z foldOneOf17 a b c d e f g h i j k l m n o p q (EightOf17 z) = h z foldOneOf17 a b c d e f g h i j k l m n o p q (NineOf17 z) = i z foldOneOf17 a b c d e f g h i j k l m n o p q (TenOf17 z) = j z foldOneOf17 a b c d e f g h i j k l m n o p q (ElevenOf17 z) = k z foldOneOf17 a b c d e f g h i j k l m n o p q (TwelveOf17 z) = l z foldOneOf17 a b c d e f g h i j k l m n o p q (ThirteenOf17 z) = m z foldOneOf17 a b c d e f g h i j k l m n o p q (FourteenOf17 z) = n z foldOneOf17 a b c d e f g h i j k l m n o p q (FifteenOf17 z) = o z foldOneOf17 a b c d e f g h i j k l m n o p q (SixteenOf17 z) = p z foldOneOf17 a b c d e f g h i j k l m n o p q (SeventeenOf17 z) = q z ---- data OneOf18 a b c d e f g h i j k l m n o p q r = OneOf18 a | TwoOf18 b | ThreeOf18 c | FourOf18 d | FiveOf18 e | SixOf18 f | SevenOf18 g | EightOf18 h | NineOf18 i | TenOf18 j | ElevenOf18 k | TwelveOf18 l | ThirteenOf18 m | FourteenOf18 n | FifteenOf18 o | SixteenOf18 p | SeventeenOf18 q | EighteenOf18 r deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o ,HTypeable p,HTypeable q,HTypeable r) => HTypeable (OneOf18 a b c d e f g h i j k l m n o p q r) where toHType _ = Defined "OneOf18" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o ,XmlContent p,XmlContent q,XmlContent r) => XmlContent (OneOf18 a b c d e f g h i j k l m n o p q r) where parseContents = (choice OneOf18 $ choice TwoOf18 $ choice ThreeOf18 $ choice FourOf18 $ choice FiveOf18 $ choice SixOf18 $ choice SevenOf18 $ choice EightOf18 $ choice NineOf18 $ choice TenOf18 $ choice ElevenOf18 $ choice TwelveOf18 $ choice ThirteenOf18 $ choice FourteenOf18 $ choice FifteenOf18 $ choice SixteenOf18 $ choice SeventeenOf18 $ choice EighteenOf18 $ fail "OneOf18") toContents (OneOf18 x) = toContents x toContents (TwoOf18 x) = toContents x toContents (ThreeOf18 x) = toContents x toContents (FourOf18 x) = toContents x toContents (FiveOf18 x) = toContents x toContents (SixOf18 x) = toContents x toContents (SevenOf18 x) = toContents x toContents (EightOf18 x) = toContents x toContents (NineOf18 x) = toContents x toContents (TenOf18 x) = toContents x toContents (ElevenOf18 x) = toContents x toContents (TwelveOf18 x) = toContents x toContents (ThirteenOf18 x) = toContents x toContents (FourteenOf18 x) = toContents x toContents (FifteenOf18 x) = toContents x toContents (SixteenOf18 x) = toContents x toContents (SeventeenOf18 x) = toContents x toContents (EighteenOf18 x) = toContents x foldOneOf18 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> OneOf18 a b c d e f g h i j k l m n o p q r -> z foldOneOf18 a b c d e f g h i j k l m n o p q r (OneOf18 z) = a z foldOneOf18 a b c d e f g h i j k l m n o p q r (TwoOf18 z) = b z foldOneOf18 a b c d e f g h i j k l m n o p q r (ThreeOf18 z) = c z foldOneOf18 a b c d e f g h i j k l m n o p q r (FourOf18 z) = d z foldOneOf18 a b c d e f g h i j k l m n o p q r (FiveOf18 z) = e z foldOneOf18 a b c d e f g h i j k l m n o p q r (SixOf18 z) = f z foldOneOf18 a b c d e f g h i j k l m n o p q r (SevenOf18 z) = g z foldOneOf18 a b c d e f g h i j k l m n o p q r (EightOf18 z) = h z foldOneOf18 a b c d e f g h i j k l m n o p q r (NineOf18 z) = i z foldOneOf18 a b c d e f g h i j k l m n o p q r (TenOf18 z) = j z foldOneOf18 a b c d e f g h i j k l m n o p q r (ElevenOf18 z) = k z foldOneOf18 a b c d e f g h i j k l m n o p q r (TwelveOf18 z) = l z foldOneOf18 a b c d e f g h i j k l m n o p q r (ThirteenOf18 z) = m z foldOneOf18 a b c d e f g h i j k l m n o p q r (FourteenOf18 z) = n z foldOneOf18 a b c d e f g h i j k l m n o p q r (FifteenOf18 z) = o z foldOneOf18 a b c d e f g h i j k l m n o p q r (SixteenOf18 z) = p z foldOneOf18 a b c d e f g h i j k l m n o p q r (SeventeenOf18 z) = q z foldOneOf18 a b c d e f g h i j k l m n o p q r (EighteenOf18 z) = r z ---- data OneOf19 a b c d e f g h i j k l m n o p q r s = OneOf19 a | TwoOf19 b | ThreeOf19 c | FourOf19 d | FiveOf19 e | SixOf19 f | SevenOf19 g | EightOf19 h | NineOf19 i | TenOf19 j | ElevenOf19 k | TwelveOf19 l | ThirteenOf19 m | FourteenOf19 n | FifteenOf19 o | SixteenOf19 p | SeventeenOf19 q | EighteenOf19 r | NineteenOf19 s deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o ,HTypeable p,HTypeable q,HTypeable r,HTypeable s) => HTypeable (OneOf19 a b c d e f g h i j k l m n o p q r s) where toHType _ = Defined "OneOf19" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o ,XmlContent p,XmlContent q,XmlContent r,XmlContent s) => XmlContent (OneOf19 a b c d e f g h i j k l m n o p q r s) where parseContents = (choice OneOf19 $ choice TwoOf19 $ choice ThreeOf19 $ choice FourOf19 $ choice FiveOf19 $ choice SixOf19 $ choice SevenOf19 $ choice EightOf19 $ choice NineOf19 $ choice TenOf19 $ choice ElevenOf19 $ choice TwelveOf19 $ choice ThirteenOf19 $ choice FourteenOf19 $ choice FifteenOf19 $ choice SixteenOf19 $ choice SeventeenOf19 $ choice EighteenOf19 $ choice NineteenOf19 $ fail "OneOf19") toContents (OneOf19 x) = toContents x toContents (TwoOf19 x) = toContents x toContents (ThreeOf19 x) = toContents x toContents (FourOf19 x) = toContents x toContents (FiveOf19 x) = toContents x toContents (SixOf19 x) = toContents x toContents (SevenOf19 x) = toContents x toContents (EightOf19 x) = toContents x toContents (NineOf19 x) = toContents x toContents (TenOf19 x) = toContents x toContents (ElevenOf19 x) = toContents x toContents (TwelveOf19 x) = toContents x toContents (ThirteenOf19 x) = toContents x toContents (FourteenOf19 x) = toContents x toContents (FifteenOf19 x) = toContents x toContents (SixteenOf19 x) = toContents x toContents (SeventeenOf19 x) = toContents x toContents (EighteenOf19 x) = toContents x toContents (NineteenOf19 x) = toContents x foldOneOf19 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> (s->z) -> OneOf19 a b c d e f g h i j k l m n o p q r s -> z foldOneOf19 a b c d e f g h i j k l m n o p q r s (OneOf19 z) = a z foldOneOf19 a b c d e f g h i j k l m n o p q r s (TwoOf19 z) = b z foldOneOf19 a b c d e f g h i j k l m n o p q r s (ThreeOf19 z) = c z foldOneOf19 a b c d e f g h i j k l m n o p q r s (FourOf19 z) = d z foldOneOf19 a b c d e f g h i j k l m n o p q r s (FiveOf19 z) = e z foldOneOf19 a b c d e f g h i j k l m n o p q r s (SixOf19 z) = f z foldOneOf19 a b c d e f g h i j k l m n o p q r s (SevenOf19 z) = g z foldOneOf19 a b c d e f g h i j k l m n o p q r s (EightOf19 z) = h z foldOneOf19 a b c d e f g h i j k l m n o p q r s (NineOf19 z) = i z foldOneOf19 a b c d e f g h i j k l m n o p q r s (TenOf19 z) = j z foldOneOf19 a b c d e f g h i j k l m n o p q r s (ElevenOf19 z) = k z foldOneOf19 a b c d e f g h i j k l m n o p q r s (TwelveOf19 z) = l z foldOneOf19 a b c d e f g h i j k l m n o p q r s (ThirteenOf19 z) = m z foldOneOf19 a b c d e f g h i j k l m n o p q r s (FourteenOf19 z) = n z foldOneOf19 a b c d e f g h i j k l m n o p q r s (FifteenOf19 z) = o z foldOneOf19 a b c d e f g h i j k l m n o p q r s (SixteenOf19 z) = p z foldOneOf19 a b c d e f g h i j k l m n o p q r s (SeventeenOf19 z) = q z foldOneOf19 a b c d e f g h i j k l m n o p q r s (EighteenOf19 z) = r z foldOneOf19 a b c d e f g h i j k l m n o p q r s (NineteenOf19 z) = s z ---- data OneOf20 a b c d e f g h i j k l m n o p q r s t = OneOf20 a | TwoOf20 b | ThreeOf20 c | FourOf20 d | FiveOf20 e | SixOf20 f | SevenOf20 g | EightOf20 h | NineOf20 i | TenOf20 j | ElevenOf20 k | TwelveOf20 l | ThirteenOf20 m | FourteenOf20 n | FifteenOf20 o | SixteenOf20 p | SeventeenOf20 q | EighteenOf20 r | NineteenOf20 s | TwentyOf20 t deriving (Eq,Show) instance (HTypeable a,HTypeable b,HTypeable c,HTypeable d,HTypeable e ,HTypeable f,HTypeable g,HTypeable h,HTypeable i,HTypeable j ,HTypeable k,HTypeable l,HTypeable m,HTypeable n,HTypeable o ,HTypeable p,HTypeable q,HTypeable r,HTypeable s,HTypeable t) => HTypeable (OneOf20 a b c d e f g h i j k l m n o p q r s t) where toHType _ = Defined "OneOf20" [] [] instance (XmlContent a,XmlContent b,XmlContent c,XmlContent d,XmlContent e ,XmlContent f,XmlContent g,XmlContent h,XmlContent i,XmlContent j ,XmlContent k,XmlContent l,XmlContent m,XmlContent n,XmlContent o ,XmlContent p,XmlContent q,XmlContent r,XmlContent s,XmlContent t) => XmlContent (OneOf20 a b c d e f g h i j k l m n o p q r s t) where parseContents = (choice OneOf20 $ choice TwoOf20 $ choice ThreeOf20 $ choice FourOf20 $ choice FiveOf20 $ choice SixOf20 $ choice SevenOf20 $ choice EightOf20 $ choice NineOf20 $ choice TenOf20 $ choice ElevenOf20 $ choice TwelveOf20 $ choice ThirteenOf20 $ choice FourteenOf20 $ choice FifteenOf20 $ choice SixteenOf20 $ choice SeventeenOf20 $ choice EighteenOf20 $ choice NineteenOf20 $ choice TwentyOf20 $ fail "OneOf20") toContents (OneOf20 x) = toContents x toContents (TwoOf20 x) = toContents x toContents (ThreeOf20 x) = toContents x toContents (FourOf20 x) = toContents x toContents (FiveOf20 x) = toContents x toContents (SixOf20 x) = toContents x toContents (SevenOf20 x) = toContents x toContents (EightOf20 x) = toContents x toContents (NineOf20 x) = toContents x toContents (TenOf20 x) = toContents x toContents (ElevenOf20 x) = toContents x toContents (TwelveOf20 x) = toContents x toContents (ThirteenOf20 x) = toContents x toContents (FourteenOf20 x) = toContents x toContents (FifteenOf20 x) = toContents x toContents (SixteenOf20 x) = toContents x toContents (SeventeenOf20 x) = toContents x toContents (EighteenOf20 x) = toContents x toContents (NineteenOf20 x) = toContents x toContents (TwentyOf20 x) = toContents x foldOneOf20 :: (a->z) -> (b->z) -> (c->z) -> (d->z) -> (e->z) -> (f->z) -> (g->z) -> (h->z) -> (i->z) -> (j->z) -> (k->z) -> (l->z) -> (m->z) -> (n->z) -> (o->z) -> (p->z) -> (q->z) -> (r->z) -> (s->z) -> (t->z) -> OneOf20 a b c d e f g h i j k l m n o p q r s t -> z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (OneOf20 z) = a z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (TwoOf20 z) = b z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (ThreeOf20 z) = c z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (FourOf20 z) = d z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (FiveOf20 z) = e z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (SixOf20 z) = f z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (SevenOf20 z) = g z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (EightOf20 z) = h z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (NineOf20 z) = i z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (TenOf20 z) = j z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (ElevenOf20 z) = k z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (TwelveOf20 z) = l z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (ThirteenOf20 z) = m z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (FourteenOf20 z) = n z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (FifteenOf20 z) = o z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (SixteenOf20 z) = p z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (SeventeenOf20 z) = q z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (EighteenOf20 z) = r z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (NineteenOf20 z) = s z foldOneOf20 a b c d e f g h i j k l m n o p q r s t (TwentyOf20 z) = t z ---- HaXml-1.23.3/src/Text/XML/HaXml/Parse.hs0000755000062000006210000007505411767644706016703 0ustar 1341796mkpasswd{-# OPTIONS -cpp #-} -- | A non-validating XML parser. For the input grammar, see -- . module Text.XML.HaXml.Parse ( -- * Parse a whole document xmlParse, xmlParse' -- * Parse just a DTD , dtdParse, dtdParse' -- * Parse a partial document , xmlParseWith -- * Individual parsers for use with /xmlParseWith/ and module SAX , document, element, content , comment, cdsect, chardata , reference, doctypedecl , processinginstruction , elemtag, qname, name, tok , elemOpenTag, elemCloseTag , emptySTs, XParser -- * These general utility functions don't belong here , fst3, snd3, thd3 ) where -- An XML parser, written using a slightly extended version of the -- Hutton/Meijer parser combinators. The input is tokenised internally -- by the lexer xmlLex. Whilst parsing, we gather a symbol -- table of entity references. PERefs must be defined before use, so we -- expand their uses as we encounter them, forcing the remainder of the -- input to be re-lexed and re-parsed. GERefs are simply stored for -- later retrieval. import Prelude hiding (either,maybe,sequence) import qualified Prelude (either) import Data.Maybe hiding (maybe) import Data.List (intersperse) -- debugging only import Data.Char (isSpace,isDigit,isHexDigit) import Control.Monad hiding (sequence) import Numeric (readDec,readHex) import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces import Text.XML.HaXml.Posn import Text.XML.HaXml.Lex import Text.ParserCombinators.Poly.State import System.FilePath (combine, dropFileName) #if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \ ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__) import System.IO.Unsafe (unsafePerformIO) #elif defined(__GLASGOW_HASKELL__) import IOExts (unsafePerformIO) #elif defined(__NHC__) import IOExtras (unsafePerformIO) #elif defined(__HBC__) import UnsafePerformIO #endif -- #define DEBUG #if defined(DEBUG) # if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \ ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__) import Debug.Trace(trace) # elif defined(__GLASGOW_HASKELL__) import IOExts(trace) # elif defined(__NHC__) || defined(__HBC__) import NonStdTrace # endif v `debug` s = trace s v #else v `debug` s = v #endif debug :: a -> String -> a -- | To parse a whole document, @xmlParse file content@ takes a filename -- (for generating error reports) and the string content of that file. -- A parse error causes program failure, with message to stderr. xmlParse :: String -> String -> Document Posn -- | To parse a whole document, @xmlParse' file content@ takes a filename -- (for generating error reports) and the string content of that file. -- Any parse error message is passed back to the caller through the -- @Either@ type. xmlParse' :: String -> String -> Either String (Document Posn) -- | To parse just a DTD, @dtdParse file content@ takes a filename -- (for generating error reports) and the string content of that -- file. If no DTD was found, you get @Nothing@ rather than an error. -- However, if a DTD is found but contains errors, the program crashes. dtdParse :: String -> String -> Maybe DocTypeDecl -- | To parse just a DTD, @dtdParse' file content@ takes a filename -- (for generating error reports) and the string content of that -- file. If no DTD was found, you get @Right Nothing@. -- If a DTD was found but contains errors, you get a @Left message@. dtdParse' :: String -> String -> Either String (Maybe DocTypeDecl) xmlParse name = Prelude.either error id . xmlParse' name dtdParse name = Prelude.either error id . dtdParse' name xmlParse' name = fst3 . runParser (toEOF document) emptySTs . xmlLex name dtdParse' name = fst3 . runParser justDTD emptySTs . xmlLex name toEOF :: XParser a -> XParser a toEOF = id -- there are other possible implementations... -- | To parse a partial document, e.g. from an XML-based stream protocol, -- where you may later want to get more document elements from the same -- stream. Arguments are: a parser for the item you want, and the -- already-lexed input to parse from. Returns the item you wanted -- (or an error message), plus the remainder of the input. xmlParseWith :: XParser a -> [(Posn,TokenT)] -> (Either String a, [(Posn,TokenT)]) xmlParseWith p = (\(v,_,s)->(v,s)) . runParser p emptySTs ---- Symbol table stuff ---- type SymTabs = (SymTab PEDef, SymTab EntityDef) -- | Some empty symbol tables for GE and PE references. emptySTs :: SymTabs emptySTs = (emptyST, emptyST) addPE :: String -> PEDef -> SymTabs -> SymTabs addPE n v (pe,ge) = (addST n v pe, ge) addGE :: String -> EntityDef -> SymTabs -> SymTabs addGE n v (pe,ge) = let newge = addST n v ge in newge `seq` (pe, newge) lookupPE :: String -> SymTabs -> Maybe PEDef lookupPE s (pe,_ge) = lookupST s pe flattenEV :: EntityValue -> String flattenEV (EntityValue evs) = concatMap flatten evs where flatten (EVString s) = s flatten (EVRef (RefEntity r)) = "&" ++r++";" flatten (EVRef (RefChar r)) = "&#"++show r++";" -- flatten (EVPERef n) = "%" ++n++";" ---- Misc ---- fst3 :: (a,b,c) -> a snd3 :: (a,b,c) -> b thd3 :: (a,b,c) -> c fst3 (a,_,_) = a snd3 (_,a,_) = a thd3 (_,_,a) = a ---- Auxiliary Parsing Functions ---- -- | Parse a bracketed item, discarding the brackets AND NOT using adjustErrBad myBracket :: PolyParse p => p bra -> p ket -> p a -> p a myBracket open close p = do do { open `adjustErr` ("Missing opening bracket:\n\t"++) ; p `discard` (close `adjustErr` ("Missing closing bracket:\n\t"++)) } -- | XParser is just a specialisation of the PolyState parser. type XParser a = Parser SymTabs (Posn,TokenT) a -- | Return the next token from the input only if it matches the given token. tok :: TokenT -> XParser TokenT tok t = do (p,t') <- next case t' of TokError _ -> report failBad (show t) p t' _ | t'==t -> return t | otherwise -> report fail (show t) p t' nottok :: [TokenT] -> XParser TokenT nottok ts = do (p,t) <- next if t`elem`ts then report fail ("no "++show t) p t else return t -- | Return a qualified name (although the namespace qualification is not -- processed here; this is merely to get the correct type). qname :: XParser QName qname = fmap N name -- | Return just a name, e.g. element name, attribute name. name :: XParser Name name = do (p,tok) <- next case tok of TokName s -> return s TokError _ -> report failBad "a name" p tok _ -> report fail "a name" p tok string, freetext :: XParser String string = do (p,t) <- next case t of TokName s -> return s _ -> report fail "text" p t freetext = do (p,t) <- next case t of TokFreeText s -> return s _ -> report fail "text" p t maybe :: XParser a -> XParser (Maybe a) maybe p = ( p >>= return . Just) `onFail` ( return Nothing) either :: XParser a -> XParser b -> XParser (Either a b) either p q = ( p >>= return . Left) `onFail` ( q >>= return . Right) word :: String -> XParser () word s = do { x <- next ; case x of (_p,TokName n) | s==n -> return () (_p,TokFreeText n) | s==n -> return () ( p,t@(TokError _)) -> report failBad (show s) p t ( p,t) -> report fail (show s) p t } posn :: XParser Posn posn = do { x@(p,_) <- next ; reparse [x] ; return p } nmtoken :: XParser NmToken nmtoken = (string `onFail` freetext) failP, failBadP :: String -> XParser a failP msg = do { p <- posn; fail (msg++"\n at "++show p) } failBadP msg = do { p <- posn; failBad (msg++"\n at "++show p) } report :: (String->XParser a) -> String -> Posn -> TokenT -> XParser a report fail expect p t = fail ("Expected "++expect++" but found "++show t ++"\n in "++show p) adjustErrP :: XParser a -> (String->String) -> XParser a p `adjustErrP` f = p `onFail` do pn <- posn (p `adjustErr` f) `adjustErr` (++show pn) peRef :: XParser a -> XParser a peRef p = p `onFail` do pn <- posn n <- pereference tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n) case tr of Just (PEDefEntityValue ev) -> do reparse (xmlReLex (posInNewCxt ("macro %"++n++";") (Just pn)) (flattenEV ev)) `debug` (" defn: "++flattenEV ev) peRef p Just (PEDefExternalID (PUBLIC _ (SystemLiteral f))) -> do let f' = combine (dropFileName $ posnFilename pn) f val = unsafePerformIO (readFile f') reparse (xmlReLex (posInNewCxt f' (Just pn)) val) `debug` (" reading from file "++f') peRef p Just (PEDefExternalID (SYSTEM (SystemLiteral f))) -> do let f' = combine (dropFileName $ posnFilename pn) f val = unsafePerformIO (readFile f') reparse (xmlReLex (posInNewCxt f' (Just pn)) val) `debug` (" reading from file "++f') peRef p Nothing -> fail ("PEReference use before definition: "++"%"++n++";" ++"\n at "++show pn) blank :: XParser a -> XParser a blank p = p `onFail` do n <- pereference tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n++" (is blank?)") case tr of Just (PEDefEntityValue ev) | all isSpace (flattenEV ev) -> do blank p `debug` "Empty macro definition" Just _ -> failP ("expected a blank PERef macro: "++"%"++n++";") Nothing -> failP ("PEReference use before definition: "++"%"++n++";") ---- XML Parsing Functions ---- justDTD :: XParser (Maybe DocTypeDecl) justDTD = do (ExtSubset _ ds) <- extsubset `debug` "Trying external subset" if null ds then fail "empty" else return (Just (DTD (N "extsubset") Nothing (concatMap extract ds))) `onFail` do (Prolog _ _ dtd _) <- prolog return dtd where extract (ExtMarkupDecl m) = [m] extract (ExtConditionalSect (IncludeSect i)) = concatMap extract i extract (ExtConditionalSect (IgnoreSect _i)) = [] -- | Return an entire XML document including prolog and trailing junk. document :: XParser (Document Posn) document = do p <- prolog `adjustErr` ("unrecognisable XML prolog\n"++) e <- element ms <- many misc (_,ge) <- stGet return (Document p ge e ms) -- | Return an XML comment. comment :: XParser Comment comment = do myBracket (tok TokCommentOpen) (tok TokCommentClose) freetext -- tok TokCommentOpen -- commit $ do -- c <- freetext -- tok TokCommentClose -- return c -- | Parse a processing instruction. processinginstruction :: XParser ProcessingInstruction processinginstruction = do tok TokPIOpen commit $ do n <- string `onFail` failP "processing instruction has no target" f <- freetext tok TokPIClose `onFail` failP ("missing ?> in in " raise ((runParser aux emptySTs . xmlReLex p) s) where aux = do v <- versioninfo `onFail` failP "missing XML version info" e <- maybe encodingdecl s <- maybe sddecl return (XMLDecl v e s) raise (Left err, _, _) = failP err raise (Right ok, _, _) = return ok versioninfo :: XParser VersionInfo versioninfo = do (word "version" `onFail` word "VERSION") tok TokEqual bracket (tok TokQuote) (tok TokQuote) freetext misc :: XParser Misc misc = oneOf' [ ("", comment >>= return . Comment) , ("", processinginstruction >>= return . PI) ] -- | Return a DOCTYPE decl, indicating a DTD. doctypedecl :: XParser DocTypeDecl doctypedecl = do tok TokSpecialOpen tok (TokSpecial DOCTYPEx) commit $ do n <- qname eid <- maybe externalid es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose) (many (peRef markupdecl))) blank (tok TokAnyClose) `onFail` failP "missing > in DOCTYPE decl" return (DTD n eid (case es of { Nothing -> []; Just e -> e })) -- | Return a DTD markup decl, e.g. ELEMENT, ATTLIST, etc markupdecl :: XParser MarkupDecl markupdecl = oneOf' [ ("ELEMENT", elementdecl >>= return . Element) , ("ATTLIST", attlistdecl >>= return . AttList) , ("ENTITY", entitydecl >>= return . Entity) , ("NOTATION", notationdecl >>= return . Notation) , ("misc", misc >>= return . MarkupMisc) ] `adjustErrP` ("when looking for a markup decl,\n"++) -- (\ (ELEMENT, ATTLIST, ENTITY, NOTATION, , or ") extsubset :: XParser ExtSubset extsubset = do td <- maybe textdecl ds <- many (peRef extsubsetdecl) return (ExtSubset td ds) extsubsetdecl :: XParser ExtSubsetDecl extsubsetdecl = ( markupdecl >>= return . ExtMarkupDecl) `onFail` ( conditionalsect >>= return . ExtConditionalSect) sddecl :: XParser SDDecl sddecl = do (word "standalone" `onFail` word "STANDALONE") commit $ do tok TokEqual `onFail` failP "missing = in 'standalone' decl" bracket (tok TokQuote) (tok TokQuote) ( (word "yes" >> return True) `onFail` (word "no" >> return False) `onFail` failP "'standalone' decl requires 'yes' or 'no' value" ) {- element :: XParser (Element Posn) element = do tok TokAnyOpen (ElemTag n as) <- elemtag oneOf' [ ("self-closing tag <"++n++"/>" , do tok TokEndClose return (Elem n as [])) , ("after open tag <"++n++">" , do tok TokAnyClose cs <- many content p <- posn m <- bracket (tok TokEndOpen) (tok TokAnyClose) qname checkmatch p n m return (Elem n as cs)) ] `adjustErr` (("in element tag "++n++",\n")++) -} -- | Return a complete element including all its inner content. element :: XParser (Element Posn) element = do tok TokAnyOpen (ElemTag n as) <- elemtag ( do tok TokEndClose commit (return (Elem n as [])) `onFail` do tok TokAnyClose commit $ do return (Elem n as) `apply` manyFinally content (do p <- posn m <- bracket (tok TokEndOpen) (tok TokAnyClose) qname checkmatch p n m) ) `adjustErrBad` (("in element tag "++printableName n++",\n")++) checkmatch :: Posn -> QName -> QName -> XParser () checkmatch p n m = if n == m then return () else failBad ("tag <"++printableName n++"> terminated by \n at "++show p) -- | Parse only the parts between angle brackets in an element tag. elemtag :: XParser ElemTag elemtag = do n <- qname `adjustErrBad` ("malformed element tag\n"++) as <- many attribute return (ElemTag n as) -- | For use with stream parsers - returns the complete opening element tag. elemOpenTag :: XParser ElemTag elemOpenTag = do tok TokAnyOpen e <- elemtag tok TokAnyClose return e -- | For use with stream parsers - accepts a closing tag, provided it -- matches the given element name. elemCloseTag :: QName -> XParser () elemCloseTag n = do tok TokEndOpen p <- posn m <- qname tok TokAnyClose checkmatch p n m attribute :: XParser Attribute attribute = do n <- qname `adjustErr` ("malformed attribute name\n"++) tok TokEqual `onFail` failBadP "missing = in attribute" v <- attvalue `onFail` failBadP "missing attvalue" return (n,v) -- | Return a content particle, e.g. text, element, reference, etc content :: XParser (Content Posn) content = do { p <- posn ; c' <- content' ; return (c' p) } where content' = oneOf' [ ("element", element >>= return . CElem) , ("chardata", chardata >>= return . CString False) , ("reference", reference >>= return . CRef) , ("CDATA", cdsect >>= return . CString True) , ("misc", misc >>= return . CMisc) ] `adjustErrP` ("when looking for a content item,\n"++) -- (\ (element, text, reference, CDATA section, , or ") elementdecl :: XParser ElementDecl elementdecl = do tok TokSpecialOpen tok (TokSpecial ELEMENTx) n <- peRef qname `adjustErrBad` ("expecting identifier in ELEMENT decl\n"++) c <- peRef contentspec `adjustErrBad` (("in content spec of ELEMENT decl: " ++printableName n++"\n")++) blank (tok TokAnyClose) `onFail` failBadP ("expected > terminating ELEMENT decl" ++"\n element name was "++show (printableName n) ++"\n contentspec was "++(\ (ContentSpec p)-> show p) c) return (ElementDecl n c) contentspec :: XParser ContentSpec contentspec = oneOf' [ ("EMPTY", peRef (word "EMPTY") >> return EMPTY) , ("ANY", peRef (word "ANY") >> return ANY) , ("mixed", peRef mixed >>= return . Mixed) , ("simple", peRef cp >>= return . ContentSpec) ] -- `adjustErr` ("when looking for content spec,\n"++) -- `adjustErr` (++"\nLooking for content spec (EMPTY, ANY, mixed, etc)") choice :: XParser [CP] choice = do myBracket (tok TokBraOpen `debug` "Trying choice") (blank (tok TokBraClose `debug` "Succeeded with choice")) (peRef cp `sepBy1` blank (tok TokPipe)) sequence :: XParser [CP] sequence = do myBracket (tok TokBraOpen `debug` "Trying sequence") (blank (tok TokBraClose `debug` "Succeeded with sequence")) (peRef cp `sepBy1` blank (tok TokComma)) cp :: XParser CP cp = oneOf [ ( do n <- qname m <- modifier let c = TagName n m return c `debug` ("ContentSpec: name "++show c)) , ( do ss <- sequence m <- modifier let c = Seq ss m return c `debug` ("ContentSpec: sequence "++show c)) , ( do cs <- choice m <- modifier let c = Choice cs m return c `debug` ("ContentSpec: choice "++show c)) ] `adjustErr` (++"\nwhen looking for a content particle") modifier :: XParser Modifier modifier = oneOf [ ( tok TokStar >> return Star ) , ( tok TokQuery >> return Query ) , ( tok TokPlus >> return Plus ) , ( return None ) ] -- just for debugging instance Show CP where show (TagName n m) = printableName n++show m show (Choice cps m) = '(': concat (intersperse "|" (map show cps)) ++")"++show m show (Seq cps m) = '(': concat (intersperse "," (map show cps)) ++")"++show m instance Show Modifier where show None = "" show Query = "?" show Star = "*" show Plus = "+" ---- mixed :: XParser Mixed mixed = do tok TokBraOpen peRef (do tok TokHash word "PCDATA") commit $ oneOf [ ( do cs <- many (peRef (do tok TokPipe peRef qname)) blank (tok TokBraClose >> tok TokStar) return (PCDATAplus cs)) , ( blank (tok TokBraClose >> tok TokStar) >> return PCDATA) , ( blank (tok TokBraClose) >> return PCDATA) ] `adjustErrP` (++"\nLooking for mixed content spec (#PCDATA | ...)*\n") attlistdecl :: XParser AttListDecl attlistdecl = do tok TokSpecialOpen tok (TokSpecial ATTLISTx) n <- peRef qname `adjustErrBad` ("expecting identifier in ATTLIST\n"++) ds <- peRef (many1 (peRef attdef)) blank (tok TokAnyClose) `onFail` failBadP "missing > terminating ATTLIST" return (AttListDecl n ds) attdef :: XParser AttDef attdef = do n <- peRef qname `adjustErr` ("expecting attribute name\n"++) t <- peRef atttype `adjustErr` (("within attlist defn: " ++printableName n++",\n")++) d <- peRef defaultdecl `adjustErr` (("in attlist defn: " ++printableName n++",\n")++) return (AttDef n t d) atttype :: XParser AttType atttype = oneOf' [ ("CDATA", word "CDATA" >> return StringType) , ("tokenized", tokenizedtype >>= return . TokenizedType) , ("enumerated", enumeratedtype >>= return . EnumeratedType) ] `adjustErr` ("looking for ATTTYPE,\n"++) -- `adjustErr` (++"\nLooking for ATTTYPE (CDATA, tokenized, or enumerated") tokenizedtype :: XParser TokenizedType tokenizedtype = oneOf [ ( word "ID" >> return ID) , ( word "IDREF" >> return IDREF) , ( word "IDREFS" >> return IDREFS) , ( word "ENTITY" >> return ENTITY) , ( word "ENTITIES" >> return ENTITIES) , ( word "NMTOKEN" >> return NMTOKEN) , ( word "NMTOKENS" >> return NMTOKENS) ] `onFail` do { t <- next ; failP ("Expected one of" ++" (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)" ++"\nbut got "++show t) } enumeratedtype :: XParser EnumeratedType enumeratedtype = oneOf' [ ("NOTATION", notationtype >>= return . NotationType) , ("enumerated", enumeration >>= return . Enumeration) ] `adjustErr` ("looking for an enumerated or NOTATION type,\n"++) notationtype :: XParser NotationType notationtype = do word "NOTATION" bracket (tok TokBraOpen) (blank (tok TokBraClose)) (peRef name `sepBy1` peRef (tok TokPipe)) enumeration :: XParser Enumeration enumeration = bracket (tok TokBraOpen) (blank (tok TokBraClose)) (peRef nmtoken `sepBy1` blank (peRef (tok TokPipe))) defaultdecl :: XParser DefaultDecl defaultdecl = oneOf' [ ("REQUIRED", tok TokHash >> word "REQUIRED" >> return REQUIRED) , ("IMPLIED", tok TokHash >> word "IMPLIED" >> return IMPLIED) , ("FIXED", do f <- maybe (tok TokHash >> word "FIXED" >> return FIXED) a <- peRef attvalue return (DefaultTo a f) ) ] `adjustErr` ("looking for an attribute default decl,\n"++) conditionalsect :: XParser ConditionalSect conditionalsect = oneOf' [ ( "INCLUDE" , do tok TokSectionOpen peRef (tok (TokSection INCLUDEx)) p <- posn tok TokSqOpen `onFail` failBadP "missing [ after INCLUDE" i <- many (peRef extsubsetdecl) tok TokSectionClose `onFail` failBadP ("missing ]]> for INCLUDE section" ++"\n begun at "++show p) return (IncludeSect i)) , ( "IGNORE" , do tok TokSectionOpen peRef (tok (TokSection IGNOREx)) p <- posn tok TokSqOpen `onFail` failBadP "missing [ after IGNORE" many newIgnore -- many ignoresectcontents tok TokSectionClose `onFail` failBadP ("missing ]]> for IGNORE section" ++"\n begun at "++show p) return (IgnoreSect [])) ] `adjustErr` ("in a conditional section,\n"++) newIgnore :: XParser Ignore newIgnore = ( do tok TokSectionOpen many newIgnore `debug` "IGNORING conditional section" tok TokSectionClose return Ignore `debug` "end of IGNORED conditional section") `onFail` ( do t <- nottok [TokSectionOpen,TokSectionClose] return Ignore `debug` ("ignoring: "++show t)) --- obsolete? --ignoresectcontents :: XParser IgnoreSectContents --ignoresectcontents = do -- i <- ignore -- is <- many (do tok TokSectionOpen -- ic <- ignoresectcontents -- tok TokSectionClose -- ig <- ignore -- return (ic,ig)) -- return (IgnoreSectContents i is) -- --ignore :: XParser Ignore --ignore = do -- is <- many1 (nottok [TokSectionOpen,TokSectionClose]) -- return Ignore `debug` ("ignored all of: "++show is) ---- -- | Return either a general entity reference, or a character reference. reference :: XParser Reference reference = do myBracket (tok TokAmp) (tok TokSemi) (freetext >>= val) where val ('#':'x':i) | all isHexDigit i = return . RefChar . fst . head . readHex $ i val ('#':i) | all isDigit i = return . RefChar . fst . head . readDec $ i val name = return . RefEntity $ name {- -- following is incorrect reference = ( charref >>= return . RefChar) `onFail` ( entityref >>= return . RefEntity) entityref :: XParser EntityRef entityref = do bracket (tok TokAmp) (tok TokSemi) name charref :: XParser CharRef charref = do bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal) where readCharVal ('#':'x':i) = return . fst . head . readHex $ i readCharVal ('#':i) = return . fst . head . readDec $ i readCharVal _ = mzero -} pereference :: XParser PEReference pereference = do myBracket (tok TokPercent) (tok TokSemi) nmtoken entitydecl :: XParser EntityDecl entitydecl = ( gedecl >>= return . EntityGEDecl) `onFail` ( pedecl >>= return . EntityPEDecl) gedecl :: XParser GEDecl gedecl = do tok TokSpecialOpen tok (TokSpecial ENTITYx) n <- name e <- entitydef `adjustErrBad` (("in general entity defn "++n++",\n")++) tok TokAnyClose `onFail` failBadP ("expected > terminating G ENTITY decl "++n) stUpdate (addGE n e) `debug` ("added GE defn &"++n++";") return (GEDecl n e) pedecl :: XParser PEDecl pedecl = do tok TokSpecialOpen tok (TokSpecial ENTITYx) tok TokPercent n <- name e <- pedef `adjustErrBad` (("in parameter entity defn "++n++",\n")++) tok TokAnyClose `onFail` failBadP ("expected > terminating P ENTITY decl "++n) stUpdate (addPE n e) `debug` ("added PE defn %"++n++";\n"++show e) return (PEDecl n e) entitydef :: XParser EntityDef entitydef = oneOf' [ ("entityvalue", entityvalue >>= return . DefEntityValue) , ("external", do eid <- externalid ndd <- maybe ndatadecl return (DefExternalID eid ndd)) ] pedef :: XParser PEDef pedef = oneOf' [ ("entityvalue", entityvalue >>= return . PEDefEntityValue) , ("externalid", externalid >>= return . PEDefExternalID) ] externalid :: XParser ExternalID externalid = oneOf' [ ("SYSTEM", do word "SYSTEM" s <- systemliteral return (SYSTEM s) ) , ("PUBLIC", do word "PUBLIC" p <- pubidliteral s <- systemliteral return (PUBLIC p s) ) ] `adjustErr` ("looking for an external id,\n"++) ndatadecl :: XParser NDataDecl ndatadecl = do word "NDATA" n <- name return (NDATA n) textdecl :: XParser TextDecl textdecl = do tok TokPIOpen (word "xml" `onFail` word "XML") v <- maybe versioninfo e <- encodingdecl tok TokPIClose `onFail` failP "expected ?> terminating text decl" return (TextDecl v e) --extparsedent :: XParser (ExtParsedEnt Posn) --extparsedent = do -- t <- maybe textdecl -- c <- content -- return (ExtParsedEnt t c) -- --extpe :: XParser ExtPE --extpe = do -- t <- maybe textdecl -- e <- many (peRef extsubsetdecl) -- return (ExtPE t e) encodingdecl :: XParser EncodingDecl encodingdecl = do (word "encoding" `onFail` word "ENCODING") tok TokEqual `onFail` failBadP "expected = in 'encoding' decl" f <- bracket (tok TokQuote) (tok TokQuote) freetext return (EncodingDecl f) notationdecl :: XParser NotationDecl notationdecl = do tok TokSpecialOpen tok (TokSpecial NOTATIONx) n <- name e <- either externalid publicid tok TokAnyClose `onFail` failBadP ("expected > terminating NOTATION decl "++n) return (NOTATION n e) publicid :: XParser PublicID publicid = do word "PUBLIC" p <- pubidliteral return (PUBLICID p) entityvalue :: XParser EntityValue entityvalue = do -- evs <- bracket (tok TokQuote) (tok TokQuote) (many (peRef ev)) tok TokQuote pn <- posn evs <- many ev tok TokQuote `onFail` failBadP "expected quote to terminate entityvalue" -- quoted text must be rescanned for possible PERefs st <- stGet Prelude.either failBad (return . EntityValue) . fst3 $ (runParser (many ev) st (reLexEntityValue (\s-> stringify (lookupPE s st)) pn (flattenEV (EntityValue evs)))) where stringify (Just (PEDefEntityValue ev)) = Just (flattenEV ev) stringify _ = Nothing ev :: XParser EV ev = oneOf' [ ("string", (string`onFail`freetext) >>= return . EVString) , ("reference", reference >>= return . EVRef) ] `adjustErr` ("looking for entity value,\n"++) attvalue :: XParser AttValue attvalue = do avs <- bracket (tok TokQuote) (tok TokQuote) (many (either freetext reference)) return (AttValue avs) systemliteral :: XParser SystemLiteral systemliteral = do s <- bracket (tok TokQuote) (tok TokQuote) freetext return (SystemLiteral s) -- note: refs &...; not permitted pubidliteral :: XParser PubidLiteral pubidliteral = do s <- bracket (tok TokQuote) (tok TokQuote) freetext return (PubidLiteral s) -- note: freetext is too liberal here -- | Return parsed freetext (i.e. until the next markup) chardata :: XParser CharData chardata = freetext HaXml-1.23.3/src/Text/XML/HaXml/ParseLazy.hs0000755000062000006210000007565611767644706017553 0ustar 1341796mkpasswd-- | A non-validating XML parser. For the input grammar, see -- . module Text.XML.HaXml.ParseLazy ( -- * Parse a whole document xmlParse -- , xmlParse' -- * Parse just a DTD , dtdParse -- , dtdParse' -- * Parse a partial document , xmlParseWith -- * Individual parsers for use with /xmlParseWith/ and module SAX , document, element, content , comment, chardata , reference, doctypedecl , processinginstruction , elemtag, qname, name, tok , elemOpenTag, elemCloseTag , emptySTs, XParser -- * These general utility functions don't belong here , fst3, snd3, thd3 ) where -- An XML parser, written using a slightly extended version of the -- Hutton/Meijer parser combinators. The input is tokenised internally -- by the lexer xmlLex. Whilst parsing, we gather a symbol -- table of entity references. PERefs must be defined before use, so we -- expand their uses as we encounter them, forcing the remainder of the -- input to be re-lexed and re-parsed. GERefs are simply stored for -- later retrieval. import Prelude hiding (either,maybe,sequence,catch) import qualified Prelude (either) import Data.Maybe hiding (maybe) import Data.List (intersperse) -- debugging only import Data.Char (isSpace,isDigit,isHexDigit) import Control.Monad hiding (sequence) import Numeric (readDec,readHex) --import Control.Exception (catch) import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces import Text.XML.HaXml.Posn import Text.XML.HaXml.Lex import Text.ParserCombinators.Poly.StateLazy import System.FilePath (combine, dropFileName) #if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \ ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__) import System.IO.Unsafe (unsafePerformIO) #elif defined(__GLASGOW_HASKELL__) import IOExts (unsafePerformIO) #elif defined(__NHC__) import IOExtras (unsafePerformIO) #elif defined(__HBC__) import UnsafePerformIO #endif -- #define DEBUG #if defined(DEBUG) # if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \ ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__) import Debug.Trace(trace) # elif defined(__GLASGOW_HASKELL__) import IOExts(trace) # elif defined(__NHC__) || defined(__HBC__) import NonStdTrace # endif v `debug` s = trace s v #else v `debug` _ = v #endif debug :: a -> String -> a -- | To parse a whole document, @xmlParse file content@ takes a filename -- (for generating error reports) and the string content of that file. -- A parse error causes program failure, with message to stderr. xmlParse :: String -> String -> Document Posn {- -- | To parse a whole document, @xmlParse' file content@ takes a filename -- (for generating error reports) and the string content of that file. -- Any parse error message is passed back to the caller through the -- @Either@ type. xmlParse' :: String -> String -> Either String (Document Posn) -} -- | To parse just a DTD, @dtdParse file content@ takes a filename -- (for generating error reports) and the string content of that -- file. If no DTD was found, you get @Nothing@ rather than an error. -- However, if a DTD is found but contains errors, the program crashes. dtdParse :: String -> String -> Maybe DocTypeDecl {- -- | To parse just a DTD, @dtdParse' file content@ takes a filename -- (for generating error reports) and the string content of that -- file. If no DTD was found, you get @Right Nothing@. -- If a DTD was found but contains errors, you get a @Left message@. dtdParse' :: String -> String -> Either String (Maybe DocTypeDecl) xmlParse' name inp = xmlParse name inp `catch` (Left . show) dtdParse' name inp = dtdParse name inp `catch` (Left . show) -} xmlParse name = fst3 . runParser (toEOF document) emptySTs . xmlLex name dtdParse name = fst3 . runParser justDTD emptySTs . xmlLex name toEOF :: XParser a -> XParser a toEOF = id -- there are other possible implementations... -- | To parse a partial document, e.g. from an XML-based stream protocol, -- where you may later want to get more document elements from the same -- stream. Arguments are: a parser for the item you want, and the -- already-lexed input to parse from. Returns the item you wanted -- (or an error message), plus the remainder of the input. xmlParseWith :: XParser a -> [(Posn,TokenT)] -> (Either String a, [(Posn,TokenT)]) xmlParseWith p = (\(v,_,s)->(Right v,s)) . runParser p emptySTs ---- Symbol table stuff ---- type SymTabs = (SymTab PEDef, SymTab EntityDef) -- | Some empty symbol tables for GE and PE references. emptySTs :: SymTabs emptySTs = (emptyST, emptyST) addPE :: String -> PEDef -> SymTabs -> SymTabs addPE n v (pe,ge) = (addST n v pe, ge) addGE :: String -> EntityDef -> SymTabs -> SymTabs addGE n v (pe,ge) = let newge = addST n v ge in newge `seq` (pe, newge) lookupPE :: String -> SymTabs -> Maybe PEDef lookupPE s (pe,_ge) = lookupST s pe flattenEV :: EntityValue -> String flattenEV (EntityValue evs) = concatMap flatten evs where flatten (EVString s) = s flatten (EVRef (RefEntity r)) = "&" ++r++";" flatten (EVRef (RefChar r)) = "&#"++show r++";" -- flatten (EVPERef n) = "%" ++n++";" ---- Misc ---- fst3 :: (a,b,c) -> a snd3 :: (a,b,c) -> b thd3 :: (a,b,c) -> c fst3 (a,_,_) = a snd3 (_,a,_) = a thd3 (_,_,a) = a ---- Auxiliary Parsing Functions ---- -- | Parse a bracketed item, discarding the brackets AND NOT using adjustErrBad myBracket :: PolyParse p => p bra -> p ket -> p a -> p a myBracket open close p = do do { open `adjustErr` ("Missing opening bracket:\n\t"++) ; p `discard` (close `adjustErr` ("Missing closing bracket:\n\t"++)) } -- | XParser is just a specialisation of the PolyStateLazy parser. type XParser a = Parser SymTabs (Posn,TokenT) a -- | Return the next token from the input only if it matches the given token. tok :: TokenT -> XParser TokenT tok t = do (p,t') <- next case t' of TokError _ -> report failBad (show t) p t' _ | t'==t -> return t | otherwise -> report fail (show t) p t' nottok :: [TokenT] -> XParser TokenT nottok ts = do (p,t) <- next if t`elem`ts then report fail ("no "++show t) p t else return t -- | Return a qualified name (although the namespace qualification is not -- processed here; this is merely to get the correct type). qname :: XParser QName qname = fmap N name -- | Return just a name, e.g. element name, attribute name. name :: XParser Name name = do (p,tok) <- next case tok of TokName s -> return s TokError _ -> report failBad "a name" p tok _ -> report fail "a name" p tok string, freetext :: XParser String string = do (p,t) <- next case t of TokName s -> return s _ -> report fail "text" p t freetext = do (p,t) <- next case t of TokFreeText s -> return s _ -> report fail "text" p t maybe :: XParser a -> XParser (Maybe a) maybe p = ( p >>= return . Just) `onFail` ( return Nothing) either :: XParser a -> XParser b -> XParser (Either a b) either p q = ( p >>= return . Left) `onFail` ( q >>= return . Right) word :: String -> XParser () word s = do { x <- next ; case x of (_p,TokName n) | s==n -> return () (_p,TokFreeText n) | s==n -> return () ( p,t@(TokError _)) -> report failBad (show s) p t ( p,t) -> report fail (show s) p t } posn :: XParser Posn posn = do { x@(p,_) <- next ; reparse [x] ; return p } nmtoken :: XParser NmToken nmtoken = (string `onFail` freetext) failP, failBadP :: String -> XParser a failP msg = do { p <- posn; fail (msg++"\n at "++show p) } failBadP msg = do { p <- posn; failBad (msg++"\n at "++show p) } report :: (String->XParser a) -> String -> Posn -> TokenT -> XParser a report fail expect p t = fail ("Expected "++expect++" but found "++show t ++"\n in "++show p) adjustErrP :: XParser a -> (String->String) -> XParser a p `adjustErrP` f = p `onFail` do pn <- posn (p `adjustErr` f) `adjustErr` (++show pn) peRef :: XParser a -> XParser a peRef p = p `onFail` do pn <- posn n <- pereference tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n) case tr of Just (PEDefEntityValue ev) -> do reparse (xmlReLex (posInNewCxt ("macro %"++n++";") (Just pn)) (flattenEV ev)) `debug` (" defn: "++flattenEV ev) peRef p Just (PEDefExternalID (PUBLIC _ (SystemLiteral f))) -> do let f' = combine (dropFileName $ posnFilename pn) f val = unsafePerformIO (readFile f') reparse (xmlReLex (posInNewCxt f' (Just pn)) val) `debug` (" reading from file "++f') peRef p Just (PEDefExternalID (SYSTEM (SystemLiteral f))) -> do let f' = combine (dropFileName $ posnFilename pn) f val = unsafePerformIO (readFile f') reparse (xmlReLex (posInNewCxt f' (Just pn)) val) `debug` (" reading from file "++f') peRef p Nothing -> fail ("PEReference use before definition: "++"%"++n++";" ++"\n at "++show pn) blank :: XParser a -> XParser a blank p = p `onFail` do n <- pereference tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n++" (is blank?)") case tr of Just (PEDefEntityValue ev) | all isSpace (flattenEV ev) -> do blank p `debug` "Empty macro definition" Just _ -> failP ("expected a blank PERef macro: "++"%"++n++";") Nothing -> failP ("PEReference use before definition: "++"%"++n++";") ---- XML Parsing Functions ---- justDTD :: XParser (Maybe DocTypeDecl) justDTD = do (ExtSubset _ ds) <- extsubset `debug` "Trying external subset" if null ds then fail "empty" else return (Just (DTD (N "extsubset") Nothing (concatMap extract ds))) `onFail` do (Prolog _ _ dtd _) <- prolog return dtd where extract (ExtMarkupDecl m) = [m] extract (ExtConditionalSect (IncludeSect i)) = concatMap extract i extract (ExtConditionalSect (IgnoreSect _)) = [] -- | Return an entire XML document including prolog and trailing junk. document :: XParser (Document Posn) document = do -- p <- prolog `adjustErr` ("unrecognisable XML prolog\n"++) -- e <- element -- ms <- many misc -- (_,ge) <- stGet -- return (Document p ge e ms) return Document `apply` (prolog `adjustErr` ("unrecognisable XML prolog\n"++)) `apply` (fmap snd stGet) `apply` element `apply` many misc -- | Return an XML comment. comment :: XParser Comment comment = do myBracket (tok TokCommentOpen) (tok TokCommentClose) freetext -- tok TokCommentOpen -- commit $ do -- c <- freetext -- tok TokCommentClose -- return c -- | Parse a processing instruction. processinginstruction :: XParser ProcessingInstruction processinginstruction = do tok TokPIOpen commit $ do n <- string `onFail` failP "processing instruction has no target" f <- freetext tok TokPIClose `onFail` failP ("missing ?> in in " -- raise ((runParser aux emptySTs . xmlReLex p) s) return (fst3 ((runParser aux emptySTs . xmlReLex p) s)) where aux = do v <- versioninfo `onFail` failP "missing XML version info" e <- maybe encodingdecl s <- maybe sddecl return (XMLDecl v e s) -- raise (Left err, _, _) = failP err -- raise (Right ok, _, _) = return ok versioninfo :: XParser VersionInfo versioninfo = do (word "version" `onFail` word "VERSION") tok TokEqual bracket (tok TokQuote) (tok TokQuote) freetext misc :: XParser Misc misc = oneOf' [ ("", comment >>= return . Comment) , ("", processinginstruction >>= return . PI) ] -- | Return a DOCTYPE decl, indicating a DTD. doctypedecl :: XParser DocTypeDecl doctypedecl = do tok TokSpecialOpen tok (TokSpecial DOCTYPEx) commit $ do n <- qname eid <- maybe externalid es <- maybe (bracket (tok TokSqOpen) (tok TokSqClose) (many (peRef markupdecl))) blank (tok TokAnyClose) `onFail` failP "missing > in DOCTYPE decl" return (DTD n eid (case es of { Nothing -> []; Just e -> e })) -- | Return a DTD markup decl, e.g. ELEMENT, ATTLIST, etc markupdecl :: XParser MarkupDecl markupdecl = oneOf' [ ("ELEMENT", elementdecl >>= return . Element) , ("ATTLIST", attlistdecl >>= return . AttList) , ("ENTITY", entitydecl >>= return . Entity) , ("NOTATION", notationdecl >>= return . Notation) , ("misc", misc >>= return . MarkupMisc) ] `adjustErrP` ("when looking for a markup decl,\n"++) -- (\ (ELEMENT, ATTLIST, ENTITY, NOTATION, , or ") extsubset :: XParser ExtSubset extsubset = do td <- maybe textdecl ds <- many (peRef extsubsetdecl) return (ExtSubset td ds) extsubsetdecl :: XParser ExtSubsetDecl extsubsetdecl = ( markupdecl >>= return . ExtMarkupDecl) `onFail` ( conditionalsect >>= return . ExtConditionalSect) sddecl :: XParser SDDecl sddecl = do (word "standalone" `onFail` word "STANDALONE") commit $ do tok TokEqual `onFail` failP "missing = in 'standalone' decl" bracket (tok TokQuote) (tok TokQuote) ( (word "yes" >> return True) `onFail` (word "no" >> return False) `onFail` failP "'standalone' decl requires 'yes' or 'no' value" ) {- element :: XParser (Element Posn) element = do tok TokAnyOpen (ElemTag n as) <- elemtag oneOf' [ ("self-closing tag <"++n++"/>" , do tok TokEndClose return (Elem n as [])) , ("after open tag <"++n++">" , do tok TokAnyClose cs <- many content p <- posn m <- bracket (tok TokEndOpen) (tok TokAnyClose) qname checkmatch p n m return (Elem n as cs)) ] `adjustErr` (("in element tag "++n++",\n")++) -} -- | Return a complete element including all its inner content. element :: XParser (Element Posn) element = do tok TokAnyOpen (ElemTag n as) <- elemtag return (Elem n as) `apply` ( do tok TokEndClose return [] `onFail` do tok TokAnyClose commit $ manyFinally content (do p <- posn m <- bracket (tok TokEndOpen) (tok TokAnyClose) qname checkmatch p n m) ) `adjustErrBad` (("in element tag "++printableName n++",\n")++) checkmatch :: Posn -> QName -> QName -> XParser () checkmatch p n m = if n == m then return () else failBad ("tag <"++printableName n++"> terminated by \n at "++show p) -- | Parse only the parts between angle brackets in an element tag. elemtag :: XParser ElemTag elemtag = do n <- qname `adjustErrBad` ("malformed element tag\n"++) as <- many attribute return (ElemTag n as) -- | For use with stream parsers - returns the complete opening element tag. elemOpenTag :: XParser ElemTag elemOpenTag = do tok TokAnyOpen e <- elemtag tok TokAnyClose return e -- | For use with stream parsers - accepts a closing tag, provided it -- matches the given element name. elemCloseTag :: QName -> XParser () elemCloseTag n = do tok TokEndOpen p <- posn m <- qname tok TokAnyClose checkmatch p n m attribute :: XParser Attribute attribute = do n <- qname `adjustErr` ("malformed attribute name\n"++) tok TokEqual `onFail` failBadP "missing = in attribute" v <- attvalue `onFail` failBadP "missing attvalue" return (n,v) -- | Return a content particle, e.g. text, element, reference, etc content :: XParser (Content Posn) content = do { p <- posn ; c' <- content' ; return (c' p) } where content' = oneOf' [ ("element", element >>= return . CElem) , ("chardata", chardata >>= return . CString False) , ("reference", reference >>= return . CRef) , ("CDATA", cdsect >>= return . CString True) , ("misc", misc >>= return . CMisc) ] `adjustErrP` ("when looking for a content item,\n"++) -- (\ (element, text, reference, CDATA section, , or ") elementdecl :: XParser ElementDecl elementdecl = do tok TokSpecialOpen tok (TokSpecial ELEMENTx) n <- peRef qname `adjustErrBad` ("expecting identifier in ELEMENT decl\n"++) c <- peRef contentspec `adjustErrBad` (("in content spec of ELEMENT decl: " ++printableName n++"\n")++) blank (tok TokAnyClose) `onFail` failBadP ("expected > terminating ELEMENT decl" ++"\n element name was "++show (printableName n) ++"\n contentspec was "++(\ (ContentSpec p)-> show p) c) return (ElementDecl n c) contentspec :: XParser ContentSpec contentspec = oneOf' [ ("EMPTY", peRef (word "EMPTY") >> return EMPTY) , ("ANY", peRef (word "ANY") >> return ANY) , ("mixed", peRef mixed >>= return . Mixed) , ("simple", peRef cp >>= return . ContentSpec) ] -- `adjustErr` ("when looking for content spec,\n"++) -- `adjustErr` (++"\nLooking for content spec (EMPTY, ANY, mixed, etc)") choice :: XParser [CP] choice = do myBracket (tok TokBraOpen `debug` "Trying choice") (blank (tok TokBraClose `debug` "Succeeded with choice")) (peRef cp `sepBy1` blank (tok TokPipe)) sequence :: XParser [CP] sequence = do myBracket (tok TokBraOpen `debug` "Trying sequence") (blank (tok TokBraClose `debug` "Succeeded with sequence")) (peRef cp `sepBy1` blank (tok TokComma)) cp :: XParser CP cp = oneOf [ ( do n <- qname m <- modifier let c = TagName n m return c `debug` ("ContentSpec: name "++show c)) , ( do ss <- sequence m <- modifier let c = Seq ss m return c `debug` ("ContentSpec: sequence "++show c)) , ( do cs <- choice m <- modifier let c = Choice cs m return c `debug` ("ContentSpec: choice "++show c)) ] `adjustErr` (++"\nwhen looking for a content particle") modifier :: XParser Modifier modifier = oneOf [ ( tok TokStar >> return Star ) , ( tok TokQuery >> return Query ) , ( tok TokPlus >> return Plus ) , ( return None ) ] -- just for debugging instance Show CP where show (TagName n m) = printableName n++show m show (Choice cps m) = '(': concat (intersperse "|" (map show cps)) ++")"++show m show (Seq cps m) = '(': concat (intersperse "," (map show cps)) ++")"++show m instance Show Modifier where show None = "" show Query = "?" show Star = "*" show Plus = "+" ---- mixed :: XParser Mixed mixed = do tok TokBraOpen peRef (do tok TokHash word "PCDATA") commit $ oneOf [ ( do cs <- many (peRef (do tok TokPipe peRef qname)) blank (tok TokBraClose >> tok TokStar) return (PCDATAplus cs)) , ( blank (tok TokBraClose >> tok TokStar) >> return PCDATA) , ( blank (tok TokBraClose) >> return PCDATA) ] `adjustErrP` (++"\nLooking for mixed content spec (#PCDATA | ...)*\n") attlistdecl :: XParser AttListDecl attlistdecl = do tok TokSpecialOpen tok (TokSpecial ATTLISTx) n <- peRef qname `adjustErrBad` ("expecting identifier in ATTLIST\n"++) ds <- peRef (many1 (peRef attdef)) blank (tok TokAnyClose) `onFail` failBadP "missing > terminating ATTLIST" return (AttListDecl n ds) attdef :: XParser AttDef attdef = do n <- peRef qname `adjustErr` ("expecting attribute name\n"++) t <- peRef atttype `adjustErr` (("within attlist defn: " ++printableName n++",\n")++) d <- peRef defaultdecl `adjustErr` (("in attlist defn: " ++printableName n++",\n")++) return (AttDef n t d) atttype :: XParser AttType atttype = oneOf' [ ("CDATA", word "CDATA" >> return StringType) , ("tokenized", tokenizedtype >>= return . TokenizedType) , ("enumerated", enumeratedtype >>= return . EnumeratedType) ] `adjustErr` ("looking for ATTTYPE,\n"++) -- `adjustErr` (++"\nLooking for ATTTYPE (CDATA, tokenized, or enumerated") tokenizedtype :: XParser TokenizedType tokenizedtype = oneOf [ ( word "ID" >> return ID) , ( word "IDREF" >> return IDREF) , ( word "IDREFS" >> return IDREFS) , ( word "ENTITY" >> return ENTITY) , ( word "ENTITIES" >> return ENTITIES) , ( word "NMTOKEN" >> return NMTOKEN) , ( word "NMTOKENS" >> return NMTOKENS) ] `onFail` do { t <- next ; failP ("Expected one of" ++" (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)" ++"\nbut got "++show t) } enumeratedtype :: XParser EnumeratedType enumeratedtype = oneOf' [ ("NOTATION", notationtype >>= return . NotationType) , ("enumerated", enumeration >>= return . Enumeration) ] `adjustErr` ("looking for an enumerated or NOTATION type,\n"++) notationtype :: XParser NotationType notationtype = do word "NOTATION" bracket (tok TokBraOpen) (blank (tok TokBraClose)) (peRef name `sepBy1` peRef (tok TokPipe)) enumeration :: XParser Enumeration enumeration = bracket (tok TokBraOpen) (blank (tok TokBraClose)) (peRef nmtoken `sepBy1` blank (peRef (tok TokPipe))) defaultdecl :: XParser DefaultDecl defaultdecl = oneOf' [ ("REQUIRED", tok TokHash >> word "REQUIRED" >> return REQUIRED) , ("IMPLIED", tok TokHash >> word "IMPLIED" >> return IMPLIED) , ("FIXED", do f <- maybe (tok TokHash >> word "FIXED" >> return FIXED) a <- peRef attvalue return (DefaultTo a f) ) ] `adjustErr` ("looking for an attribute default decl,\n"++) conditionalsect :: XParser ConditionalSect conditionalsect = oneOf' [ ( "INCLUDE" , do tok TokSectionOpen peRef (tok (TokSection INCLUDEx)) p <- posn tok TokSqOpen `onFail` failBadP "missing [ after INCLUDE" i <- many (peRef extsubsetdecl) tok TokSectionClose `onFail` failBadP ("missing ]]> for INCLUDE section" ++"\n begun at "++show p) return (IncludeSect i)) , ( "IGNORE" , do tok TokSectionOpen peRef (tok (TokSection IGNOREx)) p <- posn tok TokSqOpen `onFail` failBadP "missing [ after IGNORE" i <- many newIgnore -- many ignoresectcontents tok TokSectionClose `onFail` failBadP ("missing ]]> for IGNORE section" ++"\n begun at "++show p) return (IgnoreSect [])) ] `adjustErr` ("in a conditional section,\n"++) newIgnore :: XParser Ignore newIgnore = ( do tok TokSectionOpen many newIgnore `debug` "IGNORING conditional section" tok TokSectionClose return Ignore `debug` "end of IGNORED conditional section") `onFail` ( do t <- nottok [TokSectionOpen,TokSectionClose] return Ignore `debug` ("ignoring: "++show t)) --- obsolete? --ignoresectcontents :: XParser IgnoreSectContents --ignoresectcontents = do -- i <- ignore -- is <- many (do tok TokSectionOpen -- ic <- ignoresectcontents -- tok TokSectionClose -- ig <- ignore -- return (ic,ig)) -- return (IgnoreSectContents i is) -- --ignore :: XParser Ignore --ignore = do -- is <- many1 (nottok [TokSectionOpen,TokSectionClose]) -- return Ignore `debug` ("ignored all of: "++show is) ---- -- | Return either a general entity reference, or a character reference. reference :: XParser Reference reference = do bracket (tok TokAmp) (tok TokSemi) (freetext >>= val) where val ('#':'x':i) | all isHexDigit i = return . RefChar . fst . head . readHex $ i val ('#':i) | all isDigit i = return . RefChar . fst . head . readDec $ i val name = return . RefEntity $ name {- -- following is incorrect reference = ( charref >>= return . RefChar) `onFail` ( entityref >>= return . RefEntity) entityref :: XParser EntityRef entityref = do bracket (tok TokAmp) (tok TokSemi) name charref :: XParser CharRef charref = do bracket (tok TokAmp) (tok TokSemi) (freetext >>= readCharVal) where readCharVal ('#':'x':i) = return . fst . head . readHex $ i readCharVal ('#':i) = return . fst . head . readDec $ i readCharVal _ = mzero -} pereference :: XParser PEReference pereference = do myBracket (tok TokPercent) (tok TokSemi) nmtoken entitydecl :: XParser EntityDecl entitydecl = ( gedecl >>= return . EntityGEDecl) `onFail` ( pedecl >>= return . EntityPEDecl) gedecl :: XParser GEDecl gedecl = do tok TokSpecialOpen tok (TokSpecial ENTITYx) n <- name e <- entitydef `adjustErrBad` (("in general entity defn "++n++",\n")++) tok TokAnyClose `onFail` failBadP ("expected > terminating G ENTITY decl "++n) stUpdate (addGE n e) `debug` ("added GE defn &"++n++";") return (GEDecl n e) pedecl :: XParser PEDecl pedecl = do tok TokSpecialOpen tok (TokSpecial ENTITYx) tok TokPercent n <- name e <- pedef `adjustErrBad` (("in parameter entity defn "++n++",\n")++) tok TokAnyClose `onFail` failBadP ("expected > terminating P ENTITY decl "++n) stUpdate (addPE n e) `debug` ("added PE defn %"++n++";\n"++show e) return (PEDecl n e) entitydef :: XParser EntityDef entitydef = oneOf' [ ("entityvalue", entityvalue >>= return . DefEntityValue) , ("external", do eid <- externalid ndd <- maybe ndatadecl return (DefExternalID eid ndd)) ] pedef :: XParser PEDef pedef = oneOf' [ ("entityvalue", entityvalue >>= return . PEDefEntityValue) , ("externalid", externalid >>= return . PEDefExternalID) ] externalid :: XParser ExternalID externalid = oneOf' [ ("SYSTEM", do word "SYSTEM" s <- systemliteral return (SYSTEM s) ) , ("PUBLIC", do word "PUBLIC" p <- pubidliteral s <- systemliteral return (PUBLIC p s) ) ] `adjustErr` ("looking for an external id,\n"++) ndatadecl :: XParser NDataDecl ndatadecl = do word "NDATA" n <- name return (NDATA n) textdecl :: XParser TextDecl textdecl = do tok TokPIOpen (word "xml" `onFail` word "XML") v <- maybe versioninfo e <- encodingdecl tok TokPIClose `onFail` failP "expected ?> terminating text decl" return (TextDecl v e) --extparsedent :: XParser (ExtParsedEnt Posn) --extparsedent = do -- t <- maybe textdecl -- c <- content -- return (ExtParsedEnt t c) -- --extpe :: XParser ExtPE --extpe = do -- t <- maybe textdecl -- e <- many (peRef extsubsetdecl) -- return (ExtPE t e) encodingdecl :: XParser EncodingDecl encodingdecl = do (word "encoding" `onFail` word "ENCODING") tok TokEqual `onFail` failBadP "expected = in 'encoding' decl" f <- bracket (tok TokQuote) (tok TokQuote) freetext return (EncodingDecl f) notationdecl :: XParser NotationDecl notationdecl = do tok TokSpecialOpen tok (TokSpecial NOTATIONx) n <- name e <- either externalid publicid tok TokAnyClose `onFail` failBadP ("expected > terminating NOTATION decl "++n) return (NOTATION n e) publicid :: XParser PublicID publicid = do word "PUBLIC" p <- pubidliteral return (PUBLICID p) entityvalue :: XParser EntityValue entityvalue = do -- evs <- bracket (tok TokQuote) (tok TokQuote) (many (peRef ev)) tok TokQuote pn <- posn evs <- many ev tok TokQuote `onFail` failBadP "expected quote to terminate entityvalue" -- quoted text must be rescanned for possible PERefs st <- stGet -- Prelude.either failBad (return . EntityValue) . fst3 $ return . EntityValue . fst3 $ (runParser (many ev) st (reLexEntityValue (\s-> stringify (lookupPE s st)) pn (flattenEV (EntityValue evs)))) where stringify (Just (PEDefEntityValue ev)) = Just (flattenEV ev) stringify _ = Nothing ev :: XParser EV ev = oneOf' [ ("string", (string`onFail`freetext) >>= return . EVString) , ("reference", reference >>= return . EVRef) ] `adjustErr` ("looking for entity value,\n"++) attvalue :: XParser AttValue attvalue = do avs <- bracket (tok TokQuote) (tok TokQuote) (many (either freetext reference)) return (AttValue avs) systemliteral :: XParser SystemLiteral systemliteral = do s <- bracket (tok TokQuote) (tok TokQuote) freetext return (SystemLiteral s) -- note: refs &...; not permitted pubidliteral :: XParser PubidLiteral pubidliteral = do s <- bracket (tok TokQuote) (tok TokQuote) freetext return (PubidLiteral s) -- note: freetext is too liberal here -- | Return parsed freetext (i.e. until the next markup) chardata :: XParser CharData chardata = freetext HaXml-1.23.3/src/Text/XML/HaXml/Posn.hs0000755000062000006210000000504511767644706016541 0ustar 1341796mkpasswd-- | Define a position datatype for giving locations in error messages. module Text.XML.HaXml.Posn ( -- * Position type Posn() -- ** Constructors of a new position , posInNewCxt -- :: String -> Maybe Posn -> Posn , noPos -- :: Posn -- ** Strictifier , forcep -- ** Modifiers , addcol, newline, tab, white -- ** Accessors , posnFilename, posnLine, posnColumn ) where import Data.Char -- | Source positions contain a filename, line, column, and an -- inclusion point, which is itself another source position, -- recursively. data Posn = Pn String !Int !Int (Maybe Posn) deriving (Eq) posnFilename :: Posn -> FilePath posnFilename (Pn f _ _ _) = f posnLine, posnColumn :: Posn -> Int posnLine (Pn _ x _ _) = x posnColumn (Pn _ _ x _) = x -- | Dummy value for generated data, where a true source position does -- not exist. noPos :: Posn noPos = Pn "no recorded position" 0 0 Nothing -- | @posInNewCxt name pos@ creates a new source position from an old one. -- It is used when opening a new file (e.g. a DTD inclusion), to denote -- the start of the file @name@, but retain the stacked information that -- it was included from the old @pos@. posInNewCxt :: String -> Maybe Posn -> Posn posInNewCxt name pos = Pn name 1 1 pos instance Show Posn where showsPrec _ (Pn f l c i) = showString "file " . showString f . showString " at line " . shows l . showString " col " . shows c . ( case i of Nothing -> id Just p -> showString "\n used by " . shows p ) -- | Just used to strictify the internal values of a position, to avoid -- space leaks. forcep :: Posn -> Int forcep (Pn _ n m _) = m `seq` n -- | Add n character positions to the given position. addcol :: Int -> Posn -> Posn addcol n (Pn f r c i) = Pn f r (c+n) i -- | Add a newline or tab to the given position. newline, tab :: Posn -> Posn newline (Pn f r _ i) = Pn f (r+1) 1 i tab (Pn f r c i) = Pn f r (((c`div`8)+1)*8) i -- | Add the given whitespace char to the given position. -- Precondition: @white c | isSpace c = True@ white :: Char -> Posn -> Posn white ' ' = addcol 1 white '\n' = newline white '\r' = id white '\t' = tab white '\xa0' = addcol 1 white x | isSpace x = addcol 1 -- other Unicode whitespace white _ = error "precondition not satisfied: Posn.white c | isSpace c" HaXml-1.23.3/src/Text/XML/HaXml/Pretty.hs0000755000062000006210000002740111767644706017111 0ustar 1341796mkpasswd-- | This is a pretty-printer for turning the internal representation -- of generic structured XML documents into the Doc type (which can -- later be rendered using Text.PrettyPrint.HughesPJ.render). -- Essentially there is one pp function for each type in -- Text.Xml.HaXml.Types, so you can pretty-print as much or as little -- of the document as you wish. module Text.XML.HaXml.Pretty ( -- * Pretty-print a whole document document -- ** Just one content , content -- ** Just one tagged element , element -- * Pretty-print just a DTD , doctypedecl -- ** The prolog , prolog -- ** A content particle description , cp ) where import Prelude hiding (maybe,either) import Data.Maybe hiding (maybe) import Data.List (intersperse) --import Char (isSpace) import Text.PrettyPrint.HughesPJ import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1 either f _ (Left x) = f x either _ g (Right x) = g x maybe :: (t -> Doc) -> Maybe t -> Doc maybe _ Nothing = empty maybe f (Just x) = f x --peref p = text "%" <> text p <> text ";" ---- document :: Document i -> Doc prolog :: Prolog -> Doc xmldecl :: XMLDecl -> Doc misc :: Misc -> Doc sddecl :: Bool -> Doc doctypedecl :: DocTypeDecl -> Doc markupdecl :: MarkupDecl -> Doc --extsubset :: ExtSubset -> Doc --extsubsetdecl :: ExtSubsetDecl -> Doc cp :: CP -> Doc element :: Element i -> Doc attribute :: Attribute -> Doc --etc content :: Content i -> Doc ---- document (Document p _ e m)= prolog p $$ element e $$ vcat (map misc m) prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$ vcat (map misc m1) $$ maybe doctypedecl dtd $$ vcat (map misc m2) xmldecl (XMLDecl v e sd) = text " text v <> text "'" <+> maybe encodingdecl e <+> maybe sddecl sd <+> text "?>" misc (Comment s) = text "" misc (PI (n,s)) = text " text n <+> text s <> text "?>" sddecl sd | sd = text "standalone='yes'" | otherwise = text "standalone='no'" doctypedecl (DTD n eid ds) = if null ds then hd <> text ">" else hd <+> text " [" $$ vcat (map markupdecl ds) $$ text "]>" where hd = text " qname n <+> maybe externalid eid markupdecl (Element e) = elementdecl e markupdecl (AttList a) = attlistdecl a markupdecl (Entity e) = entitydecl e markupdecl (Notation n) = notationdecl n markupdecl (MarkupMisc m) = misc m --markupdecl (MarkupPE p m) = peref p --extsubset (ExtSubset t ds) = maybe textdecl t $$ -- vcat (map extsubsetdecl ds) --extmarkupdecl (ExtMarkupDecl m) = markupdecl m --extsubsetdecl (ExtConditionalSect c) = conditionalsect c -- -- extsubsetdecl (ExtPEReference p e) = peref p element (Elem n as []) = text "<" <> qname n <+> fsep (map attribute as) <> text "/>" element e@(Elem n as cs) | all isText cs = text "<" <> qname n <+> fsep (map attribute as) <> text ">" <> hcat (map content cs) <> text " qname n <> text ">" | otherwise = let (d,c) = carryelem e empty in d <> c isText :: Content t -> Bool isText (CString _ _ _) = True isText (CRef _ _) = True isText _ = False carryelem :: Element t -> Doc -> (Doc, Doc) carrycontent :: Content t -> Doc -> (Doc, Doc) spancontent :: [Content a] -> Doc -> ([Doc],Doc) carryelem (Elem n as []) c = ( c <> text "<" <> qname n <+> fsep (map attribute as) , text "/>") carryelem (Elem n as cs) c = let (cs0,d0) = spancontent cs (text ">") in ( c <> text "<"<>qname n <+> fsep (map attribute as) $$ nest 2 (vcat cs0) <> d0 <> text " qname n , text ">") carrycontent (CElem e _) c = carryelem e c carrycontent (CString False s _) c = (c <> chardata s, empty) carrycontent (CString True s _) c = (c <> cdsect s, empty) carrycontent (CRef r _) c = (c <> reference r, empty) carrycontent (CMisc m _) c = (c <> misc m, empty) spancontent [] c = ([],c) spancontent (a:as) c | isText a = let (ts,rest) = span isText (a:as) formatted = c <> hcat (map content ts) in spancontent rest formatted | otherwise = let (b, c0) = carrycontent a c (bs,c1) = spancontent as c0 in (b:bs, c1) attribute (n,v) = qname n <> text "=" <> attvalue v content (CElem e _) = element e content (CString False s _) = chardata s content (CString True s _) = cdsect s content (CRef r _) = reference r content (CMisc m _) = misc m elementdecl :: ElementDecl -> Doc elementdecl (ElementDecl n cs) = text " qname n <+> contentspec cs <> text ">" contentspec :: ContentSpec -> Doc contentspec EMPTY = text "EMPTY" contentspec ANY = text "ANY" contentspec (Mixed m) = mixed m contentspec (ContentSpec c) = cp c --contentspec (ContentPE p cs) = peref p cp (TagName n m) = parens (qname n) <> modifier m cp (Choice cs m) = parens (hcat (intersperse (text "|") (map cp cs))) <> modifier m cp (Seq cs m) = parens (hcat (intersperse (text ",") (map cp cs))) <> modifier m --cp (CPPE p c) = peref p modifier :: Modifier -> Doc modifier None = empty modifier Query = text "?" modifier Star = text "*" modifier Plus = text "+" mixed :: Mixed -> Doc mixed PCDATA = text "(#PCDATA)" mixed (PCDATAplus ns) = text "(#PCDATA |" <+> hcat (intersperse (text "|") (map qname ns)) <> text ")*" attlistdecl :: AttListDecl -> Doc attlistdecl (AttListDecl n ds) = text " qname n <+> fsep (map attdef ds) <> text ">" attdef :: AttDef -> Doc attdef (AttDef n t d) = qname n <+> atttype t <+> defaultdecl d atttype :: AttType -> Doc atttype StringType = text "CDATA" atttype (TokenizedType t) = tokenizedtype t atttype (EnumeratedType t) = enumeratedtype t tokenizedtype :: TokenizedType -> Doc tokenizedtype ID = text "ID" tokenizedtype IDREF = text "IDREF" tokenizedtype IDREFS = text "IDREFS" tokenizedtype ENTITY = text "ENTITY" tokenizedtype ENTITIES = text "ENTITIES" tokenizedtype NMTOKEN = text "NMTOKEN" tokenizedtype NMTOKENS = text "NMTOKENS" enumeratedtype :: EnumeratedType -> Doc enumeratedtype (NotationType n)= notationtype n enumeratedtype (Enumeration e) = enumeration e notationtype :: [String] -> Doc notationtype ns = text "NOTATION" <+> parens (hcat (intersperse (text "|") (map text ns))) enumeration :: [String] -> Doc enumeration ns = parens (hcat (intersperse (text "|") (map nmtoken ns))) defaultdecl :: DefaultDecl -> Doc defaultdecl REQUIRED = text "#REQUIRED" defaultdecl IMPLIED = text "#IMPLIED" defaultdecl (DefaultTo a f) = maybe (const (text "#FIXED")) f <+> attvalue a --conditionalsect (IncludeSect i)= text " -- vcat (map extsubsetdecl i) <+> text "]]>" --conditionalsect (IgnoreSect i) = text " -- fsep (map ignoresectcontents i) <+> text "]]>" --ignore (Ignore) = empty --ignoresectcontents (IgnoreSectContents i is) -- = ignore i <+> vcat (map internal is) -- where internal (ics,i) = text " -- ignoresectcontents ics <+> -- text "]]>" <+> ignore i reference :: Reference -> Doc reference (RefEntity er) = entityref er reference (RefChar cr) = charref cr entityref :: String -> Doc entityref n = text "&" <> text n <> text ";" charref :: (Show a) => a -> Doc charref c = text "&#" <> text (show c) <> text ";" entitydecl :: EntityDecl -> Doc entitydecl (EntityGEDecl d) = gedecl d entitydecl (EntityPEDecl d) = pedecl d gedecl :: GEDecl -> Doc gedecl (GEDecl n ed) = text " text n <+> entitydef ed <> text ">" pedecl :: PEDecl -> Doc pedecl (PEDecl n pd) = text " text n <+> pedef pd <> text ">" entitydef :: EntityDef -> Doc entitydef (DefEntityValue ew) = entityvalue ew entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd pedef :: PEDef -> Doc pedef (PEDefEntityValue ew) = entityvalue ew pedef (PEDefExternalID eid) = externalid eid externalid :: ExternalID -> Doc externalid (SYSTEM sl) = text "SYSTEM" <+> systemliteral sl externalid (PUBLIC i sl) = text "PUBLIC" <+> pubidliteral i <+> systemliteral sl ndatadecl :: NDataDecl -> Doc ndatadecl (NDATA n) = text "NDATA" <+> text n --textdecl (TextDecl vi ed) = text " maybe text vi <+> -- encodingdecl ed <+> text "?>" --extparsedent (ExtParsedEnt t c)= maybe textdecl t <+> content c --extpe (ExtPE t esd) = maybe textdecl t <+> -- vcat (map extsubsetdecl esd) notationdecl :: NotationDecl -> Doc notationdecl (NOTATION n e) = text " text n <+> either externalid publicid e <> text ">" publicid :: PublicID -> Doc publicid (PUBLICID p) = text "PUBLIC" <+> pubidliteral p encodingdecl :: EncodingDecl -> Doc encodingdecl (EncodingDecl s) = text "encoding='" <> text s <> text "'" nmtoken :: String -> Doc nmtoken s = text s attvalue :: AttValue -> Doc attvalue (AttValue esr) = text "\"" <> hcat (map (either text reference) esr) <> text "\"" entityvalue :: EntityValue -> Doc entityvalue (EntityValue evs) | containsDoubleQuote evs = text "'" <> hcat (map ev evs) <> text "'" | otherwise = text "\"" <> hcat (map ev evs) <> text "\"" ev :: EV -> Doc ev (EVString s) = text s --ev (EVPERef p e) = peref p ev (EVRef r) = reference r pubidliteral :: PubidLiteral -> Doc pubidliteral (PubidLiteral s) | '"' `elem` s = text "'" <> text s <> text "'" | otherwise = text "\"" <> text s <> text "\"" systemliteral :: SystemLiteral -> Doc systemliteral (SystemLiteral s) | '"' `elem` s = text "'" <> text s <> text "'" | otherwise = text "\"" <> text s <> text "\"" chardata :: String -> Doc chardata s = {-if all isSpace s then empty else-} text s cdsect :: String -> Doc cdsect c = text " chardata c <> text "]]>" qname n = text (printableName n) ---- containsDoubleQuote :: [EV] -> Bool containsDoubleQuote evs = any csq evs where csq (EVString s) = '"' `elem` s csq _ = False HaXml-1.23.3/src/Text/XML/HaXml/SAX.hs0000755000062000006210000000635711767644706016264 0ustar 1341796mkpasswd-- | A streaming XML parser, using a method known as SAX. SAX isn't really a -- standard, but an implementation, so it's just an \"SAX-like\" parser. -- This module allows you parse an XML document without having to evaluate -- it as a whole. This is needed for protocols like jabber, which use xml -- streams for communication. module Text.XML.HaXml.SAX ( SaxElement(..) , saxParse ) where import Text.XML.HaXml.Types import Text.XML.HaXml.Parse import Text.XML.HaXml.Lex import Text.ParserCombinators.Poly.State data SaxElement = SaxDocTypeDecl DocTypeDecl -- ^ A doctype declaration occured(\) | SaxProcessingInstruction ProcessingInstruction -- ^ A processing instruction occured (\) | SaxComment String -- ^ A comment occured (\" misc (PI (n,s)) = text " text n <+> text s <+> text "?>" sddecl sd | sd = text "standalone='yes'" | otherwise = text "standalone='no'" doctypedecl (DTD n eid ds) = if null ds then hd <> text ">" else hd <+> text " [" $$ vcat (map markupdecl ds) $$ text "]>" where hd = text " qname n <+> maybe externalid eid markupdecl (Element e) = elementdecl e markupdecl (AttList a) = attlistdecl a markupdecl (Entity e) = entitydecl e markupdecl (Notation n) = notationdecl n markupdecl (MarkupMisc m) = misc m --markupdecl (MarkupPE p m) = peref p -- _ (ExtSubset t ds) = maybe textdecl t $$ -- vcat (map extsubsetdecl ds) -- _ (ExtMarkupDecl m) = markupdecl m -- extsubsetdecl (ExtConditionalSect c) = conditionalsect c --extsubsetdecl (ExtPEReference p e) = peref p element (Elem n as []) = text "<" <> qname n <+> fsep (map attribute as) <> text "/>" element e@(Elem n as cs) -- | any isText cs = text "<" <> qname n <+> fsep (map attribute as) <> -- text ">" <> hcat (map content cs) <> -- text " qname n <> text ">" | isText (head cs) = text "<" <> qname n <+> fsep (map attribute as) <> text ">" <> hcat (map content cs) <> text " qname n <> text ">" | otherwise = let (d,c) = carryelem e empty in d <> c isText :: Content t -> Bool isText (CString _ _ _) = True isText (CRef _ _) = True isText _ = False carryelem (Elem n as []) c = ( c <> text "<" <> qname n <+> fsep (map attribute as) , text "/>") carryelem (Elem n as cs) c -- | any isText cs = ( c <> element e, empty) | otherwise = let (cs0,d0) = carryscan carrycontent cs (text ">") in ( c <> text "<" <> qname n <+> fsep (map attribute as) $$ nest (2 :: Int) (vcat cs0) <> --- $$ d0 <> text " qname n , text ">") carrycontent :: Content t -> [Char] -> ([Char], [Char]) carryelem :: Element t -> [Char] -> ([Char], [Char]) carrycontent (CElem e _) c = carryelem e c carrycontent (CString False s _) c = (c <> chardata s, empty) carrycontent (CString True s _) c = (c <> cdsect s, empty) carrycontent (CRef r _) c = (c <> reference r, empty) carrycontent (CMisc m _) c = (c <> misc m, empty) carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c) carryscan _ [] c = ([],c) carryscan f (a:as) c = let (b, c0) = f a c (bs,c1) = carryscan f as c0 in (b:bs, c1) --carryelem e@(Elem n as cs) c -- | isText (head cs) = -- ( start <> -- text ">" <> hcat (map content cs) <> text " text n -- , text ">") -- | otherwise = -- let (d,c0) = foldl carrycontent (start, text ">") cs in -- ( d <> c0 <> text " text n -- , text ">") -- where start = c <> text "<" <> text n <+> fsep (map attribute as) -- --carrycontent (d,c) (CElem e) = let (d',c') = carryelem e c in -- (d $$ nest 2 d', c') --carrycontent (d,c) (CString _ s) = (d <> c <> chardata s, empty) --carrycontent (d,c) (CRef r) = (d <> c <> reference r,empty) --carrycontent (d,c) (CMisc m) = (d $$ c <> misc m, empty) attribute (n,v) = qname n <> text "=" <> attvalue v content (CElem e _) = element e content (CString False s _) = chardata s content (CString True s _) = cdsect s content (CRef r _) = reference r content (CMisc m _) = misc m elementdecl :: ElementDecl -> [Char] elementdecl (ElementDecl n cs) = text " qname n <+> contentspec cs <> text ">" contentspec :: ContentSpec -> [Char] contentspec EMPTY = text "EMPTY" contentspec ANY = text "ANY" contentspec (Mixed m) = mixed m contentspec (ContentSpec c) = cp c --contentspec (ContentPE p cs) = peref p cp (TagName n m) = qname n <> modifier m cp (Choice cs m) = parens (hcat (intersperse (text "|") (map cp cs))) <> modifier m cp (Seq cs m) = parens (hcat (intersperse (text ",") (map cp cs))) <> modifier m --cp (CPPE p c) = peref p modifier :: Modifier -> [Char] modifier None = empty modifier Query = text "?" modifier Star = text "*" modifier Plus = text "+" mixed :: Mixed -> [Char] mixed PCDATA = text "(#PCDATA)" mixed (PCDATAplus ns) = text "(#PCDATA |" <+> hcat (intersperse (text "|") (map qname ns)) <> text ")*" attlistdecl :: AttListDecl -> [Char] attlistdecl (AttListDecl n ds) = text " qname n <+> fsep (map attdef ds) <> text ">" attdef :: AttDef -> [Char] attdef (AttDef n t d) = qname n <+> atttype t <+> defaultdecl d atttype :: AttType -> [Char] atttype StringType = text "CDATA" atttype (TokenizedType t) = tokenizedtype t atttype (EnumeratedType t) = enumeratedtype t tokenizedtype :: TokenizedType -> [Char] tokenizedtype ID = text "ID" tokenizedtype IDREF = text "IDREF" tokenizedtype IDREFS = text "IDREFS" tokenizedtype ENTITY = text "ENTITY" tokenizedtype ENTITIES = text "ENTITIES" tokenizedtype NMTOKEN = text "NMTOKEN" tokenizedtype NMTOKENS = text "NMTOKENS" enumeratedtype :: EnumeratedType -> [Char] enumeratedtype (NotationType n)= notationtype n enumeratedtype (Enumeration e) = enumeration e notationtype :: [[Char]] -> [Char] notationtype ns = text "NOTATION" <+> parens (hcat (intersperse (text "|") (map text ns))) enumeration :: [[Char]] -> [Char] enumeration ns = parens (hcat (intersperse (text "|") (map nmtoken ns))) defaultdecl :: DefaultDecl -> [Char] defaultdecl REQUIRED = text "#REQUIRED" defaultdecl IMPLIED = text "#IMPLIED" defaultdecl (DefaultTo a f) = maybe (const (text "#FIXED")) f <+> attvalue a -- _ (IncludeSect i)= text " -- vcat (map extsubsetdecl i) <+> text "]]>" -- conditionalsect (IgnoreSect i) = text " -- fsep (map ignoresectcontents i) <+> text "]]>" -- _ (Ignore) = empty -- _ (IgnoreSectContents i is) -- = ignore i <+> vcat (map internal is) -- where internal (ics,i) = text " -- ignoresectcontents ics <+> -- text "]]>" <+> ignore i reference :: Reference -> [Char] reference (RefEntity er) = entityref er reference (RefChar cr) = charref cr entityref :: [Char] -> [Char] entityref n = text "&" <> text n <> text ";" charref :: (Show a) => a -> [Char] charref c = text "&#" <> text (show c) <> text ";" entitydecl :: EntityDecl -> [Char] entitydecl (EntityGEDecl d) = gedecl d entitydecl (EntityPEDecl d) = pedecl d gedecl :: GEDecl -> [Char] gedecl (GEDecl n ed) = text " text n <+> entitydef ed <> text ">" pedecl :: PEDecl -> [Char] pedecl (PEDecl n pd) = text " text n <+> pedef pd <> text ">" entitydef :: EntityDef -> [Char] entitydef (DefEntityValue ew) = entityvalue ew entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd pedef :: PEDef -> [Char] pedef (PEDefEntityValue ew) = entityvalue ew pedef (PEDefExternalID eid) = externalid eid externalid :: ExternalID -> [Char] externalid (SYSTEM sl) = text "SYSTEM" <+> systemliteral sl externalid (PUBLIC i sl) = text "PUBLIC" <+> pubidliteral i <+> systemliteral sl ndatadecl :: NDataDecl -> [Char] ndatadecl (NDATA n) = text "NDATA" <+> text n -- _ (TextDecl vi ed) = text " maybe text vi <+> -- encodingdecl ed <> text "?>" -- _ (ExtParsedEnt t c)= maybe textdecl t <+> content c -- _ (ExtPE t esd) = maybe textdecl t <+> -- vcat (map extsubsetdecl esd) notationdecl :: NotationDecl -> [Char] notationdecl (NOTATION n e) = text " text n <+> either externalid publicid e <> text ">" publicid :: PublicID -> [Char] publicid (PUBLICID p) = text "PUBLICID" <+> pubidliteral p encodingdecl :: EncodingDecl -> [Char] encodingdecl (EncodingDecl s) = text "encoding='" <> text s <> text "'" nmtoken :: t -> t nmtoken s = text s attvalue :: AttValue -> [Char] attvalue (AttValue esr) = text "\"" <> hcat (map (either text reference) esr) <> text "\"" entityvalue :: EntityValue -> [Char] entityvalue (EntityValue evs) | containsDoubleQuote evs = text "'" <> hcat (map ev evs) <> text "'" | otherwise = text "\"" <> hcat (map ev evs) <> text "\"" ev :: EV -> String ev (EVString s) = text s --ev (EVPERef p e) = peref p ev (EVRef r) = reference r pubidliteral :: PubidLiteral -> [Char] pubidliteral (PubidLiteral s) | '"' `elem` s = text "'" <> text s <> text "'" | otherwise = text "\"" <> text s <> text "\"" systemliteral :: SystemLiteral -> [Char] systemliteral (SystemLiteral s) | '"' `elem` s = text "'" <> text s <> text "'" | otherwise = text "\"" <> text s <> text "\"" chardata :: t -> t chardata s = {-if all isSpace s then empty else-} text s cdsect :: [Char] -> [Char] cdsect c = text " chardata c <> text "]]>" qname n = text (printableName n) ---- containsDoubleQuote :: [EV] -> Bool containsDoubleQuote evs = any csq evs where csq (EVString s) = '"' `elem` s csq _ = False HaXml-1.23.3/src/Text/XML/HaXml/TypeMapping.hs0000755000062000006210000003361611767644706020064 0ustar 1341796mkpasswdmodule Text.XML.HaXml.TypeMapping ( -- * A class to get an explicit type representation for any value HTypeable(..) -- sole method, toHType -- * Explicit representation of Haskell datatype information , HType(..) -- instance of Eq, Show , Constr(..) -- instance of Eq, Show -- * Helper functions to extract type info as strings , showHType -- :: HType -> ShowS , showConstr -- :: Int -> HType -> String -- * Conversion from Haskell datatype to DTD , toDTD ) where import Text.XML.HaXml.Types import Data.List (partition, intersperse) import Text.PrettyPrint.HughesPJ (render) import qualified Text.XML.HaXml.Pretty as PP ------------------------------------------------------------------------ -- idea: in DrIFT, -- named field == primitive type, becomes an attribute -- named field == single-constructor type, renames the tag -- named field == multi-constructor type, as normal -- if prefix of all named fields is roughly typename, delete it -- | @HTypeable@ promises that we can create an explicit representation of -- of the type of any value. class HTypeable a where toHType :: a -> HType -- | A concrete representation of any Haskell type. data HType = Maybe HType | List HType | Tuple [HType] | Prim String String -- ^ separate Haskell name and XML name | String | Defined String [HType] [Constr] -- ^ A user-defined type has a name, a sequence of type variables, -- and a set of constructors. (The variables might already be -- instantiated to actual types.) deriving (Show) instance Eq HType where (Maybe x) == (Maybe y) = x==y (List x) == (List y) = x==y (Tuple xs) == (Tuple ys) = xs==ys (Prim x _) == (Prim y _) = x==y String == String = True (Defined n _xs _) == (Defined m _ys _) = n==m -- && xs==ys _ == _ = False -- | A concrete representation of any user-defined Haskell constructor. -- The constructor has a name, and a sequence of component types. The -- first sequence of types represents the minimum set of free type -- variables occurring in the (second) list of real component types. -- If there are fieldnames, they are contained in the final list, and -- correspond one-to-one with the component types. data Constr = Constr String [HType] [HType] -- (Maybe [String]) deriving (Eq,Show) -- | Project the n'th constructor from an HType and convert it to a string -- suitable for an XML tagname. showConstr :: Int -> HType -> String showConstr n (Defined _ _ cs) = flatConstr (cs!!n) "" showConstr _ _ = error "no constructors for builtin types" ------------------------------------------------------------------------ -- Some instances instance HTypeable Bool where toHType _ = Prim "Bool" "bool" instance HTypeable Int where toHType _ = Prim "Int" "int" instance HTypeable Integer where toHType _ = Prim "Integer" "integer" instance HTypeable Float where toHType _ = Prim "Float" "float" instance HTypeable Double where toHType _ = Prim "Double" "double" instance HTypeable Char where toHType _ = Prim "Char" "char" instance HTypeable () where toHType _ = Prim "unit" "unit" instance (HTypeable a, HTypeable b) => HTypeable (a,b) where toHType p = Tuple [toHType a, toHType b] where (a,b) = p instance (HTypeable a, HTypeable b, HTypeable c) => HTypeable (a,b,c) where toHType p = Tuple [toHType a, toHType b, toHType c] where (a,b,c) = p instance (HTypeable a, HTypeable b, HTypeable c, HTypeable d) => HTypeable (a,b,c,d) where toHType p = Tuple [toHType a, toHType b, toHType c, toHType d] where (a,b,c,d) = p instance (HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e) => HTypeable (a,b,c,d,e) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e ] where (a,b,c,d,e) = p instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e , HTypeable f) => HTypeable (a,b,c,d,e,f) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e, toHType f ] where (a,b,c,d,e,f) = p instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e , HTypeable f, HTypeable g) => HTypeable (a,b,c,d,e,f,g) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e, toHType f, toHType g ] where (a,b,c,d,e,f,g) = p instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e , HTypeable f, HTypeable g, HTypeable h) => HTypeable (a,b,c,d,e,f,g,h) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e, toHType f, toHType g, toHType h ] where (a,b,c,d,e,f,g,h) = p instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e , HTypeable f, HTypeable g, HTypeable h, HTypeable i) => HTypeable (a,b,c,d,e,f,g,h,i) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e, toHType f, toHType g, toHType h , toHType i ] where (a,b,c,d,e,f,g,h,i) = p instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j) => HTypeable (a,b,c,d,e,f,g,h,i,j) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e, toHType f, toHType g, toHType h , toHType i, toHType j ] where (a,b,c,d,e,f,g,h,i,j) = p instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j , HTypeable k) => HTypeable (a,b,c,d,e,f,g,h,i,j,k) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e, toHType f, toHType g, toHType h , toHType i, toHType j, toHType k ] where (a,b,c,d,e,f,g,h,i,j,k) = p instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j , HTypeable k, HTypeable l) => HTypeable (a,b,c,d,e,f,g,h,i,j,k,l) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e, toHType f, toHType g, toHType h , toHType i, toHType j, toHType k, toHType l ] where (a,b,c,d,e,f,g,h,i,j,k,l) = p instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j , HTypeable k, HTypeable l, HTypeable m) => HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e, toHType f, toHType g, toHType h , toHType i, toHType j, toHType k, toHType l , toHType m ] where (a,b,c,d,e,f,g,h,i,j,k,l,m) = p instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j , HTypeable k, HTypeable l, HTypeable m, HTypeable n) => HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e, toHType f, toHType g, toHType h , toHType i, toHType j, toHType k, toHType l , toHType m, toHType n ] where (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = p instance ( HTypeable a, HTypeable b, HTypeable c, HTypeable d, HTypeable e , HTypeable f, HTypeable g, HTypeable h, HTypeable i, HTypeable j , HTypeable k, HTypeable l, HTypeable m, HTypeable n, HTypeable o) => HTypeable (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where toHType p = Tuple [ toHType a, toHType b, toHType c, toHType d , toHType e, toHType f, toHType g, toHType h , toHType i, toHType j, toHType k, toHType l , toHType m, toHType n, toHType o ] where (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = p instance (HTypeable a) => HTypeable (Maybe a) where toHType m = Maybe (toHType x) where (Just x) = m instance (HTypeable a, HTypeable b) => HTypeable (Either a b) where toHType m = Defined "Either" [hx, hy] [ Constr "Left" [hx] [hx] {-Nothing-} , Constr "Right" [hy] [hy] {-Nothing-}] where (Left x) = m (Right y) = m hx = toHType x hy = toHType y instance HTypeable a => HTypeable [a] where toHType xs = case toHType x of (Prim "Char" _) -> String _ -> List (toHType x) where (x:_) = xs ------------------------------------------------------------------------ -- | 'toDTD' converts a concrete representation of the Haskell type of -- a value (obtained by the method 'toHType') into a real DocTypeDecl. -- It ensures that PERefs are defined before they are used, and that no -- element or attribute-list is declared more than once. toDTD :: HType -> DocTypeDecl toDTD ht = DTD (toplevel ht) Nothing (macrosFirst (reverse (h2d True [] [] [ht]))) where macrosFirst :: [MarkupDecl] -> [MarkupDecl] macrosFirst decls = concat [p, p'] where (p, p') = partition f decls f (Entity _) = True f _ = False toplevel ht@(Defined _ _ _) = N $ showHType ht "-XML" toplevel ht@_ = N $ showHType ht "" c0 = False h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl] -- toplevel? history history remainingwork result h2d _c _history _chist [] = [] h2d c history chist (ht:hts) = if ht `elem` history then h2d c0 history chist hts else case ht of Maybe ht0 -> declelem ht: h2d c0 (ht:history) chist (ht0:hts) List ht0 -> declelem ht: h2d c0 (ht:history) chist (ht0:hts) Tuple hts0 -> (c ? (declelem ht:)) (h2d c0 history chist (hts0++hts)) Prim _ _ -> declprim ht ++ h2d c0 (ht:history) chist hts String -> declstring: h2d c0 (ht:history) chist hts Defined _ _ cs -> let hts0 = concatMap grab cs in (c ? (decltopelem ht:)) (declmacro ht chist) ++ h2d c0 (ht:history) (cs++chist) (hts0++hts) declelem ht = Element (ElementDecl (N $ showHType ht "") (ContentSpec (outerHtExpr ht))) decltopelem ht = -- hack to avoid peref at toplevel Element (ElementDecl (N $ showHType ht "-XML") (ContentSpec (innerHtExpr ht None))) declmacro ht@(Defined _ _ cs) chist = Entity (EntityPEDecl (PEDecl (showHType ht "") (PEDefEntityValue ev))): concatMap (declConstr chist) cs where ev = EntityValue [EVString (render (PP.cp (outerHtExpr ht)))] declConstr chist c@(Constr s fv hts) | c `notElem` chist = [Element (ElementDecl (N $ flatConstr c "") (ContentSpec (constrHtExpr c)))] | otherwise = [] declprim (Prim _ t) = [ Element (ElementDecl (N t) EMPTY) , AttList (AttListDecl (N t) [AttDef (N "value") StringType REQUIRED])] declstring = Element (ElementDecl (N "string") (Mixed PCDATA)) grab (Constr _ _ hts) = hts (?) :: Bool -> (a->a) -> (a->a) b ? f | b = f | not b = id -- Flatten an HType to a String suitable for an XML tagname. showHType :: HType -> ShowS showHType (Maybe ht) = showString "maybe-" . showHType ht showHType (List ht) = showString "list-" . showHType ht showHType (Tuple hts) = showString "tuple" . shows (length hts) . showChar '-' . foldr1 (.) (intersperse (showChar '-') (map showHType hts)) showHType (Prim _ t) = showString t showHType String = showString "string" showHType (Defined s fv _) = showString s . ((length fv > 0) ? (showChar '-')) . foldr (.) id (intersperse (showChar '-') (map showHType fv)) flatConstr :: Constr -> ShowS flatConstr (Constr s fv _) = showString s . ((length fv > 0) ? (showChar '-')) . foldr (.) id (intersperse (showChar '-') (map showHType fv)) outerHtExpr :: HType -> CP outerHtExpr (Maybe ht) = innerHtExpr ht Query outerHtExpr (List ht) = innerHtExpr ht Star outerHtExpr (Defined _s _fv cs) = Choice (map (\c->TagName (N $ flatConstr c "") None) cs) None outerHtExpr ht = innerHtExpr ht None innerHtExpr :: HType -> Modifier -> CP innerHtExpr (Prim _ t) m = TagName (N t) m innerHtExpr (Tuple hts) m = Seq (map (\c-> innerHtExpr c None) hts) m innerHtExpr ht@(Defined _ _ _) m = -- CPPE (showHType ht "") (outerHtExpr ht) TagName (N ('%': showHType ht ";")) m -- ***HACK!!!*** innerHtExpr ht m = TagName (N $ showHType ht "") m constrHtExpr :: Constr -> CP constrHtExpr (Constr _s _fv []) = TagName (N "EMPTY") None -- ***HACK!!!*** constrHtExpr (Constr _s _fv hts) = innerHtExpr (Tuple hts) None ------------------------------------------------------------------------ HaXml-1.23.3/src/Text/XML/HaXml/Types.hs0000755000062000006210000002300311767644706016720 0ustar 1341796mkpasswd{- | This module defines an internal (generic) representation for XML documents including their DTDs. History: The original module was derived by hand from the XML specification, following the grammar precisely. Then we simplified the types, removing layers of indirection and redundancy, and generally making things easier to work with. Then we allowed PEReferences to be ubiquitous, by removing them from the types and resolving all PE references at parse-time. Finally, we added a per-document symbol table for GEReferences, and a whitespace-significance flag for plaintext. -} module Text.XML.HaXml.Types ( -- * A simple symbol table mapping strings (references) to values. SymTab -- ** Symbol table operations , emptyST , addST , lookupST -- * XML Types -- ** The top-level document container , Document(..) -- ** The main document content , Element(..) , ElemTag(..) , Content(..) , Attribute , AttValue(..) , info -- ** Administrative parts of the document , Prolog(..) , XMLDecl(..) , Misc(..) , ProcessingInstruction , SDDecl , VersionInfo , Comment , PITarget -- ** The DTD -- *** content model , DocTypeDecl(..) , MarkupDecl(..) , ExtSubset(..) , ExtSubsetDecl(..) , ElementDecl(..) , ContentSpec(..) , CP(..) , Modifier(..) , Mixed(..) -- *** attribute model , AttListDecl(..) , AttDef(..) , AttType(..) , TokenizedType(..) , EnumeratedType(..) , NotationType , Enumeration , DefaultDecl(..) , FIXED(..) -- *** conditional sections , ConditionalSect(..) , IncludeSect , IgnoreSect , Ignore(..) , IgnoreSectContents(..) -- ** References , Reference(..) , EntityRef , CharRef , PEReference -- ** Entities , EntityDecl(..) , GEDecl(..) , PEDecl(..) , EntityDef(..) , PEDef(..) , ExternalID(..) , NDataDecl(..) , TextDecl(..) , ExtParsedEnt(..) , ExtPE(..) , NotationDecl(..) , PublicID(..) , EncodingDecl(..) , EntityValue(..) , EV(..) , PubidLiteral(..) , SystemLiteral(..) -- ** Namespaces , QName(..) , Namespace(..) -- ** Basic value types , Name , Names , NmToken , NmTokens , CharData , CDSect ) where {- A simple symbol table for storing macros whilst parsing. -} type SymTab a = [(String,a)] emptyST :: SymTab a emptyST = [] addST :: String -> a -> SymTab a -> SymTab a addST n v = ((n,v):) lookupST :: String -> SymTab a -> Maybe a lookupST = lookup {- XML types start here -} -- | The symbol table stored in a document holds all its general entity -- reference definitions. data Document i = Document Prolog (SymTab EntityDef) (Element i) [Misc] deriving Eq data Prolog = Prolog (Maybe XMLDecl) [Misc] (Maybe DocTypeDecl) [Misc] deriving Eq data XMLDecl = XMLDecl VersionInfo (Maybe EncodingDecl) (Maybe SDDecl) deriving Eq data Misc = Comment Comment | PI ProcessingInstruction deriving Eq type ProcessingInstruction = (PITarget,String) type SDDecl = Bool type VersionInfo = String type Comment = String type PITarget = String data DocTypeDecl = DTD QName (Maybe ExternalID) [MarkupDecl] deriving Eq data MarkupDecl = Element ElementDecl | AttList AttListDecl | Entity EntityDecl | Notation NotationDecl | MarkupMisc Misc deriving Eq data ExtSubset = ExtSubset (Maybe TextDecl) [ExtSubsetDecl] deriving Eq data ExtSubsetDecl = ExtMarkupDecl MarkupDecl | ExtConditionalSect ConditionalSect deriving Eq data Element i = Elem QName [Attribute] [Content i] deriving Eq -- ElemTag is an intermediate type for parsing only data ElemTag = ElemTag QName [Attribute] type Attribute = (QName, AttValue) data Content i = CElem (Element i) i | CString Bool CharData i -- ^ bool is whether whitespace is significant | CRef Reference i | CMisc Misc i -- custom instance of Eq, ignoring the informational elements. instance Eq (Content i) where (CElem e _) == (CElem e' _) = e==e' (CString b c _) == (CString b' c' _) = b==b' && c==c' (CRef r _) == (CRef r' _) = r==r' (CMisc m _) == (CMisc m' _) = m==m' info :: Content t -> t info (CElem _ i) = i info (CString _ _ i) = i info (CRef _ i) = i info (CMisc _ i) = i instance Functor Document where fmap f (Document p st e ms) = Document p st (fmap f e) ms instance Functor Element where fmap f (Elem t as cs) = Elem t as (map (fmap f) cs) instance Functor Content where fmap f (CElem e i) = CElem (fmap f e) (f i) fmap f (CString b s i) = CString b s (f i) fmap f (CRef r i) = CRef r (f i) fmap f (CMisc m i) = CMisc m (f i) data ElementDecl = ElementDecl QName ContentSpec deriving Eq data ContentSpec = EMPTY | ANY | Mixed Mixed | ContentSpec CP deriving Eq data CP = TagName QName Modifier | Choice [CP] Modifier | Seq [CP] Modifier deriving Eq data Modifier = None -- ^ Just One | Query -- ^ Zero Or One | Star -- ^ Zero Or More | Plus -- ^ One Or More deriving Eq data Mixed = PCDATA | PCDATAplus [QName] deriving Eq data AttListDecl = AttListDecl QName [AttDef] deriving Eq data AttDef = AttDef QName AttType DefaultDecl deriving Eq data AttType = StringType | TokenizedType TokenizedType | EnumeratedType EnumeratedType deriving Eq data TokenizedType = ID | IDREF | IDREFS | ENTITY | ENTITIES | NMTOKEN | NMTOKENS deriving Eq data EnumeratedType = NotationType NotationType | Enumeration Enumeration deriving Eq type NotationType = [Name] -- nonempty list type Enumeration = [NmToken] -- nonempty list data DefaultDecl = REQUIRED | IMPLIED | DefaultTo AttValue (Maybe FIXED) deriving Eq data FIXED = FIXED deriving Eq data ConditionalSect = IncludeSect IncludeSect | IgnoreSect IgnoreSect deriving Eq type IncludeSect = [ExtSubsetDecl] type IgnoreSect = [IgnoreSectContents] data Ignore = Ignore deriving Eq data IgnoreSectContents = IgnoreSectContents Ignore [(IgnoreSectContents,Ignore)] deriving Eq data Reference = RefEntity EntityRef | RefChar CharRef deriving (Eq,Show) type EntityRef = Name type CharRef = Int type PEReference = Name data EntityDecl = EntityGEDecl GEDecl | EntityPEDecl PEDecl deriving Eq data GEDecl = GEDecl Name EntityDef deriving Eq data PEDecl = PEDecl Name PEDef deriving Eq data EntityDef = DefEntityValue EntityValue | DefExternalID ExternalID (Maybe NDataDecl) deriving Eq data PEDef = PEDefEntityValue EntityValue | PEDefExternalID ExternalID deriving (Eq,Show) data ExternalID = SYSTEM SystemLiteral | PUBLIC PubidLiteral SystemLiteral deriving (Eq,Show) newtype NDataDecl = NDATA Name deriving Eq data TextDecl = TextDecl (Maybe VersionInfo) EncodingDecl deriving Eq data ExtParsedEnt i = ExtParsedEnt (Maybe TextDecl) (Content i) deriving Eq data ExtPE = ExtPE (Maybe TextDecl) [ExtSubsetDecl] deriving Eq data NotationDecl = NOTATION Name (Either ExternalID PublicID) deriving Eq newtype PublicID = PUBLICID PubidLiteral deriving Eq newtype EncodingDecl = EncodingDecl String deriving Eq -- | A QName is a (possibly) qualified name, in the sense of XML namespaces. data QName = N Name | QN Namespace Name deriving (Eq,Show) -- | Namespaces are not defined in the XML spec itself, but at -- http://www.w3.org/TR/xml-names data Namespace = Namespace { nsPrefix :: String , nsURI :: String } deriving (Show) instance Eq Namespace where p == q = nsURI p == nsURI q -- this is the W3C spec's definition! instance Ord QName where compare (N n) (N m) = compare n m compare (QN p n) (N m) = LT compare (N n) (QN q m) = GT compare (QN p n) (QN q m) = case compare (nsPrefix p) (nsPrefix q) of EQ -> compare n m r -> r type Name = String -- non-empty string type Names = [Name] -- non-empty list type NmToken = String -- non-empty string type NmTokens = [NmToken] -- non-empty list data AttValue = AttValue [Either String Reference] deriving Eq instance Show AttValue where show (AttValue v) = concatMap decode v where decode (Left w) = w decode (Right (RefEntity ent)) = "&"++ent++";" decode (Right (RefChar cref)) = "&"++show cref++";" data EntityValue = EntityValue [EV] deriving (Eq,Show) data EV = EVString String -- -- | EVPERef PEReference | EVRef Reference deriving (Eq,Show) newtype PubidLiteral = PubidLiteral String deriving (Eq,Show) newtype SystemLiteral = SystemLiteral String deriving (Eq,Show) type CharData = String type CDSect = CharData instance Eq ElemTag where (ElemTag n _) == (ElemTag m _) = n==m HaXml-1.23.3/src/Text/XML/HaXml/Util.hs0000755000062000006210000000267111767644706016541 0ustar 1341796mkpasswd{- | - Only a small module containing some helper functions to extract xml content - I would have added this to Types but I've put it into an additional module - to avoid circular references (Verbatim <-> Types) -} module Text.XML.HaXml.Util ( -- ** utility functions to access XML content docContent , contentElem , attrs , tagTextContent ) where --import Text.XML.HaXml.Posn import Text.XML.HaXml.Types import Text.XML.HaXml.Verbatim -- | Get the main element of the document so that you can apply -- CFilters directly. 'i' is typically (posInNewCxt "filename" Nothing) docContent :: i -> Document i -> Content i docContent i (Document _ _ e _) = CElem e i -- | If you know that your CFilter returns a tag, you can use this -- function to get the tagged Element. contentElem :: Content i -> Element i contentElem (CElem e _) = e contentElem _ = error "content is not a CElem" attrs :: Element i -> [Attribute] attrs ( Elem _ attrs _ ) = attrs tagTextContent :: Content i -> [Char] tagTextContent ((CElem (Elem _ _ cs) _)) = concatMap verbatim cs {- now you can extract an attribute quite easily: let doc = "content" let b = head $ xtract id "a/b" $ docContent (posInNewCxt filename Nothing) $ xmlParse filename doc putStrLn $ "attr a of tag b" ++ (show $ lookup "a" $ attrs $ contentElem b) putStrLn $ "text content of b :" ++ tagTextContent b still (too) much code IMHO -} HaXml-1.23.3/src/Text/XML/HaXml/Validate.hs0000755000062000006210000003154011767644706017352 0ustar 1341796mkpasswd-- | Validate a document against a dtd. module Text.XML.HaXml.Validate ( validate , partialValidate ) where import Prelude hiding (elem,rem,mod,sequence) import qualified Prelude (elem) import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces import Text.XML.HaXml.Combinators (multi,tag,iffind,literal,none,o) import Text.XML.HaXml.XmlContent (attr2str) import Data.Maybe (fromMaybe,isNothing,fromJust) import Data.List (intersperse,nub,(\\)) import Data.Char (isSpace) #if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__) -- emulate older finite map interface using Data.Map, if it is available import qualified Data.Map as Map type FiniteMap a b = Map.Map a b listToFM :: Ord a => [(a,b)] -> FiniteMap a b listToFM = Map.fromList lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b lookupFM = flip Map.lookup #elif __GLASGOW_HASKELL__ >= 504 || __NHC__ > 114 -- real finite map, if it is available import Data.FiniteMap #else -- otherwise, a very simple and inefficient implementation of a finite map type FiniteMap a b = [(a,b)] listToFM :: Eq a => [(a,b)] -> FiniteMap a b listToFM = id lookupFM :: Eq a => FiniteMap a b -> a -> Maybe b lookupFM fm k = lookup k fm #endif -- gather appropriate information out of the DTD data SimpleDTD = SimpleDTD { elements :: FiniteMap QName ContentSpec -- content model of elem , attributes :: FiniteMap (QName,QName) AttType -- type of (elem,attr) , required :: FiniteMap QName [QName] -- required attributes of elem , ids :: [(QName,QName)] -- all (element,attr) with ID type , idrefs :: [(QName,QName)] -- all (element,attr) with IDREF type } simplifyDTD :: DocTypeDecl -> SimpleDTD simplifyDTD (DTD _ _ decls) = SimpleDTD { elements = listToFM [ (name,content) | Element (ElementDecl name content) <- decls ] , attributes = listToFM [ ((elem,attr),typ) | AttList (AttListDecl elem attdefs) <- decls , AttDef attr typ _ <- attdefs ] -- Be sure to look at all attribute declarations for each -- element, since we must merge them. This implements the -- specification in that regard only; the specification's rules -- about how to merge multiple declarations for the same -- attribute are not considered by this implementation. -- See: http://www.w3.org/TR/REC-xml/#NT-AttlistDecl , required = listToFM [ (elem, concat [ [ attr | AttDef attr _ REQUIRED <- attdefs ] | AttList (AttListDecl elem' attdefs) <- decls , elem' == elem ] ) | Element (ElementDecl elem _) <- decls ] , ids = [ (elem,attr) | Element (ElementDecl elem _) <- decls , AttList (AttListDecl name attdefs) <- decls , elem == name , AttDef attr (TokenizedType ID) _ <- attdefs ] , idrefs = [] -- not implemented } -- simple auxiliary to avoid lots of if-then-else with empty else clauses. gives :: Bool -> a -> [a] True `gives` x = [x] False `gives` _ = [] -- | 'validate' takes a DTD and a tagged element, and returns a list of -- errors in the document with respect to its DTD. -- -- If you have several documents to validate against a single DTD, -- then you will gain efficiency by freezing-in the DTD through partial -- application, e.g. @checkMyDTD = validate myDTD@. validate :: DocTypeDecl -> Element i -> [String] validate dtd' elem = root dtd' elem ++ partialValidate dtd' elem where root (DTD name _ _) (Elem name' _ _) = (name/=name') `gives` ("Document type should be <"++qname name ++"> but appears to be <"++qname name'++">.") -- | 'partialValidate' is like validate, except that it does not check that -- the element type matches that of the DTD's root element. partialValidate :: DocTypeDecl -> Element i -> [String] partialValidate dtd' elem = valid elem ++ checkIDs elem where dtd = simplifyDTD dtd' valid (Elem name attrs contents) = -- is the element defined in the DTD? let spec = lookupFM (elements dtd) name in (isNothing spec) `gives` ("Element <"++qname name++"> not known.") -- is each attribute mentioned only once? ++ (let dups = duplicates (map (qname . fst) attrs) in not (null dups) `gives` ("Element <"++qname name++"> has duplicate attributes: " ++concat (intersperse "," dups)++".")) -- does each attribute belong to this element? value is in range? ++ concatMap (checkAttr name) attrs -- are all required attributes present? ++ concatMap (checkRequired name attrs) (fromMaybe [] (lookupFM (required dtd) name)) -- are its children in a permissible sequence? ++ checkContentSpec name (fromMaybe ANY spec) contents -- now recursively check the element children ++ concatMap valid [ elm | CElem elm _ <- contents ] checkAttr elm (attr, val) = let typ = lookupFM (attributes dtd) (elm,attr) attval = attr2str val in if isNothing typ then ["Attribute \""++qname attr ++"\" not known for element <"++qname elm++">."] else case fromJust typ of EnumeratedType e -> case e of Enumeration es -> (not (attval `Prelude.elem` es)) `gives` ("Value \""++attval++"\" of attribute \"" ++qname attr++"\" in element <"++qname elm ++"> is not in the required enumeration range: " ++unwords es) _ -> [] _ -> [] checkRequired elm attrs req = (not (req `Prelude.elem` map fst attrs)) `gives` ("Element <"++qname elm++"> requires the attribute \""++qname req ++"\" but it is missing.") checkContentSpec _elm ANY _ = [] checkContentSpec _elm EMPTY [] = [] checkContentSpec elm EMPTY (_:_) = ["Element <"++qname elm++"> is not empty but should be."] checkContentSpec elm (Mixed PCDATA) cs = concatMap (checkMixed elm []) cs checkContentSpec elm (Mixed (PCDATAplus names)) cs = concatMap (checkMixed elm names) cs checkContentSpec elm (ContentSpec cp) cs = excludeText elm cs ++ (let (errs,rest) = checkCP elm cp (flatten cs) in case rest of [] -> errs _ -> errs++["Element <"++qname elm++"> contains extra " ++"elements beyond its content spec."]) checkMixed elm permitted (CElem (Elem name _ _) _) | not (name `Prelude.elem` permitted) = ["Element <"++qname elm++"> contains an element <"++qname name ++"> but should not."] checkMixed _elm _permitted _ = [] flatten (CElem (Elem name _ _) _: cs) = name: flatten cs flatten (_: cs) = flatten cs flatten [] = [] excludeText elm (CElem _ _: cs) = excludeText elm cs excludeText elm (CMisc _ _: cs) = excludeText elm cs excludeText elm (CString _ s _: cs) | all isSpace s = excludeText elm cs excludeText elm (_:_) = ["Element <"++qname elm++"> contains text/references but should not."] excludeText _elm [] = [] -- This is a little parser really. Returns any errors, plus the remainder -- of the input string. checkCP :: QName -> CP -> [QName] -> ([String],[QName]) checkCP elm cp@(TagName _ None) [] = (cpError elm cp, []) checkCP elm cp@(TagName n None) (n':ns) | n==n' = ([], ns) | otherwise = (cpError elm cp, n':ns) checkCP _ (TagName _ Query) [] = ([],[]) checkCP _ (TagName n Query) (n':ns) | n==n' = ([], ns) | otherwise = ([], n':ns) checkCP _ (TagName _ Star) [] = ([],[]) checkCP elm (TagName n Star) (n':ns) | n==n' = checkCP elm (TagName n Star) ns | otherwise = ([], n':ns) checkCP elm cp@(TagName _ Plus) [] = (cpError elm cp, []) checkCP elm cp@(TagName n Plus) (n':ns) | n==n' = checkCP elm (TagName n Star) ns | otherwise = (cpError elm cp, n':ns) -- omit this clause, to permit (a?|b?) as a valid but empty choice -- checkCP elem cp@(Choice cps None) [] = (cpError elem cp, []) checkCP elm cp@(Choice cps None) ns = let next = choice elm ns cps in if null next then (cpError elm cp, ns) else ([], head next) -- choose the first alternative with no errors checkCP _ (Choice _ Query) [] = ([],[]) checkCP elm (Choice cps Query) ns = let next = choice elm ns cps in if null next then ([],ns) else ([], head next) checkCP _ (Choice _ Star) [] = ([],[]) checkCP elm (Choice cps Star) ns = let next = choice elm ns cps in if null next then ([],ns) else checkCP elm (Choice cps Star) (head next) checkCP elm cp@(Choice _ Plus) [] = (cpError elm cp, []) checkCP elm cp@(Choice cps Plus) ns = let next = choice elm ns cps in if null next then (cpError elm cp, ns) else checkCP elm (Choice cps Star) (head next) -- omit this clause, to permit (a?,b?) as a valid but empty sequence -- checkCP elem cp@(Seq cps None) [] = (cpError elem cp, []) checkCP elm cp@(Seq cps None) ns = let (errs,next) = sequence elm ns cps in if null errs then ([],next) else (cpError elm cp++errs, ns) checkCP _ (Seq _ Query) [] = ([],[]) checkCP elm (Seq cps Query) ns = let (errs,next) = sequence elm ns cps in if null errs then ([],next) else ([], ns) checkCP _ (Seq _ Star) [] = ([],[]) checkCP elm (Seq cps Star) ns = let (errs,next) = sequence elm ns cps in if null errs then checkCP elm (Seq cps Star) next else ([], ns) checkCP elm cp@(Seq _ Plus) [] = (cpError elm cp, []) checkCP elm cp@(Seq cps Plus) ns = let (errs,next) = sequence elm ns cps in if null errs then checkCP elm (Seq cps Star) next else (cpError elm cp++errs, ns) choice elm ns cps = -- return only those parses that don't give any errors [ rem | ([],rem) <- map (\cp-> checkCP elm (definite cp) ns) cps ] ++ [ ns | all possEmpty cps ] where definite (TagName n Query) = TagName n None definite (Choice cps Query) = Choice cps None definite (Seq cps Query) = Seq cps None definite (TagName n Star) = TagName n Plus definite (Choice cps Star) = Choice cps Plus definite (Seq cps Star) = Seq cps Plus definite x = x possEmpty (TagName _ mod) = mod `Prelude.elem` [Query,Star] possEmpty (Choice cps None) = all possEmpty cps possEmpty (Choice _ mod) = mod `Prelude.elem` [Query,Star] possEmpty (Seq cps None) = all possEmpty cps possEmpty (Seq _ mod) = mod `Prelude.elem` [Query,Star] sequence elm ns cps = -- accumulate errors down the sequence foldl (\(es,ns) cp-> let (es',ns') = checkCP elm cp ns in (es++es', ns')) ([],ns) cps checkIDs elm = let celem = CElem elm undefined showAttr a = iffind (printableName a) literal none idElems = concatMap (\(name, at)-> multi (showAttr at `o` tag (printableName name)) celem) (ids dtd) badIds = duplicates (map (\(CString _ s _)->s) idElems) in not (null badIds) `gives` ("These attribute values of type ID are not unique: " ++concat (intersperse "," badIds)++".") cpError :: QName -> CP -> [String] cpError elm cp = ["Element <"++qname elm++"> should contain "++display cp++" but does not."] display :: CP -> String display (TagName name mod) = qname name ++ modifier mod display (Choice cps mod) = "(" ++ concat (intersperse "|" (map display cps)) ++ ")" ++ modifier mod display (Seq cps mod) = "(" ++ concat (intersperse "," (map display cps)) ++ ")" ++ modifier mod modifier :: Modifier -> String modifier None = "" modifier Query = "?" modifier Star = "*" modifier Plus = "+" duplicates :: Eq a => [a] -> [a] duplicates xs = xs \\ (nub xs) qname :: QName -> String qname n = printableName n HaXml-1.23.3/src/Text/XML/HaXml/Verbatim.hs0000755000062000006210000000754711767644706017404 0ustar 1341796mkpasswd{- | Maintainer : simons@cryp.to Stability : experimental Portability : portable The preferred method for rendering a 'Document' or single 'Content' is by using the pretty printing facility defined in "Pretty". Pretty-printing does not work well for cases, however, where the formatting in the XML document is significant. Examples of this case are XHTML's @\@ tag, Docbook's @\@ tag, and many more. Theoretically, the document author could avoid this problem by wrapping the contents of these tags in a \ section, but often this is not practical, for instance when the literal-layout section contains other elements. Finally, program writers could manually format these elements by transforming them into a 'literal' string in their 'CFliter', etc., but this is annoying to do and prone to omissions and formatting errors. As an alternative, this module provides the function 'verbatim', which will format XML 'Content' as a 'String' while retaining the formatting of the input document unchanged. /Known problems/: * HaXml's parser eats line feeds between two tags. * 'Attribute's should be formatted by making them an instance of 'Verbatim' as well, but since an 'Attribute' is just a tuple, not a full data type, the helper function 'verbAttr' must be used instead. * 'CMisc' is not yet supported. * 'Element's, which contain no content, are formatted as @\@, even if they were not defined as being of type @EMPTY@. In XML this perfectly alright, but in SGML it is not. Those, who wish to use 'verbatim' to format parts of say an HTML page will have to (a) replace problematic elements by 'literal's /before/ running 'verbatim' or (b) use a second search-and-replace stage to fix this. -} module Text.XML.HaXml.Verbatim where import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces qname :: QName -> String qname n = printableName n -- |This class promises that the function 'verbatim' knows how to -- format this data type into a string without changing the -- formatting. class Verbatim a where verbatim :: a -> String instance (Verbatim a) => Verbatim [a] where verbatim = concat . (map verbatim) instance Verbatim Char where verbatim c = [c] instance (Verbatim a, Verbatim b) => Verbatim (Either a b) where verbatim (Left v) = verbatim v verbatim (Right v) = verbatim v instance Verbatim (Content i) where verbatim (CElem c _) = verbatim c verbatim (CString _ c _) = c verbatim (CRef c _) = verbatim c verbatim (CMisc (Comment c) _) = "" verbatim (CMisc _ _) = "" -- verbatim (CMisc _ _) = error "NYI: verbatim not defined for CMisc" instance Verbatim (Element i) where verbatim (Elem nam att []) = "<" ++ qname nam ++ (concat . (map verbAttr)) att ++ "/>" verbatim (Elem nam att cont) = "<" ++ qname nam ++ (concat . (map verbAttr)) att ++ ">" ++ verbatim cont ++ "" instance Verbatim Reference where verbatim (RefEntity r) = "&" ++ verbatim r ++ ";" verbatim (RefChar c) = "&#" ++ show c ++ ";" instance Verbatim AttValue where verbatim (AttValue v) = verbatim v -- |This is a helper function is required because Haskell does not -- allow to make an ordinary tuple (like 'Attribute') an instance of a -- class. The resulting output will preface the actual attribute with -- a single blank so that lists of 'Attribute's can be handled -- implicitly by the definition for lists of 'Verbatim' data types. verbAttr :: Attribute -> String verbAttr (n, AttValue v) = " " ++ qname n ++ "=\"" ++ verbatim v ++ "\"" HaXml-1.23.3/src/Text/XML/HaXml/Wrappers.hs0000755000062000006210000000636211767644706017430 0ustar 1341796mkpasswd{-# LANGUAGE CPP #-} #define dummy -- just to ensure that cpp gets called on this file module Text.XML.HaXml.Wrappers ( fix2Args , processXmlWith , onContent ) where -- imports required for processXmlWith and fix2Args import Prelude hiding (filter) import System.Exit import System.Environment import System.IO import Data.List (isSuffixOf) import Control.Monad (when) import Text.XML.HaXml.Types (Document(..),Content(..)) import Text.XML.HaXml.Combinators (CFilter) import Text.XML.HaXml.Posn (Posn,posInNewCxt) import Text.XML.HaXml.Parse (xmlParse) import Text.XML.HaXml.Html.Parse (htmlParse) import Text.XML.HaXml.Pretty as PP(document) import Text.PrettyPrint.HughesPJ (render) -- | This useful auxiliary checks the commandline arguments for two -- filenames, the input and output file respectively. If either -- is missing, it is replaced by '-', which can be interpreted by the -- caller as stdin and\/or stdout. fix2Args :: IO (String,String) fix2Args = do args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++show MAJOR.MINOR exitWith ExitSuccess when ("--help" `elem` args) $ do putStrLn $ "See http://haskell.org/HaXml" exitWith ExitSuccess case length args of 0 -> return ("-", "-") 1 -> return (args!!0, "-") 2 -> return (args!!0, args!!1) _ -> do prog <- getProgName putStrLn ("Usage: "++prog++" [infile] [outfile]") exitFailure -- | The wrapper @processXmlWith@ returns an IO () computation -- that collects the filenames (or stdin\/stdout) to use when -- reading\/writing XML documents. Its CFilter argument -- is applied to transform the XML document from the input and -- write it to the output. No DTD is attached to the output. -- -- If the input filename ends with .html or .htm, it is parsed using -- the error-correcting HTML parser rather than the strict XML parser. processXmlWith :: CFilter Posn -> IO () processXmlWith f = do (inf,outf) <- fix2Args input <- if inf=="-" then getContents else readFile inf o <- if outf=="-" then return stdout else openFile outf WriteMode parse <- if ".html" `isSuffixOf` inf || ".htm" `isSuffixOf` inf then return (htmlParse inf) else return (xmlParse inf) ( hPutStrLn o . render . PP.document . onContent inf f . parse ) input hFlush o where onContent :: FilePath -> (CFilter Posn) -> Document Posn -> Document Posn onContent file filter (Document p s e m) = case filter (CElem e (posInNewCxt file Nothing)) of [CElem e' _] -> Document p s e' m [] -> error $ "filtering"++file++"produced no output" _ -> error $ "filtering"++file++ "produced more than one output document" -- | The wrapper @onContent@ simply applies a given content filter to a -- document. Ambiguous or empty results raise an error exception. onContent :: CFilter i -> Document i -> Document i onContent filter (Document p s e m) = case filter (CElem e undefined) of [CElem e' _] -> Document p s e' m [] -> error "onContent: produced no output" _ -> error "onContent: produced more than one output" HaXml-1.23.3/src/Text/XML/HaXml/XmlContent/0000755000062000006210000000000011767644706017352 5ustar 1341796mkpasswdHaXml-1.23.3/src/Text/XML/HaXml/XmlContent/Haskell.hs0000755000062000006210000002417711767644706021307 0ustar 1341796mkpasswd-- | The class 'XmlContent' is a kind of replacement for Read and Show: -- it provides conversions between a generic XML tree representation -- and your own more specialised typeful Haskell data trees. -- -- If you are starting with a set of Haskell datatypes, use DrIFT to -- derive instances of this class for you: -- http:\/\/repetae.net\/john\/computer\/haskell\/DrIFT -- and use the current module for instances of the standard Haskell -- datatypes list, Maybe, and so on. -- -- If you are starting with an XML DTD, use HaXml's tool DtdToHaskell -- to generate both the Haskell types and the corresponding instances, -- but _do_not_ use the current module for instances: use -- Text.XML.HaXml.XmlContent instead. module Text.XML.HaXml.XmlContent.Haskell ( -- * Re-export everything from Text.XML.HaXml.XmlContent.Parser. module Text.XML.HaXml.XmlContent.Parser -- * Instances (only) for the XmlContent class, for datatypes that -- originated in Haskell, rather than from a DTD definition. -- , module Text.XML.HaXml.XmlContent.Haskell -- * Whole-document conversion functions , toXml, fromXml , readXml, showXml, fpsShowXml , fReadXml, fWriteXml, fpsWriteXml , hGetXml, hPutXml, fpsHPutXml ) where import System.IO import Data.List (isPrefixOf, isSuffixOf) import qualified Text.XML.HaXml.ByteStringPP as FPS (document) import qualified Data.ByteString.Lazy.Char8 as FPS import Text.PrettyPrint.HughesPJ (render) import Text.ParserCombinators.Poly import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces import Text.XML.HaXml.TypeMapping import Text.XML.HaXml.Posn (Posn, posInNewCxt) import Text.XML.HaXml.Pretty (document) import Text.XML.HaXml.Parse (xmlParse) import Text.XML.HaXml.Verbatim (Verbatim(verbatim)) import Text.XML.HaXml.XmlContent.Parser -- probably want to write DTD separately from value, and have -- easy ways to combine DTD + value into a document, or write -- them to separate files. -- | Read an XML document from a file and convert it to a fully-typed -- Haskell value. fReadXml :: XmlContent a => FilePath -> IO a fReadXml fp = do f <- ( if fp=="-" then return stdin else openFile fp ReadMode ) x <- hGetContents f let (Document _ _ y _) = xmlParse fp x y' = CElem y (posInNewCxt fp Nothing) either fail return (fst (runParser parseContents [y'])) -- | Write a fully-typed Haskell value to the given file as an XML -- document. fWriteXml :: XmlContent a => FilePath -> a -> IO () fWriteXml fp x = do f <- ( if fp=="-" then return stdout else openFile fp WriteMode ) hPutXml f False x hClose f -- | Write any Haskell value to the given file as an XML document, -- using the FastPackedString interface (output will not be prettified). fpsWriteXml :: XmlContent a => FilePath -> a -> IO () fpsWriteXml fp x = do f <- ( if fp=="-" then return stdout else openFile fp WriteMode ) fpsHPutXml f False x hClose f -- | Read a fully-typed XML document from a string. readXml :: XmlContent a => String -> Either String a readXml s = let (Document _ _ y _) = xmlParse "string input" s in fst (runParser parseContents [CElem y (posInNewCxt "string input" Nothing)]) -- | Convert a fully-typed XML document to a string (without DTD). showXml :: XmlContent a => Bool -> a -> String showXml dtd x = case toContents x of [CElem _ _] -> (render . document . toXml dtd) x _ -> "" -- | Convert a fully-typed XML document to a ByteString (without DTD). fpsShowXml :: XmlContent a => Bool -> a -> FPS.ByteString fpsShowXml dtd x = case toContents x of [CElem _ _] -> (FPS.document . toXml dtd) x _ -> FPS.empty -- | Convert a fully-typed XML document to a string (with or without DTD). toXml :: XmlContent a => Bool -> a -> Document () toXml dtd value = let ht = toHType value in Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing)) [] (if dtd then Just (toDTD ht) else Nothing) []) emptyST ( case (ht, toContents value) of (Tuple _, cs) -> Elem (N $ showHType ht "") [] cs (Defined _ _ _, cs) -> Elem (N $ showHType ht "-XML") [] cs (_, [CElem e ()]) -> e ) [] -- | Read a Haskell value from an XML document, ignoring the DTD and -- using the Haskell result type to determine how to parse it. fromXml :: XmlContent a => Document Posn -> Either String a fromXml (Document _ _ e@(Elem n _ cs) _) | "tuple" `isPrefixOf` localName n = fst (runParser parseContents cs) | "-XML" `isSuffixOf` localName n = fst (runParser parseContents cs) | otherwise = fst (runParser parseContents [CElem e (posInNewCxt "document" Nothing)]) -- | Read a fully-typed XML document from a file handle. hGetXml :: XmlContent a => Handle -> IO a hGetXml h = do x <- hGetContents h let (Document _ _ y _) = xmlParse "file handle" x either fail return (fst (runParser parseContents [CElem y (posInNewCxt "file handle" Nothing)])) -- | Write a fully-typed XML document to a file handle. hPutXml :: XmlContent a => Handle -> Bool -> a -> IO () hPutXml h dtd x = do (hPutStrLn h . render . document . toXml dtd) x -- | Write a fully-typed XML document to a file handle, using the -- FastPackedString interface (output will not be prettified). fpsHPutXml :: XmlContent a => Handle -> Bool -> a -> IO () fpsHPutXml h dtd x = do (FPS.hPut h . FPS.document . toXml dtd) x ------------------------------------------------------------------------ -- Instances for all the standard basic datatypes. -- These are for Haskell datatypes being derived to go to XML. -- DtdToHaskell does not use these instances. ------------------------------------------------------------------------ instance XmlContent Bool where toContents b = [CElem (Elem (N "bool") [mkAttr "value" (show b)] []) ()] parseContents = do { e <- element ["bool"] ; return (attval e) } instance XmlContent Int where toContents i = [CElem (Elem (N "int") [mkAttr "value" (show i)] []) ()] parseContents = do { e <- element ["int"] ; return (attval e) } instance XmlContent Integer where toContents i = [CElem (Elem (N "integer") [mkAttr "value" (show i)] []) ()] parseContents = do { e <- element ["integer"] ; return (attval e) } instance XmlContent Float where toContents i = [CElem (Elem (N "float") [mkAttr "value" (show i)] []) ()] parseContents = do { e <- element ["float"] ; return (attval e) } instance XmlContent Double where toContents i = [CElem (Elem (N "double") [mkAttr "value" (show i)] []) ()] parseContents = do { e <- element ["double"] ; return (attval e) } instance XmlContent Char where -- NOT in a string toContents c = [CElem (Elem (N "char") [mkAttr "value" [c]] []) ()] parseContents = do { (Elem _ [(N "value",(AttValue [Left [c]]))] []) <- element ["char"] ; return c } -- Only defined for Char and no other types: xToChar = id xFromChar = id instance XmlContent a => XmlContent [a] where toContents xs = case toHType x of (Prim "Char" _) -> [mkElem "string" [CString True (map xToChar xs) ()]] _ -> [mkElem xs (concatMap toContents xs)] where (x:_) = xs parseContents = P (\x -> case x of (CString _ s _:cs) -> Success cs (map xFromChar s) (CElem (Elem (N "string") [] [CString _ s _]) _:cs) -> Success cs (map xFromChar s) (CElem (Elem (N "string") [] []) _:cs) -> Success cs [] (CElem (Elem (N e) [] xs) _:cs) | "list" `isPrefixOf` e -> scanElements xs where -- scanElements :: [Content] -> (Either String [a],[Content]) scanElements [] = Success cs [] scanElements es = case runParser parseContents es of (Left msg, es') -> Failure es' msg (Right y, es') -> case scanElements es' of Failure ds msg -> Failure ds msg Success ds ys -> Success ds (y:ys) (CElem (Elem e _ _) pos: cs) -> Failure cs ("Expected a , but found a <" ++printableName e ++"> at\n"++show pos) (CRef r pos: cs) -> Failure cs ("Expected a , but found a ref " ++verbatim r++" at\n"++ show pos) (_:cs) -> ((\ (P p)-> p) parseContents) cs -- skip comments etc. [] -> Failure [] "Ran out of input XML whilst secondary parsing" ) instance XmlContent () where toContents () = [CElem (Elem (N "unit") [] []) ()] parseContents = do { element ["unit"]; return () } instance (XmlContent a) => XmlContent (Maybe a) where toContents m = [mkElem m (maybe [] toContents m)] parseContents = do { e <- elementWith (flip isPrefixOf) ["maybe"] ; case e of (Elem _ [] []) -> return Nothing (Elem _ [] _) -> fmap Just (interior e parseContents) } instance (XmlContent a, XmlContent b) => XmlContent (Either a b) where toContents v@(Left aa) = [mkElemC (showConstr 0 (toHType v)) (toContents aa)] toContents v@(Right ab) = [mkElemC (showConstr 1 (toHType v)) (toContents ab)] parseContents = (inElementWith (flip isPrefixOf) "Left" $ fmap Left parseContents) `onFail` (inElementWith (flip isPrefixOf) "Right" $ fmap Right parseContents) -- do{ e@(Elem t [] _) <- element ["Left","Right"] -- ; case t of -- _ | "Left" `isPrefixOf` t -> fmap Left (interior e parseContents) -- | "Right" `isPrefixOf` t -> fmap Right (interior e parseContents) -- } ------------------------------------------------------------------------ HaXml-1.23.3/src/Text/XML/HaXml/XmlContent/Parser.hs0000755000062000006210000006430211767644706021152 0ustar 1341796mkpasswd{-# LANGUAGE ExistentialQuantification #-} -- | The class 'XmlContent' is a kind of replacement for Read and Show: -- it provides conversions between a generic XML tree representation -- and your own more specialised typeful Haskell data trees. -- -- If you are starting with a set of Haskell datatypes, use DrIFT to -- derive instances of this class for you: -- http:\/\/repetae.net\/john\/computer\/haskell\/DrIFT -- If you are starting with an XML DTD, use HaXml's tool DtdToHaskell -- to generate both the Haskell types and the corresponding instances. -- -- This unified class interface replaces two previous (somewhat similar) -- classes: Haskell2Xml and Xml2Haskell. There was no real reason to have -- separate classes depending on how you originally defined your datatypes. -- However, some instances for basic types like lists will depend on which -- direction you are using. See Text.XML.HaXml.XmlContent and -- Text.XML.HaXml.XmlContent.Haskell. -- The methods 'toContents' and 'parseContents' convert a value to and from -- a generic internal representation of an XML document /without/ a DTD. -- The functions 'toXml' and 'fromXml' convert a value to and from a generic -- internal representation of an XML document /including/ a DTD. -- The functions 'readXml' and 'showXml' convert to and from Strings. -- The functions 'fReadXml' and 'fWriteXml' do the conversion to and from -- the given filenames. -- The functions 'hGetXml' and 'hPutXml' do the conversion to and from -- the given file handles. -- (See the type signatures.) -- module Text.XML.HaXml.XmlContent.Parser ( -- * Re-export the relevant set of generic XML document type definitions Document(..) , Element(..) , ElemTag(..) , Content(..) , Attribute() , AttValue(..) , Prolog(..) , Reference(..) -- * The enabling classes, that define parsing\/unparsing between Haskell -- datatypes and a generic XML representation. , XmlContent(..) , XmlAttributes(..) , XmlAttrType(..) -- ** Auxiliaries for writing parsers in the XmlContent class , module Text.ParserCombinators.Poly , XMLParser , content, posnElement, element, interior, inElement, text, attributes , posnElementWith, elementWith, inElementWith , choice, definite -- ??? -- ** Auxiliaries for generating in the XmlContent class , mkElem, mkElemC, mkAttr , toText, toCData -- ** Auxiliaries for the attribute-related classes , maybeToAttr, defaultToAttr , definiteA, defaultA, possibleA, fromAttrToStr, toAttrFrStr , Defaultable(..) , str2attr, attr2str, attval , catMaybes -- re-exported from Maybe -- * Explicit representation of Haskell datatype information -- (for conversion to a DTD) , module Text.XML.HaXml.TypeMapping -- * Types useful for some content models , List1(..) , ANYContent(..) ) where --import System.IO import Data.Maybe (catMaybes) import Data.Char (chr, isSpace) import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces import Text.XML.HaXml.TypeMapping import Text.XML.HaXml.Posn (Posn) import Text.XML.HaXml.Verbatim (Verbatim(verbatim)) import Text.ParserCombinators.Poly -- #define DEBUG #if defined(DEBUG) import Debug.Trace(trace) debug :: a -> String -> a v `debug` s = trace s v #else debug :: t -> t1 -> t v `debug` _ = v #endif ------------------------------------------------------------------------ -- | Read a single attribute called "value". attval :: (Read a) => Element i -> a attval (Elem _ [(_{-N "value"-},v@(AttValue _))] []) = read (show v) -- | Generate a single attribute. mkAttr :: String -> String -> Attribute mkAttr n v = (N n, AttValue [Left v]) -- | Generate an element with no attributes, named for its HType. mkElem :: XmlContent a => a -> [Content ()] -> Content () mkElem x cs = CElem (Elem (N (showHType (toHType x) "")) [] cs) () -- | Generate an element with no attributes, named directly. mkElemC :: String -> [Content ()] -> Content () mkElemC x cs = CElem (Elem (N x) [] cs) () -- | Turn a simple string into XML text. toText :: String -> [Content ()] toText s = [CString False s ()] -- | Turn a string into an XML CDATA section. -- (i.e. special characters like '&' are preserved without interpretation.) toCData :: String -> [Content ()] toCData s = [CString True s ()] ------------------------------------------------------------------------ -- | We need a parsing monad for reading generic XML Content into specific -- datatypes. This is a specialisation of the Text.ParserCombinators.Poly -- ones, where the input token type is fixed as XML Content. type XMLParser a = Parser (Content Posn) a ------------------------------------------------------------------------ -- Some useful parsing combinators ------------------------------------------------------------------------ -- | The most primitive combinator for XMLParser - get one content item. content :: String -> XMLParser (Content Posn) content word = next `adjustErr` (++" when expecting "++word) -- | Get the next content element, checking that it has one of the required -- tags, using the given matching function. -- (Skips over comments and whitespace, rejects text and refs. -- Also returns position of element.) posnElementWith :: (String->String->Bool) -> [String] -> XMLParser (Posn, Element Posn) posnElementWith match tags = do { c <- content (formatted tags) ; case c of CElem e@(Elem t _ _) pos | any (match (localName t)) tags -> return (pos, e) | otherwise -> fail ("Found a <"++printableName t ++">, but expected " ++formatted tags++"\nat "++show pos) CString b s pos | not b && all isSpace s -> posnElementWith match tags -- ignore blank space | otherwise -> fail ("Found text content, but expected " ++formatted tags++"\ntext is: "++s ++"\nat "++show pos) CRef r pos -> fail ("Found reference, but expected " ++formatted tags++"\nreference is: "++verbatim r ++"\nat "++show pos) CMisc _ _ -> posnElementWith match tags -- skip comments, PIs, etc. } where formatted [t] = "a <"++t++">" formatted tgs = "one of"++ concatMap (\t->" <"++t++">") tgs -- | A specialisation of @posnElementWith (==)@. posnElement :: [String] -> XMLParser (Posn, Element Posn) posnElement = posnElementWith (==) -- | Get the next content element, checking that it has one of the required -- tags. (Skips over comments and whitespace, rejects text and refs.) element :: [String] -> XMLParser (Element Posn) element tags = fmap snd (posnElement tags) `debug` ("Element: "++unwords tags++"\n") -- | Like element, only permits a more flexible match against the tagname. elementWith :: (String->String->Bool) -> [String] -> XMLParser (Element Posn) elementWith match tags = fmap snd (posnElementWith match tags) `debug` ("Element: "++unwords tags++"\n") -- | Run an XMLParser on the contents of the given element (i.e. not on the -- current monadic content sequence), checking that the contents are -- exhausted, before returning the calculated value within the current -- parser context. interior :: Element Posn -> XMLParser a -> XMLParser a interior (Elem e _ cs) p = case runParser p cs of (Left msg, _) -> fail msg (Right x, []) -> return x (Right x, ds@(d:_)) | all onlyMisc ds -> return x | otherwise -> fail ("Too many elements inside <" ++printableName e++"> at\n" ++show (info d)++"\n" ++"Found excess: " ++verbatim (take 7 ds) ++"\n[...]") where onlyMisc (CMisc _ _) = True onlyMisc (CString False s _) | all isSpace s = True onlyMisc _ = False -- | A combination of element + interior. inElement :: String -> XMLParser a -> XMLParser a inElement tag p = do { e <- element [tag]; commit (interior e p) } -- | A combination of elementWith + interior. inElementWith :: (String->String->Bool) -> String -> XMLParser a -> XMLParser a inElementWith match tag p = do { e <- elementWith match [tag] ; commit (interior e p) } -- | Do some parsing of the attributes of the given element attributes :: XmlAttributes a => Element Posn -> XMLParser a attributes (Elem _ as _) = return (fromAttrs as) -- | 'text' is a counterpart to 'element', parsing text content if it -- exists. Adjacent text and references are coalesced. text :: XMLParser String text = text' [] where text' acc = do { c <- content "plain text" ; case c of CString _ s _ -> text' (s:acc) CRef (RefChar s) _ -> text' (("&#"++show s++";") :acc) CRef (RefEntity s) _ -> text' (('&':s++";"):acc) CMisc _ _ -> text' acc CElem _ _ -> do { reparse [c] -- put it back! ; if null acc then fail "empty string" else return (concat (reverse acc)) } } `onFail` ( if null acc then fail "empty string" else return (concat (reverse acc)) ) -- | 'choice f p' means if parseContents succeeds, apply f to the result, -- otherwise use the continuation parser. choice :: XmlContent a => (a -> b) -> XMLParser b -> XMLParser b choice cons (P other) = P (\cs-> case runParser parseContents cs of (Left _, _) -> other cs (Right x, cs') -> Success cs' (cons x) ) --choice cons other = fmap cons parseContents `onFail` other -- | not sure this is needed now. 'definite p' previously ensured that -- an element was definitely present. Now I think the monad might take -- care of that for us. definite :: XmlContent a => XMLParser a -> String -> String -> XMLParser a definite p inner tag = P (\cs-> case runParser p cs of (Left _, cs') -> Failure cs' msg' (Right x, cs') -> Success cs' x ) where msg' = "content error: expected "++inner++" inside <"++tag ++"> element\n" ------------------------------------------------------------------------ -- | The @XmlContent@ class promises that an XML Content element can be -- converted to and from a Haskell value. class HTypeable a => XmlContent a where -- | Convert from XML to Haskell parseContents :: XMLParser a -- | Convert from Haskell to XML toContents :: a -> [Content ()] -- | Dummy functions (for most types): used /only/ in the Char instance -- for coercing lists of Char into String. xToChar :: a -> Char xFromChar :: Char -> a xToChar = error "HaXml.XmlContent.xToChar used in error" xFromChar = error "HaXml.XmlContent.xFromChar used in error" -- | The @XmlAttributes@ class promises that a list of XML tag attributes -- can be converted to and from a Haskell value. class XmlAttributes a where fromAttrs :: [Attribute] -> a toAttrs :: a -> [Attribute] -- | The @XmlAttrType@ class promises that an attribute taking an XML -- enumerated type can be converted to and from a Haskell value. class XmlAttrType a where fromAttrToTyp :: String -> Attribute -> Maybe a toAttrFrTyp :: String -> a -> Maybe Attribute ------------------------------------------------------------------------ -- Instances for some of the standard basic datatypes. -- Both DtdToHaskell and Haskell2Xml share these instances. ------------------------------------------------------------------------ instance (XmlContent a, XmlContent b) => XmlContent (a,b) where toContents (a,b) = toContents a ++ toContents b parseContents = do { a <- parseContents ; b <- parseContents ; return (a,b) } instance (XmlContent a, XmlContent b, XmlContent c) => XmlContent (a,b,c) where toContents (a,b,c) = toContents a ++ toContents b ++ toContents c parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; return (a,b,c) } instance (XmlContent a, XmlContent b, XmlContent c, XmlContent d) => XmlContent (a,b,c,d) where toContents (a,b,c,d) = toContents a ++ toContents b ++ toContents c ++ toContents d parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; return (a,b,c,d) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e ) => XmlContent (a,b,c,d,e) where toContents (a,b,c,d,e) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; return (a,b,c,d,e) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e, XmlContent f ) => XmlContent (a,b,c,d,e,f) where toContents (a,b,c,d,e,f) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e ++ toContents f parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; f <- parseContents ; return (a,b,c,d,e,f) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e, XmlContent f, XmlContent g ) => XmlContent (a,b,c,d,e,f,g) where toContents (a,b,c,d,e,f,g) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e ++ toContents f ++ toContents g parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; f <- parseContents ; g <- parseContents ; return (a,b,c,d,e,f,g) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e, XmlContent f, XmlContent g, XmlContent h ) => XmlContent (a,b,c,d,e,f,g,h) where toContents (a,b,c,d,e,f,g,h) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e ++ toContents f ++ toContents g ++ toContents h parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; f <- parseContents ; g <- parseContents ; h <- parseContents ; return (a,b,c,d,e,f,g,h) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e, XmlContent f, XmlContent g, XmlContent h , XmlContent i ) => XmlContent (a,b,c,d,e,f,g,h,i) where toContents (a,b,c,d,e,f,g,h,i) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e ++ toContents f ++ toContents g ++ toContents h ++ toContents i parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; f <- parseContents ; g <- parseContents ; h <- parseContents ; i <- parseContents ; return (a,b,c,d,e,f,g,h,i) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e, XmlContent f, XmlContent g, XmlContent h , XmlContent i, XmlContent j ) => XmlContent (a,b,c,d,e,f,g,h,i,j) where toContents (a,b,c,d,e,f,g,h,i,j) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e ++ toContents f ++ toContents g ++ toContents h ++ toContents i ++ toContents j parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; f <- parseContents ; g <- parseContents ; h <- parseContents ; i <- parseContents ; j <- parseContents ; return (a,b,c,d,e,f,g,h,i,j) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e, XmlContent f, XmlContent g, XmlContent h , XmlContent i, XmlContent j, XmlContent k ) => XmlContent (a,b,c,d,e,f,g,h,i,j,k) where toContents (a,b,c,d,e,f,g,h,i,j,k) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e ++ toContents f ++ toContents g ++ toContents h ++ toContents i ++ toContents j ++ toContents k parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; f <- parseContents ; g <- parseContents ; h <- parseContents ; i <- parseContents ; j <- parseContents ; k <- parseContents ; return (a,b,c,d,e,f,g,h,i,j,k) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e, XmlContent f, XmlContent g, XmlContent h , XmlContent i, XmlContent j, XmlContent k, XmlContent l ) => XmlContent (a,b,c,d,e,f,g,h,i,j,k,l) where toContents (a,b,c,d,e,f,g,h,i,j,k,l) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e ++ toContents f ++ toContents g ++ toContents h ++ toContents i ++ toContents j ++ toContents k ++ toContents l parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; f <- parseContents ; g <- parseContents ; h <- parseContents ; i <- parseContents ; j <- parseContents ; k <- parseContents ; l <- parseContents ; return (a,b,c,d,e,f,g,h,i,j,k,l) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e, XmlContent f, XmlContent g, XmlContent h , XmlContent i, XmlContent j, XmlContent k, XmlContent l , XmlContent m ) => XmlContent (a,b,c,d,e,f,g,h,i,j,k,l,m) where toContents (a,b,c,d,e,f,g,h,i,j,k,l,m) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e ++ toContents f ++ toContents g ++ toContents h ++ toContents i ++ toContents j ++ toContents k ++ toContents l ++ toContents m parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; f <- parseContents ; g <- parseContents ; h <- parseContents ; i <- parseContents ; j <- parseContents ; k <- parseContents ; l <- parseContents ; m <- parseContents ; return (a,b,c,d,e,f,g,h,i,j,k,l,m) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e, XmlContent f, XmlContent g, XmlContent h , XmlContent i, XmlContent j, XmlContent k, XmlContent l , XmlContent m, XmlContent n ) => XmlContent (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where toContents (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e ++ toContents f ++ toContents g ++ toContents h ++ toContents i ++ toContents j ++ toContents k ++ toContents l ++ toContents m ++ toContents n parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; f <- parseContents ; g <- parseContents ; h <- parseContents ; i <- parseContents ; j <- parseContents ; k <- parseContents ; l <- parseContents ; m <- parseContents ; n <- parseContents ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n) } instance ( XmlContent a, XmlContent b, XmlContent c, XmlContent d , XmlContent e, XmlContent f, XmlContent g, XmlContent h , XmlContent i, XmlContent j, XmlContent k, XmlContent l , XmlContent m, XmlContent n, XmlContent o ) => XmlContent (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where toContents (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = toContents a ++ toContents b ++ toContents c ++ toContents d ++ toContents e ++ toContents f ++ toContents g ++ toContents h ++ toContents i ++ toContents j ++ toContents k ++ toContents l ++ toContents m ++ toContents n ++ toContents o parseContents = do { a <- parseContents ; b <- parseContents ; c <- parseContents ; d <- parseContents ; e <- parseContents ; f <- parseContents ; g <- parseContents ; h <- parseContents ; i <- parseContents ; j <- parseContents ; k <- parseContents ; l <- parseContents ; m <- parseContents ; n <- parseContents ; o <- parseContents ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) } ------------------------------------------------------------------------ -- Useful auxiliaries for "fromAttributes" ------------------------------------------------------------------------ -- | If an attribute is defaultable, then it either takes the default -- value (which is omitted from the output), or a non-default value -- (which obviously must be printed). data Defaultable a = Default a | NonDefault a deriving (Eq,Show) searchMaybe :: (a -> Maybe b) -> [a] -> Maybe b searchMaybe _ [] = Nothing searchMaybe f (x:xs) = let fx = f x in case fx of Nothing -> searchMaybe f xs (Just _) -> fx maybeToAttr :: (String->a->Maybe Attribute) -> String -> Maybe a -> Maybe Attribute maybeToAttr _ _ Nothing = Nothing maybeToAttr to n (Just v) = to n v defaultToAttr :: (String->a->Maybe Attribute) -> String -> Defaultable a -> Maybe Attribute defaultToAttr _ _ (Default _) = Nothing defaultToAttr to n (NonDefault v) = to n v definiteA :: (String->Attribute->Maybe a) -> String -> String -> [Attribute] -> a definiteA from tag at as = case searchMaybe (from at) as of Nothing -> error ("missing attribute "++at++" in tag <"++tag++">") (Just a) -> a defaultA :: (String->Attribute->Maybe a) -> a -> String -> [Attribute] -> Defaultable a defaultA from def at as = case searchMaybe (from at) as of Nothing -> Default def (Just a) -> NonDefault a possibleA :: (String->Attribute->Maybe a) -> String -> [Attribute] -> Maybe a possibleA from at as = searchMaybe (from at) as fromAttrToStr :: String -> Attribute -> Maybe String fromAttrToStr n (n0,v) | n == localName n0 = Just (attr2str v) | otherwise = Nothing toAttrFrStr :: String -> String -> Maybe Attribute toAttrFrStr n v = Just (N n, str2attr v) str2attr :: String -> AttValue str2attr s = let f t = let (l,r) = span (\c-> not (elem c "\"&<>'")) t in if null r then [Left l] else Left l: Right (g (head r)): f (tail r) g '"' = RefEntity "quot" g '&' = RefEntity "amp" g '<' = RefEntity "lt" g '>' = RefEntity "gt" g '\'' = RefEntity "apos" in AttValue (f s) attr2str :: AttValue -> String -- really needs symbol table attr2str (AttValue xs) = let f (Left s) = s f (Right (RefChar i)) = [chr i] f (Right (RefEntity "quot")) = "\"" f (Right (RefEntity "amp")) = "&" f (Right (RefEntity "lt")) = "<" f (Right (RefEntity "gt")) = ">" f (Right (RefEntity "apos")) = "'" f (Right _) = "*" -- Ooops, ST needed here. in concatMap f xs ------------------------------------------------------------------------ -- New content-model types ------------------------------------------------------------------------ {- data OneOf2 a b data OneOf3 a b c data OneOf4 a b c d ... etc are now defined (with instances) in module OneOfN. -} -- | A type corresponding to XML's ANY contentspec. -- It is either a list of unconverted xml 'Content' -- or some 'XmlContent'-able value. -- -- Parsing functions (e.g. 'parseContents') will always produce 'UnConverted'. -- Note: The Show instance for 'UnConverted' uses 'verbatim'. data ANYContent = forall a . (XmlContent a, Show a) => ANYContent a | UnConverted [Content Posn] instance Show ANYContent where show (UnConverted c) = "UnConverted " ++ (show $ map verbatim c) show (ANYContent a) = "ANYContent " ++ (show a) instance Eq ANYContent where a == b = show a == show b -- | The List1 type represents lists with at least one element. -- It is required for DTD content models that use + as a modifier. data List1 a = NonEmpty [a] deriving (Eq, Show) ------------------------------------------------------------------------ -- Instances for new content-model types ------------------------------------------------------------------------ instance (HTypeable a) => HTypeable (List1 a) where toHType m = Defined "List1" [hx] [Constr "NonEmpty" [hx] [List hx] {-Nothing-}] where (NonEmpty x) = m hx = toHType x instance (XmlContent a) => XmlContent (List1 a) where toContents (NonEmpty xs) = concatMap toContents xs parseContents = fmap NonEmpty $ many1 parseContents instance HTypeable ANYContent where toHType _ = Prim "ANYContent" "ANY" instance XmlContent ANYContent where toContents (ANYContent a) = toContents a toContents (UnConverted s) = map (fmap (const ())) s parseContents = P (\cs -> Success [] (UnConverted cs)) ------------------------------------------------------------------------ -- ------------------------------------------------------------------------ HaXml-1.23.3/src/Text/XML/HaXml/XmlContent.hs0000755000062000006210000001566711767644706017730 0ustar 1341796mkpasswd-- | The class 'XmlContent' is a kind of replacement for Read and Show: -- it provides conversions between a generic XML tree representation -- and your own more specialised typeful Haskell data trees. -- -- If you are starting with an XML DTD, use HaXml's tool DtdToHaskell -- to generate both the Haskell types and the corresponding instances. -- -- If you are starting with a set of Haskell datatypes, use DrIFT to -- derive instances of this class for you: -- http:\/\/repetae.net\/john\/computer\/haskell\/DrIFT -- and _do_not_ use the current module, but rather -- Text.XML.HaXml.XmlContent.Haskell, for the correct matching -- instances for standard Haskell datatypes. module Text.XML.HaXml.XmlContent ( -- * Re-export everything from Text.XML.HaXml.XmlContent.Parser. module Text.XML.HaXml.XmlContent.Parser , module Text.XML.HaXml.TypeMapping -- * Contains instances of the XmlContent classes, -- for the basic Haskell datatypes list and Maybe, -- intended for use with DtdToHaskell-generated datatypes. -- See the alternative instances in Text.XML.HaXml.XmlContent.Haskell -- if your datatypes originate in Haskell instead. -- , module Text.XML.HaXml.XmlContent -- * Whole-document conversion functions , toXml, fromXml , readXml, showXml, fpsShowXml , fReadXml, fWriteXml, fpsWriteXml , hGetXml, hPutXml, fpsHPutXml ) where import System.IO import qualified Text.XML.HaXml.ByteStringPP as FPS (document) import qualified Data.ByteString.Lazy.Char8 as FPS import Text.PrettyPrint.HughesPJ (render) --import Text.ParserCombinators.Poly import Text.XML.HaXml.Types import Text.XML.HaXml.TypeMapping import Text.XML.HaXml.Posn (Posn, posInNewCxt) import Text.XML.HaXml.Pretty (document) import Text.XML.HaXml.Parse (xmlParse) import Text.XML.HaXml.XmlContent.Parser ------------------------------------------------------------------------ -- probably want to write DTD separately from value, and have -- easy ways to combine DTD + value into a document, or write -- them to separate files. -- | Read an XML document from a file and convert it to a fully-typed -- Haskell value. fReadXml :: XmlContent a => FilePath -> IO a fReadXml fp = do f <- ( if fp=="-" then return stdin else openFile fp ReadMode ) x <- hGetContents f let (Document _ _ y _) = xmlParse fp x y' = CElem y (posInNewCxt fp Nothing) either fail return (fst (runParser parseContents [y'])) -- | Write a fully-typed Haskell value to the given file as an XML -- document. fWriteXml :: XmlContent a => FilePath -> a -> IO () fWriteXml fp x = do f <- ( if fp=="-" then return stdout else openFile fp WriteMode ) hPutXml f False x hClose f -- | Write any Haskell value to the given file as an XML document, -- using the FastPackedString interface (output will not be prettified). fpsWriteXml :: XmlContent a => FilePath -> a -> IO () fpsWriteXml fp x = do f <- ( if fp=="-" then return stdout else openFile fp WriteMode ) fpsHPutXml f False x hClose f -- | Read a fully-typed XML document from a string. readXml :: XmlContent a => String -> Either String a readXml s = let (Document _ _ y _) = xmlParse "string input" s in fst (runParser parseContents [CElem y (posInNewCxt "string input" Nothing)]) -- | Convert a fully-typed XML document to a string (without DTD). showXml :: XmlContent a => Bool -> a -> String showXml dtd x = case toContents x of [CElem _ _] -> (render . document . toXml dtd) x _ -> "" -- | Convert a fully-typed XML document to a ByteString (without DTD). fpsShowXml :: XmlContent a => Bool -> a -> FPS.ByteString fpsShowXml dtd x = case toContents x of [CElem _ _] -> (FPS.document . toXml dtd) x _ -> FPS.empty -- | Convert a fully-typed XML document to a string (with or without DTD). toXml :: XmlContent a => Bool -> a -> Document () toXml dtd value = let ht = toHType value in Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing)) [] (if dtd then Just (toDTD ht) else Nothing) []) emptyST ( case toContents value of [] -> Elem (N "empty") [] [] [CElem e ()] -> e (CElem _ ():_) -> error "too many XML elements in document" ) [] -- | Read a Haskell value from an XML document, ignoring the DTD and -- using the Haskell result type to determine how to parse it. fromXml :: XmlContent a => Document Posn -> Either String a fromXml (Document _ _ e@(Elem _ _ _) _) = fst (runParser parseContents [CElem e (posInNewCxt "document" Nothing)]) -- | Read a fully-typed XML document from a file handle. hGetXml :: XmlContent a => Handle -> IO a hGetXml h = do x <- hGetContents h let (Document _ _ y _) = xmlParse "file handle" x either fail return (fst (runParser parseContents [CElem y (posInNewCxt "file handle" Nothing)])) -- | Write a fully-typed XML document to a file handle. hPutXml :: XmlContent a => Handle -> Bool -> a -> IO () hPutXml h dtd x = do (hPutStrLn h . render . document . toXml dtd) x -- | Write a fully-typed XML document to a file handle, using the -- FastPackedString interface (output will not be prettified). fpsHPutXml :: XmlContent a => Handle -> Bool -> a -> IO () fpsHPutXml h dtd x = do (FPS.hPut h . FPS.document . toXml dtd) x ------------------------------------------------------------------------ -- Instances for all the standard basic datatypes. -- DtdToHaskell uses only a small number of standard datatypes. ------------------------------------------------------------------------ instance XmlContent Char where -- NOT in a string toContents _ = error $ "Text.XML.HaXml.XmlContent.toContents "++ " used on a Haskell Char" parseContents = fail $ "Text.XML.HaXml.XmlContent.parseContents "++ " used on a Haskell Char " -- Only defined for Char and no other types: xToChar = id xFromChar = id instance XmlContent a => XmlContent [a] where toContents xs = case toHType x of (Prim "Char" _) -> [CString True (map xToChar xs) ()] _ -> concatMap toContents xs where (x:_) = xs parseContents = let result = runParser p [] -- for type of result only p = case (toHType . head . (\ (Right x)->x) . fst) result of (Prim "Char" _) -> fmap (map xFromChar) $ text _ -> many parseContents in p -- comments, PIs, etc, are skipped in the individual element parser. instance (XmlContent a) => XmlContent (Maybe a) where toContents m = maybe [] toContents m parseContents = optional parseContents ------------------------------------------------------------------------ HaXml-1.23.3/src/Text/XML/HaXml/Xtract/0000755000062000006210000000000011767644706016524 5ustar 1341796mkpasswdHaXml-1.23.3/src/Text/XML/HaXml/Xtract/Combinators.hs0000755000062000006210000000736511767644706021356 0ustar 1341796mkpasswd-- | This is a new set of XML combinators for Xtract, not standard, -- but based on the standard set in "Text.Xml.Haxml.Combinators". -- The main difference is that the Content Filter type becomes a -- Double Filter. A Double Filter always takes the whole document -- as an extra argument, so you can start to traverse it again from -- the root, when at any inner location within the document tree. -- -- The new combinator definitions are derived from the old ones. -- The same names have the equivalent meaning - use module qualification -- on imports to distinguish between CFilter and DFilter variations. module Text.XML.HaXml.Xtract.Combinators where import Text.XML.HaXml.Types import Text.XML.HaXml.Combinators (CFilter) import qualified Text.XML.HaXml.Combinators as C -- | double content filter - takes document root + local subtree. type DFilter i = Content i -> Content i -> [Content i] -- | lift an ordinary content filter to a double filter. local,global :: CFilter i -> DFilter i local f = \_xml sub-> f sub global f = \ xml _sub-> f xml -- | drop a double filter to an ordinary content filter. -- (permitting interior access to document root) dfilter :: DFilter i -> CFilter i dfilter f = \xml-> f xml xml -- | drop a double filter to an ordinary content filter. -- (Where interior access to the document root is not needed, the -- retaining pointer to the outer element can be pruned away. -- 'cfilter' is more space-efficient than 'dfilter' in this situation.) cfilter :: DFilter i -> CFilter i cfilter f = \xml -> f undefined xml --cfilter f = \xml-> flip f xml -- (case xml of -- CElem (Elem n as cs) i -> CElem (Elem n [] []) i -- _ -> xml) -- | lift a CFilter combinator to a DFilter combinator liftLocal, liftGlobal :: (CFilter i->CFilter i) -> (DFilter i->DFilter i) liftLocal ff = \df-> \xml sub-> (ff (df xml)) sub liftGlobal ff = \df-> \xml _sub-> (ff (df xml)) xml -- | lifted composition over double filters. o :: DFilter i -> DFilter i -> DFilter i g `o` f = \xml-> concatMap (g xml) . (f xml) -- | lifted choice. (|>|) :: (a->b->[c]) -> (a->b->[c]) -> (a->b->[c]) f |>| g = \xml sub-> let first = f xml sub in if null first then g xml sub else first -- | lifted union. union :: (a->b->[c]) -> (a->b->[c]) -> (a->b->[c]) union = lift (++) where lift f g h = \x y-> f (g x y) (h x y) -- | lifted predicates. with, without :: DFilter i -> DFilter i -> DFilter i f `with` g = \xml-> filter (not.null.g xml) . f xml f `without` g = \xml-> filter (null.g xml) . f xml -- | lifted unit and zero. keep, none :: DFilter i keep = \_xml sub-> [sub] -- local C.keep none = \_xml _sub-> [] -- local C.none children, elm, txt :: DFilter i children = local C.children elm = local C.elm txt = local C.txt applypred :: CFilter i -> DFilter i -> CFilter i applypred f p = \xml-> (const f `with` p) xml xml iffind :: String -> (String -> DFilter i) -> DFilter i -> DFilter i iffind key yes no xml c@(CElem (Elem _ as _) _) = case (lookup (N key) as) of Nothing -> no xml c (Just v@(AttValue _)) -> yes (show v) xml c iffind _key _yes no xml other = no xml other ifTxt :: (String->DFilter i) -> DFilter i -> DFilter i ifTxt yes _no xml c@(CString _ s _) = yes s xml c ifTxt _yes no xml c = no xml c cat :: [a->b->[c]] -> (a->b->[c]) cat fs = \xml sub-> concat [ f xml sub | f <- fs ] (/>) :: DFilter i -> DFilter i -> DFilter i f /> g = g `o` children `o` f ( DFilter i -> DFilter i f DFilter i deep f = f |>| (deep f `o` children) deepest f = (deepest f `o` children) |>| f multi f = f `union` (multi f `o` children) HaXml-1.23.3/src/Text/XML/HaXml/Xtract/Lex.hs0000755000062000006210000001225611767644706017621 0ustar 1341796mkpasswd-- | This is another hand-written lexer, this time for the Xtract -- command-language. The entry point is lexXtract. You don't -- normally need to use this module directly - the lexer is called -- automatically by the parser. (We only expose this interface -- for debugging purposes.) -- -- The Xtract command language is very like the XPath specification. module Text.XML.HaXml.Xtract.Lex ( lexXtract , Posn(..) , TokenT(..) , Token ) where import Data.Char type Token = Either String (Posn, TokenT) data Posn = Pn Int -- char index only deriving Eq instance Show Posn where showsPrec _p (Pn c) = showString "char pos " . shows c data TokenT = Symbol String | TokString String -- begins with letter | TokNum Integer -- begins with digit deriving Eq instance Show TokenT where showsPrec _p (Symbol s) = showString s showsPrec _p (TokString s) = showString s showsPrec _p (TokNum n) = shows n emit :: TokenT -> Posn -> Token emit tok p = forcep p `seq` Right (p,tok) where forcep (Pn n) = n lexerror :: String -> Posn -> [Token] lexerror s p = [Left ("Lexical error in selection pattern at "++show p++": " ++s++"\n")] addcol :: Int -> Posn -> Posn addcol n (Pn c) = Pn (c+n) newline, tab :: Posn -> Posn newline (Pn c) = Pn (c+1) tab (Pn c) = Pn (((c`div`8)+1)*8) white :: Char -> Posn -> Posn white '\t' = tab white ' ' = addcol 1 white '\n' = addcol 1 white '\r' = addcol 1 white '\xa0' = addcol 1 blank :: (Posn->String->[Token]) -> Posn-> String-> [Token] blank _ _ [] = [] blank k p (' ': s) = blank k (addcol 1 p) s blank k p ('\t':s) = blank k (tab p) s blank k p ('\n':s) = blank k (newline p) s blank k p ('\r':s) = blank k p s blank k p ('\xa0': s) = blank k (addcol 1 p) s blank k p s = k p s ---- -- | First argument is a transformer for pattern strings, e.g. map toLower, -- but only applying to parts of the pattern not in quotation marks. -- (Needed to canonicalise HTML where tags are case-insensitive, but -- attribute values are case sensitive.) lexXtract :: (String->String) -> String -> [Token] lexXtract f = selAny f (Pn 1) syms :: [Char] syms = "/[]()@,=*&|~$+-<>" selAny :: (String->String) -> Posn -> String -> [Token] selAny _ _ [] = [] selAny f p ('/':'/':ss) = emit (Symbol "//") p: selAny f (addcol 2 p) ss selAny f p ('!':'=':ss) = emit (Symbol "!=") p: selAny f (addcol 2 p) ss selAny f p ('<':'=':ss) = emit (Symbol "<=") p: selAny f (addcol 2 p) ss selAny f p ('>':'=':ss) = emit (Symbol ">=") p: selAny f (addcol 2 p) ss selAny f p ('\'':ss) = emit (Symbol "'") p: accumulateUntil '\'' (Symbol "'") [] p (addcol 1 p) ss (selAny f) selAny f p ('"':ss) = emit (Symbol "\"") p: accumulateUntil '"' (Symbol "\"") [] p (addcol 1 p) ss (selAny f) selAny f p ('_':ss) = gatherName f "_" p (addcol 1 p) ss (blank (selAny f)) selAny f p (':':ss) = gatherName f ":" p (addcol 1 p) ss (blank (selAny f)) selAny f p ('.':'=':'.':ss) = emit (Symbol ".=.") p: selAny f (addcol 3 p) ss selAny f p ('.':'!':'=':'.':ss) = emit (Symbol ".!=.") p: selAny f (addcol 4 p) ss selAny f p ('.':'<':'.':ss) = emit (Symbol ".<.") p: selAny f (addcol 3 p) ss selAny f p ('.':'<':'=':'.':ss) = emit (Symbol ".<=.") p: selAny f (addcol 4 p) ss selAny f p ('.':'>':'.':ss) = emit (Symbol ".>.") p: selAny f (addcol 3 p) ss selAny f p ('.':'>':'=':'.':ss) = emit (Symbol ".>=.") p: selAny f (addcol 4 p) ss selAny f p ('.':'/':ss) = emit (Symbol "./") p: selAny f (addcol 2 p) ss selAny f p (s:ss) | s `elem` syms = emit (Symbol [s]) p: selAny f (addcol 1 p) ss | isSpace s = blank (selAny f) p (s:ss) | isAlpha s = gatherName f [s] p (addcol 1 p) ss (blank (selAny f)) | isDigit s = gatherNum [s] p (addcol 1 p) ss (blank (selAny f)) | otherwise = lexerror "unrecognised pattern" p gatherName :: (String->String) -> String -> Posn -> Posn -> String -> (Posn->String->[Token]) -> [Token] gatherName f acc pos p (s:ss) k | isAlphaNum s || s `elem` "-_:" = gatherName f (s:acc) pos (addcol 1 p) ss k gatherName f acc pos p ss k = emit (TokString (f (reverse acc))) pos: k p ss gatherNum :: String -> Posn -> Posn -> String -> (Posn->String->[Token]) -> [Token] gatherNum acc pos p (s:ss) k | isHexDigit s = gatherNum (s:acc) pos (addcol 1 p) ss k gatherNum acc pos p ss k = emit (TokNum (read (reverse acc))) pos: k p ss accumulateUntil :: Char -> TokenT -> String -> Posn -> Posn -> String -> (Posn->String->[Token]) -> [Token] accumulateUntil c _tok _acc pos p [] _k = lexerror ("found end of pattern while looking for "++c :" to match opening quote at "++show pos) p accumulateUntil c tok acc pos p (s:ss) k | c==s = emit (TokString (reverse acc)) pos: emit tok p: k (addcol 1 p) ss | isSpace s = accumulateUntil c tok (s:acc) pos (white s p) ss k | otherwise = accumulateUntil c tok (s:acc) pos (addcol 1 p) ss k HaXml-1.23.3/src/Text/XML/HaXml/Xtract/Parse.hs0000755000062000006210000003111611767644706020137 0ustar 1341796mkpasswd-- | A parser for the Xtract command-language. (The string input is -- tokenised internally by the lexer 'lexXtract'.) -- See for the grammar that -- is accepted. -- Because the original Xtract grammar was left-recursive, we have -- transformed it into a non-left-recursive form. module Text.XML.HaXml.Xtract.Parse (parseXtract,xtract) where import Text.ParserCombinators.Poly hiding (bracket) import Text.XML.HaXml.Xtract.Lex import Text.XML.HaXml.Xtract.Combinators as D import Text.XML.HaXml.Combinators as C import Text.XML.HaXml.Types (Content) import Data.List(isPrefixOf) import Text.XML.HaXml.Escape (xmlUnEscapeContent,stdXmlEscaper) -- output transformer - to ensure that text/references are glued together unescape :: [Content i] -> [Content i] unescape = xmlUnEscapeContent stdXmlEscaper -- | To convert an Xtract query into an ordinary HaXml combinator expression. -- First arg is a tag-transformation function (e.g. map toLower) applied --- before matching. Second arg is the query string. xtract :: (String->String) -> String -> CFilter i xtract f query | interiorRef lexedQ = dfilter (parseXtract lexedQ) | otherwise = cfilter (parseXtract lexedQ) where lexedQ = lexXtract f query -- test whether query has interior reference to doc root interiorRef (Right (_,Symbol s): Right (_,Symbol "//"): _) | s `elem` predicateIntro = True interiorRef (Right (_,Symbol s): Right (_,Symbol "/"): _) | s `elem` predicateIntro = True interiorRef (_ : rest) = interiorRef rest interiorRef [] = False predicateIntro = [ "[", "(" , "&", "|", "~" , "=", "!=", "<", "<=", ">", ">=" , ".=.",".!=.",".<.",".<=.",".>.",".>=." ] -- | The cool thing is that the Xtract command parser directly builds -- a higher-order 'DFilter' (see "Text.XML.HaXml.Xtract.Combinators") -- which can be applied to an XML document without further ado. -- (@parseXtract@ halts the program if a parse error is found.) parseXtract :: [Token] -> DFilter i parseXtract = either error id . parseXtract' -- | @parseXtract'@ returns error messages through the Either type. parseXtract' :: [Token] -> Either String (DFilter i) parseXtract' = fst . runParser (aquery liftLocal) ---- Auxiliary Parsing Functions ---- type XParser a = Parser (Either String (Posn,TokenT)) a string :: XParser String string = P (\inp -> case inp of (Left err: _) -> Failure inp err (Right (_,TokString n):ts) -> Success ts n ts -> Failure ts "expected a string" ) number :: XParser Integer number = P (\inp -> case inp of (Left err: _) -> Failure inp err (Right (_,TokNum n):ts) -> Success ts n ts -> Failure ts "expected a number" ) symbol :: String -> XParser () symbol s = P (\inp -> case inp of (Left err: _) -> Failure inp err (Right (_, Symbol n):ts) | n==s -> Success ts () ts -> Failure ts ("expected symbol "++s) ) quote :: XParser () quote = oneOf [ symbol "'", symbol "\"" ] pam :: [a->b] -> a -> [b] pam fs x = [ f x | f <- fs ] {--- original Xtract grammar ---- query = string tagname | string * tagname prefix | * string tagname suffix | * any element | - chardata | ( query ) | query / query parent/child relationship | query // query deep inside | query + query union of queries | query [predicate] | query [positions] predicate = quattr has attribute | quattr op ' string ' attribute has value | quattr op " string " attribute has value | quattr op quattr attribute value comparison (lexical) | quattr nop integer attribute has value (numerical) | quattr nop quattr attribute value comparison (numerical) | ( predicate ) bracketting | predicate & predicate logical and | predicate | predicate logical or | ~ predicate logical not attribute = @ string has attribute | query / @ string child has attribute | - has textual content | query / - child has textual content quattr = query | attribute op = = equal to | != not equal to | < less than | <= less than or equal to | > greater than | >= greater than or equal to nop = .=. equal to | .!=. not equal to | .<. less than | .<=. less than or equal to | .>. greater than | .>=. greater than or equal to positions = position {, positions} multiple positions | position - position ranges position = integer numbering is from 0 upwards | $ last ---- transformed grammar (removing left recursion) aquery = ./ tquery -- current context | tquery -- also current context | / tquery -- root context | // tquery -- deep context from root tquery = ( tquery ) xquery | tag xquery | - -- fixes original grammar ("-/*" is incorrect) tag = string * | string | * string | * xquery = / tquery | // tquery | / @ string -- new: print attribute value | + tquery | [ tpredicate ] xquery | [ positions ] xquery | lambda tpredicate = vpredicate upredicate upredicate = & tpredicate | | tpredicate | lambda vpredicate = ( tpredicate ) | ~ tpredicate | tattribute tattribute = aquery uattribute | @ string vattribute uattribute = / @ string vattribute | vattribute vattribute = op wattribute | op ' string ' | nop wattribute | nop integer | lambda wattribute = @ string | aquery / @ string | aquery positions = simplepos commapos simplepos = integer range | $ range = - integer | - $ | lambda commapos = , simplepos commapos | lambda op = = | != | < | <= | > | >= nop = .=. | .!=. | .<. | .<=. | .>. | .>=. -} bracket :: XParser a -> XParser a bracket p = do symbol "(" x <- p symbol ")" return x ---- Xtract parsers ---- -- aquery chooses to search from the root, or only in local context aquery :: ((CFilter i->CFilter i) -> (DFilter i->DFilter i)) -> XParser (DFilter i) aquery lift = oneOf [ do symbol "//" tquery [lift C.multi] , do symbol "/" tquery [lift id] , do symbol "./" tquery [(local C.keep D./>)] , do tquery [(local C.keep D./>)] ] tquery :: [DFilter i->DFilter i] -> XParser (DFilter i) tquery [] = tquery [id] tquery (qf:cxt) = oneOf [ do q <- bracket (tquery (qf:qf:cxt)) xquery cxt q , do q <- xtag xquery cxt (qf ((unescape .).q)) -- glue inners texts together , do symbol "-" return (qf (local C.txt)) ] xtag :: XParser (DFilter i) xtag = oneOf [ do s <- string symbol "*" return (local (C.tagWith (s `isPrefixOf`))) , do s <- string return (local (C.tag s)) , do symbol "*" s <- string return (local (C.tagWith (((reverse s) `isPrefixOf`) . reverse))) , do symbol "*" return (local C.elm) ] xquery :: [DFilter i->DFilter i] -> DFilter i -> XParser (DFilter i) xquery cxt q1 = oneOf [ do symbol "/" ( do symbol "@" attr <- string return (D.iffind attr (\s->local (C.literal s)) D.none `D.o` q1) `onFail` tquery ((q1 D./>):cxt) ) , do symbol "//" tquery ((\q2-> (liftLocal C.multi) q2 `D.o` local C.children `D.o` q1):cxt) , do symbol "+" q2 <- tquery cxt return (D.cat [q1,q2]) , do symbol "[" is <- iindex -- now extended to multiple indexes symbol "]" xquery cxt (\xml-> concat . pam is . q1 xml) , do symbol "[" p <- tpredicate symbol "]" xquery cxt (q1 `D.with` p) , return q1 ] tpredicate :: XParser (DFilter i) tpredicate = do p <- vpredicate f <- upredicate return (f p) upredicate :: XParser (DFilter i->DFilter i) upredicate = oneOf [ do symbol "&" p2 <- tpredicate return (`D.o` p2) , do symbol "|" p2 <- tpredicate return (D.|>| p2) , return id ] vpredicate :: XParser (DFilter i) vpredicate = oneOf [ do bracket tpredicate , do symbol "~" p <- tpredicate return (local C.keep `D.without` p) , do tattribute ] tattribute :: XParser (DFilter i) tattribute = oneOf [ do q <- aquery liftGlobal uattribute q , do symbol "@" s <- string vattribute (local C.keep, local (C.attr s), D.iffind s) ] uattribute :: DFilter i -> XParser (DFilter i) uattribute q = oneOf [ do symbol "/" symbol "@" s <- string vattribute (q, local (C.attr s), D.iffind s) , do vattribute (q, local C.keep, D.ifTxt) ] vattribute :: (DFilter i, DFilter i, (String->DFilter i)->DFilter i->DFilter i) -> XParser (DFilter i) vattribute (q,a,iffn) = oneOf [ do cmp <- op quote s2 <- string quote return ((iffn (\s1->if cmp s1 s2 then D.keep else D.none) D.none) `D.o` q) , do cmp <- op (q2,iffn2) <- wattribute -- q2 unused? is this a mistake? return ((iffn (\s1-> iffn2 (\s2-> if cmp s1 s2 then D.keep else D.none) D.none) D.none) `D.o` q) , do cmp <- nop n <- number return ((iffn (\s->if cmp (read s) n then D.keep else D.none) D.none) `D.o` q) , do cmp <- nop (q2,iffn2) <- wattribute -- q2 unused? is this a mistake? return ((iffn (\s1-> iffn2 (\s2-> if cmp (read s1) (read s2) then D.keep else D.none) D.none) D.none) `D.o` q) , do return ((a `D.o` q)) ] wattribute :: XParser (DFilter i, (String->DFilter i)->DFilter i->DFilter i) wattribute = oneOf [ do symbol "@" s <- string return (D.keep, D.iffind s) , do q <- aquery liftGlobal symbol "/" symbol "@" s <- string return (q, D.iffind s) , do q <- aquery liftGlobal return (q, D.ifTxt) ] iindex :: XParser [[a]->[a]] iindex = do i <- simpleindex is <- idxcomma return (i:is) simpleindex :: XParser ([a]->[a]) simpleindex = oneOf [ do n <- number r <- rrange n return r , do symbol "$" return (C.keep . last) ] rrange, numberdollar :: Integer -> XParser ([a]->[a]) rrange n1 = oneOf [ do symbol "-" numberdollar n1 , return (take 1 . drop (fromInteger n1)) ] numberdollar n1 = oneOf [ do n2 <- number return (take (fromInteger (1+n2-n1)) . drop (fromInteger n1)) , do symbol "$" return (drop (fromInteger n1)) ] idxcomma :: XParser [[a]->[a]] idxcomma = oneOf [ do symbol "," r <- simpleindex rs <- idxcomma return (r:rs) , return [] ] op :: XParser (String->String->Bool) op = oneOf [ do symbol "="; return (==) , do symbol "!="; return (/=) , do symbol "<"; return (<) , do symbol "<="; return (<=) , do symbol ">"; return (>) , do symbol ">="; return (>=) ] nop :: XParser (Integer->Integer->Bool) nop = oneOf [ do symbol ".=."; return (==) , do symbol ".!=."; return (/=) , do symbol ".<."; return (<) , do symbol ".<=."; return (<=) , do symbol ".>."; return (>) , do symbol ".>=."; return (>=) ] HaXml-1.23.3/src/Text/XML/HaXml.hs0000755000062000006210000000226211767644706015620 0ustar 1341796mkpasswd{-# LANGUAGE CPP #-} #define dummy -- just to ensure cpp gets called on this file -- | This is just a convenient way of bunching the XML combinators -- together with some other things you are likely to want at the -- same time. module Text.XML.HaXml ( module Text.XML.HaXml.Types , module Text.XML.HaXml.Combinators , module Text.XML.HaXml.Parse , module Text.XML.HaXml.Pretty , module Text.XML.HaXml.Html.Generate , module Text.XML.HaXml.Html.Parse , module Text.XML.HaXml.Validate , module Text.XML.HaXml.Wrappers , module Text.XML.HaXml.Verbatim , module Text.XML.HaXml.Escape , render , version ) where import Text.XML.HaXml.Types import Text.XML.HaXml.Combinators import Text.XML.HaXml.Parse (xmlParse,dtdParse) import Text.XML.HaXml.Pretty (element) import Text.XML.HaXml.Html.Generate import Text.XML.HaXml.Html.Parse (htmlParse) import Text.XML.HaXml.Validate (validate) import Text.XML.HaXml.Wrappers (fix2Args,processXmlWith) import Text.XML.HaXml.Verbatim import Text.XML.HaXml.Escape import Text.PrettyPrint.HughesPJ (render) -- | The version of the library. version :: String version = show MAJOR.MINOR -- expect cpp to fill in value HaXml-1.23.3/src/tools/0000755000062000006210000000000011767644706014022 5ustar 1341796mkpasswdHaXml-1.23.3/src/tools/Canonicalise.hs0000755000062000006210000000167611767644706016763 0ustar 1341796mkpasswdmodule Main where import System.IO import Data.List (isSuffixOf) import Text.XML.HaXml.Parse (xmlParse) import Text.XML.HaXml.Html.Parse (htmlParse) import Text.XML.HaXml.Pretty (document) import Text.XML.HaXml.Wrappers (fix2Args) import Text.PrettyPrint.HughesPJ (render) -- This is just a trivial application that reads an XML or HTML document -- from a file (or stdin) and writes it back to another file (or stdout). -- It demonstrates the behaviour of the parser and pretty-printer, -- including any shortcomings they may have. main :: IO () main = fix2Args >>= \(inf,outf)-> ( if inf=="-" then getContents else readFile inf ) >>= \content-> ( if outf=="-" then return stdout else openFile outf WriteMode ) >>= \o-> let parse = if ".html" `isSuffixOf` inf || ".htm" `isSuffixOf` inf then htmlParse inf else xmlParse inf in do ( hPutStrLn o . render . document . parse) content hFlush o HaXml-1.23.3/src/tools/CanonicaliseLazy.hs0000755000062000006210000000213011767644706017605 0ustar 1341796mkpasswdmodule Main where import System.IO import Data.List (isSuffixOf) import Text.XML.HaXml.ParseLazy (xmlParse) import Text.XML.HaXml.Html.ParseLazy (htmlParse) import Text.XML.HaXml.Wrappers (fix2Args) import Text.PrettyPrint.HughesPJ (render) import qualified Text.XML.HaXml.Pretty as XmlPP import qualified Text.XML.HaXml.Html.Pretty as HtmlPP -- This is just a trivial application that reads an XML or HTML document -- from a file (or stdin) and writes it back to another file (or stdout). -- It demonstrates the behaviour of the parser and pretty-printer, -- including any shortcomings they may have. main :: IO () main = fix2Args >>= \(inf,outf)-> ( if inf=="-" then getContents else readFile inf ) >>= \content-> ( if outf=="-" then return stdout else openFile outf WriteMode ) >>= \o-> let (parse,format) = if ".html" `isSuffixOf` inf || ".htm" `isSuffixOf` inf then (htmlParse inf, HtmlPP.document) else (xmlParse inf, XmlPP.document) in do ( mapM_ (hPutStrLn o) . lines . render . format . parse) content hFlush o HaXml-1.23.3/src/tools/DtdToHaskell.hs0000755000062000006210000000546511767644706016715 0ustar 1341796mkpasswdmodule Main where -- This program is provided to convert an XML file containing a DTD -- into a Haskell module containing data/newtype definitions which -- mirror the DTD. Once you have used this program to generate your type -- definitions, you should import Xml2Haskell wherever you intend -- to read and write XML files with your Haskell programs. import System.Environment import System.Exit import System.IO import Data.List (nub,takeWhile,dropWhile) import Control.Monad --import Text.XML.HaXml.Wrappers (fix2Args) import Text.XML.HaXml (version) import Text.XML.HaXml.Types (DocTypeDecl(..)) import Text.XML.HaXml.Namespaces (localName) import Text.XML.HaXml.Parse (dtdParse) import Text.XML.HaXml.DtdToHaskell.TypeDef (TypeDef,ppTypeDef,mangle) import Text.XML.HaXml.DtdToHaskell.Convert (dtd2TypeDef) import Text.XML.HaXml.DtdToHaskell.Instance (mkInstance) import Text.PrettyPrint.HughesPJ (render,vcat) -- sucked in from Text.XML.HaXml.Wrappers to avod dependency on T.X.H.Html fix2Args :: IO (String,String) fix2Args = do args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version exitWith ExitSuccess when ("--help" `elem` args) $ do putStrLn $ "See http://haskell.org/HaXml" exitWith ExitSuccess case length args of 0 -> return ("-", "-") 1 -> return (args!!0, "-") 2 -> return (args!!0, args!!1) _ -> do prog <- getProgName putStrLn ("Usage: "++prog++" [xmlfile] [outfile]") exitFailure main ::IO () main = fix2Args >>= \(inf,outf)-> ( if inf=="-" then getContents else readFile inf ) >>= \content-> ( if outf=="-" then return stdout else openFile outf WriteMode ) >>= \o-> let (DTD name _ markup) = (getDtd . dtdParse inf) content decls = (nub . dtd2TypeDef) markup realname = if outf/="-" then mangle (trim outf) else if null (localName name) then mangle (trim inf) else mangle (localName name) in do hPutStrLn o ("module "++realname ++" where\n\nimport Text.XML.HaXml.XmlContent" ++"\nimport Text.XML.HaXml.Types" ++"\nimport Text.XML.HaXml.OneOfN") -- ++"\nimport Char (isSpace)" -- ++"\nimport List (isPrefixOf)" hPutStrLn o "\n\n{-Type decls-}\n" (hPutStrLn o . render . vcat . map ppTypeDef) decls hPutStrLn o "\n\n{-Instance decls-}\n" mapM_ (hPutStrLn o . (++"\n") . render . mkInstance) decls hPutStrLn o "\n\n{-Done-}" hFlush o getDtd :: Maybe t -> t getDtd (Just dtd) = dtd getDtd (Nothing) = error "No DTD in this document" trim :: [Char] -> [Char] trim name | '/' `elem` name = (trim . tail . dropWhile (/='/')) name | '.' `elem` name = takeWhile (/='.') name | otherwise = name HaXml-1.23.3/src/tools/FpMLToHaskell.hs0000755000062000006210000002312611767644706016772 0ustar 1341796mkpasswd-- FpMLToHaskell module Main where -- This program is designed to convert a bunch of XML files containing XSD -- module decls into a bunch of Haskell modules containing data/newtype -- definitions which mirror the XSD. Once you have used this program -- to generate your type definitions, you should import Text.XML.HaXml.Schema -- (as well as the generated modules) wherever you intend to read and write -- XML files with your Haskell programs. import System.Exit import System.Environment import System.IO import Control.Monad import System.Directory import Data.List import Data.Maybe (fromMaybe,catMaybes) import Data.Function (on) import Data.Monoid (mconcat) --import Either import Text.XML.HaXml (version) import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces (resolveAllNames,qualify ,nullNamespace) import Text.XML.HaXml.Parse (xmlParse') import Text.XML.HaXml.Util (docContent) import Text.XML.HaXml.Posn (posInNewCxt) import Text.XML.HaXml.Schema.Parse import Text.XML.HaXml.Schema.XSDTypeModel (Schema) import Text.XML.HaXml.Schema.NameConversion import Text.XML.HaXml.Schema.Environment as Env import Text.XML.HaXml.Schema.TypeConversion as XsdToH import Text.XML.HaXml.Schema.PrettyHaskell import qualified Text.XML.HaXml.Schema.PrettyHsBoot as HsBoot import qualified Text.XML.HaXml.Schema.HaskellTypeModel as Haskell import Text.ParserCombinators.Poly import Text.PrettyPrint.HughesPJ (render,vcat) fst3 :: (a,b,c) -> a fst3 (a,_,_) = a -- sucked in from Text.XML.HaXml.Wrappers to avoid dependency on T.X.H.Html argDirsToFiles :: IO (FilePath,[(FilePath,FilePath)]) argDirsToFiles = do args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version exitWith ExitSuccess when ("--help" `elem` args) $ do putStrLn $ "Usage: FpMLToHaskell xsdDir haskellDir" putStrLn $ " -- The results go into haskelldir/Data/FpML/file0.hs etc" putStrLn $ "See http://haskell.org/HaXml" exitWith ExitSuccess case args of [xsddir,hdir]-> do files <- fmap (filter (".xsd" `isSuffixOf`)) (getDirectoryContents xsddir) let newdirs = map (\file->hdir++"/"++dirOf (fpml file)) files mapM_ (\newdir -> do createDirectoryIfMissing True newdir) newdirs return (xsddir ,map (\f-> (f, hdir++"/"++(reslash (fpml f))++".hs")) files) _ -> do prog <- getProgName putStrLn ("Usage: "++prog++" xsdDir haskellDir") exitFailure where reslash = map (\c-> case c of '.'->'/'; _->c) dirOf = concat . intersperse "/" . init . wordsBy '.' wordsBy c s = let (a,b) = span (/=c) s in if null b then [a] else a: wordsBy c (tail b) main ::IO () main = do (dir,files) <- argDirsToFiles deps <- flip mapM files (\ (inf,outf)-> do hPutStrLn stdout $ "Reading "++inf thiscontent <- readFile (dir++"/"++inf) let d@Document{} = resolveAllNames qualify . either (error . ("not XML:\n"++)) id . xmlParse' inf $ thiscontent case runParser schema [docContent (posInNewCxt inf Nothing) d] of (Left msg,_) -> do hPutStrLn stderr msg return ([], undefined) (Right v,[]) -> return (Env.gatherImports v, v) (Right v,_) -> do hPutStrLn stdout $ "Parse incomplete!" hPutStrLn stdout $ inf hPutStrLn stdout $ "\n-----------------\n" hPutStrLn stdout $ show v hPutStrLn stdout $ "\n-----------------\n" return ([],v) ) let filedeps :: [[((FilePath,FilePath),([(FilePath,Maybe String)],Schema))]] filedeps = ordered (\ ((inf,_),_)-> inf) (\ (_,(ds,_))-> map fst ds) (\x-> lookupWith (fst.fst) x (zip files deps)) (zip files deps) -- a single supertype environment, closed over all modules supertypeEnv :: Environment supertypeEnv = foldr (\fs e-> foldr (\((inf,_),(_,v))-> mkEnvironment inf v) e fs) emptyEnv filedeps adjust :: Environment -> Environment adjust env = env{ env_extendty = env_extendty supertypeEnv , env_substGrp = env_substGrp supertypeEnv , env_allTypes = env_allTypes supertypeEnv } -- each module's env includes only dependencies, apart from supertypes environs :: [(FilePath,(Environment,FilePath,Schema))] environs = flip concatMap filedeps $ \scc-> case scc of [((inf,outf),(ds,v))]-> [(inf, ( adjust $ mkEnvironment inf v (foldr combineEnv emptyEnv (flip map ds (\d-> fst3 $ fromMaybe (error "FME") $ lookup (fst d) environs) ) ) , outf , v ) )] cyclic -> let jointSchema :: Schema jointSchema = mconcat (map (snd.snd) cyclic) jointDeps :: [FilePath] jointDeps = concatMap (map fst.fst.snd) cyclic jointEnv :: Environment jointEnv = mkEnvironment "" jointSchema $ foldr combineEnv emptyEnv $ flip map (nub jointDeps \\ map (fst.fst) cyclic) (\d-> fst3 $ fromMaybe (error "FME") $ lookup d environs) in flip map cyclic (\((inf,outf),(_,v))-> (inf,(adjust $ mkEnvironment inf v $ jointEnv ,outf ,v) ) ) flip mapM_ environs (\ (inf,(env,outf,v))-> do o <- openFile outf WriteMode hb <- openFile (bootf outf) WriteMode let decls = XsdToH.convert env v haskell = Haskell.mkModule inf v decls doc = ppModule fpmlNameConverter haskell docboot = HsBoot.ppModule fpmlNameConverter haskell hPutStrLn stdout $ "Writing "++outf hPutStrLn o $ render doc hPutStrLn stdout $ "Writing "++(bootf outf) hPutStrLn hb $ render docboot hFlush o hFlush hb ) -- | Munge filename for hs-boot. bootf :: FilePath -> FilePath bootf x = case reverse x of 's':'h':'.':f -> reverse f++".hs-boot" _ -> error "bad stuff made my cheese boots melt" -- | Calculate dependency ordering of modules, least dependent first. -- Cyclic groups may occur, suitably placed in the ordering. ordered :: (Eq a, Eq b) => (b->a) -> (b->[a]) -> (a->Maybe b) -> [b] -> [[b]] ordered name deps env list = let cycles = cyclicDeps name deps env list noncyclic = map (:[]) $ list \\ concat cycles workqueue = noncyclic++cycles in traverse [] workqueue where traverse acc [] = acc traverse acc (w:wq) = if all (`elem` concatMap (map name) acc) (concatMap deps w \\ map name w) then traverse (acc++[w]) wq else traverse acc (wq++[w]) -- | Find cyclic dependencies between modules. cyclicDeps :: Eq a => (b->a) -> (b->[a]) -> (a->Maybe b) -> [b] -> [[b]] cyclicDeps name deps env = nubBy (setEq`on`map name) . (\cs-> foldl minimal cs cs) . concatMap (walk []) where -- walk :: [b] -> b -> [[b]] walk acc t = if name t `elem` map name acc then [acc] else concatMap (walk (t:acc)) (catMaybes . map env $ deps t) minimal acc c = concatMap (prune c) acc prune c c' = if map name c `isProperSubsetOf` map name c' then [] else [c'] isSubsetOf a b = all (`elem`b) a setEq a b = a`isSubsetOf`b && b`isSubsetOf`a isProperSubsetOf a b = a`isSubsetOf`b && not (b`isSubsetOf`a) -- | A variation on the standard lookup function. lookupWith :: Eq a => (b->a) -> a -> [b] -> Maybe b lookupWith proj x [] = Nothing lookupWith proj x (y:ys) | proj y == x = Just y | otherwise = lookupWith proj x ys -- | What is the targetNamespace of the unique top-level element? targetNamespace :: Element i -> String targetNamespace (Elem qn attrs _) = if qn /= xsdSchema then "ERROR! top element not an xsd:schema tag" else case lookup (N "targetNamespace") attrs of Nothing -> "ERROR! no targetNamespace specified" Just atv -> show atv -- | The XSD Namespace. xsdSchema :: QName xsdSchema = QN (nullNamespace{nsURI="http://www.w3.org/2001/XMLSchema"}) "schema" HaXml-1.23.3/src/tools/MkOneOf.hs0000755000062000006210000001071411767644706015662 0ustar 1341796mkpasswdmodule Main where import Prelude hiding (max) import System.Exit (exitWith,ExitCode(..)) import System.Environment (getArgs) import Data.Char (isDigit) import System.IO (hFlush,stdout) import Control.Monad (when) import Text.XML.HaXml (version) main :: IO () main = do args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version exitWith ExitSuccess when ("--help" `elem` args) $ do putStrLn $ "See http://haskell.org/HaXml" exitWith ExitSuccess case length args of 1 -> do n <- saferead (head args) putStrLn ("module Text.XML.HaXml."++constructor 1 n++" where\n") putStrLn ("import Text.XML.HaXml.XmlContent\n") putStrLn (mkOneOf n) 2 -> do n <- saferead (args!!0) m <- saferead (args!!1) putStrLn ("module Text.XML.HaXml.OneOfN where\n") putStrLn ("import Text.XML.HaXml.XmlContent\n") mapM_ (putStrLn . mkOneOf) [n..m] _ -> error "Usage: MkOneOf n [m]" hFlush stdout ---- main text-generating function ---- mkOneOf :: Int -> String mkOneOf n = "data "++ typename n 12 ++ "\n "++ format 3 78 3 " = " " | " (zipWith (\m v->constructor m n++" "++v) [1..n] (take n variables)) ++ "\n deriving (Eq,Show)" ++ "\n\ninstance "++ format 9 78 9 "(" "," (map ("HTypeable "++) (take n variables)) ++ ")\n => HTypeable ("++ typename n 26 ++")\n where" ++ " toHType _ = Defined \""++constructor 1 n++"\" [] []" ++ "\n\ninstance "++ format 9 78 9 "(" "," (map ("XmlContent "++) (take n variables)) ++ ")\n => XmlContent ("++ typename n 26 ++")\n where" ++ "\n parseContents =" ++ "\n "++ format 7 78 7 " (" " $ " (map (\v->"choice "++constructor v n) [1..n]) ++ "\n $ fail \""++constructor 1 n++"\")" ++ concatMap (\v->"\n toContents ("++constructor v n ++" x) = toContents x") [1..n] ++ "\n\nfold"++constructor 1 n++" :: " ++format 15 78 15 "" "" (map (\v->"("++v++"->z) -> ") (take n variables)) ++"\n " ++constructor 1 n++format 22 78 22 " " " " (take n variables) ++"\n -> z" ++ concat (zipWith (\i v-> "\n"++"fold"++constructor 1 n ++format 11 50 11 " " " " (take n variables) ++" ("++constructor i n ++" z) = "++v++" z") [1..n] (take n variables)) ++ "\n\n----" ---- constructor names ---- typename :: Int -> Int -> String typename n pos = constructor 1 n ++ format pos 78 pos " " " " (take n variables) constructor :: Int -> Int -> String constructor n m = ordinal n ++"Of" ++ show m ordinal :: Int -> String ordinal n | n <= 20 = ordinals!!n ordinal n | otherwise = "Choice"++show n ordinals :: [String] ordinals = ["Zero","One","Two","Three","Four","Five","Six","Seven","Eight" ,"Nine","Ten","Eleven","Twelve","Thirteen","Fourteen","Fifteen" ,"Sixteen","Seventeen","Eighteen","Nineteen","Twenty"] ---- variable names ---- variables :: [String] variables = [ v:[] | v <- ['a'..'y']] ++ [ v:w:[] | v <- ['a'..'z'], w <- ['a'..'z']] ---- simple pretty-printing ---- format :: Int -- current position on page -> Int -- maximum width of page -> Int -- amount to indent when a newline is emitted -> String -- text to precede first value -> String -- text to precede subsequent values -> [String] -- list of values to format -> String format _cur _max _ind _s0 _s1 [] = "" format cur max ind s0 s1 (x:xs) | sameline < max = s0 ++ x ++ format sameline max ind s1 s1 xs | otherwise = "\n" ++ replicate ind ' ' ++ s0 ++ x ++ format newline max ind s1 s1 xs where sameline = cur + length s0 + length x newline = ind + length s0 + length x ---- safe integer parsing ---- saferead :: String -> IO Int saferead s | all isDigit s = return (read s) saferead s | otherwise = error ("expected a number on the commandline, " ++"but got \""++s++"\" instead") HaXml-1.23.3/src/tools/Validate.hs0000755000062000006210000000147011767644706016114 0ustar 1341796mkpasswdmodule Main where import System.IO import Data.Maybe (fromJust) import Text.XML.HaXml.Types (Document(..)) import Text.XML.HaXml.Parse (xmlParse,dtdParse) import Text.XML.HaXml.Validate (validate) import Text.XML.HaXml.Wrappers (fix2Args) -- This is a fairly trivial application that reads a DTD from a file, -- an XML document from another file (or stdin), and writes any validation -- errors to stdout. main :: IO () main = do (dtdf,xmlf) <- fix2Args dtdtext <- ( if dtdf=="-" then error "Usage: validate dtdfile [xmlfile]" else readFile dtdf ) content <- ( if xmlf=="-" then getContents else readFile xmlf ) let dtd = dtdParse dtdf dtdtext Document _ _ xml _ = xmlParse xmlf content errs = validate (fromJust dtd) xml mapM_ putStrLn errs hFlush stdout HaXml-1.23.3/src/tools/XsdToHaskell.hs0000755000062000006210000001143511767644706016732 0ustar 1341796mkpasswd-- XsdToHaskell module Main where -- This program is designed to convert an XML file containing an XSD -- decl into a Haskell module containing data/newtype definitions which -- mirror the XSD. Once you have used this program to generate your type -- definitions, you should import Xsd2Haskell wherever you intend -- to read and write XML files with your Haskell programs. import System.Environment import System.Exit import System.IO import Control.Monad --import Data.Either --import Text.XML.HaXml.Wrappers (fix2Args) import Text.XML.HaXml (version) import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces (resolveAllNames,qualify ,nullNamespace) import Text.XML.HaXml.Parse (xmlParse') import Text.XML.HaXml.Util (docContent) import Text.XML.HaXml.Posn (posInNewCxt) import Text.XML.HaXml.Schema.Parse import Text.XML.HaXml.Schema.Environment import Text.XML.HaXml.Schema.NameConversion import Text.XML.HaXml.Schema.TypeConversion import Text.XML.HaXml.Schema.PrettyHaskell import qualified Text.XML.HaXml.Schema.HaskellTypeModel as Haskell import Text.ParserCombinators.Poly import Text.PrettyPrint.HughesPJ (render,vcat) -- sucked in from Text.XML.HaXml.Wrappers to avoid dependency on T.X.H.Html fix2Args :: IO (String,String) fix2Args = do args <- getArgs when ("--version" `elem` args) $ do putStrLn $ "part of HaXml-"++version exitWith ExitSuccess when ("--help" `elem` args) $ do putStrLn $ "See http://haskell.org/HaXml" exitWith ExitSuccess case length args of 0 -> return ("-", "-") 1 -> return (args!!0, "-") 2 -> return (args!!0, args!!1) _ -> do prog <- getProgName putStrLn ("Usage: "++prog++" [xmlfile] [outfile]") exitFailure main ::IO () main = fix2Args >>= \(inf,outf)-> ( if inf=="-" then getContents else readFile inf ) >>= \thiscontent-> ( if outf=="-" then return stdout else openFile outf WriteMode ) >>= \o-> let d@Document{} = resolveAllNames qualify . either (error . ("not XML:\n"++)) id . xmlParse' inf $ thiscontent in do case runParser schema [docContent (posInNewCxt inf Nothing) d] of (Left msg,_) -> hPutStrLn stderr msg (Right v,[]) -> do hPutStrLn stdout $ "Parse Success!" hPutStrLn stdout $ "\n-----------------\n" hPutStrLn stdout $ show v hPutStrLn stdout $ "\n-----------------\n" let decls = convert (mkEnvironment inf v emptyEnv) v haskl = Haskell.mkModule inf v decls doc = ppModule simpleNameConverter haskl hPutStrLn stdout $ render doc (Right v,_) -> do hPutStrLn stdout $ "Parse incomplete!" hPutStrLn stdout $ "\n-----------------\n" hPutStrLn stdout $ show v hPutStrLn stdout $ "\n-----------------\n" hFlush o --do hPutStrLn o $ "Document contains XSD for target namespace "++ -- targetNamespace e {- let (DTD name _ markup) = (getDtd . dtdParse inf) content decls = (nub . dtd2TypeDef) markup realname = if outf/="-" then mangle (trim outf) else if null (localName name) then mangle (trim inf) else mangle (localName name) in do hPutStrLn o ("module "++realname ++" where\n\nimport Text.XML.HaXml.XmlContent" ++"\nimport Text.XML.HaXml.OneOfN") -- ++"\nimport Char (isSpace)" -- ++"\nimport List (isPrefixOf)" hPutStrLn o "\n\n{-Type decls-}\n" (hPutStrLn o . render . vcat . map ppTypeDef) decls hPutStrLn o "\n\n{-Instance decls-}\n" mapM_ (hPutStrLn o . (++"\n") . render . mkInstance) decls hPutStrLn o "\n\n{-Done-}" hFlush o -} {- getDtd :: Maybe t -> t getDtd (Just dtd) = dtd getDtd (Nothing) = error "No DTD in this document" trim :: [Char] -> [Char] trim name | '/' `elem` name = (trim . tail . dropWhile (/='/')) name | '.' `elem` name = takeWhile (/='.') name | otherwise = name -} targetNamespace :: Element i -> String targetNamespace (Elem qn attrs _) = if qn /= xsdSchema then "ERROR! top element not an xsd:schema tag" else case lookup (N "targetNamespace") attrs of Nothing -> "ERROR! no targetNamespace specified" Just atv -> show atv xsdSchema :: QName xsdSchema = QN (nullNamespace{nsURI="http://www.w3.org/2001/XMLSchema"}) "schema" -- HaXml-1.23.3/src/tools/Xtract.hs0000755000062000006210000001013111767644706015622 0ustar 1341796mkpasswd------------------------------------------------------------ -- The Xtract tool - an XML-grep. ------------------------------------------------------------ module Main where import System.Environment (getArgs) import System.Exit (exitWith, ExitCode(..)) import System.IO import Data.Char (toLower) import Data.List (isSuffixOf) import Control.Monad (when) import System.Console.GetOpt import Text.XML.HaXml (version) import Text.XML.HaXml.Types import Text.XML.HaXml.Posn (posInNewCxt) import qualified Text.XML.HaXml.Parse (xmlParse) import qualified Text.XML.HaXml.Html.Parse (htmlParse) import Text.XML.HaXml.Xtract.Parse (xtract) import qualified Text.XML.HaXml.ParseLazy (xmlParse) import qualified Text.XML.HaXml.Html.ParseLazy (htmlParse) import Text.PrettyPrint.HughesPJ (Doc,render, vcat, hcat, empty) import Text.XML.HaXml.Pretty (content) import Text.XML.HaXml.Html.Generate (htmlprint) import Text.XML.HaXml.Escape (xmlEscapeContent,stdXmlEscaper) import Text.XML.HaXml.Util (docContent) escape :: [Content i] -> [Content i] escape = xmlEscapeContent stdXmlEscaper data Opts = Opts {doEscaping :: Bool, forceHtml :: Bool, printHelp :: Bool, printVersion :: Bool, beLazy :: Bool} defaultOptions = Opts {doEscaping = True, forceHtml = False, printHelp = False, printVersion = False, beLazy = False} options :: [OptDescr (Opts -> Opts)] options = [ Option ['n'] [] (NoArg (\o -> o {doEscaping = False})) "Do not escape output", Option [] ["html"] (NoArg (\o -> o {forceHtml = True})) "Force HTML mode", Option [] ["help"] (NoArg (\o -> o {printHelp = True})) "Displays this help", Option [] ["version"] (NoArg (\o -> o {printVersion = True})) "Prints version", Option ['l'] ["lazy"] (NoArg (\o -> o {beLazy = True})) "Parse lazily" ] main :: IO () main = do preArgs <- getArgs let (preOpts, args, errs) = getOpt Permute options preArgs let opts = foldl (flip ($)) defaultOptions preOpts when (printVersion opts) $ do putStrLn $ "part of HaXml-"++version exitWith ExitSuccess when (printHelp opts) $ do putStrLn $ "See http://haskell.org/HaXml" exitWith ExitSuccess when (length args < 1) $ do putStrLn $ usageInfo "Usage: Xtract [options] [xmlfile ...]" options exitWith (ExitFailure 1) let (xmlParse, htmlParse) = if beLazy opts then (Text.XML.HaXml.ParseLazy.xmlParse, Text.XML.HaXml.Html.ParseLazy.htmlParse) else (Text.XML.HaXml.Parse.xmlParse, Text.XML.HaXml.Html.Parse.htmlParse) let (pattern,files,esc) = (head args,tail args,if doEscaping opts then escape .(:[]) else (:[])) -- findcontents = -- if null files then (getContents >>= \x-> return [xmlParse ""x]) -- else mapM (\x-> do c <- (if x=="-" then getContents else readFile x) -- return ((if isHTML x -- then htmlParse x else xmlParse x) c)) -- files -- findcontents >>= \cs-> -- ( hPutStrLn stdout . render . vcat -- . map (vcat . map content . selection . docContent)) cs mapM_ (\x-> do c <- (if x=="-" then getContents else readFile x) ( if isHTML x || forceHtml opts then hPutStrLn stdout . render . htmlprint . xtract (map toLower) pattern . docContent (posInNewCxt x Nothing) . htmlParse x else hPutStrLn stdout . render . vcat . map (format . esc) . xtract id pattern . docContent (posInNewCxt x Nothing) . xmlParse x) c hFlush stdout) files isHTML :: [Char] -> Bool isHTML x = ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x format :: [Content i] -> Doc format [] = empty format cs@(CString _ _ _:_) = hcat . map content $ cs format cs@(CRef _ _:_) = hcat . map content $ cs format cs = vcat . map content $ cs