HaXml-1.25.4/0000755000000000000000000000000013122420334010774 5ustar0000000000000000HaXml-1.25.4/COPYRIGHT0000644000000000000000000000250013122420334012264 0ustar0000000000000000The HaXml library and tools were written by and are copyright to (c) copyright 1998-1999 Malcolm Wallace and Colin Runciman (c) copyright 2000-2013 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.25.4/HaXml.cabal0000644000000000000000000000734013122420334012775 0ustar0000000000000000name: HaXml version: 1.25.4 license: LGPL license-file: COPYRIGHT author: Malcolm Wallace maintainer: author homepage: http://projects.haskell.org/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.8 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.Version 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.10, 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 nhc98-options: -K10M Executable Canonicalise GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools Main-Is: Canonicalise.hs build-depends: base, HaXml, pretty Executable CanonicaliseLazy GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools Main-Is: CanonicaliseLazy.hs build-depends: base, HaXml, pretty Executable Xtract GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools Main-Is: Xtract.hs build-depends: base, HaXml, pretty Executable Validate GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools Main-Is: Validate.hs build-depends: base, HaXml Executable MkOneOf GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools Main-Is: MkOneOf.hs build-depends: base, HaXml Executable DtdToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools Main-Is: DtdToHaskell.hs build-depends: base, HaXml, pretty Executable XsdToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools Main-Is: XsdToHaskell.hs build-depends: base, HaXml, pretty, polyparse, directory Executable FpMLToHaskell GHC-Options: -Wall Extensions: CPP Hs-Source-Dirs: src/tools Main-Is: FpMLToHaskell.hs build-depends: base, HaXml, pretty, polyparse, directory HaXml-1.25.4/LICENCE-GPL0000644000000000000000000004311213122420334012402 0ustar0000000000000000 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.25.4/LICENCE-LGPL0000644000000000000000000006363413122420334012531 0ustar0000000000000000 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.25.4/Setup.hs0000644000000000000000000000005613122420334012431 0ustar0000000000000000import Distribution.Simple main = defaultMain HaXml-1.25.4/src/0000755000000000000000000000000013122420334011563 5ustar0000000000000000HaXml-1.25.4/src/Text/0000755000000000000000000000000013122420334012507 5ustar0000000000000000HaXml-1.25.4/src/Text/XML/0000755000000000000000000000000013122420334013147 5ustar0000000000000000HaXml-1.25.4/src/Text/XML/HaXml.hs0000644000000000000000000000214013122420334014511 0ustar0000000000000000{-# 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.XML.HaXml.Version import Text.PrettyPrint.HughesPJ (render) HaXml-1.25.4/src/Text/XML/HaXml/0000755000000000000000000000000013122420334014160 5ustar0000000000000000HaXml-1.25.4/src/Text/XML/HaXml/ByteStringPP.hs0000644000000000000000000003552313122420334017056 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/Combinators.hs0000644000000000000000000004311213122420334016775 0ustar0000000000000000-------------------------------------------- -- | 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] -- | Recursively process an element in place. That is, the filter is -- applied to the element itself, then recursively to the results of the -- filter, all the way to the bottom, then the original element rebuilt -- around the final results. recursivelyInPlace :: CFilter i -> CFilter i recursivelyInPlace f = inplace (recursivelyInPlace f `o` f) -- | 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 -- -- $constructive -- The constructive filters are primitive filters for building new elements, -- or editing existing elements. -- | 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 _ _ = [] -- | Add the desired attribute name and value to the topmost element, -- without changing the element in any other way. addAttribute :: String -> String -> CFilter a addAttribute name val (CElem (Elem n as cs) i) = [CElem (Elem n (a:as) cs) i] where a = (N name, AttValue [Left val]) addAttribute _ _ _ = [] -- LABELLING -- $labelling -- LabelFilters are a way of annotating the results of a filter operation -- with some arbitrary values drawn from the tree values. Typically, the -- annotations are then consumed by a label-processing filter (of -- type @a -> CFilter@). This is useful way of passing information between -- sections of the tree as you process it. An example may help to explain. -- -- Let's say we want to add an attribute to every node of the tree, -- containing a textual representation of its path from the root, -- e.g. "/foo/bar/quux". Where there are multiple identically-tagged elements -- under the same parent node of the original tree, we expect them to have -- a distinguishing attribute called "name". -- -- Step one. Given the path prefix to this node, how do we add the "xpath" -- attribute? -- -- > annotateOne :: String -> CFilter a -- > annotateOne prefix = -- > (f `oo` ((tagged `x` attributed "name") (attr "name"))) -- > |>| -- > (g `oo` (tagged keep)) -- > where -- > f (tag,att) = addAttribute "xpath" (prefix++"/"++tag++"["++att++"]") -- > g tag = addAttribute "xpath" (prefix++"/"++tag)@ -- -- First, the @attr "name"@ filter distinguishes whether this node contains -- the attribute, hence choosing whether the left or right branch of the -- @|>|@ is taken. If the attribute is /not/ present, then the LabelFilter -- @tagged keep@ selects the current node, and annotates it with the -- tagname of the element. The @oo@ applies the label-consuming function @g@ -- to the result, and this injects the "xpath" attribute by suffixing -- the tagname to the known path prefix. -- -- If the "name" attribute /is/ present, then there are /two/ labelling filters -- applied to the current node, annotating it with the pair of its tag -- and the value of the attribute "name". The label-consuming function @f@ is -- applied to the pair with @oo@, to inject the "xpath" attribute with a more -- complex representation of its path. -- -- Step two. Recursively apply the annotation throughout the tree. -- -- > labelAllPaths :: CFilter a -- > labelAllPaths = allPaths `o` initialise -- > where -- > initialise = annotateOne "/" -- > -- > allPaths :: CFilter a -- > allPaths = inplace ( allPaths -- > `o` -- > (\prefix-> annotateOne prefix `o` children) -- > `oo` -- > (attributed "xpath" keep) -- > ) -- -- In order to apply @annotateOne@ to any node, we need to know the path -- prefix thus far into the tree. So, we read the "xpath" attribute from -- the current node (assumed to have already been processed) as a -- LabelFilter, then consume the label by passing it to @annotateOne@ on -- the children of the current node. Using @inplace@ rebuilds the processed -- children into the current node, after recursively dealing with their -- children. -- | 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.25.4/src/Text/XML/HaXml/Escape.hs0000644000000000000000000002350113122420334015715 0ustar0000000000000000{- 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.25.4/src/Text/XML/HaXml/Lex.hs0000644000000000000000000003633113122420334015252 0ustar0000000000000000-- | 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 | tok==TokSemi && length acc >= 8 -- special case for repairing broken & = emit (TokFreeText "amp") pos: emit tok pos: k (addcol 1 pos) (reverse acc++s:ss) | 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 "":tale w)) | otherwise = emit TokAnyOpen p: skip 1 p s (xmlTag (InTag "<...>":NotInTag:w)) where tale [] = [NotInTag] -- cope with non-well-formed input tale xs = tail xs 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.25.4/src/Text/XML/HaXml/Namespaces.hs0000644000000000000000000002033313122420334016574 0ustar0000000000000000{-# 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.25.4/src/Text/XML/HaXml/OneOfN.hs0000644000000000000000000013044113122420334015643 0ustar0000000000000000module 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.25.4/src/Text/XML/HaXml/Parse.hs0000644000000000000000000007471113122420334015600 0ustar0000000000000000{-# 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 ---- -- | 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 bracket (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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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)-> debugShowCP 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 bracket (tok TokBraOpen `debug` "Trying choice") (blank (tok TokBraClose `debug` "Succeeded with choice")) (peRef cp `sepBy1` blank (tok TokPipe)) sequence :: XParser [CP] sequence = do bracket (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 "++debugShowCP c)) , ( do ss <- sequence m <- modifier let c = Seq ss m return c `debug` ("ContentSpec: sequence "++debugShowCP c)) , ( do cs <- choice m <- modifier let c = Choice cs m return c `debug` ("ContentSpec: choice "++debugShowCP 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 debugShowCP :: CP -> String debugShowCP cp = case cp of TagName n m -> printableName n++debugShowModifier m Choice cps m -> '(': concat (intersperse "|" (map debugShowCP cps))++")"++debugShowModifier m Seq cps m -> '(': concat (intersperse "," (map debugShowCP cps))++")"++debugShowModifier m debugShowModifier :: Modifier -> String debugShowModifier modifier = case modifier of None -> "" Query -> "?" Star -> "*" 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) (commit $ blank $ tok TokBraClose) (peRef name `sepBy1` peRef (tok TokPipe)) enumeration :: XParser Enumeration enumeration = bracket (tok TokBraOpen) (commit $ 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 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) (commit $ tok TokSemi) name charref :: XParser CharRef charref = do bracket (tok TokAmp) (commit $ 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 bracket (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) (commit $ 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) (commit $ 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) (commit $ tok TokQuote) (many (either freetext reference)) return (AttValue avs) systemliteral :: XParser SystemLiteral systemliteral = do s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (SystemLiteral s) -- note: refs &...; not permitted pubidliteral :: XParser PubidLiteral pubidliteral = do s <- bracket (tok TokQuote) (commit $ 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.25.4/src/Text/XML/HaXml/ParseLazy.hs0000644000000000000000000007552513122420334016444 0ustar0000000000000000-- | 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 ---- -- | 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 bracket (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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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)-> debugShowCP 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 bracket (tok TokBraOpen `debug` "Trying choice") (blank (tok TokBraClose `debug` "Succeeded with choice")) (peRef cp `sepBy1` blank (tok TokPipe)) sequence :: XParser [CP] sequence = do bracket (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 "++debugShowCP c)) , ( do ss <- sequence m <- modifier let c = Seq ss m return c `debug` ("ContentSpec: sequence "++debugShowCP c)) , ( do cs <- choice m <- modifier let c = Choice cs m return c `debug` ("ContentSpec: choice "++debugShowCP 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 debugShowCP :: CP -> String debugShowCP cp = case cp of TagName n m -> printableName n++debugShowModifier m Choice cps m -> '(': concat (intersperse "|" (map debugShowCP cps))++")"++debugShowModifier m Seq cps m -> '(': concat (intersperse "," (map debugShowCP cps))++")"++debugShowModifier m debugShowModifier :: Modifier -> String debugShowModifier modifier = case modifier of None -> "" Query -> "?" Star -> "*" 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) (commit $ blank $ tok TokBraClose) (peRef name `sepBy1` peRef (tok TokPipe)) enumeration :: XParser Enumeration enumeration = bracket (tok TokBraOpen) (commit $ 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) (commit $ 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) (commit $ tok TokSemi) name charref :: XParser CharRef charref = do bracket (tok TokAmp) (commit $ 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 bracket (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) (commit $ 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) (commit $ 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) (commit $ tok TokQuote) (many (either freetext reference)) return (AttValue avs) systemliteral :: XParser SystemLiteral systemliteral = do s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (SystemLiteral s) -- note: refs &...; not permitted pubidliteral :: XParser PubidLiteral pubidliteral = do s <- bracket (tok TokQuote) (commit $ 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.25.4/src/Text/XML/HaXml/Posn.hs0000644000000000000000000000504513122420334015437 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/Pretty.hs0000644000000000000000000002740113122420334016007 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/SAX.hs0000644000000000000000000000635713122420334015162 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/TypeMapping.hs0000644000000000000000000003361613122420334016762 0ustar0000000000000000module 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.25.4/src/Text/XML/HaXml/Types.hs0000644000000000000000000002347013122420334015626 0ustar0000000000000000{- | 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, Show) data Prolog = Prolog (Maybe XMLDecl) [Misc] (Maybe DocTypeDecl) [Misc] deriving (Eq, Show) data XMLDecl = XMLDecl VersionInfo (Maybe EncodingDecl) (Maybe SDDecl) deriving (Eq, Show) data Misc = Comment Comment | PI ProcessingInstruction deriving (Eq, Show) 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, Show) data MarkupDecl = Element ElementDecl | AttList AttListDecl | Entity EntityDecl | Notation NotationDecl | MarkupMisc Misc deriving (Eq, Show) data ExtSubset = ExtSubset (Maybe TextDecl) [ExtSubsetDecl] deriving (Eq, Show) data ExtSubsetDecl = ExtMarkupDecl MarkupDecl | ExtConditionalSect ConditionalSect deriving (Eq, Show) data Element i = Elem QName [Attribute] [Content i] deriving (Eq, Show) -- 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 deriving Show -- 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, Show) data ContentSpec = EMPTY | ANY | Mixed Mixed | ContentSpec CP deriving (Eq, Show) data CP = TagName QName Modifier | Choice [CP] Modifier | Seq [CP] Modifier deriving (Eq, Show) data Modifier = None -- ^ Just One | Query -- ^ Zero Or One | Star -- ^ Zero Or More | Plus -- ^ One Or More deriving (Eq, Show) data Mixed = PCDATA | PCDATAplus [QName] deriving (Eq, Show) data AttListDecl = AttListDecl QName [AttDef] deriving (Eq, Show) data AttDef = AttDef QName AttType DefaultDecl deriving (Eq, Show) data AttType = StringType | TokenizedType TokenizedType | EnumeratedType EnumeratedType deriving (Eq, Show) data TokenizedType = ID | IDREF | IDREFS | ENTITY | ENTITIES | NMTOKEN | NMTOKENS deriving (Eq, Show) data EnumeratedType = NotationType NotationType | Enumeration Enumeration deriving (Eq, Show) type NotationType = [Name] -- nonempty list type Enumeration = [NmToken] -- nonempty list data DefaultDecl = REQUIRED | IMPLIED | DefaultTo AttValue (Maybe FIXED) deriving (Eq, Show) data FIXED = FIXED deriving (Eq, Show) data ConditionalSect = IncludeSect IncludeSect | IgnoreSect IgnoreSect deriving (Eq, Show) type IncludeSect = [ExtSubsetDecl] type IgnoreSect = [IgnoreSectContents] data Ignore = Ignore deriving (Eq, Show) data IgnoreSectContents = IgnoreSectContents Ignore [(IgnoreSectContents,Ignore)] deriving (Eq, Show) 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, Show) data GEDecl = GEDecl Name EntityDef deriving (Eq, Show) data PEDecl = PEDecl Name PEDef deriving (Eq, Show) data EntityDef = DefEntityValue EntityValue | DefExternalID ExternalID (Maybe NDataDecl) deriving (Eq, Show) 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, Show) data TextDecl = TextDecl (Maybe VersionInfo) EncodingDecl deriving (Eq, Show) data ExtParsedEnt i = ExtParsedEnt (Maybe TextDecl) (Content i) deriving (Eq, Show) data ExtPE = ExtPE (Maybe TextDecl) [ExtSubsetDecl] deriving (Eq, Show) data NotationDecl = NOTATION Name (Either ExternalID PublicID) deriving (Eq, Show) newtype PublicID = PUBLICID PubidLiteral deriving (Eq, Show) newtype EncodingDecl = EncodingDecl String deriving (Eq, Show) -- | 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.25.4/src/Text/XML/HaXml/Util.hs0000644000000000000000000000267113122420334015437 0ustar0000000000000000{- | - 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.25.4/src/Text/XML/HaXml/Validate.hs0000644000000000000000000003154013122420334016250 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/Verbatim.hs0000644000000000000000000000754713122420334016302 0ustar0000000000000000{- | 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.25.4/src/Text/XML/HaXml/Version.hs0000644000000000000000000000013313122420334016136 0ustar0000000000000000module Text.XML.HaXml.Version ( version ) where version :: String version = "1.25.4" HaXml-1.25.4/src/Text/XML/HaXml/Wrappers.hs0000644000000000000000000000642313122420334016324 0ustar0000000000000000{-# 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.XML.HaXml.Version 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-" ++ version exitWith ExitSuccess when ("--help" `elem` args) $ do putStrLn $ "See http://projects.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.25.4/src/Text/XML/HaXml/XmlContent.hs0000644000000000000000000001566713122420334016626 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/DtdToHaskell/0000755000000000000000000000000013122420334016502 5ustar0000000000000000HaXml-1.25.4/src/Text/XML/HaXml/DtdToHaskell/Convert.hs0000644000000000000000000001311313122420334020455 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/DtdToHaskell/Instance.hs0000644000000000000000000004104413122420334020605 0ustar0000000000000000module 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.25.4/src/Text/XML/HaXml/DtdToHaskell/TypeDef.hs0000644000000000000000000002104513122420334020400 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/Html/0000755000000000000000000000000013122420334015064 5ustar0000000000000000HaXml-1.25.4/src/Text/XML/HaXml/Html/Generate.hs0000644000000000000000000001306313122420334017155 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/Html/Parse.hs0000644000000000000000000005743513122420334016510 0ustar0000000000000000-- | 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)) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ tok TokSemi) name return n charref :: HParser CharRef charref = do bracket (tok TokAmp) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ tok TokQuote) freetext return (SystemLiteral s) -- note: need to fold &...; escapes pubidliteral :: HParser PubidLiteral pubidliteral = do s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (PubidLiteral s) -- note: need to fold &...; escapes chardata :: HParser CharData chardata = freetext -- >>= return . CharData HaXml-1.25.4/src/Text/XML/HaXml/Html/ParseLazy.hs0000644000000000000000000005773113122420334017347 0ustar0000000000000000-- | 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)) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ tok TokBraClose) -- (name `sepby1` (tok TokPipe)) -- --enumeration :: HParser Enumeration --enumeration = -- bracket (tok TokBraOpen) (commit $ 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) (commit $ tok TokSemi) name return n charref :: HParser CharRef charref = do bracket (tok TokAmp) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ 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) (commit $ tok TokQuote) freetext return (SystemLiteral s) -- note: need to fold &...; escapes pubidliteral :: HParser PubidLiteral pubidliteral = do s <- bracket (tok TokQuote) (commit $ tok TokQuote) freetext return (PubidLiteral s) -- note: need to fold &...; escapes chardata :: HParser CharData chardata = freetext -- >>= return . CharData HaXml-1.25.4/src/Text/XML/HaXml/Html/Pretty.hs0000644000000000000000000002674313122420334016723 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/Schema/0000755000000000000000000000000013122420334015360 5ustar0000000000000000HaXml-1.25.4/src/Text/XML/HaXml/Schema/Environment.hs0000644000000000000000000002377713122420334020240 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} module Text.XML.HaXml.Schema.Environment ( module Text.XML.HaXml.Schema.Environment ) where import Text.XML.HaXml.Types (QName(..),Name(..),Namespace(..)) import Text.XML.HaXml.Schema.XSDTypeModel import Text.XML.HaXml.Schema.NameConversion (wordsBy) import Text.XML.HaXml.Schema.Parse (targetPrefix) import qualified Data.Map as Map import Data.Map (Map) import Data.List (foldl') -- Some things we probably want to do. -- * Build Maps from : -- typename to definition -- element name to definition -- attribute name to definition -- (element) group to definition -- attribute group to definition -- abstract complextype to its extension types -- substitution group to its substitutable elements -- abstract/substGroup to defining module -- * XSD types become top-level types in Haskell. -- * XSD element decls also become top-level types in Haskell. -- * Element groups get their own Haskell types too. -- * Attributes and attribute groups do not become types, they are -- simply constituent parts of an element. -- * Resolve element/attribute references by inlining their names. -- If a complextype definition includes nested in-line decls of other -- types, we need to be able to lift them out to the top-level, then -- refer to them by name only at the nested position(?) -- When dealing with sub/supertype relationships, we often need to know all -- of the subtypes of a supertype before some of the subtypes are actually -- available in scope. The environment must therefore first be closed -- over all modules: the resulting type mapping (env_type) should be _copied_ -- across to (env_allTypes) in a fresh initial environment, which latter is -- then used to rebuild the local scope from scratch. -- Likewise, the mappings from supertype->subtype (env_extendty) and for -- substitution groups (env_substGrp) also need to be global. data Environment = Environment { env_type :: Map QName (Either SimpleType ComplexType) -- ^ type definitions in scope , env_allTypes :: Map QName (Either SimpleType ComplexType) -- ^ all type definitions, regardless of scope , env_element :: Map QName ElementDecl , env_attribute :: Map QName AttributeDecl , env_group :: Map QName Group , env_attrgroup :: Map QName AttrGroup , env_namespace :: Map String{-URI-} String{-Prefix-} , env_extendty :: Map QName [(QName,FilePath)] -- ^ supertype -> subtypes , env_substGrp :: Map QName [(QName,FilePath)] -- ^ substitution groups , env_typeloc :: Map QName FilePath -- ^ where type is defined } -- | An empty environment of XSD type mappings. emptyEnv :: Environment emptyEnv = Environment Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty -- | Combine two environments (e.g. read from different interface files) combineEnv :: Environment -> Environment -> Environment combineEnv e1 e0 = Environment { env_type = Map.union (env_type e1) (env_type e0) , env_allTypes = Map.union (env_allTypes e1) (env_allTypes e0) , env_element = Map.union (env_element e1) (env_element e0) , env_attribute = Map.union (env_attribute e1) (env_attribute e0) , env_group = Map.union (env_group e1) (env_group e0) , env_attrgroup = Map.union (env_attrgroup e1) (env_attrgroup e0) , env_namespace = Map.union (env_namespace e1) (env_namespace e0) , env_extendty = Map.unionWith (++) (env_extendty e1) (env_extendty e0) , env_substGrp = Map.unionWith (++) (env_substGrp e1) (env_substGrp e0) , env_typeloc = Map.union (env_typeloc e1) (env_typeloc e0) } -- | Build an environment of XSD type mappings from a schema module. mkEnvironment :: FilePath -> Schema -> Environment -> Environment mkEnvironment fp s init = foldl' item (addNS init (schema_namespaces s)) (schema_items s) where -- think about qualification, w.r.t targetNamespace, elementFormDefault, etc item env (Include _ _) = env item env (Import _ _ _) = env item env (Redefine _ _) = env -- revisit this item env (Annotation _) = env item env (Simple st) = simple env st item env (Complex ct) = complex env ct item env (SchemaElement e) = elementDecl env e item env (SchemaAttribute a) = attributeDecl env a item env (AttributeGroup g) = attrGroup env g item env (SchemaGroup g) = group env g simple env s@(Restricted _ (Just n) _ _) = env{env_type=Map.insert (mkN n) (Left s) (env_type env)} simple env s@(ListOf _ (Just n) _ _) = env{env_type=Map.insert (mkN n) (Left s) (env_type env)} simple env s@(UnionOf _ (Just n) _ _ _) = env{env_type=Map.insert (mkN n) (Left s) (env_type env)} simple env _ = env -- Only toplevel names have global scope. -- Should we lift local names to toplevel with prefixed names? -- Or thread the environment explicitly through every tree-walker? -- Or resolve every reference to its referent in a single resolution pass? -- (Latter not good, because it potentially duplicates exprs?) complex env c | Nothing <- complex_name c = env | Just n <- complex_name c = either (const id) (\extn env-> env{env_extendty = Map.insertWith (++) (extension_base extn) [(mkN n, fp)] (env_extendty env)}) (isExtn (complex_content c)) $ (if complex_abstract c then \env-> -- because an abstract type might have no concrete instantiations! env{env_extendty = Map.insertWith (++) (mkN n) [] (env_extendty env)} else id) $ env{env_type=Map.insert (mkN n) (Right c) (env_type env) ,env_typeloc=Map.insert (mkN n) fp (env_typeloc env)} where isExtn x@SimpleContent{} = ci_stuff x isExtn x@ComplexContent{} = ci_stuff x isExtn x@ThisType{} = Left undefined {- | Nothing <- complex_name c = env | Right extn <- isExtn $ complex_content c , Just n <- complex_name c = env{env_extendty = Map.insertWith (++) (extension_base extn) [(mkN n, isFwd)] (env_extendty env) ,env_type=Map.insert (mkN n) (Right c) (env_type env)} | Just n <- complex_name c = env{env_type=Map.insert (mkN n) (Right c) (env_type env)} where isExtn x@SimpleContent{} = ci_stuff x isExtn x@ComplexContent{} = ci_stuff x isExtn x@ThisType{} = Left undefined isFwd = case Map.lookup (extension_base extn) (env_typeloc env) of Nothing -> error $ "unknown supertype of "++show c Just mod -> mod /= fp -} elementDecl env e | Right r <- elem_nameOrRef e = env -- | Just sg <- elem_substGroup e -- , Left nt <- elem_nameOrRef e = env{env_substGrp=Map.insertWith (++) sg -- [(mkN $ theName nt, isFwd sg)] -- (env_substGrp env) -- ,env_element=Map.insert -- (mkN $ theName nt) e -- (env_element env)} | Left nt <- elem_nameOrRef e = maybe id (\sg env-> env{env_substGrp=Map.insertWith (++) sg [(mkN $ theName nt, fp)] (env_substGrp env)}) (elem_substGroup e) $ env{env_element=Map.insert (mkN $ theName nt) e (env_element env) ,env_typeloc=Map.insert (mkN $ theName nt) fp (env_typeloc env)} attributeDecl env a | Right r <- attr_nameOrRef a = env | Left nt <- attr_nameOrRef a = env{env_attribute= Map.insert (mkN $ theName nt) a (env_attribute env)} attrGroup env g | Right r <- attrgroup_nameOrRef g = env | Left n <- attrgroup_nameOrRef g = env{env_attrgroup=Map.insert (mkN n) g (env_attrgroup env)} group env g | Right r <- group_nameOrRef g = env | Left n <- group_nameOrRef g = env{env_group=Map.insert (mkN n) g (env_group env)} mkN = N . last . wordsBy (==':') addNS env nss = env{env_namespace = foldr newNS (env_namespace env) nss} where newNS ns env = Map.insert (nsURI ns) (nsPrefix ns) env -- | Find all direct module dependencies. gatherImports :: Schema -> [(FilePath, Maybe String)] gatherImports s = [ (f,Nothing) | (Include f _) <- schema_items s ] ++ [ (f,ns) | (Import uri f _) <- schema_items s , let ns = targetPrefix (Just uri) (schema_namespaces s) ] HaXml-1.25.4/src/Text/XML/HaXml/Schema/HaskellTypeModel.hs0000644000000000000000000002231213122420334021122 0ustar0000000000000000-- | A type model for Haskell datatypes that bears a reasonable correspondence -- to the XSD type model. module Text.XML.HaXml.Schema.HaskellTypeModel ( module Text.XML.HaXml.Schema.HaskellTypeModel ) where import Text.XML.HaXml.Schema.NameConversion import Text.XML.HaXml.Schema.XSDTypeModel (Schema(..),Occurs) import Text.XML.HaXml.Schema.Parse (lookupBy) import Text.XML.HaXml.Types (QName(..),Namespace(..)) import Data.List (partition) -- | Comments can be attached to most things, but not all of them will exist. type Comment = Maybe String -- | The whole Haskell module. data Module = Module { module_name :: XName -- the name of this module , module_xsd_ns :: Maybe XName -- xmlns:prefix for XSD , module_re_exports :: [Decl] -- modules imported + exported , module_import_only :: [Decl] -- module + alias , module_decls :: [Decl] -- the body of the module } -- | There are essentially simple types, and complex types, each of which -- can be either restricted or extended. There are four kinds of complex -- type: choices, sequences, named groups, or a simple element with content. data Decl -- becomes type T = S = NamedSimpleType XName XName Comment -- becomes newtype T = T S -- + instance Restricts T S where restricts ... | RestrictSimpleType XName XName [Restrict] Comment -- becomes data T = T S Tf -- + data Tf = Tf {fields} -- + instance Extension T S Tf where ... | ExtendSimpleType XName XName [Attribute] Comment -- becomes data T = Ta S0 | Tb S1 | Tc S2 | ... | UnionSimpleTypes XName [XName] Comment -- becomes data T = T_C0 | T_C1 | T_C2 | ... | EnumSimpleType XName [(XName,Comment)] Comment -- becomes data T = T { singleattr, fields } -- or data T = T { manyattr, singlefield } -- or data T = T { t_attrs :: Ta, fields } -- + data Ta = Ta { attributes } | ElementsAttrs XName [Element] [Attribute] Comment -- or if T is abstract, it becomes -- data T = T_A A -- | T_B B -- | FwdDecl fc c => T_C (fc->c) fc -- | ... -- data FwdC = FwdC -- because C is not yet in scope -- instance FwdDecl FwdC C -- later, at defn of C -- -- In fact, it is better to move the declaration of type C -- here, rather than use a FwdDecl proxy. This will require -- some patching later where C was originally declared. -- data T = T_A A -- | T_B B -- | T_C C -- but C not yet declared -- | ... -- data C = ... -- because C is not yet in scope -- -- later, at true defn site of C, omit its decl. -- -- An earlier solution was -- class T a where parseT :: String -> XMLParser a -- instance T A -- instance T B -- instance T C -- but this is incorrect because the choice between A|B|C -- rests with the input doc, not with the caller of the parser. | ElementsAttrsAbstract {-typename-}XName {-subtypes-}[(XName,Maybe XName)] -- ^ [(type name, module where declared later)] Comment -- becomes function -- elementE :: Parser T -- elementE = parseSchemaType "E" | ElementOfType Element -- or, if E is abstract, with substitutionGroup {Foo,Bar}, -- elementE = fmap T_Foo elementFoo `onFail` -- fmap T_Bar elementBar `onFail` ... | ElementAbstractOfType {-element name-}XName {-abstract type name-}XName {-substitute elems and fwddecls-} [(XName,Maybe XName)] Comment -- becomes (global) data T = E0 e0 | E1 e1 | E2 e2 | E3 e3 -- becomes (local) OneOfN e0 e1 e2 e3 | Choice XName [Element] Comment -- becomes data GroupT = GT e0 e1 e2 e3 | Group XName [Element] Comment {- -- becomes data GroupT = GT e0 e1 e2 e3 | GroupAttrs XName [Attribute] Comment -} -- becomes newtype T = T S -- + different (more restrictive) parser | RestrictComplexType XName XName Comment -- becomes data T = T {fields} -- + instance Extension T S where ... -- or when T extends an _abstract_ XSDtype S, defined in an -- earlier module, it additionally has -- instance FwdDecl FwdT T | ExtendComplexType XName XName [Element] [Attribute] [Element] [Attribute] {-FwdDecl req'd-}(Maybe XName) {-supertype abstract?-}Bool {-grandsupertypes-}[XName] Comment -- or when T is itself abstract, extending an abstract type S -- class T a where parseT :: String -> XMLParser a -- instance (T a) => S a where parseS = parseT | ExtendComplexTypeAbstract XName XName {-subtypes-}[(XName,Maybe XName)] {-FwdDecl instnc req'd-}(Maybe XName) {-grandsupertypes-}[XName] Comment -- becomes an import and re-export | XSDInclude XName Comment -- becomes an import only | XSDImport XName (Maybe XName) Comment -- a top-level annotation | XSDComment Comment deriving (Eq,Show) data Element = Element { elem_name :: XName , elem_type :: XName , elem_modifier :: Modifier , elem_byRef :: Bool , elem_locals :: [Decl] -- , elem_abstract :: Bool , elem_substs :: Maybe [XName] -- substitutable elems , elem_comment :: Comment } | OneOf { elem_oneOf :: [[Element]] , elem_modifier :: Modifier , elem_comment :: Comment } | AnyElem { elem_modifier :: Modifier , elem_comment :: Comment } | Text -- for mixed content deriving (Eq,Show) data Attribute = Attribute { attr_name :: XName , attr_type :: XName , attr_required:: Bool , attr_comment :: Comment } deriving (Eq,Show) data Modifier = Single | Optional | Range Occurs deriving (Eq,Show) -- | Restrictions on simpleType data Restrict = RangeR Occurs Comment | Pattern String{-really Regexp-} Comment | Enumeration [(String,Comment)] | StrLength Occurs Comment deriving (Eq,Show) -- | A helper for building the formal Module structure. mkModule :: String -> Schema -> [Decl] -> Module mkModule name schema decls = Module { module_name = XName $ N name , module_xsd_ns = xsdQualification (schema_namespaces schema) , module_re_exports = reexports , module_import_only = imports , module_decls = theRest } where (reexports,other) = partition xsdinclude decls (imports, theRest) = partition xsdimport other xsdinclude (XSDInclude _ _) = True xsdinclude _ = False xsdimport (XSDImport _ _ _) = True xsdimport _ = False xsdQualification nss = fmap (XName . N . nsPrefix) $ lookupBy ((==xsd).nsURI) nss where xsd = "http://www.w3.org/2001/XMLSchema" HaXml-1.25.4/src/Text/XML/HaXml/Schema/NameConversion.hs0000644000000000000000000002254313122420334020650 0ustar0000000000000000-- | A type model for Haskell datatypes that bears a reasonable correspondence -- to the XSD type model. module Text.XML.HaXml.Schema.NameConversion ( module Text.XML.HaXml.Schema.NameConversion ) where import Text.XML.HaXml.Types import Text.XML.HaXml.Namespaces import Data.Char import Data.List -- | An XName just holds the original XSD qualified name. It does not -- ensure that the string conforms to any rules of the various Haskell -- namespaces. Use a NameConverter to define how you would like names -- to be mangled. newtype XName = XName QName deriving (Eq,Show) -- | An HName is a resolved version of an XName. It should conform to -- the various namespace rules, and may already include a module -- qualifier if appropriate. newtype HName = HName String deriving Show -- | A NameConverter is a collection of functions that convert an XName -- into an HName, for various Haskell namespaces. You can define your -- own arbitrary resolver, but should ensure that you abide by the -- Haskell rules for conid, varid, etc. data NameConverter = NameConverter { modid :: XName -> HName , conid :: XName -> HName , varid :: XName -> HName , unqconid :: XName -> HName , unqvarid :: XName -> HName , fwdconid :: XName -> HName -- ^ for forward type decls , fieldid :: XName -> XName -> HName } -- | A simple default set of rules for resolving XNames into HNames. simpleNameConverter :: NameConverter simpleNameConverter = NameConverter { modid = \(XName qn)-> HName . mkConid . hierarchy $ qn , conid = \(XName qn)-> HName . mkConid . hierarchy $ qn , varid = \(XName qn)-> HName . mkVarid . last avoidKeywords . hierarchy $ qn , unqconid = \(XName qn)-> HName . mkConid . local $ qn , unqvarid = \(XName qn)-> HName . mkVarid . last avoidKeywords . local $ qn , fwdconid = \(XName qn)-> HName . ("Fwd"++) . mkConid . local $ qn , fieldid = \(XName qnt) (XName qnf)-> HName $ (mkVarid . last id . hierarchy $ qnt) ++ "_" ++ (mkVarid . last id . hierarchy $ qnf) } where hierarchy (N n) = wordsBy (==':') n hierarchy (QN ns n) = [nsPrefix ns, n] local = (:[]) . Prelude.last . hierarchy mkConid [] = "Empty" mkConid [c] | map toLower c == "string" = "Xsd.XsdString" | otherwise = first toUpper $ map escape c mkConid [m,c] | map toLower c == "string" = "Xsd.XsdString" | map toLower c == "date" = "Xsd.Date" | map toLower c == "double" = "Xsd.Double" | map toLower c == "integer" = "Xsd.Integer" | map toLower c == "boolean" = "Xsd.Boolean" | map toLower c == "decimal" = "Xsd.Decimal" | otherwise = first toUpper m++"."++first toUpper (map escape c) mkConid more = mkConid [concat more] mkVarid [v] = first toLower (map escape v) mkVarid [m,v] = first toUpper m++"."++first toLower (map escape v) first f (x:xs) | not (isAlpha x) = f 'v': x: xs | otherwise = f x: xs last f [x] = [ f x ] last f (x:xs) = x: last f xs -- | Character escapes to create a valid Haskell identifier. escape :: Char -> Char escape x | x==' ' = '_' | x=='_' = '_' | isAlphaNum x = x | otherwise = '\'' -- cleanUp = map (\c-> if not (isAlphaNum c) then '_' else c) -- | Ensure that a string does not match a Haskell keyword. avoidKeywords :: String -> String avoidKeywords s | s `elem` keywords = s++"_" | otherwise = s where keywords = [ "case", "of", "data", "default", "deriving", "do" , "forall", "foreign", "if", "then", "else", "import" , "infix", "infixl", "infixr", "instance", "let", "in" , "module", "newtype", "qualified", "type", "where" ] -- | A specialised module-name converter for FpML module names with -- multiple dashes, including version numbers, -- e.g. fpml-dividend-swaps-4-7.xsd becomes FpML.V47.Swaps.Dividend -- but fpml-posttrade-execution-4-7.xsd becomes FpML.V47.PostTrade.Execution fpml :: String -> String fpml = concat . intersperse "." -- put the dots in . ("Data":) -- root of the Haskell module namespace . rearrange -- hierarchy shuffling, dependent on names . map cap -- make into nice module names . version -- move version number to front . wordsBy (=='-') -- separate words . basename ".xsd" -- strip .xsd if present where version ws = let (last2,remain) = splitAt 2 . reverse $ ws in if all (all isDigit) last2 && length ws > 2 then head ws: ('V':concat (reverse last2)) : tail (reverse remain) else ws rearrange [a,v,"PostTrade",c] = [a,v,"PostTrade",c] rearrange [a,v,b,c] = [a,v,c,b] rearrange [a,v,b,c,d] = [a,v,d,b++c] rearrange [a,v,b,c,d,e] = [a,v,e,b++c++d] rearrange v = v cap :: String -> String cap "Fpml" = "FpML" cap "fpml" = "FpML" cap "cd" = "CD" cap "eq" = "EQ" cap "fx" = "FX" cap "ird" = "IRD" cap "posttrade" = "PostTrade" cap "pretrade" = "PreTrade" cap (c:cs) = toUpper c: cs -- | Chop a list into segments, at separators identified by the predicate. -- The separator items are discarded. wordsBy :: (a->Bool) -> [a] -> [[a]] wordsBy pred = wordsBy' pred [] where wordsBy' p [] [] = [] wordsBy' p acc [] = [reverse acc] wordsBy' p acc (c:cs) | p c = reverse acc : wordsBy' p [] (dropWhile p cs) | otherwise = wordsBy' p (c:acc) cs -- | Remove any prefix directory names, and given suffix extension. basename :: String -> String -> String basename ext = reverse . snip (reverse ext) . takeWhile (not.(`elem`"\\/")) . reverse where snip p s = if p `isPrefixOf`s then drop (length p) s else s fpmlNameConverter :: NameConverter fpmlNameConverter = simpleNameConverter { modid = (\(HName h)-> HName (fpml h)) . modid simpleNameConverter -- , conid = (\(HName h)-> case take 4 (reverse h) of -- "munE" -> HName (reverse (drop 4 (reverse h))) -- _ -> HName h ) -- . conid simpleNameConverter , fwdconid = \(XName qn)-> HName . ("Pseudo"++) . mkConId . local $ qn , fieldid = \(XName qnt) (XName qnf)-> let t = mkVarId . local $ qnt f = mkVarId . local $ qnf in HName $ if t==f then f else mkVarId (shorten (mkConId t)) ++"_"++ if t `isPrefixOf` f then mkVarId (drop (length t) f) else f } where hierarchy (N n) = wordsBy (==':') n hierarchy (QN ns n) = [nsPrefix ns, n] local = Prelude.last . hierarchy mkVarId ("id") = "ID" mkVarId (v:vs) = toLower v: map escape vs mkConId (v:vs) = toUpper v: map escape vs shorten t | length t <= 12 = t | length t < 35 = concatMap shortenWord (splitWords t) | otherwise = map toLower (head t: filter isUpper (tail t)) splitWords "" = [] splitWords (u:s) = let (w,rest) = span (not . (\c->isUpper c || c=='_')) s in (u:w) : splitWords rest shortenWord "Request" = "Req" -- some special cases shortenWord "Reference" = "Ref" shortenWord "Valuation" = "Val" shortenWord "Calendar" = "Cal" shortenWord "Absolute" = "Abs" shortenWord "Additional" = "Add" shortenWord "Business" = "Bus" shortenWord "Standard" = "Std" shortenWord "Calculation" = "Calc" shortenWord "Quotation" = "Quot" shortenWord "Information" = "Info" shortenWord "Exchange" = "Exch" shortenWord "Characteristics" = "Char" shortenWord "Multiple" = "Multi" shortenWord "Constituent" = "Constit" shortenWord "Convertible" = "Convert" shortenWord "Underlyer" = "Underly" shortenWord "Underlying" = "Underly" shortenWord "Properties" = "Props" shortenWord "Property" = "Prop" shortenWord "Affirmation" = "Affirmation" shortenWord "Affirmed" = "Affirmed" shortenWord "KnockIn" = "KnockIn" -- avoid shortening shortenWord "Knockin" = "Knockin" shortenWord "KnockOut" = "KnockOut" shortenWord "Knockout" = "Knockout" shortenWord w | length w < 8 = w -- then the general rule | otherwise = case splitAt 5 w of (pref,c:suf) | isVowel c -> pref | otherwise -> pref++[c] isVowel = (`elem` "aeiouy") HaXml-1.25.4/src/Text/XML/HaXml/Schema/Parse.hs0000644000000000000000000007002113122420334016766 0ustar0000000000000000module Text.XML.HaXml.Schema.Parse ( module Text.XML.HaXml.Schema.Parse ) where import Data.Char (isSpace) import Data.List (isPrefixOf) import Data.Monoid (Monoid(mappend)) -- import Text.ParserCombinators.Poly import Text.Parse -- for String parsers import Text.XML.HaXml.Types (Name,QName(..),Namespace(..),Attribute(..) ,Content(..),Element(..),info) import Text.XML.HaXml.Namespaces import Text.XML.HaXml.Verbatim hiding (qname) import Text.XML.HaXml.Posn import Text.XML.HaXml.Schema.XSDTypeModel as XSD import Text.XML.HaXml.XmlContent.Parser (text) -- | Lift boolean 'or' over predicates. (|||) :: (a->Bool) -> (a->Bool) -> (a->Bool) p ||| q = \v -> p v || q v -- | Qualify an ordinary name with the XSD namespace. xsd :: Name -> QName xsd name = QN Namespace{nsPrefix="xsd",nsURI="http://www.w3.org/2001/XMLSchema"} name -- | Predicate for comparing against an XSD-qualified name. (Also accepts -- unqualified names, but this is probably a bit too lax. Doing it right -- would require checking to see whether the current schema module's default -- namespace is XSD or not.) xsdTag :: String -> Content Posn -> Bool xsdTag tag (CElem (Elem qn _ _) _) = qn == xsd tag || qn == (N tag) xsdTag _ _ = False -- | We need a Parser monad for reading from a sequence of generic XML -- Contents into specific datatypes that model the structure of XSD -- descriptions. This is a specialisation of the polyparse combinators, -- fixing the input token type. type XsdParser a = Parser (Content Posn) a -- | Get the next content element, checking that it matches some criterion -- given by the predicate. -- (Skips over comments and whitespace, rejects text and refs. -- Also returns position of element.) -- The list of strings argument is for error reporting - it usually -- represents a list of expected tags. posnElementWith :: (Content Posn->Bool) -> [String] -> XsdParser (Posn,Element Posn) posnElementWith match tags = do { c <- next `adjustErr` (++" when expecting "++formatted tags) ; case c of CElem e pos | match c -> return (pos,e) CElem (Elem t _ _) pos | otherwise -> fail ("Found a <"++printableName t ++">, but expected " ++formatted tags++"\nat "++show pos) CString b s pos -- ignore blank space | not b && all isSpace s -> posnElementWith match tags | 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 -- | Get the next content element, checking that it has the required tag -- belonging to the XSD namespace. xsdElement :: Name -> XsdParser (Element Posn) xsdElement n = fmap snd (posnElementWith (xsdTag n) ["xsd:"++n]) -- | Get the next content element, whatever it is. anyElement :: XsdParser (Element Posn) anyElement = fmap snd (posnElementWith (const True) ["any element"]) -- | Grab and parse any and all children of the next element. allChildren :: XsdParser a -> XsdParser a allChildren p = do e <- anyElement interiorWith (const True) p e -- | Run an XsdParser on the child contents of the given element (i.e. not -- in the current monadic content sequence), filtering the children -- before parsing, and checking that the contents are exhausted, before -- returning the calculated value within the current parser context. interiorWith :: (Content Posn->Bool) -> XsdParser a -> Element Posn -> XsdParser a interiorWith keep (P p) (Elem e _ cs) = P $ \inp-> tidy inp $ case p (filter keep cs) of Committed r -> r f@(Failure _ _) -> f s@(Success [] _) -> s Success ds@(d:_) a | all onlyMisc ds -> Success [] a | otherwise -> Committed $ Failure ds ("Too many elements inside <" ++printableName e++"> at\n" ++show (info d)++"\n\n" ++"Found excess: " ++verbatim (take 5 ds)) where onlyMisc (CMisc _ _) = True onlyMisc (CString False s _) | all isSpace s = True onlyMisc _ = False -- | Check for the presence (and value) of an attribute in the given element. -- Absence results in failure. attribute :: QName -> TextParser a -> Element Posn -> XsdParser a attribute qn (P p) (Elem n as _) = P $ \inp-> case lookup qn as of Nothing -> Failure inp $ "attribute "++printableName qn ++" not present in <"++printableName n++">" Just atv -> tidy inp $ case p (show atv) of Committed r -> r Failure z msg -> Failure z $ "Attribute parsing failure: " ++printableName qn++"=\"" ++show atv++"\": "++msg Success [] v -> Success [] v Success xs _ -> Committed $ Failure xs $ "Attribute parsing excess text: " ++printableName qn++"=\"" ++show atv++"\":\n Excess is: " ++xs -- | Grab any attributes that declare a locally-used prefix for a -- specific namespace. namespaceAttrs :: Element Posn -> XsdParser [Namespace] namespaceAttrs (Elem _ as _) = return . map mkNamespace . filter (matchNamespace "xmlns") $ as where deQN (QN _ n) = n mkNamespace (attname,attval) = Namespace { nsPrefix = deQN attname , nsURI = verbatim attval } -- | Predicate for whether an attribute belongs to a given namespace. matchNamespace :: String -> Attribute -> Bool matchNamespace n (N m, _) = False -- (n++":") `isPrefixOf` m matchNamespace n (QN ns _, _) = n == nsPrefix ns -- | Tidy up the parsing context. tidy :: t -> Result x a -> Result t a tidy inp (Committed r) = tidy inp r tidy inp (Failure _ m) = Failure inp m tidy inp (Success _ v) = Success inp v -- | Given a URI for a targetNamespace, and a list of Namespaces, tell -- me the prefix corresponding to the targetNamespace. targetPrefix :: Maybe TargetNamespace -> [Namespace] -> Maybe String targetPrefix Nothing _ = Nothing targetPrefix (Just uri) nss = fmap nsPrefix $ lookupBy ((==uri).nsURI) nss -- | An auxiliary you might expect to find in Data.List lookupBy :: (a->Bool) -> [a] -> Maybe a lookupBy p [] = Nothing lookupBy p (y:ys) | p y = Just y | otherwise = lookupBy p ys -- | Turn a qualified attribute value (two strings) into a qualified name -- (QName), but excluding the case where the namespace prefix corresponds -- to the targetNamespace of the current schema document. qual :: Maybe TargetNamespace -> [Namespace] -> String-> String -> QName qual tn nss pre nm = case targetPrefix tn nss of Nothing -> QN thisNS nm Just p | p/=pre -> QN thisNS nm | otherwise -> N nm where thisNS = Namespace{ nsPrefix = pre , nsURI = maybe "" nsURI $ lookupBy ((==pre).nsPrefix) nss } -- Now for the real parsers. -- | Parse a Schema declaration schema = do e <- xsdElement "schema" commit $ do tn <- optional (attribute (N "targetNamespace") uri e) nss <- namespaceAttrs e return Schema `apply` (attribute (N "elementFormDefault") qform e `onFail` return Unqualified) `apply` (attribute (N "attributeFormDefault") qform e `onFail` return Unqualified) `apply` optional (attribute (xsd "finalDefault") final e) `apply` optional (attribute (xsd "blockDefault") block e) `apply` return tn `apply` optional (attribute (N "version") string e) `apply` return nss `apply` interiorWith (const True) (many (schemaItem (qual tn nss))) e -- | Parse a (possibly missing) element. annotation :: XsdParser Annotation annotation = do definiteAnnotation `onFail` return (NoAnnotation "missing") -- | Parse a definitely-occurring element. definiteAnnotation :: XsdParser Annotation definiteAnnotation = do e <- xsdElement "annotation" ( fmap Documentation $ interiorWith (xsdTag "documentation") (allChildren text) e ) `onFail` ( fmap AppInfo $ interiorWith (xsdTag "documentation") (allChildren text) e ) `onFail` ( return (NoAnnotation "failed to parse") ) -- | Parse a FormDefault attribute. qform :: TextParser QForm qform = do w <- word case w of "qualified" -> return Qualified "unqualified" -> return Unqualified _ -> failBad "Expected \"qualified\" or \"unqualified\"" -- | Parse a Final or Block attribute. final :: TextParser Final final = do w <- word case w of "restriction" -> return NoRestriction "extension" -> return NoExtension "#all" -> return AllFinal _ -> failBad $ "Expected \"restriction\" or \"extension\"" ++" or \"#all\"" block :: TextParser Block block = final -- | Parse a schema item (just under the toplevel ) schemaItem :: (String->String->QName) -> XsdParser SchemaItem schemaItem qual = oneOf' [ ("xsd:include", include) , ("xsd:import", import_) , ("xsd:redefine", (redefine qual)) , ("xsd:annotation", fmap Annotation definiteAnnotation) -- , ("xsd:simpleType", fmap Simple (simpleType qual)) , ("xsd:complexType", fmap Complex (complexType qual)) , ("xsd:element", fmap SchemaElement (elementDecl qual)) , ("xsd:attribute", fmap SchemaAttribute (attributeDecl qual)) , ("xsd:attributeGroup", fmap AttributeGroup (attributeGroup qual)) , ("xsd:group", fmap SchemaGroup (group_ qual)) -- , ("xsd:notation", notation) -- sigh , ("xs:include", include) , ("xs:import", import_) , ("xs:redefine", (redefine qual)) , ("xs:annotation", fmap Annotation definiteAnnotation) -- , ("xs:simpleType", fmap Simple (simpleType qual)) , ("xs:complexType", fmap Complex (complexType qual)) , ("xs:element", fmap SchemaElement (elementDecl qual)) , ("xs:attribute", fmap SchemaAttribute (attributeDecl qual)) , ("xs:attributeGroup", fmap AttributeGroup (attributeGroup qual)) , ("xs:group", fmap SchemaGroup (group_ qual)) -- , ("xs:notation", notation) ] -- | Parse an . include :: XsdParser SchemaItem include = do e <- xsdElement "include" commit $ return Include `apply` attribute (N "schemaLocation") uri e `apply` interiorWith (xsdTag "annotation") annotation e -- | Parse an . import_ :: XsdParser SchemaItem import_ = do e <- xsdElement "import" commit $ return Import `apply` attribute (N "namespace") uri e `apply` attribute (N "schemaLocation") uri e `apply` interiorWith (xsdTag "annotation") annotation e -- | Parse a . redefine :: (String->String->QName) -> XsdParser SchemaItem redefine q = do e <- xsdElement "redefine" commit $ return Redefine `apply` attribute (N "schemaLocation") uri e `apply` interiorWith (const True) (many (schemaItem q)) e -- | Parse a decl. simpleType :: (String->String->QName) -> XsdParser SimpleType simpleType q = do e <- xsdElement "simpleType" n <- optional (attribute (N "name") name e) f <- optional (attribute (N "final") final e) a <- interiorWith (xsdTag "annotation") annotation e commit $ interiorWith (not . xsdTag "annotation") (simpleItem n f a) e where simpleItem n f a = do e <- xsdElement "restriction" commit $ do a1 <- interiorWith (xsdTag "annotation") annotation e b <- optional (attribute (N "base") (qname q) e) r <- interiorWith (not . xsdTag "annotation") (restrictType a1 b `onFail` restriction1 a1 b) e return (Restricted a n f r) `onFail` do e <- xsdElement "list" commit $ do a1 <- interiorWith (xsdTag "annotation") annotation e t <- attribute (N "itemType") (fmap Right (qname q)) e `onFail` interiorWith (xsdTag "simpleType") (fmap Left (simpleType q)) e `adjustErr` (("Expected attribute 'itemType' or element \n" ++" inside decl.\n")++) return (ListOf (a`mappend`a1) n f t) `onFail` do e <- xsdElement "union" commit $ do a1 <- interiorWith (xsdTag "annotation") annotation e ts <- interiorWith (xsdTag "simpleType") (many (simpleType q)) e ms <- attribute (N "memberTypes") (many (qname q)) e `onFail` return [] return (UnionOf (a`mappend`a1) n f ts ms) `adjustErr` ("xsd:simpleType does not contain a restriction, list, or union\n"++) restriction1 a b = return (RestrictSim1 a b) `apply` (return Restriction1 `apply` particle q) restrictType a b = return (RestrictType a b) `apply` (optional (simpleType q)) `apply` many1 aFacet aFacet :: XsdParser Facet aFacet = foldr onFail (fail "Could not recognise simpleType Facet") (zipWith facet ["minInclusive","minExclusive","maxInclusive" ,"maxExclusive","totalDigits","fractionDigits" ,"length","minLength","maxLength" ,"enumeration","whiteSpace","pattern"] [OrderedBoundsMinIncl,OrderedBoundsMinExcl ,OrderedBoundsMaxIncl,OrderedBoundsMaxExcl ,OrderedNumericTotalDigits ,OrderedNumericFractionDigits ,UnorderedLength,UnorderedMinLength ,UnorderedMaxLength,UnorderedEnumeration ,UnorderedWhitespace,UnorderedPattern]) facet :: String -> FacetType -> XsdParser Facet facet s t = do e <- xsdElement s v <- attribute (N "value") string e f <- attribute (N "fixed") bool e `onFail` return False -- XXX check this a <- interiorWith (const True) annotation e return (Facet t a v f) -- | Parse a decl. complexType :: (String->String->QName) -> XsdParser ComplexType complexType q = do e <- xsdElement "complexType" commit $ return ComplexType `apply` interiorWith (xsdTag "annotation") annotation e `apply` optional (attribute (N "name") string e) `apply` (attribute (N "abstract") bool e `onFail` return False) `apply` optional (attribute (N "final") final e) `apply` optional (attribute (N "block") block e) `apply` (attribute (N "mixed") bool e `onFail` return False) `apply` interiorWith (not . xsdTag "annotation") (complexItem q) e -- | Parse the alternative contents of a decl. complexItem :: (String->String->QName) -> XsdParser ComplexItem complexItem q = ( do e <- xsdElement "simpleContent" commit $ return SimpleContent `apply` interiorWith (xsdTag "annotation") annotation e `apply` interiorWith (not.xsdTag "annotation") stuff e ) `onFail` ( do e <- xsdElement "complexContent" commit $ return ComplexContent `apply` interiorWith (xsdTag "annotation") annotation e `apply` (attribute (N "mixed") bool e `onFail` return False) `apply` interiorWith (not.xsdTag "annotation") stuff e ) `onFail` ( do fmap ThisType $ particleAttrs q ) where stuff :: XsdParser (Either Restriction1 Extension) stuff = ( do e <- xsdElement "restriction" commit $ fmap Left $ return Restriction1 `apply` particle q ) `onFail` ( do e <- xsdElement "extension" commit $ fmap Right $ return Extension `apply` interiorWith (xsdTag "annotation") annotation e `apply` attribute (N "base") (qname q) e `apply` interiorWith (not.xsdTag "annotation") (particleAttrs q) e ) -- | Parse a particle decl. particle :: (String->String->QName) -> XsdParser Particle particle q = optional (fmap Left (choiceOrSeq q) `onFail` fmap Right (group_ q)) -- | Parse a particle decl with optional attributes. particleAttrs :: (String->String->QName) -> XsdParser ParticleAttrs particleAttrs q = return PA `apply` particle q `apply` many (fmap Left (attributeDecl q) `onFail` fmap Right (attributeGroup q)) `apply` optional anyAttr -- | Parse an , , or decl. choiceOrSeq :: (String->String->QName) -> XsdParser ChoiceOrSeq choiceOrSeq q = do e <- xsdElement "all" commit $ return All `apply` interiorWith (xsdTag "annotation") annotation e `apply` interiorWith (not.xsdTag "annotation") (many (elementDecl q)) e `onFail` do e <- xsdElement "choice" commit $ return Choice `apply` interiorWith (xsdTag "annotation") annotation e `apply` occurs e `apply` interiorWith (not.xsdTag "annotation") (many (elementEtc q)) e `onFail` do e <- xsdElement "sequence" commit $ return Sequence `apply` interiorWith (xsdTag "annotation") annotation e `apply` occurs e `apply` interiorWith (not.xsdTag "annotation") (many (elementEtc q)) e -- | Parse a decl. group_ :: (String->String->QName) -> XsdParser Group group_ q = do e <- xsdElement "group" commit $ return Group `apply` interiorWith (xsdTag "annotation") annotation e `apply` (fmap Left (attribute (N "name") string e) `onFail` fmap Right (attribute (N "ref") (qname q) e)) `apply` occurs e `apply` interiorWith (not.xsdTag "annotation") (optional (choiceOrSeq q)) e -- | Parse an , , , , -- or . elementEtc :: (String->String->QName) -> XsdParser ElementEtc elementEtc q = fmap HasElement (elementDecl q) `onFail` fmap HasGroup (group_ q) `onFail` fmap HasCS (choiceOrSeq q) `onFail` fmap HasAny any_ -- | Parse an . any_ :: XsdParser Any any_ = do e <- xsdElement "any" commit $ return Any `apply` interiorWith (xsdTag "annotation") annotation e `apply` (attribute (N "namespace") uri e `onFail` return "##any") `apply` (attribute (N "processContents") processContents e `onFail` return Strict) `apply` occurs e -- | Parse an . anyAttr :: XsdParser AnyAttr anyAttr = do e <- xsdElement "anyAttribute" commit $ return AnyAttr `apply` interiorWith (xsdTag "annotation") annotation e `apply` (attribute (N "namespace") uri e `onFail` return "##any") `apply` (attribute (N "processContents") processContents e `onFail` return Strict) -- | Parse an . attributeGroup :: (String->String->QName) -> XsdParser AttrGroup attributeGroup q = do e <- xsdElement "attributeGroup" commit $ return AttrGroup `apply` interiorWith (xsdTag "annotation") annotation e `apply` (fmap Left (attribute (N "name") string e) `onFail` fmap Right (attribute (N "ref") (qname q) e)) `apply` interiorWith (not.xsdTag "annotation") (many stuff) e where stuff = fmap Left (attributeDecl q) `onFail` fmap Right (attributeGroup q) -- | Parse an decl. elementDecl :: (String->String->QName) -> XsdParser ElementDecl elementDecl q = do e <- xsdElement "element" commit $ return ElementDecl `apply` interiorWith (xsdTag "annotation") annotation e `apply` (fmap Left (nameAndType q e) `onFail` fmap Right (attribute (N "ref") (qname q) e)) `apply` occurs e `apply` (attribute (N "nillable") bool e `onFail` return False) `apply` optional (attribute (N "substitutionGroup") (qname q) e) `apply` (attribute (N "abstract") bool e `onFail` return False) `apply` optional (attribute (xsd "final") final e) `apply` optional (attribute (xsd "block") block e) `apply` (attribute (xsd "form") qform e `onFail` return Unqualified) `apply` interiorWith (xsdTag "simpleType" ||| xsdTag "complexType") (optional (fmap Left (simpleType q) `onFail` fmap Right (complexType q))) e `apply` interiorWith (xsdTag "unique" ||| xsdTag "key" ||| xsdTag "keyRef") (many (uniqueKeyOrKeyRef q)) e -- | Parse name and type attributes. nameAndType :: (String->String->QName) -> Element Posn -> XsdParser NameAndType nameAndType q e = return NT `apply` attribute (N "name") string e `apply` optional (attribute (N "type") (qname q) e) -- | Parse an decl. attributeDecl :: (String->String->QName) -> XsdParser AttributeDecl attributeDecl q = do e <- xsdElement "attribute" commit $ return AttributeDecl `apply` interiorWith (xsdTag "annotation") annotation e `apply` (fmap Left (nameAndType q e) `onFail` fmap Right (attribute (N "ref") (qname q) e)) `apply` (attribute (N "use") use e `onFail` return Optional) `apply` (optional (attribute (N "default") (fmap Left string) e `onFail` attribute (N "fixed") (fmap Right string) e)) `apply` (attribute (xsd "form") qform e `onFail` return Unqualified) `apply` interiorWith (xsdTag "simpleType") (optional (simpleType q)) e -- | Parse an occurrence range from attributes of given element. occurs :: Element Posn -> XsdParser Occurs occurs e = return Occurs `apply` (optional $ attribute (N "minOccurs") parseDec e) `apply` (optional $ attribute (N "maxOccurs") maxDec e) where maxDec = parseDec `onFail` do isWord "unbounded"; return maxBound -- | Parse a , , or . uniqueKeyOrKeyRef :: (String->String->QName) -> XsdParser UniqueKeyOrKeyRef uniqueKeyOrKeyRef q = fmap U unique `onFail` fmap K key `onFail` fmap KR (keyRef q) -- | Parse a . unique :: XsdParser Unique unique = do e <- xsdElement "unique" commit $ return Unique `apply` interiorWith (xsdTag "annotation") annotation e `apply` attribute (N "name") string e `apply` interiorWith (xsdTag "selector") selector e `apply` interiorWith (xsdTag "field") (many1 field_) e -- | Parse a . key :: XsdParser Key key = do e <- xsdElement "key" commit $ return Key `apply` interiorWith (xsdTag "annotation") annotation e `apply` attribute (N "name") string e `apply` interiorWith (xsdTag "selector") selector e `apply` interiorWith (xsdTag "field") (many1 field_) e -- | Parse a . keyRef :: (String->String->QName) -> XsdParser KeyRef keyRef q = do e <- xsdElement "keyref" commit $ return KeyRef `apply` interiorWith (xsdTag "annotation") annotation e `apply` attribute (N "name") string e `apply` attribute (N "refer") (qname q) e `apply` interiorWith (xsdTag "selector") selector e `apply` interiorWith (xsdTag "field") (many1 field_) e -- | Parse a . selector :: XsdParser Selector selector = do e <- xsdElement "selector" commit $ return Selector `apply` interiorWith (xsdTag "annotation") annotation e `apply` attribute (N "xpath") string e -- | Parse a . field_ :: XsdParser Field field_ = do e <- xsdElement "field" commit $ return Field `apply` interiorWith (xsdTag "annotation") annotation e `apply` attribute (N "xpath") string e -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- | Text parser for a URI (very simple, non-validating, probably incorrect). uri :: TextParser String uri = string -- | Text parser for an arbitrary string consisting of possibly multiple tokens. string :: TextParser String string = fmap concat $ many (space `onFail` word) space :: TextParser String space = many1 $ satisfy isSpace -- | Parse a textual boolean, i.e. "true", "false", "0", or "1" bool :: TextParser Bool bool = do w <- word case w of "true" -> return True "false" -> return False "0" -> return True "1" -> return False _ -> fail "could not parse boolean value" -- | Parse a "use" attribute value, i.e. "required", "optional", or "prohibited" use :: TextParser Use use = do w <- word case w of "required" -> return Required "optional" -> return Optional "prohibited" -> return Prohibited _ -> fail "could not parse \"use\" attribute value" -- | Parse a "processContents" attribute, i.e. "skip", "lax", or "strict". processContents :: TextParser ProcessContents processContents = do w <- word case w of "skip" -> return Skip "lax" -> return Lax "strict" -> return Strict _ -> fail "could not parse \"processContents\" attribute value" -- | Parse an attribute value that should be a QName. qname :: (String->String->QName) -> TextParser QName qname q = do a <- word ( do ":" <- word b <- many (satisfy (/=':')) return (q a b) `onFail` do cs <- many next return (N (a++cs)) ) -- | Parse an attribute value that should be a simple Name. name :: TextParser Name name = word HaXml-1.25.4/src/Text/XML/HaXml/Schema/PrettyHaskell.hs0000644000000000000000000012543513122420334020521 0ustar0000000000000000-- | Pretty-print the internal Haskell model of XSD datatypes to a real -- Haskell module containing type declarations, and instances for parsing -- (and printing - though not yet implemented) values of those datatypes -- from(/to) XML. module Text.XML.HaXml.Schema.PrettyHaskell ( ppComment , ppModule , ppHighLevelDecl , ppHighLevelDecls , ppvList ) where import Text.XML.HaXml.Types (QName(..),Namespace(..)) import Text.XML.HaXml.Schema.HaskellTypeModel import Text.XML.HaXml.Schema.XSDTypeModel (Occurs(..)) import Text.XML.HaXml.Schema.NameConversion import Text.PrettyPrint.HughesPJ as PP import Data.List (intersperse,notElem,inits) import Data.Maybe (isJust,fromJust,fromMaybe,catMaybes) import Data.Char (toLower) -- | Vertically pretty-print a list of things, with open and close brackets, -- and separators. ppvList :: String -> String -> String -> (a->Doc) -> [a] -> Doc ppvList open sep close pp [] = text open <> text close ppvList open sep close pp (x:xs) = text open <+> pp x $$ vcat (map (\y-> text sep <+> pp y) xs) $$ text close data CommentPosition = Before | After -- | Generate aligned haddock-style documentation. -- (but without escapes in comment text yet) ppComment :: CommentPosition -> Comment -> Doc ppComment _ Nothing = empty ppComment pos (Just s) = text "--" <+> text (case pos of Before -> "|"; After -> "^") <+> text c $$ vcat (map (\x-> text "-- " <+> text x) cs) where (c:cs) = lines (paragraph 60 s) -- | Generate aligned haddock-style docs for choices (where each choice -- has its own documentation, but haddock cannot place it directly next -- to the appropriate component. ppCommentForChoice :: CommentPosition -> Comment -> [[Element]] -> Doc ppCommentForChoice pos outer nested = text "--" <+> text (case pos of Before -> "|"; After -> "^") <+> text c $$ vcat (map (\x-> text "-- " <+> text x) cs) $$ vcat (map (\x-> text "-- " <+> text x) bullets) where (c:cs) = lines intro intro = maybe "Choice between:" (\s-> paragraph 60 s++"\n\nChoice between:") outer bullets = concatMap lines $ zipWith (\n seq-> case seq of [x]-> "\n("++show n++") "++paragraph 56 x _ -> "\n("++show n++") Sequence of:" ++ concatMap (\s->"\n\n * " ++paragraph 52 s) seq) [1..] $ map (map safeComment) $ nested safeComment Text = "mixed text" safeComment e@Element{} = fromMaybe (xname $ elem_name e) (elem_comment e) safeComment e@_ = fromMaybe ("unknown") (elem_comment e) xname (XName (N x)) = x xname (XName (QN ns x)) = nsPrefix ns++":"++x -- | Pretty-print a Haskell-style name. ppHName :: HName -> Doc ppHName (HName x) = text x -- | Pretty-print an XML-style name. ppXName :: XName -> Doc ppXName (XName (N x)) = text x ppXName (XName (QN ns x)) = text (nsPrefix ns) <> text ":" <> text x -- | Some different ways of using a Haskell identifier. ppModId, ppConId, ppVarId, ppUnqConId, ppUnqVarId, ppFwdConId :: NameConverter -> XName -> Doc ppModId nx = ppHName . modid nx ppConId nx = ppHName . conid nx ppVarId nx = ppHName . varid nx ppUnqConId nx = ppHName . unqconid nx ppUnqVarId nx = ppHName . unqvarid nx ppFwdConId nx = ppHName . fwdconid nx ppJoinConId, ppFieldId :: NameConverter -> XName -> XName -> Doc ppJoinConId nx p q = ppHName (conid nx p) <> text "_" <> ppHName (conid nx q) ppFieldId nx = \t-> ppHName . fieldid nx t -- | Convert a whole document from HaskellTypeModel to Haskell source text. ppModule :: NameConverter -> Module -> Doc ppModule nx m = text "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}" $$ text "{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}" $$ text "module" <+> ppModId nx (module_name m) $$ nest 2 (text "( module" <+> ppModId nx (module_name m) $$ vcat (map (\(XSDInclude ex com)-> ppComment Before com $$ text ", module" <+> ppModId nx ex) (module_re_exports m)) $$ text ") where") $$ text " " $$ text "import Text.XML.HaXml.Schema.Schema (SchemaType(..),SimpleType(..),Extension(..),Restricts(..))" $$ text "import Text.XML.HaXml.Schema.Schema as Schema" $$ text "import Text.XML.HaXml.OneOfN" $$ (case module_xsd_ns m of Nothing -> text "import Text.XML.HaXml.Schema.PrimitiveTypes as Xsd" Just ns -> text "import qualified Text.XML.HaXml.Schema.PrimitiveTypes as"<+>ppConId nx ns) $$ vcat (map (ppHighLevelDecl nx) (module_re_exports m ++ module_import_only m)) $$ text " " $$ text "-- Some hs-boot imports are required, for fwd-declaring types." $$ vcat (map ppFwdDecl $ concatMap imports $ module_decls m) $$ vcat (map ppFwdElem $ concatMap importElems $ module_decls m) $$ text " " $$ ppHighLevelDecls nx (module_decls m) where imports (ElementsAttrsAbstract _ deps _) = deps imports (ExtendComplexTypeAbstract _ _ deps _ _ _) = deps imports _ = [] importElems (ElementAbstractOfType _ _ deps _) = deps importElems _ = [] ppFwdDecl (_, Nothing) = empty ppFwdDecl (name,Just mod) = text "import {-# SOURCE #-}" <+> ppModId nx mod <+> text "(" <+> ppConId nx name <+> text ")" ppFwdElem (_, Nothing) = empty ppFwdElem (name,Just mod) = text "import {-# SOURCE #-}" <+> ppModId nx mod <+> text "(" <+> (text "element" <> ppUnqConId nx name) <> (text ", elementToXML" <> ppUnqConId nx name) <+> text ")" -- | Generate a fragmentary parser for an attribute. ppAttr :: Attribute -> Int -> Doc ppAttr a n = (text "a"<>text (show n)) <+> text "<-" <+> (if attr_required a then empty else text "optional $") <+> text "getAttribute \"" <> ppXName (attr_name a) <> text "\" e pos" -- | Generate a fragmentary toXML for an attribute. toXmlAttr :: Attribute -> Doc toXmlAttr a = (if attr_required a then id else (\d-> text "maybe []" <+> parens d)) (text "toXMLAttribute \"" <> ppXName (attr_name a) <> text "\"") -- | Generate a fragmentary parser for an element. ppElem :: NameConverter -> Element -> Doc ppElem nx e@Element{} | elem_byRef e = ppElemModifier (elem_modifier e) (text "element" <> ppUnqConId nx (elem_name e)) | otherwise = ppElemModifier (elem_modifier e) (text "parseSchemaType \"" <> ppXName (elem_name e) <> text "\"") ppElem nx e@AnyElem{} = ppElemModifier (elem_modifier e) (text "parseAnyElement") ppElem nx e@Text{} = text "parseText" ppElem nx e@OneOf{} = ppElemModifier (liftedElemModifier e) (text "oneOf'" <+> ppvList "[" "," "]" (ppOneOf n) (zip (elem_oneOf e) [1..n])) where n = length (elem_oneOf e) ppOneOf n (e,i) = text "(\"" <> hsep (map (ppElemTypeName nx id) . cleanChoices $ e) <> text "\"," <+> text "fmap" <+> text (ordinal i ++"Of"++show n) <+> parens (ppSeqElem . cleanChoices $ e) <> text ")" ordinal i | i <= 20 = ordinals!!i | otherwise = "Choice" ++ show i ordinals = ["Zero","One","Two","Three","Four","Five","Six","Seven","Eight" ,"Nine","Ten","Eleven","Twelve","Thirteen","Fourteen","Fifteen" ,"Sixteen","Seventeen","Eighteen","Nineteen","Twenty"] ppSeqElem [] = PP.empty ppSeqElem [e] = ppElem nx e ppSeqElem es = text ("return ("++replicate (length es-1) ','++")") <+> vcat (map (\e-> text "`apply`" <+> ppElem nx e) es) -- | Generate a fragmentary toXML for an element. Fragment must still be -- applied to an actual element value. toXmlElem :: NameConverter -> Element -> Doc toXmlElem nx e@Element{} | elem_byRef e = xmlElemModifier (elem_modifier e) (text "elementToXML" <> ppUnqConId nx (elem_name e)) | otherwise = xmlElemModifier (elem_modifier e) (text "schemaTypeToXML \"" <> ppXName (elem_name e) <> text "\"") toXmlElem nx e@AnyElem{} = xmlElemModifier (elem_modifier e) (text "toXMLAnyElement") toXmlElem nx e@Text{} = text "toXMLText" toXmlElem nx e@OneOf{} = xmlElemModifier (liftedElemModifier e) (text "foldOneOf" <> text (show n) <+> ppvList "" "" "" xmlOneOf (elem_oneOf e)) where n = length (elem_oneOf e) xmlOneOf e = parens (xmlSeqElem . cleanChoices $ e) xmlSeqElem [] = PP.empty xmlSeqElem [e] = toXmlElem nx e xmlSeqElem es = text "\\ (" <> hcat (intersperse (text ",") vars) <> text ") -> concat" <+> ppvList "[" "," "]" (\(e,v)-> toXmlElem nx e <+> v) (zip es vars) where vars = map (text.(:[])) . take (length es) $ ['a'..'z'] -- | Convert multiple HaskellTypeModel Decls to Haskell source text. ppHighLevelDecls :: NameConverter -> [Decl] -> Doc ppHighLevelDecls nx hs = vcat (intersperse (text " ") (map (ppHighLevelDecl nx) hs)) -- | Convert a single Haskell Decl into Haskell source text. ppHighLevelDecl :: NameConverter -> Decl -> Doc ppHighLevelDecl nx (NamedSimpleType t s comm) = ppComment Before comm $$ text "type" <+> ppUnqConId nx t <+> text "=" <+> ppConId nx s $$ text "-- No instances required: synonym is isomorphic to the original." ppHighLevelDecl nx (RestrictSimpleType t s r comm) = ppComment Before comm $$ text "newtype" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t <+> ppConId nx s <+> text "deriving (Eq,Show)" $$ text "instance Restricts" <+> ppUnqConId nx t <+> ppConId nx s <+> text "where" $$ nest 4 (text "restricts (" <> ppUnqConId nx t <+> text "x) = x") $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (text "e <- element [s]" $$ text "commit $ interior e $ parseSimpleType") ) $$ nest 4 (text "schemaTypeToXML s ("<> ppUnqConId nx t <+> text "x) = " $$ nest 4 (text "toXMLElement s [] [toXMLText (simpleTypeText x)]") ) $$ text "instance SimpleType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "acceptingParser = fmap" <+> ppUnqConId nx t <+> text "acceptingParser" -- XXX should enforce the restrictions somehow. (?) $$ text "-- XXX should enforce the restrictions somehow?" $$ text "-- The restrictions are:" $$ vcat (map ((text "-- " <+>) . ppRestrict) r)) $$ nest 4 (text "simpleTypeText (" <> ppUnqConId nx t <+> text "x) = simpleTypeText x") where ppRestrict (RangeR occ comm) = text "(RangeR" <+> ppOccurs occ <> text ")" ppRestrict (Pattern regexp comm) = text ("(Pattern "++regexp++")") ppRestrict (Enumeration items) = text "(Enumeration" <+> hsep (map (text . fst) items) <> text ")" ppRestrict (StrLength occ comm) = text "(StrLength" <+> ppOccurs occ <> text ")" ppOccurs = parens . text . show ppHighLevelDecl nx (ExtendSimpleType t s as comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t <+> ppConId nx s <+> ppConId nx t_attrs <+> text "deriving (Eq,Show)" $$ text "data" <+> ppConId nx t_attrs <+> text "=" <+> ppConId nx t_attrs $$ nest 4 (ppFields nx t_attrs [] as $$ text "deriving (Eq,Show)") $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (text "(pos,e) <- posnElement [s]" $$ text "commit $ do" $$ nest 2 (vcat (zipWith ppAttr as [0..]) $$ text "reparse [CElem e pos]" $$ text "v <- parseSchemaType s" $$ text "return $" <+> ppUnqConId nx t <+> text "v" <+> attrsValue as) ) ) $$ nest 4 (text "schemaTypeToXML s ("<> ppUnqConId nx t <+> text "bt at) =" $$ nest 4 (text "addXMLAttributes" <+> ppvList "[" "," "]" (\a-> toXmlAttr a <+> text "$" <+> ppFieldId nx t_attrs (attr_name a) <+> text "at") as $$ nest 4 (text "$ schemaTypeToXML s bt")) ) $$ text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx s <+> text "where" $$ nest 4 (text "supertype (" <> ppUnqConId nx t <> text " s _) = s") where t_attrs = let (XName (N t_base)) = t in XName (N (t_base++"Attributes")) attrsValue [] = ppConId nx t_attrs attrsValue as = parens (ppConId nx t_attrs <+> hsep [text ("a"++show n) | n <- [0..length as-1]]) -- do element [s] -- blah <- attribute foo -- interior e $ do -- simple <- parseText acceptingParser -- return (T simple blah) ppHighLevelDecl nx (UnionSimpleTypes t sts comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t $$ text "-- Placeholder for a Union type, not yet implemented." ppHighLevelDecl nx (EnumSimpleType t [] comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t ppHighLevelDecl nx (EnumSimpleType t is comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t $$ nest 4 ( ppvList "=" "|" "deriving (Eq,Show,Enum)" item is ) $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (text "e <- element [s]" $$ text "commit $ interior e $ parseSimpleType") ) $$ nest 4 (text "schemaTypeToXML s x = " $$ nest 4 (text "toXMLElement s [] [toXMLText (simpleTypeText x)]") ) $$ text "instance SimpleType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "acceptingParser =" <+> ppvList "" "`onFail`" "" parseItem is $$ vcat (map enumText is)) where item (i,c) = (ppUnqConId nx t <> text "_" <> ppConId nx i) $$ ppComment After c parseItem (i,_) = text "do literal \"" <> ppXName i <> text "\"; return" <+> (ppUnqConId nx t <> text "_" <> ppConId nx i) enumText (i,_) = text "simpleTypeText" <+> (ppUnqConId nx t <> text "_" <> ppConId nx i) <+> text "= \"" <> ppXName i <> text "\"" ppHighLevelDecl nx (ElementsAttrs t es as comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t $$ nest 8 (ppFields nx t (uniqueify es) as $$ text "deriving (Eq,Show)") $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (text "(pos,e) <- posnElement [s]" -- $$ text "commit $ do" -- $$ nest 2 $$ (vcat (zipWith ppAttr as [0..]) $$ text "commit $ interior e $ return" <+> returnValue as $$ nest 4 (vcat (map ppApplyElem es)) ) ) ) $$ nest 4 (text "schemaTypeToXML s x@"<> ppUnqConId nx t <> text "{} =" $$ nest 4 (text "toXMLElement s" <+> ppvList "[" "," "]" (\a-> toXmlAttr a <+> text "$" <+> ppFieldId nx t (attr_name a) <+> text "x") as $$ nest 4 (ppvList "[" "," "]" (\ (e,i)-> toXmlElem nx e <+> text "$" <+> ppFieldName nx t e i <+> text "x") (zip es [0..])) ) ) where returnValue [] = ppUnqConId nx t returnValue as = parens (ppUnqConId nx t <+> hsep [text ("a"++show n) | n <- [0..length as-1]]) ppApplyElem e = text "`apply`" <+> ppElem nx e ppHighLevelDecl nx (ElementsAttrsAbstract t [] comm) = ppComment Before comm $$ text "-- (There are no subtypes defined for this abstract type.)" $$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t <+> text "deriving (Eq,Show)" $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType s = fail" <+> errmsg) $$ nest 4 (text "schemaTypeToXML s _ = toXMLElement s [] []") where errmsg = text "\"Parse failed when expecting an extension type of" <+> ppXName t <> text ":\\n No extension types are known.\"" ppHighLevelDecl nx (ElementsAttrsAbstract t insts comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t $$ nest 8 (ppvList "=" "|" "" ppAbstrCons insts $$ text "deriving (Eq,Show)") -- $$ text "-- instance SchemaType" <+> ppUnqConId nx t -- <+> text "(declared in Instance module)" -- *** Declare instance here $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (vcat (intersperse (text "`onFail`") (map ppParse insts) ++ [text "`onFail` fail" <+> errmsg]))) $$ nest 4 (vcat (map toXML insts)) -- $$ text "" -- $$ vcat (map ppFwdDecl $ filter (isJust . snd) insts) where ppAbstrCons (name,Nothing) = con name <+> ppConId nx name ppAbstrCons (name,Just mod) = con name <+> ppConId nx name -- *** Declare FwdDecl type here (proxy for type declared in later module) -- ppAbstrCons (name,Just mod) = text "forall q . (FwdDecl" <+> -- fwd name <+> text "q," <+> -- text "SchemaType q) =>" <+> -- con name <+> -- text "("<>fwd name<>text"->q)" <+> fwd name ppParse (name,Nothing) = text "(fmap" <+> con name <+> text "$ parseSchemaType s)" ppParse (name,Just _) = ppParse (name,Nothing) -- ppParse (name,Just _) = text "(return" <+> con name <+> -- text "`apply` (fmap const $ parseSchemaType s)" <+> -- text "`apply` return" <+> fwd name <> text ")" -- ppFwdDecl (name,Just mod) -- = text "-- | Proxy:" <+> ppConId nx name -- <+> text "declared later in" <+> ppModId nx mod -- $$ text "data" <+> fwd name <+> text "=" <+> fwd name errmsg = text "\"Parse failed when expecting an extension type of" <+> ppXName t <> text ",\\n\\\n\\ namely one of:\\n\\\n\\" <> hcat (intersperse (text ",") (map (ppXName . fst) insts)) <> text "\"" -- fwd name = ppFwdConId nx name con name = ppJoinConId nx t name -- This is probably an unportable hack, but because an abstract type never -- has an element in its own name, we need to guess at the name of the -- possible subtype elements that could substitute for it. toXML (name,_) = text "schemaTypeToXML _s (" <> con name <+> text "x) = schemaTypeToXML \"" <> ppXName (initLower name) <> text "\" x" initLower (XName (N (c:cs))) = XName $ N (toLower c:cs) initLower (XName (QN ns (c:cs))) = XName $ QN ns (toLower c:cs) ppHighLevelDecl nx (ElementOfType e@Element{}) = ppComment Before (elem_comment e) $$ (text "element" <> ppUnqConId nx (elem_name e)) <+> text "::" <+> text "XMLParser" <+> ppConId nx (elem_type e) $$ (text "element" <> ppUnqConId nx (elem_name e)) <+> text "=" <+> (text "parseSchemaType \"" <> ppXName (elem_name e) <> text "\"") $$ (text "elementToXML" <> ppUnqConId nx (elem_name e)) <+> text "::" <+> ppConId nx (elem_type e) <+> text "-> [Content ()]" $$ (text "elementToXML" <> ppUnqConId nx (elem_name e)) <+> text "=" <+> (text "schemaTypeToXML \"" <> ppXName (elem_name e) <> text "\"") ppHighLevelDecl nx e@(ElementAbstractOfType n t [] comm) = ppComment Before comm $$ text "-- (There are no elements in any substitution group for this element.)" $$ (text "element" <> ppUnqConId nx n) <+> text "::" <+> text "XMLParser" <+> ppConId nx t $$ (text "element" <> ppUnqConId nx n) <+> text "=" <+> text "fail" <+> errmsg $$ (text "elementToXML" <> ppUnqConId nx n) <+> text "::" <+> ppConId nx t <+> text "-> [Content ()]" $$ (text "elementToXML" <> ppUnqConId nx n) <+> text "=" <+> (text "schemaTypeToXML \"" <> ppXName n <> text "\"") where errmsg = text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\ <" <> ppXName n <> text ">,\\n\\\n\\ There are no substitutable elements.\"" ppHighLevelDecl nx e@(ElementAbstractOfType n t substgrp comm) -- | any notInScope substgrp -- = (text "-- element" <> ppUnqConId nx n) <+> text "::" -- <+> text "XMLParser" <+> ppConId nx t -- $$ text "-- declared in Instances module" | otherwise = ppComment Before comm $$ (text "element" <> ppUnqConId nx n) <+> text "::" <+> text "XMLParser" <+> ppConId nx t $$ (text "element" <> ppUnqConId nx n) <+> text "=" <+> vcat (intersperse (text "`onFail`") (map ppOne substgrp) ++ [text "`onFail` fail" <+> errmsg]) $$ (text "elementToXML" <> ppUnqConId nx n) <+> text "::" <+> ppConId nx t <+> text "-> [Content ()]" $$ (text "elementToXML" <> ppUnqConId nx n) <+> text "=" <+> (text "schemaTypeToXML \"" <> ppXName n <> text "\"") -- $$ vcat (map elementToXML substgrp) -- | otherwise = ppElementAbstractOfType nx e where notInScope (_,Just _) = True notInScope (_,Nothing) = False ppOne (c,Nothing) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c <+> (text "element" <> ppConId nx c) ppOne (c,Just _) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c <+> (text "element" <> ppConId nx c) <+> text "-- FIXME: element is forward-declared" errmsg = text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\ <" <> ppXName n <> text ">,\\n\\\n\\ namely one of:\\n\\\n\\<" <> hcat (intersperse (text ">, <") (map (ppXName . fst) substgrp)) <> text ">\"" -- elementToXML (c,_) = (text "elementToXML" <> ppUnqConId nx n) -- <+> text "(" <> ppJoinConId nx t c -- <+> text " x) = elementToXML" <> ppUnqConId nx c -- <+> text "x" ppHighLevelDecl nx (Choice t es comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t <+> nest 4 ( ppvList "=" "|" "" choices (zip es [1..]) $$ text "deriving (Eq,Show)" ) where choices (e,n) = (ppUnqConId nx t <> text (show n)) <+> ppConId nx (elem_type e) -- Comment out the Group for now. Groups get inlined into the ComplexType -- where they are used, so it may not be sensible to declare them separately -- as well. ppHighLevelDecl nx (Group t es comm) = PP.empty -- ppComment Before comm -- $$ text "data" <+> ppConId nx t <+> text "=" -- <+> ppConId nx t <+> hsep (map (ppConId nx . elem_type) es) -- Possibly we want to declare a really more restrictive type, e.g. -- to remove optionality, (Maybe Foo) -> (Foo), [Foo] -> Foo -- consequently the "restricts" method should do a proper translation, -- not merely an unwrapping. ppHighLevelDecl nx (RestrictComplexType t s comm) = ppComment Before comm $$ text "newtype" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t <+> ppConId nx s <+> text "deriving (Eq,Show)" $$ text "-- plus different (more restrictive) parser" $$ text "-- (parsing restrictions currently unimplemented)" $$ text "instance Restricts" <+> ppUnqConId nx t <+> ppConId nx s <+> text "where" $$ nest 4 (text "restricts (" <> ppUnqConId nx t <+> text "x) = x") $$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType = fmap " <+> ppUnqConId nx t <+> text ". parseSchemaType") -- XXX should enforce the restriction. $$ nest 4 (text "schemaTypeToXML s (" <> ppUnqConId nx t <+> text "x)") <+> text "= schemaTypeToXML s x" {- ppHighLevelDecl nx (ExtendComplexType t s es as _ comm) | length es + length as = 1 = ppComment Before comm $$ text "data" <+> ppConId nx t <+> text "=" <+> ppConId nx t <+> ppConId nx s <+> ppFields nx t es as <+> text "deriving (Eq,Show)" $$ text "instance Extension" <+> ppConId nx t <+> ppConId nx s <+> ppAuxConId nx t <+> text "where" $$ nest 4 (text "supertype (" <> ppConId nx t <> text " s e) = s" $$ text "extension (" <> ppConId nx t <> text " s e) = e") -} ppHighLevelDecl nx (ExtendComplexType t s oes oas es as fwdReqd absSup grandsuper comm) = ppHighLevelDecl nx (ElementsAttrs t (oes++es) (oas++as) comm) $$ ppExtension nx t s fwdReqd absSup oes oas es as $$ (if not (null grandsuper) -- && not (isJust fwdReqd) -- && isJust fwdReqd then ppSuperExtension nx s grandsuper (t,Nothing) else empty) ppHighLevelDecl nx (ExtendComplexTypeAbstract t s insts fwdReqd grandsuper comm) = ppHighLevelDecl nx (ElementsAttrsAbstract t insts comm) $$ ppExtension nx t s fwdReqd True [] [] [] [] -- $$ if not (null grandsuper) -- then vcat (map (ppSuperExtension nx t grandsuper) insts) -- -- FIXME some instances are missing! -- else empty ppHighLevelDecl nx (XSDInclude m comm) = ppComment After comm $$ text "import" <+> ppModId nx m ppHighLevelDecl nx (XSDImport m ma comm) = ppComment After comm $$ text "import" <+> ppModId nx m <+> maybe empty (\a->text "as"<+>ppConId nx a) ma ppHighLevelDecl nx (XSDComment comm) = ppComment Before comm {------------------------------------------------------------------------------- -- | Instances that depend on FwdDecl'd types, need to be declared in a -- different module. So they have been separated out from ppHighLevelDecl. ppHighLevelInstances :: NameConverter -> Decl -> Doc ppHighLevelInstances nx (ElementsAttrsAbstract t insts comm) = text "instance SchemaType" <+> ppUnqConId nx t <+> text "where" $$ nest 4 (text "parseSchemaType s = do" $$ nest 4 (vcat (intersperse (text "`onFail`") (map ppParse insts) ++ [text "`onFail` fail" <+> errmsg]))) where ppParse (name,Nothing) = text "(fmap" <+> con name <+> text "$ parseSchemaType s)" ppParse (name,Just _) = text "(return" <+> con name <+> text "`apply` (fmap const $ parseSchemaType s)" <+> text "`apply` return" <+> fwd name <> text ")" errmsg = text "\"Parse failed when expecting an extension type of" <+> ppXName t <> text ",\\n\\\n\\ namely one of:\\n\\\n\\" <> hcat (intersperse (text ",") (map (ppXName . fst) insts)) <> text "\"" fwd name = ppFwdConId nx name con name = ppJoinConId nx t name ppHighLevelInstances nx e@(ElementAbstractOfType n t substgrp comm) | any notInScope substgrp = ppElementAbstractOfType nx e | otherwise = empty where notInScope (_,Just _) = True notInScope (_,Nothing) = False ppHighLevelInstances nx (ExtendComplexType t s oes oas es as fwdReqd absSup grandsuper comm) = empty -- ppExtension nx t s fwdReqd absSup oes oas es as -- $$ (if not (null grandsuper) && isJust fwdReqd -- then ppSuperExtension nx s grandsuper (t,Nothing) -- else empty) ppHighLevelInstances nx (ExtendComplexTypeAbstract t s insts fwdReqd grandsuper comm) = ppHighLevelInstances nx (ElementsAttrsAbstract t insts comm) -- $$ ppExtension nx t s fwdReqd True [] [] [] [] -- $$ if not (null grandsuper) -- then vcat (map (ppSuperExtension nx t grandsuper) insts) -- -- FIXME some instances are missing! -- else empty ppElementAbstractOfType nx (ElementAbstractOfType n t substgrp comm) = ppComment Before comm $$ (text "element" <> ppUnqConId nx n) <+> text "::" <+> text "XMLParser" <+> ppConId nx t $$ (text "element" <> ppUnqConId nx n) <+> text "=" <+> vcat (intersperse (text "`onFail`") (map ppOne substgrp) ++ [text "`onFail` fail" <+> errmsg]) where ppOne (c,Nothing) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c <+> (text "element" <> ppConId nx c) ppOne (c,Just _) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c <+> (text "element" <> ppConId nx c) <+> text "-- FIXME: element is forward-declared" errmsg = text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\ <" <> ppXName n <> text ">,\\n\\\n\\ namely one of:\\n\\\n\\<" <> hcat (intersperse (text ">, <") (map (ppXName . fst) substgrp)) <> text ">\"" ----------------------------------------------------------------------------- -} -------------------------------------------------------------------------------- -- | Generate an instance of the Extension class for a subtype/supertype pair. ppExtension :: NameConverter -> XName -> XName -> Maybe XName -> Bool -> [Element] -> [Attribute] -> [Element] -> [Attribute] -> Doc ppExtension nx t s fwdReqd abstractSuper oes oas es as = text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx s <+> text "where" $$ (if abstractSuper then nest 4 (text "supertype v" <+> text "=" <+> ppJoinConId nx s t <+> -- (if isJust fwdReqd -- then text "(\\_-> v)" <+> ppFwdConId nx t -- else text "v") text "v") else nest 4 (text "supertype (" <> ppType t (oes++es) (oas++as) <> text ") =" $$ nest 11 (ppType s oes oas) )) -- $$ (if isJust fwdReqd then -- -- text "data" <+> fwd t <+> text "=" <+> fwd t $$ -- already defined -- text "" -- $$ text "-- | Proxy" <+> fwd t <+> text "was declared earlier in" -- <+> ppModId nx (fromJust fwdReqd) -- $$ text "instance FwdDecl" <+> fwd t <+> ppConId nx t -- else empty) where fwd name = ppFwdConId nx name ppType t es as = ppUnqConId nx t <+> hsep (take (length as) [text ('a':show n) | n<-[0..]]) <+> hsep (take (length es) [text ('e':show n) | n<-[0..]]) -- | Generate an instance of the Extension class for a type and its -- "grand"-supertype, that is, the supertype of its supertype. ppSuperExtension :: NameConverter -> XName -> [XName] -> (XName,Maybe XName) -> Doc {- ppSuperExtension nx super (grandSuper:_) (t,Nothing) = text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx grandSuper <+> text "where" $$ nest 4 (text "supertype = (supertype ::" <+> ppUnqConId nx super <+> text "->" <+> ppConId nx grandSuper <> text ")" $$ nest 12 (text ". (supertype ::" <+> ppUnqConId nx t <+> text "->" <+> ppConId nx super <> text ")")) -} ppSuperExtension nx super grandSupers (t,Just mod) = -- fwddecl text "-- Note that" <+> ppUnqConId nx t <+> text "will be declared later in module" <+> ppModId nx mod $$ ppSuperExtension nx super grandSupers (t,Nothing) ppSuperExtension nx super grandSupers (t,Nothing) = vcat (map (ppSuper t) (map reverse . drop 2 . inits $ super: grandSupers)) where ppSuper :: XName -> [XName] -> Doc ppSuper t gss@(gs:_) = text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx gs <+> text "where" $$ nest 4 (text "supertype" <+> (ppvList "=" "." "" coerce (zip (tail gss++[t]) gss))) coerce (a,b) = text "(supertype ::" <+> ppUnqConId nx a <+> text "->" <+> ppConId nx b <> text ")" -- | Generate named fields from elements and attributes. ppFields :: NameConverter -> XName -> [Element] -> [Attribute] -> Doc ppFields nx t es as | null es && null as = empty ppFields nx t es as = ppvList "{" "," "}" id fields where fields = map (ppFieldAttribute nx t) as ++ zipWith (ppFieldElement nx t) es [0..] -- | Generate a single named field (including type sig) from an element. ppFieldElement :: NameConverter -> XName -> Element -> Int -> Doc ppFieldElement nx t e@Element{} i = ppFieldName nx t e i <+> text "::" <+> ppElemTypeName nx id e $$ ppComment After (elem_comment e) ppFieldElement nx t e@OneOf{} i = ppFieldName nx t e i <+> text "::" <+> ppElemTypeName nx id e $$ ppCommentForChoice After (elem_comment e) (elem_oneOf e) ppFieldElement nx t e@AnyElem{} i = ppFieldName nx t e i <+> text "::" <+> ppElemTypeName nx id e $$ ppComment After (elem_comment e) ppFieldElement nx t e@Text{} i = ppFieldName nx t e i <+> text "::" <+> ppElemTypeName nx id e -- | Generate a single named field (no type sig) from an element. ppFieldName :: NameConverter -> XName -> Element -> Int -> Doc ppFieldName nx t e@Element{} _ = ppFieldId nx t (elem_name e) ppFieldName nx t e@OneOf{} i = ppFieldId nx t (XName $ N $"choice"++show i) ppFieldName nx t e@AnyElem{} i = ppFieldId nx t (XName $ N $"any"++show i) ppFieldName nx t e@Text{} i = ppFieldId nx t (XName $ N $"text"++show i) -- | What is the name of the type for an Element (or choice of Elements)? ppElemTypeName :: NameConverter -> (Doc->Doc) -> Element -> Doc ppElemTypeName nx brack e@Element{} = ppTypeModifier (elem_modifier e) brack $ ppConId nx (elem_type e) ppElemTypeName nx brack e@OneOf{} = brack $ ppTypeModifier (liftedElemModifier e) parens $ text "OneOf" <> text (show (length (elem_oneOf e))) <+> hsep (map (ppSeq . cleanChoices) (elem_oneOf e)) where ppSeq [] = text "()" ppSeq [e] = ppElemTypeName nx parens e ppSeq es = text "(" <> hcat (intersperse (text ",") (map (ppElemTypeName nx parens) es)) <> text ")" ppElemTypeName nx brack e@AnyElem{} = brack $ ppTypeModifier (elem_modifier e) id $ text "AnyElement" ppElemTypeName nx brack e@Text{} = text "String" -- | Generate a single named field from an attribute. ppFieldAttribute :: NameConverter -> XName -> Attribute -> Doc ppFieldAttribute nx t a = ppFieldId nx t (attr_name a) <+> text "::" <+> (if attr_required a then empty else text "Maybe") <+> ppConId nx (attr_type a) $$ ppComment After (attr_comment a) -- | Generate a list or maybe type name (possibly parenthesised). ppTypeModifier :: Modifier -> (Doc->Doc) -> Doc -> Doc ppTypeModifier Single _ d = d ppTypeModifier Optional k d = k $ text "Maybe" <+> k d ppTypeModifier (Range (Occurs Nothing Nothing)) _ d = d ppTypeModifier (Range (Occurs (Just 0) Nothing)) k d = k $ text "Maybe" <+> k d ppTypeModifier (Range (Occurs _ _)) _ d = text "[" <> d <> text "]" -- | Generate a parser for a list or Maybe value. ppElemModifier :: Modifier -> Doc -> Doc ppElemModifier Single doc = doc ppElemModifier Optional doc = text "optional" <+> parens doc ppElemModifier (Range (Occurs Nothing Nothing)) doc = doc ppElemModifier (Range (Occurs (Just 0) Nothing)) doc = text "optional" <+> parens doc ppElemModifier (Range (Occurs (Just 0) (Just n))) doc | n==maxBound = text "many" <+> parens doc ppElemModifier (Range (Occurs Nothing (Just n))) doc | n==maxBound = text "many1" <+> parens doc ppElemModifier (Range (Occurs (Just 1) (Just n))) doc | n==maxBound = text "many1" <+> parens doc ppElemModifier (Range o) doc = text "between" <+> (parens (text (show o)) $$ parens doc) -- | Generate a toXML for a list or Maybe value. xmlElemModifier :: Modifier -> Doc -> Doc xmlElemModifier Single doc = doc xmlElemModifier Optional doc = text "maybe []" <+> parens doc xmlElemModifier (Range (Occurs Nothing Nothing)) doc = doc xmlElemModifier (Range (Occurs (Just 0) Nothing)) doc = text "maybe []" <+> parens doc xmlElemModifier (Range (Occurs _ _)) doc = text "concatMap" <+> parens doc -- | Eliminate a Maybe type modifier, when it occurs directly inside a -- choice construct (since a parsed Nothing would always be preferred over -- a real value later in the choice). Likewise, empty lists must -- be disallowed inside choice. cleanChoices :: [Element] -> [Element] cleanChoices [e@Element{}] = (:[]) $ case elem_modifier e of Range (Occurs (Just 0) Nothing) -> e{elem_modifier=Single} Range (Occurs (Just 0) max)-> e{elem_modifier=Range (Occurs (Just 1) max)} _ -> e cleanChoices es = es -- | Sometimes, a choice without a type modifier contains element sequences, -- all of which have the same modifier. In that case, it makes sense to lift -- the modifier (typically Maybe) to the outer layer. liftedElemModifier :: Element -> Modifier liftedElemModifier e@OneOf{} = case elem_modifier e of Range (Occurs Nothing Nothing) -> newModifier Single -> newModifier m -> m where newModifier = if all (\x-> case x of Text -> True _ -> case elem_modifier x of Range (Occurs (Just 0) _) -> True Optional -> True _ -> False) (concat (elem_oneOf e)) then Optional else Single -- | Split long lines of comment text into a paragraph with a maximum width. paragraph :: Int -> String -> String paragraph n s = go n (words s) where go i [] = [] go i [x] | len [Element] uniqueify = go [] where go seen [] = [] go seen (e@Element{}:es) | show (elem_name e) `elem` seen = let fresh = new (`elem`seen) (elem_name e) in e{elem_name=fresh} : go (show fresh:seen) es | otherwise = e: go (show (elem_name e): seen) es go seen (e:es) = e : go seen es new pred (XName (N n)) = XName $ N $ head $ dropWhile pred [(n++show i) | i <- [2..]] new pred (XName (QN ns n)) = XName $ QN ns $ head $ dropWhile pred [(n++show i) | i <- [2..]] HaXml-1.25.4/src/Text/XML/HaXml/Schema/PrettyHsBoot.hs0000644000000000000000000004711513122420334020332 0ustar0000000000000000-- | Pretty-print the internal Haskell model of XSD datatypes to a -- Haskell hs-boot module containing only stub type declarations. -- This approach is intended to work around issues of mutually recursive -- datatype definitions. module Text.XML.HaXml.Schema.PrettyHsBoot ( ppComment , ppModule , ppHighLevelDecl , ppHighLevelDecls , ppvList ) where import Text.XML.HaXml.Types (QName(..),Namespace(..)) import Text.XML.HaXml.Schema.HaskellTypeModel import Text.XML.HaXml.Schema.XSDTypeModel (Occurs(..)) import Text.XML.HaXml.Schema.NameConversion import Text.PrettyPrint.HughesPJ as PP import Data.List (intersperse,notElem,inits) import Data.Maybe (isJust,fromJust,catMaybes) -- | Vertically pretty-print a list of things, with open and close brackets, -- and separators. ppvList :: String -> String -> String -> (a->Doc) -> [a] -> Doc ppvList open sep close pp [] = text open <> text close ppvList open sep close pp (x:xs) = text open <+> pp x $$ vcat (map (\y-> text sep <+> pp y) xs) $$ text close data CommentPosition = Before | After -- | Generate aligned haddock-style documentation. -- (but without escapes in comment text yet) ppComment :: CommentPosition -> Comment -> Doc ppComment _ Nothing = empty ppComment pos (Just s) = text "--" <+> text (case pos of Before -> "|"; After -> "^") <+> text c $$ vcat (map (\x-> text "-- " <+> text x) cs) where (c:cs) = lines (paragraph 60 s) -- | Pretty-print a Haskell-style name. ppHName :: HName -> Doc ppHName (HName x) = text x -- | Pretty-print an XML-style name. ppXName :: XName -> Doc ppXName (XName (N x)) = text x ppXName (XName (QN ns x)) = text (nsPrefix ns) <> text ":" <> text x -- | Some different ways of using a Haskell identifier. ppModId, ppConId, ppVarId, ppUnqConId, ppUnqVarId, ppFwdConId :: NameConverter -> XName -> Doc ppModId nx = ppHName . modid nx ppConId nx = ppHName . conid nx ppVarId nx = ppHName . varid nx ppUnqConId nx = ppHName . unqconid nx ppUnqVarId nx = ppHName . unqvarid nx ppFwdConId nx = ppHName . fwdconid nx ppJoinConId, ppFieldId :: NameConverter -> XName -> XName -> Doc ppJoinConId nx p q = ppHName (conid nx p) <> text "_" <> ppHName (conid nx q) ppFieldId nx = \t-> ppHName . fieldid nx t -- | Convert a whole document from HaskellTypeModel to Haskell source text. ppModule :: NameConverter -> Module -> Doc ppModule nx m = text "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}" $$ text "{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}" $$ text "module" <+> ppModId nx (module_name m) $$ nest 2 (text "( module" <+> ppModId nx (module_name m) $$ vcat (map (\(XSDInclude ex com)-> ppComment Before com $$ text ", module" <+> ppModId nx ex) (module_re_exports m)) $$ text ") where") $$ text " " $$ text "import Text.XML.HaXml.Schema.Schema (SchemaType(..),SimpleType(..),Extension(..),Restricts(..))" $$ text "import Text.XML.HaXml.Schema.Schema as Schema" $$ (case module_xsd_ns m of Nothing -> text "import Text.XML.HaXml.Schema.PrimitiveTypes as Xsd" Just ns -> text "import qualified Text.XML.HaXml.Schema.PrimitiveTypes as"<+>ppConId nx ns) $$ vcat (map (ppHighLevelDecl nx) (module_re_exports m {-++ module_import_only m-})) $$ text " " $$ ppHighLevelDecls nx (module_decls m) -- | Generate a fragmentary parser for an attribute. ppAttr :: Attribute -> Int -> Doc ppAttr a n = (text "a"<>text (show n)) <+> text "<- getAttribute \"" <> ppXName (attr_name a) <> text "\" e pos" -- | Generate a fragmentary parser for an element. ppElem :: NameConverter -> Element -> Doc ppElem nx e@Element{} | elem_byRef e = ppElemModifier (elem_modifier e) (text "element" <> ppUnqConId nx (elem_name e)) | otherwise = ppElemModifier (elem_modifier e) (text "parseSchemaType \"" <> ppXName (elem_name e) <> text "\"") ppElem nx e@AnyElem{} = ppElemModifier (elem_modifier e) (text "parseAnyElement") ppElem nx e@Text{} = text "parseText" ppElem nx e@OneOf{} = ppElemModifier (elem_modifier e) (text "oneOf" <+> ppvList "[" "," "]" (ppOneOf n) (zip (elem_oneOf e) [1..n])) where n = length (elem_oneOf e) ppOneOf n (e,i) = text "fmap" <+> text (ordinal i ++"Of"++show n) <+> parens (ppSeqElem e) ordinal i | i <= 20 = ordinals!!i | otherwise = "Choice" ++ show i ordinals = ["Zero","One","Two","Three","Four","Five","Six","Seven","Eight" ,"Nine","Ten","Eleven","Twelve","Thirteen","Fourteen","Fifteen" ,"Sixteen","Seventeen","Eighteen","Nineteen","Twenty"] ppSeqElem [] = PP.empty ppSeqElem [e] = ppElem nx e ppSeqElem es = text ("return ("++replicate (length es-1) ','++")") <+> vcat (map (\e-> text "`apply`" <+> ppElem nx e) es) -- | Convert multiple HaskellTypeModel Decls to Haskell source text. ppHighLevelDecls :: NameConverter -> [Decl] -> Doc ppHighLevelDecls nx hs = vcat (intersperse (text " ") (map (ppHighLevelDecl nx) hs)) -- | Convert a single Haskell Decl into Haskell source text. ppHighLevelDecl :: NameConverter -> Decl -> Doc ppHighLevelDecl nx (NamedSimpleType t s comm) = ppComment Before comm $$ text "type" <+> ppUnqConId nx t <+> text "=" <+> ppConId nx s $$ text "-- No instances required: synonym is isomorphic to the original." ppHighLevelDecl nx (RestrictSimpleType t s r comm) = ppComment Before comm $$ text "newtype" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t <+> ppConId nx s $$ text "instance Eq" <+> ppUnqConId nx t $$ text "instance Show" <+> ppUnqConId nx t $$ text "instance Restricts" <+> ppUnqConId nx t <+> ppConId nx s $$ text "instance SchemaType" <+> ppUnqConId nx t $$ text "instance SimpleType" <+> ppUnqConId nx t ppHighLevelDecl nx (ExtendSimpleType t s as comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t $$ text "data" <+> ppConId nx t_attrs $$ text "instance Eq" <+> ppUnqConId nx t $$ text "instance Eq" <+> ppConId nx t_attrs $$ text "instance Show" <+> ppUnqConId nx t $$ text "instance Show" <+> ppConId nx t_attrs $$ text "instance SchemaType" <+> ppUnqConId nx t $$ text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx s where t_attrs = let (XName (N t_base)) = t in XName (N (t_base++"Attributes")) ppHighLevelDecl nx (UnionSimpleTypes t sts comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t $$ text "-- Placeholder for a Union type, not yet implemented." ppHighLevelDecl nx (EnumSimpleType t [] comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t ppHighLevelDecl nx (EnumSimpleType t is comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t $$ text "instance Eq" <+> ppUnqConId nx t $$ text "instance Show" <+> ppUnqConId nx t $$ text "instance Enum" <+> ppUnqConId nx t $$ text "instance SchemaType" <+> ppUnqConId nx t $$ text "instance SimpleType" <+> ppUnqConId nx t ppHighLevelDecl nx (ElementsAttrs t es as comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t $$ text "instance Eq" <+> ppUnqConId nx t $$ text "instance Show" <+> ppUnqConId nx t $$ text "instance SchemaType" <+> ppUnqConId nx t ppHighLevelDecl nx (ElementsAttrsAbstract t insts comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t $$ text "instance Eq" <+> ppUnqConId nx t $$ text "instance Show" <+> ppUnqConId nx t $$ text "instance SchemaType" <+> ppUnqConId nx t ppHighLevelDecl nx (ElementOfType e@Element{}) = ppComment Before (elem_comment e) $$ (text "element" <> ppUnqConId nx (elem_name e)) <+> text "::" <+> text "XMLParser" <+> ppConId nx (elem_type e) $$ (text "elementToXML" <> ppUnqConId nx (elem_name e)) <+> text "::" <+> ppConId nx (elem_type e) <+> text "-> [Content ()]" ppHighLevelDecl nx e@(ElementAbstractOfType n t substgrp comm) | any notInScope substgrp = (text "element" <> ppUnqConId nx n) <+> text "::" <+> text "XMLParser" <+> ppConId nx t $$ (text "elementToXML" <> ppUnqConId nx n) <+> text "::" <+> ppConId nx t <+> text "-> [Content ()]" | otherwise = ppElementAbstractOfType nx e where notInScope (_,Just _) = True notInScope (_,Nothing) = False ppHighLevelDecl nx (Choice t es comm) = ppComment Before comm $$ text "data" <+> ppUnqConId nx t $$ text "instance Eq" <+> ppUnqConId nx t $$ text "instance Show" <+> ppUnqConId nx t -- Comment out the Group for now. Groups get inlined into the ComplexType -- where they are used, so it may not be sensible to declare them separately -- as well. ppHighLevelDecl nx (Group t es comm) = PP.empty -- ppComment Before comm -- $$ text "data" <+> ppConId nx t <+> text "=" -- <+> ppConId nx t <+> hsep (map (ppConId nx . elem_type) es) -- Possibly we want to declare a really more restrictive type, e.g. -- to remove optionality, (Maybe Foo) -> (Foo), [Foo] -> Foo -- consequently the "restricts" method should do a proper translation, -- not merely an unwrapping. ppHighLevelDecl nx (RestrictComplexType t s comm) = ppComment Before comm $$ text "newtype" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t <+> ppConId nx s $$ text "-- plus different (more restrictive) parser" $$ text "instance Eq" <+> ppUnqConId nx t $$ text "instance Show" <+> ppUnqConId nx t $$ text "instance Restricts" <+> ppUnqConId nx t <+> ppConId nx s $$ text "instance SchemaType" <+> ppUnqConId nx t {- ppHighLevelDecl nx (ExtendComplexType t s es as _ comm) | length es + length as = 1 = ppComment Before comm $$ text "data" <+> ppConId nx t <+> text "=" <+> ppConId nx t <+> ppConId nx s <+> ppFields nx t es as $$ text "instance Extension" <+> ppConId nx t <+> ppConId nx s <+> ppAuxConId nx t <+> text "where" $$ nest 4 (text "supertype (" <> ppConId nx t <> text " s e) = s" $$ text "extension (" <> ppConId nx t <> text " s e) = e") -} ppHighLevelDecl nx (ExtendComplexType t s oes oas es as fwdReqd absSup grandsuper comm) = ppHighLevelDecl nx (ElementsAttrs t (oes++es) (oas++as) comm) $$ ppExtension nx t s fwdReqd absSup oes oas es as $$ (if not (null grandsuper) -- && not (isJust fwdReqd) then ppSuperExtension nx s grandsuper (t,Nothing) else empty) ppHighLevelDecl nx (ExtendComplexTypeAbstract t s insts fwdReqd grandsuper comm) = ppHighLevelDecl nx (ElementsAttrsAbstract t insts comm) $$ ppExtension nx t s fwdReqd True [] [] [] [] -- $$ if not (null grandsuper) -- then vcat (map (ppSuperExtension nx t grandsuper) insts) -- -- FIXME some instances are missing! -- else empty ppHighLevelDecl nx (XSDInclude m comm) = ppComment After comm $$ text "import {-# SOURCE #-}" <+> ppModId nx m ppHighLevelDecl nx (XSDImport m ma comm) = ppComment After comm $$ text "import {-# SOURCE #-}" <+> ppModId nx m <+> maybe empty (\a->text "as"<+>ppConId nx a) ma ppHighLevelDecl nx (XSDComment comm) = ppComment Before comm -------------------------------------------------------------------------------- -- | Instances that depend on FwdDecl'd types, need to be declared in a -- different module. So they have been separated out from ppHighLevelDecl. ppHighLevelInstances :: NameConverter -> Decl -> Doc ppHighLevelInstances nx (ElementsAttrsAbstract t insts comm) = text "instance SchemaType" <+> ppUnqConId nx t ppHighLevelInstances nx e@(ElementAbstractOfType n t substgrp comm) | any notInScope substgrp = ppElementAbstractOfType nx e | otherwise = empty where notInScope (_,Just _) = True notInScope (_,Nothing) = False ppHighLevelInstances nx (ExtendComplexType t s oes oas es as fwdReqd absSup grandsuper comm) = empty -- ppExtension nx t s fwdReqd absSup oes oas es as -- $$ (if not (null grandsuper) && isJust fwdReqd -- then ppSuperExtension nx s grandsuper (t,Nothing) -- else empty) ppHighLevelInstances nx (ExtendComplexTypeAbstract t s insts fwdReqd grandsuper comm) = ppHighLevelInstances nx (ElementsAttrsAbstract t insts comm) -- $$ ppExtension nx t s fwdReqd True [] [] [] [] -- $$ if not (null grandsuper) -- then vcat (map (ppSuperExtension nx t grandsuper) insts) -- -- FIXME some instances are missing! -- else empty ppElementAbstractOfType nx (ElementAbstractOfType n t substgrp comm) = ppComment Before comm $$ (text "element" <> ppUnqConId nx n) <+> text "::" <+> text "XMLParser" <+> ppConId nx t -------------------------------------------------------------------------------- -- | Generate an instance of the Extension class for a subtype/supertype pair. ppExtension :: NameConverter -> XName -> XName -> Maybe XName -> Bool -> [Element] -> [Attribute] -> [Element] -> [Attribute] -> Doc ppExtension nx t s fwdReqd abstractSuper oes oas es as = text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx s -- | Generate an instance of the Extension class for a type and its -- "grand"-supertype, that is, the supertype of its supertype. ppSuperExtension :: NameConverter -> XName -> [XName] -> (XName,Maybe XName) -> Doc {- ppSuperExtension nx super (grandSuper:_) (t,Nothing) = text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx grandSuper <+> text "where" $$ nest 4 (text "supertype = (supertype ::" <+> ppUnqConId nx super <+> text "->" <+> ppConId nx grandSuper <> text ")" $$ nest 12 (text ". (supertype ::" <+> ppUnqConId nx t <+> text "->" <+> ppConId nx super <> text ")")) -} ppSuperExtension nx super (grandSuper:_) (t,Just mod) = -- fwddecl -- FIXME: generate comment for all of the grandSupers. text "-- instance Extension" <+> ppUnqConId nx t <+> ppConId nx grandSuper $$ text "-- will be declared in module" <+> ppModId nx mod ppSuperExtension nx super grandSupers (t,Nothing) = vcat (map (ppSuper t) (map reverse . drop 2 . inits $ super: grandSupers)) where ppSuper :: XName -> [XName] -> Doc ppSuper t gss@(gs:_) = text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx gs -- | Generate named fields from elements and attributes. ppFields :: NameConverter -> XName -> [Element] -> [Attribute] -> Doc ppFields nx t es as | null es && null as = empty ppFields nx t es as = ppvList "{" "," "}" id fields where fields = map (ppFieldAttribute nx t) as ++ zipWith (ppFieldElement nx t) es [0..] -- | Generate a single named field from an element. ppFieldElement :: NameConverter -> XName -> Element -> Int -> Doc ppFieldElement nx t e@Element{} _ = ppFieldId nx t (elem_name e) <+> text "::" <+> ppElemTypeName nx id e $$ ppComment After (elem_comment e) ppFieldElement nx t e@OneOf{} i = ppFieldId nx t (XName $ N $"choice"++show i) <+> text "::" <+> ppElemTypeName nx id e $$ ppComment After (elem_comment e) ppFieldElement nx t e@AnyElem{} i = ppFieldId nx t (XName $ N $"any"++show i) <+> text "::" <+> ppElemTypeName nx id e $$ ppComment After (elem_comment e) ppFieldElement nx t e@Text{} i = ppFieldId nx t (XName $ N $"text"++show i) <+> text "::" <+> ppElemTypeName nx id e -- | What is the name of the type for an Element (or choice of Elements)? ppElemTypeName :: NameConverter -> (Doc->Doc) -> Element -> Doc ppElemTypeName nx brack e@Element{} = ppTypeModifier (elem_modifier e) brack $ ppConId nx (elem_type e) ppElemTypeName nx brack e@OneOf{} = brack $ ppTypeModifier (elem_modifier e) parens $ text "OneOf" <> text (show (length (elem_oneOf e))) <+> hsep (map ppSeq (elem_oneOf e)) where ppSeq [] = text "()" ppSeq [e] = ppElemTypeName nx parens e ppSeq es = text "(" <> hcat (intersperse (text ",") (map (ppElemTypeName nx parens) es)) <> text ")" ppElemTypeName nx brack e@AnyElem{} = brack $ ppTypeModifier (elem_modifier e) id $ text "AnyElement" ppElemTypeName nx brack e@Text{} = text "String" -- | Generate a single named field from an attribute. ppFieldAttribute :: NameConverter -> XName -> Attribute -> Doc ppFieldAttribute nx t a = ppFieldId nx t (attr_name a) <+> text "::" <+> ppConId nx (attr_type a) $$ ppComment After (attr_comment a) -- | Generate a list or maybe type name (possibly parenthesised). ppTypeModifier :: Modifier -> (Doc->Doc) -> Doc -> Doc ppTypeModifier Single _ d = d ppTypeModifier Optional k d = k $ text "Maybe" <+> k d ppTypeModifier (Range (Occurs Nothing Nothing)) _ d = d ppTypeModifier (Range (Occurs (Just 0) Nothing)) k d = k $ text "Maybe" <+> k d ppTypeModifier (Range (Occurs _ _)) _ d = text "[" <> d <> text "]" -- | Generate a parser for a list or Maybe value. ppElemModifier Single doc = doc ppElemModifier Optional doc = text "optional" <+> parens doc ppElemModifier (Range (Occurs Nothing Nothing)) doc = doc ppElemModifier (Range (Occurs (Just 0) Nothing)) doc = text "optional" <+> parens doc ppElemModifier (Range o) doc = text "between" <+> (parens (text (show o)) $$ parens doc) -- | Split long lines of comment text into a paragraph with a maximum width. paragraph :: Int -> String -> String paragraph n s = go n (words s) where go i [] = [] go i (x:xs) | len [Element] uniqueify = go [] where go seen [] = [] go seen (e@Element{}:es) | show (elem_name e) `elem` seen = let fresh = new (`elem`seen) (elem_name e) in e{elem_name=fresh} : go (show fresh:seen) es | otherwise = e: go (show (elem_name e): seen) es go seen (e:es) = e : go seen es new pred (XName (N n)) = XName $ N $ head $ dropWhile pred [(n++show i) | i <- [2..]] new pred (XName (QN ns n)) = XName $ QN ns $ head $ dropWhile pred [(n++show i) | i <- [2..]] HaXml-1.25.4/src/Text/XML/HaXml/Schema/PrimitiveTypes.hs0000644000000000000000000003001413122420334020707 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} module Text.XML.HaXml.Schema.PrimitiveTypes ( -- * Type class for parsing simpleTypes SimpleType(..) , module Text.Parse , -- * Primitive XSD datatypes XsdString(..) , Boolean(..) , Base64Binary(..) , HexBinary(..) , Float(..) , Decimal(..) , Double(..) , AnyURI(..) , QName(..) , NOTATION(..) , Duration(..) , DateTime(..) , Time(..) , Date(..) , GYearMonth(..) , GYear(..) , GMonthDay(..) , GDay(..) , GMonth(..) , -- * Derived, yet builtin, datatypes NormalizedString(..) , Token(..) , Language(..) , Name(..) , NCName(..) , ID(..) , IDREF(..) , IDREFS(..) , ENTITY(..) , ENTITIES(..) , NMTOKEN(..) , NMTOKENS(..) , Integer(..) , NonPositiveInteger(..) , NegativeInteger(..) , Long(..) , Int(..) , Short(..) , Byte(..) , NonNegativeInteger(..) , UnsignedLong(..) , UnsignedInt(..) , UnsignedShort(..) , UnsignedByte(..) , PositiveInteger(..) ) where import Text.Parse import Data.Char as Char --import Data.Time.LocalTime -- for dates and times? import Text.XML.HaXml.Types (QName(..)) import Data.Int import Data.Word -- | Ultimately, an XML parser will find some plain text as the content -- of a simpleType, which will need to be parsed. We use a TextParser, -- because values of simpleTypes can also be given elsewhere, e.g. as -- attribute values in an XSD definition, e.g. to restrict the permissible -- values of the simpleType. Such restrictions are therefore implemented -- as layered parsers. class SimpleType a where acceptingParser :: TextParser a simpleTypeText :: a -> String -- * Primitive types type Boolean = Bool newtype XsdString = XsdString String deriving (Eq,Show) data Base64Binary = Base64Binary String deriving (Eq,Show) data HexBinary = HexBinary String deriving (Eq,Show) data AnyURI = AnyURI String deriving (Eq,Show) --data QName data NOTATION = NOTATION String -- or re-use NOTATION from HaXml.Types? deriving (Eq,Show) data Decimal = Decimal Double deriving (Eq,Show) --data Float --data Double data Duration = Duration Bool Int Int Int Int Int Float deriving (Eq,Show) -- * All of the following temporal types are incompletely specified for now. -- They should probably be mapped to something appropriate from the time -- package? data DateTime = DateTime String deriving (Eq,Show) -- LocalTime ? data Time = Time String deriving (Eq,Show) -- TimeOfDay ? data Date = Date String deriving (Eq,Show) -- Day ? data GYearMonth = GYearMonth String deriving (Eq,Show) -- ?? data GYear = GYear String deriving (Eq,Show) -- ?? data GMonthDay = GMonthDay String deriving (Eq,Show) -- ?? data GDay = GDay String deriving (Eq,Show) -- ?? data GMonth = GMonth String deriving (Eq,Show) -- ?? isNext :: Char -> TextParser Char isNext c = do d <- next if c==d then return c else fail ("expected "++c:", got "++d:".") instance SimpleType Bool where acceptingParser = do w <- word case w of "true" -> return True; "false" -> return False "0" -> return False; "1" -> return True _ -> fail ("Not a bool: "++w) simpleTypeText False = "false" simpleTypeText True = "true" instance SimpleType XsdString where acceptingParser = fmap XsdString (many next) simpleTypeText (XsdString s) = s instance SimpleType Base64Binary where acceptingParser = fmap Base64Binary (many (satisfy isAlphaNum `onFail` satisfy isSpace `onFail` satisfy (`elem`"+/="))) simpleTypeText (Base64Binary s) = s instance SimpleType HexBinary where acceptingParser = fmap HexBinary (many (satisfy Char.isHexDigit)) simpleTypeText (HexBinary s) = s instance SimpleType AnyURI where acceptingParser = fmap AnyURI (many next) -- not very satisfactory simpleTypeText (AnyURI s) = s instance SimpleType NOTATION where acceptingParser = fmap NOTATION (many next) -- not very satisfactory simpleTypeText (NOTATION s) = s instance SimpleType Decimal where acceptingParser = fmap Decimal parse simpleTypeText (Decimal s) = show s -- XXX FIXME: showGFloat? instance SimpleType Float where acceptingParser = parse simpleTypeText x = show x -- XXX FIXME: showGFloat? instance SimpleType Double where acceptingParser = parse simpleTypeText x = show x -- XXX FIXME: showGFloat? instance SimpleType Duration where acceptingParser = return Duration `apply` (do isNext '-'; return False `onFail` return True) `discard` isNext 'P' `apply` ((parseDec `discard` isNext 'Y') `onFail` return 0) `apply` ((parseDec `discard` isNext 'M') `onFail` return 0) `apply` ((parseDec `discard` isNext 'D') `onFail` return 0) `discard` (isNext 'T'`onFail`return 'T') -- fix: T absent iff H:M:S absent also `apply` ((parseDec `discard` isNext 'H') `onFail` return 0) `apply` ((parseDec `discard` isNext 'M') `onFail` return 0) `apply` ((parseFloat `discard` isNext 'S') `onFail` return 0) simpleTypeText (Duration pos y m d h n s) = (if pos then "" else "-")++show y++"Y"++show m++"M"++show d++"D" ++"T"++show h++"H"++show n++"M"++show s++"S" instance SimpleType DateTime where acceptingParser = fmap DateTime (many next) -- acceptingParser = fail "not implemented: simpletype parser for DateTime" simpleTypeText (DateTime x) = x instance SimpleType Time where acceptingParser = fmap Time (many next) -- acceptingParser = fail "not implemented: simpletype parser for Time" simpleTypeText (Time x) = x instance SimpleType Date where acceptingParser = fmap Date (many next) -- acceptingParser = fail "not implemented: simpletype parser for Date" simpleTypeText (Date x) = x instance SimpleType GYearMonth where acceptingParser = fmap GYearMonth (many next) -- acceptingParser = fail "not implemented: simpletype parser for GYearMonth" simpleTypeText (GYearMonth x) = x instance SimpleType GYear where acceptingParser = fmap GYear (many next) -- acceptingParser = fail "not implemented: simpletype parser for GYear" simpleTypeText (GYear x) = x instance SimpleType GMonthDay where acceptingParser = fmap GMonthDay (many next) -- acceptingParser = fail "not implemented: simpletype parser for GMonthDay" simpleTypeText (GMonthDay x) = x instance SimpleType GDay where acceptingParser = fmap GDay (many next) -- acceptingParser = fail "not implemented: simpletype parser for GDay" simpleTypeText (GDay x) = x instance SimpleType GMonth where acceptingParser = fmap GMonth (many next) -- acceptingParser = fail "not implemented: simpletype parser for GMonth" simpleTypeText (GMonth x) = x -- * Derived builtin types newtype NormalizedString = Normalized String deriving (Eq,Show) newtype Token = Token String deriving (Eq,Show) newtype Language = Language String deriving (Eq,Show) newtype Name = Name String deriving (Eq,Show) newtype NCName = NCName String deriving (Eq,Show) newtype ID = ID String deriving (Eq,Show) newtype IDREF = IDREF String deriving (Eq,Show) newtype IDREFS = IDREFS String deriving (Eq,Show) newtype ENTITY = ENTITY String deriving (Eq,Show) newtype ENTITIES = ENTITIES String deriving (Eq,Show) newtype NMTOKEN = NMTOKEN String deriving (Eq,Show) newtype NMTOKENS = NMTOKENS String deriving (Eq,Show) instance SimpleType NormalizedString where acceptingParser = fmap Normalized (many next) simpleTypeText (Normalized x) = x instance SimpleType Token where acceptingParser = fmap Token (many next) simpleTypeText (Token x) = x instance SimpleType Language where acceptingParser = fmap Language (many next) simpleTypeText (Language x) = x instance SimpleType Name where acceptingParser = fmap Name (many next) simpleTypeText (Name x) = x instance SimpleType NCName where acceptingParser = fmap NCName (many next) simpleTypeText (NCName x) = x instance SimpleType ID where acceptingParser = fmap ID (many next) simpleTypeText (ID x) = x instance SimpleType IDREF where acceptingParser = fmap IDREF (many next) simpleTypeText (IDREF x) = x instance SimpleType IDREFS where acceptingParser = fmap IDREFS (many next) simpleTypeText (IDREFS x) = x instance SimpleType ENTITY where acceptingParser = fmap ENTITY (many next) simpleTypeText (ENTITY x) = x instance SimpleType ENTITIES where acceptingParser = fmap ENTITIES (many next) simpleTypeText (ENTITIES x) = x instance SimpleType NMTOKEN where acceptingParser = fmap NMTOKEN (many next) simpleTypeText (NMTOKEN x) = x instance SimpleType NMTOKENS where acceptingParser = fmap NMTOKENS (many next) simpleTypeText (NMTOKENS x) = x --data Integer newtype NonPositiveInteger = NonPos Integer deriving (Eq,Show) newtype NegativeInteger = Negative Integer deriving (Eq,Show) newtype Long = Long Int64 deriving (Eq,Show) --data Int newtype Short = Short Int16 deriving (Eq,Show) newtype Byte = Byte Int8 deriving (Eq,Show) newtype NonNegativeInteger = NonNeg Integer deriving (Eq,Show) newtype UnsignedLong = ULong Word64 deriving (Eq,Show) newtype UnsignedInt = UInt Word32 deriving (Eq,Show) newtype UnsignedShort = UShort Word16 deriving (Eq,Show) newtype UnsignedByte = UByte Word8 deriving (Eq,Show) newtype PositiveInteger = Positive Integer deriving (Eq,Show) instance SimpleType Integer where acceptingParser = parse simpleTypeText = show instance SimpleType NonPositiveInteger where acceptingParser = fmap NonPos parse simpleTypeText (NonPos x) = show x instance SimpleType NegativeInteger where acceptingParser = fmap Negative parse simpleTypeText (Negative x) = show x instance SimpleType Long where acceptingParser = fmap (Long . fromInteger) parse simpleTypeText (Long x) = show x instance SimpleType Int where acceptingParser = parse simpleTypeText = show instance SimpleType Short where acceptingParser = fmap (Short . fromInteger) parse simpleTypeText (Short x) = show x instance SimpleType Byte where acceptingParser = fmap (Byte . fromInteger) parse simpleTypeText (Byte x) = show x instance SimpleType NonNegativeInteger where acceptingParser = fmap NonNeg parse simpleTypeText (NonNeg x) = show x instance SimpleType UnsignedLong where acceptingParser = fmap (ULong . fromInteger) parse simpleTypeText (ULong x) = show x instance SimpleType UnsignedInt where acceptingParser = fmap (UInt . fromInteger) parse simpleTypeText (UInt x) = show x instance SimpleType UnsignedShort where acceptingParser = fmap (UShort . fromInteger) parse simpleTypeText (UShort x) = show x instance SimpleType UnsignedByte where acceptingParser = fmap (UByte . fromInteger) parse simpleTypeText (UByte x) = show x instance SimpleType PositiveInteger where acceptingParser = fmap Positive parse simpleTypeText (Positive x) = show x HaXml-1.25.4/src/Text/XML/HaXml/Schema/Schema.hs0000644000000000000000000002336013122420334017120 0ustar0000000000000000{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, ExistentialQuantification #-} module Text.XML.HaXml.Schema.Schema ( SchemaType(..) , SimpleType(..) -- already exported by PrimitiveTypes , Extension(..) , Restricts(..) , FwdDecl(..) , getAttribute , between , Occurs(..) , parseSimpleType , parseText , AnyElement(..) , parseAnyElement -- , module Text.XML.HaXml.XmlContent.Parser -- no, just the things below , Content(..) , XMLParser(..) , posnElement , posnElementWith , element , interior , text , module Text.ParserCombinators.Poly , module Text.Parse -- , module Text.XML.HaXml.Schema.PrimitiveTypes , module Text.XML.HaXml.OneOfN , toXMLElement , toXMLText , toXMLAnyElement , toXMLAttribute , addXMLAttributes ) where import Text.ParserCombinators.Poly import Text.Parse import Text.XML.HaXml.Types import Text.XML.HaXml.Posn import Text.XML.HaXml.Namespaces (printableName) import Text.XML.HaXml.XmlContent.Parser hiding (Document,Reference) import Text.XML.HaXml.Schema.XSDTypeModel (Occurs(..)) import Text.XML.HaXml.Schema.PrimitiveTypes import Text.XML.HaXml.Schema.PrimitiveTypes as Prim import Text.XML.HaXml.OneOfN import Text.XML.HaXml.Verbatim -- | A SchemaType promises to interconvert between a generic XML -- content tree and a Haskell value, according to the rules of XSD. class SchemaType a where parseSchemaType :: String -> XMLParser a schemaTypeToXML :: String -> a -> [Content ()] -- | A type t can extend another type s by the addition of extra elements -- and/or attributes. s is therefore the supertype of t. class Extension t s {- - | t -> s -} where -- fundep ill-advised. supertype :: t -> s -- | A type t can restrict another type s, that is, t admits fewer values -- than s, but all the values t does admit also belong to the type s. class Restricts t s | t -> s where restricts :: t -> s -- | A trick to enable forward-declaration of a type that will be defined -- properly in another module, higher in the dependency graph. 'fd' is -- a dummy type e.g. the empty @data FwdA@, where 'a' is the proper -- @data A@, not yet available. class FwdDecl fd a | fd -> a -- | Given a TextParser for a SimpleType, make it into an XMLParser, i.e. -- consuming textual XML content as input rather than a String. parseSimpleType :: SimpleType t => XMLParser t parseSimpleType = do s <- text case runParser acceptingParser s of (Left err, _) -> fail err (Right v, "") -> return v (Right v, _) -> return v -- ignore trailing text -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- | Between is a list parser that tries to ensure that any range -- specification (min and max elements) is obeyed when parsing. between :: PolyParse p => Occurs -> p a -> p [a] between (Occurs Nothing Nothing) p = fmap (:[]) p between (Occurs (Just i) Nothing) p = return (++) `apply` exactly i p `apply` many p between (Occurs Nothing (Just j)) p = upto j p between (Occurs (Just i) (Just j)) p = return (++) `apply` exactly i p `apply` upto (j-i) p -- | Generated parsers will use 'getAttribute' as a convenient wrapper -- to lift a SchemaAttribute parser into an XMLParser. getAttribute :: (SimpleType a, Show a) => String -> Element Posn -> Posn -> XMLParser a getAttribute aname (Elem t as _) pos = case qnLookup aname as of Nothing -> fail $ "attribute missing: " ++ aname ++ " in element <" ++ printableName t ++ "> at " ++ show pos Just atv -> case runParser acceptingParser (attr2str atv) of (Right val, "") -> return val (Right val, rest) -> failBad $ "Bad attribute value for " ++ aname ++ " in element <" ++ printableName t ++ ">: got "++show val ++ "\n but trailing text: " ++ rest ++ "\n at " ++ show pos (Left err, rest) -> failBad $ err ++ " in attribute " ++ aname ++ " of element <" ++ printableName t ++ "> at " ++ show pos where qnLookup :: String -> [(QName,a)] -> Maybe a qnLookup s = Prelude.lookup s . map (\(qn,v)-> (printableName qn, v)) -- | The type. Parsing will always produce an "UnconvertedANY". data AnyElement = forall a . (SchemaType a, Show a) => ANYSchemaType a | UnconvertedANY (Content Posn) instance Show AnyElement where show (UnconvertedANY c) = "Unconverted "++ show (verbatim c) show (ANYSchemaType a) = "ANYSchemaType "++show a instance Eq AnyElement where a == b = show a == show b instance SchemaType AnyElement where parseSchemaType _ = parseAnyElement schemaTypeToXML _ = toXMLAnyElement parseAnyElement :: XMLParser AnyElement parseAnyElement = fmap UnconvertedANY next -- | Parse the textual part of mixed content parseText :: XMLParser String parseText = text -- from XmlContent.Parser `onFail` return "" -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- toXMLElement :: String -> [[Attribute]] -> [[Content ()]] -> [Content ()] toXMLElement name attrs content = [CElem (Elem (N name) (concat attrs) (concat content)) ()] toXMLText :: String -> [Content ()] toXMLText text = [CString False text ()] toXMLAnyElement :: AnyElement -> [Content ()] toXMLAnyElement (UnconvertedANY c) = [fmap (const ()) c] --toXMLAnyElement (ANYSchemaType x) = [c] toXMLAttribute :: (SimpleType a) => String -> a -> [Attribute] toXMLAttribute name val = [ (N name, AttValue [Left (simpleTypeText val)]) ] -- | For a ComplexType that is an extension of a SimpleType, it is necessary to -- convert the value to XML first, then add in the extra attributes that -- constitute the extension. addXMLAttributes :: [[Attribute]] -> [Content ()] -> [Content ()] addXMLAttributes extra [CElem (Elem n attrs content) ()] = [CElem (Elem n (attrs++concat extra) content) ()] addXMLAttributes _ x = x -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- {- examples -------- instance SchemaType FpMLSomething where parseSchemaType s = do (pos,e) <- posnElement [s] commit $ do a0 <- getAttribute "flirble" e pos a1 <- getAttribute "binky" e pos interior e $ do c0 <- parseSchemaType "foobar" c1 <- many $ parseSchemaType "quux" c2 <- optional $ parseSchemaType "doodad" c3 <- between (Occurs (Just 3) (Just 5)) $ parseSchemaType "rinta" c4 <- fmap OneOf2 (parseSchemaType "left") `onFail` fmap TwoOf2 (parseSchemaType "right") return $ FpMLSomething a0 a1 c0 c1 c2 c3 c4 schemaTypeToXML s x@FPMLSomething{} = toXMLElement s [ mkAttribute "flirble" (something_flirble x) , mkAttribute "binky" (something_binky x) ] [ schemaTypeToXML "foobar" (something_foobar x) , concatMap (schemaTypeToXML "quux") (something_quux x) , maybe [] (schemaTypeToXML "doodad") (something_doodad x) , concatMap (schemaTypeToXML "rinta") (something_rinta x) , foldOneOf2 (schemaTypeToXML "left") (schemaTypeToXML "right") (something_choice4 x) ] instance SimpleType FpMLNumber where acceptingParser = ... simpleTypeText = ... -} -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Ensure that all primitive/simple types can also be used as elements. #define SchemaInstance(TYPE) instance SchemaType TYPE where { parseSchemaType s = do { e <- element [s]; interior e $ parseSimpleType; }; schemaTypeToXML s x = toXMLElement s [] [toXMLText (simpleTypeText x)] } SchemaInstance(XsdString) SchemaInstance(Prim.Boolean) SchemaInstance(Prim.Base64Binary) SchemaInstance(Prim.HexBinary) SchemaInstance(Float) SchemaInstance(Decimal) SchemaInstance(Double) SchemaInstance(Prim.AnyURI) SchemaInstance(Prim.NOTATION) SchemaInstance(Prim.Duration) SchemaInstance(Prim.DateTime) SchemaInstance(Prim.Time) SchemaInstance(Prim.Date) SchemaInstance(Prim.GYearMonth) SchemaInstance(Prim.GYear) SchemaInstance(Prim.GMonthDay) SchemaInstance(Prim.GDay) SchemaInstance(Prim.GMonth) SchemaInstance(Prim.NormalizedString) SchemaInstance(Prim.Token) SchemaInstance(Prim.Language) SchemaInstance(Prim.Name) SchemaInstance(Prim.NCName) SchemaInstance(Prim.ID) SchemaInstance(Prim.IDREF) SchemaInstance(Prim.IDREFS) SchemaInstance(Prim.ENTITY) SchemaInstance(Prim.ENTITIES) SchemaInstance(Prim.NMTOKEN) SchemaInstance(Prim.NMTOKENS) SchemaInstance(Integer) SchemaInstance(Prim.NonPositiveInteger) SchemaInstance(Prim.NegativeInteger) SchemaInstance(Prim.Long) SchemaInstance(Int) SchemaInstance(Prim.Short) SchemaInstance(Prim.Byte) SchemaInstance(Prim.NonNegativeInteger) SchemaInstance(Prim.UnsignedLong) SchemaInstance(Prim.UnsignedInt) SchemaInstance(Prim.UnsignedShort) SchemaInstance(Prim.UnsignedByte) SchemaInstance(Prim.PositiveInteger) HaXml-1.25.4/src/Text/XML/HaXml/Schema/TypeConversion.hs0000644000000000000000000007416513122420334020720 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} module Text.XML.HaXml.Schema.TypeConversion ( module Text.XML.HaXml.Schema.TypeConversion ) where import Text.XML.HaXml.Types (QName(..),Name(..),Namespace(..)) import Text.XML.HaXml.Namespaces (printableName,localName) import Text.XML.HaXml.Schema.Environment import Text.XML.HaXml.Schema.XSDTypeModel as XSD import Text.XML.HaXml.Schema.HaskellTypeModel as Haskell import Text.XML.HaXml.Schema.NameConversion import Text.XML.HaXml.Schema.Parse (xsd) import qualified Data.Map as Map import Data.Map (Map) import Data.List (foldl') import Data.Maybe (fromMaybe,fromJust,isNothing,isJust) import Data.Monoid -- | Transform a Schema by lifting all locally-defined anonymous types to -- the top-level, naming them, and planting a referend at their original -- location. typeLift :: Schema -> Schema typeLift s = s{ schema_items = concat [ hoist e | SchemaElement e <- schema_items s ] ++ map renameLocals (schema_items s) } where hoist :: ElementDecl -> [SchemaItem] hoist e = flip concatMap (findE e) $ \e@ElementDecl{elem_nameOrRef=Left (NT{ theName=n {-, theType=Nothing-}})}-> localType n (elem_content e) findE :: ElementDecl -> [ElementDecl] findE e = ( case elem_nameOrRef e of Left (NT{theType=Nothing}) -> (e:) Left (NT{theType=Just t}) -> case elem_content e of Just (Right (ComplexType {complex_name=Just t'})) {--| t==t'-} -> (e:) _ -> id _ -> id ) $ ( case elem_content e of Nothing -> [] Just (Left _) -> [] Just (Right c) -> case complex_content c of v@SimpleContent{ci_stuff=Left (Restriction1 p)} -> particle p v@SimpleContent{ci_stuff=Right (Extension{extension_newstuff=PA p _ _})} -> particle p v@ComplexContent{ci_stuff=Left (Restriction1 p)} -> particle p v@ComplexContent{ci_stuff=Right (Extension{extension_newstuff=PA p _ _})} -> particle p v@ThisType{ci_thistype=PA p _ _} -> particle p ) particle Nothing = [] particle (Just (Left cos)) = choiceOrSeq cos particle (Just (Right g)) = maybe [] choiceOrSeq $ group_stuff g choiceOrSeq (XSD.All _ es) = concatMap findE es choiceOrSeq (XSD.Choice _ _ es) = concatMap etc es choiceOrSeq (XSD.Sequence _ _ es) = concatMap etc es etc (HasElement e) = findE e etc (HasGroup g) = maybe [] choiceOrSeq $ group_stuff g etc (HasCS cos) = choiceOrSeq cos etc (HasAny _) = [] localType n Nothing = [] localType n (Just (Left s)) = [Simple (renameSimple n s)] localType n (Just (Right c)) = [Complex c{ complex_name = Just n }] renameSimple n s@Primitive{} = s renameSimple n s@Restricted{} = s{ simple_name = Just n } renameSimple n s@ListOf{} = s{ simple_name = Just n } renameSimple n s@UnionOf{} = s{ simple_name = Just n } -- * For now, rather than walk the tree, giving typenames to nodes that were -- previously locally-typed, we will instead assume in the pretty-printer -- that it can always replace a missing typename with the element name, and -- have it resolve to something sensible. renameLocals :: SchemaItem -> SchemaItem renameLocals s = s -- renameLocals (SchemaElement e) -- | Left (NT{theName=n,theType=Nothing}) <- elem_nameOrRef e -- = SchemaElement e{ elem_nameOrRef = Left (NT{theName=n -- ,theType=Just n}) -- } -- -- still gotta do the recursive search + rename -- | Given an environment of schema type mappings, and a schema module, -- create a bunch of Decls that describe the types in a more -- Haskell-friendly way. convert :: Environment -> Schema -> [Haskell.Decl] convert env s = concatMap item (schema_items s) where item (Include loc ann) = [XSDInclude (xname loc) (comment ann)] item (Import uri loc ann) = [XSDImport (xname loc) (fmap xname $ Map.lookup uri (env_namespace env)) (comment ann)] item (Redefine _ _) = [] -- ignoring redefinitions for now item (Annotation ann) = [XSDComment (comment ann)] item (Simple st) = simple st item (Complex ct) = complex ct item (SchemaElement ed) = topElementDecl ed item (SchemaAttribute ad) = [] -- attributeDecl ad item (AttributeGroup ag) = [] -- attrgroup ag item (SchemaGroup g) = group g simple (Primitive prim) = [] simple s@(Restricted a n f r) | (Just enums) <- isEnumeration s = [EnumSimpleType (maybe (error "missing Name") xname n) enums (comment a) ] | otherwise = [RestrictSimpleType (maybe (error "missing Name") xname n) (maybe (xname "unknownSimple") XName (restrict_base r)) (mkRestrict r) (comment a)] simple (ListOf a n f t) = error "Not yet implemented: ListOf simpleType" -- [NamedSimpleType (xname n) (nameOfSimple s) -- (comment a)] simple s@(UnionOf a n f u m) | (Just enums) <- isEnumeration s = [EnumSimpleType (maybe (error "missing Name") xname n) enums (comment a) ] | otherwise = [UnionSimpleTypes (maybe (error "missing Name") xname n) (map (xname . printableName) m) -- XXX ignores content 'u' (comment a)] isEnumeration :: SimpleType -> Maybe [(XName,Comment)] isEnumeration (Primitive _) = Nothing isEnumeration (ListOf _ _ _ _) = Nothing isEnumeration (Restricted _ _ _ r) = case r of RestrictSim1 ann base r1 -> Nothing RestrictType _ _ _ facets -> let enum = [ (xname v, comment ann) | (Facet UnorderedEnumeration ann v _) <- facets ] in if null enum then Nothing else Just enum isEnumeration (UnionOf _ _ _ u ms) = squeeze [] ( flip map ms (\m-> case Map.lookup m (env_type env) of Just (Left s)-> isEnumeration s _ -> Nothing) ++ map isEnumeration u ) where squeeze _ (Nothing:_) = Nothing squeeze xs (Just ys:rest) = squeeze (xs++ys) rest squeeze xs [] = Just xs complex ct = let nx = N $ fromMaybe ("errorMissingName") (complex_name ct) n = XName nx in singleton $ case complex_content ct of c@SimpleContent{} -> case ci_stuff c of Left r -> RestrictSimpleType n ({-simple-}xname $ "Unimplemented") [] (comment (complex_annotation ct `mappend` ci_annotation c)) Right e -> ExtendSimpleType n ({-supertype-}XName $ extension_base e) ({-attrs-}snd $ particleAttrs $ extension_newstuff e) (comment (complex_annotation ct `mappend` ci_annotation c `mappend` extension_annotation e)) c@ComplexContent{} -> case ci_stuff c of Left r -> RestrictComplexType n ({-complex-}xname $ "Can'tBeRight") (comment (complex_annotation ct `mappend` ci_annotation c)) Right e -> let myLoc = fromMaybe "NUL" (Map.lookup nx (env_typeloc env)) supLoc = fromMaybe "NUL" (Map.lookup (extension_base e) (env_typeloc env)) in if complex_abstract ct then ExtendComplexTypeAbstract n ({-supertype-}XName $ extension_base e) ({-subtypes-} maybe (error ("ExtendComplexTypeAbstract "++show nx)) (map (\(t,l)->(XName t,if l/=myLoc then Just (xname l) else Nothing))) (Map.lookup nx (env_extendty env))) ({-fwddecl-}if myLoc/=supLoc then Just (xname supLoc) else Nothing) ({-grandsupers-} map XName $ repeatedly (supertypeOf env) nx) (comment (complex_annotation ct `mappend` ci_annotation c `mappend` extension_annotation e)) else let (es,as) = particleAttrs (extension_newstuff e) es' | ci_mixed c = mkMixedContent es | otherwise = es (oldEs,oldAs) = contentInfo $ Map.lookup (extension_base e) (env_type env) in ExtendComplexType n ({-supertype-}XName $ extension_base e) ({-supertype elems-}oldEs) ({-supertype attrs-}oldAs) ({-elems-}es) ({-attrs-}as) ({-fwddecl-}if myLoc/=supLoc then Just (xname supLoc) else Nothing) ({-abstract supertype-} maybe False (either (const False) complex_abstract) (Map.lookup (extension_base e) (env_type env))) ({-grandsupers-} map XName $ repeatedly (supertypeOf env) $ extension_base e) (comment (complex_annotation ct `mappend` ci_annotation c `mappend` extension_annotation e)) c@ThisType{} | complex_abstract ct -> let myLoc = fromMaybe "NUL" (Map.lookup nx (env_typeloc env)) in ElementsAttrsAbstract n {-all instance types: -} (map (\ (x,loc)->(XName x,if loc/=myLoc then Just (xname loc) else Nothing)) $ fromMaybe [] $ Map.lookup nx (env_extendty env)) (comment (complex_annotation ct)) c@ThisType{} | otherwise -> let (es,as) = particleAttrs (ci_thistype c) es' | complex_mixed ct = mkMixedContent es | otherwise = es in ElementsAttrs n es' as (comment (complex_annotation ct)) mkMixedContent [e@OneOf{}] = [e{ elem_oneOf = [Text]: elem_oneOf e }] mkMixedContent es = Text: concatMap (\e->[e,Text]) es topElementDecl :: XSD.ElementDecl -> [Haskell.Decl] topElementDecl ed = case elem_nameOrRef ed of Left n -> case theType n of Nothing -> --error "Not implemented: contentInfo on topElementDecl" --I'm pretty sure a topElementDecl can't be abstract... let (es,as) = contentInfo (elem_content ed) in [ ElementsAttrs ({-name-}xname $ theName n) ({-elems-}es) ({-attrs-}as) (comment (elem_annotation ed)) , ElementOfType $ elementDecl ed -- Element{ elem_name = xname (theName n) -- , elem_type = checkXName s (N $ theName n) -- , elem_modifier = -- occursToModifier (elem_occurs ed) -- , elem_byRef = False -- , elem_locals = [] -- , elem_substs = Nothing -- , elem_comment = -- (comment (elem_annotation ed)) -- } ] Just t | elem_abstract ed -> let nm = N $ theName n myLoc = fromMaybe "NUL" (Map.lookup nm (env_typeloc env)) in singleton $ ElementAbstractOfType (XName nm) (checkXName s t) (map (\ (x,loc)->(XName x,if loc/=myLoc then Just (xname loc) else Nothing)) $ fromMaybe [] $ Map.lookup nm (env_substGrp env)) (comment (elem_annotation ed)) Just t | otherwise -> singleton $ ElementOfType $ elementDecl ed -- Element{ elem_name = xname $ theName n -- , elem_type = checkXName s t -- , elem_modifier= -- occursToModifier (elem_occurs ed) -- , elem_byRef = False -- , elem_locals = [] -- , elem_substs = Nothing -- , elem_comment = comment (elem_annotation ed) -- } Right ref -> case Map.lookup ref (env_element env) of Nothing -> error $ " unknown element reference " ++printableName ref Just e' -> topElementDecl e' elementDecl :: XSD.ElementDecl -> Haskell.Element elementDecl ed = case elem_nameOrRef ed of Left n -> Element { elem_name = xname $ theName n , elem_type = maybe (localTypeExp ed) (checkXName s) (theType n) , elem_modifier = occursToModifier $ elem_occurs ed , elem_byRef = False -- by reference , elem_locals = [] -- internal Decl , elem_substs = Nothing -- substitution group -- , elem_substs = if elem_abstract ed -- then fmap (map XName) $ -- Map.lookup (N $ theName n) -- (env_substGrp env) -- else Nothing , elem_comment = comment $ elem_annotation ed } Right ref -> case Map.lookup ref (env_element env) of Just e' -> (elementDecl e') { elem_modifier = occursToModifier (elem_occurs ed) , elem_byRef = True } Nothing -> -- possible ref is imported qualified? case Map.lookup (N $ localName ref) (env_element env) of Just e' -> (elementDecl e') { elem_modifier = occursToModifier (elem_occurs ed) , elem_byRef = True } Nothing -> Element ({-name-}XName ref) -- best guess at type ({-type-}XName ref) (occursToModifier (elem_occurs ed)) True [] Nothing Nothing localTypeExp :: XSD.ElementDecl -> XName localTypeExp ed | isJust (elem_content ed) = case fromJust (elem_content ed) of Left st@Primitive{} -> xname "SomethingPrimitive" Left st@Restricted{} -> (\x-> maybe x xname (simple_name st)) $ (maybe (xname "GiveUp") XName $ restrict_base $ simple_restriction st) Left st@ListOf{} -> xname "SomethingListy" Left st@UnionOf{} -> xname "SomethingUnionLike" Right c@ComplexType{} -> maybe (localTypeExp ed{elem_content=Nothing}) xname $ complex_name c | otherwise = case elem_nameOrRef ed of Left n -> xname $ theName n Right _ -> xname $ "unknownElement" attributeDecl :: XSD.AttributeDecl -> [Haskell.Attribute] attributeDecl ad = case attr_nameOrRef ad of Left n -> singleton $ Attribute (xname $ theName n) (maybe (maybe (xname $ "String") -- guess at an attribute typename? --(error "XSD.attributeDecl->") nameOfSimple (attr_simpleType ad)) XName (theType n)) (attr_use ad == Required) (comment (attr_annotation ad)) Right ref -> case Map.lookup ref (env_attribute env) of Nothing -> error $ " unknown attribute reference " ++printableName ref Just a' -> attributeDecl a' attrgroup :: XSD.AttrGroup -> [Haskell.Attribute] attrgroup g = case attrgroup_nameOrRef g of Left n -> concatMap (either attributeDecl attrgroup) (attrgroup_stuff g) Right ref -> case Map.lookup ref (env_attrgroup env) of Nothing -> error $ "unknown attribute group reference " ++printableName ref Just g' -> attrgroup g' group :: XSD.Group -> [Haskell.Decl] group g = case group_nameOrRef g of Left n -> let ({-highs,-}es) = choiceOrSeq (fromMaybe (error "XSD.group") (group_stuff g)) in {-highs ++-} singleton $ Haskell.Group (xname n) (map (\e->e{elem_modifier= combineOccursModifier (group_occurs g) (elem_modifier e)}) es) (comment (group_annotation g)) Right ref -> case Map.lookup ref (env_group env) of -- Nothing -> error $ "bad group reference " -- ++printableName ref Nothing -> singleton $ Haskell.Group (xname ("unknown-group-"++printableName ref)) [] (comment (group_annotation g)) Just g' -> group g'{ group_occurs=group_occurs g } particleAttrs :: ParticleAttrs -> ([Haskell.Element],[Haskell.Attribute]) particleAttrs (PA part attrs _) = -- ignoring AnyAttr for now (particle part, concatMap (either attributeDecl attrgroup) attrs) particle :: Particle -> [Haskell.Element] -- XXX fix to ret Decls particle Nothing = [] particle (Just (Left cs)) = {-snd $-} choiceOrSeq cs particle (Just (Right g)) = let [Haskell.Group _ es _] = group g in es -- choiceOrSeq :: ChoiceOrSeq -> ([Haskell.Decl],[Haskell.Element]) choiceOrSeq :: ChoiceOrSeq -> [Haskell.Element] choiceOrSeq (XSD.All ann eds) = error "not yet implemented: XSD.All" choiceOrSeq (XSD.Choice ann o ees) = [ OneOf (anyToEnd (map elementEtc ees)) (occursToModifier o) (comment ann) ] choiceOrSeq (XSD.Sequence ann _ ees) = concatMap elementEtc ees elementEtc :: ElementEtc -> [Haskell.Element] elementEtc (HasElement ed) = [elementDecl ed] elementEtc (HasGroup g) = let [Haskell.Group _ es _] = group g in es elementEtc (HasCS cs) = choiceOrSeq cs elementEtc (HasAny a) = any a any :: XSD.Any -> [Haskell.Element] any a@XSD.Any{} = [Haskell.AnyElem { elem_modifier = occursToModifier (any_occurs a) , elem_comment = comment (any_annotation a) }] -- If an ANY element is part of a choice, ensure it is the last part. anyToEnd :: [[Haskell.Element]] -> [[Haskell.Element]] anyToEnd = go Nothing where go _ (e@[AnyElem{}]:[]) = e:[] go _ (e@[AnyElem{}]:es) = go (Just e) es go Nothing [] = [] go (Just e) [] = e:[] go m (e:es) = e:go m es contentInfo :: Maybe (Either SimpleType ComplexType) -> ([Haskell.Element],[Haskell.Attribute]) contentInfo Nothing = ([],[]) contentInfo (Just e) = either simple complex e where simple :: SimpleType -> ([Element],[Attribute]) complex :: ComplexType -> ([Element],[Attribute]) simple _ = ([], []) -- XXX clearly wrong -- simple (Primitive p) = ([], []) -- XXX clearly wrong -- simple (Restricted n _ _ _) = complex ct = case complex_content ct of SimpleContent{} -> ([],[]) -- XXX clearly wrong ci@ComplexContent{} -> either restr exten (ci_stuff ci) ThisType pa -> particleAttrs pa restr :: Restriction1 -> ([Element],[Attribute]) exten :: Extension -> ([Element],[Attribute]) restr (Restriction1 p) = (particle p,[]) exten e = let (oes,oas) = contentInfo (Map.lookup (extension_base e) (env_type env)) (nes,nas) = particleAttrs (extension_newstuff e) in (oes++nes, oas++nas) comment :: Annotation -> Comment comment (Documentation s) = Just s comment (AppInfo s) = Just s comment (NoAnnotation _) = Nothing xname :: String -> XName xname = XName . N checkXName :: Schema -> QName -> XName checkXName s n@(N _) = XName n checkXName s n@(QN ns m) | (Just uri) <- schema_targetNamespace s , nsURI ns == uri = XName $ N m | otherwise = XName n nameOfSimple :: SimpleType -> XName nameOfSimple (Primitive prim) = XName . xsd . show $ prim nameOfSimple (Restricted _ (Just n) _ _) = xname n nameOfSimple (ListOf _ (Just n) _ _) = xname n -- ("["++n++"]") nameOfSimple (UnionOf _ (Just n) _ _ _) = xname n -- return to this nameOfSimple s = xname "String" -- anonymous simple mkRestrict :: XSD.Restriction -> [Haskell.Restrict] mkRestrict (RestrictSim1 ann base r1) = [] -- = error "Not yet implemented: Restriction1 on simpletype" -- ^ This branch is not strictly correct. There ought to be some -- restrictions. mkRestrict (RestrictType _ _ _ facets) = (let occurs = [ (f,ann,v) | (Facet f ann v _) <- facets , f `elem` [OrderedBoundsMinIncl ,OrderedBoundsMinExcl ,OrderedBoundsMaxIncl ,OrderedBoundsMaxExcl] ] in if null occurs then [] else [Haskell.RangeR (foldl consolidate (Occurs Nothing Nothing) occurs) (comment $ foldr mappend mempty [ ann | (_,ann,_) <- occurs])] ) ++ [ Haskell.Pattern v (comment ann) | (Facet UnorderedPattern ann v _) <- facets ] ++ (let enum = [ (v,comment ann) | (Facet UnorderedEnumeration ann v _) <- facets ] in if null enum then [] else [Haskell.Enumeration enum] ) ++ (let occurs = [ (f,ann,v) | (Facet f ann v _) <- facets , f `elem` [UnorderedLength ,UnorderedMaxLength ,UnorderedMinLength] ] in if null occurs then [] else [Haskell.StrLength (foldl consolidate (Occurs Nothing Nothing) occurs) (comment $ foldr mappend mempty [ ann | (_,ann,_) <- occurs])] ) singleton :: a -> [a] singleton = (:[]) -- | Consolidate a Facet occurrence into a single Occurs value. consolidate :: Occurs -> (FacetType,Annotation,String) -> Occurs consolidate (Occurs min max) (OrderedBoundsMinIncl,_,n) = Occurs (Just (read n)) max consolidate (Occurs min max) (OrderedBoundsMinExcl,_,n) = Occurs (Just ((read n)+1)) max consolidate (Occurs min max) (OrderedBoundsMaxIncl,_,n) = Occurs min (Just (read n)) consolidate (Occurs min max) (OrderedBoundsMaxExcl,_,n) = Occurs min (Just ((read n)-1)) consolidate (Occurs min max) (UnorderedLength,_,n) = Occurs (Just (read n)) (Just (read n)) consolidate (Occurs min max) (UnorderedMinLength,_,n) = Occurs (Just (read n)) max consolidate (Occurs min max) (UnorderedMaxLength,_,n) = Occurs min (Just (read n)) instance Monoid Occurs where mempty = Occurs Nothing Nothing (Occurs Nothing Nothing) `mappend` o = o (Occurs (Just z) Nothing) `mappend` (Occurs min max) = Occurs (Just $ maybe z (*z) min) max (Occurs Nothing (Just x)) `mappend` (Occurs min max) = Occurs min (Just $ maybe x (*x) max) (Occurs (Just z) (Just x)) `mappend` (Occurs min max) = Occurs (Just $ maybe z (*z) min) (Just $ maybe x (*x) max) -- | Push another Occurs value inside an existing Modifier. combineOccursModifier :: Occurs -> Modifier -> Modifier combineOccursModifier o Haskell.Single = occursToModifier $ mappend o $ Occurs (Just 1) (Just 1) combineOccursModifier o Haskell.Optional = occursToModifier $ mappend o $ Occurs (Just 0) (Just 1) combineOccursModifier o (Haskell.Range o') = occursToModifier $ mappend o o' -- | Convert an occurs range to a Haskell-style type modifier (Maybe, List, Id) occursToModifier :: Occurs -> Modifier occursToModifier (Occurs Nothing Nothing) = Haskell.Single occursToModifier (Occurs (Just 0) Nothing) = Haskell.Optional occursToModifier (Occurs (Just 0) (Just 1)) = Haskell.Optional occursToModifier (Occurs (Just 1) (Just 1)) = Haskell.Single occursToModifier o = Haskell.Range o -- | Find the supertype (if it exists) of a given type name. supertypeOf :: Environment -> QName -> Maybe QName supertypeOf env t = do typ <- Map.lookup t (env_type env) a <- either (const Nothing) (Just . complex_content) typ b <- case a of ComplexContent{} -> Just (ci_stuff a) _ -> Nothing either (const Nothing) (Just . extension_base) b -- | Keep applying the function to transform the value, until it yields -- Nothing. Returns the sequence of transformed values. repeatedly :: (a->Maybe a) -> a -> [a] repeatedly f x = case f x of Nothing -> [] Just y -> y : repeatedly f y HaXml-1.25.4/src/Text/XML/HaXml/Schema/XSDTypeModel.hs0000644000000000000000000003160313122420334020200 0ustar0000000000000000module Text.XML.HaXml.Schema.XSDTypeModel ( module Text.XML.HaXml.Schema.XSDTypeModel ) where import Data.Monoid hiding (Any) import Text.XML.HaXml.Types (Name,Namespace,QName) data Schema = Schema -- { schema_annotation :: Annotation { schema_elementFormDefault :: QForm , schema_attributeFormDefault :: QForm , schema_finalDefault :: Maybe Final , schema_blockDefault :: Maybe Block , schema_targetNamespace :: Maybe TargetNamespace , schema_version :: Maybe String , schema_namespaces :: [Namespace] , schema_items :: [SchemaItem] } deriving (Eq,Show) data SchemaItem = Include SchemaLocation Annotation | Import URI SchemaLocation Annotation | Redefine SchemaLocation [SchemaItem] | Annotation Annotation -- | Simple SimpleType | Complex ComplexType | SchemaElement ElementDecl | SchemaAttribute AttributeDecl | AttributeGroup AttrGroup | SchemaGroup Group -- | Notation Name deriving (Eq,Show) -- The "simple type" model data SimpleType = Primitive { simple_primitive :: PrimitiveType } | Restricted { simple_annotation :: Annotation , simple_name :: Maybe Name , simple_final :: Maybe Final , simple_restriction :: Restriction } | ListOf { simple_annotation :: Annotation , simple_name :: Maybe Name , simple_final :: Maybe Final -- simpletype = element, qname = attribute , simple_type :: Either SimpleType QName } | UnionOf { simple_annotation :: Annotation , simple_name :: Maybe Name , simple_final :: Maybe Final -- union = elements , simple_union :: [SimpleType] -- members = attribute , simple_members :: [QName] } deriving (Eq,Show) data Restriction = RestrictSim1 { restrict_annotation :: Annotation , restrict_base :: Maybe QName , restrict_r1 :: Restriction1 } | RestrictType { restrict_annotation :: Annotation , restrict_base :: Maybe QName , restrict_type :: Maybe SimpleType , restrict_facets :: [Facet] } deriving (Eq,Show) data Facet = Facet { facet_facetType :: FacetType , facet_annotation :: Annotation , facet_facetValue :: String , facet_fixed :: Bool } deriving (Eq,Show) data FacetType = OrderedBoundsMinIncl | OrderedBoundsMinExcl | OrderedBoundsMaxIncl | OrderedBoundsMaxExcl | OrderedNumericTotalDigits | OrderedNumericFractionDigits | UnorderedPattern | UnorderedEnumeration | UnorderedWhitespace | UnorderedLength | UnorderedMaxLength | UnorderedMinLength deriving (Eq,Show) -- The "complex type" model data ComplexType = ComplexType { complex_annotation :: Annotation , complex_name :: Maybe Name , complex_abstract :: Bool , complex_final :: Maybe Final , complex_block :: Maybe Block , complex_mixed :: Bool , complex_content :: ComplexItem } deriving (Eq,Show) data ComplexItem = SimpleContent { ci_annotation :: Annotation , ci_stuff :: (Either Restriction1 Extension) } | ComplexContent { ci_annotation :: Annotation , ci_mixed :: Bool , ci_stuff :: (Either Restriction1 Extension) } | ThisType { ci_thistype :: ParticleAttrs } deriving (Eq,Show) data Restriction1 = Restriction1 Particle deriving (Eq,Show) data Extension = Extension { extension_annotation :: Annotation , extension_base :: QName , extension_newstuff :: ParticleAttrs } deriving (Eq,Show) type Particle = Maybe (Either ChoiceOrSeq Group) data ParticleAttrs = PA Particle [Either AttributeDecl AttrGroup] (Maybe AnyAttr) deriving (Eq,Show) data Group = Group { group_annotation :: Annotation , group_nameOrRef :: Either Name QName , group_occurs :: Occurs , group_stuff :: Maybe ChoiceOrSeq } deriving (Eq,Show) data ChoiceOrSeq = All Annotation [ElementDecl] | Choice Annotation Occurs [ElementEtc] | Sequence Annotation Occurs [ElementEtc] deriving (Eq,Show) data ElementEtc = HasElement ElementDecl | HasGroup Group | HasCS ChoiceOrSeq | HasAny Any deriving (Eq,Show) data Any = Any { any_annotation :: Annotation , any_namespace :: URI , any_processContents :: ProcessContents , any_occurs :: Occurs } deriving (Eq,Show) data AnyAttr = AnyAttr { anyattr_annotation :: Annotation , anyattr_namespace :: URI , anyattr_processContents :: ProcessContents } deriving (Eq,Show) data AttrGroup = AttrGroup { attrgroup_annotation :: Annotation , attrgroup_nameOrRef :: Either Name QName , attrgroup_stuff :: [Either AttributeDecl AttrGroup] } deriving (Eq,Show) data ElementDecl = ElementDecl { elem_annotation :: Annotation , elem_nameOrRef :: Either NameAndType QName , elem_occurs :: Occurs , elem_nillable :: Nillable , elem_substGroup :: Maybe QName , elem_abstract :: Bool , elem_final :: Maybe Final , elem_block :: Maybe Block , elem_form :: QForm , elem_content :: Maybe (Either SimpleType ComplexType) , elem_stuff :: [ UniqueKeyOrKeyRef ] } deriving (Eq,Show) data NameAndType = NT { theName :: Name, theType :: Maybe QName } deriving (Eq,Show) data AttributeDecl = AttributeDecl { attr_annotation :: Annotation , attr_nameOrRef :: Either NameAndType QName , attr_use :: Use , attr_defFixed :: Maybe (Either DefaultValue FixedValue) , attr_form :: QForm , attr_simpleType :: Maybe SimpleType } deriving (Eq,Show) data UniqueKeyOrKeyRef = U Unique | K Key | KR KeyRef deriving (Eq,Show) data Unique = Unique { unique_annotation :: Annotation , unique_name :: Name , unique_selector :: Selector , unique_fields :: [Field] } deriving (Eq,Show) data Key = Key { key_annotation :: Annotation , key_name :: Name , key_selector :: Selector , key_fields :: [Field] } deriving (Eq,Show) data KeyRef = KeyRef { keyref_annotation :: Annotation , keyref_name :: Name , keyref_refer :: QName , keyref_selector :: Selector , keyref_fields :: [Field] } deriving (Eq,Show) data Selector = Selector { selector_annotation :: Annotation , selector_xpath :: String } deriving (Eq,Show) data Field = Field { field_annotation :: Annotation , field_xpath :: String } deriving (Eq,Show) data Occurs = Occurs (Maybe Int) (Maybe Int) deriving (Eq,Show) data Use = Required | Optional | Prohibited -- (1,1) | (0,1) | (0,0) -- corresp. to Occurs values deriving (Eq,Show) data PrimitiveType = String | Boolean | Decimal | Float | Double | Duration | DateTime | Time | Date | GYearMonth | GYear | GMonthDay | GDay | GMonth | Base64Binary | HexBinary | AnyURI | QName | Notation deriving (Eq,Show) data MyRestriction = Range Occurs | Pattern Regexp | Enumeration [String] deriving (Eq,Show) type Mixed = Bool type Nillable = Bool type Fixed = Bool data Annotation = Documentation String | AppInfo String | NoAnnotation String deriving (Eq,Show) data QForm = Qualified | Unqualified -- only matters for locally decl'd deriving (Eq,Show) type TargetNamespace = URI data Final = NoExtension | NoRestriction | AllFinal deriving (Eq,Show) type Block = Final data ProcessContents = Skip | Lax | Strict deriving (Eq,Show) {- data Constraint = Unique Selector [Field] | Key Selector [Field] | KeyRef Selector [Field] deriving (Eq,Show) type Selector = String -- XPath query for scope of constraint type Field = String -- XPath query for entity being constrained -} -- check all of the following. type SchemaLocation= String type DefaultValue = String type FixedValue = String type Regexp = String type URI = String type TypeName = String instance Monoid Annotation where mempty = NoAnnotation "Monoid.mempty " (Documentation d) `mappend` (Documentation e) = Documentation (d++"\n"++e) _ `mappend` (Documentation e) = Documentation e ann `mappend` _ = ann -- This instance is pretty unsatisfactory, and is useful only for -- building environments involving recursive modules. The /mappend/ -- method is left-biased, and the /mempty/ value contains lots of -- undefined values. instance Monoid Schema where mempty = Schema{ schema_items=[] } s `mappend` t = s{ schema_items = schema_items s ++ schema_items t } HaXml-1.25.4/src/Text/XML/HaXml/XmlContent/0000755000000000000000000000000013122420334016253 5ustar0000000000000000HaXml-1.25.4/src/Text/XML/HaXml/XmlContent/Haskell.hs0000644000000000000000000002417713122420334020205 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/XmlContent/Parser.hs0000644000000000000000000006430213122420334020050 0ustar0000000000000000{-# 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.25.4/src/Text/XML/HaXml/Xtract/0000755000000000000000000000000013122420334015425 5ustar0000000000000000HaXml-1.25.4/src/Text/XML/HaXml/Xtract/Combinators.hs0000644000000000000000000000736513122420334020254 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/Xtract/Lex.hs0000644000000000000000000001225613122420334016517 0ustar0000000000000000-- | 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.25.4/src/Text/XML/HaXml/Xtract/Parse.hs0000644000000000000000000003111613122420334017035 0ustar0000000000000000-- | 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.25.4/src/tools/0000755000000000000000000000000013122420334012723 5ustar0000000000000000HaXml-1.25.4/src/tools/Canonicalise.hs0000644000000000000000000000167613122420334015661 0ustar0000000000000000module 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.25.4/src/tools/CanonicaliseLazy.hs0000644000000000000000000000213013122420334016503 0ustar0000000000000000module 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.25.4/src/tools/DtdToHaskell.hs0000644000000000000000000000546513122420334015613 0ustar0000000000000000module 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.25.4/src/tools/FpMLToHaskell.hs0000644000000000000000000002363713122420334015677 0ustar0000000000000000-- 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 Control.Exception as E 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 <- readFileUTF8 (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 hSetEncoding o utf8 hSetEncoding hb utf8 let decls = XsdToH.convert env (XsdToH.typeLift 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" -- | UTF8-clean readFile; avoids handle-leaks. readFileUTF8 :: FilePath -> IO String readFileUTF8 file = do h <- openFile file ReadMode (do hSetEncoding h utf8 hGetContents h) `E.onException` (hClose h) HaXml-1.25.4/src/tools/MkOneOf.hs0000644000000000000000000001071413122420334014560 0ustar0000000000000000module 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.25.4/src/tools/Validate.hs0000644000000000000000000000147013122420334015012 0ustar0000000000000000module 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.25.4/src/tools/XsdToHaskell.hs0000644000000000000000000001143013122420334015623 0ustar0000000000000000-- 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 o $ 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.25.4/src/tools/Xtract.hs0000644000000000000000000001013113122420334014520 0ustar0000000000000000------------------------------------------------------------ -- 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