diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,482 @@ + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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 library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + 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 Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, 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 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 a program 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. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, 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 companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + 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, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +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 compile 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) 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. + + c) 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. + + d) 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 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. + + 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 to +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 Library 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 + + Appendix: 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 Library General Public + License as published by the Free Software Foundation; either + version 2 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 + Library General Public License for more details. + + You should have received a copy of the GNU Library 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! diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,57 @@ +Please pick the right section in this file for instructions depending on how you optained the uuagc sources. + +IMPORTANT: We assume that you have the latest official release of GHC installed together with the accompanying Cabal package. For older GHC installations, rename: + uuagc.cabal-for-ghc-6.6 to uuagc.cabal + or upgrade to at least Cabal-1.2.x + + +------------------------------------------- +Installing uuagc from a source distribution +------------------------------------------- +Here we assume that you have downloaded the sources from http://www.cs.uu.nl/wiki/HUT/Download . + + ghc --make Setup.hs -o setup -package Cabal + ./setup configure + ./setup build + ./setup install + + The 1.0 release of Cabal has a bug that prevents + the installation step from succeeding. + You may prefer to use the following alternative: + + ./configure + make build + make install + +------------------------------- +Using the user package database +------------------------------- + + In the case that you registered uulib in your + user package database you may install uuagc + thusly: + + ghc --make Setup.hs -o setup -package Cabal + ./setup configure --user + ./setup build + ./setup install + + Or, alternatively: + + ./configure --with-user-pckg + make build + make install + +--------------------------------------------------------------- +Installing uuagc after checking out from the svn respository +--------------------------------------------------------------- +Please note that this is only possible if you alreday have a running version of the uuagc on your system. +This can be downloaded from: http://www.cs.uu.nl/wiki/HUT/Download + + First execute the steps below: + + autoconf + ./configure + make build + make install + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ + +import Distribution.Simple +main = defaultMain diff --git a/src-derived/AbstractSyntax.hs b/src-derived/AbstractSyntax.hs new file mode 100644 --- /dev/null +++ b/src-derived/AbstractSyntax.hs @@ -0,0 +1,117 @@ + +-- UUAGC 0.9.5 (AbstractSyntax.ag) +module AbstractSyntax where + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes +-- Alternative ------------------------------------------------- +{- + alternatives: + alternative Alternative: + child con : {Constructor} + child children : Children + child rules : Rules + child typeSigs : TypeSigs +-} +data Alternative = Alternative (Constructor) (Children) (Rules) (TypeSigs) +-- Alternatives ------------------------------------------------ +{- + alternatives: + alternative Cons: + child hd : Alternative + child tl : Alternatives + alternative Nil: +-} +type Alternatives = [Alternative] +-- Child ------------------------------------------------------- +{- + alternatives: + alternative Child: + child name : {Name} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child higherOrder : {Bool} +-} +data Child = Child (Name) (Type) (Attributes) (Attributes) (Bool) +-- Children ---------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : Child + child tl : Children + alternative Nil: +-} +type Children = [Child] +-- Grammar ----------------------------------------------------- +{- + alternatives: + alternative Grammar: + child typeSyns : {TypeSyns} + child useMap : {UseMap} + child derivings : {Derivings} + child wrappers : {Set Nonterminal} + child prods : Productions + child pragmas : {PragmaMap} + child manualAttrOrderMap : {AttrOrderMap} +-} +data Grammar = Grammar (TypeSyns) (UseMap) (Derivings) (Set Nonterminal) (Productions) (PragmaMap) (AttrOrderMap) +-- Production -------------------------------------------------- +{- + alternatives: + alternative Production: + child nt : {Nonterminal} + child inh : {Attributes} + child syn : {Attributes} + child alts : Alternatives +-} +data Production = Production (Nonterminal) (Attributes) (Attributes) (Alternatives) +-- Productions ------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : Production + child tl : Productions + alternative Nil: +-} +type Productions = [Production] +-- Rule -------------------------------------------------------- +{- + alternatives: + alternative Rule: + child pattern : {Pattern} + child rhs : {Expression} + child owrt : {Bool} + child origin : {String} +-} +data Rule = Rule (Pattern) (Expression) (Bool) (String) +-- Rules ------------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : Rule + child tl : Rules + alternative Nil: +-} +type Rules = [Rule] +-- TypeSig ----------------------------------------------------- +{- + alternatives: + alternative TypeSig: + child name : {Name} + child tp : {Type} +-} +data TypeSig = TypeSig (Name) (Type) +-- TypeSigs ---------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : TypeSig + child tl : TypeSigs + alternative Nil: +-} +type TypeSigs = [TypeSig] diff --git a/src-derived/AbstractSyntaxDump.hs b/src-derived/AbstractSyntaxDump.hs new file mode 100644 --- /dev/null +++ b/src-derived/AbstractSyntaxDump.hs @@ -0,0 +1,798 @@ + +-- UUAGC 0.9.5 (AbstractSyntaxDump.ag) +module AbstractSyntaxDump where + +import Data.List +import qualified Data.Map as Map + +import Pretty +import PPUtil + +import AbstractSyntax + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (Constructor,Name) + +import UU.Scanner.Position(Pos) +-- Alternative ------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Alternative: + child con : {Constructor} + child children : Children + child rules : Rules + child typeSigs : TypeSigs +-} +-- cata +sem_Alternative :: Alternative -> + T_Alternative +sem_Alternative (Alternative _con _children _rules _typeSigs ) = + (sem_Alternative_Alternative _con (sem_Children _children ) (sem_Rules _rules ) (sem_TypeSigs _typeSigs ) ) +-- semantic domain +newtype T_Alternative = T_Alternative (( PP_Doc)) +data Inh_Alternative = Inh_Alternative {} +data Syn_Alternative = Syn_Alternative {pp_Syn_Alternative :: PP_Doc} +wrap_Alternative (T_Alternative sem ) (Inh_Alternative ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_Alternative _lhsOpp )) +sem_Alternative_Alternative :: Constructor -> + T_Children -> + T_Rules -> + T_TypeSigs -> + T_Alternative +sem_Alternative_Alternative con_ (T_Children children_ ) (T_Rules rules_ ) (T_TypeSigs typeSigs_ ) = + (T_Alternative (let _lhsOpp :: PP_Doc + _childrenIpp :: PP_Doc + _childrenIppL :: ([PP_Doc]) + _rulesIpp :: PP_Doc + _rulesIppL :: ([PP_Doc]) + _typeSigsIpp :: PP_Doc + _typeSigsIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 31, column 25) + _lhsOpp = + ppNestInfo ["Alternative","Alternative"] [pp con_] [ppF "children" $ ppVList _childrenIppL,ppF "rules" $ ppVList _rulesIppL,ppF "typeSigs" $ ppVList _typeSigsIppL] [] + ( _childrenIpp,_childrenIppL) = + (children_ ) + ( _rulesIpp,_rulesIppL) = + (rules_ ) + ( _typeSigsIpp,_typeSigsIppL) = + (typeSigs_ ) + in ( _lhsOpp)) ) +-- Alternatives ------------------------------------------------ +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : Alternative + child tl : Alternatives + alternative Nil: +-} +-- cata +sem_Alternatives :: Alternatives -> + T_Alternatives +sem_Alternatives list = + (Prelude.foldr sem_Alternatives_Cons sem_Alternatives_Nil (Prelude.map sem_Alternative list) ) +-- semantic domain +newtype T_Alternatives = T_Alternatives (( PP_Doc,([PP_Doc]))) +data Inh_Alternatives = Inh_Alternatives {} +data Syn_Alternatives = Syn_Alternatives {pp_Syn_Alternatives :: PP_Doc,ppL_Syn_Alternatives :: [PP_Doc]} +wrap_Alternatives (T_Alternatives sem ) (Inh_Alternatives ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_Alternatives _lhsOpp _lhsOppL )) +sem_Alternatives_Cons :: T_Alternative -> + T_Alternatives -> + T_Alternatives +sem_Alternatives_Cons (T_Alternative hd_ ) (T_Alternatives tl_ ) = + (T_Alternatives (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 70, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL)) ) +sem_Alternatives_Nil :: T_Alternatives +sem_Alternatives_Nil = + (T_Alternatives (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "AbstractSyntaxDump.ag"(line 71, column 33) + _lhsOppL = + [] + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL)) ) +-- Child ------------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Child: + child name : {Name} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child higherOrder : {Bool} +-} +-- cata +sem_Child :: Child -> + T_Child +sem_Child (Child _name _tp _inh _syn _higherOrder ) = + (sem_Child_Child _name _tp _inh _syn _higherOrder ) +-- semantic domain +newtype T_Child = T_Child (( PP_Doc)) +data Inh_Child = Inh_Child {} +data Syn_Child = Syn_Child {pp_Syn_Child :: PP_Doc} +wrap_Child (T_Child sem ) (Inh_Child ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_Child _lhsOpp )) +sem_Child_Child :: Name -> + Type -> + Attributes -> + Attributes -> + Bool -> + T_Child +sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = + (T_Child (let _lhsOpp :: PP_Doc + -- "AbstractSyntaxDump.ag"(line 34, column 33) + _lhsOpp = + ppNestInfo ["Child","Child"] [pp name_, ppShow tp_] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_] [] + in ( _lhsOpp)) ) +-- Children ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : Child + child tl : Children + alternative Nil: +-} +-- cata +sem_Children :: Children -> + T_Children +sem_Children list = + (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) ) +-- semantic domain +newtype T_Children = T_Children (( PP_Doc,([PP_Doc]))) +data Inh_Children = Inh_Children {} +data Syn_Children = Syn_Children {pp_Syn_Children :: PP_Doc,ppL_Syn_Children :: [PP_Doc]} +wrap_Children (T_Children sem ) (Inh_Children ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_Children _lhsOpp _lhsOppL )) +sem_Children_Cons :: T_Child -> + T_Children -> + T_Children +sem_Children_Cons (T_Child hd_ ) (T_Children tl_ ) = + (T_Children (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 66, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL)) ) +sem_Children_Nil :: T_Children +sem_Children_Nil = + (T_Children (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "AbstractSyntaxDump.ag"(line 67, column 33) + _lhsOppL = + [] + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL)) ) +-- Expression -------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Expression: + child pos : {Pos} + child txt : {String} +-} +-- cata +sem_Expression :: Expression -> + T_Expression +sem_Expression (Expression _pos _txt ) = + (sem_Expression_Expression _pos _txt ) +-- semantic domain +newtype T_Expression = T_Expression (( PP_Doc)) +data Inh_Expression = Inh_Expression {} +data Syn_Expression = Syn_Expression {pp_Syn_Expression :: PP_Doc} +wrap_Expression (T_Expression sem ) (Inh_Expression ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_Expression _lhsOpp )) +sem_Expression_Expression :: Pos -> + String -> + T_Expression +sem_Expression_Expression pos_ txt_ = + (T_Expression (let _lhsOpp :: PP_Doc + -- "AbstractSyntaxDump.ag"(line 49, column 25) + _lhsOpp = + ppNestInfo ["Expression","Expression"] [ppShow pos_] [ppF "txt" $ text txt_] [] + in ( _lhsOpp)) ) +-- Grammar ----------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Grammar: + child typeSyns : {TypeSyns} + child useMap : {UseMap} + child derivings : {Derivings} + child wrappers : {Set Nonterminal} + child prods : Productions + child pragmas : {PragmaMap} + child manualAttrOrderMap : {AttrOrderMap} +-} +-- cata +sem_Grammar :: Grammar -> + T_Grammar +sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _prods _pragmas _manualAttrOrderMap ) = + (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Productions _prods ) _pragmas _manualAttrOrderMap ) +-- semantic domain +newtype T_Grammar = T_Grammar (( PP_Doc)) +data Inh_Grammar = Inh_Grammar {} +data Syn_Grammar = Syn_Grammar {pp_Syn_Grammar :: PP_Doc} +wrap_Grammar (T_Grammar sem ) (Inh_Grammar ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_Grammar _lhsOpp )) +sem_Grammar_Grammar :: TypeSyns -> + UseMap -> + Derivings -> + (Set Nonterminal) -> + T_Productions -> + PragmaMap -> + AttrOrderMap -> + T_Grammar +sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Productions prods_ ) pragmas_ manualAttrOrderMap_ = + (T_Grammar (let _lhsOpp :: PP_Doc + _prodsIpp :: PP_Doc + _prodsIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 19, column 25) + _lhsOpp = + ppNestInfo ["Grammar","Grammar"] [] + [ ppF "typeSyns" $ ppAssocL typeSyns_ + , ppF "useMap" $ ppMap $ Map.map ppMap $ useMap_ + , ppF "derivings" $ ppMap $ derivings_ + , ppF "wrappers" $ ppShow $ wrappers_ + , ppF "prods" $ ppVList _prodsIppL + ] [] + ( _prodsIpp,_prodsIppL) = + (prods_ ) + in ( _lhsOpp)) ) +-- Pattern ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + pp : PP_Doc + alternatives: + alternative Alias: + child field : {Name} + child attr : {Name} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + alternative Constr: + child name : {Constructor} + child pats : Patterns + visit 0: + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts ) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) +sem_Pattern (Constr _name _pats ) = + (sem_Pattern_Constr _name (sem_Patterns _pats ) ) +sem_Pattern (Product _pos _pats ) = + (sem_Pattern_Product _pos (sem_Patterns _pats ) ) +sem_Pattern (Underscore _pos ) = + (sem_Pattern_Underscore _pos ) +-- semantic domain +newtype T_Pattern = T_Pattern (( Pattern,PP_Doc)) +data Inh_Pattern = Inh_Pattern {} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,pp_Syn_Pattern :: PP_Doc} +wrap_Pattern (T_Pattern sem ) (Inh_Pattern ) = + (let ( _lhsOcopy,_lhsOpp) = + (sem ) + in (Syn_Pattern _lhsOcopy _lhsOpp )) +sem_Pattern_Alias :: Name -> + Name -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = + (T_Pattern (let _lhsOpp :: PP_Doc + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIpp :: PP_Doc + _partsIcopy :: Patterns + _partsIpp :: PP_Doc + _partsIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 45, column 33) + _lhsOpp = + ppNestInfo ["Pattern","Alias"] [pp field_, pp attr_] [ppF "pat" $ _patIpp] [] + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patIcopy,_patIpp) = + (pat_ ) + ( _partsIcopy,_partsIpp,_partsIppL) = + (parts_ ) + in ( _lhsOcopy,_lhsOpp)) ) +sem_Pattern_Constr :: Constructor -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_ ) = + (T_Pattern (let _lhsOpp :: PP_Doc + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIpp :: PP_Doc + _patsIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 43, column 33) + _lhsOpp = + ppNestInfo ["Pattern","Constr"] [pp name_] [ppF "pats" $ ppVList _patsIppL] [] + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIpp,_patsIppL) = + (pats_ ) + in ( _lhsOcopy,_lhsOpp)) ) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_ ) = + (T_Pattern (let _lhsOpp :: PP_Doc + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIpp :: PP_Doc + _patsIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 44, column 33) + _lhsOpp = + ppNestInfo ["Pattern","Product"] [ppShow pos_] [ppF "pats" $ ppVList _patsIppL] [] + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIpp,_patsIppL) = + (pats_ ) + in ( _lhsOcopy,_lhsOpp)) ) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (let _lhsOpp :: PP_Doc + _lhsOcopy :: Pattern + -- "AbstractSyntaxDump.ag"(line 46, column 25) + _lhsOpp = + ppNestInfo ["Pattern","Underscore"] [ppShow pos_] [] [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOpp)) ) +-- Patterns ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) +-- semantic domain +newtype T_Patterns = T_Patterns (( Patterns,PP_Doc,([PP_Doc]))) +data Inh_Patterns = Inh_Patterns {} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,pp_Syn_Patterns :: PP_Doc,ppL_Syn_Patterns :: [PP_Doc]} +wrap_Patterns (T_Patterns sem ) (Inh_Patterns ) = + (let ( _lhsOcopy,_lhsOpp,_lhsOppL) = + (sem ) + in (Syn_Patterns _lhsOcopy _lhsOpp _lhsOppL )) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = + (T_Patterns (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _lhsOcopy :: Patterns + _hdIcopy :: Pattern + _hdIpp :: PP_Doc + _tlIcopy :: Patterns + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 54, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + _hdIpp >-< _tlIpp + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _lhsOcopy = + _copy + ( _hdIcopy,_hdIpp) = + (hd_ ) + ( _tlIcopy,_tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOcopy,_lhsOpp,_lhsOppL)) ) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _lhsOcopy :: Patterns + -- "AbstractSyntaxDump.ag"(line 55, column 33) + _lhsOppL = + [] + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + empty + -- self rule + _copy = + [] + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOpp,_lhsOppL)) ) +-- Production -------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Production: + child nt : {Nonterminal} + child inh : {Attributes} + child syn : {Attributes} + child alts : Alternatives +-} +-- cata +sem_Production :: Production -> + T_Production +sem_Production (Production _nt _inh _syn _alts ) = + (sem_Production_Production _nt _inh _syn (sem_Alternatives _alts ) ) +-- semantic domain +newtype T_Production = T_Production (( PP_Doc)) +data Inh_Production = Inh_Production {} +data Syn_Production = Syn_Production {pp_Syn_Production :: PP_Doc} +wrap_Production (T_Production sem ) (Inh_Production ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_Production _lhsOpp )) +sem_Production_Production :: Nonterminal -> + Attributes -> + Attributes -> + T_Alternatives -> + T_Production +sem_Production_Production nt_ inh_ syn_ (T_Alternatives alts_ ) = + (T_Production (let _lhsOpp :: PP_Doc + _altsIpp :: PP_Doc + _altsIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 28, column 25) + _lhsOpp = + ppNestInfo ["Production","Production"] [pp nt_] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "alts" $ ppVList _altsIppL] [] + ( _altsIpp,_altsIppL) = + (alts_ ) + in ( _lhsOpp)) ) +-- Productions ------------------------------------------------- +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : Production + child tl : Productions + alternative Nil: +-} +-- cata +sem_Productions :: Productions -> + T_Productions +sem_Productions list = + (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) ) +-- semantic domain +newtype T_Productions = T_Productions (( PP_Doc,([PP_Doc]))) +data Inh_Productions = Inh_Productions {} +data Syn_Productions = Syn_Productions {pp_Syn_Productions :: PP_Doc,ppL_Syn_Productions :: [PP_Doc]} +wrap_Productions (T_Productions sem ) (Inh_Productions ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_Productions _lhsOpp _lhsOppL )) +sem_Productions_Cons :: T_Production -> + T_Productions -> + T_Productions +sem_Productions_Cons (T_Production hd_ ) (T_Productions tl_ ) = + (T_Productions (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 74, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL)) ) +sem_Productions_Nil :: T_Productions +sem_Productions_Nil = + (T_Productions (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "AbstractSyntaxDump.ag"(line 75, column 33) + _lhsOppL = + [] + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL)) ) +-- Rule -------------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Rule: + child pattern : Pattern + child rhs : Expression + child owrt : {Bool} + child origin : {String} +-} +-- cata +sem_Rule :: Rule -> + T_Rule +sem_Rule (Rule _pattern _rhs _owrt _origin ) = + (sem_Rule_Rule (sem_Pattern _pattern ) (sem_Expression _rhs ) _owrt _origin ) +-- semantic domain +newtype T_Rule = T_Rule (( PP_Doc)) +data Inh_Rule = Inh_Rule {} +data Syn_Rule = Syn_Rule {pp_Syn_Rule :: PP_Doc} +wrap_Rule (T_Rule sem ) (Inh_Rule ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_Rule _lhsOpp )) +sem_Rule_Rule :: T_Pattern -> + T_Expression -> + Bool -> + String -> + T_Rule +sem_Rule_Rule (T_Pattern pattern_ ) (T_Expression rhs_ ) owrt_ origin_ = + (T_Rule (let _lhsOpp :: PP_Doc + _patternIcopy :: Pattern + _patternIpp :: PP_Doc + _rhsIpp :: PP_Doc + -- "AbstractSyntaxDump.ag"(line 37, column 33) + _lhsOpp = + ppNestInfo ["Rule","Rule"] [ppShow owrt_, pp origin_] [ppF "pattern" $ _patternIpp, ppF "rhs" $ _rhsIpp] [] + ( _patternIcopy,_patternIpp) = + (pattern_ ) + ( _rhsIpp) = + (rhs_ ) + in ( _lhsOpp)) ) +-- Rules ------------------------------------------------------- +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : Rule + child tl : Rules + alternative Nil: +-} +-- cata +sem_Rules :: Rules -> + T_Rules +sem_Rules list = + (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) ) +-- semantic domain +newtype T_Rules = T_Rules (( PP_Doc,([PP_Doc]))) +data Inh_Rules = Inh_Rules {} +data Syn_Rules = Syn_Rules {pp_Syn_Rules :: PP_Doc,ppL_Syn_Rules :: [PP_Doc]} +wrap_Rules (T_Rules sem ) (Inh_Rules ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_Rules _lhsOpp _lhsOppL )) +sem_Rules_Cons :: T_Rule -> + T_Rules -> + T_Rules +sem_Rules_Cons (T_Rule hd_ ) (T_Rules tl_ ) = + (T_Rules (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 62, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL)) ) +sem_Rules_Nil :: T_Rules +sem_Rules_Nil = + (T_Rules (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "AbstractSyntaxDump.ag"(line 63, column 33) + _lhsOppL = + [] + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL)) ) +-- TypeSig ----------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative TypeSig: + child name : {Name} + child tp : {Type} +-} +-- cata +sem_TypeSig :: TypeSig -> + T_TypeSig +sem_TypeSig (TypeSig _name _tp ) = + (sem_TypeSig_TypeSig _name _tp ) +-- semantic domain +newtype T_TypeSig = T_TypeSig (( PP_Doc)) +data Inh_TypeSig = Inh_TypeSig {} +data Syn_TypeSig = Syn_TypeSig {pp_Syn_TypeSig :: PP_Doc} +wrap_TypeSig (T_TypeSig sem ) (Inh_TypeSig ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_TypeSig _lhsOpp )) +sem_TypeSig_TypeSig :: Name -> + Type -> + T_TypeSig +sem_TypeSig_TypeSig name_ tp_ = + (T_TypeSig (let _lhsOpp :: PP_Doc + -- "AbstractSyntaxDump.ag"(line 40, column 33) + _lhsOpp = + ppNestInfo ["TypeSig","TypeSig"] [pp name_, ppShow tp_] [] [] + in ( _lhsOpp)) ) +-- TypeSigs ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : TypeSig + child tl : TypeSigs + alternative Nil: +-} +-- cata +sem_TypeSigs :: TypeSigs -> + T_TypeSigs +sem_TypeSigs list = + (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) ) +-- semantic domain +newtype T_TypeSigs = T_TypeSigs (( PP_Doc,([PP_Doc]))) +data Inh_TypeSigs = Inh_TypeSigs {} +data Syn_TypeSigs = Syn_TypeSigs {pp_Syn_TypeSigs :: PP_Doc,ppL_Syn_TypeSigs :: [PP_Doc]} +wrap_TypeSigs (T_TypeSigs sem ) (Inh_TypeSigs ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_TypeSigs _lhsOpp _lhsOppL )) +sem_TypeSigs_Cons :: T_TypeSig -> + T_TypeSigs -> + T_TypeSigs +sem_TypeSigs_Cons (T_TypeSig hd_ ) (T_TypeSigs tl_ ) = + (T_TypeSigs (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 58, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL)) ) +sem_TypeSigs_Nil :: T_TypeSigs +sem_TypeSigs_Nil = + (T_TypeSigs (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "AbstractSyntaxDump.ag"(line 59, column 33) + _lhsOppL = + [] + -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL)) ) diff --git a/src-derived/Code.hs b/src-derived/Code.hs new file mode 100644 --- /dev/null +++ b/src-derived/Code.hs @@ -0,0 +1,243 @@ + +-- UUAGC 0.9.5 (Code.ag) +module Code where + +import Pretty +import Patterns +import Data.List(partition) +import Data.Set(Set) +import qualified UU.DData.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map + +-- Unboxed tuples +-- unbox Whether unboxed tuples are wanted or not +-- inh The inherited attributes. +-- If there are none, no unboxing can take place, +-- because in that case the semantic function (a top-level identifier) would have an unboxed type. +-- Of course we can't have an unboxed 1-tuple +mkTupleExpr :: Bool -> Bool -> Exprs -> Expr +mkTupleExpr unbox noInh exprs | not unbox || noInh || length exprs == 1 = TupleExpr exprs + | otherwise = UnboxedTupleExpr exprs +mkTupleType :: Bool -> Bool -> Types -> Type +mkTupleType unbox noInh tps | not unbox || noInh || length tps == 1 = TupleType tps + | otherwise = UnboxedTupleType tps +mkTupleLhs :: Bool -> Bool -> [String] -> Lhs +mkTupleLhs unbox noInh comps | not unbox || noInh || length comps == 1 = TupleLhs comps + | otherwise = UnboxedTupleLhs comps +-- CaseAlt ----------------------------------------------------- +{- + alternatives: + alternative CaseAlt: + child left : Lhs + child expr : Expr +-} +data CaseAlt = CaseAlt (Lhs) (Expr) +-- CaseAlts ---------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : CaseAlt + child tl : CaseAlts + alternative Nil: +-} +type CaseAlts = [CaseAlt] +-- Chunk ------------------------------------------------------- +{- + alternatives: + alternative Chunk: + child name : {String} + child comment : Decl + child info : Decls + child dataDef : Decls + child cataFun : Decls + child semDom : Decls + child semWrapper : Decls + child semFunctions : Decls + child semNames : {[String]} +-} +data Chunk = Chunk (String) (Decl) (Decls) (Decls) (Decls) (Decls) (Decls) (Decls) ([String]) +-- Chunks ------------------------------------------------------ +{- + alternatives: + alternative Cons: + child hd : Chunk + child tl : Chunks + alternative Nil: +-} +type Chunks = [Chunk] +-- DataAlt ----------------------------------------------------- +{- + alternatives: + alternative DataAlt: + child name : {String} + child args : {[String]} + alternative Record: + child name : {String} + child args : {[(String,String)]} +-} +data DataAlt = DataAlt (String) ([String]) + | Record (String) ([(String,String)]) +-- DataAlts ---------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : DataAlt + child tl : DataAlts + alternative Nil: +-} +type DataAlts = [DataAlt] +-- Decl -------------------------------------------------------- +{- + alternatives: + alternative Comment: + child txt : {String} + alternative Data: + child name : {String} + child alts : DataAlts + child strict : {Bool} + child derivings : {[String]} + alternative Decl: + child left : Lhs + child rhs : Expr + child binds : {Set String} + child uses : {Set String} + alternative NewType: + child name : {String} + child con : {String} + child tp : Type + alternative PragmaDecl: + child txt : {String} + alternative TSig: + child name : {String} + child tp : Type + alternative Type: + child name : {String} + child tp : Type +-} +data Decl = Comment (String) + | Data (String) (DataAlts) (Bool) ([String]) + | Decl (Lhs) (Expr) (Set String) (Set String) + | NewType (String) (String) (Type) + | PragmaDecl (String) + | TSig (String) (Type) + | Type (String) (Type) +-- Decls ------------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : Decl + child tl : Decls + alternative Nil: +-} +type Decls = [Decl] +-- Expr -------------------------------------------------------- +{- + alternatives: + alternative App: + child name : {String} + child args : Exprs + alternative Case: + child expr : Expr + child alts : CaseAlts + alternative Lambda: + child args : {[String]} + child body : Expr + alternative Let: + child decls : Decls + child body : Expr + alternative LineExpr: + child expr : Expr + alternative PragmaExpr: + child onLeftSide : {Bool} + child onNewLine : {Bool} + child txt : {String} + child expr : Expr + alternative SimpleExpr: + child txt : {String} + alternative TextExpr: + child lns : {[String]} + alternative Trace: + child txt : {String} + child expr : Expr + alternative TupleExpr: + child exprs : Exprs + alternative UnboxedTupleExpr: + child exprs : Exprs +-} +data Expr = App (String) (Exprs) + | Case (Expr) (CaseAlts) + | Lambda ([String]) (Expr) + | Let (Decls) (Expr) + | LineExpr (Expr) + | PragmaExpr (Bool) (Bool) (String) (Expr) + | SimpleExpr (String) + | TextExpr ([String]) + | Trace (String) (Expr) + | TupleExpr (Exprs) + | UnboxedTupleExpr (Exprs) +-- Exprs ------------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : Expr + child tl : Exprs + alternative Nil: +-} +type Exprs = [Expr] +-- Lhs --------------------------------------------------------- +{- + alternatives: + alternative Fun: + child name : {String} + child args : Exprs + alternative Pattern3: + child pat3 : {Pattern} + alternative Pattern3SM: + child pat3 : {Pattern} + alternative TupleLhs: + child comps : {[String]} + alternative UnboxedTupleLhs: + child comps : {[String]} +-} +data Lhs = Fun (String) (Exprs) + | Pattern3 (Pattern) + | Pattern3SM (Pattern) + | TupleLhs ([String]) + | UnboxedTupleLhs ([String]) +-- Program ----------------------------------------------------- +{- + alternatives: + alternative Program: + child chunks : Chunks +-} +data Program = Program (Chunks) +-- Type -------------------------------------------------------- +{- + alternatives: + alternative Arr: + child left : Type + child right : Type + alternative List: + child tp : Type + alternative SimpleType: + child txt : {String} + alternative TupleType: + child tps : Types + alternative UnboxedTupleType: + child tps : Types +-} +data Type = Arr (Type) (Type) + | List (Type) + | SimpleType (String) + | TupleType (Types) + | UnboxedTupleType (Types) +-- Types ------------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : Type + child tl : Types + alternative Nil: +-} +type Types = [Type] diff --git a/src-derived/CodeSyntax.hs b/src-derived/CodeSyntax.hs new file mode 100644 --- /dev/null +++ b/src-derived/CodeSyntax.hs @@ -0,0 +1,139 @@ + +-- UUAGC 0.9.5 (CodeSyntax.ag) +module CodeSyntax where + +import Patterns +import CommonTypes +import Data.Map(Map) +import Data.Set(Set) +-- CAlternative ------------------------------------------------ +{- + alternatives: + alternative CAlternative: + child con : {Constructor} + child visits : CVisits + child children : {[(Name,Type,Bool)]} + child terminals : {[Name]} +-} +data CAlternative = CAlternative (Constructor) (CVisits) ([(Name,Type,Bool)]) ([Name]) +-- CAlternatives ----------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : CAlternative + child tl : CAlternatives + alternative Nil: +-} +type CAlternatives = [CAlternative] +-- CGrammar ---------------------------------------------------- +{- + alternatives: + alternative CGrammar: + child typeSyns : {TypeSyns} + child derivings : {Derivings} + child wrappers : {Set Nonterminal} + child prods : CProductions + child pragmas : {PragmaMap} +-} +data CGrammar = CGrammar (TypeSyns) (Derivings) (Set Nonterminal) (CProductions) (PragmaMap) +-- CInterface -------------------------------------------------- +{- + alternatives: + alternative CInterface: + child seg : CSegments +-} +data CInterface = CInterface (CSegments) +-- CProduction ------------------------------------------------- +{- + alternatives: + alternative CProduction: + child nt : {Nonterminal} + child inh : {Attributes} + child syn : {Attributes} + child alts : CAlternatives + child inter : CInterface +-} +data CProduction = CProduction (Nonterminal) (Attributes) (Attributes) (CAlternatives) (CInterface) +-- CProductions ------------------------------------------------ +{- + alternatives: + alternative Cons: + child hd : CProduction + child tl : CProductions + alternative Nil: +-} +type CProductions = [CProduction] +-- CRule ------------------------------------------------------- +{- + alternatives: + alternative CChildVisit: + child name : {Name} + child nt : {Nonterminal} + child nr : {Int} + child inh : {Attributes} + child syn : {Attributes} + child isLast : {Bool} + alternative CRule: + child name : {Name} + child isIn : {Bool} + child hasCode : {Bool} + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child childnt : {Maybe Nonterminal} + child tp : {Maybe Type} + child pattern : {Pattern} + child rhs : {[String]} + child defines : {Map Int (Name,Name,Maybe Type)} + child owrt : {Bool} + child origin : {String} + child uses : {Set (Name, Name)} +-} +data CRule = CChildVisit (Name) (Nonterminal) (Int) (Attributes) (Attributes) (Bool) + | CRule (Name) (Bool) (Bool) (Nonterminal) (Constructor) (Name) (Maybe Nonterminal) (Maybe Type) (Pattern) ([String]) (Map Int (Name,Name,Maybe Type)) (Bool) (String) (Set (Name, Name)) +-- CSegment ---------------------------------------------------- +{- + alternatives: + alternative CSegment: + child inh : {Attributes} + child syn : {Attributes} +-} +data CSegment = CSegment (Attributes) (Attributes) +-- CSegments --------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : CSegment + child tl : CSegments + alternative Nil: +-} +type CSegments = [CSegment] +-- CVisit ------------------------------------------------------ +{- + alternatives: + alternative CVisit: + child inh : {Attributes} + child syn : {Attributes} + child vss : Sequence + child intra : Sequence + child ordered : {Bool} +-} +data CVisit = CVisit (Attributes) (Attributes) (Sequence) (Sequence) (Bool) +-- CVisits ----------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : CVisit + child tl : CVisits + alternative Nil: +-} +type CVisits = [CVisit] +-- Sequence ---------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : CRule + child tl : Sequence + alternative Nil: +-} +type Sequence = [CRule] diff --git a/src-derived/CodeSyntaxDump.hs b/src-derived/CodeSyntaxDump.hs new file mode 100644 --- /dev/null +++ b/src-derived/CodeSyntaxDump.hs @@ -0,0 +1,848 @@ + +-- UUAGC 0.9.5 (CodeSyntaxDump.ag) +module CodeSyntaxDump where + +import Data.List +import qualified Data.Map as Map + +import Pretty +import PPUtil + +import CodeSyntax + +import Patterns +import CommonTypes +import Data.Map(Map) +import Data.Set(Set) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (Constructor,Name) + +ppChild :: (Name,Type,Bool) -> PP_Doc +ppChild (nm,tp,b) + = pp nm >#< "::" >#< pp (show tp) >#< "<" >|< ppBool b >|< ">" + +ppVertexMap :: Map Int (Name,Name,Maybe Type) -> PP_Doc +ppVertexMap m + = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ] + +ppAttr :: (Name,Name,Maybe Type) -> PP_Doc +ppAttr (fld,nm,mTp) + = pp fld >|< "." >|< pp nm >#< + case mTp of + Just tp -> pp "::" >#< show tp + Nothing -> empty + +ppBool :: Bool -> PP_Doc +ppBool True = pp "T" +ppBool False = pp "F" + +ppMaybeShow :: Show a => Maybe a -> PP_Doc +ppMaybeShow (Just x) = pp (show x) +ppMaybeShow Nothing = pp "_" + +ppStrings :: [String] -> PP_Doc +ppStrings = vlist +-- CAlternative ------------------------------------------------ +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative CAlternative: + child con : {Constructor} + child visits : CVisits + child children : {[(Name,Type,Bool)]} + child terminals : {[Name]} +-} +-- cata +sem_CAlternative :: CAlternative -> + T_CAlternative +sem_CAlternative (CAlternative _con _visits _children _terminals ) = + (sem_CAlternative_CAlternative _con (sem_CVisits _visits ) _children _terminals ) +-- semantic domain +newtype T_CAlternative = T_CAlternative (( PP_Doc)) +data Inh_CAlternative = Inh_CAlternative {} +data Syn_CAlternative = Syn_CAlternative {pp_Syn_CAlternative :: PP_Doc} +wrap_CAlternative (T_CAlternative sem ) (Inh_CAlternative ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_CAlternative _lhsOpp )) +sem_CAlternative_CAlternative :: Constructor -> + T_CVisits -> + ([(Name,Type,Bool)]) -> + ([Name]) -> + T_CAlternative +sem_CAlternative_CAlternative con_ (T_CVisits visits_ ) children_ terminals_ = + (T_CAlternative (let _lhsOpp :: PP_Doc + _visitsIpp :: PP_Doc + _visitsIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 63, column 25) + _lhsOpp = + ppNestInfo ["CAlternative","CAlternative"] [pp con_] [ppF "visits" $ ppVList _visitsIppL, ppF "children" $ ppVList (map ppChild children_),ppF "terminals" $ ppVList (map ppShow terminals_)] [] + ( _visitsIpp,_visitsIppL) = + (visits_ ) + in ( _lhsOpp)) ) +-- CAlternatives ----------------------------------------------- +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : CAlternative + child tl : CAlternatives + alternative Nil: +-} +-- cata +sem_CAlternatives :: CAlternatives -> + T_CAlternatives +sem_CAlternatives list = + (Prelude.foldr sem_CAlternatives_Cons sem_CAlternatives_Nil (Prelude.map sem_CAlternative list) ) +-- semantic domain +newtype T_CAlternatives = T_CAlternatives (( PP_Doc,([PP_Doc]))) +data Inh_CAlternatives = Inh_CAlternatives {} +data Syn_CAlternatives = Syn_CAlternatives {pp_Syn_CAlternatives :: PP_Doc,ppL_Syn_CAlternatives :: [PP_Doc]} +wrap_CAlternatives (T_CAlternatives sem ) (Inh_CAlternatives ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_CAlternatives _lhsOpp _lhsOppL )) +sem_CAlternatives_Cons :: T_CAlternative -> + T_CAlternatives -> + T_CAlternatives +sem_CAlternatives_Cons (T_CAlternative hd_ ) (T_CAlternatives tl_ ) = + (T_CAlternatives (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 94, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL)) ) +sem_CAlternatives_Nil :: T_CAlternatives +sem_CAlternatives_Nil = + (T_CAlternatives (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "CodeSyntaxDump.ag"(line 95, column 33) + _lhsOppL = + [] + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL)) ) +-- CGrammar ---------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative CGrammar: + child typeSyns : {TypeSyns} + child derivings : {Derivings} + child wrappers : {Set Nonterminal} + child prods : CProductions + child pragmas : {PragmaMap} +-} +-- cata +sem_CGrammar :: CGrammar -> + T_CGrammar +sem_CGrammar (CGrammar _typeSyns _derivings _wrappers _prods _pragmas ) = + (sem_CGrammar_CGrammar _typeSyns _derivings _wrappers (sem_CProductions _prods ) _pragmas ) +-- semantic domain +newtype T_CGrammar = T_CGrammar (( PP_Doc)) +data Inh_CGrammar = Inh_CGrammar {} +data Syn_CGrammar = Syn_CGrammar {pp_Syn_CGrammar :: PP_Doc} +wrap_CGrammar (T_CGrammar sem ) (Inh_CGrammar ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_CGrammar _lhsOpp )) +sem_CGrammar_CGrammar :: TypeSyns -> + Derivings -> + (Set Nonterminal) -> + T_CProductions -> + PragmaMap -> + T_CGrammar +sem_CGrammar_CGrammar typeSyns_ derivings_ wrappers_ (T_CProductions prods_ ) pragmas_ = + (T_CGrammar (let _lhsOpp :: PP_Doc + _prodsIpp :: PP_Doc + _prodsIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 47, column 21) + _lhsOpp = + ppNestInfo ["CGrammar","CGrammar"] [] + [ ppF "typeSyns" $ ppAssocL typeSyns_ + , ppF "derivings" $ ppMap $ derivings_ + , ppF "prods" $ ppVList _prodsIppL + ] [] + ( _prodsIpp,_prodsIppL) = + (prods_ ) + in ( _lhsOpp)) ) +-- CInterface -------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative CInterface: + child seg : CSegments +-} +-- cata +sem_CInterface :: CInterface -> + T_CInterface +sem_CInterface (CInterface _seg ) = + (sem_CInterface_CInterface (sem_CSegments _seg ) ) +-- semantic domain +newtype T_CInterface = T_CInterface (( PP_Doc)) +data Inh_CInterface = Inh_CInterface {} +data Syn_CInterface = Syn_CInterface {pp_Syn_CInterface :: PP_Doc} +wrap_CInterface (T_CInterface sem ) (Inh_CInterface ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_CInterface _lhsOpp )) +sem_CInterface_CInterface :: T_CSegments -> + T_CInterface +sem_CInterface_CInterface (T_CSegments seg_ ) = + (T_CInterface (let _lhsOpp :: PP_Doc + _segIpp :: PP_Doc + _segIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 57, column 21) + _lhsOpp = + ppNestInfo ["CInterface","CInterface"] [] [ppF "seg" $ ppVList _segIppL] [] + ( _segIpp,_segIppL) = + (seg_ ) + in ( _lhsOpp)) ) +-- CProduction ------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative CProduction: + child nt : {Nonterminal} + child inh : {Attributes} + child syn : {Attributes} + child alts : CAlternatives + child inter : CInterface +-} +-- cata +sem_CProduction :: CProduction -> + T_CProduction +sem_CProduction (CProduction _nt _inh _syn _alts _inter ) = + (sem_CProduction_CProduction _nt _inh _syn (sem_CAlternatives _alts ) (sem_CInterface _inter ) ) +-- semantic domain +newtype T_CProduction = T_CProduction (( PP_Doc)) +data Inh_CProduction = Inh_CProduction {} +data Syn_CProduction = Syn_CProduction {pp_Syn_CProduction :: PP_Doc} +wrap_CProduction (T_CProduction sem ) (Inh_CProduction ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_CProduction _lhsOpp )) +sem_CProduction_CProduction :: Nonterminal -> + Attributes -> + Attributes -> + T_CAlternatives -> + T_CInterface -> + T_CProduction +sem_CProduction_CProduction nt_ inh_ syn_ (T_CAlternatives alts_ ) (T_CInterface inter_ ) = + (T_CProduction (let _lhsOpp :: PP_Doc + _altsIpp :: PP_Doc + _altsIppL :: ([PP_Doc]) + _interIpp :: PP_Doc + -- "CodeSyntaxDump.ag"(line 54, column 25) + _lhsOpp = + ppNestInfo ["CProduction","CProduction"] [pp nt_] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "alts" $ ppVList _altsIppL, ppF "inter" _interIpp] [] + ( _altsIpp,_altsIppL) = + (alts_ ) + ( _interIpp) = + (inter_ ) + in ( _lhsOpp)) ) +-- CProductions ------------------------------------------------ +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : CProduction + child tl : CProductions + alternative Nil: +-} +-- cata +sem_CProductions :: CProductions -> + T_CProductions +sem_CProductions list = + (Prelude.foldr sem_CProductions_Cons sem_CProductions_Nil (Prelude.map sem_CProduction list) ) +-- semantic domain +newtype T_CProductions = T_CProductions (( PP_Doc,([PP_Doc]))) +data Inh_CProductions = Inh_CProductions {} +data Syn_CProductions = Syn_CProductions {pp_Syn_CProductions :: PP_Doc,ppL_Syn_CProductions :: [PP_Doc]} +wrap_CProductions (T_CProductions sem ) (Inh_CProductions ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_CProductions _lhsOpp _lhsOppL )) +sem_CProductions_Cons :: T_CProduction -> + T_CProductions -> + T_CProductions +sem_CProductions_Cons (T_CProduction hd_ ) (T_CProductions tl_ ) = + (T_CProductions (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 102, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL)) ) +sem_CProductions_Nil :: T_CProductions +sem_CProductions_Nil = + (T_CProductions (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "CodeSyntaxDump.ag"(line 103, column 33) + _lhsOppL = + [] + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL)) ) +-- CRule ------------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative CChildVisit: + child name : {Name} + child nt : {Nonterminal} + child nr : {Int} + child inh : {Attributes} + child syn : {Attributes} + child isLast : {Bool} + alternative CRule: + child name : {Name} + child isIn : {Bool} + child hasCode : {Bool} + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child childnt : {Maybe Nonterminal} + child tp : {Maybe Type} + child pattern : Pattern + child rhs : {[String]} + child defines : {Map Int (Name,Name,Maybe Type)} + child owrt : {Bool} + child origin : {String} + child uses : {Set (Name, Name)} +-} +-- cata +sem_CRule :: CRule -> + T_CRule +sem_CRule (CChildVisit _name _nt _nr _inh _syn _isLast ) = + (sem_CRule_CChildVisit _name _nt _nr _inh _syn _isLast ) +sem_CRule (CRule _name _isIn _hasCode _nt _con _field _childnt _tp _pattern _rhs _defines _owrt _origin _uses ) = + (sem_CRule_CRule _name _isIn _hasCode _nt _con _field _childnt _tp (sem_Pattern _pattern ) _rhs _defines _owrt _origin _uses ) +-- semantic domain +newtype T_CRule = T_CRule (( PP_Doc)) +data Inh_CRule = Inh_CRule {} +data Syn_CRule = Syn_CRule {pp_Syn_CRule :: PP_Doc} +wrap_CRule (T_CRule sem ) (Inh_CRule ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_CRule _lhsOpp )) +sem_CRule_CChildVisit :: Name -> + Nonterminal -> + Int -> + Attributes -> + Attributes -> + Bool -> + T_CRule +sem_CRule_CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ = + (T_CRule (let _lhsOpp :: PP_Doc + -- "CodeSyntaxDump.ag"(line 70, column 21) + _lhsOpp = + ppNestInfo ["CRule","CChildVisit"] [pp name_] [ppF "nt" $ pp nt_, ppF "nr" $ ppShow nr_, ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "last" $ ppBool isLast_] [] + in ( _lhsOpp)) ) +sem_CRule_CRule :: Name -> + Bool -> + Bool -> + Nonterminal -> + Constructor -> + Name -> + (Maybe Nonterminal) -> + (Maybe Type) -> + T_Pattern -> + ([String]) -> + (Map Int (Name,Name,Maybe Type)) -> + Bool -> + String -> + (Set (Name, Name)) -> + T_CRule +sem_CRule_CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ (T_Pattern pattern_ ) rhs_ defines_ owrt_ origin_ uses_ = + (T_CRule (let _lhsOpp :: PP_Doc + _patternIcopy :: Pattern + _patternIpp :: PP_Doc + -- "CodeSyntaxDump.ag"(line 69, column 33) + _lhsOpp = + ppNestInfo ["CRule","CRule"] [pp name_] [ppF "isIn" $ ppBool isIn_, ppF "hasCode" $ ppBool hasCode_, ppF "nt" $ pp nt_, ppF "con" $ pp con_, ppF "field" $ pp field_, ppF "childnt" $ ppMaybeShow childnt_, ppF "tp" $ ppMaybeShow tp_, ppF "pattern" $ if isIn_ then pp "" else _patternIpp, ppF "rhs" $ ppStrings rhs_, ppF "defines" $ ppVertexMap defines_, ppF "owrt" $ ppBool owrt_, ppF "origin" $ pp origin_] [] + ( _patternIcopy,_patternIpp) = + (pattern_ ) + in ( _lhsOpp)) ) +-- CSegment ---------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative CSegment: + child inh : {Attributes} + child syn : {Attributes} +-} +-- cata +sem_CSegment :: CSegment -> + T_CSegment +sem_CSegment (CSegment _inh _syn ) = + (sem_CSegment_CSegment _inh _syn ) +-- semantic domain +newtype T_CSegment = T_CSegment (( PP_Doc)) +data Inh_CSegment = Inh_CSegment {} +data Syn_CSegment = Syn_CSegment {pp_Syn_CSegment :: PP_Doc} +wrap_CSegment (T_CSegment sem ) (Inh_CSegment ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_CSegment _lhsOpp )) +sem_CSegment_CSegment :: Attributes -> + Attributes -> + T_CSegment +sem_CSegment_CSegment inh_ syn_ = + (T_CSegment (let _lhsOpp :: PP_Doc + -- "CodeSyntaxDump.ag"(line 60, column 21) + _lhsOpp = + ppNestInfo ["CSegment","CSegment"] [] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_] [] + in ( _lhsOpp)) ) +-- CSegments --------------------------------------------------- +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : CSegment + child tl : CSegments + alternative Nil: +-} +-- cata +sem_CSegments :: CSegments -> + T_CSegments +sem_CSegments list = + (Prelude.foldr sem_CSegments_Cons sem_CSegments_Nil (Prelude.map sem_CSegment list) ) +-- semantic domain +newtype T_CSegments = T_CSegments (( PP_Doc,([PP_Doc]))) +data Inh_CSegments = Inh_CSegments {} +data Syn_CSegments = Syn_CSegments {pp_Syn_CSegments :: PP_Doc,ppL_Syn_CSegments :: [PP_Doc]} +wrap_CSegments (T_CSegments sem ) (Inh_CSegments ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_CSegments _lhsOpp _lhsOppL )) +sem_CSegments_Cons :: T_CSegment -> + T_CSegments -> + T_CSegments +sem_CSegments_Cons (T_CSegment hd_ ) (T_CSegments tl_ ) = + (T_CSegments (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 98, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL)) ) +sem_CSegments_Nil :: T_CSegments +sem_CSegments_Nil = + (T_CSegments (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "CodeSyntaxDump.ag"(line 99, column 33) + _lhsOppL = + [] + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL)) ) +-- CVisit ------------------------------------------------------ +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative CVisit: + child inh : {Attributes} + child syn : {Attributes} + child vss : Sequence + child intra : Sequence + child ordered : {Bool} +-} +-- cata +sem_CVisit :: CVisit -> + T_CVisit +sem_CVisit (CVisit _inh _syn _vss _intra _ordered ) = + (sem_CVisit_CVisit _inh _syn (sem_Sequence _vss ) (sem_Sequence _intra ) _ordered ) +-- semantic domain +newtype T_CVisit = T_CVisit (( PP_Doc)) +data Inh_CVisit = Inh_CVisit {} +data Syn_CVisit = Syn_CVisit {pp_Syn_CVisit :: PP_Doc} +wrap_CVisit (T_CVisit sem ) (Inh_CVisit ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_CVisit _lhsOpp )) +sem_CVisit_CVisit :: Attributes -> + Attributes -> + T_Sequence -> + T_Sequence -> + Bool -> + T_CVisit +sem_CVisit_CVisit inh_ syn_ (T_Sequence vss_ ) (T_Sequence intra_ ) ordered_ = + (T_CVisit (let _lhsOpp :: PP_Doc + _vssIppL :: ([PP_Doc]) + _intraIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 66, column 21) + _lhsOpp = + ppNestInfo ["CVisit","CVisit"] [] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "sequence" $ ppVList _vssIppL, ppF "intra" $ ppVList _intraIppL, ppF "ordered" $ ppBool ordered_] [] + ( _vssIppL) = + (vss_ ) + ( _intraIppL) = + (intra_ ) + in ( _lhsOpp)) ) +-- CVisits ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : CVisit + child tl : CVisits + alternative Nil: +-} +-- cata +sem_CVisits :: CVisits -> + T_CVisits +sem_CVisits list = + (Prelude.foldr sem_CVisits_Cons sem_CVisits_Nil (Prelude.map sem_CVisit list) ) +-- semantic domain +newtype T_CVisits = T_CVisits (( PP_Doc,([PP_Doc]))) +data Inh_CVisits = Inh_CVisits {} +data Syn_CVisits = Syn_CVisits {pp_Syn_CVisits :: PP_Doc,ppL_Syn_CVisits :: [PP_Doc]} +wrap_CVisits (T_CVisits sem ) (Inh_CVisits ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_CVisits _lhsOpp _lhsOppL )) +sem_CVisits_Cons :: T_CVisit -> + T_CVisits -> + T_CVisits +sem_CVisits_Cons (T_CVisit hd_ ) (T_CVisits tl_ ) = + (T_CVisits (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 90, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL)) ) +sem_CVisits_Nil :: T_CVisits +sem_CVisits_Nil = + (T_CVisits (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "CodeSyntaxDump.ag"(line 91, column 33) + _lhsOppL = + [] + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL)) ) +-- Pattern ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + pp : PP_Doc + alternatives: + alternative Alias: + child field : {Name} + child attr : {Name} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + alternative Constr: + child name : {Constructor} + child pats : Patterns + visit 0: + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts ) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) +sem_Pattern (Constr _name _pats ) = + (sem_Pattern_Constr _name (sem_Patterns _pats ) ) +sem_Pattern (Product _pos _pats ) = + (sem_Pattern_Product _pos (sem_Patterns _pats ) ) +sem_Pattern (Underscore _pos ) = + (sem_Pattern_Underscore _pos ) +-- semantic domain +newtype T_Pattern = T_Pattern (( Pattern,PP_Doc)) +data Inh_Pattern = Inh_Pattern {} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,pp_Syn_Pattern :: PP_Doc} +wrap_Pattern (T_Pattern sem ) (Inh_Pattern ) = + (let ( _lhsOcopy,_lhsOpp) = + (sem ) + in (Syn_Pattern _lhsOcopy _lhsOpp )) +sem_Pattern_Alias :: Name -> + Name -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = + (T_Pattern (let _lhsOpp :: PP_Doc + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIpp :: PP_Doc + _partsIcopy :: Patterns + _partsIpp :: PP_Doc + _partsIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 75, column 33) + _lhsOpp = + ppNestInfo ["Pattern","Alias"] [pp field_, pp attr_] [ppF "pat" $ _patIpp] [] + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patIcopy,_patIpp) = + (pat_ ) + ( _partsIcopy,_partsIpp,_partsIppL) = + (parts_ ) + in ( _lhsOcopy,_lhsOpp)) ) +sem_Pattern_Constr :: Constructor -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_ ) = + (T_Pattern (let _lhsOpp :: PP_Doc + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIpp :: PP_Doc + _patsIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 73, column 33) + _lhsOpp = + ppNestInfo ["Pattern","Constr"] [pp name_] [ppF "pats" $ ppVList _patsIppL] [] + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIpp,_patsIppL) = + (pats_ ) + in ( _lhsOcopy,_lhsOpp)) ) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_ ) = + (T_Pattern (let _lhsOpp :: PP_Doc + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIpp :: PP_Doc + _patsIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 74, column 33) + _lhsOpp = + ppNestInfo ["Pattern","Product"] [ppShow pos_] [ppF "pats" $ ppVList _patsIppL] [] + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIpp,_patsIppL) = + (pats_ ) + in ( _lhsOcopy,_lhsOpp)) ) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (let _lhsOpp :: PP_Doc + _lhsOcopy :: Pattern + -- "CodeSyntaxDump.ag"(line 76, column 25) + _lhsOpp = + ppNestInfo ["Pattern","Underscore"] [ppShow pos_] [] [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOpp)) ) +-- Patterns ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) +-- semantic domain +newtype T_Patterns = T_Patterns (( Patterns,PP_Doc,([PP_Doc]))) +data Inh_Patterns = Inh_Patterns {} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,pp_Syn_Patterns :: PP_Doc,ppL_Syn_Patterns :: [PP_Doc]} +wrap_Patterns (T_Patterns sem ) (Inh_Patterns ) = + (let ( _lhsOcopy,_lhsOpp,_lhsOppL) = + (sem ) + in (Syn_Patterns _lhsOcopy _lhsOpp _lhsOppL )) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = + (T_Patterns (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _lhsOcopy :: Patterns + _hdIcopy :: Pattern + _hdIpp :: PP_Doc + _tlIcopy :: Patterns + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 82, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + _hdIpp >-< _tlIpp + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _lhsOcopy = + _copy + ( _hdIcopy,_hdIpp) = + (hd_ ) + ( _tlIcopy,_tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOcopy,_lhsOpp,_lhsOppL)) ) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _lhsOcopy :: Patterns + -- "CodeSyntaxDump.ag"(line 83, column 33) + _lhsOppL = + [] + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + empty + -- self rule + _copy = + [] + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOpp,_lhsOppL)) ) +-- Sequence ---------------------------------------------------- +{- + visit 0: + synthesized attribute: + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : CRule + child tl : Sequence + alternative Nil: +-} +-- cata +sem_Sequence :: Sequence -> + T_Sequence +sem_Sequence list = + (Prelude.foldr sem_Sequence_Cons sem_Sequence_Nil (Prelude.map sem_CRule list) ) +-- semantic domain +newtype T_Sequence = T_Sequence (( ([PP_Doc]))) +data Inh_Sequence = Inh_Sequence {} +data Syn_Sequence = Syn_Sequence {ppL_Syn_Sequence :: [PP_Doc]} +wrap_Sequence (T_Sequence sem ) (Inh_Sequence ) = + (let ( _lhsOppL) = + (sem ) + in (Syn_Sequence _lhsOppL )) +sem_Sequence_Cons :: T_CRule -> + T_Sequence -> + T_Sequence +sem_Sequence_Cons (T_CRule hd_ ) (T_Sequence tl_ ) = + (T_Sequence (let _lhsOppL :: ([PP_Doc]) + _hdIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 86, column 33) + _lhsOppL = + _hdIpp : _tlIppL + ( _hdIpp) = + (hd_ ) + ( _tlIppL) = + (tl_ ) + in ( _lhsOppL)) ) +sem_Sequence_Nil :: T_Sequence +sem_Sequence_Nil = + (T_Sequence (let _lhsOppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 87, column 33) + _lhsOppL = + [] + in ( _lhsOppL)) ) diff --git a/src-derived/ConcreteSyntax.hs b/src-derived/ConcreteSyntax.hs new file mode 100644 --- /dev/null +++ b/src-derived/ConcreteSyntax.hs @@ -0,0 +1,197 @@ + +-- UUAGC 0.9.5 (ConcreteSyntax.ag) +module ConcreteSyntax where + +import UU.Scanner.Position (Pos) +import Patterns (Pattern) +import Expression (Expression) +import CommonTypes +-- AG ---------------------------------------------------------- +{- + alternatives: + alternative AG: + child elems : Elems +-} +data AG = AG (Elems) +-- Alt --------------------------------------------------------- +{- + alternatives: + alternative Alt: + child pos : {Pos} + child names : ConstructorSet + child fields : {Fields} +-} +data Alt = Alt (Pos) (ConstructorSet) (Fields) +-- Alts -------------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : Alt + child tl : Alts + alternative Nil: +-} +type Alts = [Alt] +-- Attrs ------------------------------------------------------- +{- + alternatives: + alternative Attrs: + child pos : {Pos} + child inh : {AttrNames} + child chn : {AttrNames} + child syn : {AttrNames} +-} +data Attrs = Attrs (Pos) (AttrNames) (AttrNames) (AttrNames) +-- ConstructorSet ---------------------------------------------- +{- + alternatives: + alternative CAll: + alternative CDifference: + child set1 : ConstructorSet + child set2 : ConstructorSet + alternative CName: + child name : {Constructor} + alternative CUnion: + child set1 : ConstructorSet + child set2 : ConstructorSet +-} +data ConstructorSet = CAll + | CDifference (ConstructorSet) (ConstructorSet) + | CName (Constructor) + | CUnion (ConstructorSet) (ConstructorSet) +-- Elem -------------------------------------------------------- +{- + alternatives: + alternative Attr: + child pos : {Pos} + child names : NontSet + child attrs : Attrs + alternative Data: + child pos : {Pos} + child names : NontSet + child attrs : Attrs + child alts : Alts + child ext : {Bool} + alternative Deriving: + child pos : {Pos} + child set : NontSet + child classes : {[Name]} + alternative Module: + child pos : {Pos} + child name : {String} + child exports : {String} + child imports : {String} + alternative Pragma: + child pos : {Pos} + child names : {[Name]} + alternative Sem: + child pos : {Pos} + child names : NontSet + child attrs : Attrs + child alts : SemAlts + alternative Set: + child pos : {Pos} + child name : {Name} + child set : NontSet + alternative Txt: + child pos : {Pos} + child name : {Name} + child lines : {[String]} + alternative Type: + child pos : {Pos} + child name : {Nonterminal} + child type : {ComplexType} + alternative Wrapper: + child pos : {Pos} + child set : NontSet +-} +data Elem = Attr (Pos) (NontSet) (Attrs) + | Data (Pos) (NontSet) (Attrs) (Alts) (Bool) + | Deriving (Pos) (NontSet) ([Name]) + | Module (Pos) (String) (String) (String) + | Pragma (Pos) ([Name]) + | Sem (Pos) (NontSet) (Attrs) (SemAlts) + | Set (Pos) (Name) (NontSet) + | Txt (Pos) (Name) ([String]) + | Type (Pos) (Nonterminal) (ComplexType) + | Wrapper (Pos) (NontSet) +-- Elems ------------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : Elem + child tl : Elems + alternative Nil: +-} +type Elems = [Elem] +-- NontSet ----------------------------------------------------- +{- + alternatives: + alternative All: + alternative Difference: + child set1 : NontSet + child set2 : NontSet + alternative Intersect: + child set1 : NontSet + child set2 : NontSet + alternative NamedSet: + child name : {Nonterminal} + alternative Path: + child from : {Nonterminal} + child to : {Nonterminal} + alternative Union: + child set1 : NontSet + child set2 : NontSet +-} +data NontSet = All + | Difference (NontSet) (NontSet) + | Intersect (NontSet) (NontSet) + | NamedSet (Nonterminal) + | Path (Nonterminal) (Nonterminal) + | Union (NontSet) (NontSet) +-- SemAlt ------------------------------------------------------ +{- + alternatives: + alternative SemAlt: + child pos : {Pos} + child constructorSet : ConstructorSet + child rules : SemDefs +-} +data SemAlt = SemAlt (Pos) (ConstructorSet) (SemDefs) +-- SemAlts ----------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : SemAlt + child tl : SemAlts + alternative Nil: +-} +type SemAlts = [SemAlt] +-- SemDef ------------------------------------------------------ +{- + alternatives: + alternative AttrOrderBefore: + child before : {(Identifier,Identifier)} + child after : {(Identifier,Identifier)} + alternative Def: + child pattern : {Pattern} + child rhs : {Expression} + child owrt : {Bool} + alternative SemPragma: + child names : {[Name]} + alternative TypeDef: + child ident : {Identifier} + child tp : {Type} +-} +data SemDef = AttrOrderBefore ((Identifier,Identifier)) ((Identifier,Identifier)) + | Def (Pattern) (Expression) (Bool) + | SemPragma ([Name]) + | TypeDef (Identifier) (Type) +-- SemDefs ----------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : SemDef + child tl : SemDefs + alternative Nil: +-} +type SemDefs = [SemDef] diff --git a/src-derived/DeclBlocks.hs b/src-derived/DeclBlocks.hs new file mode 100644 --- /dev/null +++ b/src-derived/DeclBlocks.hs @@ -0,0 +1,25 @@ + +-- UUAGC 0.9.5 (DeclBlocks.ag) +module DeclBlocks where + +import Code (Decl,Expr) +-- DeclBlocks -------------------------------------------------- +{- + alternatives: + alternative DeclBlock: + child defs : {[Decl]} + child visit : {Decl} + child next : DeclBlocks + alternative DeclTerminator: + child defs : {[Decl]} + child result : {Expr} +-} +data DeclBlocks = DeclBlock ([Decl]) (Decl) (DeclBlocks) + | DeclTerminator ([Decl]) (Expr) +-- DeclBlocksRoot ---------------------------------------------- +{- + alternatives: + alternative DeclBlocksRoot: + child blocks : DeclBlocks +-} +data DeclBlocksRoot = DeclBlocksRoot (DeclBlocks) diff --git a/src-derived/DefaultRules.hs b/src-derived/DefaultRules.hs new file mode 100644 --- /dev/null +++ b/src-derived/DefaultRules.hs @@ -0,0 +1,2034 @@ + +-- UUAGC 0.9.5 (DefaultRules.ag) +module DefaultRules where + +import qualified List (delete,intersperse) + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map(Map) +import qualified UU.DData.Seq as Seq +import UU.DData.Seq(Seq,(<>)) +import UU.Scanner.Position(noPos) +import Pretty +import Maybe + +import AbstractSyntax +import ErrorMessages + +import Options(Options,modcopy,rename) + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (Constructor,Name) + +fieldName n = '@' : getName n + +locName n = '@' : getName n + +attrName fld attr + | fld == _LOC = '@' : getName attr + | otherwise = '@' : getName fld ++ "." ++ getName attr + +_ACHILD = Ident "(" noPos -- hack + + +getConName typeSyns rename nt con1 + | nt `elem` map fst typeSyns = synonym + | otherwise = normalName + where con = getName con1 + normalName | rename = getName nt++"_"++ con + | otherwise = con + synonym | con == "Cons" = "(:)" + | con == "Nil" = "[]" + | con == "Just" = "Just" + | con == "Nothing" = "Nothing" + | otherwise = normalName + + + +concatSeq = foldr Seq.append Seq.empty + +splitAttrs :: Map Name a -> [Name] -> ([(Name,a)],[Name]) -- a used as (String,String) +splitAttrs _ [] + = ([],[]) +splitAttrs useMap (n:rest) + = let (uses,normals) = splitAttrs useMap rest + in case Map.lookup n useMap of + Just x -> ((n,x):uses , normals ) + Nothing -> ( uses , n:normals ) + +removeDefined :: Set (Name,Name) -> (Name,Attributes) -> (Name,[Name]) +removeDefined defined (fld,as) + = ( fld + , [ a + | a <- Map.keys as + , not (Set.member (fld,a) defined) + ] + ) + + + + + +deprecatedCopyRuleError nt con fld a + = let mesg = + "In the definitions for alternative" + >#< getName con + >#< "of nonterminal" + >#< getName nt + >|< "," + >-< "the value of field" + >#< getName a + >#< "is copied by a copy-rule." + >-< "Copying the value of a field using a copy-rule is deprecated" + >-< "Please add the following lines to your code:" + >-< ( "SEM" + >#< getName nt + >-< indent 2 ( "|" + >#< getName con + >#< getName fld + >#< "." + >#< a + >#< "=" + >#< "@" + >|< a + ) + ) + in CustomError True (getPos a) mesg + + +missingRuleErrorExpr nt con fld a + = "error \"missing rule: " + ++ show nt ++ "." ++ show con ++ "." + ++ show fld ++ "." ++ show a ++ "\"" + + + +makeRule :: (Name,Name) -> Expression -> String -> Rule +makeRule (f1,a1) expr origin + = Rule (Alias f1 a1 (Underscore noPos) []) + expr + False + origin + + +useRule :: Set Name -> [(Name,Attributes)] -> (Name,(String,String,String)) -> Rule +useRule locals ch_outs (n,(op,e,pos)) + = let elems = [ fld + | (fld,as) <- ch_outs + , Map.member n as + ] + + expr | Set.member n locals = attrName _LOC n + | null elems = e + | otherwise = foldr1 (\x y -> x ++ " " ++ op ++ " " ++ y) + (map (flip attrName n) elems) + + in makeRule (_LHS,n) + (Expression noPos expr) + ("use rule " ++ pos) + + + + +selfRule lhsNecLoc attr x + = let expr | lhsNecLoc = locName attr + | otherwise = x + + in makeRule (if lhsNecLoc then _LHS else _LOC,attr) + (Expression noPos expr) + "self rule" + + + + +concatRE rsess = let (rss,ess) = unzip rsess + in (concat rss, concatSeq ess) + + +copyRule :: Name -> Name -> Bool -> Set Name -> (Map Name Name, (Name,[Name])) -> ([Rule], Seq Error) +copyRule nt con modcopy locals (env,(fld,as)) + = concatRE (map copyRu as) + + where + copyRu a + = ( [ makeRule (fld,a) + (Expression noPos expr) + (cruletxt sel) + ] + , err + ) + + where + sel + | not modcopy + && Set.member a locals = Just _LOC + | otherwise = Map.lookup a env + + (expr,err) + = case sel of + Nothing -> ( missingRuleErrorExpr nt con fld a + , Seq.single (MissingRule nt con fld a) + ) + Just f + | f == _ACHILD -> ( fieldName a + , Seq.single (deprecatedCopyRuleError nt con fld a) + ) + | otherwise -> ( attrName f a + , Seq.empty + ) + + cruletxt sel + | local = "copy rule (from local)" + | deprChild = "deprecated child copy" + | Set.member a locals && nonlocal = "modified copy rule" + | incoming && outgoing = "copy rule (chain)" + | incoming = "copy rule (down)" + | outgoing = "copy rule (up)" + | otherwise = "copy rule (chain)" + where outgoing = fld == _LHS + incoming = maybe False (== _LHS) sel + nonlocal = maybe False (/= _LOC) sel + local = maybe False (== _LOC) sel + deprChild = maybe False (== _ACHILD) sel + +{- +multiRule replaces + loc.(a,b) = e +by + loc.tup1 = e + loc.(a,_) = @loc.tup1 + loc.(_,b) = @loc.tup1 +It needs to thread a unique number for inventing names for the tuples. + +It also works for nested tuples: + loc.(a,(b,c)) = e +becomes + loc.tup1 = e + loc.(a,_) = @loc.tup1 + loc.(_,tup2) = @loc.tup1 + loc.(b,_) = @loc.tup2 + loc.(_,c) = @loc.tup2 +-} + +multiRule :: Rule -> Int -> ([Rule], Int) +multiRule (Rule pat expr owrt origin) uniq + = let f :: (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int)) + f w e (Product pos pats) n + = let freshName = Ident ("_tup" ++ show n) pos + freshExpr = Expression pos (attrName _LOC freshName) + freshPat = Alias _LOC freshName (Underscore pos) pats + a = length pats - 1 + us b p = Product pos (replicate (a-b) (Underscore pos) ++ [p] ++ replicate b (Underscore pos)) + g :: Pattern -> ([Pattern],[Rule],Int) -> ([Pattern],[Rule],Int) + g p (xs1,rs1,n1) = let (x2,(rs2,n2)) = f (us (length xs1)) freshExpr p n1 + in (x2:xs1, rs2++rs1, n2) + (xs9,rs9,n9) = foldr g ([], [], n+1) pats + in ( freshPat + , ( Rule (w freshPat) e owrt origin : rs9 + , n9 + ) + ) + f w e p n + = ( p + , ( [Rule (w p) e owrt origin] + , n + ) + ) + in snd (f id expr pat uniq) + + +isDefined :: Map Name Attributes -> Identifier -> Identifier -> Bool +isDefined mp fld nm + = Map.member nm $ Map.findWithDefault Map.empty fld mp + +-- check that for a dependency a < b, that a is an In attribute +isInAttribute :: [(Name,Attributes)] -> Identifier -> Identifier -> Bool +isInAttribute allSyns fld nm + | fld == _INST || fld == _LOC || fld == _LHS + = True + | otherwise -- is nm it a synthesized attribute of fld? + = maybe False (Map.member nm) (lookup fld allSyns) +-- Alternative ------------------------------------------------- +{- + visit 0: + inherited attributes: + cr : Bool + inh : Attributes + manualAttrOrderMap : AttrOrderMap + nonterminals : Set Nonterminal + nt : Nonterminal + o_rename : Bool + syn : Attributes + typeSyns : TypeSyns + useMap : Map Name (String,String,String) + chained attribute: + uniq : Int + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Alternative: + child con : {Constructor} + child children : Children + child rules : Rules + child typeSigs : TypeSigs + visit 0: + local _tup1 : _ + local newRls : _ + local errs : _ + local orderDeps : _ + local allAttrsInScope : _ + local invalidOrderDepsErrors : _ + local undefinedAttributeInDepsErrors : _ + local orderErrs : _ + local output : _ +-} +-- cata +sem_Alternative :: Alternative -> + T_Alternative +sem_Alternative (Alternative _con _children _rules _typeSigs ) = + (sem_Alternative_Alternative _con (sem_Children _children ) (sem_Rules _rules ) (sem_TypeSigs _typeSigs ) ) +-- semantic domain +newtype T_Alternative = T_Alternative (Bool -> + Attributes -> + AttrOrderMap -> + (Set Nonterminal) -> + Nonterminal -> + Bool -> + Attributes -> + TypeSyns -> + Int -> + (Map Name (String,String,String)) -> + ( (Seq Error),Alternative,Int)) +data Inh_Alternative = Inh_Alternative {cr_Inh_Alternative :: Bool,inh_Inh_Alternative :: Attributes,manualAttrOrderMap_Inh_Alternative :: AttrOrderMap,nonterminals_Inh_Alternative :: Set Nonterminal,nt_Inh_Alternative :: Nonterminal,o_rename_Inh_Alternative :: Bool,syn_Inh_Alternative :: Attributes,typeSyns_Inh_Alternative :: TypeSyns,uniq_Inh_Alternative :: Int,useMap_Inh_Alternative :: Map Name (String,String,String)} +data Syn_Alternative = Syn_Alternative {errors_Syn_Alternative :: Seq Error,output_Syn_Alternative :: Alternative,uniq_Syn_Alternative :: Int} +wrap_Alternative (T_Alternative sem ) (Inh_Alternative _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap ) = + (let ( _lhsOerrors,_lhsOoutput,_lhsOuniq) = + (sem _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap ) + in (Syn_Alternative _lhsOerrors _lhsOoutput _lhsOuniq )) +sem_Alternative_Alternative :: Constructor -> + T_Children -> + T_Rules -> + T_TypeSigs -> + T_Alternative +sem_Alternative_Alternative con_ (T_Children children_ ) (T_Rules rules_ ) (T_TypeSigs typeSigs_ ) = + (T_Alternative (\ _lhsIcr + _lhsIinh + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsInt + _lhsIo_rename + _lhsIsyn + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _rulesOcon :: Constructor + _childrenOcon :: Constructor + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Alternative + _lhsOuniq :: Int + _childrenOcr :: Bool + _childrenOnt :: Nonterminal + _rulesOnt :: Nonterminal + _rulesOuniq :: Int + _childrenIerrors :: (Seq Error) + _childrenIfields :: ([(Name,Type,Bool)]) + _childrenIinputs :: ([(Name, Attributes)]) + _childrenIoutput :: Children + _childrenIoutputs :: ([(Name, Attributes)]) + _rulesIdefinedAttrs :: (Set (Name,Name)) + _rulesIerrors :: (Seq Error) + _rulesIlocals :: (Set Name) + _rulesIoutput :: Rules + _rulesIuniq :: Int + _typeSigsIoutput :: TypeSigs + -- "DefaultRules.ag"(line 135, column 17) + _rulesOcon = + con_ + -- "DefaultRules.ag"(line 136, column 17) + _childrenOcon = + con_ + -- "DefaultRules.ag"(line 295, column 4) + _lhsOerrors = + _childrenIerrors <> _errs <> _rulesIerrors <> _orderErrs + -- "DefaultRules.ag"(line 297, column 8) + __tup1 = + let locals = _rulesIlocals + initenv = Map.fromList ( [ (a,_ACHILD) + | (a,_,_) <- _childrenIfields + ] + ++ attrs(_LHS, _lhsIinh) + ++ [ (a,_LOC) + | a <- Set.toList locals + ] + ) + attrs (n,as) = [ (a,n) | a <- Map.keys as ] + envs = scanl (flip Map.union) + initenv + (map (Map.fromList . attrs ) _childrenIoutputs) + child_envs = init envs + lhs_env = last envs + (selfAttrs, normalAttrs) + = Map.partition (==NT _SELF) _lhsIsyn + (_,undefAttrs) + = removeDefined _rulesIdefinedAttrs (_LHS, normalAttrs) + (useAttrs,others) + = splitAttrs _lhsIuseMap undefAttrs + (rules1, errors1) + = concatRE $ map (copyRule _lhsInt con_ _lhsIcr locals) + (zip envs (map (removeDefined _rulesIdefinedAttrs) _childrenIinputs)) + uRules + = map (useRule locals _childrenIoutputs) useAttrs + selfLocRules + = [ selfRule False attr (constructor [childSelf attr nm tp | (nm,tp,ho) <- _childrenIfields, not ho]) + | attr <- Map.keys selfAttrs + , not (Set.member attr locals) + ] + where + childSelf self nm tp + = case tp of NT nt -> attrName nm self + _ | nm `Set.member` locals -> locname nm + | otherwise -> fieldName nm + constructor fs + | getName con_ == "Tuple" && _lhsInt `elem` map fst _lhsItypeSyns + = "(" ++ concat (List.intersperse "," fs) ++ ")" + | otherwise + = getConName _lhsItypeSyns _lhsIo_rename _lhsInt con_ ++ " " ++ unwords fs + selfRules + = [ selfRule True attr undefined + | attr <- Map.keys selfAttrs + , not (Set.member (_LHS,attr) _rulesIdefinedAttrs) + ] + (rules5, errs5) + = copyRule _lhsInt + con_ + _lhsIcr + locals + (lhs_env, (_LHS, others)) + in (uRules++selfLocRules++selfRules++rules5++rules1, errors1<>errs5) + -- "DefaultRules.ag"(line 297, column 8) + (_newRls,_) = + __tup1 + -- "DefaultRules.ag"(line 297, column 8) + (_,_errs) = + __tup1 + -- "DefaultRules.ag"(line 413, column 17) + _lhsOoutput = + Alternative con_ _childrenIoutput (_rulesIoutput ++ _newRls) _typeSigsIoutput + -- "DefaultRules.ag"(line 484, column 7) + _orderDeps = + Set.toList $ Map.findWithDefault Set.empty con_ $ Map.findWithDefault Map.empty _lhsInt _lhsImanualAttrOrderMap + -- "DefaultRules.ag"(line 486, column 7) + _allAttrsInScope = + Map.fromList ( [ (_LHS, _lhsIsyn `Map.union` _lhsIinh) + , (_LOC, Map.fromList [ (l,Haskell "LOC") | l <- Set.toList _rulesIlocals]) ] + ++ _childrenIinputs + ++ _childrenIoutputs + ) + -- "DefaultRules.ag"(line 493, column 7) + _invalidOrderDepsErrors = + [ ErroneousOrder _lhsInt con_ dep + | dep@(Dependency (fld,nm) _) <- _orderDeps + , not $ isInAttribute _childrenIoutputs fld nm + ] + -- "DefaultRules.ag"(line 499, column 7) + _undefinedAttributeInDepsErrors = + [ UndefAttr _lhsInt con_ fld nm + | (fld,nm) <- concatMap (\(Dependency a b) -> [a,b]) $ _orderDeps + , not $ isDefined _allAttrsInScope fld nm + ] + -- "DefaultRules.ag"(line 505, column 7) + _orderErrs = + if null _undefinedAttributeInDepsErrors + then Seq.fromList _invalidOrderDepsErrors + else Seq.fromList _undefinedAttributeInDepsErrors + -- self rule + _output = + Alternative con_ _childrenIoutput _rulesIoutput _typeSigsIoutput + -- copy rule (up) + _lhsOuniq = + _rulesIuniq + -- copy rule (down) + _childrenOcr = + _lhsIcr + -- copy rule (down) + _childrenOnt = + _lhsInt + -- copy rule (down) + _rulesOnt = + _lhsInt + -- copy rule (down) + _rulesOuniq = + _lhsIuniq + ( _childrenIerrors,_childrenIfields,_childrenIinputs,_childrenIoutput,_childrenIoutputs) = + (children_ _childrenOcon _childrenOcr _childrenOnt ) + ( _rulesIdefinedAttrs,_rulesIerrors,_rulesIlocals,_rulesIoutput,_rulesIuniq) = + (rules_ _rulesOcon _rulesOnt _rulesOuniq ) + ( _typeSigsIoutput) = + (typeSigs_ ) + in ( _lhsOerrors,_lhsOoutput,_lhsOuniq))) ) +-- Alternatives ------------------------------------------------ +{- + visit 0: + inherited attributes: + cr : Bool + inh : Attributes + manualAttrOrderMap : AttrOrderMap + nonterminals : Set Nonterminal + nt : Nonterminal + o_rename : Bool + syn : Attributes + typeSyns : TypeSyns + useMap : Map Name (String,String,String) + chained attribute: + uniq : Int + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Alternative + child tl : Alternatives + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Alternatives :: Alternatives -> + T_Alternatives +sem_Alternatives list = + (Prelude.foldr sem_Alternatives_Cons sem_Alternatives_Nil (Prelude.map sem_Alternative list) ) +-- semantic domain +newtype T_Alternatives = T_Alternatives (Bool -> + Attributes -> + AttrOrderMap -> + (Set Nonterminal) -> + Nonterminal -> + Bool -> + Attributes -> + TypeSyns -> + Int -> + (Map Name (String,String,String)) -> + ( (Seq Error),Alternatives,Int)) +data Inh_Alternatives = Inh_Alternatives {cr_Inh_Alternatives :: Bool,inh_Inh_Alternatives :: Attributes,manualAttrOrderMap_Inh_Alternatives :: AttrOrderMap,nonterminals_Inh_Alternatives :: Set Nonterminal,nt_Inh_Alternatives :: Nonterminal,o_rename_Inh_Alternatives :: Bool,syn_Inh_Alternatives :: Attributes,typeSyns_Inh_Alternatives :: TypeSyns,uniq_Inh_Alternatives :: Int,useMap_Inh_Alternatives :: Map Name (String,String,String)} +data Syn_Alternatives = Syn_Alternatives {errors_Syn_Alternatives :: Seq Error,output_Syn_Alternatives :: Alternatives,uniq_Syn_Alternatives :: Int} +wrap_Alternatives (T_Alternatives sem ) (Inh_Alternatives _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap ) = + (let ( _lhsOerrors,_lhsOoutput,_lhsOuniq) = + (sem _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap ) + in (Syn_Alternatives _lhsOerrors _lhsOoutput _lhsOuniq )) +sem_Alternatives_Cons :: T_Alternative -> + T_Alternatives -> + T_Alternatives +sem_Alternatives_Cons (T_Alternative hd_ ) (T_Alternatives tl_ ) = + (T_Alternatives (\ _lhsIcr + _lhsIinh + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsInt + _lhsIo_rename + _lhsIsyn + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Alternatives + _lhsOuniq :: Int + _hdOcr :: Bool + _hdOinh :: Attributes + _hdOmanualAttrOrderMap :: AttrOrderMap + _hdOnonterminals :: (Set Nonterminal) + _hdOnt :: Nonterminal + _hdOo_rename :: Bool + _hdOsyn :: Attributes + _hdOtypeSyns :: TypeSyns + _hdOuniq :: Int + _hdOuseMap :: (Map Name (String,String,String)) + _tlOcr :: Bool + _tlOinh :: Attributes + _tlOmanualAttrOrderMap :: AttrOrderMap + _tlOnonterminals :: (Set Nonterminal) + _tlOnt :: Nonterminal + _tlOo_rename :: Bool + _tlOsyn :: Attributes + _tlOtypeSyns :: TypeSyns + _tlOuniq :: Int + _tlOuseMap :: (Map Name (String,String,String)) + _hdIerrors :: (Seq Error) + _hdIoutput :: Alternative + _hdIuniq :: Int + _tlIerrors :: (Seq Error) + _tlIoutput :: Alternatives + _tlIuniq :: Int + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (up) + _lhsOuniq = + _tlIuniq + -- copy rule (down) + _hdOcr = + _lhsIcr + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOmanualAttrOrderMap = + _lhsImanualAttrOrderMap + -- copy rule (down) + _hdOnonterminals = + _lhsInonterminals + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOtypeSyns = + _lhsItypeSyns + -- copy rule (down) + _hdOuniq = + _lhsIuniq + -- copy rule (down) + _hdOuseMap = + _lhsIuseMap + -- copy rule (down) + _tlOcr = + _lhsIcr + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOmanualAttrOrderMap = + _lhsImanualAttrOrderMap + -- copy rule (down) + _tlOnonterminals = + _lhsInonterminals + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (down) + _tlOtypeSyns = + _lhsItypeSyns + -- copy rule (chain) + _tlOuniq = + _hdIuniq + -- copy rule (down) + _tlOuseMap = + _lhsIuseMap + ( _hdIerrors,_hdIoutput,_hdIuniq) = + (hd_ _hdOcr _hdOinh _hdOmanualAttrOrderMap _hdOnonterminals _hdOnt _hdOo_rename _hdOsyn _hdOtypeSyns _hdOuniq _hdOuseMap ) + ( _tlIerrors,_tlIoutput,_tlIuniq) = + (tl_ _tlOcr _tlOinh _tlOmanualAttrOrderMap _tlOnonterminals _tlOnt _tlOo_rename _tlOsyn _tlOtypeSyns _tlOuniq _tlOuseMap ) + in ( _lhsOerrors,_lhsOoutput,_lhsOuniq))) ) +sem_Alternatives_Nil :: T_Alternatives +sem_Alternatives_Nil = + (T_Alternatives (\ _lhsIcr + _lhsIinh + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsInt + _lhsIo_rename + _lhsIsyn + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Alternatives + _lhsOuniq :: Int + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + -- copy rule (chain) + _lhsOuniq = + _lhsIuniq + in ( _lhsOerrors,_lhsOoutput,_lhsOuniq))) ) +-- Child ------------------------------------------------------- +{- + visit 0: + inherited attributes: + con : Constructor + cr : Bool + nt : Nonterminal + synthesized attributes: + errors : Seq Error + field : (Name,Type,Bool) + inherited : Attributes + name : Name + output : SELF + synthesized : Attributes + alternatives: + alternative Child: + child name : {Name} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child higherOrder : {Bool} + visit 0: + local output : _ +-} +-- cata +sem_Child :: Child -> + T_Child +sem_Child (Child _name _tp _inh _syn _higherOrder ) = + (sem_Child_Child _name _tp _inh _syn _higherOrder ) +-- semantic domain +newtype T_Child = T_Child (Constructor -> + Bool -> + Nonterminal -> + ( (Seq Error),( (Name,Type,Bool) ),Attributes,Name,Child,Attributes)) +data Inh_Child = Inh_Child {con_Inh_Child :: Constructor,cr_Inh_Child :: Bool,nt_Inh_Child :: Nonterminal} +data Syn_Child = Syn_Child {errors_Syn_Child :: Seq Error,field_Syn_Child :: (Name,Type,Bool) ,inherited_Syn_Child :: Attributes,name_Syn_Child :: Name,output_Syn_Child :: Child,synthesized_Syn_Child :: Attributes} +wrap_Child (T_Child sem ) (Inh_Child _lhsIcon _lhsIcr _lhsInt ) = + (let ( _lhsOerrors,_lhsOfield,_lhsOinherited,_lhsOname,_lhsOoutput,_lhsOsynthesized) = + (sem _lhsIcon _lhsIcr _lhsInt ) + in (Syn_Child _lhsOerrors _lhsOfield _lhsOinherited _lhsOname _lhsOoutput _lhsOsynthesized )) +sem_Child_Child :: Name -> + Type -> + Attributes -> + Attributes -> + Bool -> + T_Child +sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = + (T_Child (\ _lhsIcon + _lhsIcr + _lhsInt -> + (let _lhsOname :: Name + _lhsOinherited :: Attributes + _lhsOsynthesized :: Attributes + _lhsOfield :: ( (Name,Type,Bool) ) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Child + -- "DefaultRules.ag"(line 138, column 11) + _lhsOname = + name_ + -- "DefaultRules.ag"(line 147, column 11) + _lhsOinherited = + inh_ + -- "DefaultRules.ag"(line 148, column 11) + _lhsOsynthesized = + syn_ + -- "DefaultRules.ag"(line 386, column 11) + _lhsOfield = + (name_,tp_,higherOrder_) + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + Seq.empty + -- self rule + _output = + Child name_ tp_ inh_ syn_ higherOrder_ + -- self rule + _lhsOoutput = + _output + in ( _lhsOerrors,_lhsOfield,_lhsOinherited,_lhsOname,_lhsOoutput,_lhsOsynthesized))) ) +-- Children ---------------------------------------------------- +{- + visit 0: + inherited attributes: + con : Constructor + cr : Bool + nt : Nonterminal + synthesized attributes: + errors : Seq Error + fields : [(Name,Type,Bool)] + inputs : [(Name, Attributes)] + output : SELF + outputs : [(Name, Attributes)] + alternatives: + alternative Cons: + child hd : Child + child tl : Children + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Children :: Children -> + T_Children +sem_Children list = + (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) ) +-- semantic domain +newtype T_Children = T_Children (Constructor -> + Bool -> + Nonterminal -> + ( (Seq Error),([(Name,Type,Bool)]),([(Name, Attributes)]),Children,([(Name, Attributes)]))) +data Inh_Children = Inh_Children {con_Inh_Children :: Constructor,cr_Inh_Children :: Bool,nt_Inh_Children :: Nonterminal} +data Syn_Children = Syn_Children {errors_Syn_Children :: Seq Error,fields_Syn_Children :: [(Name,Type,Bool)],inputs_Syn_Children :: [(Name, Attributes)],output_Syn_Children :: Children,outputs_Syn_Children :: [(Name, Attributes)]} +wrap_Children (T_Children sem ) (Inh_Children _lhsIcon _lhsIcr _lhsInt ) = + (let ( _lhsOerrors,_lhsOfields,_lhsOinputs,_lhsOoutput,_lhsOoutputs) = + (sem _lhsIcon _lhsIcr _lhsInt ) + in (Syn_Children _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutput _lhsOoutputs )) +sem_Children_Cons :: T_Child -> + T_Children -> + T_Children +sem_Children_Cons (T_Child hd_ ) (T_Children tl_ ) = + (T_Children (\ _lhsIcon + _lhsIcr + _lhsInt -> + (let _lhsOinputs :: ([(Name, Attributes)]) + _lhsOoutputs :: ([(Name, Attributes)]) + _lhsOfields :: ([(Name,Type,Bool)]) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Children + _hdOcon :: Constructor + _hdOcr :: Bool + _hdOnt :: Nonterminal + _tlOcon :: Constructor + _tlOcr :: Bool + _tlOnt :: Nonterminal + _hdIerrors :: (Seq Error) + _hdIfield :: ( (Name,Type,Bool) ) + _hdIinherited :: Attributes + _hdIname :: Name + _hdIoutput :: Child + _hdIsynthesized :: Attributes + _tlIerrors :: (Seq Error) + _tlIfields :: ([(Name,Type,Bool)]) + _tlIinputs :: ([(Name, Attributes)]) + _tlIoutput :: Children + _tlIoutputs :: ([(Name, Attributes)]) + -- "DefaultRules.ag"(line 151, column 10) + _lhsOinputs = + (_hdIname, _hdIinherited) : _tlIinputs + -- "DefaultRules.ag"(line 151, column 10) + _lhsOoutputs = + (_hdIname, _hdIsynthesized) : _tlIoutputs + -- "DefaultRules.ag"(line 382, column 10) + _lhsOfields = + _hdIfield : _tlIfields + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOcr = + _lhsIcr + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOcr = + _lhsIcr + -- copy rule (down) + _tlOnt = + _lhsInt + ( _hdIerrors,_hdIfield,_hdIinherited,_hdIname,_hdIoutput,_hdIsynthesized) = + (hd_ _hdOcon _hdOcr _hdOnt ) + ( _tlIerrors,_tlIfields,_tlIinputs,_tlIoutput,_tlIoutputs) = + (tl_ _tlOcon _tlOcr _tlOnt ) + in ( _lhsOerrors,_lhsOfields,_lhsOinputs,_lhsOoutput,_lhsOoutputs))) ) +sem_Children_Nil :: T_Children +sem_Children_Nil = + (T_Children (\ _lhsIcon + _lhsIcr + _lhsInt -> + (let _lhsOinputs :: ([(Name, Attributes)]) + _lhsOoutputs :: ([(Name, Attributes)]) + _lhsOfields :: ([(Name,Type,Bool)]) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Children + -- "DefaultRules.ag"(line 153, column 10) + _lhsOinputs = + [] + -- "DefaultRules.ag"(line 153, column 10) + _lhsOoutputs = + [] + -- "DefaultRules.ag"(line 383, column 10) + _lhsOfields = + [] + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOerrors,_lhsOfields,_lhsOinputs,_lhsOoutput,_lhsOoutputs))) ) +-- Grammar ----------------------------------------------------- +{- + visit 0: + inherited attribute: + options : Options + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Grammar: + child typeSyns : {TypeSyns} + child useMap : {UseMap} + child derivings : {Derivings} + child wrappers : {Set Nonterminal} + child prods : Productions + child pragmas : {PragmaMap} + child manualAttrOrderMap : {AttrOrderMap} + visit 0: + local output : _ +-} +-- cata +sem_Grammar :: Grammar -> + T_Grammar +sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _prods _pragmas _manualAttrOrderMap ) = + (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Productions _prods ) _pragmas _manualAttrOrderMap ) +-- semantic domain +newtype T_Grammar = T_Grammar (Options -> + ( (Seq Error),Grammar)) +data Inh_Grammar = Inh_Grammar {options_Inh_Grammar :: Options} +data Syn_Grammar = Syn_Grammar {errors_Syn_Grammar :: Seq Error,output_Syn_Grammar :: Grammar} +wrap_Grammar (T_Grammar sem ) (Inh_Grammar _lhsIoptions ) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsIoptions ) + in (Syn_Grammar _lhsOerrors _lhsOoutput )) +sem_Grammar_Grammar :: TypeSyns -> + UseMap -> + Derivings -> + (Set Nonterminal) -> + T_Productions -> + PragmaMap -> + AttrOrderMap -> + T_Grammar +sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Productions prods_ ) pragmas_ manualAttrOrderMap_ = + (T_Grammar (\ _lhsIoptions -> + (let _prodsOo_rename :: Bool + _prodsOcr :: Bool + _prodsOnonterminals :: (Set Nonterminal) + _prodsOuseMap :: UseMap + _prodsOtypeSyns :: TypeSyns + _prodsOuniq :: Int + _prodsOmanualAttrOrderMap :: AttrOrderMap + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Grammar + _prodsIcollect_nts :: (Set Nonterminal) + _prodsIerrors :: (Seq Error) + _prodsIoutput :: Productions + _prodsIuniq :: Int + -- "DefaultRules.ag"(line 41, column 17) + _prodsOo_rename = + rename _lhsIoptions + -- "DefaultRules.ag"(line 42, column 17) + _prodsOcr = + modcopy _lhsIoptions + -- "DefaultRules.ag"(line 119, column 13) + _prodsOnonterminals = + _prodsIcollect_nts + -- "DefaultRules.ag"(line 140, column 13) + _prodsOuseMap = + useMap_ + -- "DefaultRules.ag"(line 142, column 13) + _prodsOtypeSyns = + typeSyns_ + -- "DefaultRules.ag"(line 403, column 13) + _prodsOuniq = + 1 + -- "DefaultRules.ag"(line 479, column 7) + _prodsOmanualAttrOrderMap = + manualAttrOrderMap_ + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _prodsIerrors + -- self rule + _output = + Grammar typeSyns_ useMap_ derivings_ wrappers_ _prodsIoutput pragmas_ manualAttrOrderMap_ + -- self rule + _lhsOoutput = + _output + ( _prodsIcollect_nts,_prodsIerrors,_prodsIoutput,_prodsIuniq) = + (prods_ _prodsOcr _prodsOmanualAttrOrderMap _prodsOnonterminals _prodsOo_rename _prodsOtypeSyns _prodsOuniq _prodsOuseMap ) + in ( _lhsOerrors,_lhsOoutput))) ) +-- Pattern ----------------------------------------------------- +{- + visit 0: + inherited attributes: + con : Constructor + nt : Nonterminal + synthesized attributes: + containsVars : Bool + copy : SELF + definedAttrs : Set (Name,Name) + errors : Seq Error + locals : Set Name + output : SELF + alternatives: + alternative Alias: + child field : {Name} + child attr : {Name} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + local output : _ + alternative Constr: + child name : {Constructor} + child pats : Patterns + visit 0: + local copy : _ + local output : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + local output : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ + local output : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts ) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) +sem_Pattern (Constr _name _pats ) = + (sem_Pattern_Constr _name (sem_Patterns _pats ) ) +sem_Pattern (Product _pos _pats ) = + (sem_Pattern_Product _pos (sem_Patterns _pats ) ) +sem_Pattern (Underscore _pos ) = + (sem_Pattern_Underscore _pos ) +-- semantic domain +newtype T_Pattern = T_Pattern (Constructor -> + Nonterminal -> + ( Bool,Pattern,(Set (Name,Name)),(Seq Error),(Set Name),Pattern)) +data Inh_Pattern = Inh_Pattern {con_Inh_Pattern :: Constructor,nt_Inh_Pattern :: Nonterminal} +data Syn_Pattern = Syn_Pattern {containsVars_Syn_Pattern :: Bool,copy_Syn_Pattern :: Pattern,definedAttrs_Syn_Pattern :: Set (Name,Name),errors_Syn_Pattern :: Seq Error,locals_Syn_Pattern :: Set Name,output_Syn_Pattern :: Pattern} +wrap_Pattern (T_Pattern sem ) (Inh_Pattern _lhsIcon _lhsInt ) = + (let ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput) = + (sem _lhsIcon _lhsInt ) + in (Syn_Pattern _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput )) +sem_Pattern_Alias :: Name -> + Name -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = + (T_Pattern (\ _lhsIcon + _lhsInt -> + (let _lhsOdefinedAttrs :: (Set (Name,Name)) + _lhsOlocals :: (Set Name) + _lhsOcontainsVars :: Bool + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patOcon :: Constructor + _patOnt :: Nonterminal + _partsOcon :: Constructor + _partsOnt :: Nonterminal + _patIcontainsVars :: Bool + _patIcopy :: Pattern + _patIdefinedAttrs :: (Set (Name,Name)) + _patIerrors :: (Seq Error) + _patIlocals :: (Set Name) + _patIoutput :: Pattern + _partsIcontainsVars :: Bool + _partsIcopy :: Patterns + _partsIdefinedAttrs :: (Set (Name,Name)) + _partsIerrors :: (Seq Error) + _partsIlocals :: (Set Name) + _partsIoutput :: Patterns + -- "DefaultRules.ag"(line 376, column 11) + _lhsOdefinedAttrs = + Set.insert (field_,attr_) _patIdefinedAttrs + -- "DefaultRules.ag"(line 376, column 11) + _lhsOlocals = + if field_ == _LOC + then Set.insert attr_ _patIlocals + else _patIlocals + -- "DefaultRules.ag"(line 394, column 16) + _lhsOcontainsVars = + True + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _patIerrors Seq.<> _partsIerrors + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _output = + Alias field_ attr_ _patIoutput _partsIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patOcon = + _lhsIcon + -- copy rule (down) + _patOnt = + _lhsInt + -- copy rule (down) + _partsOcon = + _lhsIcon + -- copy rule (down) + _partsOnt = + _lhsInt + ( _patIcontainsVars,_patIcopy,_patIdefinedAttrs,_patIerrors,_patIlocals,_patIoutput) = + (pat_ _patOcon _patOnt ) + ( _partsIcontainsVars,_partsIcopy,_partsIdefinedAttrs,_partsIerrors,_partsIlocals,_partsIoutput) = + (parts_ _partsOcon _partsOnt ) + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) +sem_Pattern_Constr :: Constructor -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_ ) = + (T_Pattern (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Name,Name)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Name) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patsOcon :: Constructor + _patsOnt :: Nonterminal + _patsIcontainsVars :: Bool + _patsIcopy :: Patterns + _patsIdefinedAttrs :: (Set (Name,Name)) + _patsIerrors :: (Seq Error) + _patsIlocals :: (Set Name) + _patsIoutput :: Patterns + -- use rule "DefaultRules.ag"(line 391, column 46) + _lhsOcontainsVars = + _patsIcontainsVars + -- use rule "DefaultRules.ag"(line 371, column 23) + _lhsOdefinedAttrs = + _patsIdefinedAttrs + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _patsIerrors + -- use rule "DefaultRules.ag"(line 370, column 23) + _lhsOlocals = + _patsIlocals + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _output = + Constr name_ _patsIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOnt = + _lhsInt + ( _patsIcontainsVars,_patsIcopy,_patsIdefinedAttrs,_patsIerrors,_patsIlocals,_patsIoutput) = + (pats_ _patsOcon _patsOnt ) + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_ ) = + (T_Pattern (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Name,Name)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Name) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patsOcon :: Constructor + _patsOnt :: Nonterminal + _patsIcontainsVars :: Bool + _patsIcopy :: Patterns + _patsIdefinedAttrs :: (Set (Name,Name)) + _patsIerrors :: (Seq Error) + _patsIlocals :: (Set Name) + _patsIoutput :: Patterns + -- use rule "DefaultRules.ag"(line 391, column 46) + _lhsOcontainsVars = + _patsIcontainsVars + -- use rule "DefaultRules.ag"(line 371, column 23) + _lhsOdefinedAttrs = + _patsIdefinedAttrs + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _patsIerrors + -- use rule "DefaultRules.ag"(line 370, column 23) + _lhsOlocals = + _patsIlocals + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _output = + Product pos_ _patsIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOnt = + _lhsInt + ( _patsIcontainsVars,_patsIcopy,_patsIdefinedAttrs,_patsIerrors,_patsIlocals,_patsIoutput) = + (pats_ _patsOcon _patsOnt ) + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Name,Name)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Name) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + -- use rule "DefaultRules.ag"(line 391, column 46) + _lhsOcontainsVars = + False + -- use rule "DefaultRules.ag"(line 371, column 23) + _lhsOdefinedAttrs = + Set.empty + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + Seq.empty + -- use rule "DefaultRules.ag"(line 370, column 23) + _lhsOlocals = + Set.empty + -- self rule + _copy = + Underscore pos_ + -- self rule + _output = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) +-- Patterns ---------------------------------------------------- +{- + visit 0: + inherited attributes: + con : Constructor + nt : Nonterminal + synthesized attributes: + containsVars : Bool + copy : SELF + definedAttrs : Set (Name,Name) + errors : Seq Error + locals : Set Name + output : SELF + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + local output : _ + alternative Nil: + visit 0: + local copy : _ + local output : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) +-- semantic domain +newtype T_Patterns = T_Patterns (Constructor -> + Nonterminal -> + ( Bool,Patterns,(Set (Name,Name)),(Seq Error),(Set Name),Patterns)) +data Inh_Patterns = Inh_Patterns {con_Inh_Patterns :: Constructor,nt_Inh_Patterns :: Nonterminal} +data Syn_Patterns = Syn_Patterns {containsVars_Syn_Patterns :: Bool,copy_Syn_Patterns :: Patterns,definedAttrs_Syn_Patterns :: Set (Name,Name),errors_Syn_Patterns :: Seq Error,locals_Syn_Patterns :: Set Name,output_Syn_Patterns :: Patterns} +wrap_Patterns (T_Patterns sem ) (Inh_Patterns _lhsIcon _lhsInt ) = + (let ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput) = + (sem _lhsIcon _lhsInt ) + in (Syn_Patterns _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput )) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = + (T_Patterns (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Name,Name)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Name) + _lhsOcopy :: Patterns + _lhsOoutput :: Patterns + _hdOcon :: Constructor + _hdOnt :: Nonterminal + _tlOcon :: Constructor + _tlOnt :: Nonterminal + _hdIcontainsVars :: Bool + _hdIcopy :: Pattern + _hdIdefinedAttrs :: (Set (Name,Name)) + _hdIerrors :: (Seq Error) + _hdIlocals :: (Set Name) + _hdIoutput :: Pattern + _tlIcontainsVars :: Bool + _tlIcopy :: Patterns + _tlIdefinedAttrs :: (Set (Name,Name)) + _tlIerrors :: (Seq Error) + _tlIlocals :: (Set Name) + _tlIoutput :: Patterns + -- use rule "DefaultRules.ag"(line 391, column 46) + _lhsOcontainsVars = + _hdIcontainsVars || _tlIcontainsVars + -- use rule "DefaultRules.ag"(line 371, column 23) + _lhsOdefinedAttrs = + _hdIdefinedAttrs `Set.union` _tlIdefinedAttrs + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "DefaultRules.ag"(line 370, column 23) + _lhsOlocals = + _hdIlocals `Set.union` _tlIlocals + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOnt = + _lhsInt + ( _hdIcontainsVars,_hdIcopy,_hdIdefinedAttrs,_hdIerrors,_hdIlocals,_hdIoutput) = + (hd_ _hdOcon _hdOnt ) + ( _tlIcontainsVars,_tlIcopy,_tlIdefinedAttrs,_tlIerrors,_tlIlocals,_tlIoutput) = + (tl_ _tlOcon _tlOnt ) + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Name,Name)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Name) + _lhsOcopy :: Patterns + _lhsOoutput :: Patterns + -- use rule "DefaultRules.ag"(line 391, column 46) + _lhsOcontainsVars = + False + -- use rule "DefaultRules.ag"(line 371, column 23) + _lhsOdefinedAttrs = + Set.empty + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + Seq.empty + -- use rule "DefaultRules.ag"(line 370, column 23) + _lhsOlocals = + Set.empty + -- self rule + _copy = + [] + -- self rule + _output = + [] + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) +-- Production -------------------------------------------------- +{- + visit 0: + inherited attributes: + cr : Bool + manualAttrOrderMap : AttrOrderMap + nonterminals : Set Nonterminal + o_rename : Bool + typeSyns : TypeSyns + useMap : UseMap + chained attribute: + uniq : Int + synthesized attributes: + collect_nts : Set Nonterminal + errors : Seq Error + output : SELF + alternatives: + alternative Production: + child nt : {Nonterminal} + child inh : {Attributes} + child syn : {Attributes} + child alts : Alternatives + visit 0: + local output : _ +-} +-- cata +sem_Production :: Production -> + T_Production +sem_Production (Production _nt _inh _syn _alts ) = + (sem_Production_Production _nt _inh _syn (sem_Alternatives _alts ) ) +-- semantic domain +newtype T_Production = T_Production (Bool -> + AttrOrderMap -> + (Set Nonterminal) -> + Bool -> + TypeSyns -> + Int -> + UseMap -> + ( (Set Nonterminal),(Seq Error),Production,Int)) +data Inh_Production = Inh_Production {cr_Inh_Production :: Bool,manualAttrOrderMap_Inh_Production :: AttrOrderMap,nonterminals_Inh_Production :: Set Nonterminal,o_rename_Inh_Production :: Bool,typeSyns_Inh_Production :: TypeSyns,uniq_Inh_Production :: Int,useMap_Inh_Production :: UseMap} +data Syn_Production = Syn_Production {collect_nts_Syn_Production :: Set Nonterminal,errors_Syn_Production :: Seq Error,output_Syn_Production :: Production,uniq_Syn_Production :: Int} +wrap_Production (T_Production sem ) (Inh_Production _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap ) = + (let ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq) = + (sem _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap ) + in (Syn_Production _lhsOcollect_nts _lhsOerrors _lhsOoutput _lhsOuniq )) +sem_Production_Production :: Nonterminal -> + Attributes -> + Attributes -> + T_Alternatives -> + T_Production +sem_Production_Production nt_ inh_ syn_ (T_Alternatives alts_ ) = + (T_Production (\ _lhsIcr + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsIo_rename + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _lhsOcollect_nts :: (Set Nonterminal) + _altsOinh :: Attributes + _altsOsyn :: Attributes + _altsOuseMap :: (Map Name (String,String,String)) + _altsOnt :: Nonterminal + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Production + _lhsOuniq :: Int + _altsOcr :: Bool + _altsOmanualAttrOrderMap :: AttrOrderMap + _altsOnonterminals :: (Set Nonterminal) + _altsOo_rename :: Bool + _altsOtypeSyns :: TypeSyns + _altsOuniq :: Int + _altsIerrors :: (Seq Error) + _altsIoutput :: Alternatives + _altsIuniq :: Int + -- "DefaultRules.ag"(line 115, column 16) + _lhsOcollect_nts = + Set.singleton nt_ + -- "DefaultRules.ag"(line 130, column 17) + _altsOinh = + inh_ + -- "DefaultRules.ag"(line 131, column 17) + _altsOsyn = + syn_ + -- "DefaultRules.ag"(line 132, column 17) + _altsOuseMap = + Map.findWithDefault Map.empty nt_ _lhsIuseMap + -- "DefaultRules.ag"(line 144, column 16) + _altsOnt = + nt_ + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _altsIerrors + -- self rule + _output = + Production nt_ inh_ syn_ _altsIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (up) + _lhsOuniq = + _altsIuniq + -- copy rule (down) + _altsOcr = + _lhsIcr + -- copy rule (down) + _altsOmanualAttrOrderMap = + _lhsImanualAttrOrderMap + -- copy rule (down) + _altsOnonterminals = + _lhsInonterminals + -- copy rule (down) + _altsOo_rename = + _lhsIo_rename + -- copy rule (down) + _altsOtypeSyns = + _lhsItypeSyns + -- copy rule (down) + _altsOuniq = + _lhsIuniq + ( _altsIerrors,_altsIoutput,_altsIuniq) = + (alts_ _altsOcr _altsOinh _altsOmanualAttrOrderMap _altsOnonterminals _altsOnt _altsOo_rename _altsOsyn _altsOtypeSyns _altsOuniq _altsOuseMap ) + in ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq))) ) +-- Productions ------------------------------------------------- +{- + visit 0: + inherited attributes: + cr : Bool + manualAttrOrderMap : AttrOrderMap + nonterminals : Set Nonterminal + o_rename : Bool + typeSyns : TypeSyns + useMap : UseMap + chained attribute: + uniq : Int + synthesized attributes: + collect_nts : Set Nonterminal + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Production + child tl : Productions + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Productions :: Productions -> + T_Productions +sem_Productions list = + (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) ) +-- semantic domain +newtype T_Productions = T_Productions (Bool -> + AttrOrderMap -> + (Set Nonterminal) -> + Bool -> + TypeSyns -> + Int -> + UseMap -> + ( (Set Nonterminal),(Seq Error),Productions,Int)) +data Inh_Productions = Inh_Productions {cr_Inh_Productions :: Bool,manualAttrOrderMap_Inh_Productions :: AttrOrderMap,nonterminals_Inh_Productions :: Set Nonterminal,o_rename_Inh_Productions :: Bool,typeSyns_Inh_Productions :: TypeSyns,uniq_Inh_Productions :: Int,useMap_Inh_Productions :: UseMap} +data Syn_Productions = Syn_Productions {collect_nts_Syn_Productions :: Set Nonterminal,errors_Syn_Productions :: Seq Error,output_Syn_Productions :: Productions,uniq_Syn_Productions :: Int} +wrap_Productions (T_Productions sem ) (Inh_Productions _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap ) = + (let ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq) = + (sem _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap ) + in (Syn_Productions _lhsOcollect_nts _lhsOerrors _lhsOoutput _lhsOuniq )) +sem_Productions_Cons :: T_Production -> + T_Productions -> + T_Productions +sem_Productions_Cons (T_Production hd_ ) (T_Productions tl_ ) = + (T_Productions (\ _lhsIcr + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsIo_rename + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _lhsOcollect_nts :: (Set Nonterminal) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Productions + _lhsOuniq :: Int + _hdOcr :: Bool + _hdOmanualAttrOrderMap :: AttrOrderMap + _hdOnonterminals :: (Set Nonterminal) + _hdOo_rename :: Bool + _hdOtypeSyns :: TypeSyns + _hdOuniq :: Int + _hdOuseMap :: UseMap + _tlOcr :: Bool + _tlOmanualAttrOrderMap :: AttrOrderMap + _tlOnonterminals :: (Set Nonterminal) + _tlOo_rename :: Bool + _tlOtypeSyns :: TypeSyns + _tlOuniq :: Int + _tlOuseMap :: UseMap + _hdIcollect_nts :: (Set Nonterminal) + _hdIerrors :: (Seq Error) + _hdIoutput :: Production + _hdIuniq :: Int + _tlIcollect_nts :: (Set Nonterminal) + _tlIerrors :: (Seq Error) + _tlIoutput :: Productions + _tlIuniq :: Int + -- use rule "DefaultRules.ag"(line 113, column 47) + _lhsOcollect_nts = + _hdIcollect_nts `Set.union` _tlIcollect_nts + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (up) + _lhsOuniq = + _tlIuniq + -- copy rule (down) + _hdOcr = + _lhsIcr + -- copy rule (down) + _hdOmanualAttrOrderMap = + _lhsImanualAttrOrderMap + -- copy rule (down) + _hdOnonterminals = + _lhsInonterminals + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOtypeSyns = + _lhsItypeSyns + -- copy rule (down) + _hdOuniq = + _lhsIuniq + -- copy rule (down) + _hdOuseMap = + _lhsIuseMap + -- copy rule (down) + _tlOcr = + _lhsIcr + -- copy rule (down) + _tlOmanualAttrOrderMap = + _lhsImanualAttrOrderMap + -- copy rule (down) + _tlOnonterminals = + _lhsInonterminals + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOtypeSyns = + _lhsItypeSyns + -- copy rule (chain) + _tlOuniq = + _hdIuniq + -- copy rule (down) + _tlOuseMap = + _lhsIuseMap + ( _hdIcollect_nts,_hdIerrors,_hdIoutput,_hdIuniq) = + (hd_ _hdOcr _hdOmanualAttrOrderMap _hdOnonterminals _hdOo_rename _hdOtypeSyns _hdOuniq _hdOuseMap ) + ( _tlIcollect_nts,_tlIerrors,_tlIoutput,_tlIuniq) = + (tl_ _tlOcr _tlOmanualAttrOrderMap _tlOnonterminals _tlOo_rename _tlOtypeSyns _tlOuniq _tlOuseMap ) + in ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq))) ) +sem_Productions_Nil :: T_Productions +sem_Productions_Nil = + (T_Productions (\ _lhsIcr + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsIo_rename + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _lhsOcollect_nts :: (Set Nonterminal) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Productions + _lhsOuniq :: Int + -- use rule "DefaultRules.ag"(line 113, column 47) + _lhsOcollect_nts = + Set.empty + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + -- copy rule (chain) + _lhsOuniq = + _lhsIuniq + in ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq))) ) +-- Rule -------------------------------------------------------- +{- + visit 0: + inherited attributes: + con : Constructor + nt : Nonterminal + chained attribute: + uniq : Int + synthesized attributes: + containsVars : Bool + definedAttrs : Set (Name,Name) + errors : Seq Error + locals : Set Name + output : SELF + outputs : Rules + alternatives: + alternative Rule: + child pattern : Pattern + child rhs : {Expression} + child owrt : {Bool} + child origin : {String} + visit 0: + local _tup2 : {(Rules,Int)} + local output : _ +-} +-- cata +sem_Rule :: Rule -> + T_Rule +sem_Rule (Rule _pattern _rhs _owrt _origin ) = + (sem_Rule_Rule (sem_Pattern _pattern ) _rhs _owrt _origin ) +-- semantic domain +newtype T_Rule = T_Rule (Constructor -> + Nonterminal -> + Int -> + ( Bool,(Set (Name,Name)),(Seq Error),(Set Name),Rule,Rules,Int)) +data Inh_Rule = Inh_Rule {con_Inh_Rule :: Constructor,nt_Inh_Rule :: Nonterminal,uniq_Inh_Rule :: Int} +data Syn_Rule = Syn_Rule {containsVars_Syn_Rule :: Bool,definedAttrs_Syn_Rule :: Set (Name,Name),errors_Syn_Rule :: Seq Error,locals_Syn_Rule :: Set Name,output_Syn_Rule :: Rule,outputs_Syn_Rule :: Rules,uniq_Syn_Rule :: Int} +wrap_Rule (T_Rule sem ) (Inh_Rule _lhsIcon _lhsInt _lhsIuniq ) = + (let ( _lhsOcontainsVars,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOoutputs,_lhsOuniq) = + (sem _lhsIcon _lhsInt _lhsIuniq ) + in (Syn_Rule _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOoutputs _lhsOuniq )) +sem_Rule_Rule :: T_Pattern -> + Expression -> + Bool -> + String -> + T_Rule +sem_Rule_Rule (T_Pattern pattern_ ) rhs_ owrt_ origin_ = + (T_Rule (\ _lhsIcon + _lhsInt + _lhsIuniq -> + (let __tup2 :: ((Rules,Int)) + _lhsOoutputs :: Rules + _lhsOuniq :: Int + _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Name,Name)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Name) + _lhsOoutput :: Rule + _patternOcon :: Constructor + _patternOnt :: Nonterminal + _patternIcontainsVars :: Bool + _patternIcopy :: Pattern + _patternIdefinedAttrs :: (Set (Name,Name)) + _patternIerrors :: (Seq Error) + _patternIlocals :: (Set Name) + _patternIoutput :: Pattern + -- "DefaultRules.ag"(line 420, column 11) + __tup2 = + multiRule _output _lhsIuniq + -- "DefaultRules.ag"(line 420, column 11) + (_lhsOoutputs,_) = + __tup2 + -- "DefaultRules.ag"(line 420, column 11) + (_,_lhsOuniq) = + __tup2 + -- use rule "DefaultRules.ag"(line 391, column 46) + _lhsOcontainsVars = + _patternIcontainsVars + -- use rule "DefaultRules.ag"(line 371, column 23) + _lhsOdefinedAttrs = + _patternIdefinedAttrs + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _patternIerrors + -- use rule "DefaultRules.ag"(line 370, column 23) + _lhsOlocals = + _patternIlocals + -- self rule + _output = + Rule _patternIoutput rhs_ owrt_ origin_ + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patternOcon = + _lhsIcon + -- copy rule (down) + _patternOnt = + _lhsInt + ( _patternIcontainsVars,_patternIcopy,_patternIdefinedAttrs,_patternIerrors,_patternIlocals,_patternIoutput) = + (pattern_ _patternOcon _patternOnt ) + in ( _lhsOcontainsVars,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOoutputs,_lhsOuniq))) ) +-- Rules ------------------------------------------------------- +{- + visit 0: + inherited attributes: + con : Constructor + nt : Nonterminal + chained attribute: + uniq : Int + synthesized attributes: + definedAttrs : Set (Name,Name) + errors : Seq Error + locals : Set Name + output : SELF + alternatives: + alternative Cons: + child hd : Rule + child tl : Rules + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Rules :: Rules -> + T_Rules +sem_Rules list = + (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) ) +-- semantic domain +newtype T_Rules = T_Rules (Constructor -> + Nonterminal -> + Int -> + ( (Set (Name,Name)),(Seq Error),(Set Name),Rules,Int)) +data Inh_Rules = Inh_Rules {con_Inh_Rules :: Constructor,nt_Inh_Rules :: Nonterminal,uniq_Inh_Rules :: Int} +data Syn_Rules = Syn_Rules {definedAttrs_Syn_Rules :: Set (Name,Name),errors_Syn_Rules :: Seq Error,locals_Syn_Rules :: Set Name,output_Syn_Rules :: Rules,uniq_Syn_Rules :: Int} +wrap_Rules (T_Rules sem ) (Inh_Rules _lhsIcon _lhsInt _lhsIuniq ) = + (let ( _lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOuniq) = + (sem _lhsIcon _lhsInt _lhsIuniq ) + in (Syn_Rules _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOuniq )) +sem_Rules_Cons :: T_Rule -> + T_Rules -> + T_Rules +sem_Rules_Cons (T_Rule hd_ ) (T_Rules tl_ ) = + (T_Rules (\ _lhsIcon + _lhsInt + _lhsIuniq -> + (let _lhsOoutput :: Rules + _lhsOdefinedAttrs :: (Set (Name,Name)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Name) + _lhsOuniq :: Int + _hdOcon :: Constructor + _hdOnt :: Nonterminal + _hdOuniq :: Int + _tlOcon :: Constructor + _tlOnt :: Nonterminal + _tlOuniq :: Int + _hdIcontainsVars :: Bool + _hdIdefinedAttrs :: (Set (Name,Name)) + _hdIerrors :: (Seq Error) + _hdIlocals :: (Set Name) + _hdIoutput :: Rule + _hdIoutputs :: Rules + _hdIuniq :: Int + _tlIdefinedAttrs :: (Set (Name,Name)) + _tlIerrors :: (Seq Error) + _tlIlocals :: (Set Name) + _tlIoutput :: Rules + _tlIuniq :: Int + -- "DefaultRules.ag"(line 416, column 10) + _lhsOoutput = + if _hdIcontainsVars then _hdIoutputs ++ _tlIoutput else _tlIoutput + -- use rule "DefaultRules.ag"(line 371, column 23) + _lhsOdefinedAttrs = + _hdIdefinedAttrs `Set.union` _tlIdefinedAttrs + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "DefaultRules.ag"(line 370, column 23) + _lhsOlocals = + _hdIlocals `Set.union` _tlIlocals + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- copy rule (up) + _lhsOuniq = + _tlIuniq + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOuniq = + _lhsIuniq + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (chain) + _tlOuniq = + _hdIuniq + ( _hdIcontainsVars,_hdIdefinedAttrs,_hdIerrors,_hdIlocals,_hdIoutput,_hdIoutputs,_hdIuniq) = + (hd_ _hdOcon _hdOnt _hdOuniq ) + ( _tlIdefinedAttrs,_tlIerrors,_tlIlocals,_tlIoutput,_tlIuniq) = + (tl_ _tlOcon _tlOnt _tlOuniq ) + in ( _lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOuniq))) ) +sem_Rules_Nil :: T_Rules +sem_Rules_Nil = + (T_Rules (\ _lhsIcon + _lhsInt + _lhsIuniq -> + (let _lhsOdefinedAttrs :: (Set (Name,Name)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Name) + _lhsOoutput :: Rules + _lhsOuniq :: Int + -- use rule "DefaultRules.ag"(line 371, column 23) + _lhsOdefinedAttrs = + Set.empty + -- use rule "DefaultRules.ag"(line 107, column 19) + _lhsOerrors = + Seq.empty + -- use rule "DefaultRules.ag"(line 370, column 23) + _lhsOlocals = + Set.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + -- copy rule (chain) + _lhsOuniq = + _lhsIuniq + in ( _lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOuniq))) ) +-- TypeSig ----------------------------------------------------- +{- + visit 0: + synthesized attribute: + output : SELF + alternatives: + alternative TypeSig: + child name : {Name} + child tp : {Type} + visit 0: + local output : _ +-} +-- cata +sem_TypeSig :: TypeSig -> + T_TypeSig +sem_TypeSig (TypeSig _name _tp ) = + (sem_TypeSig_TypeSig _name _tp ) +-- semantic domain +newtype T_TypeSig = T_TypeSig (( TypeSig)) +data Inh_TypeSig = Inh_TypeSig {} +data Syn_TypeSig = Syn_TypeSig {output_Syn_TypeSig :: TypeSig} +wrap_TypeSig (T_TypeSig sem ) (Inh_TypeSig ) = + (let ( _lhsOoutput) = + (sem ) + in (Syn_TypeSig _lhsOoutput )) +sem_TypeSig_TypeSig :: Name -> + Type -> + T_TypeSig +sem_TypeSig_TypeSig name_ tp_ = + (T_TypeSig (let _lhsOoutput :: TypeSig + -- self rule + _output = + TypeSig name_ tp_ + -- self rule + _lhsOoutput = + _output + in ( _lhsOoutput)) ) +-- TypeSigs ---------------------------------------------------- +{- + visit 0: + synthesized attribute: + output : SELF + alternatives: + alternative Cons: + child hd : TypeSig + child tl : TypeSigs + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_TypeSigs :: TypeSigs -> + T_TypeSigs +sem_TypeSigs list = + (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) ) +-- semantic domain +newtype T_TypeSigs = T_TypeSigs (( TypeSigs)) +data Inh_TypeSigs = Inh_TypeSigs {} +data Syn_TypeSigs = Syn_TypeSigs {output_Syn_TypeSigs :: TypeSigs} +wrap_TypeSigs (T_TypeSigs sem ) (Inh_TypeSigs ) = + (let ( _lhsOoutput) = + (sem ) + in (Syn_TypeSigs _lhsOoutput )) +sem_TypeSigs_Cons :: T_TypeSig -> + T_TypeSigs -> + T_TypeSigs +sem_TypeSigs_Cons (T_TypeSig hd_ ) (T_TypeSigs tl_ ) = + (T_TypeSigs (let _lhsOoutput :: TypeSigs + _hdIoutput :: TypeSig + _tlIoutput :: TypeSigs + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + ( _hdIoutput) = + (hd_ ) + ( _tlIoutput) = + (tl_ ) + in ( _lhsOoutput)) ) +sem_TypeSigs_Nil :: T_TypeSigs +sem_TypeSigs_Nil = + (T_TypeSigs (let _lhsOoutput :: TypeSigs + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOoutput)) ) diff --git a/src-derived/Desugar.hs b/src-derived/Desugar.hs new file mode 100644 --- /dev/null +++ b/src-derived/Desugar.hs @@ -0,0 +1,1837 @@ + +-- UUAGC 0.9.5 (Desugar.ag) +module Desugar where + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map(Map) +import qualified UU.DData.Seq as Seq +import UU.DData.Seq(Seq,(<>)) +import UU.Scanner.Position(Pos(..)) +import Maybe + +import AbstractSyntax +import ErrorMessages +import Options +import HsToken +import HsTokenScanner +import TokenDef + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (Constructor,Name) + +import UU.Scanner.Position(Pos) + +import CommonTypes +import UU.Scanner.Position(Pos) + +addl :: Int -> Pos -> Pos +addl n (Pos l c f) = Pos (l+n) c f + +maybeError :: a -> Error -> Maybe a -> (a, Seq Error) +maybeError def err mb + = maybe (def, Seq.single err) (\r -> (r, Seq.empty)) mb + +findField :: Name -> Name -> [(Name,Name)] -> Maybe Name +findField fld attr list + | fld == _FIRST = f list + | fld == _LAST = f (reverse list) + | otherwise = Just fld + where + f = lookup attr +-- Alternative ------------------------------------------------- +{- + visit 0: + inherited attribute: + nt : Nonterminal + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Alternative: + child con : {Constructor} + child children : Children + child rules : Rules + child typeSigs : TypeSigs + visit 0: + local output : _ +-} +-- cata +sem_Alternative :: Alternative -> + T_Alternative +sem_Alternative (Alternative _con _children _rules _typeSigs ) = + (sem_Alternative_Alternative _con (sem_Children _children ) (sem_Rules _rules ) (sem_TypeSigs _typeSigs ) ) +-- semantic domain +newtype T_Alternative = T_Alternative (Nonterminal -> + ( (Seq Error),Alternative)) +data Inh_Alternative = Inh_Alternative {nt_Inh_Alternative :: Nonterminal} +data Syn_Alternative = Syn_Alternative {errors_Syn_Alternative :: Seq Error,output_Syn_Alternative :: Alternative} +wrap_Alternative (T_Alternative sem ) (Inh_Alternative _lhsInt ) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsInt ) + in (Syn_Alternative _lhsOerrors _lhsOoutput )) +sem_Alternative_Alternative :: Constructor -> + T_Children -> + T_Rules -> + T_TypeSigs -> + T_Alternative +sem_Alternative_Alternative con_ (T_Children children_ ) (T_Rules rules_ ) (T_TypeSigs typeSigs_ ) = + (T_Alternative (\ _lhsInt -> + (let _rulesOcon :: Constructor + _rulesOdefs :: (Set (Name, Name)) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Alternative + _rulesOchildInhs :: ([(Name, Name)]) + _rulesOchildSyns :: ([(Name, Name)]) + _rulesOnt :: Nonterminal + _childrenIchildInhs :: ([(Name, Name)]) + _childrenIchildSyns :: ([(Name, Name)]) + _childrenIoutput :: Children + _rulesIdefsCollect :: (Set (Name, Name)) + _rulesIerrors :: (Seq Error) + _rulesIoutput :: Rules + _typeSigsIoutput :: TypeSigs + -- "Desugar.ag"(line 149, column 7) + _rulesOcon = + con_ + -- "Desugar.ag"(line 165, column 7) + _rulesOdefs = + _rulesIdefsCollect + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _rulesIerrors + -- self rule + _output = + Alternative con_ _childrenIoutput _rulesIoutput _typeSigsIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (chain) + _rulesOchildInhs = + _childrenIchildInhs + -- copy rule (chain) + _rulesOchildSyns = + _childrenIchildSyns + -- copy rule (down) + _rulesOnt = + _lhsInt + ( _childrenIchildInhs,_childrenIchildSyns,_childrenIoutput) = + (children_ ) + ( _rulesIdefsCollect,_rulesIerrors,_rulesIoutput) = + (rules_ _rulesOchildInhs _rulesOchildSyns _rulesOcon _rulesOdefs _rulesOnt ) + ( _typeSigsIoutput) = + (typeSigs_ ) + in ( _lhsOerrors,_lhsOoutput))) ) +-- Alternatives ------------------------------------------------ +{- + visit 0: + inherited attribute: + nt : Nonterminal + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Alternative + child tl : Alternatives + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Alternatives :: Alternatives -> + T_Alternatives +sem_Alternatives list = + (Prelude.foldr sem_Alternatives_Cons sem_Alternatives_Nil (Prelude.map sem_Alternative list) ) +-- semantic domain +newtype T_Alternatives = T_Alternatives (Nonterminal -> + ( (Seq Error),Alternatives)) +data Inh_Alternatives = Inh_Alternatives {nt_Inh_Alternatives :: Nonterminal} +data Syn_Alternatives = Syn_Alternatives {errors_Syn_Alternatives :: Seq Error,output_Syn_Alternatives :: Alternatives} +wrap_Alternatives (T_Alternatives sem ) (Inh_Alternatives _lhsInt ) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsInt ) + in (Syn_Alternatives _lhsOerrors _lhsOoutput )) +sem_Alternatives_Cons :: T_Alternative -> + T_Alternatives -> + T_Alternatives +sem_Alternatives_Cons (T_Alternative hd_ ) (T_Alternatives tl_ ) = + (T_Alternatives (\ _lhsInt -> + (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Alternatives + _hdOnt :: Nonterminal + _tlOnt :: Nonterminal + _hdIerrors :: (Seq Error) + _hdIoutput :: Alternative + _tlIerrors :: (Seq Error) + _tlIoutput :: Alternatives + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _tlOnt = + _lhsInt + ( _hdIerrors,_hdIoutput) = + (hd_ _hdOnt ) + ( _tlIerrors,_tlIoutput) = + (tl_ _tlOnt ) + in ( _lhsOerrors,_lhsOoutput))) ) +sem_Alternatives_Nil :: T_Alternatives +sem_Alternatives_Nil = + (T_Alternatives (\ _lhsInt -> + (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Alternatives + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOerrors,_lhsOoutput))) ) +-- Child ------------------------------------------------------- +{- + visit 0: + synthesized attributes: + childInhs : [(Name, Name)] + childSyns : [(Name, Name)] + output : SELF + alternatives: + alternative Child: + child name : {Name} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child higherOrder : {Bool} + visit 0: + local output : _ +-} +-- cata +sem_Child :: Child -> + T_Child +sem_Child (Child _name _tp _inh _syn _higherOrder ) = + (sem_Child_Child _name _tp _inh _syn _higherOrder ) +-- semantic domain +newtype T_Child = T_Child (( ([(Name, Name)]),([(Name, Name)]),Child)) +data Inh_Child = Inh_Child {} +data Syn_Child = Syn_Child {childInhs_Syn_Child :: [(Name, Name)],childSyns_Syn_Child :: [(Name, Name)],output_Syn_Child :: Child} +wrap_Child (T_Child sem ) (Inh_Child ) = + (let ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput) = + (sem ) + in (Syn_Child _lhsOchildInhs _lhsOchildSyns _lhsOoutput )) +sem_Child_Child :: Name -> + Type -> + Attributes -> + Attributes -> + Bool -> + T_Child +sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = + (T_Child (let _lhsOchildInhs :: ([(Name, Name)]) + _lhsOchildSyns :: ([(Name, Name)]) + _lhsOoutput :: Child + -- "Desugar.ag"(line 118, column 7) + _lhsOchildInhs = + [(i, name_) | i <- Map.keys inh_ ] + -- "Desugar.ag"(line 119, column 7) + _lhsOchildSyns = + [(s, name_) | s <- Map.keys syn_ ] + -- self rule + _output = + Child name_ tp_ inh_ syn_ higherOrder_ + -- self rule + _lhsOoutput = + _output + in ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput)) ) +-- Children ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + childInhs : [(Name, Name)] + childSyns : [(Name, Name)] + output : SELF + alternatives: + alternative Cons: + child hd : Child + child tl : Children + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Children :: Children -> + T_Children +sem_Children list = + (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) ) +-- semantic domain +newtype T_Children = T_Children (( ([(Name, Name)]),([(Name, Name)]),Children)) +data Inh_Children = Inh_Children {} +data Syn_Children = Syn_Children {childInhs_Syn_Children :: [(Name, Name)],childSyns_Syn_Children :: [(Name, Name)],output_Syn_Children :: Children} +wrap_Children (T_Children sem ) (Inh_Children ) = + (let ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput) = + (sem ) + in (Syn_Children _lhsOchildInhs _lhsOchildSyns _lhsOoutput )) +sem_Children_Cons :: T_Child -> + T_Children -> + T_Children +sem_Children_Cons (T_Child hd_ ) (T_Children tl_ ) = + (T_Children (let _lhsOchildInhs :: ([(Name, Name)]) + _lhsOchildSyns :: ([(Name, Name)]) + _lhsOoutput :: Children + _hdIchildInhs :: ([(Name, Name)]) + _hdIchildSyns :: ([(Name, Name)]) + _hdIoutput :: Child + _tlIchildInhs :: ([(Name, Name)]) + _tlIchildSyns :: ([(Name, Name)]) + _tlIoutput :: Children + -- use rule "Desugar.ag"(line 113, column 48) + _lhsOchildInhs = + _hdIchildInhs ++ _tlIchildInhs + -- use rule "Desugar.ag"(line 113, column 48) + _lhsOchildSyns = + _hdIchildSyns ++ _tlIchildSyns + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + ( _hdIchildInhs,_hdIchildSyns,_hdIoutput) = + (hd_ ) + ( _tlIchildInhs,_tlIchildSyns,_tlIoutput) = + (tl_ ) + in ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput)) ) +sem_Children_Nil :: T_Children +sem_Children_Nil = + (T_Children (let _lhsOchildInhs :: ([(Name, Name)]) + _lhsOchildSyns :: ([(Name, Name)]) + _lhsOoutput :: Children + -- use rule "Desugar.ag"(line 113, column 48) + _lhsOchildInhs = + [] + -- use rule "Desugar.ag"(line 113, column 48) + _lhsOchildSyns = + [] + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput)) ) +-- Expression -------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Name, Name)] + childSyns : [(Name, Name)] + con : Constructor + nt : Nonterminal + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Expression: + child pos : {Pos} + child txt : {String} + visit 0: + local tokens : _ + local _tup1 : _ + local txt' : _ + local output : _ +-} +-- cata +sem_Expression :: Expression -> + T_Expression +sem_Expression (Expression _pos _txt ) = + (sem_Expression_Expression _pos _txt ) +-- semantic domain +newtype T_Expression = T_Expression (([(Name, Name)]) -> + ([(Name, Name)]) -> + Constructor -> + Nonterminal -> + ( (Seq Error),Expression)) +data Inh_Expression = Inh_Expression {childInhs_Inh_Expression :: [(Name, Name)],childSyns_Inh_Expression :: [(Name, Name)],con_Inh_Expression :: Constructor,nt_Inh_Expression :: Nonterminal} +data Syn_Expression = Syn_Expression {errors_Syn_Expression :: Seq Error,output_Syn_Expression :: Expression} +wrap_Expression (T_Expression sem ) (Inh_Expression _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) + in (Syn_Expression _lhsOerrors _lhsOoutput )) +sem_Expression_Expression :: Pos -> + String -> + T_Expression +sem_Expression_Expression pos_ txt_ = + (T_Expression (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt -> + (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Expression + -- "Desugar.ag"(line 41, column 7) + _tokens = + lexTokens pos_ txt_ + -- "Desugar.ag"(line 42, column 7) + __tup1 = + let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot = _lhsIchildInhs + , childSyns_Inh_HsTokensRoot = _lhsIchildSyns + , nt_Inh_HsTokensRoot = _lhsInt + , con_Inh_HsTokensRoot = _lhsIcon + } + sem = sem_HsTokensRoot (HsTokensRoot _tokens ) + syn = wrap_HsTokensRoot sem inh + in (txt_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn) + -- "Desugar.ag"(line 42, column 7) + (_txt',_) = + __tup1 + -- "Desugar.ag"(line 42, column 7) + (_,_lhsOerrors) = + __tup1 + -- "Desugar.ag"(line 50, column 7) + _lhsOoutput = + Expression pos_ _txt' + -- self rule + _output = + Expression pos_ txt_ + in ( _lhsOerrors,_lhsOoutput))) ) +-- Grammar ----------------------------------------------------- +{- + visit 0: + inherited attribute: + options : Options + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Grammar: + child typeSyns : {TypeSyns} + child useMap : {UseMap} + child derivings : {Derivings} + child wrappers : {Set Nonterminal} + child prods : Productions + child pragmas : {PragmaMap} + child manualAttrOrderMap : {AttrOrderMap} + visit 0: + local output : _ +-} +-- cata +sem_Grammar :: Grammar -> + T_Grammar +sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _prods _pragmas _manualAttrOrderMap ) = + (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Productions _prods ) _pragmas _manualAttrOrderMap ) +-- semantic domain +newtype T_Grammar = T_Grammar (Options -> + ( (Seq Error),Grammar)) +data Inh_Grammar = Inh_Grammar {options_Inh_Grammar :: Options} +data Syn_Grammar = Syn_Grammar {errors_Syn_Grammar :: Seq Error,output_Syn_Grammar :: Grammar} +wrap_Grammar (T_Grammar sem ) (Inh_Grammar _lhsIoptions ) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsIoptions ) + in (Syn_Grammar _lhsOerrors _lhsOoutput )) +sem_Grammar_Grammar :: TypeSyns -> + UseMap -> + Derivings -> + (Set Nonterminal) -> + T_Productions -> + PragmaMap -> + AttrOrderMap -> + T_Grammar +sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Productions prods_ ) pragmas_ manualAttrOrderMap_ = + (T_Grammar (\ _lhsIoptions -> + (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Grammar + _prodsIerrors :: (Seq Error) + _prodsIoutput :: Productions + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _prodsIerrors + -- self rule + _output = + Grammar typeSyns_ useMap_ derivings_ wrappers_ _prodsIoutput pragmas_ manualAttrOrderMap_ + -- self rule + _lhsOoutput = + _output + ( _prodsIerrors,_prodsIoutput) = + (prods_ ) + in ( _lhsOerrors,_lhsOoutput))) ) +-- HsToken ----------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Name, Name)] + childSyns : [(Name, Name)] + con : Constructor + nt : Nonterminal + chained attribute: + addLines : Int + synthesized attributes: + errors : Seq Error + tks : [(Pos,String)] + alternatives: + alternative AGField: + child field : {Name} + child attr : {Name} + child pos : {Pos} + visit 0: + local mField : _ + local field' : _ + alternative AGLocal: + child var : {Name} + child pos : {Pos} + alternative CharToken: + child value : {String} + child pos : {Pos} + alternative Err: + child mesg : {String} + child pos : {Pos} + alternative HsToken: + child value : {String} + child pos : {Pos} + alternative StrToken: + child value : {String} + child pos : {Pos} +-} +-- cata +sem_HsToken :: HsToken -> + T_HsToken +sem_HsToken (AGField _field _attr _pos ) = + (sem_HsToken_AGField _field _attr _pos ) +sem_HsToken (AGLocal _var _pos ) = + (sem_HsToken_AGLocal _var _pos ) +sem_HsToken (CharToken _value _pos ) = + (sem_HsToken_CharToken _value _pos ) +sem_HsToken (Err _mesg _pos ) = + (sem_HsToken_Err _mesg _pos ) +sem_HsToken (HsToken _value _pos ) = + (sem_HsToken_HsToken _value _pos ) +sem_HsToken (StrToken _value _pos ) = + (sem_HsToken_StrToken _value _pos ) +-- semantic domain +newtype T_HsToken = T_HsToken (Int -> + ([(Name, Name)]) -> + ([(Name, Name)]) -> + Constructor -> + Nonterminal -> + ( Int,(Seq Error),([(Pos,String)]))) +data Inh_HsToken = Inh_HsToken {addLines_Inh_HsToken :: Int,childInhs_Inh_HsToken :: [(Name, Name)],childSyns_Inh_HsToken :: [(Name, Name)],con_Inh_HsToken :: Constructor,nt_Inh_HsToken :: Nonterminal} +data Syn_HsToken = Syn_HsToken {addLines_Syn_HsToken :: Int,errors_Syn_HsToken :: Seq Error,tks_Syn_HsToken :: [(Pos,String)]} +wrap_HsToken (T_HsToken sem ) (Inh_HsToken _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) = + (let ( _lhsOaddLines,_lhsOerrors,_lhsOtks) = + (sem _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) + in (Syn_HsToken _lhsOaddLines _lhsOerrors _lhsOtks )) +sem_HsToken_AGField :: Name -> + Name -> + Pos -> + T_HsToken +sem_HsToken_AGField field_ attr_ pos_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt -> + (let _lhsOerrors :: (Seq Error) + _lhsOaddLines :: Int + _lhsOtks :: ([(Pos,String)]) + -- "Desugar.ag"(line 67, column 7) + _mField = + findField field_ attr_ _lhsIchildSyns + -- "Desugar.ag"(line 69, column 7) + _field' = + maybe field_ id _mField + -- "Desugar.ag"(line 70, column 7) + _lhsOerrors = + maybe (Seq.single (UndefAttr _lhsInt _lhsIcon field_ (Ident "" (getPos field_)))) (const Seq.empty) _mField + -- "Desugar.ag"(line 72, column 7) + _lhsOaddLines = + if length (getName field_) < length (getName _field' ) + then _lhsIaddLines + 1 + else _lhsIaddLines + -- "Desugar.ag"(line 76, column 7) + _lhsOtks = + [(addl _lhsIaddLines pos_, "@" ++ show _field' ++ "." ++ show attr_)] + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) +sem_HsToken_AGLocal :: Name -> + Pos -> + T_HsToken +sem_HsToken_AGLocal var_ pos_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt -> + (let _lhsOtks :: ([(Pos,String)]) + _lhsOerrors :: (Seq Error) + _lhsOaddLines :: Int + -- "Desugar.ag"(line 65, column 7) + _lhsOtks = + [(addl _lhsIaddLines pos_, "@" ++ show var_)] + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) +sem_HsToken_CharToken :: String -> + Pos -> + T_HsToken +sem_HsToken_CharToken value_ pos_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt -> + (let _lhsOtks :: ([(Pos,String)]) + _lhsOerrors :: (Seq Error) + _lhsOaddLines :: Int + -- "Desugar.ag"(line 80, column 7) + _lhsOtks = + [(addl _lhsIaddLines pos_, if null value_ then "" else showCharShort (head value_))] + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) +sem_HsToken_Err :: String -> + Pos -> + T_HsToken +sem_HsToken_Err mesg_ pos_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt -> + (let _lhsOtks :: ([(Pos,String)]) + _lhsOerrors :: (Seq Error) + _lhsOaddLines :: Int + -- "Desugar.ag"(line 84, column 7) + _lhsOtks = + [(addl _lhsIaddLines pos_, "***" ++ mesg_ ++ "***")] + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) +sem_HsToken_HsToken :: String -> + Pos -> + T_HsToken +sem_HsToken_HsToken value_ pos_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt -> + (let _lhsOtks :: ([(Pos,String)]) + _lhsOerrors :: (Seq Error) + _lhsOaddLines :: Int + -- "Desugar.ag"(line 78, column 7) + _lhsOtks = + [(addl _lhsIaddLines pos_, value_)] + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) +sem_HsToken_StrToken :: String -> + Pos -> + T_HsToken +sem_HsToken_StrToken value_ pos_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt -> + (let _lhsOtks :: ([(Pos,String)]) + _lhsOerrors :: (Seq Error) + _lhsOaddLines :: Int + -- "Desugar.ag"(line 82, column 7) + _lhsOtks = + [(addl _lhsIaddLines pos_, showStrShort value_)] + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) +-- HsTokens ---------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Name, Name)] + childSyns : [(Name, Name)] + con : Constructor + nt : Nonterminal + chained attribute: + addLines : Int + synthesized attributes: + errors : Seq Error + tks : [(Pos,String)] + alternatives: + alternative Cons: + child hd : HsToken + child tl : HsTokens + alternative Nil: +-} +-- cata +sem_HsTokens :: HsTokens -> + T_HsTokens +sem_HsTokens list = + (Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list) ) +-- semantic domain +newtype T_HsTokens = T_HsTokens (Int -> + ([(Name, Name)]) -> + ([(Name, Name)]) -> + Constructor -> + Nonterminal -> + ( Int,(Seq Error),([(Pos,String)]))) +data Inh_HsTokens = Inh_HsTokens {addLines_Inh_HsTokens :: Int,childInhs_Inh_HsTokens :: [(Name, Name)],childSyns_Inh_HsTokens :: [(Name, Name)],con_Inh_HsTokens :: Constructor,nt_Inh_HsTokens :: Nonterminal} +data Syn_HsTokens = Syn_HsTokens {addLines_Syn_HsTokens :: Int,errors_Syn_HsTokens :: Seq Error,tks_Syn_HsTokens :: [(Pos,String)]} +wrap_HsTokens (T_HsTokens sem ) (Inh_HsTokens _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) = + (let ( _lhsOaddLines,_lhsOerrors,_lhsOtks) = + (sem _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) + in (Syn_HsTokens _lhsOaddLines _lhsOerrors _lhsOtks )) +sem_HsTokens_Cons :: T_HsToken -> + T_HsTokens -> + T_HsTokens +sem_HsTokens_Cons (T_HsToken hd_ ) (T_HsTokens tl_ ) = + (T_HsTokens (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt -> + (let _lhsOerrors :: (Seq Error) + _lhsOtks :: ([(Pos,String)]) + _lhsOaddLines :: Int + _hdOaddLines :: Int + _hdOchildInhs :: ([(Name, Name)]) + _hdOchildSyns :: ([(Name, Name)]) + _hdOcon :: Constructor + _hdOnt :: Nonterminal + _tlOaddLines :: Int + _tlOchildInhs :: ([(Name, Name)]) + _tlOchildSyns :: ([(Name, Name)]) + _tlOcon :: Constructor + _tlOnt :: Nonterminal + _hdIaddLines :: Int + _hdIerrors :: (Seq Error) + _hdItks :: ([(Pos,String)]) + _tlIaddLines :: Int + _tlIerrors :: (Seq Error) + _tlItks :: ([(Pos,String)]) + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Desugar.ag"(line 62, column 46) + _lhsOtks = + _hdItks ++ _tlItks + -- copy rule (up) + _lhsOaddLines = + _tlIaddLines + -- copy rule (down) + _hdOaddLines = + _lhsIaddLines + -- copy rule (down) + _hdOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _hdOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (chain) + _tlOaddLines = + _hdIaddLines + -- copy rule (down) + _tlOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _tlOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOnt = + _lhsInt + ( _hdIaddLines,_hdIerrors,_hdItks) = + (hd_ _hdOaddLines _hdOchildInhs _hdOchildSyns _hdOcon _hdOnt ) + ( _tlIaddLines,_tlIerrors,_tlItks) = + (tl_ _tlOaddLines _tlOchildInhs _tlOchildSyns _tlOcon _tlOnt ) + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) +sem_HsTokens_Nil :: T_HsTokens +sem_HsTokens_Nil = + (T_HsTokens (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt -> + (let _lhsOerrors :: (Seq Error) + _lhsOtks :: ([(Pos,String)]) + _lhsOaddLines :: Int + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- use rule "Desugar.ag"(line 62, column 46) + _lhsOtks = + [] + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) +-- HsTokensRoot ------------------------------------------------ +{- + visit 0: + inherited attributes: + childInhs : [(Name, Name)] + childSyns : [(Name, Name)] + con : Constructor + nt : Nonterminal + synthesized attributes: + errors : Seq Error + tks : [(Pos,String)] + txt : String + alternatives: + alternative HsTokensRoot: + child tokens : HsTokens +-} +-- cata +sem_HsTokensRoot :: HsTokensRoot -> + T_HsTokensRoot +sem_HsTokensRoot (HsTokensRoot _tokens ) = + (sem_HsTokensRoot_HsTokensRoot (sem_HsTokens _tokens ) ) +-- semantic domain +newtype T_HsTokensRoot = T_HsTokensRoot (([(Name, Name)]) -> + ([(Name, Name)]) -> + Constructor -> + Nonterminal -> + ( (Seq Error),([(Pos,String)]),String)) +data Inh_HsTokensRoot = Inh_HsTokensRoot {childInhs_Inh_HsTokensRoot :: [(Name, Name)],childSyns_Inh_HsTokensRoot :: [(Name, Name)],con_Inh_HsTokensRoot :: Constructor,nt_Inh_HsTokensRoot :: Nonterminal} +data Syn_HsTokensRoot = Syn_HsTokensRoot {errors_Syn_HsTokensRoot :: Seq Error,tks_Syn_HsTokensRoot :: [(Pos,String)],txt_Syn_HsTokensRoot :: String} +wrap_HsTokensRoot (T_HsTokensRoot sem ) (Inh_HsTokensRoot _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) = + (let ( _lhsOerrors,_lhsOtks,_lhsOtxt) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) + in (Syn_HsTokensRoot _lhsOerrors _lhsOtks _lhsOtxt )) +sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> + T_HsTokensRoot +sem_HsTokensRoot_HsTokensRoot (T_HsTokens tokens_ ) = + (T_HsTokensRoot (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt -> + (let _lhsOtxt :: String + _tokensOaddLines :: Int + _lhsOerrors :: (Seq Error) + _lhsOtks :: ([(Pos,String)]) + _tokensOchildInhs :: ([(Name, Name)]) + _tokensOchildSyns :: ([(Name, Name)]) + _tokensOcon :: Constructor + _tokensOnt :: Nonterminal + _tokensIaddLines :: Int + _tokensIerrors :: (Seq Error) + _tokensItks :: ([(Pos,String)]) + -- "Desugar.ag"(line 55, column 7) + _lhsOtxt = + unlines $ showTokens _tokensItks + -- "Desugar.ag"(line 60, column 7) + _tokensOaddLines = + 0 + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _tokensIerrors + -- use rule "Desugar.ag"(line 62, column 46) + _lhsOtks = + _tokensItks + -- copy rule (down) + _tokensOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _tokensOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _tokensOcon = + _lhsIcon + -- copy rule (down) + _tokensOnt = + _lhsInt + ( _tokensIaddLines,_tokensIerrors,_tokensItks) = + (tokens_ _tokensOaddLines _tokensOchildInhs _tokensOchildSyns _tokensOcon _tokensOnt ) + in ( _lhsOerrors,_lhsOtks,_lhsOtxt))) ) +-- Pattern ----------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Name, Name)] + childSyns : [(Name, Name)] + con : Constructor + defs : Set (Name, Name) + nt : Nonterminal + synthesized attributes: + copy : SELF + defsCollect : Set (Name, Name) + errors : Seq Error + output : SELF + alternatives: + alternative Alias: + child field : {Name} + child attr : {Name} + child pat : Pattern + child parts : Patterns + visit 0: + local _tup2 : _ + local field' : _ + local err1 : _ + local err2 : _ + local def : _ + local copy : _ + local output : _ + alternative Constr: + child name : {Constructor} + child pats : Patterns + visit 0: + local copy : _ + local output : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + local output : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ + local output : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts ) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) +sem_Pattern (Constr _name _pats ) = + (sem_Pattern_Constr _name (sem_Patterns _pats ) ) +sem_Pattern (Product _pos _pats ) = + (sem_Pattern_Product _pos (sem_Patterns _pats ) ) +sem_Pattern (Underscore _pos ) = + (sem_Pattern_Underscore _pos ) +-- semantic domain +newtype T_Pattern = T_Pattern (([(Name, Name)]) -> + ([(Name, Name)]) -> + Constructor -> + (Set (Name, Name)) -> + Nonterminal -> + ( Pattern,(Set (Name, Name)),(Seq Error),Pattern)) +data Inh_Pattern = Inh_Pattern {childInhs_Inh_Pattern :: [(Name, Name)],childSyns_Inh_Pattern :: [(Name, Name)],con_Inh_Pattern :: Constructor,defs_Inh_Pattern :: Set (Name, Name),nt_Inh_Pattern :: Nonterminal} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,defsCollect_Syn_Pattern :: Set (Name, Name),errors_Syn_Pattern :: Seq Error,output_Syn_Pattern :: Pattern} +wrap_Pattern (T_Pattern sem ) (Inh_Pattern _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) = + (let ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) + in (Syn_Pattern _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput )) +sem_Pattern_Alias :: Name -> + Name -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = + (T_Pattern (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsInt -> + (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Pattern + _lhsOdefsCollect :: (Set (Name, Name)) + _lhsOcopy :: Pattern + _patOchildInhs :: ([(Name, Name)]) + _patOchildSyns :: ([(Name, Name)]) + _patOcon :: Constructor + _patOdefs :: (Set (Name, Name)) + _patOnt :: Nonterminal + _partsOchildInhs :: ([(Name, Name)]) + _partsOchildSyns :: ([(Name, Name)]) + _partsOcon :: Constructor + _partsOdefs :: (Set (Name, Name)) + _partsOnt :: Nonterminal + _patIcopy :: Pattern + _patIdefsCollect :: (Set (Name, Name)) + _patIerrors :: (Seq Error) + _patIoutput :: Pattern + _partsIcopy :: Patterns + _partsIdefsCollect :: (Set (Name, Name)) + _partsIerrors :: (Seq Error) + _partsIoutput :: Patterns + -- "Desugar.ag"(line 98, column 7) + __tup2 = + maybeError field_ (UndefAttr _lhsInt _lhsIcon (Ident "" (getPos field_)) attr_) $ + findField field_ attr_ _lhsIchildInhs + -- "Desugar.ag"(line 98, column 7) + (_field',_) = + __tup2 + -- "Desugar.ag"(line 98, column 7) + (_,_err1) = + __tup2 + -- "Desugar.ag"(line 100, column 7) + _err2 = + if _field' == field_ + then Seq.empty + else if (_field' , attr_) `Set.member` _lhsIdefs + then Seq.single $ DupRule _lhsInt _lhsIcon field_ attr_ _field' + else Seq.empty + -- "Desugar.ag"(line 105, column 7) + _lhsOerrors = + _err1 Seq.<> _err2 Seq.<> _patIerrors <> _partsIerrors + -- "Desugar.ag"(line 106, column 7) + _lhsOoutput = + Alias _field' attr_ _patIoutput _partsIoutput + -- "Desugar.ag"(line 159, column 7) + _def = + Set.singleton (field_, attr_) + -- "Desugar.ag"(line 160, column 7) + _lhsOdefsCollect = + _def `Set.union` _patIdefsCollect `Set.union` _partsIdefsCollect + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _output = + Alias field_ attr_ _patIoutput _partsIoutput + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _patOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _patOcon = + _lhsIcon + -- copy rule (down) + _patOdefs = + _lhsIdefs + -- copy rule (down) + _patOnt = + _lhsInt + -- copy rule (down) + _partsOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _partsOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _partsOcon = + _lhsIcon + -- copy rule (down) + _partsOdefs = + _lhsIdefs + -- copy rule (down) + _partsOnt = + _lhsInt + ( _patIcopy,_patIdefsCollect,_patIerrors,_patIoutput) = + (pat_ _patOchildInhs _patOchildSyns _patOcon _patOdefs _patOnt ) + ( _partsIcopy,_partsIdefsCollect,_partsIerrors,_partsIoutput) = + (parts_ _partsOchildInhs _partsOchildSyns _partsOcon _partsOdefs _partsOnt ) + in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) +sem_Pattern_Constr :: Constructor -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_ ) = + (T_Pattern (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsInt -> + (let _lhsOdefsCollect :: (Set (Name, Name)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patsOchildInhs :: ([(Name, Name)]) + _patsOchildSyns :: ([(Name, Name)]) + _patsOcon :: Constructor + _patsOdefs :: (Set (Name, Name)) + _patsOnt :: Nonterminal + _patsIcopy :: Patterns + _patsIdefsCollect :: (Set (Name, Name)) + _patsIerrors :: (Seq Error) + _patsIoutput :: Patterns + -- use rule "Desugar.ag"(line 156, column 52) + _lhsOdefsCollect = + _patsIdefsCollect + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _patsIerrors + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _output = + Constr name_ _patsIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patsOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _patsOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOdefs = + _lhsIdefs + -- copy rule (down) + _patsOnt = + _lhsInt + ( _patsIcopy,_patsIdefsCollect,_patsIerrors,_patsIoutput) = + (pats_ _patsOchildInhs _patsOchildSyns _patsOcon _patsOdefs _patsOnt ) + in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_ ) = + (T_Pattern (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsInt -> + (let _lhsOdefsCollect :: (Set (Name, Name)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patsOchildInhs :: ([(Name, Name)]) + _patsOchildSyns :: ([(Name, Name)]) + _patsOcon :: Constructor + _patsOdefs :: (Set (Name, Name)) + _patsOnt :: Nonterminal + _patsIcopy :: Patterns + _patsIdefsCollect :: (Set (Name, Name)) + _patsIerrors :: (Seq Error) + _patsIoutput :: Patterns + -- use rule "Desugar.ag"(line 156, column 52) + _lhsOdefsCollect = + _patsIdefsCollect + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _patsIerrors + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _output = + Product pos_ _patsIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patsOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _patsOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOdefs = + _lhsIdefs + -- copy rule (down) + _patsOnt = + _lhsInt + ( _patsIcopy,_patsIdefsCollect,_patsIerrors,_patsIoutput) = + (pats_ _patsOchildInhs _patsOchildSyns _patsOcon _patsOdefs _patsOnt ) + in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsInt -> + (let _lhsOdefsCollect :: (Set (Name, Name)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + -- use rule "Desugar.ag"(line 156, column 52) + _lhsOdefsCollect = + Set.empty + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _copy = + Underscore pos_ + -- self rule + _output = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) +-- Patterns ---------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Name, Name)] + childSyns : [(Name, Name)] + con : Constructor + defs : Set (Name, Name) + nt : Nonterminal + synthesized attributes: + copy : SELF + defsCollect : Set (Name, Name) + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + local output : _ + alternative Nil: + visit 0: + local copy : _ + local output : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) +-- semantic domain +newtype T_Patterns = T_Patterns (([(Name, Name)]) -> + ([(Name, Name)]) -> + Constructor -> + (Set (Name, Name)) -> + Nonterminal -> + ( Patterns,(Set (Name, Name)),(Seq Error),Patterns)) +data Inh_Patterns = Inh_Patterns {childInhs_Inh_Patterns :: [(Name, Name)],childSyns_Inh_Patterns :: [(Name, Name)],con_Inh_Patterns :: Constructor,defs_Inh_Patterns :: Set (Name, Name),nt_Inh_Patterns :: Nonterminal} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,defsCollect_Syn_Patterns :: Set (Name, Name),errors_Syn_Patterns :: Seq Error,output_Syn_Patterns :: Patterns} +wrap_Patterns (T_Patterns sem ) (Inh_Patterns _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) = + (let ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) + in (Syn_Patterns _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput )) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = + (T_Patterns (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsInt -> + (let _lhsOdefsCollect :: (Set (Name, Name)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Patterns + _lhsOoutput :: Patterns + _hdOchildInhs :: ([(Name, Name)]) + _hdOchildSyns :: ([(Name, Name)]) + _hdOcon :: Constructor + _hdOdefs :: (Set (Name, Name)) + _hdOnt :: Nonterminal + _tlOchildInhs :: ([(Name, Name)]) + _tlOchildSyns :: ([(Name, Name)]) + _tlOcon :: Constructor + _tlOdefs :: (Set (Name, Name)) + _tlOnt :: Nonterminal + _hdIcopy :: Pattern + _hdIdefsCollect :: (Set (Name, Name)) + _hdIerrors :: (Seq Error) + _hdIoutput :: Pattern + _tlIcopy :: Patterns + _tlIdefsCollect :: (Set (Name, Name)) + _tlIerrors :: (Seq Error) + _tlIoutput :: Patterns + -- use rule "Desugar.ag"(line 156, column 52) + _lhsOdefsCollect = + _hdIdefsCollect `Set.union` _tlIdefsCollect + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _hdOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOdefs = + _lhsIdefs + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _tlOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _tlOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOdefs = + _lhsIdefs + -- copy rule (down) + _tlOnt = + _lhsInt + ( _hdIcopy,_hdIdefsCollect,_hdIerrors,_hdIoutput) = + (hd_ _hdOchildInhs _hdOchildSyns _hdOcon _hdOdefs _hdOnt ) + ( _tlIcopy,_tlIdefsCollect,_tlIerrors,_tlIoutput) = + (tl_ _tlOchildInhs _tlOchildSyns _tlOcon _tlOdefs _tlOnt ) + in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsInt -> + (let _lhsOdefsCollect :: (Set (Name, Name)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Patterns + _lhsOoutput :: Patterns + -- use rule "Desugar.ag"(line 156, column 52) + _lhsOdefsCollect = + Set.empty + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _copy = + [] + -- self rule + _output = + [] + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) +-- Production -------------------------------------------------- +{- + visit 0: + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Production: + child nt : {Nonterminal} + child inh : {Attributes} + child syn : {Attributes} + child alts : Alternatives + visit 0: + local output : _ +-} +-- cata +sem_Production :: Production -> + T_Production +sem_Production (Production _nt _inh _syn _alts ) = + (sem_Production_Production _nt _inh _syn (sem_Alternatives _alts ) ) +-- semantic domain +newtype T_Production = T_Production (( (Seq Error),Production)) +data Inh_Production = Inh_Production {} +data Syn_Production = Syn_Production {errors_Syn_Production :: Seq Error,output_Syn_Production :: Production} +wrap_Production (T_Production sem ) (Inh_Production ) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem ) + in (Syn_Production _lhsOerrors _lhsOoutput )) +sem_Production_Production :: Nonterminal -> + Attributes -> + Attributes -> + T_Alternatives -> + T_Production +sem_Production_Production nt_ inh_ syn_ (T_Alternatives alts_ ) = + (T_Production (let _altsOnt :: Nonterminal + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Production + _altsIerrors :: (Seq Error) + _altsIoutput :: Alternatives + -- "Desugar.ag"(line 145, column 7) + _altsOnt = + nt_ + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _altsIerrors + -- self rule + _output = + Production nt_ inh_ syn_ _altsIoutput + -- self rule + _lhsOoutput = + _output + ( _altsIerrors,_altsIoutput) = + (alts_ _altsOnt ) + in ( _lhsOerrors,_lhsOoutput)) ) +-- Productions ------------------------------------------------- +{- + visit 0: + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Production + child tl : Productions + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Productions :: Productions -> + T_Productions +sem_Productions list = + (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) ) +-- semantic domain +newtype T_Productions = T_Productions (( (Seq Error),Productions)) +data Inh_Productions = Inh_Productions {} +data Syn_Productions = Syn_Productions {errors_Syn_Productions :: Seq Error,output_Syn_Productions :: Productions} +wrap_Productions (T_Productions sem ) (Inh_Productions ) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem ) + in (Syn_Productions _lhsOerrors _lhsOoutput )) +sem_Productions_Cons :: T_Production -> + T_Productions -> + T_Productions +sem_Productions_Cons (T_Production hd_ ) (T_Productions tl_ ) = + (T_Productions (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Productions + _hdIerrors :: (Seq Error) + _hdIoutput :: Production + _tlIerrors :: (Seq Error) + _tlIoutput :: Productions + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + ( _hdIerrors,_hdIoutput) = + (hd_ ) + ( _tlIerrors,_tlIoutput) = + (tl_ ) + in ( _lhsOerrors,_lhsOoutput)) ) +sem_Productions_Nil :: T_Productions +sem_Productions_Nil = + (T_Productions (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Productions + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOerrors,_lhsOoutput)) ) +-- Rule -------------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Name, Name)] + childSyns : [(Name, Name)] + con : Constructor + defs : Set (Name, Name) + nt : Nonterminal + synthesized attributes: + defsCollect : Set (Name, Name) + errors : Seq Error + output : SELF + alternatives: + alternative Rule: + child pattern : Pattern + child rhs : Expression + child owrt : {Bool} + child origin : {String} + visit 0: + local output : _ +-} +-- cata +sem_Rule :: Rule -> + T_Rule +sem_Rule (Rule _pattern _rhs _owrt _origin ) = + (sem_Rule_Rule (sem_Pattern _pattern ) (sem_Expression _rhs ) _owrt _origin ) +-- semantic domain +newtype T_Rule = T_Rule (([(Name, Name)]) -> + ([(Name, Name)]) -> + Constructor -> + (Set (Name, Name)) -> + Nonterminal -> + ( (Set (Name, Name)),(Seq Error),Rule)) +data Inh_Rule = Inh_Rule {childInhs_Inh_Rule :: [(Name, Name)],childSyns_Inh_Rule :: [(Name, Name)],con_Inh_Rule :: Constructor,defs_Inh_Rule :: Set (Name, Name),nt_Inh_Rule :: Nonterminal} +data Syn_Rule = Syn_Rule {defsCollect_Syn_Rule :: Set (Name, Name),errors_Syn_Rule :: Seq Error,output_Syn_Rule :: Rule} +wrap_Rule (T_Rule sem ) (Inh_Rule _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) = + (let ( _lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) + in (Syn_Rule _lhsOdefsCollect _lhsOerrors _lhsOoutput )) +sem_Rule_Rule :: T_Pattern -> + T_Expression -> + Bool -> + String -> + T_Rule +sem_Rule_Rule (T_Pattern pattern_ ) (T_Expression rhs_ ) owrt_ origin_ = + (T_Rule (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsInt -> + (let _lhsOdefsCollect :: (Set (Name, Name)) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Rule + _patternOchildInhs :: ([(Name, Name)]) + _patternOchildSyns :: ([(Name, Name)]) + _patternOcon :: Constructor + _patternOdefs :: (Set (Name, Name)) + _patternOnt :: Nonterminal + _rhsOchildInhs :: ([(Name, Name)]) + _rhsOchildSyns :: ([(Name, Name)]) + _rhsOcon :: Constructor + _rhsOnt :: Nonterminal + _patternIcopy :: Pattern + _patternIdefsCollect :: (Set (Name, Name)) + _patternIerrors :: (Seq Error) + _patternIoutput :: Pattern + _rhsIerrors :: (Seq Error) + _rhsIoutput :: Expression + -- use rule "Desugar.ag"(line 156, column 52) + _lhsOdefsCollect = + _patternIdefsCollect + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _patternIerrors Seq.<> _rhsIerrors + -- self rule + _output = + Rule _patternIoutput _rhsIoutput owrt_ origin_ + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patternOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _patternOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _patternOcon = + _lhsIcon + -- copy rule (down) + _patternOdefs = + _lhsIdefs + -- copy rule (down) + _patternOnt = + _lhsInt + -- copy rule (down) + _rhsOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _rhsOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _rhsOcon = + _lhsIcon + -- copy rule (down) + _rhsOnt = + _lhsInt + ( _patternIcopy,_patternIdefsCollect,_patternIerrors,_patternIoutput) = + (pattern_ _patternOchildInhs _patternOchildSyns _patternOcon _patternOdefs _patternOnt ) + ( _rhsIerrors,_rhsIoutput) = + (rhs_ _rhsOchildInhs _rhsOchildSyns _rhsOcon _rhsOnt ) + in ( _lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) +-- Rules ------------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Name, Name)] + childSyns : [(Name, Name)] + con : Constructor + defs : Set (Name, Name) + nt : Nonterminal + synthesized attributes: + defsCollect : Set (Name, Name) + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Rule + child tl : Rules + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Rules :: Rules -> + T_Rules +sem_Rules list = + (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) ) +-- semantic domain +newtype T_Rules = T_Rules (([(Name, Name)]) -> + ([(Name, Name)]) -> + Constructor -> + (Set (Name, Name)) -> + Nonterminal -> + ( (Set (Name, Name)),(Seq Error),Rules)) +data Inh_Rules = Inh_Rules {childInhs_Inh_Rules :: [(Name, Name)],childSyns_Inh_Rules :: [(Name, Name)],con_Inh_Rules :: Constructor,defs_Inh_Rules :: Set (Name, Name),nt_Inh_Rules :: Nonterminal} +data Syn_Rules = Syn_Rules {defsCollect_Syn_Rules :: Set (Name, Name),errors_Syn_Rules :: Seq Error,output_Syn_Rules :: Rules} +wrap_Rules (T_Rules sem ) (Inh_Rules _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) = + (let ( _lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) + in (Syn_Rules _lhsOdefsCollect _lhsOerrors _lhsOoutput )) +sem_Rules_Cons :: T_Rule -> + T_Rules -> + T_Rules +sem_Rules_Cons (T_Rule hd_ ) (T_Rules tl_ ) = + (T_Rules (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsInt -> + (let _lhsOdefsCollect :: (Set (Name, Name)) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Rules + _hdOchildInhs :: ([(Name, Name)]) + _hdOchildSyns :: ([(Name, Name)]) + _hdOcon :: Constructor + _hdOdefs :: (Set (Name, Name)) + _hdOnt :: Nonterminal + _tlOchildInhs :: ([(Name, Name)]) + _tlOchildSyns :: ([(Name, Name)]) + _tlOcon :: Constructor + _tlOdefs :: (Set (Name, Name)) + _tlOnt :: Nonterminal + _hdIdefsCollect :: (Set (Name, Name)) + _hdIerrors :: (Seq Error) + _hdIoutput :: Rule + _tlIdefsCollect :: (Set (Name, Name)) + _tlIerrors :: (Seq Error) + _tlIoutput :: Rules + -- use rule "Desugar.ag"(line 156, column 52) + _lhsOdefsCollect = + _hdIdefsCollect `Set.union` _tlIdefsCollect + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _hdOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOdefs = + _lhsIdefs + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _tlOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _tlOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOdefs = + _lhsIdefs + -- copy rule (down) + _tlOnt = + _lhsInt + ( _hdIdefsCollect,_hdIerrors,_hdIoutput) = + (hd_ _hdOchildInhs _hdOchildSyns _hdOcon _hdOdefs _hdOnt ) + ( _tlIdefsCollect,_tlIerrors,_tlIoutput) = + (tl_ _tlOchildInhs _tlOchildSyns _tlOcon _tlOdefs _tlOnt ) + in ( _lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) +sem_Rules_Nil :: T_Rules +sem_Rules_Nil = + (T_Rules (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsInt -> + (let _lhsOdefsCollect :: (Set (Name, Name)) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Rules + -- use rule "Desugar.ag"(line 156, column 52) + _lhsOdefsCollect = + Set.empty + -- use rule "Desugar.ag"(line 30, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) +-- TypeSig ----------------------------------------------------- +{- + visit 0: + synthesized attribute: + output : SELF + alternatives: + alternative TypeSig: + child name : {Name} + child tp : {Type} + visit 0: + local output : _ +-} +-- cata +sem_TypeSig :: TypeSig -> + T_TypeSig +sem_TypeSig (TypeSig _name _tp ) = + (sem_TypeSig_TypeSig _name _tp ) +-- semantic domain +newtype T_TypeSig = T_TypeSig (( TypeSig)) +data Inh_TypeSig = Inh_TypeSig {} +data Syn_TypeSig = Syn_TypeSig {output_Syn_TypeSig :: TypeSig} +wrap_TypeSig (T_TypeSig sem ) (Inh_TypeSig ) = + (let ( _lhsOoutput) = + (sem ) + in (Syn_TypeSig _lhsOoutput )) +sem_TypeSig_TypeSig :: Name -> + Type -> + T_TypeSig +sem_TypeSig_TypeSig name_ tp_ = + (T_TypeSig (let _lhsOoutput :: TypeSig + -- self rule + _output = + TypeSig name_ tp_ + -- self rule + _lhsOoutput = + _output + in ( _lhsOoutput)) ) +-- TypeSigs ---------------------------------------------------- +{- + visit 0: + synthesized attribute: + output : SELF + alternatives: + alternative Cons: + child hd : TypeSig + child tl : TypeSigs + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_TypeSigs :: TypeSigs -> + T_TypeSigs +sem_TypeSigs list = + (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) ) +-- semantic domain +newtype T_TypeSigs = T_TypeSigs (( TypeSigs)) +data Inh_TypeSigs = Inh_TypeSigs {} +data Syn_TypeSigs = Syn_TypeSigs {output_Syn_TypeSigs :: TypeSigs} +wrap_TypeSigs (T_TypeSigs sem ) (Inh_TypeSigs ) = + (let ( _lhsOoutput) = + (sem ) + in (Syn_TypeSigs _lhsOoutput )) +sem_TypeSigs_Cons :: T_TypeSig -> + T_TypeSigs -> + T_TypeSigs +sem_TypeSigs_Cons (T_TypeSig hd_ ) (T_TypeSigs tl_ ) = + (T_TypeSigs (let _lhsOoutput :: TypeSigs + _hdIoutput :: TypeSig + _tlIoutput :: TypeSigs + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + ( _hdIoutput) = + (hd_ ) + ( _tlIoutput) = + (tl_ ) + in ( _lhsOoutput)) ) +sem_TypeSigs_Nil :: T_TypeSigs +sem_TypeSigs_Nil = + (T_TypeSigs (let _lhsOoutput :: TypeSigs + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOoutput)) ) diff --git a/src-derived/ErrorMessages.hs b/src-derived/ErrorMessages.hs new file mode 100644 --- /dev/null +++ b/src-derived/ErrorMessages.hs @@ -0,0 +1,155 @@ + +-- UUAGC 0.9.5 (ErrorMessages.ag) +module ErrorMessages where + +import UU.Scanner.Position(Pos) +import Pretty +import DepTypes(Trace) +import CodeSyntax +import CommonTypes +-- Error ------------------------------------------------------- +{- + alternatives: + alternative ChildAsLocal: + child nt : {Nonterminal} + child con : {Constructor} + child var : {Name} + alternative CustomError: + child isWarning : {Bool} + child pos : {Pos} + child mesg : {PP_Doc} + alternative CyclicSet: + child name : {Name} + alternative DirectCirc: + child nt : {Nonterminal} + child o_visit : {Bool} + child cyclic : {[((Name,Name),[String],[String])]} + alternative DupAlt: + child nt : {Nonterminal} + child con : {Constructor} + child occ1 : {Constructor} + alternative DupChild: + child nt : {Nonterminal} + child con : {Constructor} + child name : {Name} + child occ1 : {Name} + alternative DupInhAttr: + child nt : {Nonterminal} + child attr : {Name} + child occ1 : {Name} + alternative DupRule: + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child attr : {Name} + child occ1 : {Name} + alternative DupSet: + child name : {Nonterminal} + child occ1 : {Nonterminal} + alternative DupSig: + child nt : {Nonterminal} + child con : {Constructor} + child attr : {Name} + alternative DupSynAttr: + child nt : {Nonterminal} + child attr : {Name} + child occ1 : {Name} + alternative DupSynonym: + child nt : {Nonterminal} + child occ1 : {Nonterminal} + alternative ErroneousOrder: + child nt : {Nonterminal} + child con : {Constructor} + child order : {Dependency} + alternative InducedCirc: + child nt : {Nonterminal} + child cinter : {CInterface} + child cyclic : {[((Name,Name),[String],[String])]} + alternative InstCirc: + child nt : {Nonterminal} + child con : {Constructor} + child attr : {Name} + child o_visit : {Bool} + child path : {[String]} + alternative LocalCirc: + child nt : {Nonterminal} + child con : {Constructor} + child attr : {Name} + child o_visit : {Bool} + child path : {[String]} + alternative MissingInstSig: + child nt : {Nonterminal} + child con : {Constructor} + child attr : {Name} + alternative MissingRule: + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child attr : {Name} + alternative MissingTypeSig: + child nt : {Nonterminal} + child con : {Constructor} + child attr : {Name} + alternative ParserError: + child pos : {Pos} + child problem : {String} + child action : {String} + alternative SuperfluousRule: + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child attr : {Name} + alternative UndefAlt: + child nt : {Nonterminal} + child con : {Constructor} + alternative UndefAttr: + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child attr : {Name} + alternative UndefChild: + child nt : {Nonterminal} + child con : {Constructor} + child name : {Name} + alternative UndefLocal: + child nt : {Nonterminal} + child con : {Constructor} + child var : {Name} + alternative UndefNont: + child nt : {Nonterminal} +-} +data Error = ChildAsLocal (Nonterminal) (Constructor) (Name) + | CustomError (Bool) (Pos) (PP_Doc) + | CyclicSet (Name) + | DirectCirc (Nonterminal) (Bool) ([((Name,Name),[String],[String])]) + | DupAlt (Nonterminal) (Constructor) (Constructor) + | DupChild (Nonterminal) (Constructor) (Name) (Name) + | DupInhAttr (Nonterminal) (Name) (Name) + | DupRule (Nonterminal) (Constructor) (Name) (Name) (Name) + | DupSet (Nonterminal) (Nonterminal) + | DupSig (Nonterminal) (Constructor) (Name) + | DupSynAttr (Nonterminal) (Name) (Name) + | DupSynonym (Nonterminal) (Nonterminal) + | ErroneousOrder (Nonterminal) (Constructor) (Dependency) + | InducedCirc (Nonterminal) (CInterface) ([((Name,Name),[String],[String])]) + | InstCirc (Nonterminal) (Constructor) (Name) (Bool) ([String]) + | LocalCirc (Nonterminal) (Constructor) (Name) (Bool) ([String]) + | MissingInstSig (Nonterminal) (Constructor) (Name) + | MissingRule (Nonterminal) (Constructor) (Name) (Name) + | MissingTypeSig (Nonterminal) (Constructor) (Name) + | ParserError (Pos) (String) (String) + | SuperfluousRule (Nonterminal) (Constructor) (Name) (Name) + | UndefAlt (Nonterminal) (Constructor) + | UndefAttr (Nonterminal) (Constructor) (Name) (Name) + | UndefChild (Nonterminal) (Constructor) (Name) + | UndefLocal (Nonterminal) (Constructor) (Name) + | UndefNont (Nonterminal) +-- Errors ------------------------------------------------------ +{- + alternatives: + alternative Cons: + child hd : Error + child tl : Errors + alternative Nil: +-} +type Errors = [Error] diff --git a/src-derived/Expression.hs b/src-derived/Expression.hs new file mode 100644 --- /dev/null +++ b/src-derived/Expression.hs @@ -0,0 +1,13 @@ + +-- UUAGC 0.9.5 (Expression.ag) +module Expression where + +import UU.Scanner.Position(Pos) +-- Expression -------------------------------------------------- +{- + alternatives: + alternative Expression: + child pos : {Pos} + child txt : {String} +-} +data Expression = Expression (Pos) (String) diff --git a/src-derived/GenerateCode.hs b/src-derived/GenerateCode.hs new file mode 100644 --- /dev/null +++ b/src-derived/GenerateCode.hs @@ -0,0 +1,4544 @@ + +-- UUAGC 0.9.5 (GenerateCode.ag) +module GenerateCode where + +import SequentialTypes +import Code hiding (Type) +import qualified Code +import Options +import CodeSyntax +import ErrorMessages +import GrammarInfo +import DeclBlocks + +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Set as Set +import Data.Set(Set) +import qualified UU.DData.Seq as Seq +import UU.DData.Seq(Seq) +import UU.Scanner.Position + +import Data.List(partition,intersperse,intersect,(\\)) +import Maybe(fromJust,isJust) + +import Patterns +import CommonTypes +import Data.Map(Map) +import Data.Set(Set) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (Constructor,Name) + +import Code (Decl,Expr) + +substSelf nt tp = if tp==NT _SELF + then Haskell (getName nt) + else tp + +mkLambda [] e = e +mkLambda xs e = Lambda xs e + +-- dead code - replaced by mkPartitionedFunction +{- +localCpsToExpr :: Bool -> [Decl] -> DeclBlocks -> Expr +localCpsToExpr o_case nextVisitDecl + = rec + where + rec cps + = case cps of + DeclTerminator decls expr + -> mkLet o_case (decls ++ nextVisitDecl) expr + DeclBlock decls (Decl lhs rhs _ _) remainder + -> let inDecls = [ PragmaDecl ("NOINLINE " ++ internalCpsName) + , Decl (Fun internalCpsName [SimpleExpr internalCpsVarName]) + (mkLet o_case [Decl lhs (SimpleExpr internalCpsVarName) Set.empty Set.empty] (rec remainder)) + Set.empty Set.empty + ] + inBody = App "head" [App "(:)" [App internalCpsName [rhs], App "(:)" [App internalCpsName [rhs], SimpleExpr "[]"]]] + outerBody = Let inDecls inBody + block = mkLet o_case decls outerBody + in block + +internalCpsName :: String +internalCpsName = "internalCps_" + +internalCpsVarName :: String +internalCpsVarName = "internalCps_var_" +-} + +mkPartitionedFunction :: String -> Bool -> [Decl] -> [String] -> DeclBlocks -> ([Decl], Expr) +mkPartitionedFunction prefix optCase nextVisitDecls lastExprVars cpsTree + = let inh = Inh_DeclBlocksRoot { prefix_Inh_DeclBlocksRoot = prefix + , optCase_Inh_DeclBlocksRoot = optCase + , nextVisitDecls_Inh_DeclBlocksRoot = nextVisitDecls + , lastExprVars_Inh_DeclBlocksRoot = lastExprVars + } + sem = sem_DeclBlocksRoot (DeclBlocksRoot cpsTree) + syn = wrap_DeclBlocksRoot sem inh + in (lambdas_Syn_DeclBlocksRoot syn, firstCall_Syn_DeclBlocksRoot syn) + +freevars :: [String] -> [Decl] -> [String] +freevars additional decls + = Set.toList (allused `Set.difference` alldefined) + where + allused = Set.unions (Set.fromList additional : map usedvars decls) + alldefined = Set.unions (map definedvars decls) + + usedvars (Decl _ _ _ uses) = uses + usedvars _ = Set.empty + + definedvars (Decl _ _ defs _) = defs + definedvars _ = Set.empty + +mkBlockLambda :: Bool -> String -> [String] -> [Decl] -> Expr -> Decl +mkBlockLambda optCase name args decls expr + = Decl lhs rhs Set.empty Set.empty + where + lhs = Fun name (map SimpleExpr args) + rhs = mkLet optCase decls expr + +makeLocalComment :: Int -> String -> Name -> Maybe Type -> String +makeLocalComment width what name tp = let x = getName name + y = maybe "_" (\t -> case t of (NT nt) -> getName nt; Haskell t -> '{':t++"}") tp + in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y ) + + +-- Lets or nested Cases? +mkLet :: Bool -> Decls -> Expr -> Expr +mkLet False decls body = Let decls body +mkLet True decls body = foldr oneCase body decls + +oneCase :: Decl -> Expr -> Expr +oneCase (Decl left rhs _ _) exp = Case rhs [CaseAlt left exp] +oneCase _ exp = exp + +-- Gives the name of the visit function +funname field 0 = show field ++ "_" +funname field nr = show field ++ "_" ++ show nr + +-- Gives the name of a semantic function +seqSemname :: String -> Nonterminal -> Constructor -> Int -> String +seqSemname pre nt con 0 = semname pre nt con +seqSemname pre nt con nr = semname pre nt con ++ "_" ++ show nr + +-- Gives the name of a type +typeName :: Nonterminal -> Int -> String +typeName nt 0 = "T_" ++ show nt +typeName nt n = "T_" ++ show nt ++ "_" ++ show n + +-- Gives the name of a visit function +visitname :: String -> Nonterminal -> Int -> String +visitname pre nt n = pre ++ getName nt ++ "_" ++ show n +-- CAlternative ------------------------------------------------ +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + inh : Attributes + nt : Nonterminal + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + syn : Attributes + with_sig : Bool + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + cataAlt : Decl + comments : [String] + dataAlt : DataAlt + decls : Decls + semNames : [String] + alternatives: + alternative CAlternative: + child con : {Constructor} + child visits : CVisits + child children : {[(Name,Type,Bool)]} + child terminals : {[Name]} + visit 0: + local firstOrderChildren : _ +-} +-- cata +sem_CAlternative :: CAlternative -> + T_CAlternative +sem_CAlternative (CAlternative _con _visits _children _terminals ) = + (sem_CAlternative_CAlternative _con (sem_CVisits _visits ) _children _terminals ) +-- semantic domain +newtype T_CAlternative = T_CAlternative (PragmaMap -> + (Seq Error) -> + Attributes -> + Nonterminal -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + Bool -> + ( Bool,Decl,([String]),DataAlt,Decls,(Seq Error),([String]))) +data Inh_CAlternative = Inh_CAlternative {allPragmas_Inh_CAlternative :: PragmaMap,errors_Inh_CAlternative :: Seq Error,inh_Inh_CAlternative :: Attributes,nt_Inh_CAlternative :: Nonterminal,o_case_Inh_CAlternative :: Bool,o_cata_Inh_CAlternative :: Bool,o_costcentre_Inh_CAlternative :: Bool,o_data_Inh_CAlternative :: Maybe Bool,o_linePragmas_Inh_CAlternative :: Bool,o_newtypes_Inh_CAlternative :: Bool,o_pretty_Inh_CAlternative :: Bool,o_rename_Inh_CAlternative :: Bool,o_sem_Inh_CAlternative :: Bool,o_sig_Inh_CAlternative :: Bool,o_splitsems_Inh_CAlternative :: Bool,o_strictwrap_Inh_CAlternative :: Bool,o_traces_Inh_CAlternative :: Bool,o_unbox_Inh_CAlternative :: Bool,prefix_Inh_CAlternative :: String,syn_Inh_CAlternative :: Attributes,with_sig_Inh_CAlternative :: Bool} +data Syn_CAlternative = Syn_CAlternative {allTpsFound_Syn_CAlternative :: Bool,cataAlt_Syn_CAlternative :: Decl,comments_Syn_CAlternative :: [String],dataAlt_Syn_CAlternative :: DataAlt,decls_Syn_CAlternative :: Decls,errors_Syn_CAlternative :: Seq Error,semNames_Syn_CAlternative :: [String]} +wrap_CAlternative (T_CAlternative sem ) (Inh_CAlternative _lhsIallPragmas _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIwith_sig ) = + (let ( _lhsOallTpsFound,_lhsOcataAlt,_lhsOcomments,_lhsOdataAlt,_lhsOdecls,_lhsOerrors,_lhsOsemNames) = + (sem _lhsIallPragmas _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIwith_sig ) + in (Syn_CAlternative _lhsOallTpsFound _lhsOcataAlt _lhsOcomments _lhsOdataAlt _lhsOdecls _lhsOerrors _lhsOsemNames )) +sem_CAlternative_CAlternative :: Constructor -> + T_CVisits -> + ([(Name,Type,Bool)]) -> + ([Name]) -> + T_CAlternative +sem_CAlternative_CAlternative con_ (T_CVisits visits_ ) children_ terminals_ = + (T_CAlternative (\ _lhsIallPragmas + _lhsIerrors + _lhsIinh + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn + _lhsIwith_sig -> + (let _visitsOcon :: Constructor + _visitsOterminals :: ([Name]) + _visitsOnr :: Int + _visitsOchildren :: ([(Name,Type,Bool)]) + _visitsOinstVisitNrs :: (Map Identifier Int) + _lhsOcomments :: ([String]) + _lhsOdataAlt :: DataAlt + _lhsOcataAlt :: Decl + _lhsOallTpsFound :: Bool + _lhsOdecls :: Decls + _lhsOerrors :: (Seq Error) + _lhsOsemNames :: ([String]) + _visitsOallPragmas :: PragmaMap + _visitsOerrors :: (Seq Error) + _visitsOinh :: Attributes + _visitsOnt :: Nonterminal + _visitsOo_case :: Bool + _visitsOo_cata :: Bool + _visitsOo_costcentre :: Bool + _visitsOo_data :: (Maybe Bool) + _visitsOo_linePragmas :: Bool + _visitsOo_newtypes :: Bool + _visitsOo_pretty :: Bool + _visitsOo_rename :: Bool + _visitsOo_sem :: Bool + _visitsOo_sig :: Bool + _visitsOo_splitsems :: Bool + _visitsOo_strictwrap :: Bool + _visitsOo_traces :: Bool + _visitsOo_unbox :: Bool + _visitsOprefix :: String + _visitsOsyn :: Attributes + _visitsOwith_sig :: Bool + _visitsIallTpsFound :: Bool + _visitsIcomments :: ([String]) + _visitsIdecls :: Decls + _visitsIerrors :: (Seq Error) + _visitsIgatherInstVisitNrs :: (Map Identifier Int) + _visitsIintra :: Exprs + _visitsIintraVars :: (Set String) + _visitsIisNil :: Bool + _visitsIsemNames :: ([String]) + -- "GenerateCode.ag"(line 78, column 20) + _visitsOcon = + con_ + -- "GenerateCode.ag"(line 79, column 20) + _visitsOterminals = + terminals_ + -- "GenerateCode.ag"(line 159, column 19) + _visitsOnr = + 0 + -- "GenerateCode.ag"(line 261, column 19) + _visitsOchildren = + children_ + -- "GenerateCode.ag"(line 349, column 7) + _visitsOinstVisitNrs = + _visitsIgatherInstVisitNrs + -- "GenerateCode.ag"(line 594, column 18) + _firstOrderChildren = + filter (\(_,_,ho) -> not ho) children_ + -- "GenerateCode.ag"(line 595, column 18) + _lhsOcomments = + ("alternative " ++ getName con_ ++ ":") + : map ind ( map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) _firstOrderChildren + ++ _visitsIcomments + ) + -- "GenerateCode.ag"(line 704, column 19) + _lhsOdataAlt = + DataAlt (conname _lhsIo_rename _lhsInt con_) (map (\(_,t,_) -> typeToString _lhsInt t) _firstOrderChildren ) + -- "GenerateCode.ag"(line 759, column 18) + _lhsOcataAlt = + let lhs = Fun (cataname _lhsIprefix _lhsInt) [lhs_pat] + lhs_pat = App (conname _lhsIo_rename _lhsInt con_) + (map (\(n,_,_) -> SimpleExpr $ locname $ n) _firstOrderChildren ) + rhs = App (semname _lhsIprefix _lhsInt con_) + (map argument _firstOrderChildren ) + argument (nm,NT tp,_) = App (cataname _lhsIprefix tp) + [SimpleExpr (locname nm)] + argument (nm, _,_) = SimpleExpr (locname nm) + in Decl lhs rhs Set.empty Set.empty + -- use rule "GenerateCode.ag"(line 551, column 39) + _lhsOallTpsFound = + _visitsIallTpsFound + -- use rule "GenerateCode.ag"(line 626, column 46) + _lhsOdecls = + _visitsIdecls + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + _visitsIerrors + -- use rule "GenerateCode.ag"(line 774, column 63) + _lhsOsemNames = + _visitsIsemNames + -- copy rule (down) + _visitsOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _visitsOerrors = + _lhsIerrors + -- copy rule (down) + _visitsOinh = + _lhsIinh + -- copy rule (down) + _visitsOnt = + _lhsInt + -- copy rule (down) + _visitsOo_case = + _lhsIo_case + -- copy rule (down) + _visitsOo_cata = + _lhsIo_cata + -- copy rule (down) + _visitsOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _visitsOo_data = + _lhsIo_data + -- copy rule (down) + _visitsOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _visitsOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _visitsOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _visitsOo_rename = + _lhsIo_rename + -- copy rule (down) + _visitsOo_sem = + _lhsIo_sem + -- copy rule (down) + _visitsOo_sig = + _lhsIo_sig + -- copy rule (down) + _visitsOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _visitsOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _visitsOo_traces = + _lhsIo_traces + -- copy rule (down) + _visitsOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _visitsOprefix = + _lhsIprefix + -- copy rule (down) + _visitsOsyn = + _lhsIsyn + -- copy rule (down) + _visitsOwith_sig = + _lhsIwith_sig + ( _visitsIallTpsFound,_visitsIcomments,_visitsIdecls,_visitsIerrors,_visitsIgatherInstVisitNrs,_visitsIintra,_visitsIintraVars,_visitsIisNil,_visitsIsemNames) = + (visits_ _visitsOallPragmas _visitsOchildren _visitsOcon _visitsOerrors _visitsOinh _visitsOinstVisitNrs _visitsOnr _visitsOnt _visitsOo_case _visitsOo_cata _visitsOo_costcentre _visitsOo_data _visitsOo_linePragmas _visitsOo_newtypes _visitsOo_pretty _visitsOo_rename _visitsOo_sem _visitsOo_sig _visitsOo_splitsems _visitsOo_strictwrap _visitsOo_traces _visitsOo_unbox _visitsOprefix _visitsOsyn _visitsOterminals _visitsOwith_sig ) + in ( _lhsOallTpsFound,_lhsOcataAlt,_lhsOcomments,_lhsOdataAlt,_lhsOdecls,_lhsOerrors,_lhsOsemNames))) ) +-- CAlternatives ----------------------------------------------- +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + inh : Attributes + nt : Nonterminal + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + syn : Attributes + with_sig : Bool + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + cataAlts : Decls + comments : [String] + dataAlts : DataAlts + decls : Decls + semNames : [String] + alternatives: + alternative Cons: + child hd : CAlternative + child tl : CAlternatives + alternative Nil: +-} +-- cata +sem_CAlternatives :: CAlternatives -> + T_CAlternatives +sem_CAlternatives list = + (Prelude.foldr sem_CAlternatives_Cons sem_CAlternatives_Nil (Prelude.map sem_CAlternative list) ) +-- semantic domain +newtype T_CAlternatives = T_CAlternatives (PragmaMap -> + (Seq Error) -> + Attributes -> + Nonterminal -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + Bool -> + ( Bool,Decls,([String]),DataAlts,Decls,(Seq Error),([String]))) +data Inh_CAlternatives = Inh_CAlternatives {allPragmas_Inh_CAlternatives :: PragmaMap,errors_Inh_CAlternatives :: Seq Error,inh_Inh_CAlternatives :: Attributes,nt_Inh_CAlternatives :: Nonterminal,o_case_Inh_CAlternatives :: Bool,o_cata_Inh_CAlternatives :: Bool,o_costcentre_Inh_CAlternatives :: Bool,o_data_Inh_CAlternatives :: Maybe Bool,o_linePragmas_Inh_CAlternatives :: Bool,o_newtypes_Inh_CAlternatives :: Bool,o_pretty_Inh_CAlternatives :: Bool,o_rename_Inh_CAlternatives :: Bool,o_sem_Inh_CAlternatives :: Bool,o_sig_Inh_CAlternatives :: Bool,o_splitsems_Inh_CAlternatives :: Bool,o_strictwrap_Inh_CAlternatives :: Bool,o_traces_Inh_CAlternatives :: Bool,o_unbox_Inh_CAlternatives :: Bool,prefix_Inh_CAlternatives :: String,syn_Inh_CAlternatives :: Attributes,with_sig_Inh_CAlternatives :: Bool} +data Syn_CAlternatives = Syn_CAlternatives {allTpsFound_Syn_CAlternatives :: Bool,cataAlts_Syn_CAlternatives :: Decls,comments_Syn_CAlternatives :: [String],dataAlts_Syn_CAlternatives :: DataAlts,decls_Syn_CAlternatives :: Decls,errors_Syn_CAlternatives :: Seq Error,semNames_Syn_CAlternatives :: [String]} +wrap_CAlternatives (T_CAlternatives sem ) (Inh_CAlternatives _lhsIallPragmas _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIwith_sig ) = + (let ( _lhsOallTpsFound,_lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOerrors,_lhsOsemNames) = + (sem _lhsIallPragmas _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIwith_sig ) + in (Syn_CAlternatives _lhsOallTpsFound _lhsOcataAlts _lhsOcomments _lhsOdataAlts _lhsOdecls _lhsOerrors _lhsOsemNames )) +sem_CAlternatives_Cons :: T_CAlternative -> + T_CAlternatives -> + T_CAlternatives +sem_CAlternatives_Cons (T_CAlternative hd_ ) (T_CAlternatives tl_ ) = + (T_CAlternatives (\ _lhsIallPragmas + _lhsIerrors + _lhsIinh + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn + _lhsIwith_sig -> + (let _lhsOdataAlts :: DataAlts + _lhsOcataAlts :: Decls + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOerrors :: (Seq Error) + _lhsOsemNames :: ([String]) + _hdOallPragmas :: PragmaMap + _hdOerrors :: (Seq Error) + _hdOinh :: Attributes + _hdOnt :: Nonterminal + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_costcentre :: Bool + _hdOo_data :: (Maybe Bool) + _hdOo_linePragmas :: Bool + _hdOo_newtypes :: Bool + _hdOo_pretty :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_splitsems :: Bool + _hdOo_strictwrap :: Bool + _hdOo_traces :: Bool + _hdOo_unbox :: Bool + _hdOprefix :: String + _hdOsyn :: Attributes + _hdOwith_sig :: Bool + _tlOallPragmas :: PragmaMap + _tlOerrors :: (Seq Error) + _tlOinh :: Attributes + _tlOnt :: Nonterminal + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_costcentre :: Bool + _tlOo_data :: (Maybe Bool) + _tlOo_linePragmas :: Bool + _tlOo_newtypes :: Bool + _tlOo_pretty :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_splitsems :: Bool + _tlOo_strictwrap :: Bool + _tlOo_traces :: Bool + _tlOo_unbox :: Bool + _tlOprefix :: String + _tlOsyn :: Attributes + _tlOwith_sig :: Bool + _hdIallTpsFound :: Bool + _hdIcataAlt :: Decl + _hdIcomments :: ([String]) + _hdIdataAlt :: DataAlt + _hdIdecls :: Decls + _hdIerrors :: (Seq Error) + _hdIsemNames :: ([String]) + _tlIallTpsFound :: Bool + _tlIcataAlts :: Decls + _tlIcomments :: ([String]) + _tlIdataAlts :: DataAlts + _tlIdecls :: Decls + _tlIerrors :: (Seq Error) + _tlIsemNames :: ([String]) + -- "GenerateCode.ag"(line 700, column 17) + _lhsOdataAlts = + _hdIdataAlt : _tlIdataAlts + -- "GenerateCode.ag"(line 755, column 10) + _lhsOcataAlts = + _hdIcataAlt : _tlIcataAlts + -- use rule "GenerateCode.ag"(line 551, column 39) + _lhsOallTpsFound = + _hdIallTpsFound && _tlIallTpsFound + -- use rule "GenerateCode.ag"(line 583, column 52) + _lhsOcomments = + _hdIcomments ++ _tlIcomments + -- use rule "GenerateCode.ag"(line 626, column 46) + _lhsOdecls = + _hdIdecls ++ _tlIdecls + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "GenerateCode.ag"(line 774, column 63) + _lhsOsemNames = + _hdIsemNames ++ _tlIsemNames + -- copy rule (down) + _hdOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _hdOerrors = + _lhsIerrors + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _hdOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _hdOo_traces = + _lhsIo_traces + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOwith_sig = + _lhsIwith_sig + -- copy rule (down) + _tlOallPragmas = + _lhsIallPragmas + -- copy rule (chain) + _tlOerrors = + _hdIerrors + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _tlOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _tlOo_traces = + _lhsIo_traces + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (down) + _tlOwith_sig = + _lhsIwith_sig + ( _hdIallTpsFound,_hdIcataAlt,_hdIcomments,_hdIdataAlt,_hdIdecls,_hdIerrors,_hdIsemNames) = + (hd_ _hdOallPragmas _hdOerrors _hdOinh _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOprefix _hdOsyn _hdOwith_sig ) + ( _tlIallTpsFound,_tlIcataAlts,_tlIcomments,_tlIdataAlts,_tlIdecls,_tlIerrors,_tlIsemNames) = + (tl_ _tlOallPragmas _tlOerrors _tlOinh _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOprefix _tlOsyn _tlOwith_sig ) + in ( _lhsOallTpsFound,_lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOerrors,_lhsOsemNames))) ) +sem_CAlternatives_Nil :: T_CAlternatives +sem_CAlternatives_Nil = + (T_CAlternatives (\ _lhsIallPragmas + _lhsIerrors + _lhsIinh + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn + _lhsIwith_sig -> + (let _lhsOdataAlts :: DataAlts + _lhsOcataAlts :: Decls + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOerrors :: (Seq Error) + _lhsOsemNames :: ([String]) + -- "GenerateCode.ag"(line 701, column 17) + _lhsOdataAlts = + [] + -- "GenerateCode.ag"(line 756, column 10) + _lhsOcataAlts = + [] + -- use rule "GenerateCode.ag"(line 551, column 39) + _lhsOallTpsFound = + True + -- use rule "GenerateCode.ag"(line 583, column 52) + _lhsOcomments = + [] + -- use rule "GenerateCode.ag"(line 626, column 46) + _lhsOdecls = + [] + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + Seq.empty + -- use rule "GenerateCode.ag"(line 774, column 63) + _lhsOsemNames = + [] + in ( _lhsOallTpsFound,_lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOerrors,_lhsOsemNames))) ) +-- CGrammar ---------------------------------------------------- +{- + visit 0: + inherited attribute: + options : Options + synthesized attributes: + errors : Seq Error + output : Program + alternatives: + alternative CGrammar: + child typeSyns : {TypeSyns} + child derivings : {Derivings} + child wrappers : {Set Nonterminal} + child prods : CProductions + child pragmas : {PragmaMap} +-} +-- cata +sem_CGrammar :: CGrammar -> + T_CGrammar +sem_CGrammar (CGrammar _typeSyns _derivings _wrappers _prods _pragmas ) = + (sem_CGrammar_CGrammar _typeSyns _derivings _wrappers (sem_CProductions _prods ) _pragmas ) +-- semantic domain +newtype T_CGrammar = T_CGrammar (Options -> + ( (Seq Error),Program)) +data Inh_CGrammar = Inh_CGrammar {options_Inh_CGrammar :: Options} +data Syn_CGrammar = Syn_CGrammar {errors_Syn_CGrammar :: Seq Error,output_Syn_CGrammar :: Program} +wrap_CGrammar (T_CGrammar sem ) (Inh_CGrammar _lhsIoptions ) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsIoptions ) + in (Syn_CGrammar _lhsOerrors _lhsOoutput )) +sem_CGrammar_CGrammar :: TypeSyns -> + Derivings -> + (Set Nonterminal) -> + T_CProductions -> + PragmaMap -> + T_CGrammar +sem_CGrammar_CGrammar typeSyns_ derivings_ wrappers_ (T_CProductions prods_ ) pragmas_ = + (T_CGrammar (\ _lhsIoptions -> + (let _prodsOo_sig :: Bool + _prodsOo_cata :: Bool + _prodsOo_sem :: Bool + _prodsOo_newtypes :: Bool + _prodsOo_unbox :: Bool + _prodsOo_case :: Bool + _prodsOo_pretty :: Bool + _prodsOo_rename :: Bool + _prodsOo_strictwrap :: Bool + _prodsOo_splitsems :: Bool + _prodsOo_data :: (Maybe Bool) + _prodsOprefix :: String + _prodsOo_traces :: Bool + _prodsOo_costcentre :: Bool + _prodsOo_linePragmas :: Bool + _prodsOallPragmas :: PragmaMap + _prodsOwith_sig :: Bool + _prodsOerrors :: (Seq Error) + _lhsOoutput :: Program + _prodsOtypeSyns :: TypeSyns + _prodsOderivings :: Derivings + _prodsOwrappers :: (Set Nonterminal) + _lhsOerrors :: (Seq Error) + _prodsIallTpsFound :: Bool + _prodsIchunks :: Chunks + _prodsIerrors :: (Seq Error) + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_sig = + typeSigs _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_cata = + folds _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_sem = + semfuns _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_newtypes = + newtypes _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_unbox = + unbox _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_case = + cases _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_pretty = + attrInfo _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_rename = + rename _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_strictwrap = + strictWrap _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_splitsems = + splitSems _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_data = + if dataTypes _lhsIoptions then Just (strictData _lhsIoptions) else Nothing + -- "GenerateCode.ag"(line 43, column 17) + _prodsOprefix = + prefix _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_traces = + genTraces _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_costcentre = + genCostCentres _lhsIoptions + -- "GenerateCode.ag"(line 43, column 17) + _prodsOo_linePragmas = + genLinePragmas _lhsIoptions + -- "GenerateCode.ag"(line 62, column 15) + _prodsOallPragmas = + pragmas_ + -- "GenerateCode.ag"(line 559, column 14) + _prodsOwith_sig = + typeSigs _lhsIoptions && _prodsIallTpsFound + -- "GenerateCode.ag"(line 566, column 15) + _prodsOerrors = + Seq.empty + -- "GenerateCode.ag"(line 630, column 17) + _lhsOoutput = + Program _prodsIchunks + -- "GenerateCode.ag"(line 679, column 14) + _prodsOtypeSyns = + typeSyns_ + -- "GenerateCode.ag"(line 679, column 14) + _prodsOderivings = + derivings_ + -- "GenerateCode.ag"(line 679, column 14) + _prodsOwrappers = + wrappers_ + -- copy rule (up) + _lhsOerrors = + _prodsIerrors + ( _prodsIallTpsFound,_prodsIchunks,_prodsIerrors) = + (prods_ _prodsOallPragmas _prodsOderivings _prodsOerrors _prodsOo_case _prodsOo_cata _prodsOo_costcentre _prodsOo_data _prodsOo_linePragmas _prodsOo_newtypes _prodsOo_pretty _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_splitsems _prodsOo_strictwrap _prodsOo_traces _prodsOo_unbox _prodsOprefix _prodsOtypeSyns _prodsOwith_sig _prodsOwrappers ) + in ( _lhsOerrors,_lhsOoutput))) ) +-- CInterface -------------------------------------------------- +{- + visit 0: + inherited attributes: + inh : Attributes + nt : Nonterminal + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + syn : Attributes + synthesized attributes: + comments : [String] + semDom : [Decl] + wrapDecls : Decls + alternatives: + alternative CInterface: + child seg : CSegments +-} +-- cata +sem_CInterface :: CInterface -> + T_CInterface +sem_CInterface (CInterface _seg ) = + (sem_CInterface_CInterface (sem_CSegments _seg ) ) +-- semantic domain +newtype T_CInterface = T_CInterface (Attributes -> + Nonterminal -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + ( ([String]),([Decl]),Decls)) +data Inh_CInterface = Inh_CInterface {inh_Inh_CInterface :: Attributes,nt_Inh_CInterface :: Nonterminal,o_case_Inh_CInterface :: Bool,o_cata_Inh_CInterface :: Bool,o_costcentre_Inh_CInterface :: Bool,o_data_Inh_CInterface :: Maybe Bool,o_linePragmas_Inh_CInterface :: Bool,o_newtypes_Inh_CInterface :: Bool,o_pretty_Inh_CInterface :: Bool,o_rename_Inh_CInterface :: Bool,o_sem_Inh_CInterface :: Bool,o_sig_Inh_CInterface :: Bool,o_splitsems_Inh_CInterface :: Bool,o_strictwrap_Inh_CInterface :: Bool,o_traces_Inh_CInterface :: Bool,o_unbox_Inh_CInterface :: Bool,prefix_Inh_CInterface :: String,syn_Inh_CInterface :: Attributes} +data Syn_CInterface = Syn_CInterface {comments_Syn_CInterface :: [String],semDom_Syn_CInterface :: [Decl],wrapDecls_Syn_CInterface :: Decls} +wrap_CInterface (T_CInterface sem ) (Inh_CInterface _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) = + (let ( _lhsOcomments,_lhsOsemDom,_lhsOwrapDecls) = + (sem _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) + in (Syn_CInterface _lhsOcomments _lhsOsemDom _lhsOwrapDecls )) +sem_CInterface_CInterface :: T_CSegments -> + T_CInterface +sem_CInterface_CInterface (T_CSegments seg_ ) = + (T_CInterface (\ _lhsIinh + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn -> + (let _segOnr :: Int + _lhsOsemDom :: ([Decl]) + _lhsOcomments :: ([String]) + _lhsOwrapDecls :: Decls + _segOinh :: Attributes + _segOnt :: Nonterminal + _segOo_case :: Bool + _segOo_cata :: Bool + _segOo_costcentre :: Bool + _segOo_data :: (Maybe Bool) + _segOo_linePragmas :: Bool + _segOo_newtypes :: Bool + _segOo_pretty :: Bool + _segOo_rename :: Bool + _segOo_sem :: Bool + _segOo_sig :: Bool + _segOo_splitsems :: Bool + _segOo_strictwrap :: Bool + _segOo_traces :: Bool + _segOo_unbox :: Bool + _segOprefix :: String + _segOsyn :: Attributes + _segIcomments :: ([String]) + _segIisNil :: Bool + _segIsemDom :: ([Decl]) + _segIwrapDecls :: Decls + -- "GenerateCode.ag"(line 163, column 17) + _segOnr = + 0 + -- "GenerateCode.ag"(line 493, column 18) + _lhsOsemDom = + Comment "semantic domain" : _segIsemDom + -- use rule "GenerateCode.ag"(line 583, column 52) + _lhsOcomments = + _segIcomments + -- use rule "GenerateCode.ag"(line 532, column 52) + _lhsOwrapDecls = + _segIwrapDecls + -- copy rule (down) + _segOinh = + _lhsIinh + -- copy rule (down) + _segOnt = + _lhsInt + -- copy rule (down) + _segOo_case = + _lhsIo_case + -- copy rule (down) + _segOo_cata = + _lhsIo_cata + -- copy rule (down) + _segOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _segOo_data = + _lhsIo_data + -- copy rule (down) + _segOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _segOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _segOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _segOo_rename = + _lhsIo_rename + -- copy rule (down) + _segOo_sem = + _lhsIo_sem + -- copy rule (down) + _segOo_sig = + _lhsIo_sig + -- copy rule (down) + _segOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _segOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _segOo_traces = + _lhsIo_traces + -- copy rule (down) + _segOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _segOprefix = + _lhsIprefix + -- copy rule (down) + _segOsyn = + _lhsIsyn + ( _segIcomments,_segIisNil,_segIsemDom,_segIwrapDecls) = + (seg_ _segOinh _segOnr _segOnt _segOo_case _segOo_cata _segOo_costcentre _segOo_data _segOo_linePragmas _segOo_newtypes _segOo_pretty _segOo_rename _segOo_sem _segOo_sig _segOo_splitsems _segOo_strictwrap _segOo_traces _segOo_unbox _segOprefix _segOsyn ) + in ( _lhsOcomments,_lhsOsemDom,_lhsOwrapDecls))) ) +-- CProduction ------------------------------------------------- +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + derivings : Derivings + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + typeSyns : TypeSyns + with_sig : Bool + wrappers : Set Nonterminal + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + chunks : Chunks + alternatives: + alternative CProduction: + child nt : {Nonterminal} + child inh : {Attributes} + child syn : {Attributes} + child alts : CAlternatives + child inter : CInterface + visit 0: + local _tup1 : {(Attributes,Attributes,Nonterminal)} + local _tup2 : {(Attributes,Attributes,Nonterminal)} + local semWrapper : _ + local comment : _ + local dataDef : _ + local cataFun : _ +-} +-- cata +sem_CProduction :: CProduction -> + T_CProduction +sem_CProduction (CProduction _nt _inh _syn _alts _inter ) = + (sem_CProduction_CProduction _nt _inh _syn (sem_CAlternatives _alts ) (sem_CInterface _inter ) ) +-- semantic domain +newtype T_CProduction = T_CProduction (PragmaMap -> + Derivings -> + (Seq Error) -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + TypeSyns -> + Bool -> + (Set Nonterminal) -> + ( Bool,Chunks,(Seq Error))) +data Inh_CProduction = Inh_CProduction {allPragmas_Inh_CProduction :: PragmaMap,derivings_Inh_CProduction :: Derivings,errors_Inh_CProduction :: Seq Error,o_case_Inh_CProduction :: Bool,o_cata_Inh_CProduction :: Bool,o_costcentre_Inh_CProduction :: Bool,o_data_Inh_CProduction :: Maybe Bool,o_linePragmas_Inh_CProduction :: Bool,o_newtypes_Inh_CProduction :: Bool,o_pretty_Inh_CProduction :: Bool,o_rename_Inh_CProduction :: Bool,o_sem_Inh_CProduction :: Bool,o_sig_Inh_CProduction :: Bool,o_splitsems_Inh_CProduction :: Bool,o_strictwrap_Inh_CProduction :: Bool,o_traces_Inh_CProduction :: Bool,o_unbox_Inh_CProduction :: Bool,prefix_Inh_CProduction :: String,typeSyns_Inh_CProduction :: TypeSyns,with_sig_Inh_CProduction :: Bool,wrappers_Inh_CProduction :: Set Nonterminal} +data Syn_CProduction = Syn_CProduction {allTpsFound_Syn_CProduction :: Bool,chunks_Syn_CProduction :: Chunks,errors_Syn_CProduction :: Seq Error} +wrap_CProduction (T_CProduction sem ) (Inh_CProduction _lhsIallPragmas _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsItypeSyns _lhsIwith_sig _lhsIwrappers ) = + (let ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors) = + (sem _lhsIallPragmas _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsItypeSyns _lhsIwith_sig _lhsIwrappers ) + in (Syn_CProduction _lhsOallTpsFound _lhsOchunks _lhsOerrors )) +sem_CProduction_CProduction :: Nonterminal -> + Attributes -> + Attributes -> + T_CAlternatives -> + T_CInterface -> + T_CProduction +sem_CProduction_CProduction nt_ inh_ syn_ (T_CAlternatives alts_ ) (T_CInterface inter_ ) = + (T_CProduction (\ _lhsIallPragmas + _lhsIderivings + _lhsIerrors + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsItypeSyns + _lhsIwith_sig + _lhsIwrappers -> + (let __tup1 :: ((Attributes,Attributes,Nonterminal)) + _interOinh :: Attributes + _interOsyn :: Attributes + _interOnt :: Nonterminal + __tup2 :: ((Attributes,Attributes,Nonterminal)) + _altsOinh :: Attributes + _altsOsyn :: Attributes + _altsOnt :: Nonterminal + _lhsOchunks :: Chunks + _lhsOallTpsFound :: Bool + _lhsOerrors :: (Seq Error) + _altsOallPragmas :: PragmaMap + _altsOerrors :: (Seq Error) + _altsOo_case :: Bool + _altsOo_cata :: Bool + _altsOo_costcentre :: Bool + _altsOo_data :: (Maybe Bool) + _altsOo_linePragmas :: Bool + _altsOo_newtypes :: Bool + _altsOo_pretty :: Bool + _altsOo_rename :: Bool + _altsOo_sem :: Bool + _altsOo_sig :: Bool + _altsOo_splitsems :: Bool + _altsOo_strictwrap :: Bool + _altsOo_traces :: Bool + _altsOo_unbox :: Bool + _altsOprefix :: String + _altsOwith_sig :: Bool + _interOo_case :: Bool + _interOo_cata :: Bool + _interOo_costcentre :: Bool + _interOo_data :: (Maybe Bool) + _interOo_linePragmas :: Bool + _interOo_newtypes :: Bool + _interOo_pretty :: Bool + _interOo_rename :: Bool + _interOo_sem :: Bool + _interOo_sig :: Bool + _interOo_splitsems :: Bool + _interOo_strictwrap :: Bool + _interOo_traces :: Bool + _interOo_unbox :: Bool + _interOprefix :: String + _altsIallTpsFound :: Bool + _altsIcataAlts :: Decls + _altsIcomments :: ([String]) + _altsIdataAlts :: DataAlts + _altsIdecls :: Decls + _altsIerrors :: (Seq Error) + _altsIsemNames :: ([String]) + _interIcomments :: ([String]) + _interIsemDom :: ([Decl]) + _interIwrapDecls :: Decls + -- "GenerateCode.ag"(line 72, column 25) + __tup1 = + (inh_,syn_,nt_) + -- "GenerateCode.ag"(line 72, column 25) + (_interOinh,_,_) = + __tup1 + -- "GenerateCode.ag"(line 72, column 25) + (_,_interOsyn,_) = + __tup1 + -- "GenerateCode.ag"(line 72, column 25) + (_,_,_interOnt) = + __tup1 + -- "GenerateCode.ag"(line 73, column 24) + __tup2 = + (inh_,syn_,nt_) + -- "GenerateCode.ag"(line 73, column 24) + (_altsOinh,_,_) = + __tup2 + -- "GenerateCode.ag"(line 73, column 24) + (_,_altsOsyn,_) = + __tup2 + -- "GenerateCode.ag"(line 73, column 24) + (_,_,_altsOnt) = + __tup2 + -- "GenerateCode.ag"(line 512, column 17) + _semWrapper = + let inhAttrs = Map.toList inh_ + synAttrs = Map.toList syn_ + inhVars = [ SimpleExpr (attrname True _LHS a) | (a,_) <- inhAttrs ] + synVars = [ SimpleExpr (attrname False _LHS a) | (a,_) <- synAttrs ] + var = "sem" + wrapNT = "wrap" ++ "_" ++ getName nt_ + inhNT = "Inh" ++ "_" ++ getName nt_ + synNT = "Syn" ++ "_" ++ getName nt_ + varPat = if _lhsIo_newtypes + then App (sdtype nt_) [SimpleExpr var] + else SimpleExpr var + typeSig = TSig wrapNT (SimpleType (sdtype nt_) `Arr` (SimpleType inhNT `Arr` SimpleType synNT)) + mkstrict = if _lhsIo_strictwrap then (\x -> "!(" ++ x ++ ")") else id + mkdata n attrs = Data n [Record n [(getName f++"_"++n,mkstrict $ typeToString nt_ t) | (f,t) <- attrs]] False [] + datas = [mkdata inhNT inhAttrs, mkdata synNT synAttrs] + in datas ++ [ Decl (Fun wrapNT [varPat, App inhNT inhVars]) + (Let _interIwrapDecls (App synNT synVars)) + Set.empty Set.empty + ] + -- "GenerateCode.ag"(line 579, column 17) + _comment = + Comment . unlines . map ind $ ( _interIcomments ++ ("alternatives:" : map ind _altsIcomments) ) + -- "GenerateCode.ag"(line 633, column 18) + _lhsOchunks = + [ Chunk (getName nt_) + (Comment (getName nt_ ++ " " ++ replicate (60 - length (getName nt_)) '-')) + (if _lhsIo_pretty then [_comment ] else []) + (if isJust _lhsIo_data then [_dataDef ] else []) + (if _lhsIo_cata then _cataFun else []) + (if _lhsIo_sig then _interIsemDom else []) + (if nt_ `Set.member` _lhsIwrappers then _semWrapper else []) + (if _lhsIo_sem then _altsIdecls else []) + (if _lhsIo_sem then _altsIsemNames else []) + ] + -- "GenerateCode.ag"(line 684, column 17) + _dataDef = + let typeSyn tp = let theType = + case tp of + CommonTypes.Maybe t -> SimpleType ("Maybe (" ++ typeToString nt_ t ++")") + CommonTypes.List t -> Code.List $ SimpleType (typeToString nt_ t) + CommonTypes.Tuple ts -> Code.TupleType [SimpleType (typeToString nt_ t) + | (_,t) <- ts + ] + in Code.Type (getName nt_) theType + derivings = maybe [] (map getName . Set.toList) (Map.lookup nt_ _lhsIderivings) + dataDef = Data (getName nt_) _altsIdataAlts (maybe False id _lhsIo_data) derivings + in maybe dataDef typeSyn $ lookup nt_ _lhsItypeSyns + -- "GenerateCode.ag"(line 711, column 17) + _cataFun = + let tSig = TSig (cataname _lhsIprefix nt_) + (SimpleType (getName nt_) `Arr` SimpleType (sdtype nt_)) + special typ = case typ of + CommonTypes.List tp -> + let cons = SimpleExpr (semname _lhsIprefix nt_ (identifier "Cons")) + nil = SimpleExpr (semname _lhsIprefix nt_ (identifier "Nil" )) + arg = SimpleExpr "list" + rarg = case tp of + NT t -> SimpleExpr ("(Prelude.map " ++ (cataname _lhsIprefix t) ++ " list)") + _ -> arg + lhs = Fun (cataname _lhsIprefix nt_) [arg] + rhs = (App "Prelude.foldr" [cons,nil,rarg]) + in [Decl lhs rhs Set.empty Set.empty] + CommonTypes.Maybe tp -> + let just = semname _lhsIprefix nt_ (identifier "Just") + nothing = semname _lhsIprefix nt_ (identifier "Nothing" ) + arg = SimpleExpr "x" + rarg = case tp of + NT t -> App (cataname _lhsIprefix t) [arg] + _ -> arg + lhs a = Fun (cataname _lhsIprefix nt_) [a] + in [Decl (lhs (App "Prelude.Just" [arg])) (App just [rarg]) Set.empty Set.empty + ,Decl (lhs (SimpleExpr "Prelude.Nothing")) (SimpleExpr nothing) Set.empty Set.empty + ] + CommonTypes.Tuple tps -> + let con = semname _lhsIprefix nt_ (identifier "Tuple") + tps' = [ (SimpleExpr (getName x),y) | (x,y) <- tps] + rargs = map rarg tps' + rarg (n, tp) = case tp of + NT t -> App (cataname _lhsIprefix t) [n] + _ -> n + lhs = Fun (cataname _lhsIprefix nt_) [TupleExpr (map fst tps')] + rhs = App con rargs + in [Decl lhs rhs Set.empty Set.empty] + in Comment "cata" : + (if _lhsIo_sig then [tSig] else []) ++ + maybe _altsIcataAlts special (lookup nt_ _lhsItypeSyns) + -- use rule "GenerateCode.ag"(line 551, column 39) + _lhsOallTpsFound = + _altsIallTpsFound + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + _altsIerrors + -- copy rule (down) + _altsOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _altsOerrors = + _lhsIerrors + -- copy rule (down) + _altsOo_case = + _lhsIo_case + -- copy rule (down) + _altsOo_cata = + _lhsIo_cata + -- copy rule (down) + _altsOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _altsOo_data = + _lhsIo_data + -- copy rule (down) + _altsOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _altsOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _altsOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _altsOo_rename = + _lhsIo_rename + -- copy rule (down) + _altsOo_sem = + _lhsIo_sem + -- copy rule (down) + _altsOo_sig = + _lhsIo_sig + -- copy rule (down) + _altsOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _altsOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _altsOo_traces = + _lhsIo_traces + -- copy rule (down) + _altsOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _altsOprefix = + _lhsIprefix + -- copy rule (down) + _altsOwith_sig = + _lhsIwith_sig + -- copy rule (down) + _interOo_case = + _lhsIo_case + -- copy rule (down) + _interOo_cata = + _lhsIo_cata + -- copy rule (down) + _interOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _interOo_data = + _lhsIo_data + -- copy rule (down) + _interOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _interOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _interOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _interOo_rename = + _lhsIo_rename + -- copy rule (down) + _interOo_sem = + _lhsIo_sem + -- copy rule (down) + _interOo_sig = + _lhsIo_sig + -- copy rule (down) + _interOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _interOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _interOo_traces = + _lhsIo_traces + -- copy rule (down) + _interOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _interOprefix = + _lhsIprefix + ( _altsIallTpsFound,_altsIcataAlts,_altsIcomments,_altsIdataAlts,_altsIdecls,_altsIerrors,_altsIsemNames) = + (alts_ _altsOallPragmas _altsOerrors _altsOinh _altsOnt _altsOo_case _altsOo_cata _altsOo_costcentre _altsOo_data _altsOo_linePragmas _altsOo_newtypes _altsOo_pretty _altsOo_rename _altsOo_sem _altsOo_sig _altsOo_splitsems _altsOo_strictwrap _altsOo_traces _altsOo_unbox _altsOprefix _altsOsyn _altsOwith_sig ) + ( _interIcomments,_interIsemDom,_interIwrapDecls) = + (inter_ _interOinh _interOnt _interOo_case _interOo_cata _interOo_costcentre _interOo_data _interOo_linePragmas _interOo_newtypes _interOo_pretty _interOo_rename _interOo_sem _interOo_sig _interOo_splitsems _interOo_strictwrap _interOo_traces _interOo_unbox _interOprefix _interOsyn ) + in ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors))) ) +-- CProductions ------------------------------------------------ +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + derivings : Derivings + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + typeSyns : TypeSyns + with_sig : Bool + wrappers : Set Nonterminal + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + chunks : Chunks + alternatives: + alternative Cons: + child hd : CProduction + child tl : CProductions + alternative Nil: +-} +-- cata +sem_CProductions :: CProductions -> + T_CProductions +sem_CProductions list = + (Prelude.foldr sem_CProductions_Cons sem_CProductions_Nil (Prelude.map sem_CProduction list) ) +-- semantic domain +newtype T_CProductions = T_CProductions (PragmaMap -> + Derivings -> + (Seq Error) -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + TypeSyns -> + Bool -> + (Set Nonterminal) -> + ( Bool,Chunks,(Seq Error))) +data Inh_CProductions = Inh_CProductions {allPragmas_Inh_CProductions :: PragmaMap,derivings_Inh_CProductions :: Derivings,errors_Inh_CProductions :: Seq Error,o_case_Inh_CProductions :: Bool,o_cata_Inh_CProductions :: Bool,o_costcentre_Inh_CProductions :: Bool,o_data_Inh_CProductions :: Maybe Bool,o_linePragmas_Inh_CProductions :: Bool,o_newtypes_Inh_CProductions :: Bool,o_pretty_Inh_CProductions :: Bool,o_rename_Inh_CProductions :: Bool,o_sem_Inh_CProductions :: Bool,o_sig_Inh_CProductions :: Bool,o_splitsems_Inh_CProductions :: Bool,o_strictwrap_Inh_CProductions :: Bool,o_traces_Inh_CProductions :: Bool,o_unbox_Inh_CProductions :: Bool,prefix_Inh_CProductions :: String,typeSyns_Inh_CProductions :: TypeSyns,with_sig_Inh_CProductions :: Bool,wrappers_Inh_CProductions :: Set Nonterminal} +data Syn_CProductions = Syn_CProductions {allTpsFound_Syn_CProductions :: Bool,chunks_Syn_CProductions :: Chunks,errors_Syn_CProductions :: Seq Error} +wrap_CProductions (T_CProductions sem ) (Inh_CProductions _lhsIallPragmas _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsItypeSyns _lhsIwith_sig _lhsIwrappers ) = + (let ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors) = + (sem _lhsIallPragmas _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsItypeSyns _lhsIwith_sig _lhsIwrappers ) + in (Syn_CProductions _lhsOallTpsFound _lhsOchunks _lhsOerrors )) +sem_CProductions_Cons :: T_CProduction -> + T_CProductions -> + T_CProductions +sem_CProductions_Cons (T_CProduction hd_ ) (T_CProductions tl_ ) = + (T_CProductions (\ _lhsIallPragmas + _lhsIderivings + _lhsIerrors + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsItypeSyns + _lhsIwith_sig + _lhsIwrappers -> + (let _lhsOallTpsFound :: Bool + _lhsOchunks :: Chunks + _lhsOerrors :: (Seq Error) + _hdOallPragmas :: PragmaMap + _hdOderivings :: Derivings + _hdOerrors :: (Seq Error) + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_costcentre :: Bool + _hdOo_data :: (Maybe Bool) + _hdOo_linePragmas :: Bool + _hdOo_newtypes :: Bool + _hdOo_pretty :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_splitsems :: Bool + _hdOo_strictwrap :: Bool + _hdOo_traces :: Bool + _hdOo_unbox :: Bool + _hdOprefix :: String + _hdOtypeSyns :: TypeSyns + _hdOwith_sig :: Bool + _hdOwrappers :: (Set Nonterminal) + _tlOallPragmas :: PragmaMap + _tlOderivings :: Derivings + _tlOerrors :: (Seq Error) + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_costcentre :: Bool + _tlOo_data :: (Maybe Bool) + _tlOo_linePragmas :: Bool + _tlOo_newtypes :: Bool + _tlOo_pretty :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_splitsems :: Bool + _tlOo_strictwrap :: Bool + _tlOo_traces :: Bool + _tlOo_unbox :: Bool + _tlOprefix :: String + _tlOtypeSyns :: TypeSyns + _tlOwith_sig :: Bool + _tlOwrappers :: (Set Nonterminal) + _hdIallTpsFound :: Bool + _hdIchunks :: Chunks + _hdIerrors :: (Seq Error) + _tlIallTpsFound :: Bool + _tlIchunks :: Chunks + _tlIerrors :: (Seq Error) + -- use rule "GenerateCode.ag"(line 551, column 39) + _lhsOallTpsFound = + _hdIallTpsFound && _tlIallTpsFound + -- use rule "GenerateCode.ag"(line 625, column 47) + _lhsOchunks = + _hdIchunks ++ _tlIchunks + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- copy rule (down) + _hdOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _hdOderivings = + _lhsIderivings + -- copy rule (down) + _hdOerrors = + _lhsIerrors + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _hdOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _hdOo_traces = + _lhsIo_traces + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOtypeSyns = + _lhsItypeSyns + -- copy rule (down) + _hdOwith_sig = + _lhsIwith_sig + -- copy rule (down) + _hdOwrappers = + _lhsIwrappers + -- copy rule (down) + _tlOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _tlOderivings = + _lhsIderivings + -- copy rule (chain) + _tlOerrors = + _hdIerrors + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _tlOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _tlOo_traces = + _lhsIo_traces + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOtypeSyns = + _lhsItypeSyns + -- copy rule (down) + _tlOwith_sig = + _lhsIwith_sig + -- copy rule (down) + _tlOwrappers = + _lhsIwrappers + ( _hdIallTpsFound,_hdIchunks,_hdIerrors) = + (hd_ _hdOallPragmas _hdOderivings _hdOerrors _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOprefix _hdOtypeSyns _hdOwith_sig _hdOwrappers ) + ( _tlIallTpsFound,_tlIchunks,_tlIerrors) = + (tl_ _tlOallPragmas _tlOderivings _tlOerrors _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOprefix _tlOtypeSyns _tlOwith_sig _tlOwrappers ) + in ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors))) ) +sem_CProductions_Nil :: T_CProductions +sem_CProductions_Nil = + (T_CProductions (\ _lhsIallPragmas + _lhsIderivings + _lhsIerrors + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsItypeSyns + _lhsIwith_sig + _lhsIwrappers -> + (let _lhsOallTpsFound :: Bool + _lhsOchunks :: Chunks + _lhsOerrors :: (Seq Error) + -- use rule "GenerateCode.ag"(line 551, column 39) + _lhsOallTpsFound = + True + -- use rule "GenerateCode.ag"(line 625, column 47) + _lhsOchunks = + [] + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + Seq.empty + in ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors))) ) +-- CRule ------------------------------------------------------- +{- + visit 0: + inherited attributes: + children : [(Name,Type,Bool)] + con : Constructor + higherOrderChildren : [(Name,Type,Bool)] + inh : Attributes + instVisitNrs : Map Identifier Int + nr : Int + nt : Nonterminal + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + syn : Attributes + terminals : [Name] + what : String + chained attributes: + declsAbove : [Decl] + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + bldBlocksFun : DeclBlocks -> DeclBlocks + comments : [String] + decls : Decls + definedInsts : [Identifier] + exprs : Exprs + tSigs : [Decl] + tps : [Type] + usedVars : Set String + alternatives: + alternative CChildVisit: + child name : {Name} + child nt : {Nonterminal} + child nr : {Int} + child inh : {Attributes} + child syn : {Attributes} + child isLast : {Bool} + visit 0: + local costCentreDescr : _ + local addCostCentre : _ + local decls : _ + local isSuperfluousHigherOrderIntra : _ + local names : _ + local mkTp : _ + local definedTps : _ + local nextTp : _ + alternative CRule: + child name : {Name} + child isIn : {Bool} + child hasCode : {Bool} + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child childnt : {Maybe Nonterminal} + child tp : {Maybe Type} + child pattern : Pattern + child rhs : {[String]} + child defines : {Map Int (Name,Name,Maybe Type)} + child owrt : {Bool} + child origin : {String} + child uses : {Set (Name, Name)} + visit 0: + local instTypes : _ + local originComment : _ + local instDecls : _ + local patDescr : _ + local traceDescr : _ + local addTrace : _ + local costCentreDescr : _ + local addCostCentre : _ + local addLinePragma : _ + local decls : _ + local definedInsts : _ + local name : _ + local mkTp : _ + local _tup3 : {([Type],Bool)} +-} +-- cata +sem_CRule :: CRule -> + T_CRule +sem_CRule (CChildVisit _name _nt _nr _inh _syn _isLast ) = + (sem_CRule_CChildVisit _name _nt _nr _inh _syn _isLast ) +sem_CRule (CRule _name _isIn _hasCode _nt _con _field _childnt _tp _pattern _rhs _defines _owrt _origin _uses ) = + (sem_CRule_CRule _name _isIn _hasCode _nt _con _field _childnt _tp (sem_Pattern _pattern ) _rhs _defines _owrt _origin _uses ) +-- semantic domain +newtype T_CRule = T_CRule (([(Name,Type,Bool)]) -> + Constructor -> + ([Decl]) -> + (Seq Error) -> + ([(Name,Type,Bool)]) -> + Attributes -> + (Map Identifier Int) -> + Int -> + Nonterminal -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + ([Name]) -> + String -> + ( Bool,(DeclBlocks -> DeclBlocks),([String]),Decls,([Decl]),([Identifier]),(Seq Error),Exprs,([Decl]),([Type]),(Set String))) +data Inh_CRule = Inh_CRule {children_Inh_CRule :: [(Name,Type,Bool)],con_Inh_CRule :: Constructor,declsAbove_Inh_CRule :: [Decl],errors_Inh_CRule :: Seq Error,higherOrderChildren_Inh_CRule :: [(Name,Type,Bool)],inh_Inh_CRule :: Attributes,instVisitNrs_Inh_CRule :: Map Identifier Int,nr_Inh_CRule :: Int,nt_Inh_CRule :: Nonterminal,o_case_Inh_CRule :: Bool,o_cata_Inh_CRule :: Bool,o_costcentre_Inh_CRule :: Bool,o_data_Inh_CRule :: Maybe Bool,o_linePragmas_Inh_CRule :: Bool,o_newtypes_Inh_CRule :: Bool,o_pretty_Inh_CRule :: Bool,o_rename_Inh_CRule :: Bool,o_sem_Inh_CRule :: Bool,o_sig_Inh_CRule :: Bool,o_splitsems_Inh_CRule :: Bool,o_strictwrap_Inh_CRule :: Bool,o_traces_Inh_CRule :: Bool,o_unbox_Inh_CRule :: Bool,prefix_Inh_CRule :: String,syn_Inh_CRule :: Attributes,terminals_Inh_CRule :: [Name],what_Inh_CRule :: String} +data Syn_CRule = Syn_CRule {allTpsFound_Syn_CRule :: Bool,bldBlocksFun_Syn_CRule :: DeclBlocks -> DeclBlocks,comments_Syn_CRule :: [String],decls_Syn_CRule :: Decls,declsAbove_Syn_CRule :: [Decl],definedInsts_Syn_CRule :: [Identifier],errors_Syn_CRule :: Seq Error,exprs_Syn_CRule :: Exprs,tSigs_Syn_CRule :: [Decl],tps_Syn_CRule :: [Type],usedVars_Syn_CRule :: Set String} +wrap_CRule (T_CRule sem ) (Inh_CRule _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat ) = + (let ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars) = + (sem _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat ) + in (Syn_CRule _lhsOallTpsFound _lhsObldBlocksFun _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOerrors _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars )) +sem_CRule_CChildVisit :: Name -> + Nonterminal -> + Int -> + Attributes -> + Attributes -> + Bool -> + T_CRule +sem_CRule_CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ = + (T_CRule (\ _lhsIchildren + _lhsIcon + _lhsIdeclsAbove + _lhsIerrors + _lhsIhigherOrderChildren + _lhsIinh + _lhsIinstVisitNrs + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwhat -> + (let _lhsOexprs :: Exprs + _lhsOusedVars :: (Set String) + _lhsOtSigs :: ([Decl]) + _lhsOtps :: ([Type]) + _lhsOdeclsAbove :: ([Decl]) + _lhsObldBlocksFun :: (DeclBlocks -> DeclBlocks) + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOdefinedInsts :: ([Identifier]) + _lhsOerrors :: (Seq Error) + -- "GenerateCode.ag"(line 126, column 18) + _costCentreDescr = + show _lhsInt ++ ":" ++ show _lhsIcon ++ ":" ++ show name_ ++ ":" ++ show nt_ ++ ":" ++ show nr_ + -- "GenerateCode.ag"(line 127, column 18) + _addCostCentre = + \v -> if _lhsIo_costcentre + then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v + else v + -- "GenerateCode.ag"(line 130, column 18) + _decls = + let lhsVars = map (attrname True name_) (Map.keys syn_) + ++ if isLast_ then [] else [unwrap ++ funname name_ (nr_+1)] + rhsVars = map (attrname False name_) (Map.keys inh_) + unwrap = if _lhsIo_newtypes then typeName nt_ (nr_ + 1) ++ " " else "" + tuple = mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars + rhs = _addCostCentre $ App (funname name_ nr_) (map SimpleExpr rhsVars) + in [Decl tuple rhs (Set.fromList lhsVars) (Set.fromList (funname name_ nr_ : rhsVars))] + -- "GenerateCode.ag"(line 206, column 7) + _isSuperfluousHigherOrderIntra = + _lhsInr <= Map.findWithDefault (-1) name_ _lhsIinstVisitNrs + -- "GenerateCode.ag"(line 220, column 8) + _names = + if _isSuperfluousHigherOrderIntra + then [] + else [funname name_ (nr_+1)] + -- "GenerateCode.ag"(line 224, column 8) + _lhsOexprs = + let wrap = if _lhsIo_newtypes then \x -> App (typeName nt_ (nr_ + 1)) [x] else id + in map (wrap . SimpleExpr) _names + -- "GenerateCode.ag"(line 232, column 7) + _lhsOusedVars = + Set.fromList _names + -- "GenerateCode.ag"(line 243, column 19) + _mkTp = + SimpleType . typeToString nt_ + -- "GenerateCode.ag"(line 244, column 19) + _definedTps = + [ TSig (attrname True name_ a) (_mkTp tp) | (a,tp) <- Map.toList syn_ ] + -- "GenerateCode.ag"(line 245, column 19) + _nextTp = + typeName nt_ (nr_+1) + -- "GenerateCode.ag"(line 246, column 19) + _lhsOtSigs = + (if isLast_ then id else (TSig (funname name_ (nr_+1)) (SimpleType _nextTp) :)) _definedTps + -- "GenerateCode.ag"(line 268, column 19) + _lhsOtps = + if _isSuperfluousHigherOrderIntra + then [] + else [Haskell _nextTp] + -- "GenerateCode.ag"(line 371, column 7) + _lhsOdeclsAbove = + [] + -- "GenerateCode.ag"(line 384, column 7) + _lhsObldBlocksFun = + DeclBlock _lhsIdeclsAbove (head _decls ) + -- use rule "GenerateCode.ag"(line 265, column 39) + _lhsOallTpsFound = + True + -- use rule "GenerateCode.ag"(line 583, column 52) + _lhsOcomments = + [] + -- use rule "GenerateCode.ag"(line 87, column 34) + _lhsOdecls = + _decls + -- use rule "GenerateCode.ag"(line 140, column 55) + _lhsOdefinedInsts = + [] + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + Seq.empty + in ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars))) ) +sem_CRule_CRule :: Name -> + Bool -> + Bool -> + Nonterminal -> + Constructor -> + Name -> + (Maybe Nonterminal) -> + (Maybe Type) -> + T_Pattern -> + ([String]) -> + (Map Int (Name,Name,Maybe Type)) -> + Bool -> + String -> + (Set (Name, Name)) -> + T_CRule +sem_CRule_CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ (T_Pattern pattern_ ) rhs_ defines_ owrt_ origin_ uses_ = + (T_CRule (\ _lhsIchildren + _lhsIcon + _lhsIdeclsAbove + _lhsIerrors + _lhsIhigherOrderChildren + _lhsIinh + _lhsIinstVisitNrs + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwhat -> + (let _lhsOexprs :: Exprs + _lhsOusedVars :: (Set String) + _lhsOtSigs :: ([Decl]) + __tup3 :: (([Type],Bool)) + _lhsOtps :: ([Type]) + _lhsOallTpsFound :: Bool + _lhsOdeclsAbove :: ([Decl]) + _lhsObldBlocksFun :: (DeclBlocks -> DeclBlocks) + _lhsOerrors :: (Seq Error) + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOdefinedInsts :: ([Identifier]) + _patternIcopy :: Pattern + _patternIdefinedInsts :: ([Identifier]) + _patternIpatternAttributes :: ([(Name, Name)]) + -- "GenerateCode.ag"(line 89, column 12) + _instTypes = + map (\(n,NT t,_) -> (n,t)) _lhsIhigherOrderChildren + -- "GenerateCode.ag"(line 90, column 12) + _originComment = + if _lhsIo_pretty + then (Comment origin_:) + else id + -- "GenerateCode.ag"(line 93, column 12) + _instDecls = + [ Decl (Pattern3 (Alias _INST' inst (Underscore (getPos inst)) [])) + (App (cataname _lhsIprefix (fromJust $ inst `lookup` _instTypes )) + [SimpleExpr instLocFieldName]) + (Set.singleton instSemFieldName) + (Set.singleton instLocFieldName) + | inst <- _definedInsts + , let instLocFieldName = attrname True _INST inst + , let instSemFieldName = attrname False _INST' inst ] + -- "GenerateCode.ag"(line 101, column 12) + _patDescr = + if isIn_ + then "_" + else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) _patternIpatternAttributes) + -- "GenerateCode.ag"(line 104, column 12) + _traceDescr = + show nt_ ++ " :: " ++ show con_ ++ " :: " ++ _patDescr + -- "GenerateCode.ag"(line 106, column 12) + _addTrace = + \v -> if _lhsIo_traces + then Trace _traceDescr v + else v + -- "GenerateCode.ag"(line 109, column 12) + _costCentreDescr = + show nt_ ++ ":" ++ show con_ ++ ":" ++ _patDescr + -- "GenerateCode.ag"(line 110, column 12) + _addCostCentre = + \v -> if _lhsIo_costcentre + then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v + else v + -- "GenerateCode.ag"(line 113, column 12) + _addLinePragma = + \v -> let p = getPos name_ + hasPos = line p > 0 && column p >= 0 && not (null (file p)) + in if _lhsIo_linePragmas && hasPos + then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p)) + $ LineExpr + $ v + else v + -- "GenerateCode.ag"(line 120, column 12) + _decls = + if hasCode_ + then _originComment ( Decl (Pattern3 _patternIcopy) (_addTrace $ _addCostCentre $ _addLinePragma $ (TextExpr rhs_)) + (Set.fromList [attrname False fld nm | (fld,nm,_) <- Map.elems defines_]) + (Set.fromList [attrname True fld nm | (fld,nm) <- Set.toList uses_]) + : _instDecls ) + else _instDecls + -- "GenerateCode.ag"(line 145, column 12) + _definedInsts = + if isIn_ then [] else _patternIdefinedInsts + -- "GenerateCode.ag"(line 215, column 12) + _name = + if field_ == _LOC && name_ `elem` _lhsIterminals + then funname name_ 0 + else attrname isIn_ field_ name_ + -- "GenerateCode.ag"(line 218, column 12) + _lhsOexprs = + [SimpleExpr _name ] + -- "GenerateCode.ag"(line 230, column 7) + _lhsOusedVars = + Set.singleton _name + -- "GenerateCode.ag"(line 240, column 19) + _mkTp = + SimpleType . typeToString _lhsInt + -- "GenerateCode.ag"(line 241, column 19) + _lhsOtSigs = + [ TSig (attrname False field attr) (_mkTp (fromJust tp)) + | (field,attr,tp) <- Map.elems defines_, isJust tp ] + -- "GenerateCode.ag"(line 267, column 23) + __tup3 = + maybe ([],False) (\tp -> ([substSelf (fromJust childnt_) tp],True)) tp_ + -- "GenerateCode.ag"(line 267, column 23) + (_lhsOtps,_) = + __tup3 + -- "GenerateCode.ag"(line 267, column 23) + (_,_lhsOallTpsFound) = + __tup3 + -- "GenerateCode.ag"(line 369, column 7) + _lhsOdeclsAbove = + _lhsIdeclsAbove ++ _decls + -- "GenerateCode.ag"(line 382, column 7) + _lhsObldBlocksFun = + id + -- "GenerateCode.ag"(line 570, column 12) + _lhsOerrors = + let nameOf (Alias _ _ _ pats@(_:_)) = Ident (show (map (\(Alias _ a _ _)->a) pats)) (getPos name_) + nameOf _ = name_ + in maybe (Seq.single (MissingTypeSig _lhsInt _lhsIcon (nameOf _patternIcopy))) (const Seq.empty) tp_ + -- "GenerateCode.ag"(line 610, column 18) + _lhsOcomments = + [ makeLocalComment 11 _lhsIwhat name tp | (field,name,tp) <- Map.elems defines_, field == _LOC ] + ++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems defines_, field == _INST ] + -- use rule "GenerateCode.ag"(line 87, column 34) + _lhsOdecls = + _decls + -- use rule "GenerateCode.ag"(line 140, column 55) + _lhsOdefinedInsts = + _definedInsts + ( _patternIcopy,_patternIdefinedInsts,_patternIpatternAttributes) = + (pattern_ ) + in ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars))) ) +-- CSegment ---------------------------------------------------- +{- + visit 0: + inherited attributes: + inh : Attributes + isLast : Bool + nr : Int + nt : Nonterminal + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + syn : Attributes + synthesized attributes: + comments : [String] + semDom : [Decl] + wrapDecls : Decls + alternatives: + alternative CSegment: + child inh : {Attributes} + child syn : {Attributes} +-} +-- cata +sem_CSegment :: CSegment -> + T_CSegment +sem_CSegment (CSegment _inh _syn ) = + (sem_CSegment_CSegment _inh _syn ) +-- semantic domain +newtype T_CSegment = T_CSegment (Attributes -> + Bool -> + Int -> + Nonterminal -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + ( ([String]),([Decl]),Decls)) +data Inh_CSegment = Inh_CSegment {inh_Inh_CSegment :: Attributes,isLast_Inh_CSegment :: Bool,nr_Inh_CSegment :: Int,nt_Inh_CSegment :: Nonterminal,o_case_Inh_CSegment :: Bool,o_cata_Inh_CSegment :: Bool,o_costcentre_Inh_CSegment :: Bool,o_data_Inh_CSegment :: Maybe Bool,o_linePragmas_Inh_CSegment :: Bool,o_newtypes_Inh_CSegment :: Bool,o_pretty_Inh_CSegment :: Bool,o_rename_Inh_CSegment :: Bool,o_sem_Inh_CSegment :: Bool,o_sig_Inh_CSegment :: Bool,o_splitsems_Inh_CSegment :: Bool,o_strictwrap_Inh_CSegment :: Bool,o_traces_Inh_CSegment :: Bool,o_unbox_Inh_CSegment :: Bool,prefix_Inh_CSegment :: String,syn_Inh_CSegment :: Attributes} +data Syn_CSegment = Syn_CSegment {comments_Syn_CSegment :: [String],semDom_Syn_CSegment :: [Decl],wrapDecls_Syn_CSegment :: Decls} +wrap_CSegment (T_CSegment sem ) (Inh_CSegment _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) = + (let ( _lhsOcomments,_lhsOsemDom,_lhsOwrapDecls) = + (sem _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) + in (Syn_CSegment _lhsOcomments _lhsOsemDom _lhsOwrapDecls )) +sem_CSegment_CSegment :: Attributes -> + Attributes -> + T_CSegment +sem_CSegment_CSegment inh_ syn_ = + (T_CSegment (\ _lhsIinh + _lhsIisLast + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn -> + (let _lhsOsemDom :: ([Decl]) + _lhsOwrapDecls :: Decls + _lhsOcomments :: ([String]) + -- "GenerateCode.ag"(line 496, column 15) + _lhsOsemDom = + let name = typeName _lhsInt _lhsInr + tp = foldr Arr synTps inhTps + inhTps = [SimpleType (typeToString _lhsInt tp) | tp <- Map.elems inh_] + synTps = mkTupleType _lhsIo_unbox (null inhTps) ([SimpleType (typeToString _lhsInt tp) | tp <- Map.elems syn_] ++ continuation) + continuation = if _lhsIisLast + then [] + else [SimpleType (typeName _lhsInt (_lhsInr + 1))] + in if _lhsIo_newtypes + then [ Code.NewType name name tp ] + else [ Code.Type name tp ] + -- "GenerateCode.ag"(line 534, column 15) + _lhsOwrapDecls = + let lhsVars = map (lhsname False) (Map.keys syn_) + ++ if _lhsIisLast then [] else [unwrap ++ sem (_lhsInr+1)] + rhsVars = map (lhsname True) (Map.keys inh_) + rhs = map SimpleExpr rhsVars + unwrap = if _lhsIo_newtypes then typeName _lhsInt (_lhsInr + 1) ++ " " else "" + var = "sem" + sem 0 = var + sem n = var ++ "_" ++ show n + in [ Decl (mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars) (App (sem _lhsInr) rhs) (Set.fromList lhsVars) (Set.fromList rhsVars) ] + -- "GenerateCode.ag"(line 588, column 18) + _lhsOcomments = + let body = map ind (showsSegment (CSegment inh_ syn_)) + in if null body + then [] + else ("visit " ++ show _lhsInr ++ ":") : body + in ( _lhsOcomments,_lhsOsemDom,_lhsOwrapDecls))) ) +-- CSegments --------------------------------------------------- +{- + visit 0: + inherited attributes: + inh : Attributes + nr : Int + nt : Nonterminal + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + syn : Attributes + synthesized attributes: + comments : [String] + isNil : Bool + semDom : [Decl] + wrapDecls : Decls + alternatives: + alternative Cons: + child hd : CSegment + child tl : CSegments + alternative Nil: +-} +-- cata +sem_CSegments :: CSegments -> + T_CSegments +sem_CSegments list = + (Prelude.foldr sem_CSegments_Cons sem_CSegments_Nil (Prelude.map sem_CSegment list) ) +-- semantic domain +newtype T_CSegments = T_CSegments (Attributes -> + Int -> + Nonterminal -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + ( ([String]),Bool,([Decl]),Decls)) +data Inh_CSegments = Inh_CSegments {inh_Inh_CSegments :: Attributes,nr_Inh_CSegments :: Int,nt_Inh_CSegments :: Nonterminal,o_case_Inh_CSegments :: Bool,o_cata_Inh_CSegments :: Bool,o_costcentre_Inh_CSegments :: Bool,o_data_Inh_CSegments :: Maybe Bool,o_linePragmas_Inh_CSegments :: Bool,o_newtypes_Inh_CSegments :: Bool,o_pretty_Inh_CSegments :: Bool,o_rename_Inh_CSegments :: Bool,o_sem_Inh_CSegments :: Bool,o_sig_Inh_CSegments :: Bool,o_splitsems_Inh_CSegments :: Bool,o_strictwrap_Inh_CSegments :: Bool,o_traces_Inh_CSegments :: Bool,o_unbox_Inh_CSegments :: Bool,prefix_Inh_CSegments :: String,syn_Inh_CSegments :: Attributes} +data Syn_CSegments = Syn_CSegments {comments_Syn_CSegments :: [String],isNil_Syn_CSegments :: Bool,semDom_Syn_CSegments :: [Decl],wrapDecls_Syn_CSegments :: Decls} +wrap_CSegments (T_CSegments sem ) (Inh_CSegments _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) = + (let ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOwrapDecls) = + (sem _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) + in (Syn_CSegments _lhsOcomments _lhsOisNil _lhsOsemDom _lhsOwrapDecls )) +sem_CSegments_Cons :: T_CSegment -> + T_CSegments -> + T_CSegments +sem_CSegments_Cons (T_CSegment hd_ ) (T_CSegments tl_ ) = + (T_CSegments (\ _lhsIinh + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn -> + (let _tlOnr :: Int + _lhsOisNil :: Bool + _hdOisLast :: Bool + _lhsOcomments :: ([String]) + _lhsOsemDom :: ([Decl]) + _lhsOwrapDecls :: Decls + _hdOinh :: Attributes + _hdOnr :: Int + _hdOnt :: Nonterminal + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_costcentre :: Bool + _hdOo_data :: (Maybe Bool) + _hdOo_linePragmas :: Bool + _hdOo_newtypes :: Bool + _hdOo_pretty :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_splitsems :: Bool + _hdOo_strictwrap :: Bool + _hdOo_traces :: Bool + _hdOo_unbox :: Bool + _hdOprefix :: String + _hdOsyn :: Attributes + _tlOinh :: Attributes + _tlOnt :: Nonterminal + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_costcentre :: Bool + _tlOo_data :: (Maybe Bool) + _tlOo_linePragmas :: Bool + _tlOo_newtypes :: Bool + _tlOo_pretty :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_splitsems :: Bool + _tlOo_strictwrap :: Bool + _tlOo_traces :: Bool + _tlOo_unbox :: Bool + _tlOprefix :: String + _tlOsyn :: Attributes + _hdIcomments :: ([String]) + _hdIsemDom :: ([Decl]) + _hdIwrapDecls :: Decls + _tlIcomments :: ([String]) + _tlIisNil :: Bool + _tlIsemDom :: ([Decl]) + _tlIwrapDecls :: Decls + -- "GenerateCode.ag"(line 165, column 11) + _tlOnr = + _lhsInr + 1 + -- "GenerateCode.ag"(line 178, column 12) + _lhsOisNil = + False + -- "GenerateCode.ag"(line 179, column 12) + _hdOisLast = + _tlIisNil + -- use rule "GenerateCode.ag"(line 583, column 52) + _lhsOcomments = + _hdIcomments ++ _tlIcomments + -- use rule "GenerateCode.ag"(line 491, column 50) + _lhsOsemDom = + _hdIsemDom ++ _tlIsemDom + -- use rule "GenerateCode.ag"(line 532, column 52) + _lhsOwrapDecls = + _hdIwrapDecls ++ _tlIwrapDecls + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOnr = + _lhsInr + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _hdOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _hdOo_traces = + _lhsIo_traces + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _tlOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _tlOo_traces = + _lhsIo_traces + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + ( _hdIcomments,_hdIsemDom,_hdIwrapDecls) = + (hd_ _hdOinh _hdOisLast _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOprefix _hdOsyn ) + ( _tlIcomments,_tlIisNil,_tlIsemDom,_tlIwrapDecls) = + (tl_ _tlOinh _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOprefix _tlOsyn ) + in ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOwrapDecls))) ) +sem_CSegments_Nil :: T_CSegments +sem_CSegments_Nil = + (T_CSegments (\ _lhsIinh + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn -> + (let _lhsOisNil :: Bool + _lhsOcomments :: ([String]) + _lhsOsemDom :: ([Decl]) + _lhsOwrapDecls :: Decls + -- "GenerateCode.ag"(line 180, column 10) + _lhsOisNil = + True + -- use rule "GenerateCode.ag"(line 583, column 52) + _lhsOcomments = + [] + -- use rule "GenerateCode.ag"(line 491, column 50) + _lhsOsemDom = + [] + -- use rule "GenerateCode.ag"(line 532, column 52) + _lhsOwrapDecls = + [] + in ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOwrapDecls))) ) +-- CVisit ------------------------------------------------------ +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + children : [(Name,Type,Bool)] + con : Constructor + inh : Attributes + instVisitNrs : Map Identifier Int + isLast : Bool + nextIntra : Exprs + nextIntraVars : Set String + nr : Int + nt : Nonterminal + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + syn : Attributes + terminals : [Name] + with_sig : Bool + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + comments : [String] + decls : Decls + gatherInstVisitNrs : Map Identifier Int + intra : Exprs + intraVars : Set String + semNames : [String] + alternatives: + alternative CVisit: + child inh : {Attributes} + child syn : {Attributes} + child vss : Sequence + child intra : Sequence + child ordered : {Bool} + visit 0: + local _tup4 : _ + local higherOrderChildren : _ + local firstOrderChildren : _ + local funcname : _ + local nextVisitName : _ + local nextVisitDecl : _ + local decls : _ + local lastExprVars : _ + local _tup5 : _ + local blockFunDecls : _ + local blockFirstFunCall : _ + local costCentreDescr : _ + local addCostCentre : _ + local semFun : _ + local tsig : _ + local semType : _ + local typeSigs : _ + local o_case : _ + local o_splitsems : _ +-} +-- cata +sem_CVisit :: CVisit -> + T_CVisit +sem_CVisit (CVisit _inh _syn _vss _intra _ordered ) = + (sem_CVisit_CVisit _inh _syn (sem_Sequence _vss ) (sem_Sequence _intra ) _ordered ) +-- semantic domain +newtype T_CVisit = T_CVisit (PragmaMap -> + ([(Name,Type,Bool)]) -> + Constructor -> + (Seq Error) -> + Attributes -> + (Map Identifier Int) -> + Bool -> + Exprs -> + (Set String) -> + Int -> + Nonterminal -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + ([Name]) -> + Bool -> + ( Bool,([String]),Decls,(Seq Error),(Map Identifier Int),Exprs,(Set String),([String]))) +data Inh_CVisit = Inh_CVisit {allPragmas_Inh_CVisit :: PragmaMap,children_Inh_CVisit :: [(Name,Type,Bool)],con_Inh_CVisit :: Constructor,errors_Inh_CVisit :: Seq Error,inh_Inh_CVisit :: Attributes,instVisitNrs_Inh_CVisit :: Map Identifier Int,isLast_Inh_CVisit :: Bool,nextIntra_Inh_CVisit :: Exprs,nextIntraVars_Inh_CVisit :: Set String,nr_Inh_CVisit :: Int,nt_Inh_CVisit :: Nonterminal,o_case_Inh_CVisit :: Bool,o_cata_Inh_CVisit :: Bool,o_costcentre_Inh_CVisit :: Bool,o_data_Inh_CVisit :: Maybe Bool,o_linePragmas_Inh_CVisit :: Bool,o_newtypes_Inh_CVisit :: Bool,o_pretty_Inh_CVisit :: Bool,o_rename_Inh_CVisit :: Bool,o_sem_Inh_CVisit :: Bool,o_sig_Inh_CVisit :: Bool,o_splitsems_Inh_CVisit :: Bool,o_strictwrap_Inh_CVisit :: Bool,o_traces_Inh_CVisit :: Bool,o_unbox_Inh_CVisit :: Bool,prefix_Inh_CVisit :: String,syn_Inh_CVisit :: Attributes,terminals_Inh_CVisit :: [Name],with_sig_Inh_CVisit :: Bool} +data Syn_CVisit = Syn_CVisit {allTpsFound_Syn_CVisit :: Bool,comments_Syn_CVisit :: [String],decls_Syn_CVisit :: Decls,errors_Syn_CVisit :: Seq Error,gatherInstVisitNrs_Syn_CVisit :: Map Identifier Int,intra_Syn_CVisit :: Exprs,intraVars_Syn_CVisit :: Set String,semNames_Syn_CVisit :: [String]} +wrap_CVisit (T_CVisit sem ) (Inh_CVisit _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwith_sig ) = + (let ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOsemNames) = + (sem _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwith_sig ) + in (Syn_CVisit _lhsOallTpsFound _lhsOcomments _lhsOdecls _lhsOerrors _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOsemNames )) +sem_CVisit_CVisit :: Attributes -> + Attributes -> + T_Sequence -> + T_Sequence -> + Bool -> + T_CVisit +sem_CVisit_CVisit inh_ syn_ (T_Sequence vss_ ) (T_Sequence intra_ ) ordered_ = + (T_CVisit (\ _lhsIallPragmas + _lhsIchildren + _lhsIcon + _lhsIerrors + _lhsIinh + _lhsIinstVisitNrs + _lhsIisLast + _lhsInextIntra + _lhsInextIntraVars + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwith_sig -> + (let _lhsOintra :: Exprs + _lhsOintraVars :: (Set String) + _vssOlastExpr :: Expr + _intraOlastExpr :: Expr + _lhsOdecls :: Decls + _lhsOgatherInstVisitNrs :: (Map Identifier Int) + _vssOdeclsAbove :: ([Decl]) + _intraOdeclsAbove :: ([Decl]) + _lhsOallTpsFound :: Bool + _lhsOerrors :: (Seq Error) + _lhsOcomments :: ([String]) + _vssOwhat :: String + _intraOwhat :: String + _lhsOsemNames :: ([String]) + _vssOchildren :: ([(Name,Type,Bool)]) + _vssOcon :: Constructor + _vssOerrors :: (Seq Error) + _vssOhigherOrderChildren :: ([(Name,Type,Bool)]) + _vssOinh :: Attributes + _vssOinstVisitNrs :: (Map Identifier Int) + _vssOnr :: Int + _vssOnt :: Nonterminal + _vssOo_case :: Bool + _vssOo_cata :: Bool + _vssOo_costcentre :: Bool + _vssOo_data :: (Maybe Bool) + _vssOo_linePragmas :: Bool + _vssOo_newtypes :: Bool + _vssOo_pretty :: Bool + _vssOo_rename :: Bool + _vssOo_sem :: Bool + _vssOo_sig :: Bool + _vssOo_splitsems :: Bool + _vssOo_strictwrap :: Bool + _vssOo_traces :: Bool + _vssOo_unbox :: Bool + _vssOprefix :: String + _vssOsyn :: Attributes + _vssOterminals :: ([Name]) + _intraOchildren :: ([(Name,Type,Bool)]) + _intraOcon :: Constructor + _intraOerrors :: (Seq Error) + _intraOhigherOrderChildren :: ([(Name,Type,Bool)]) + _intraOinh :: Attributes + _intraOinstVisitNrs :: (Map Identifier Int) + _intraOnr :: Int + _intraOnt :: Nonterminal + _intraOo_case :: Bool + _intraOo_cata :: Bool + _intraOo_costcentre :: Bool + _intraOo_data :: (Maybe Bool) + _intraOo_linePragmas :: Bool + _intraOo_newtypes :: Bool + _intraOo_pretty :: Bool + _intraOo_rename :: Bool + _intraOo_sem :: Bool + _intraOo_sig :: Bool + _intraOo_splitsems :: Bool + _intraOo_strictwrap :: Bool + _intraOo_traces :: Bool + _intraOo_unbox :: Bool + _intraOprefix :: String + _intraOsyn :: Attributes + _intraOterminals :: ([Name]) + _vssIallTpsFound :: Bool + _vssIblockDecls :: DeclBlocks + _vssIcomments :: ([String]) + _vssIdecls :: Decls + _vssIdeclsAbove :: ([Decl]) + _vssIdefinedInsts :: ([Identifier]) + _vssIerrors :: (Seq Error) + _vssIexprs :: Exprs + _vssItSigs :: ([Decl]) + _vssItps :: ([Type]) + _vssIusedVars :: (Set String) + _intraIallTpsFound :: Bool + _intraIblockDecls :: DeclBlocks + _intraIcomments :: ([String]) + _intraIdecls :: Decls + _intraIdeclsAbove :: ([Decl]) + _intraIdefinedInsts :: ([Identifier]) + _intraIerrors :: (Seq Error) + _intraIexprs :: Exprs + _intraItSigs :: ([Decl]) + _intraItps :: ([Type]) + _intraIusedVars :: (Set String) + -- "GenerateCode.ag"(line 189, column 13) + _lhsOintra = + _intraIexprs + -- "GenerateCode.ag"(line 190, column 13) + _lhsOintraVars = + _intraIusedVars + -- "GenerateCode.ag"(line 278, column 13) + __tup4 = + partition (\(_,_,ho) -> ho) _lhsIchildren + -- "GenerateCode.ag"(line 278, column 13) + (_higherOrderChildren,_) = + __tup4 + -- "GenerateCode.ag"(line 278, column 13) + (_,_firstOrderChildren) = + __tup4 + -- "GenerateCode.ag"(line 279, column 13) + _funcname = + seqSemname _lhsIprefix _lhsInt _lhsIcon _lhsInr + -- "GenerateCode.ag"(line 280, column 13) + _nextVisitName = + if _lhsIisLast then [] else [visitname _lhsIprefix _lhsInt (_lhsInr+1)] + -- "GenerateCode.ag"(line 281, column 13) + _nextVisitDecl = + let lhs = TupleLhs _nextVisitName + rhs = App fun _lhsInextIntra + fun = seqSemname _lhsIprefix _lhsInt _lhsIcon (_lhsInr+1) + in if _lhsIisLast + then [] + else [Decl lhs rhs (Set.fromList _nextVisitName) _lhsInextIntraVars] + -- "GenerateCode.ag"(line 287, column 13) + _decls = + _typeSigs ++ _vssIdecls ++ _nextVisitDecl + -- "GenerateCode.ag"(line 288, column 13) + _vssOlastExpr = + mkTupleExpr _lhsIo_unbox (null $ Map.keys inh_) $ map (SimpleExpr . lhsname False) (Map.keys syn_) ++ map SimpleExpr _nextVisitName + -- "GenerateCode.ag"(line 289, column 13) + _intraOlastExpr = + error "lastExpr: not used here" + -- "GenerateCode.ag"(line 290, column 13) + _lastExprVars = + map (lhsname False) (Map.keys syn_) ++ _nextVisitName + -- "GenerateCode.ag"(line 291, column 13) + __tup5 = + mkPartitionedFunction _funcname _o_case _nextVisitDecl _lastExprVars _vssIblockDecls + -- "GenerateCode.ag"(line 291, column 13) + (_blockFunDecls,_) = + __tup5 + -- "GenerateCode.ag"(line 291, column 13) + (_,_blockFirstFunCall) = + __tup5 + -- "GenerateCode.ag"(line 293, column 13) + _costCentreDescr = + "b" ++ ":" ++ show _lhsInt ++ ":" ++ show _lhsIcon ++ ":" ++ show _lhsInr + -- "GenerateCode.ag"(line 294, column 13) + _addCostCentre = + \v -> if _lhsIo_costcentre + then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v + else v + -- "GenerateCode.ag"(line 298, column 13) + _semFun = + let lhs = Fun _funcname lhs_args + lhs_args = if _lhsInr == 0 then map field _firstOrderChildren else _intraIexprs + field (name,NT tp,_) = let unwrap | _lhsIo_newtypes = \x -> App (sdtype tp) [x] + | otherwise = id + in unwrap (SimpleExpr (funname name 0)) + field (name,_,_) = SimpleExpr (funname name 0) + rhs = wrap + . mkLambda (map (lhsname True) (Map.keys inh_)) + $ _addCostCentre + $ if ordered_ && _o_splitsems + then _blockFirstFunCall + else mkLet _o_case _decls + . mkTupleExpr _lhsIo_unbox (null $ Map.keys inh_) + $ map (SimpleExpr . lhsname False) (Map.keys syn_) ++ map SimpleExpr _nextVisitName + wrap = if _lhsIo_newtypes + then \x -> App (typeName _lhsInt _lhsInr) [x] + else id + in Decl lhs rhs Set.empty Set.empty + -- "GenerateCode.ag"(line 319, column 13) + _tsig = + TSig _funcname _semType + -- "GenerateCode.ag"(line 320, column 13) + _semType = + let argType (NT tp) rec | tp /= _SELF = SimpleType (sdtype tp) `Arr` rec + | tp == _SELF = error "GenerateCode: found an intra-type with type SELF, which should have been prevented by CRule.tps" + argType (Haskell tp) rec = SimpleType tp `Arr` rec + in if _lhsInr == 0 + then foldr argType (SimpleType (sdtype _lhsInt )) (map (\(_,t,_) -> t) _firstOrderChildren ) + else foldr argType (SimpleType (typeName _lhsInt _lhsInr)) _intraItps + -- "GenerateCode.ag"(line 326, column 13) + _lhsOdecls = + ( if _lhsIwith_sig + then [_tsig, _semFun] + else [_semFun] + ) ++ + ( if ordered_ && _o_splitsems + then _blockFunDecls + else [] + ) + -- "GenerateCode.ag"(line 334, column 13) + _typeSigs = + if _lhsIo_sig && not _o_case + then _vssItSigs + else [] + -- "GenerateCode.ag"(line 337, column 13) + _o_case = + _lhsIo_case && ordered_ && not (hasPragma _lhsIallPragmas _lhsInt _lhsIcon _NOCASE) + -- "GenerateCode.ag"(line 338, column 13) + _o_splitsems = + ordered_ && _lhsIo_splitsems + -- "GenerateCode.ag"(line 353, column 7) + _lhsOgatherInstVisitNrs = + Map.fromList [(i,_lhsInr) | i <- _vssIdefinedInsts] + -- "GenerateCode.ag"(line 364, column 7) + _vssOdeclsAbove = + [] + -- "GenerateCode.ag"(line 365, column 7) + _intraOdeclsAbove = + error "declsAbove: not used here" + -- "GenerateCode.ag"(line 557, column 13) + _lhsOallTpsFound = + _intraIallTpsFound + -- "GenerateCode.ag"(line 568, column 13) + _lhsOerrors = + _intraIerrors + -- "GenerateCode.ag"(line 601, column 18) + _lhsOcomments = + let body = map ind (_vssIcomments ++ _intraIcomments) + in if null body + then [] + else ("visit " ++ show _lhsInr ++ ":") : body + -- "GenerateCode.ag"(line 605, column 18) + _vssOwhat = + "local" + -- "GenerateCode.ag"(line 606, column 18) + _intraOwhat = + "intra" + -- "GenerateCode.ag"(line 784, column 7) + _lhsOsemNames = + [_funcname ] + -- copy rule (down) + _vssOchildren = + _lhsIchildren + -- copy rule (down) + _vssOcon = + _lhsIcon + -- copy rule (down) + _vssOerrors = + _lhsIerrors + -- copy rule (from local) + _vssOhigherOrderChildren = + _higherOrderChildren + -- copy rule (down) + _vssOinh = + _lhsIinh + -- copy rule (down) + _vssOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _vssOnr = + _lhsInr + -- copy rule (down) + _vssOnt = + _lhsInt + -- copy rule (from local) + _vssOo_case = + _o_case + -- copy rule (down) + _vssOo_cata = + _lhsIo_cata + -- copy rule (down) + _vssOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _vssOo_data = + _lhsIo_data + -- copy rule (down) + _vssOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _vssOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _vssOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _vssOo_rename = + _lhsIo_rename + -- copy rule (down) + _vssOo_sem = + _lhsIo_sem + -- copy rule (down) + _vssOo_sig = + _lhsIo_sig + -- copy rule (from local) + _vssOo_splitsems = + _o_splitsems + -- copy rule (down) + _vssOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _vssOo_traces = + _lhsIo_traces + -- copy rule (down) + _vssOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _vssOprefix = + _lhsIprefix + -- copy rule (down) + _vssOsyn = + _lhsIsyn + -- copy rule (down) + _vssOterminals = + _lhsIterminals + -- copy rule (down) + _intraOchildren = + _lhsIchildren + -- copy rule (down) + _intraOcon = + _lhsIcon + -- copy rule (chain) + _intraOerrors = + _vssIerrors + -- copy rule (from local) + _intraOhigherOrderChildren = + _higherOrderChildren + -- copy rule (down) + _intraOinh = + _lhsIinh + -- copy rule (down) + _intraOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _intraOnr = + _lhsInr + -- copy rule (down) + _intraOnt = + _lhsInt + -- copy rule (from local) + _intraOo_case = + _o_case + -- copy rule (down) + _intraOo_cata = + _lhsIo_cata + -- copy rule (down) + _intraOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _intraOo_data = + _lhsIo_data + -- copy rule (down) + _intraOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _intraOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _intraOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _intraOo_rename = + _lhsIo_rename + -- copy rule (down) + _intraOo_sem = + _lhsIo_sem + -- copy rule (down) + _intraOo_sig = + _lhsIo_sig + -- copy rule (from local) + _intraOo_splitsems = + _o_splitsems + -- copy rule (down) + _intraOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _intraOo_traces = + _lhsIo_traces + -- copy rule (down) + _intraOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _intraOprefix = + _lhsIprefix + -- copy rule (down) + _intraOsyn = + _lhsIsyn + -- copy rule (down) + _intraOterminals = + _lhsIterminals + ( _vssIallTpsFound,_vssIblockDecls,_vssIcomments,_vssIdecls,_vssIdeclsAbove,_vssIdefinedInsts,_vssIerrors,_vssIexprs,_vssItSigs,_vssItps,_vssIusedVars) = + (vss_ _vssOchildren _vssOcon _vssOdeclsAbove _vssOerrors _vssOhigherOrderChildren _vssOinh _vssOinstVisitNrs _vssOlastExpr _vssOnr _vssOnt _vssOo_case _vssOo_cata _vssOo_costcentre _vssOo_data _vssOo_linePragmas _vssOo_newtypes _vssOo_pretty _vssOo_rename _vssOo_sem _vssOo_sig _vssOo_splitsems _vssOo_strictwrap _vssOo_traces _vssOo_unbox _vssOprefix _vssOsyn _vssOterminals _vssOwhat ) + ( _intraIallTpsFound,_intraIblockDecls,_intraIcomments,_intraIdecls,_intraIdeclsAbove,_intraIdefinedInsts,_intraIerrors,_intraIexprs,_intraItSigs,_intraItps,_intraIusedVars) = + (intra_ _intraOchildren _intraOcon _intraOdeclsAbove _intraOerrors _intraOhigherOrderChildren _intraOinh _intraOinstVisitNrs _intraOlastExpr _intraOnr _intraOnt _intraOo_case _intraOo_cata _intraOo_costcentre _intraOo_data _intraOo_linePragmas _intraOo_newtypes _intraOo_pretty _intraOo_rename _intraOo_sem _intraOo_sig _intraOo_splitsems _intraOo_strictwrap _intraOo_traces _intraOo_unbox _intraOprefix _intraOsyn _intraOterminals _intraOwhat ) + in ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOsemNames))) ) +-- CVisits ----------------------------------------------------- +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + children : [(Name,Type,Bool)] + con : Constructor + inh : Attributes + instVisitNrs : Map Identifier Int + nr : Int + nt : Nonterminal + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + syn : Attributes + terminals : [Name] + with_sig : Bool + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + comments : [String] + decls : Decls + gatherInstVisitNrs : Map Identifier Int + intra : Exprs + intraVars : Set String + isNil : Bool + semNames : [String] + alternatives: + alternative Cons: + child hd : CVisit + child tl : CVisits + alternative Nil: +-} +-- cata +sem_CVisits :: CVisits -> + T_CVisits +sem_CVisits list = + (Prelude.foldr sem_CVisits_Cons sem_CVisits_Nil (Prelude.map sem_CVisit list) ) +-- semantic domain +newtype T_CVisits = T_CVisits (PragmaMap -> + ([(Name,Type,Bool)]) -> + Constructor -> + (Seq Error) -> + Attributes -> + (Map Identifier Int) -> + Int -> + Nonterminal -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + ([Name]) -> + Bool -> + ( Bool,([String]),Decls,(Seq Error),(Map Identifier Int),Exprs,(Set String),Bool,([String]))) +data Inh_CVisits = Inh_CVisits {allPragmas_Inh_CVisits :: PragmaMap,children_Inh_CVisits :: [(Name,Type,Bool)],con_Inh_CVisits :: Constructor,errors_Inh_CVisits :: Seq Error,inh_Inh_CVisits :: Attributes,instVisitNrs_Inh_CVisits :: Map Identifier Int,nr_Inh_CVisits :: Int,nt_Inh_CVisits :: Nonterminal,o_case_Inh_CVisits :: Bool,o_cata_Inh_CVisits :: Bool,o_costcentre_Inh_CVisits :: Bool,o_data_Inh_CVisits :: Maybe Bool,o_linePragmas_Inh_CVisits :: Bool,o_newtypes_Inh_CVisits :: Bool,o_pretty_Inh_CVisits :: Bool,o_rename_Inh_CVisits :: Bool,o_sem_Inh_CVisits :: Bool,o_sig_Inh_CVisits :: Bool,o_splitsems_Inh_CVisits :: Bool,o_strictwrap_Inh_CVisits :: Bool,o_traces_Inh_CVisits :: Bool,o_unbox_Inh_CVisits :: Bool,prefix_Inh_CVisits :: String,syn_Inh_CVisits :: Attributes,terminals_Inh_CVisits :: [Name],with_sig_Inh_CVisits :: Bool} +data Syn_CVisits = Syn_CVisits {allTpsFound_Syn_CVisits :: Bool,comments_Syn_CVisits :: [String],decls_Syn_CVisits :: Decls,errors_Syn_CVisits :: Seq Error,gatherInstVisitNrs_Syn_CVisits :: Map Identifier Int,intra_Syn_CVisits :: Exprs,intraVars_Syn_CVisits :: Set String,isNil_Syn_CVisits :: Bool,semNames_Syn_CVisits :: [String]} +wrap_CVisits (T_CVisits sem ) (Inh_CVisits _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwith_sig ) = + (let ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames) = + (sem _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwith_sig ) + in (Syn_CVisits _lhsOallTpsFound _lhsOcomments _lhsOdecls _lhsOerrors _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOisNil _lhsOsemNames )) +sem_CVisits_Cons :: T_CVisit -> + T_CVisits -> + T_CVisits +sem_CVisits_Cons (T_CVisit hd_ ) (T_CVisits tl_ ) = + (T_CVisits (\ _lhsIallPragmas + _lhsIchildren + _lhsIcon + _lhsIerrors + _lhsIinh + _lhsIinstVisitNrs + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwith_sig -> + (let _tlOnr :: Int + _lhsOisNil :: Bool + _hdOisLast :: Bool + _hdOnextIntra :: Exprs + _hdOnextIntraVars :: (Set String) + _lhsOintra :: Exprs + _lhsOintraVars :: (Set String) + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOerrors :: (Seq Error) + _lhsOgatherInstVisitNrs :: (Map Identifier Int) + _lhsOsemNames :: ([String]) + _hdOallPragmas :: PragmaMap + _hdOchildren :: ([(Name,Type,Bool)]) + _hdOcon :: Constructor + _hdOerrors :: (Seq Error) + _hdOinh :: Attributes + _hdOinstVisitNrs :: (Map Identifier Int) + _hdOnr :: Int + _hdOnt :: Nonterminal + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_costcentre :: Bool + _hdOo_data :: (Maybe Bool) + _hdOo_linePragmas :: Bool + _hdOo_newtypes :: Bool + _hdOo_pretty :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_splitsems :: Bool + _hdOo_strictwrap :: Bool + _hdOo_traces :: Bool + _hdOo_unbox :: Bool + _hdOprefix :: String + _hdOsyn :: Attributes + _hdOterminals :: ([Name]) + _hdOwith_sig :: Bool + _tlOallPragmas :: PragmaMap + _tlOchildren :: ([(Name,Type,Bool)]) + _tlOcon :: Constructor + _tlOerrors :: (Seq Error) + _tlOinh :: Attributes + _tlOinstVisitNrs :: (Map Identifier Int) + _tlOnt :: Nonterminal + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_costcentre :: Bool + _tlOo_data :: (Maybe Bool) + _tlOo_linePragmas :: Bool + _tlOo_newtypes :: Bool + _tlOo_pretty :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_splitsems :: Bool + _tlOo_strictwrap :: Bool + _tlOo_traces :: Bool + _tlOo_unbox :: Bool + _tlOprefix :: String + _tlOsyn :: Attributes + _tlOterminals :: ([Name]) + _tlOwith_sig :: Bool + _hdIallTpsFound :: Bool + _hdIcomments :: ([String]) + _hdIdecls :: Decls + _hdIerrors :: (Seq Error) + _hdIgatherInstVisitNrs :: (Map Identifier Int) + _hdIintra :: Exprs + _hdIintraVars :: (Set String) + _hdIsemNames :: ([String]) + _tlIallTpsFound :: Bool + _tlIcomments :: ([String]) + _tlIdecls :: Decls + _tlIerrors :: (Seq Error) + _tlIgatherInstVisitNrs :: (Map Identifier Int) + _tlIintra :: Exprs + _tlIintraVars :: (Set String) + _tlIisNil :: Bool + _tlIsemNames :: ([String]) + -- "GenerateCode.ag"(line 161, column 11) + _tlOnr = + _lhsInr + 1 + -- "GenerateCode.ag"(line 174, column 12) + _lhsOisNil = + False + -- "GenerateCode.ag"(line 175, column 12) + _hdOisLast = + _tlIisNil + -- "GenerateCode.ag"(line 192, column 12) + _hdOnextIntra = + _tlIintra + -- "GenerateCode.ag"(line 193, column 12) + _hdOnextIntraVars = + _tlIintraVars + -- "GenerateCode.ag"(line 194, column 12) + _lhsOintra = + _hdIintra + -- "GenerateCode.ag"(line 195, column 12) + _lhsOintraVars = + _hdIintraVars + -- use rule "GenerateCode.ag"(line 551, column 39) + _lhsOallTpsFound = + _hdIallTpsFound && _tlIallTpsFound + -- use rule "GenerateCode.ag"(line 583, column 52) + _lhsOcomments = + _hdIcomments ++ _tlIcomments + -- use rule "GenerateCode.ag"(line 276, column 33) + _lhsOdecls = + _hdIdecls ++ _tlIdecls + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "GenerateCode.ag"(line 346, column 44) + _lhsOgatherInstVisitNrs = + _hdIgatherInstVisitNrs `Map.union` _tlIgatherInstVisitNrs + -- use rule "GenerateCode.ag"(line 774, column 63) + _lhsOsemNames = + _hdIsemNames ++ _tlIsemNames + -- copy rule (down) + _hdOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _hdOchildren = + _lhsIchildren + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOerrors = + _lhsIerrors + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _hdOnr = + _lhsInr + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _hdOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _hdOo_traces = + _lhsIo_traces + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOterminals = + _lhsIterminals + -- copy rule (down) + _hdOwith_sig = + _lhsIwith_sig + -- copy rule (down) + _tlOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _tlOchildren = + _lhsIchildren + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (chain) + _tlOerrors = + _hdIerrors + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _tlOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _tlOo_traces = + _lhsIo_traces + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (down) + _tlOterminals = + _lhsIterminals + -- copy rule (down) + _tlOwith_sig = + _lhsIwith_sig + ( _hdIallTpsFound,_hdIcomments,_hdIdecls,_hdIerrors,_hdIgatherInstVisitNrs,_hdIintra,_hdIintraVars,_hdIsemNames) = + (hd_ _hdOallPragmas _hdOchildren _hdOcon _hdOerrors _hdOinh _hdOinstVisitNrs _hdOisLast _hdOnextIntra _hdOnextIntraVars _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOprefix _hdOsyn _hdOterminals _hdOwith_sig ) + ( _tlIallTpsFound,_tlIcomments,_tlIdecls,_tlIerrors,_tlIgatherInstVisitNrs,_tlIintra,_tlIintraVars,_tlIisNil,_tlIsemNames) = + (tl_ _tlOallPragmas _tlOchildren _tlOcon _tlOerrors _tlOinh _tlOinstVisitNrs _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOprefix _tlOsyn _tlOterminals _tlOwith_sig ) + in ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames))) ) +sem_CVisits_Nil :: T_CVisits +sem_CVisits_Nil = + (T_CVisits (\ _lhsIallPragmas + _lhsIchildren + _lhsIcon + _lhsIerrors + _lhsIinh + _lhsIinstVisitNrs + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwith_sig -> + (let _lhsOisNil :: Bool + _lhsOintra :: Exprs + _lhsOintraVars :: (Set String) + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOerrors :: (Seq Error) + _lhsOgatherInstVisitNrs :: (Map Identifier Int) + _lhsOsemNames :: ([String]) + -- "GenerateCode.ag"(line 176, column 10) + _lhsOisNil = + True + -- "GenerateCode.ag"(line 196, column 10) + _lhsOintra = + [] + -- "GenerateCode.ag"(line 197, column 10) + _lhsOintraVars = + Set.empty + -- use rule "GenerateCode.ag"(line 551, column 39) + _lhsOallTpsFound = + True + -- use rule "GenerateCode.ag"(line 583, column 52) + _lhsOcomments = + [] + -- use rule "GenerateCode.ag"(line 276, column 33) + _lhsOdecls = + [] + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + Seq.empty + -- use rule "GenerateCode.ag"(line 346, column 44) + _lhsOgatherInstVisitNrs = + Map.empty + -- use rule "GenerateCode.ag"(line 774, column 63) + _lhsOsemNames = + [] + in ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames))) ) +-- DeclBlocks -------------------------------------------------- +{- + visit 0: + inherited attributes: + blockNr : Int + lastExprVars : [String] + nextVisitDecls : [Decl] + optCase : Bool + prefix : String + synthesized attributes: + callExpr : Expr + decls : [Decl] + freeVars : [String] + alternatives: + alternative DeclBlock: + child defs : {[Decl]} + child visit : {Decl} + child next : DeclBlocks + visit 0: + local lambdaName : _ + local pragmaDecl : _ + local freeVars : _ + local decl : _ + alternative DeclTerminator: + child defs : {[Decl]} + child result : {Expr} + visit 0: + local lambdaName : _ + local pragmaDecl : _ + local freeVars : _ +-} +-- cata +sem_DeclBlocks :: DeclBlocks -> + T_DeclBlocks +sem_DeclBlocks (DeclBlock _defs _visit _next ) = + (sem_DeclBlocks_DeclBlock _defs _visit (sem_DeclBlocks _next ) ) +sem_DeclBlocks (DeclTerminator _defs _result ) = + (sem_DeclBlocks_DeclTerminator _defs _result ) +-- semantic domain +newtype T_DeclBlocks = T_DeclBlocks (Int -> + ([String]) -> + ([Decl]) -> + Bool -> + String -> + ( Expr,([Decl]),([String]))) +data Inh_DeclBlocks = Inh_DeclBlocks {blockNr_Inh_DeclBlocks :: Int,lastExprVars_Inh_DeclBlocks :: [String],nextVisitDecls_Inh_DeclBlocks :: [Decl],optCase_Inh_DeclBlocks :: Bool,prefix_Inh_DeclBlocks :: String} +data Syn_DeclBlocks = Syn_DeclBlocks {callExpr_Syn_DeclBlocks :: Expr,decls_Syn_DeclBlocks :: [Decl],freeVars_Syn_DeclBlocks :: [String]} +wrap_DeclBlocks (T_DeclBlocks sem ) (Inh_DeclBlocks _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix ) = + (let ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars) = + (sem _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix ) + in (Syn_DeclBlocks _lhsOcallExpr _lhsOdecls _lhsOfreeVars )) +sem_DeclBlocks_DeclBlock :: ([Decl]) -> + Decl -> + T_DeclBlocks -> + T_DeclBlocks +sem_DeclBlocks_DeclBlock defs_ visit_ (T_DeclBlocks next_ ) = + (T_DeclBlocks (\ _lhsIblockNr + _lhsIlastExprVars + _lhsInextVisitDecls + _lhsIoptCase + _lhsIprefix -> + (let _nextOblockNr :: Int + _lhsOcallExpr :: Expr + _lhsOdecls :: ([Decl]) + _lhsOfreeVars :: ([String]) + _nextOlastExprVars :: ([String]) + _nextOnextVisitDecls :: ([Decl]) + _nextOoptCase :: Bool + _nextOprefix :: String + _nextIcallExpr :: Expr + _nextIdecls :: ([Decl]) + _nextIfreeVars :: ([String]) + -- "GenerateCode.ag"(line 443, column 7) + _nextOblockNr = + _lhsIblockNr + 1 + -- "GenerateCode.ag"(line 448, column 7) + _lambdaName = + _lhsIprefix ++ "_block" ++ show _lhsIblockNr + -- "GenerateCode.ag"(line 449, column 7) + _pragmaDecl = + PragmaDecl ("NOINLINE " ++ _lambdaName ) + -- "GenerateCode.ag"(line 450, column 7) + _lhsOcallExpr = + App _lambdaName (map SimpleExpr _freeVars ) + -- "GenerateCode.ag"(line 454, column 7) + _freeVars = + freevars _nextIfreeVars (visit_ : defs_) + -- "GenerateCode.ag"(line 461, column 7) + _decl = + mkBlockLambda _lhsIoptCase _lambdaName _freeVars (defs_ ++ [visit_]) _nextIcallExpr + -- "GenerateCode.ag"(line 462, column 7) + _lhsOdecls = + (if _lhsIblockNr > 1 then [_pragmaDecl ] else []) ++ [_decl ] ++ _nextIdecls + -- copy rule (from local) + _lhsOfreeVars = + _freeVars + -- copy rule (down) + _nextOlastExprVars = + _lhsIlastExprVars + -- copy rule (down) + _nextOnextVisitDecls = + _lhsInextVisitDecls + -- copy rule (down) + _nextOoptCase = + _lhsIoptCase + -- copy rule (down) + _nextOprefix = + _lhsIprefix + ( _nextIcallExpr,_nextIdecls,_nextIfreeVars) = + (next_ _nextOblockNr _nextOlastExprVars _nextOnextVisitDecls _nextOoptCase _nextOprefix ) + in ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars))) ) +sem_DeclBlocks_DeclTerminator :: ([Decl]) -> + Expr -> + T_DeclBlocks +sem_DeclBlocks_DeclTerminator defs_ result_ = + (T_DeclBlocks (\ _lhsIblockNr + _lhsIlastExprVars + _lhsInextVisitDecls + _lhsIoptCase + _lhsIprefix -> + (let _lhsOcallExpr :: Expr + _lhsOdecls :: ([Decl]) + _lhsOfreeVars :: ([String]) + -- "GenerateCode.ag"(line 448, column 7) + _lambdaName = + _lhsIprefix ++ "_block" ++ show _lhsIblockNr + -- "GenerateCode.ag"(line 449, column 7) + _pragmaDecl = + PragmaDecl ("NOINLINE " ++ _lambdaName ) + -- "GenerateCode.ag"(line 450, column 7) + _lhsOcallExpr = + App _lambdaName (map SimpleExpr _freeVars ) + -- "GenerateCode.ag"(line 452, column 7) + _freeVars = + freevars _lhsIlastExprVars (defs_ ++ _lhsInextVisitDecls) + -- "GenerateCode.ag"(line 459, column 7) + _lhsOdecls = + [ mkBlockLambda _lhsIoptCase _lambdaName _freeVars (defs_ ++ _lhsInextVisitDecls) result_ ] + -- copy rule (from local) + _lhsOfreeVars = + _freeVars + in ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars))) ) +-- DeclBlocksRoot ---------------------------------------------- +{- + visit 0: + inherited attributes: + lastExprVars : [String] + nextVisitDecls : [Decl] + optCase : Bool + prefix : String + synthesized attributes: + firstCall : Expr + lambdas : [Decl] + alternatives: + alternative DeclBlocksRoot: + child blocks : DeclBlocks +-} +-- cata +sem_DeclBlocksRoot :: DeclBlocksRoot -> + T_DeclBlocksRoot +sem_DeclBlocksRoot (DeclBlocksRoot _blocks ) = + (sem_DeclBlocksRoot_DeclBlocksRoot (sem_DeclBlocks _blocks ) ) +-- semantic domain +newtype T_DeclBlocksRoot = T_DeclBlocksRoot (([String]) -> + ([Decl]) -> + Bool -> + String -> + ( Expr,([Decl]))) +data Inh_DeclBlocksRoot = Inh_DeclBlocksRoot {lastExprVars_Inh_DeclBlocksRoot :: [String],nextVisitDecls_Inh_DeclBlocksRoot :: [Decl],optCase_Inh_DeclBlocksRoot :: Bool,prefix_Inh_DeclBlocksRoot :: String} +data Syn_DeclBlocksRoot = Syn_DeclBlocksRoot {firstCall_Syn_DeclBlocksRoot :: Expr,lambdas_Syn_DeclBlocksRoot :: [Decl]} +wrap_DeclBlocksRoot (T_DeclBlocksRoot sem ) (Inh_DeclBlocksRoot _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix ) = + (let ( _lhsOfirstCall,_lhsOlambdas) = + (sem _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix ) + in (Syn_DeclBlocksRoot _lhsOfirstCall _lhsOlambdas )) +sem_DeclBlocksRoot_DeclBlocksRoot :: T_DeclBlocks -> + T_DeclBlocksRoot +sem_DeclBlocksRoot_DeclBlocksRoot (T_DeclBlocks blocks_ ) = + (T_DeclBlocksRoot (\ _lhsIlastExprVars + _lhsInextVisitDecls + _lhsIoptCase + _lhsIprefix -> + (let _lhsOlambdas :: ([Decl]) + _lhsOfirstCall :: Expr + _blocksOblockNr :: Int + _blocksOlastExprVars :: ([String]) + _blocksOnextVisitDecls :: ([Decl]) + _blocksOoptCase :: Bool + _blocksOprefix :: String + _blocksIcallExpr :: Expr + _blocksIdecls :: ([Decl]) + _blocksIfreeVars :: ([String]) + -- "GenerateCode.ag"(line 434, column 7) + _lhsOlambdas = + _blocksIdecls + -- "GenerateCode.ag"(line 435, column 7) + _lhsOfirstCall = + _blocksIcallExpr + -- "GenerateCode.ag"(line 440, column 7) + _blocksOblockNr = + 1 + -- copy rule (down) + _blocksOlastExprVars = + _lhsIlastExprVars + -- copy rule (down) + _blocksOnextVisitDecls = + _lhsInextVisitDecls + -- copy rule (down) + _blocksOoptCase = + _lhsIoptCase + -- copy rule (down) + _blocksOprefix = + _lhsIprefix + ( _blocksIcallExpr,_blocksIdecls,_blocksIfreeVars) = + (blocks_ _blocksOblockNr _blocksOlastExprVars _blocksOnextVisitDecls _blocksOoptCase _blocksOprefix ) + in ( _lhsOfirstCall,_lhsOlambdas))) ) +-- Pattern ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + definedInsts : [Identifier] + patternAttributes : [(Name, Name)] + alternatives: + alternative Alias: + child field : {Name} + child attr : {Name} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + alternative Constr: + child name : {Constructor} + child pats : Patterns + visit 0: + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts ) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) +sem_Pattern (Constr _name _pats ) = + (sem_Pattern_Constr _name (sem_Patterns _pats ) ) +sem_Pattern (Product _pos _pats ) = + (sem_Pattern_Product _pos (sem_Patterns _pats ) ) +sem_Pattern (Underscore _pos ) = + (sem_Pattern_Underscore _pos ) +-- semantic domain +newtype T_Pattern = T_Pattern (( Pattern,([Identifier]),([(Name, Name)]))) +data Inh_Pattern = Inh_Pattern {} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,definedInsts_Syn_Pattern :: [Identifier],patternAttributes_Syn_Pattern :: [(Name, Name)]} +wrap_Pattern (T_Pattern sem ) (Inh_Pattern ) = + (let ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes) = + (sem ) + in (Syn_Pattern _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes )) +sem_Pattern_Alias :: Name -> + Name -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = + (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Name, Name)]) + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIdefinedInsts :: ([Identifier]) + _patIpatternAttributes :: ([(Name, Name)]) + _partsIcopy :: Patterns + _partsIdefinedInsts :: ([Identifier]) + _partsIpatternAttributes :: ([(Name, Name)]) + -- "GenerateCode.ag"(line 142, column 11) + _lhsOdefinedInsts = + (if field_ == _INST then [attr_] else []) ++ _patIdefinedInsts + -- "GenerateCode.ag"(line 150, column 7) + _lhsOpatternAttributes = + (field_,attr_) : (_patIpatternAttributes ++ _partsIpatternAttributes) + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patIcopy,_patIdefinedInsts,_patIpatternAttributes) = + (pat_ ) + ( _partsIcopy,_partsIdefinedInsts,_partsIpatternAttributes) = + (parts_ ) + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) +sem_Pattern_Constr :: Constructor -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_ ) = + (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Name, Name)]) + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIdefinedInsts :: ([Identifier]) + _patsIpatternAttributes :: ([(Name, Name)]) + -- use rule "GenerateCode.ag"(line 140, column 55) + _lhsOdefinedInsts = + _patsIdefinedInsts + -- use rule "GenerateCode.ag"(line 147, column 47) + _lhsOpatternAttributes = + _patsIpatternAttributes + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIdefinedInsts,_patsIpatternAttributes) = + (pats_ ) + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_ ) = + (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Name, Name)]) + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIdefinedInsts :: ([Identifier]) + _patsIpatternAttributes :: ([(Name, Name)]) + -- use rule "GenerateCode.ag"(line 140, column 55) + _lhsOdefinedInsts = + _patsIdefinedInsts + -- use rule "GenerateCode.ag"(line 147, column 47) + _lhsOpatternAttributes = + _patsIpatternAttributes + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIdefinedInsts,_patsIpatternAttributes) = + (pats_ ) + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Name, Name)]) + _lhsOcopy :: Pattern + -- use rule "GenerateCode.ag"(line 140, column 55) + _lhsOdefinedInsts = + [] + -- use rule "GenerateCode.ag"(line 147, column 47) + _lhsOpatternAttributes = + [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) +-- Patterns ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + definedInsts : [Identifier] + patternAttributes : [(Name, Name)] + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) +-- semantic domain +newtype T_Patterns = T_Patterns (( Patterns,([Identifier]),([(Name, Name)]))) +data Inh_Patterns = Inh_Patterns {} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,definedInsts_Syn_Patterns :: [Identifier],patternAttributes_Syn_Patterns :: [(Name, Name)]} +wrap_Patterns (T_Patterns sem ) (Inh_Patterns ) = + (let ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes) = + (sem ) + in (Syn_Patterns _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes )) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = + (T_Patterns (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Name, Name)]) + _lhsOcopy :: Patterns + _hdIcopy :: Pattern + _hdIdefinedInsts :: ([Identifier]) + _hdIpatternAttributes :: ([(Name, Name)]) + _tlIcopy :: Patterns + _tlIdefinedInsts :: ([Identifier]) + _tlIpatternAttributes :: ([(Name, Name)]) + -- use rule "GenerateCode.ag"(line 140, column 55) + _lhsOdefinedInsts = + _hdIdefinedInsts ++ _tlIdefinedInsts + -- use rule "GenerateCode.ag"(line 147, column 47) + _lhsOpatternAttributes = + _hdIpatternAttributes ++ _tlIpatternAttributes + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _lhsOcopy = + _copy + ( _hdIcopy,_hdIdefinedInsts,_hdIpatternAttributes) = + (hd_ ) + ( _tlIcopy,_tlIdefinedInsts,_tlIpatternAttributes) = + (tl_ ) + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Name, Name)]) + _lhsOcopy :: Patterns + -- use rule "GenerateCode.ag"(line 140, column 55) + _lhsOdefinedInsts = + [] + -- use rule "GenerateCode.ag"(line 147, column 47) + _lhsOpatternAttributes = + [] + -- self rule + _copy = + [] + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) +-- Sequence ---------------------------------------------------- +{- + visit 0: + inherited attributes: + children : [(Name,Type,Bool)] + con : Constructor + higherOrderChildren : [(Name,Type,Bool)] + inh : Attributes + instVisitNrs : Map Identifier Int + lastExpr : Expr + nr : Int + nt : Nonterminal + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + prefix : String + syn : Attributes + terminals : [Name] + what : String + chained attributes: + declsAbove : [Decl] + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + blockDecls : DeclBlocks + comments : [String] + decls : Decls + definedInsts : [Identifier] + exprs : Exprs + tSigs : [Decl] + tps : [Type] + usedVars : Set String + alternatives: + alternative Cons: + child hd : CRule + child tl : Sequence + alternative Nil: +-} +-- cata +sem_Sequence :: Sequence -> + T_Sequence +sem_Sequence list = + (Prelude.foldr sem_Sequence_Cons sem_Sequence_Nil (Prelude.map sem_CRule list) ) +-- semantic domain +newtype T_Sequence = T_Sequence (([(Name,Type,Bool)]) -> + Constructor -> + ([Decl]) -> + (Seq Error) -> + ([(Name,Type,Bool)]) -> + Attributes -> + (Map Identifier Int) -> + Expr -> + Int -> + Nonterminal -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + ([Name]) -> + String -> + ( Bool,DeclBlocks,([String]),Decls,([Decl]),([Identifier]),(Seq Error),Exprs,([Decl]),([Type]),(Set String))) +data Inh_Sequence = Inh_Sequence {children_Inh_Sequence :: [(Name,Type,Bool)],con_Inh_Sequence :: Constructor,declsAbove_Inh_Sequence :: [Decl],errors_Inh_Sequence :: Seq Error,higherOrderChildren_Inh_Sequence :: [(Name,Type,Bool)],inh_Inh_Sequence :: Attributes,instVisitNrs_Inh_Sequence :: Map Identifier Int,lastExpr_Inh_Sequence :: Expr,nr_Inh_Sequence :: Int,nt_Inh_Sequence :: Nonterminal,o_case_Inh_Sequence :: Bool,o_cata_Inh_Sequence :: Bool,o_costcentre_Inh_Sequence :: Bool,o_data_Inh_Sequence :: Maybe Bool,o_linePragmas_Inh_Sequence :: Bool,o_newtypes_Inh_Sequence :: Bool,o_pretty_Inh_Sequence :: Bool,o_rename_Inh_Sequence :: Bool,o_sem_Inh_Sequence :: Bool,o_sig_Inh_Sequence :: Bool,o_splitsems_Inh_Sequence :: Bool,o_strictwrap_Inh_Sequence :: Bool,o_traces_Inh_Sequence :: Bool,o_unbox_Inh_Sequence :: Bool,prefix_Inh_Sequence :: String,syn_Inh_Sequence :: Attributes,terminals_Inh_Sequence :: [Name],what_Inh_Sequence :: String} +data Syn_Sequence = Syn_Sequence {allTpsFound_Syn_Sequence :: Bool,blockDecls_Syn_Sequence :: DeclBlocks,comments_Syn_Sequence :: [String],decls_Syn_Sequence :: Decls,declsAbove_Syn_Sequence :: [Decl],definedInsts_Syn_Sequence :: [Identifier],errors_Syn_Sequence :: Seq Error,exprs_Syn_Sequence :: Exprs,tSigs_Syn_Sequence :: [Decl],tps_Syn_Sequence :: [Type],usedVars_Syn_Sequence :: Set String} +wrap_Sequence (T_Sequence sem ) (Inh_Sequence _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat ) = + (let ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars) = + (sem _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat ) + in (Syn_Sequence _lhsOallTpsFound _lhsOblockDecls _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOerrors _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars )) +sem_Sequence_Cons :: T_CRule -> + T_Sequence -> + T_Sequence +sem_Sequence_Cons (T_CRule hd_ ) (T_Sequence tl_ ) = + (T_Sequence (\ _lhsIchildren + _lhsIcon + _lhsIdeclsAbove + _lhsIerrors + _lhsIhigherOrderChildren + _lhsIinh + _lhsIinstVisitNrs + _lhsIlastExpr + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwhat -> + (let _lhsOblockDecls :: DeclBlocks + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOdefinedInsts :: ([Identifier]) + _lhsOerrors :: (Seq Error) + _lhsOexprs :: Exprs + _lhsOtSigs :: ([Decl]) + _lhsOtps :: ([Type]) + _lhsOusedVars :: (Set String) + _lhsOdeclsAbove :: ([Decl]) + _hdOchildren :: ([(Name,Type,Bool)]) + _hdOcon :: Constructor + _hdOdeclsAbove :: ([Decl]) + _hdOerrors :: (Seq Error) + _hdOhigherOrderChildren :: ([(Name,Type,Bool)]) + _hdOinh :: Attributes + _hdOinstVisitNrs :: (Map Identifier Int) + _hdOnr :: Int + _hdOnt :: Nonterminal + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_costcentre :: Bool + _hdOo_data :: (Maybe Bool) + _hdOo_linePragmas :: Bool + _hdOo_newtypes :: Bool + _hdOo_pretty :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_splitsems :: Bool + _hdOo_strictwrap :: Bool + _hdOo_traces :: Bool + _hdOo_unbox :: Bool + _hdOprefix :: String + _hdOsyn :: Attributes + _hdOterminals :: ([Name]) + _hdOwhat :: String + _tlOchildren :: ([(Name,Type,Bool)]) + _tlOcon :: Constructor + _tlOdeclsAbove :: ([Decl]) + _tlOerrors :: (Seq Error) + _tlOhigherOrderChildren :: ([(Name,Type,Bool)]) + _tlOinh :: Attributes + _tlOinstVisitNrs :: (Map Identifier Int) + _tlOlastExpr :: Expr + _tlOnr :: Int + _tlOnt :: Nonterminal + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_costcentre :: Bool + _tlOo_data :: (Maybe Bool) + _tlOo_linePragmas :: Bool + _tlOo_newtypes :: Bool + _tlOo_pretty :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_splitsems :: Bool + _tlOo_strictwrap :: Bool + _tlOo_traces :: Bool + _tlOo_unbox :: Bool + _tlOprefix :: String + _tlOsyn :: Attributes + _tlOterminals :: ([Name]) + _tlOwhat :: String + _hdIallTpsFound :: Bool + _hdIbldBlocksFun :: (DeclBlocks -> DeclBlocks) + _hdIcomments :: ([String]) + _hdIdecls :: Decls + _hdIdeclsAbove :: ([Decl]) + _hdIdefinedInsts :: ([Identifier]) + _hdIerrors :: (Seq Error) + _hdIexprs :: Exprs + _hdItSigs :: ([Decl]) + _hdItps :: ([Type]) + _hdIusedVars :: (Set String) + _tlIallTpsFound :: Bool + _tlIblockDecls :: DeclBlocks + _tlIcomments :: ([String]) + _tlIdecls :: Decls + _tlIdeclsAbove :: ([Decl]) + _tlIdefinedInsts :: ([Identifier]) + _tlIerrors :: (Seq Error) + _tlIexprs :: Exprs + _tlItSigs :: ([Decl]) + _tlItps :: ([Type]) + _tlIusedVars :: (Set String) + -- "GenerateCode.ag"(line 375, column 7) + _lhsOblockDecls = + _hdIbldBlocksFun _tlIblockDecls + -- use rule "GenerateCode.ag"(line 265, column 39) + _lhsOallTpsFound = + _hdIallTpsFound && _tlIallTpsFound + -- use rule "GenerateCode.ag"(line 583, column 52) + _lhsOcomments = + _hdIcomments ++ _tlIcomments + -- use rule "GenerateCode.ag"(line 87, column 34) + _lhsOdecls = + _hdIdecls ++ _tlIdecls + -- use rule "GenerateCode.ag"(line 140, column 55) + _lhsOdefinedInsts = + _hdIdefinedInsts ++ _tlIdefinedInsts + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "GenerateCode.ag"(line 213, column 34) + _lhsOexprs = + _hdIexprs ++ _tlIexprs + -- use rule "GenerateCode.ag"(line 238, column 33) + _lhsOtSigs = + _hdItSigs ++ _tlItSigs + -- use rule "GenerateCode.ag"(line 264, column 31) + _lhsOtps = + _hdItps ++ _tlItps + -- use rule "GenerateCode.ag"(line 227, column 37) + _lhsOusedVars = + _hdIusedVars `Set.union` _tlIusedVars + -- copy rule (up) + _lhsOdeclsAbove = + _tlIdeclsAbove + -- copy rule (down) + _hdOchildren = + _lhsIchildren + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOdeclsAbove = + _lhsIdeclsAbove + -- copy rule (down) + _hdOerrors = + _lhsIerrors + -- copy rule (down) + _hdOhigherOrderChildren = + _lhsIhigherOrderChildren + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _hdOnr = + _lhsInr + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _hdOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _hdOo_traces = + _lhsIo_traces + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOterminals = + _lhsIterminals + -- copy rule (down) + _hdOwhat = + _lhsIwhat + -- copy rule (down) + _tlOchildren = + _lhsIchildren + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (chain) + _tlOdeclsAbove = + _hdIdeclsAbove + -- copy rule (chain) + _tlOerrors = + _hdIerrors + -- copy rule (down) + _tlOhigherOrderChildren = + _lhsIhigherOrderChildren + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _tlOlastExpr = + _lhsIlastExpr + -- copy rule (down) + _tlOnr = + _lhsInr + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _tlOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _tlOo_traces = + _lhsIo_traces + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (down) + _tlOterminals = + _lhsIterminals + -- copy rule (down) + _tlOwhat = + _lhsIwhat + ( _hdIallTpsFound,_hdIbldBlocksFun,_hdIcomments,_hdIdecls,_hdIdeclsAbove,_hdIdefinedInsts,_hdIerrors,_hdIexprs,_hdItSigs,_hdItps,_hdIusedVars) = + (hd_ _hdOchildren _hdOcon _hdOdeclsAbove _hdOerrors _hdOhigherOrderChildren _hdOinh _hdOinstVisitNrs _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOprefix _hdOsyn _hdOterminals _hdOwhat ) + ( _tlIallTpsFound,_tlIblockDecls,_tlIcomments,_tlIdecls,_tlIdeclsAbove,_tlIdefinedInsts,_tlIerrors,_tlIexprs,_tlItSigs,_tlItps,_tlIusedVars) = + (tl_ _tlOchildren _tlOcon _tlOdeclsAbove _tlOerrors _tlOhigherOrderChildren _tlOinh _tlOinstVisitNrs _tlOlastExpr _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOprefix _tlOsyn _tlOterminals _tlOwhat ) + in ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars))) ) +sem_Sequence_Nil :: T_Sequence +sem_Sequence_Nil = + (T_Sequence (\ _lhsIchildren + _lhsIcon + _lhsIdeclsAbove + _lhsIerrors + _lhsIhigherOrderChildren + _lhsIinh + _lhsIinstVisitNrs + _lhsIlastExpr + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwhat -> + (let _lhsOblockDecls :: DeclBlocks + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOdefinedInsts :: ([Identifier]) + _lhsOerrors :: (Seq Error) + _lhsOexprs :: Exprs + _lhsOtSigs :: ([Decl]) + _lhsOtps :: ([Type]) + _lhsOusedVars :: (Set String) + _lhsOdeclsAbove :: ([Decl]) + -- "GenerateCode.ag"(line 377, column 7) + _lhsOblockDecls = + DeclTerminator _lhsIdeclsAbove _lhsIlastExpr + -- use rule "GenerateCode.ag"(line 265, column 39) + _lhsOallTpsFound = + True + -- use rule "GenerateCode.ag"(line 583, column 52) + _lhsOcomments = + [] + -- use rule "GenerateCode.ag"(line 87, column 34) + _lhsOdecls = + [] + -- use rule "GenerateCode.ag"(line 140, column 55) + _lhsOdefinedInsts = + [] + -- use rule "GenerateCode.ag"(line 564, column 32) + _lhsOerrors = + Seq.empty + -- use rule "GenerateCode.ag"(line 213, column 34) + _lhsOexprs = + [] + -- use rule "GenerateCode.ag"(line 238, column 33) + _lhsOtSigs = + [] + -- use rule "GenerateCode.ag"(line 264, column 31) + _lhsOtps = + [] + -- use rule "GenerateCode.ag"(line 227, column 37) + _lhsOusedVars = + Set.empty + -- copy rule (chain) + _lhsOdeclsAbove = + _lhsIdeclsAbove + in ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars))) ) diff --git a/src-derived/HsToken.hs b/src-derived/HsToken.hs new file mode 100644 --- /dev/null +++ b/src-derived/HsToken.hs @@ -0,0 +1,51 @@ + +-- UUAGC 0.9.5 (HsToken.ag) +module HsToken where + +import CommonTypes +import UU.Scanner.Position(Pos) +-- HsToken ----------------------------------------------------- +{- + alternatives: + alternative AGField: + child field : {Name} + child attr : {Name} + child pos : {Pos} + alternative AGLocal: + child var : {Name} + child pos : {Pos} + alternative CharToken: + child value : {String} + child pos : {Pos} + alternative Err: + child mesg : {String} + child pos : {Pos} + alternative HsToken: + child value : {String} + child pos : {Pos} + alternative StrToken: + child value : {String} + child pos : {Pos} +-} +data HsToken = AGField (Name) (Name) (Pos) + | AGLocal (Name) (Pos) + | CharToken (String) (Pos) + | Err (String) (Pos) + | HsToken (String) (Pos) + | StrToken (String) (Pos) +-- HsTokens ---------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : HsToken + child tl : HsTokens + alternative Nil: +-} +type HsTokens = [HsToken] +-- HsTokensRoot ------------------------------------------------ +{- + alternatives: + alternative HsTokensRoot: + child tokens : HsTokens +-} +data HsTokensRoot = HsTokensRoot (HsTokens) diff --git a/src-derived/Interfaces.hs b/src-derived/Interfaces.hs new file mode 100644 --- /dev/null +++ b/src-derived/Interfaces.hs @@ -0,0 +1,48 @@ + +-- UUAGC 0.9.5 (Interfaces.ag) +module Interfaces where + +import CommonTypes +import SequentialTypes +-- IRoot ------------------------------------------------------- +{- + alternatives: + alternative IRoot: + child inters : Interfaces +-} +data IRoot = IRoot (Interfaces) +-- Interface --------------------------------------------------- +{- + alternatives: + alternative Interface: + child nt : {Nonterminal} + child cons : {[Constructor]} + child seg : Segments +-} +data Interface = Interface (Nonterminal) ([Constructor]) (Segments) +-- Interfaces -------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : Interface + child tl : Interfaces + alternative Nil: +-} +type Interfaces = [Interface] +-- Segment ----------------------------------------------------- +{- + alternatives: + alternative Segment: + child inh : {[Vertex]} + child syn : {[Vertex]} +-} +data Segment = Segment ([Vertex]) ([Vertex]) +-- Segments ---------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : Segment + child tl : Segments + alternative Nil: +-} +type Segments = [Segment] diff --git a/src-derived/InterfacesRules.hs b/src-derived/InterfacesRules.hs new file mode 100644 --- /dev/null +++ b/src-derived/InterfacesRules.hs @@ -0,0 +1,1069 @@ + +-- UUAGC 0.9.5 (InterfacesRules.lag) +module InterfacesRules where + +import Interfaces +import SequentialTypes +import CodeSyntax +import GrammarInfo + +import UU.DData.Seq as Seq +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Set as Set +import Data.Set(Set) +import Data.Tree(Tree(Node)) +import Data.Graph(Graph, dfs, edges, buildG, transposeG) +import Data.Maybe (fromJust) +import Data.List (partition,transpose,(\\),nub,intersect) +import Data.Array ((!),inRange,bounds,assocs) + +import Debug.Trace(trace) + +import CommonTypes +import SequentialTypes + +type VisitSS = [Vertex] + +gather :: Info -> [Vertex] -> [[Vertex]] +gather info = eqClasses comp + where comp a b = isEqualField (ruleTable info ! a) (ruleTable info ! b) + +-- Only non-empty syn will ever be forced, because visits with empty syn are never performed +-- Right hand side synthesized attributes always have a field +cv :: (Vertex -> CRule) -> Int -> Vertex -> ([Vertex],[Vertex]) -> (Vertex,ChildVisit) +cv look n v (inh,syn) = let fld = getField (look (head syn)) + rnt = fromJust (getRhsNt (look (head syn))) + d = ChildVisit fld rnt n inh syn + in (v,d) + +ed v (inh,syn) = map (\i -> (i,v)) inh ++ map (\s -> (v,s)) syn + +postorder (Node a ts) = postorderF ts ++ [a] +postorderF = concatMap postorder +postOrd g = postorderF . dfs g +topSort' g = postOrd g + +type IntraVisit = [Vertex] + +swap (a,b) = (b,a) + +ccv :: Name -> Nonterminal -> Int -> CInterfaceMap -> CRule +ccv name nt n table + = CChildVisit name nt n inh syn last + where CInterface segs = Map.findWithDefault (error ("InterfacesRules::ccv::interfaces not in table for nt: " ++ show nt)) nt table + (seg:remain) = drop n segs + CSegment inh syn = seg + last = null remain +-- IRoot ------------------------------------------------------- +{- + visit 0: + inherited attributes: + dpr : [Edge] + info : Info + tdp : Graph + synthesized attributes: + edp : [Edge] + inters : CInterfaceMap + visits : CVisitsMap + alternatives: + alternative IRoot: + child inters : Interfaces + visit 0: + local newedges : _ + local visitssGraph : _ + local descr : _ +-} +-- cata +sem_IRoot :: IRoot -> + T_IRoot +sem_IRoot (IRoot _inters ) = + (sem_IRoot_IRoot (sem_Interfaces _inters ) ) +-- semantic domain +newtype T_IRoot = T_IRoot (([Edge]) -> + Info -> + Graph -> + ( ([Edge]),CInterfaceMap,CVisitsMap)) +data Inh_IRoot = Inh_IRoot {dpr_Inh_IRoot :: [Edge],info_Inh_IRoot :: Info,tdp_Inh_IRoot :: Graph} +data Syn_IRoot = Syn_IRoot {edp_Syn_IRoot :: [Edge],inters_Syn_IRoot :: CInterfaceMap,visits_Syn_IRoot :: CVisitsMap} +wrap_IRoot (T_IRoot sem ) (Inh_IRoot _lhsIdpr _lhsIinfo _lhsItdp ) = + (let ( _lhsOedp,_lhsOinters,_lhsOvisits) = + (sem _lhsIdpr _lhsIinfo _lhsItdp ) + in (Syn_IRoot _lhsOedp _lhsOinters _lhsOvisits )) +sem_IRoot_IRoot :: T_Interfaces -> + T_IRoot +sem_IRoot_IRoot (T_Interfaces inters_ ) = + (T_IRoot (\ _lhsIdpr + _lhsIinfo + _lhsItdp -> + (let _intersOv :: Vertex + _intersOvisitDescr :: (Map Vertex ChildVisit) + _intersOvssGraph :: Graph + _intersOprev :: ([Vertex]) + _intersOddp :: Graph + _intersOallInters :: CInterfaceMap + _lhsOedp :: ([Edge]) + _lhsOinters :: CInterfaceMap + _lhsOvisits :: CVisitsMap + _intersOinfo :: Info + _intersIdescr :: (Seq (Vertex,ChildVisit)) + _intersIedp :: (Seq Edge) + _intersIfirstvisitvertices :: ([Vertex]) + _intersIinters :: CInterfaceMap + _intersInewedges :: (Seq Edge ) + _intersIv :: Vertex + _intersIvisits :: CVisitsMap + -- "InterfacesRules.lag"(line 64, column 12) + _newedges = + Seq.toList _intersInewedges + -- "InterfacesRules.lag"(line 65, column 12) + _visitssGraph = + let graph = buildG (0,_intersIv-1) es + es = _newedges ++ edges _lhsItdp + in transposeG graph + -- "InterfacesRules.lag"(line 78, column 12) + _intersOv = + snd (bounds _lhsItdp) + 1 + -- "InterfacesRules.lag"(line 115, column 13) + _intersOvisitDescr = + Map.fromList _descr + -- "InterfacesRules.lag"(line 135, column 12) + _descr = + Seq.toList _intersIdescr + -- "InterfacesRules.lag"(line 204, column 12) + _intersOvssGraph = + _visitssGraph + -- "InterfacesRules.lag"(line 246, column 12) + _intersOprev = + let terminals = [ v | (v,cr) <- assocs (ruleTable _lhsIinfo), not (getHasCode cr), isLocal cr ] + in _intersIfirstvisitvertices ++ terminals + -- "InterfacesRules.lag"(line 325, column 12) + _intersOddp = + buildG (0,_intersIv-1) (map swap (_lhsIdpr ++ _newedges)) + -- "InterfacesRules.lag"(line 362, column 13) + _intersOallInters = + _intersIinters + -- "InterfacesRules.lag"(line 422, column 13) + _lhsOedp = + Seq.toList _intersIedp + -- copy rule (up) + _lhsOinters = + _intersIinters + -- copy rule (up) + _lhsOvisits = + _intersIvisits + -- copy rule (down) + _intersOinfo = + _lhsIinfo + ( _intersIdescr,_intersIedp,_intersIfirstvisitvertices,_intersIinters,_intersInewedges,_intersIv,_intersIvisits) = + (inters_ _intersOallInters _intersOddp _intersOinfo _intersOprev _intersOv _intersOvisitDescr _intersOvssGraph ) + in ( _lhsOedp,_lhsOinters,_lhsOvisits))) ) +-- Interface --------------------------------------------------- +{- + visit 0: + inherited attributes: + allInters : CInterfaceMap + ddp : Graph + info : Info + prev : [Vertex] + visitDescr : Map Vertex ChildVisit + vssGraph : Graph + chained attribute: + v : Vertex + synthesized attributes: + descr : Seq (Vertex,ChildVisit) + edp : Seq Edge + firstvisitvertices : [Vertex] + inter : CInterface + newedges : Seq Edge + nt : Nonterminal + visits : Map Constructor CVisits + alternatives: + alternative Interface: + child nt : {Nonterminal} + child cons : {[Constructor]} + child seg : Segments + visit 0: + local v : _ + local firstvisitvertices : _ + local newedges : _ + local look : _ + local descr : _ +-} +-- cata +sem_Interface :: Interface -> + T_Interface +sem_Interface (Interface _nt _cons _seg ) = + (sem_Interface_Interface _nt _cons (sem_Segments _seg ) ) +-- semantic domain +newtype T_Interface = T_Interface (CInterfaceMap -> + Graph -> + Info -> + ([Vertex]) -> + Vertex -> + (Map Vertex ChildVisit) -> + Graph -> + ( (Seq (Vertex,ChildVisit)),(Seq Edge),([Vertex]),CInterface,(Seq Edge ),Nonterminal,Vertex,(Map Constructor CVisits))) +data Inh_Interface = Inh_Interface {allInters_Inh_Interface :: CInterfaceMap,ddp_Inh_Interface :: Graph,info_Inh_Interface :: Info,prev_Inh_Interface :: [Vertex],v_Inh_Interface :: Vertex,visitDescr_Inh_Interface :: Map Vertex ChildVisit,vssGraph_Inh_Interface :: Graph} +data Syn_Interface = Syn_Interface {descr_Syn_Interface :: Seq (Vertex,ChildVisit),edp_Syn_Interface :: Seq Edge,firstvisitvertices_Syn_Interface :: [Vertex],inter_Syn_Interface :: CInterface,newedges_Syn_Interface :: Seq Edge ,nt_Syn_Interface :: Nonterminal,v_Syn_Interface :: Vertex,visits_Syn_Interface :: Map Constructor CVisits} +wrap_Interface (T_Interface sem ) (Inh_Interface _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) = + (let ( _lhsOdescr,_lhsOedp,_lhsOfirstvisitvertices,_lhsOinter,_lhsOnewedges,_lhsOnt,_lhsOv,_lhsOvisits) = + (sem _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) + in (Syn_Interface _lhsOdescr _lhsOedp _lhsOfirstvisitvertices _lhsOinter _lhsOnewedges _lhsOnt _lhsOv _lhsOvisits )) +sem_Interface_Interface :: Nonterminal -> + ([Constructor]) -> + T_Segments -> + T_Interface +sem_Interface_Interface nt_ cons_ (T_Segments seg_ ) = + (T_Interface (\ _lhsIallInters + _lhsIddp + _lhsIinfo + _lhsIprev + _lhsIv + _lhsIvisitDescr + _lhsIvssGraph -> + (let _segOv :: Vertex + _lhsOv :: Vertex + _lhsOnewedges :: (Seq Edge ) + _lhsOdescr :: (Seq (Vertex,ChildVisit)) + _segOn :: Int + _segOcons :: ([Constructor]) + _segOisFirst :: Bool + _segOfromLhs :: ([Vertex]) + _lhsOnt :: Nonterminal + _lhsOinter :: CInterface + _lhsOvisits :: (Map Constructor CVisits) + _lhsOedp :: (Seq Edge) + _lhsOfirstvisitvertices :: ([Vertex]) + _segOallInters :: CInterfaceMap + _segOddp :: Graph + _segOinfo :: Info + _segOprev :: ([Vertex]) + _segOvisitDescr :: (Map Vertex ChildVisit) + _segOvssGraph :: Graph + _segIcvisits :: ([[CVisit]]) + _segIdescr :: (Seq (Vertex,ChildVisit)) + _segIedp :: (Seq Edge) + _segIfirstInh :: ([Vertex]) + _segIgroups :: ([([Vertex],[Vertex])]) + _segIhdIntravisits :: ([IntraVisit]) + _segInewedges :: (Seq Edge ) + _segInewvertices :: ([Vertex]) + _segIprev :: ([Vertex]) + _segIsegs :: CSegments + _segIv :: Vertex + -- "InterfacesRules.lag"(line 175, column 17) + _segOv = + _lhsIv + -- "InterfacesRules.lag"(line 176, column 17) + _v = + _segIv + length _segInewvertices + -- "InterfacesRules.lag"(line 177, column 17) + _lhsOv = + _v + -- "InterfacesRules.lag"(line 178, column 17) + _firstvisitvertices = + [_segIv .. _v-1] + -- "InterfacesRules.lag"(line 179, column 17) + _newedges = + zip _firstvisitvertices _segInewvertices + -- "InterfacesRules.lag"(line 180, column 17) + _lhsOnewedges = + _segInewedges Seq.<> Seq.fromList _newedges + -- "InterfacesRules.lag"(line 181, column 17) + _look = + \a -> ruleTable _lhsIinfo ! a + -- "InterfacesRules.lag"(line 182, column 17) + _descr = + zipWith (cv _look (-1)) _firstvisitvertices _segIgroups + -- "InterfacesRules.lag"(line 183, column 17) + _lhsOdescr = + _segIdescr Seq.<> Seq.fromList _descr + -- "InterfacesRules.lag"(line 191, column 16) + _segOn = + 0 + -- "InterfacesRules.lag"(line 223, column 16) + _segOcons = + cons_ + -- "InterfacesRules.lag"(line 296, column 16) + _segOisFirst = + True + -- "InterfacesRules.lag"(line 333, column 16) + _segOfromLhs = + _lhsIprev + -- "InterfacesRules.lag"(line 373, column 16) + _lhsOnt = + nt_ + -- "InterfacesRules.lag"(line 377, column 17) + _lhsOinter = + CInterface _segIsegs + -- "InterfacesRules.lag"(line 378, column 17) + _lhsOvisits = + Map.fromList (zip cons_ (transpose _segIcvisits)) + -- use rule "InterfacesRules.lag"(line 417, column 54) + _lhsOedp = + _segIedp + -- use rule "InterfacesRules.lag"(line 244, column 70) + _lhsOfirstvisitvertices = + _firstvisitvertices + -- copy rule (down) + _segOallInters = + _lhsIallInters + -- copy rule (down) + _segOddp = + _lhsIddp + -- copy rule (down) + _segOinfo = + _lhsIinfo + -- copy rule (down) + _segOprev = + _lhsIprev + -- copy rule (down) + _segOvisitDescr = + _lhsIvisitDescr + -- copy rule (down) + _segOvssGraph = + _lhsIvssGraph + ( _segIcvisits,_segIdescr,_segIedp,_segIfirstInh,_segIgroups,_segIhdIntravisits,_segInewedges,_segInewvertices,_segIprev,_segIsegs,_segIv) = + (seg_ _segOallInters _segOcons _segOddp _segOfromLhs _segOinfo _segOisFirst _segOn _segOprev _segOv _segOvisitDescr _segOvssGraph ) + in ( _lhsOdescr,_lhsOedp,_lhsOfirstvisitvertices,_lhsOinter,_lhsOnewedges,_lhsOnt,_lhsOv,_lhsOvisits))) ) +-- Interfaces -------------------------------------------------- +{- + visit 0: + inherited attributes: + allInters : CInterfaceMap + ddp : Graph + info : Info + prev : [Vertex] + visitDescr : Map Vertex ChildVisit + vssGraph : Graph + chained attribute: + v : Vertex + synthesized attributes: + descr : Seq (Vertex,ChildVisit) + edp : Seq Edge + firstvisitvertices : [Vertex] + inters : CInterfaceMap + newedges : Seq Edge + visits : CVisitsMap + alternatives: + alternative Cons: + child hd : Interface + child tl : Interfaces + alternative Nil: +-} +-- cata +sem_Interfaces :: Interfaces -> + T_Interfaces +sem_Interfaces list = + (Prelude.foldr sem_Interfaces_Cons sem_Interfaces_Nil (Prelude.map sem_Interface list) ) +-- semantic domain +newtype T_Interfaces = T_Interfaces (CInterfaceMap -> + Graph -> + Info -> + ([Vertex]) -> + Vertex -> + (Map Vertex ChildVisit) -> + Graph -> + ( (Seq (Vertex,ChildVisit)),(Seq Edge),([Vertex]),CInterfaceMap,(Seq Edge ),Vertex,CVisitsMap)) +data Inh_Interfaces = Inh_Interfaces {allInters_Inh_Interfaces :: CInterfaceMap,ddp_Inh_Interfaces :: Graph,info_Inh_Interfaces :: Info,prev_Inh_Interfaces :: [Vertex],v_Inh_Interfaces :: Vertex,visitDescr_Inh_Interfaces :: Map Vertex ChildVisit,vssGraph_Inh_Interfaces :: Graph} +data Syn_Interfaces = Syn_Interfaces {descr_Syn_Interfaces :: Seq (Vertex,ChildVisit),edp_Syn_Interfaces :: Seq Edge,firstvisitvertices_Syn_Interfaces :: [Vertex],inters_Syn_Interfaces :: CInterfaceMap,newedges_Syn_Interfaces :: Seq Edge ,v_Syn_Interfaces :: Vertex,visits_Syn_Interfaces :: CVisitsMap} +wrap_Interfaces (T_Interfaces sem ) (Inh_Interfaces _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) = + (let ( _lhsOdescr,_lhsOedp,_lhsOfirstvisitvertices,_lhsOinters,_lhsOnewedges,_lhsOv,_lhsOvisits) = + (sem _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) + in (Syn_Interfaces _lhsOdescr _lhsOedp _lhsOfirstvisitvertices _lhsOinters _lhsOnewedges _lhsOv _lhsOvisits )) +sem_Interfaces_Cons :: T_Interface -> + T_Interfaces -> + T_Interfaces +sem_Interfaces_Cons (T_Interface hd_ ) (T_Interfaces tl_ ) = + (T_Interfaces (\ _lhsIallInters + _lhsIddp + _lhsIinfo + _lhsIprev + _lhsIv + _lhsIvisitDescr + _lhsIvssGraph -> + (let _lhsOinters :: CInterfaceMap + _lhsOvisits :: CVisitsMap + _lhsOdescr :: (Seq (Vertex,ChildVisit)) + _lhsOedp :: (Seq Edge) + _lhsOfirstvisitvertices :: ([Vertex]) + _lhsOnewedges :: (Seq Edge ) + _lhsOv :: Vertex + _hdOallInters :: CInterfaceMap + _hdOddp :: Graph + _hdOinfo :: Info + _hdOprev :: ([Vertex]) + _hdOv :: Vertex + _hdOvisitDescr :: (Map Vertex ChildVisit) + _hdOvssGraph :: Graph + _tlOallInters :: CInterfaceMap + _tlOddp :: Graph + _tlOinfo :: Info + _tlOprev :: ([Vertex]) + _tlOv :: Vertex + _tlOvisitDescr :: (Map Vertex ChildVisit) + _tlOvssGraph :: Graph + _hdIdescr :: (Seq (Vertex,ChildVisit)) + _hdIedp :: (Seq Edge) + _hdIfirstvisitvertices :: ([Vertex]) + _hdIinter :: CInterface + _hdInewedges :: (Seq Edge ) + _hdInt :: Nonterminal + _hdIv :: Vertex + _hdIvisits :: (Map Constructor CVisits) + _tlIdescr :: (Seq (Vertex,ChildVisit)) + _tlIedp :: (Seq Edge) + _tlIfirstvisitvertices :: ([Vertex]) + _tlIinters :: CInterfaceMap + _tlInewedges :: (Seq Edge ) + _tlIv :: Vertex + _tlIvisits :: CVisitsMap + -- "InterfacesRules.lag"(line 367, column 12) + _lhsOinters = + Map.insert _hdInt _hdIinter _tlIinters + -- "InterfacesRules.lag"(line 368, column 12) + _lhsOvisits = + Map.insert _hdInt _hdIvisits _tlIvisits + -- use rule "InterfacesRules.lag"(line 118, column 20) + _lhsOdescr = + _hdIdescr Seq.<> _tlIdescr + -- use rule "InterfacesRules.lag"(line 417, column 54) + _lhsOedp = + _hdIedp Seq.<> _tlIedp + -- use rule "InterfacesRules.lag"(line 244, column 70) + _lhsOfirstvisitvertices = + _hdIfirstvisitvertices ++ _tlIfirstvisitvertices + -- use rule "InterfacesRules.lag"(line 117, column 23) + _lhsOnewedges = + _hdInewedges Seq.<> _tlInewedges + -- copy rule (up) + _lhsOv = + _tlIv + -- copy rule (down) + _hdOallInters = + _lhsIallInters + -- copy rule (down) + _hdOddp = + _lhsIddp + -- copy rule (down) + _hdOinfo = + _lhsIinfo + -- copy rule (down) + _hdOprev = + _lhsIprev + -- copy rule (down) + _hdOv = + _lhsIv + -- copy rule (down) + _hdOvisitDescr = + _lhsIvisitDescr + -- copy rule (down) + _hdOvssGraph = + _lhsIvssGraph + -- copy rule (down) + _tlOallInters = + _lhsIallInters + -- copy rule (down) + _tlOddp = + _lhsIddp + -- copy rule (down) + _tlOinfo = + _lhsIinfo + -- copy rule (down) + _tlOprev = + _lhsIprev + -- copy rule (chain) + _tlOv = + _hdIv + -- copy rule (down) + _tlOvisitDescr = + _lhsIvisitDescr + -- copy rule (down) + _tlOvssGraph = + _lhsIvssGraph + ( _hdIdescr,_hdIedp,_hdIfirstvisitvertices,_hdIinter,_hdInewedges,_hdInt,_hdIv,_hdIvisits) = + (hd_ _hdOallInters _hdOddp _hdOinfo _hdOprev _hdOv _hdOvisitDescr _hdOvssGraph ) + ( _tlIdescr,_tlIedp,_tlIfirstvisitvertices,_tlIinters,_tlInewedges,_tlIv,_tlIvisits) = + (tl_ _tlOallInters _tlOddp _tlOinfo _tlOprev _tlOv _tlOvisitDescr _tlOvssGraph ) + in ( _lhsOdescr,_lhsOedp,_lhsOfirstvisitvertices,_lhsOinters,_lhsOnewedges,_lhsOv,_lhsOvisits))) ) +sem_Interfaces_Nil :: T_Interfaces +sem_Interfaces_Nil = + (T_Interfaces (\ _lhsIallInters + _lhsIddp + _lhsIinfo + _lhsIprev + _lhsIv + _lhsIvisitDescr + _lhsIvssGraph -> + (let _lhsOinters :: CInterfaceMap + _lhsOvisits :: CVisitsMap + _lhsOdescr :: (Seq (Vertex,ChildVisit)) + _lhsOedp :: (Seq Edge) + _lhsOfirstvisitvertices :: ([Vertex]) + _lhsOnewedges :: (Seq Edge ) + _lhsOv :: Vertex + -- "InterfacesRules.lag"(line 369, column 12) + _lhsOinters = + Map.empty + -- "InterfacesRules.lag"(line 370, column 12) + _lhsOvisits = + Map.empty + -- use rule "InterfacesRules.lag"(line 118, column 20) + _lhsOdescr = + Seq.empty + -- use rule "InterfacesRules.lag"(line 417, column 54) + _lhsOedp = + Seq.empty + -- use rule "InterfacesRules.lag"(line 244, column 70) + _lhsOfirstvisitvertices = + [] + -- use rule "InterfacesRules.lag"(line 117, column 23) + _lhsOnewedges = + Seq.empty + -- copy rule (chain) + _lhsOv = + _lhsIv + in ( _lhsOdescr,_lhsOedp,_lhsOfirstvisitvertices,_lhsOinters,_lhsOnewedges,_lhsOv,_lhsOvisits))) ) +-- Segment ----------------------------------------------------- +{- + visit 0: + inherited attributes: + allInters : CInterfaceMap + cons : [Constructor] + ddp : Graph + fromLhs : [Vertex] + info : Info + isFirst : Bool + n : Int + nextInh : [Vertex] + nextIntravisits : [IntraVisit] + nextNewvertices : [Vertex] + visitDescr : Map Vertex ChildVisit + vssGraph : Graph + chained attributes: + prev : [Vertex] + v : Vertex + synthesized attributes: + cvisits : [CVisit] + descr : Seq (Vertex,ChildVisit) + edp : Seq Edge + groups : [([Vertex],[Vertex])] + inh : [Vertex] + intravisits : [IntraVisit] + newedges : Seq Edge + newvertices : [Vertex] + seg : CSegment + visitss : [VisitSS] + alternatives: + alternative Segment: + child inh : {[Vertex]} + child syn : {[Vertex]} + visit 0: + local look : _ + local occurAs : _ + local groups : _ + local v : _ + local newvertices : _ + local attredges : _ + local visitedges : _ + local synOccur : _ + local vss : _ + local visitss' : _ + local defined : _ + local visitss : _ + local fromLhs : _ + local computed : _ + local intravisits : _ + local iv : _ + local _tup1 : _ + local inhmap : _ + local synmap : _ +-} +-- cata +sem_Segment :: Segment -> + T_Segment +sem_Segment (Segment _inh _syn ) = + (sem_Segment_Segment _inh _syn ) +-- semantic domain +newtype T_Segment = T_Segment (CInterfaceMap -> + ([Constructor]) -> + Graph -> + ([Vertex]) -> + Info -> + Bool -> + Int -> + ([Vertex]) -> + ([IntraVisit]) -> + ([Vertex]) -> + ([Vertex]) -> + Vertex -> + (Map Vertex ChildVisit) -> + Graph -> + ( ([CVisit]),(Seq (Vertex,ChildVisit)),(Seq Edge),([([Vertex],[Vertex])]),([Vertex]),([IntraVisit]),(Seq Edge ),([Vertex]),([Vertex]),CSegment,Vertex,([VisitSS]))) +data Inh_Segment = Inh_Segment {allInters_Inh_Segment :: CInterfaceMap,cons_Inh_Segment :: [Constructor],ddp_Inh_Segment :: Graph,fromLhs_Inh_Segment :: [Vertex],info_Inh_Segment :: Info,isFirst_Inh_Segment :: Bool,n_Inh_Segment :: Int,nextInh_Inh_Segment :: [Vertex],nextIntravisits_Inh_Segment :: [IntraVisit],nextNewvertices_Inh_Segment :: [Vertex],prev_Inh_Segment :: [Vertex],v_Inh_Segment :: Vertex,visitDescr_Inh_Segment :: Map Vertex ChildVisit,vssGraph_Inh_Segment :: Graph} +data Syn_Segment = Syn_Segment {cvisits_Syn_Segment :: [CVisit],descr_Syn_Segment :: Seq (Vertex,ChildVisit),edp_Syn_Segment :: Seq Edge,groups_Syn_Segment :: [([Vertex],[Vertex])],inh_Syn_Segment :: [Vertex],intravisits_Syn_Segment :: [IntraVisit],newedges_Syn_Segment :: Seq Edge ,newvertices_Syn_Segment :: [Vertex],prev_Syn_Segment :: [Vertex],seg_Syn_Segment :: CSegment,v_Syn_Segment :: Vertex,visitss_Syn_Segment :: [VisitSS]} +wrap_Segment (T_Segment sem ) (Inh_Segment _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsInextInh _lhsInextIntravisits _lhsInextNewvertices _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) = + (let ( _lhsOcvisits,_lhsOdescr,_lhsOedp,_lhsOgroups,_lhsOinh,_lhsOintravisits,_lhsOnewedges,_lhsOnewvertices,_lhsOprev,_lhsOseg,_lhsOv,_lhsOvisitss) = + (sem _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsInextInh _lhsInextIntravisits _lhsInextNewvertices _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) + in (Syn_Segment _lhsOcvisits _lhsOdescr _lhsOedp _lhsOgroups _lhsOinh _lhsOintravisits _lhsOnewedges _lhsOnewvertices _lhsOprev _lhsOseg _lhsOv _lhsOvisitss )) +sem_Segment_Segment :: ([Vertex]) -> + ([Vertex]) -> + T_Segment +sem_Segment_Segment inh_ syn_ = + (T_Segment (\ _lhsIallInters + _lhsIcons + _lhsIddp + _lhsIfromLhs + _lhsIinfo + _lhsIisFirst + _lhsIn + _lhsInextInh + _lhsInextIntravisits + _lhsInextNewvertices + _lhsIprev + _lhsIv + _lhsIvisitDescr + _lhsIvssGraph -> + (let _lhsOdescr :: (Seq (Vertex,ChildVisit)) + _lhsOnewedges :: (Seq Edge ) + _lhsOprev :: ([Vertex]) + _lhsOseg :: CSegment + _lhsOcvisits :: ([CVisit]) + _lhsOedp :: (Seq Edge) + _lhsOinh :: ([Vertex]) + _lhsOgroups :: ([([Vertex],[Vertex])]) + _lhsOintravisits :: ([IntraVisit]) + _lhsOnewvertices :: ([Vertex]) + _lhsOv :: Vertex + _lhsOvisitss :: ([VisitSS]) + -- "InterfacesRules.lag"(line 98, column 15) + _look = + \a -> ruleTable _lhsIinfo ! a + -- "InterfacesRules.lag"(line 99, column 15) + _occurAs = + \p us -> [ a | u <- us + , a <- tdsToTdp _lhsIinfo ! u + , p (_look a)] + -- "InterfacesRules.lag"(line 102, column 15) + _groups = + let group as = gather _lhsIinfo (_occurAs isRhs as) + in map (partition (isInh . _look)) (group (inh_ ++ syn_)) + -- "InterfacesRules.lag"(line 104, column 15) + _v = + _lhsIv + length _groups + -- "InterfacesRules.lag"(line 105, column 15) + _newvertices = + [_lhsIv .. _v -1] + -- "InterfacesRules.lag"(line 120, column 14) + _lhsOdescr = + Seq.fromList $ zipWith (cv _look _lhsIn) _newvertices _groups + -- "InterfacesRules.lag"(line 143, column 14) + _attredges = + concat (zipWith ed _newvertices _groups) + -- "InterfacesRules.lag"(line 162, column 15) + _visitedges = + zip _newvertices _lhsInextNewvertices + -- "InterfacesRules.lag"(line 163, column 15) + _lhsOnewedges = + Seq.fromList _attredges Seq.<> Seq.fromList _visitedges + -- "InterfacesRules.lag"(line 215, column 15) + _synOccur = + gather _lhsIinfo (_occurAs isLhs syn_) + -- "InterfacesRules.lag"(line 216, column 15) + _vss = + let hasCode v | inRange (bounds (ruleTable _lhsIinfo)) v = getHasCode (ruleTable _lhsIinfo ! v) + | otherwise = True + in if null syn_ + then replicate (length _lhsIcons) [] + else map (filter hasCode . topSort' _lhsIvssGraph) _synOccur + -- "InterfacesRules.lag"(line 256, column 15) + _visitss' = + map (\\ _lhsIprev) _vss + -- "InterfacesRules.lag"(line 257, column 15) + _defined = + let defines v = case Map.lookup v _lhsIvisitDescr of + Nothing -> [v] + Just (ChildVisit _ _ _ inh _) -> v:inh + in concatMap (concatMap defines) _visitss + -- "InterfacesRules.lag"(line 261, column 15) + _lhsOprev = + _lhsIprev ++ _defined + -- "InterfacesRules.lag"(line 269, column 15) + _visitss = + let rem :: [(Name,Name,Maybe Type)] -> [Vertex] -> [Vertex] + rem prev [] = [] + rem prev (v:vs) + | inRange (bounds table) v + = let cr = table ! v + addV = if (getField cr,getAttr cr,getType cr) `elem` prev + then id + else (v:) + def = Map.elems (getDefines cr) + in addV (rem (def ++ prev) vs) + | otherwise = v:rem prev vs + table = ruleTable _lhsIinfo + in map (rem []) _visitss' + -- "InterfacesRules.lag"(line 338, column 15) + _fromLhs = + _occurAs isLhs inh_ ++ _lhsIfromLhs + -- "InterfacesRules.lag"(line 339, column 15) + _computed = + let computes v = case Map.lookup v _lhsIvisitDescr of + Nothing -> Map.keys (getDefines (ruleTable _lhsIinfo ! v)) + Just (ChildVisit _ _ _ _ syn) -> v:syn + in concatMap (concatMap computes) _visitss + -- "InterfacesRules.lag"(line 343, column 15) + _intravisits = + zipWith _iv _visitss _lhsInextIntravisits + -- "InterfacesRules.lag"(line 344, column 15) + _iv = + \vs next -> + let needed = concatMap (_lhsIddp !) vs + in nub (needed ++ next) \\ (_fromLhs ++ _computed) + -- "InterfacesRules.lag"(line 387, column 15) + _lhsOseg = + if False then undefined _lhsIvssGraph _lhsIvisitDescr _lhsIprev else CSegment _inhmap _synmap + -- "InterfacesRules.lag"(line 389, column 19) + __tup1 = + let makemap = Map.fromList . map findType + findType v = getNtaNameType (attrTable _lhsIinfo ! v) + in (makemap inh_,makemap syn_) + -- "InterfacesRules.lag"(line 389, column 19) + (_inhmap,_) = + __tup1 + -- "InterfacesRules.lag"(line 389, column 19) + (_,_synmap) = + __tup1 + -- "InterfacesRules.lag"(line 392, column 15) + _lhsOcvisits = + let mkVisit vss intra = CVisit _inhmap _synmap (mkSequence vss) (mkSequence intra) True + mkSequence = map mkRule + mkRule v = case Map.lookup v _lhsIvisitDescr of + Nothing -> ruleTable _lhsIinfo ! v + Just (ChildVisit name nt n _ _) -> ccv name nt n _lhsIallInters + in zipWith mkVisit _visitss _intravisits + -- "InterfacesRules.lag"(line 419, column 14) + _lhsOedp = + Seq.fromList [(i,s) | i <- inh_, s <- syn_] + Seq.<> Seq.fromList [(s,i) | s <- syn_, i <- _lhsInextInh ] + -- "InterfacesRules.lag"(line 424, column 14) + _lhsOinh = + inh_ + -- copy rule (from local) + _lhsOgroups = + _groups + -- copy rule (from local) + _lhsOintravisits = + _intravisits + -- copy rule (from local) + _lhsOnewvertices = + _newvertices + -- copy rule (from local) + _lhsOv = + _v + -- copy rule (from local) + _lhsOvisitss = + _visitss + in ( _lhsOcvisits,_lhsOdescr,_lhsOedp,_lhsOgroups,_lhsOinh,_lhsOintravisits,_lhsOnewedges,_lhsOnewvertices,_lhsOprev,_lhsOseg,_lhsOv,_lhsOvisitss))) ) +-- Segments ---------------------------------------------------- +{- + visit 0: + inherited attributes: + allInters : CInterfaceMap + cons : [Constructor] + ddp : Graph + fromLhs : [Vertex] + info : Info + isFirst : Bool + n : Int + visitDescr : Map Vertex ChildVisit + vssGraph : Graph + chained attributes: + prev : [Vertex] + v : Vertex + synthesized attributes: + cvisits : [[CVisit]] + descr : Seq (Vertex,ChildVisit) + edp : Seq Edge + firstInh : [Vertex] + groups : [([Vertex],[Vertex])] + hdIntravisits : [IntraVisit] + newedges : Seq Edge + newvertices : [Vertex] + segs : CSegments + alternatives: + alternative Cons: + child hd : Segment + child tl : Segments + alternative Nil: +-} +-- cata +sem_Segments :: Segments -> + T_Segments +sem_Segments list = + (Prelude.foldr sem_Segments_Cons sem_Segments_Nil (Prelude.map sem_Segment list) ) +-- semantic domain +newtype T_Segments = T_Segments (CInterfaceMap -> + ([Constructor]) -> + Graph -> + ([Vertex]) -> + Info -> + Bool -> + Int -> + ([Vertex]) -> + Vertex -> + (Map Vertex ChildVisit) -> + Graph -> + ( ([[CVisit]]),(Seq (Vertex,ChildVisit)),(Seq Edge),([Vertex]),([([Vertex],[Vertex])]),([IntraVisit]),(Seq Edge ),([Vertex]),([Vertex]),CSegments,Vertex)) +data Inh_Segments = Inh_Segments {allInters_Inh_Segments :: CInterfaceMap,cons_Inh_Segments :: [Constructor],ddp_Inh_Segments :: Graph,fromLhs_Inh_Segments :: [Vertex],info_Inh_Segments :: Info,isFirst_Inh_Segments :: Bool,n_Inh_Segments :: Int,prev_Inh_Segments :: [Vertex],v_Inh_Segments :: Vertex,visitDescr_Inh_Segments :: Map Vertex ChildVisit,vssGraph_Inh_Segments :: Graph} +data Syn_Segments = Syn_Segments {cvisits_Syn_Segments :: [[CVisit]],descr_Syn_Segments :: Seq (Vertex,ChildVisit),edp_Syn_Segments :: Seq Edge,firstInh_Syn_Segments :: [Vertex],groups_Syn_Segments :: [([Vertex],[Vertex])],hdIntravisits_Syn_Segments :: [IntraVisit],newedges_Syn_Segments :: Seq Edge ,newvertices_Syn_Segments :: [Vertex],prev_Syn_Segments :: [Vertex],segs_Syn_Segments :: CSegments,v_Syn_Segments :: Vertex} +wrap_Segments (T_Segments sem ) (Inh_Segments _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) = + (let ( _lhsOcvisits,_lhsOdescr,_lhsOedp,_lhsOfirstInh,_lhsOgroups,_lhsOhdIntravisits,_lhsOnewedges,_lhsOnewvertices,_lhsOprev,_lhsOsegs,_lhsOv) = + (sem _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) + in (Syn_Segments _lhsOcvisits _lhsOdescr _lhsOedp _lhsOfirstInh _lhsOgroups _lhsOhdIntravisits _lhsOnewedges _lhsOnewvertices _lhsOprev _lhsOsegs _lhsOv )) +sem_Segments_Cons :: T_Segment -> + T_Segments -> + T_Segments +sem_Segments_Cons (T_Segment hd_ ) (T_Segments tl_ ) = + (T_Segments (\ _lhsIallInters + _lhsIcons + _lhsIddp + _lhsIfromLhs + _lhsIinfo + _lhsIisFirst + _lhsIn + _lhsIprev + _lhsIv + _lhsIvisitDescr + _lhsIvssGraph -> + (let _hdOnextNewvertices :: ([Vertex]) + _lhsOnewvertices :: ([Vertex]) + _lhsOgroups :: ([([Vertex],[Vertex])]) + _tlOn :: Int + _tlOisFirst :: Bool + _hdOnextIntravisits :: ([IntraVisit]) + _lhsOhdIntravisits :: ([IntraVisit]) + _hdOfromLhs :: ([Vertex]) + _tlOfromLhs :: ([Vertex]) + _lhsOsegs :: CSegments + _hdOnextInh :: ([Vertex]) + _lhsOfirstInh :: ([Vertex]) + _lhsOcvisits :: ([[CVisit]]) + _lhsOdescr :: (Seq (Vertex,ChildVisit)) + _lhsOedp :: (Seq Edge) + _lhsOnewedges :: (Seq Edge ) + _lhsOprev :: ([Vertex]) + _lhsOv :: Vertex + _hdOallInters :: CInterfaceMap + _hdOcons :: ([Constructor]) + _hdOddp :: Graph + _hdOinfo :: Info + _hdOisFirst :: Bool + _hdOn :: Int + _hdOprev :: ([Vertex]) + _hdOv :: Vertex + _hdOvisitDescr :: (Map Vertex ChildVisit) + _hdOvssGraph :: Graph + _tlOallInters :: CInterfaceMap + _tlOcons :: ([Constructor]) + _tlOddp :: Graph + _tlOinfo :: Info + _tlOprev :: ([Vertex]) + _tlOv :: Vertex + _tlOvisitDescr :: (Map Vertex ChildVisit) + _tlOvssGraph :: Graph + _hdIcvisits :: ([CVisit]) + _hdIdescr :: (Seq (Vertex,ChildVisit)) + _hdIedp :: (Seq Edge) + _hdIgroups :: ([([Vertex],[Vertex])]) + _hdIinh :: ([Vertex]) + _hdIintravisits :: ([IntraVisit]) + _hdInewedges :: (Seq Edge ) + _hdInewvertices :: ([Vertex]) + _hdIprev :: ([Vertex]) + _hdIseg :: CSegment + _hdIv :: Vertex + _hdIvisitss :: ([VisitSS]) + _tlIcvisits :: ([[CVisit]]) + _tlIdescr :: (Seq (Vertex,ChildVisit)) + _tlIedp :: (Seq Edge) + _tlIfirstInh :: ([Vertex]) + _tlIgroups :: ([([Vertex],[Vertex])]) + _tlIhdIntravisits :: ([IntraVisit]) + _tlInewedges :: (Seq Edge ) + _tlInewvertices :: ([Vertex]) + _tlIprev :: ([Vertex]) + _tlIsegs :: CSegments + _tlIv :: Vertex + -- "InterfacesRules.lag"(line 157, column 12) + _hdOnextNewvertices = + _tlInewvertices + -- "InterfacesRules.lag"(line 158, column 12) + _lhsOnewvertices = + _hdInewvertices + -- "InterfacesRules.lag"(line 172, column 11) + _lhsOgroups = + _hdIgroups + -- "InterfacesRules.lag"(line 193, column 11) + _tlOn = + _lhsIn + 1 + -- "InterfacesRules.lag"(line 298, column 11) + _tlOisFirst = + False + -- "InterfacesRules.lag"(line 311, column 12) + _hdOnextIntravisits = + _tlIhdIntravisits + -- "InterfacesRules.lag"(line 312, column 12) + _lhsOhdIntravisits = + _hdIintravisits + -- "InterfacesRules.lag"(line 335, column 12) + _hdOfromLhs = + _lhsIfromLhs + -- "InterfacesRules.lag"(line 336, column 12) + _tlOfromLhs = + [] + -- "InterfacesRules.lag"(line 382, column 12) + _lhsOsegs = + _hdIseg : _tlIsegs + -- "InterfacesRules.lag"(line 426, column 12) + _hdOnextInh = + _tlIfirstInh + -- "InterfacesRules.lag"(line 427, column 12) + _lhsOfirstInh = + _hdIinh + -- use rule "InterfacesRules.lag"(line 381, column 29) + _lhsOcvisits = + _hdIcvisits : _tlIcvisits + -- use rule "InterfacesRules.lag"(line 118, column 20) + _lhsOdescr = + _hdIdescr Seq.<> _tlIdescr + -- use rule "InterfacesRules.lag"(line 417, column 54) + _lhsOedp = + _hdIedp Seq.<> _tlIedp + -- use rule "InterfacesRules.lag"(line 117, column 23) + _lhsOnewedges = + _hdInewedges Seq.<> _tlInewedges + -- copy rule (up) + _lhsOprev = + _tlIprev + -- copy rule (up) + _lhsOv = + _tlIv + -- copy rule (down) + _hdOallInters = + _lhsIallInters + -- copy rule (down) + _hdOcons = + _lhsIcons + -- copy rule (down) + _hdOddp = + _lhsIddp + -- copy rule (down) + _hdOinfo = + _lhsIinfo + -- copy rule (down) + _hdOisFirst = + _lhsIisFirst + -- copy rule (down) + _hdOn = + _lhsIn + -- copy rule (down) + _hdOprev = + _lhsIprev + -- copy rule (down) + _hdOv = + _lhsIv + -- copy rule (down) + _hdOvisitDescr = + _lhsIvisitDescr + -- copy rule (down) + _hdOvssGraph = + _lhsIvssGraph + -- copy rule (down) + _tlOallInters = + _lhsIallInters + -- copy rule (down) + _tlOcons = + _lhsIcons + -- copy rule (down) + _tlOddp = + _lhsIddp + -- copy rule (down) + _tlOinfo = + _lhsIinfo + -- copy rule (chain) + _tlOprev = + _hdIprev + -- copy rule (chain) + _tlOv = + _hdIv + -- copy rule (down) + _tlOvisitDescr = + _lhsIvisitDescr + -- copy rule (down) + _tlOvssGraph = + _lhsIvssGraph + ( _hdIcvisits,_hdIdescr,_hdIedp,_hdIgroups,_hdIinh,_hdIintravisits,_hdInewedges,_hdInewvertices,_hdIprev,_hdIseg,_hdIv,_hdIvisitss) = + (hd_ _hdOallInters _hdOcons _hdOddp _hdOfromLhs _hdOinfo _hdOisFirst _hdOn _hdOnextInh _hdOnextIntravisits _hdOnextNewvertices _hdOprev _hdOv _hdOvisitDescr _hdOvssGraph ) + ( _tlIcvisits,_tlIdescr,_tlIedp,_tlIfirstInh,_tlIgroups,_tlIhdIntravisits,_tlInewedges,_tlInewvertices,_tlIprev,_tlIsegs,_tlIv) = + (tl_ _tlOallInters _tlOcons _tlOddp _tlOfromLhs _tlOinfo _tlOisFirst _tlOn _tlOprev _tlOv _tlOvisitDescr _tlOvssGraph ) + in ( _lhsOcvisits,_lhsOdescr,_lhsOedp,_lhsOfirstInh,_lhsOgroups,_lhsOhdIntravisits,_lhsOnewedges,_lhsOnewvertices,_lhsOprev,_lhsOsegs,_lhsOv))) ) +sem_Segments_Nil :: T_Segments +sem_Segments_Nil = + (T_Segments (\ _lhsIallInters + _lhsIcons + _lhsIddp + _lhsIfromLhs + _lhsIinfo + _lhsIisFirst + _lhsIn + _lhsIprev + _lhsIv + _lhsIvisitDescr + _lhsIvssGraph -> + (let _lhsOnewvertices :: ([Vertex]) + _lhsOgroups :: ([([Vertex],[Vertex])]) + _lhsOhdIntravisits :: ([IntraVisit]) + _lhsOsegs :: CSegments + _lhsOfirstInh :: ([Vertex]) + _lhsOcvisits :: ([[CVisit]]) + _lhsOdescr :: (Seq (Vertex,ChildVisit)) + _lhsOedp :: (Seq Edge) + _lhsOnewedges :: (Seq Edge ) + _lhsOprev :: ([Vertex]) + _lhsOv :: Vertex + -- "InterfacesRules.lag"(line 159, column 12) + _lhsOnewvertices = + [] + -- "InterfacesRules.lag"(line 173, column 11) + _lhsOgroups = + [] + -- "InterfacesRules.lag"(line 313, column 10) + _lhsOhdIntravisits = + repeat [] + -- "InterfacesRules.lag"(line 383, column 12) + _lhsOsegs = + [] + -- "InterfacesRules.lag"(line 428, column 11) + _lhsOfirstInh = + [] + -- use rule "InterfacesRules.lag"(line 381, column 29) + _lhsOcvisits = + [] + -- use rule "InterfacesRules.lag"(line 118, column 20) + _lhsOdescr = + Seq.empty + -- use rule "InterfacesRules.lag"(line 417, column 54) + _lhsOedp = + Seq.empty + -- use rule "InterfacesRules.lag"(line 117, column 23) + _lhsOnewedges = + Seq.empty + -- copy rule (chain) + _lhsOprev = + _lhsIprev + -- copy rule (chain) + _lhsOv = + _lhsIv + in ( _lhsOcvisits,_lhsOdescr,_lhsOedp,_lhsOfirstInh,_lhsOgroups,_lhsOhdIntravisits,_lhsOnewedges,_lhsOnewvertices,_lhsOprev,_lhsOsegs,_lhsOv))) ) diff --git a/src-derived/Order.hs b/src-derived/Order.hs new file mode 100644 --- /dev/null +++ b/src-derived/Order.hs @@ -0,0 +1,3399 @@ + +-- UUAGC 0.9.5 (Order.ag) +module Order where + +-- From uuagc +import CommonTypes +import Patterns +import ErrorMessages +import AbstractSyntax +import Code hiding (Type) +import qualified Code +import Expression +import Options +import SequentialComputation +import SequentialTypes +import CodeSyntax +import GrammarInfo +import HsToken(HsTokensRoot(HsTokensRoot)) +import HsTokenScanner(lexTokens) +import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) +-- From uulib +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified UU.DData.Seq as Seq +import Data.Map(Map) +import Data.Set(Set) +import UU.DData.Seq(Seq, (<>)) +import UU.Util.Utils +import UU.Scanner.Position(Pos(..),initPos) + +-- From haskell libraries +import Control.Monad(liftM) +import qualified Data.Array as Array +import Data.Array((!),bounds,inRange) +import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose) +import qualified Data.Tree as Tree +import Maybe + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (Constructor,Name) + +import UU.Scanner.Position(Pos) + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes + +-- Terminates with an error if the key is not in the map +findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a +findWithErr1 s k + = Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k + +findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a +findWithErr2 k m + = Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m + +getNtName :: Type -> Nonterminal +getNtName (NT nt) = nt +getNtName _ = nullIdent + +data AltAttr = AltAttr Name Name Bool + deriving (Eq, Ord, Show) + +substSelf nt tp = if tp==NT _SELF + then Haskell (getName nt) + else tp + +haskellTupel :: [Type] -> Maybe Type +haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) + +lookupVertices :: Identifier -> Identifier -> Map AltAttr Int -> [Int] +lookupVertices fld nm attrs + = catMaybes ( [Map.lookup (AltAttr fld nm True) attrs] + ++ [Map.lookup (AltAttr fld nm False) attrs] + ) + +swap (a,b) = (b,a) + +showPath :: Table CRule -> [Vertex] -> [String] +showPath ruleTable path + = let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)] + | otherwise = ["Vertex " ++ show a] + showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")" + | otherwise = prettyCRule cr + in concatMap look path + + +showPathLocal :: Table CRule -> [Vertex] -> [String] +showPathLocal _ [] = [] +showPathLocal ruleTable xs = showP (xs++[-1]) + where showP [] = [] + showP (v1:v2:vs) = let line = step v1 v2 + lines = showP vs + in line:lines + step v1 v2 = " - " ++ a1 + where r1 = ruleTable ! v1 + a1 = show (getAttr r1) + + +limitTo :: Int -> [String] -> [String] +limitTo _ [] = [] +limitTo 0 _ = ["....etcetera, etcetera...."] +limitTo n (x:xs) = x : limitTo (n-1) xs + +showPathNice :: Table CRule -> [Vertex] -> [String] +showPathNice _ [] = [] +showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1])) + where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs) + showP [] = [] + showP (v1:v2:vs) = let line = step v1 v2 + lines = showP vs + in if null line then lines else line:lines + step v1 v2 | last && first = induced + | last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced + | first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 + | last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced + | isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 + | isLocal r1 = if head a1 == '_' + then "" + else "calculate " ++ alignR maxf "loc" ++ "." ++ a1 + | otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2 + where + first = v1<0 + last = v2<0 + r1 = ruleTable ! v1 + r2 = ruleTable ! v2 + a1 = show (getAttr r1) + a2 = show (getAttr r2) + f1 = show (getField r1) + f2 = show (getField r2) + n1 = show (getLhsNt r1) + n2 = show (getLhsNt r2) + c1 = show (getCon r1) + c2 = show (getCon r2) + induced | v2== -2 = " INDUCED dependency to " + | otherwise = "" + + +maxWidths ruleTable vs + = map maximum (transpose (map getWidth vs)) + where getWidth v | v<0 = [0,0,0,0] + | otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon] + +alignL n xs | k Bool -> Route -> Error +localCycleErr ruleTable o_visit (s:path) + = let cr = ruleTable ! s + attr = getAttr cr + nt = getLhsNt cr + con = getCon cr + in LocalCirc nt con attr o_visit (showPathLocal ruleTable path) + +instCycleErr :: Table CRule -> Bool -> Route -> Error +instCycleErr ruleTable o_visit (s:path) + = let cr = ruleTable ! s + attr = getAttr cr + nt = getLhsNt cr + con = getCon cr + in InstCirc nt con attr o_visit (showPathLocal ruleTable path) + +directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error] +directCycleErrs attrTable ruleTable o_visit xs + = let getNont v = case attrTable ! v of + NTASyn nt _ _ -> nt + NTAInh nt _ _ -> nt + getAttr v = case attrTable ! v of + NTASyn _ a _ -> a + NTAInh _ a _ -> a + sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 + procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) + wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr) + in map wrapGroup (groupBy sameNont xs) + +inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error] +inducedCycleErrs attrTable ruleTable cim xs + = let getNont v = case attrTable ! v of + NTASyn nt _ _ -> nt + NTAInh nt _ _ -> nt + getAttr v = case attrTable ! v of + NTASyn _ a _ -> a + NTAInh _ a _ -> a + sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 + procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) + wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr) + in map wrapGroup (groupBy sameNont xs) +-- Alternative ------------------------------------------------- +{- + visit 0: + inherited attributes: + allnts : [Name] + cVisitsMap : CVisitsMap + inh : Attributes + manualAttrDepMap : AttrOrderMap + nt : Identifier + o_case : Bool + o_cata : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_unbox : Bool + o_wantvisit : Bool + prefix : String + syn : Attributes + chained attribute: + vcount : Int + synthesized attributes: + additionalDep : Seq Edge + cAlternative : CAlternative + cons : [Constructor] + directDep : Seq Edge + errors : Seq Error + instDep : Seq Edge + rules : Seq (Vertex,CRule) + alternatives: + alternative Alternative: + child con : {Constructor} + child children : Children + child rules : Rules + child typeSigs : TypeSigs + visit 0: + local gathAltAttrs : _ + local inhRules : _ + local gathRules : _ + local cVisits : _ + local allfields : _ + local attrs : _ + local inhnames : _ + local synnames : _ +-} +-- cata +sem_Alternative :: Alternative -> + T_Alternative +sem_Alternative (Alternative _con _children _rules _typeSigs ) = + (sem_Alternative_Alternative _con (sem_Children _children ) (sem_Rules _rules ) (sem_TypeSigs _typeSigs ) ) +-- semantic domain +newtype T_Alternative = T_Alternative (([Name]) -> + CVisitsMap -> + Attributes -> + AttrOrderMap -> + Identifier -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + Int -> + ( (Seq Edge),CAlternative,([Constructor]),(Seq Edge),(Seq Error),(Seq Edge),(Seq (Vertex,CRule)),Int)) +data Inh_Alternative = Inh_Alternative {allnts_Inh_Alternative :: [Name],cVisitsMap_Inh_Alternative :: CVisitsMap,inh_Inh_Alternative :: Attributes,manualAttrDepMap_Inh_Alternative :: AttrOrderMap,nt_Inh_Alternative :: Identifier,o_case_Inh_Alternative :: Bool,o_cata_Inh_Alternative :: Bool,o_dovisit_Inh_Alternative :: Bool,o_newtypes_Inh_Alternative :: Bool,o_rename_Inh_Alternative :: Bool,o_sem_Inh_Alternative :: Bool,o_sig_Inh_Alternative :: Bool,o_unbox_Inh_Alternative :: Bool,o_wantvisit_Inh_Alternative :: Bool,prefix_Inh_Alternative :: String,syn_Inh_Alternative :: Attributes,vcount_Inh_Alternative :: Int} +data Syn_Alternative = Syn_Alternative {additionalDep_Syn_Alternative :: Seq Edge,cAlternative_Syn_Alternative :: CAlternative,cons_Syn_Alternative :: [Constructor],directDep_Syn_Alternative :: Seq Edge,errors_Syn_Alternative :: Seq Error,instDep_Syn_Alternative :: Seq Edge,rules_Syn_Alternative :: Seq (Vertex,CRule),vcount_Syn_Alternative :: Int} +wrap_Alternative (T_Alternative sem ) (Inh_Alternative _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount ) = + (let ( _lhsOadditionalDep,_lhsOcAlternative,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount) = + (sem _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount ) + in (Syn_Alternative _lhsOadditionalDep _lhsOcAlternative _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOrules _lhsOvcount )) +sem_Alternative_Alternative :: Constructor -> + T_Children -> + T_Rules -> + T_TypeSigs -> + T_Alternative +sem_Alternative_Alternative con_ (T_Children children_ ) (T_Rules rules_ ) (T_TypeSigs typeSigs_ ) = + (T_Alternative (\ _lhsIallnts + _lhsIcVisitsMap + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIvcount -> + (let _childrenOcon :: Identifier + _rulesOcon :: Identifier + _rulesOaltAttrs :: (Map AltAttr Vertex) + _rulesOchildNts :: (Map Name Nonterminal) + _rulesOchildInhs :: (Map Name Attributes) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOvcount :: Int + _rulesOsynsOfChildren :: (Map Name Attributes) + _lhsOcons :: ([Constructor]) + _typeSigsOtypeSigs :: (Map Name Type) + _rulesOallTypeSigs :: (Map Name Type) + _lhsOcAlternative :: CAlternative + _lhsOadditionalDep :: (Seq Edge) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _childrenOallfields :: ([(Name,Type,Bool)]) + _childrenOallnts :: ([Name]) + _childrenOattrs :: ([(Name,Name)]) + _childrenOinh :: Attributes + _childrenOnt :: Identifier + _childrenOo_unbox :: Bool + _childrenOsyn :: Attributes + _rulesOallfields :: ([(Name,Type,Bool)]) + _rulesOallnts :: ([Name]) + _rulesOattrs :: ([(Name,Name)]) + _rulesOinh :: Attributes + _rulesOmanualAttrDepMap :: AttrOrderMap + _rulesOnt :: Identifier + _rulesOo_case :: Bool + _rulesOo_cata :: Bool + _rulesOo_dovisit :: Bool + _rulesOo_newtypes :: Bool + _rulesOo_rename :: Bool + _rulesOo_sem :: Bool + _rulesOo_sig :: Bool + _rulesOo_wantvisit :: Bool + _rulesOprefix :: String + _rulesOsyn :: Attributes + _childrenIattributes :: ([(Name,Attributes,Attributes)]) + _childrenIcollectChildrenSyns :: (Map Name Attributes ) + _childrenIerrors :: (Seq Error) + _childrenIfields :: ([(Name,Type,Bool)]) + _childrenIgathAltAttrs :: ([AltAttr]) + _childrenIgathRules :: (Seq CRule) + _childrenIinhs :: (Seq (Name,Attributes)) + _childrenInts :: (Seq (Name,Nonterminal)) + _childrenIsinglevisits :: ([CRule]) + _childrenIterminals :: ([Name]) + _rulesIadditionalDep :: (Seq Edge) + _rulesIdirectDep :: (Seq Edge) + _rulesIerrors :: (Seq Error) + _rulesIgathAltAttrs :: ([AltAttr]) + _rulesIgathRules :: (Seq CRule) + _rulesIinstDep :: (Seq Edge) + _rulesIinstVars :: ([Name]) + _rulesIlocVars :: ([Name]) + _typeSigsItypeSigs :: (Map Name Type) + -- "Order.ag"(line 69, column 17) + _childrenOcon = + con_ + -- "Order.ag"(line 71, column 17) + _rulesOcon = + con_ + -- "Order.ag"(line 148, column 19) + _gathAltAttrs = + [ AltAttr _LHS inh True | inh <- Map.keys _lhsIinh ] + ++ _childrenIgathAltAttrs + ++ _rulesIgathAltAttrs + -- "Order.ag"(line 164, column 18) + _rulesOaltAttrs = + Map.fromList (zip _gathAltAttrs [_lhsIvcount..]) + -- "Order.ag"(line 177, column 19) + _rulesOchildNts = + Map.fromList (Seq.toList _childrenInts) + -- "Order.ag"(line 178, column 19) + _rulesOchildInhs = + Map.fromList (Seq.toList _childrenIinhs) + -- "Order.ag"(line 184, column 19) + _inhRules = + [ cRuleLhsInh inh _lhsInt con_ tp | (inh,tp) <- Map.assocs _lhsIinh ] + -- "Order.ag"(line 185, column 19) + _gathRules = + _inhRules ++ Seq.toList (_childrenIgathRules Seq.<> _rulesIgathRules) + -- "Order.ag"(line 238, column 19) + _lhsOrules = + Seq.fromList (zip [_lhsIvcount..] _gathRules) + -- "Order.ag"(line 239, column 19) + _lhsOvcount = + _lhsIvcount + length _gathRules + -- "Order.ag"(line 306, column 18) + _rulesOsynsOfChildren = + _childrenIcollectChildrenSyns + -- "Order.ag"(line 384, column 19) + _lhsOcons = + [con_] + -- "Order.ag"(line 391, column 17) + _typeSigsOtypeSigs = + Map.empty + -- "Order.ag"(line 397, column 18) + _rulesOallTypeSigs = + _typeSigsItypeSigs + -- "Order.ag"(line 463, column 18) + _cVisits = + if _lhsIo_dovisit + then let altsVisitsMap = findWithErr1 "Alternative.cVisits.nt" _lhsInt _lhsIcVisitsMap + visits = findWithErr1 "Alternative.cVisits.con" con_ altsVisitsMap + in visits + else let vss = nubBy eqCRuleDefines _gathRules ++ _childrenIsinglevisits + in [CVisit _lhsIinh _lhsIsyn vss [] False] + -- "Order.ag"(line 489, column 19) + _lhsOcAlternative = + CAlternative con_ _cVisits _childrenIfields _childrenIterminals + -- "Order.ag"(line 513, column 17) + _allfields = + _childrenIfields + -- "Order.ag"(line 513, column 17) + _attrs = + map ((,) _LOC) _rulesIlocVars ++ + map ((,) _INST) _rulesIinstVars ++ + map ((,) _LHS) _inhnames ++ + concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- _childrenIattributes] + -- "Order.ag"(line 513, column 17) + _inhnames = + Map.keys _lhsIinh + -- "Order.ag"(line 513, column 17) + _synnames = + Map.keys _lhsIsyn + -- use rule "Order.ag"(line 258, column 71) + _lhsOadditionalDep = + _rulesIadditionalDep + -- use rule "Order.ag"(line 244, column 33) + _lhsOdirectDep = + _rulesIdirectDep + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _childrenIerrors Seq.<> _rulesIerrors + -- use rule "Order.ag"(line 289, column 31) + _lhsOinstDep = + _rulesIinstDep + -- copy rule (from local) + _childrenOallfields = + _allfields + -- copy rule (down) + _childrenOallnts = + _lhsIallnts + -- copy rule (from local) + _childrenOattrs = + _attrs + -- copy rule (down) + _childrenOinh = + _lhsIinh + -- copy rule (down) + _childrenOnt = + _lhsInt + -- copy rule (down) + _childrenOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _childrenOsyn = + _lhsIsyn + -- copy rule (from local) + _rulesOallfields = + _allfields + -- copy rule (down) + _rulesOallnts = + _lhsIallnts + -- copy rule (from local) + _rulesOattrs = + _attrs + -- copy rule (down) + _rulesOinh = + _lhsIinh + -- copy rule (down) + _rulesOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _rulesOnt = + _lhsInt + -- copy rule (down) + _rulesOo_case = + _lhsIo_case + -- copy rule (down) + _rulesOo_cata = + _lhsIo_cata + -- copy rule (down) + _rulesOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _rulesOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _rulesOo_rename = + _lhsIo_rename + -- copy rule (down) + _rulesOo_sem = + _lhsIo_sem + -- copy rule (down) + _rulesOo_sig = + _lhsIo_sig + -- copy rule (down) + _rulesOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _rulesOprefix = + _lhsIprefix + -- copy rule (down) + _rulesOsyn = + _lhsIsyn + ( _childrenIattributes,_childrenIcollectChildrenSyns,_childrenIerrors,_childrenIfields,_childrenIgathAltAttrs,_childrenIgathRules,_childrenIinhs,_childrenInts,_childrenIsinglevisits,_childrenIterminals) = + (children_ _childrenOallfields _childrenOallnts _childrenOattrs _childrenOcon _childrenOinh _childrenOnt _childrenOo_unbox _childrenOsyn ) + ( _rulesIadditionalDep,_rulesIdirectDep,_rulesIerrors,_rulesIgathAltAttrs,_rulesIgathRules,_rulesIinstDep,_rulesIinstVars,_rulesIlocVars) = + (rules_ _rulesOallTypeSigs _rulesOallfields _rulesOallnts _rulesOaltAttrs _rulesOattrs _rulesOchildInhs _rulesOchildNts _rulesOcon _rulesOinh _rulesOmanualAttrDepMap _rulesOnt _rulesOo_case _rulesOo_cata _rulesOo_dovisit _rulesOo_newtypes _rulesOo_rename _rulesOo_sem _rulesOo_sig _rulesOo_wantvisit _rulesOprefix _rulesOsyn _rulesOsynsOfChildren ) + ( _typeSigsItypeSigs) = + (typeSigs_ _typeSigsOtypeSigs ) + in ( _lhsOadditionalDep,_lhsOcAlternative,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount))) ) +-- Alternatives ------------------------------------------------ +{- + visit 0: + inherited attributes: + allnts : [Name] + cVisitsMap : CVisitsMap + inh : Attributes + manualAttrDepMap : AttrOrderMap + nt : Identifier + o_case : Bool + o_cata : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_unbox : Bool + o_wantvisit : Bool + prefix : String + syn : Attributes + chained attribute: + vcount : Int + synthesized attributes: + additionalDep : Seq Edge + cAlternatives : CAlternatives + cons : [Constructor] + directDep : Seq Edge + errors : Seq Error + instDep : Seq Edge + rules : Seq (Vertex,CRule) + alternatives: + alternative Cons: + child hd : Alternative + child tl : Alternatives + alternative Nil: +-} +-- cata +sem_Alternatives :: Alternatives -> + T_Alternatives +sem_Alternatives list = + (Prelude.foldr sem_Alternatives_Cons sem_Alternatives_Nil (Prelude.map sem_Alternative list) ) +-- semantic domain +newtype T_Alternatives = T_Alternatives (([Name]) -> + CVisitsMap -> + Attributes -> + AttrOrderMap -> + Identifier -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + Int -> + ( (Seq Edge),CAlternatives,([Constructor]),(Seq Edge),(Seq Error),(Seq Edge),(Seq (Vertex,CRule)),Int)) +data Inh_Alternatives = Inh_Alternatives {allnts_Inh_Alternatives :: [Name],cVisitsMap_Inh_Alternatives :: CVisitsMap,inh_Inh_Alternatives :: Attributes,manualAttrDepMap_Inh_Alternatives :: AttrOrderMap,nt_Inh_Alternatives :: Identifier,o_case_Inh_Alternatives :: Bool,o_cata_Inh_Alternatives :: Bool,o_dovisit_Inh_Alternatives :: Bool,o_newtypes_Inh_Alternatives :: Bool,o_rename_Inh_Alternatives :: Bool,o_sem_Inh_Alternatives :: Bool,o_sig_Inh_Alternatives :: Bool,o_unbox_Inh_Alternatives :: Bool,o_wantvisit_Inh_Alternatives :: Bool,prefix_Inh_Alternatives :: String,syn_Inh_Alternatives :: Attributes,vcount_Inh_Alternatives :: Int} +data Syn_Alternatives = Syn_Alternatives {additionalDep_Syn_Alternatives :: Seq Edge,cAlternatives_Syn_Alternatives :: CAlternatives,cons_Syn_Alternatives :: [Constructor],directDep_Syn_Alternatives :: Seq Edge,errors_Syn_Alternatives :: Seq Error,instDep_Syn_Alternatives :: Seq Edge,rules_Syn_Alternatives :: Seq (Vertex,CRule),vcount_Syn_Alternatives :: Int} +wrap_Alternatives (T_Alternatives sem ) (Inh_Alternatives _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount ) = + (let ( _lhsOadditionalDep,_lhsOcAlternatives,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount) = + (sem _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount ) + in (Syn_Alternatives _lhsOadditionalDep _lhsOcAlternatives _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOrules _lhsOvcount )) +sem_Alternatives_Cons :: T_Alternative -> + T_Alternatives -> + T_Alternatives +sem_Alternatives_Cons (T_Alternative hd_ ) (T_Alternatives tl_ ) = + (T_Alternatives (\ _lhsIallnts + _lhsIcVisitsMap + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIvcount -> + (let _lhsOcAlternatives :: CAlternatives + _lhsOadditionalDep :: (Seq Edge) + _lhsOcons :: ([Constructor]) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOvcount :: Int + _hdOallnts :: ([Name]) + _hdOcVisitsMap :: CVisitsMap + _hdOinh :: Attributes + _hdOmanualAttrDepMap :: AttrOrderMap + _hdOnt :: Identifier + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_dovisit :: Bool + _hdOo_newtypes :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_unbox :: Bool + _hdOo_wantvisit :: Bool + _hdOprefix :: String + _hdOsyn :: Attributes + _hdOvcount :: Int + _tlOallnts :: ([Name]) + _tlOcVisitsMap :: CVisitsMap + _tlOinh :: Attributes + _tlOmanualAttrDepMap :: AttrOrderMap + _tlOnt :: Identifier + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_dovisit :: Bool + _tlOo_newtypes :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_unbox :: Bool + _tlOo_wantvisit :: Bool + _tlOprefix :: String + _tlOsyn :: Attributes + _tlOvcount :: Int + _hdIadditionalDep :: (Seq Edge) + _hdIcAlternative :: CAlternative + _hdIcons :: ([Constructor]) + _hdIdirectDep :: (Seq Edge) + _hdIerrors :: (Seq Error) + _hdIinstDep :: (Seq Edge) + _hdIrules :: (Seq (Vertex,CRule)) + _hdIvcount :: Int + _tlIadditionalDep :: (Seq Edge) + _tlIcAlternatives :: CAlternatives + _tlIcons :: ([Constructor]) + _tlIdirectDep :: (Seq Edge) + _tlIerrors :: (Seq Error) + _tlIinstDep :: (Seq Edge) + _tlIrules :: (Seq (Vertex,CRule)) + _tlIvcount :: Int + -- "Order.ag"(line 486, column 12) + _lhsOcAlternatives = + _hdIcAlternative : _tlIcAlternatives + -- use rule "Order.ag"(line 258, column 71) + _lhsOadditionalDep = + _hdIadditionalDep Seq.<> _tlIadditionalDep + -- use rule "Order.ag"(line 382, column 42) + _lhsOcons = + _hdIcons ++ _tlIcons + -- use rule "Order.ag"(line 244, column 33) + _lhsOdirectDep = + _hdIdirectDep Seq.<> _tlIdirectDep + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Order.ag"(line 289, column 31) + _lhsOinstDep = + _hdIinstDep Seq.<> _tlIinstDep + -- use rule "Order.ag"(line 234, column 18) + _lhsOrules = + _hdIrules Seq.<> _tlIrules + -- copy rule (up) + _lhsOvcount = + _tlIvcount + -- copy rule (down) + _hdOallnts = + _lhsIallnts + -- copy rule (down) + _hdOcVisitsMap = + _lhsIcVisitsMap + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOvcount = + _lhsIvcount + -- copy rule (down) + _tlOallnts = + _lhsIallnts + -- copy rule (down) + _tlOcVisitsMap = + _lhsIcVisitsMap + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (chain) + _tlOvcount = + _hdIvcount + ( _hdIadditionalDep,_hdIcAlternative,_hdIcons,_hdIdirectDep,_hdIerrors,_hdIinstDep,_hdIrules,_hdIvcount) = + (hd_ _hdOallnts _hdOcVisitsMap _hdOinh _hdOmanualAttrDepMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOprefix _hdOsyn _hdOvcount ) + ( _tlIadditionalDep,_tlIcAlternatives,_tlIcons,_tlIdirectDep,_tlIerrors,_tlIinstDep,_tlIrules,_tlIvcount) = + (tl_ _tlOallnts _tlOcVisitsMap _tlOinh _tlOmanualAttrDepMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOprefix _tlOsyn _tlOvcount ) + in ( _lhsOadditionalDep,_lhsOcAlternatives,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount))) ) +sem_Alternatives_Nil :: T_Alternatives +sem_Alternatives_Nil = + (T_Alternatives (\ _lhsIallnts + _lhsIcVisitsMap + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIvcount -> + (let _lhsOcAlternatives :: CAlternatives + _lhsOadditionalDep :: (Seq Edge) + _lhsOcons :: ([Constructor]) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOvcount :: Int + -- "Order.ag"(line 487, column 12) + _lhsOcAlternatives = + [] + -- use rule "Order.ag"(line 258, column 71) + _lhsOadditionalDep = + Seq.empty + -- use rule "Order.ag"(line 382, column 42) + _lhsOcons = + [] + -- use rule "Order.ag"(line 244, column 33) + _lhsOdirectDep = + Seq.empty + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 289, column 31) + _lhsOinstDep = + Seq.empty + -- use rule "Order.ag"(line 234, column 18) + _lhsOrules = + Seq.empty + -- copy rule (chain) + _lhsOvcount = + _lhsIvcount + in ( _lhsOadditionalDep,_lhsOcAlternatives,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount))) ) +-- Child ------------------------------------------------------- +{- + visit 0: + inherited attributes: + allfields : [(Name,Type,Bool)] + allnts : [Name] + attrs : [(Name,Name)] + con : Identifier + inh : Attributes + nt : Identifier + o_unbox : Bool + syn : Attributes + synthesized attributes: + attributes : [(Name,Attributes,Attributes)] + collectChildrenSyns : Map Name Attributes + errors : Seq Error + field : (Name,Type,Bool) + gathAltAttrs : [AltAttr] + gathRules : Seq CRule + inhs : Seq (Name,Attributes) + nts : Seq (Name,Nonterminal) + singlevisits : [CRule] + terminals : [Name] + alternatives: + alternative Child: + child name : {Name} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child higherOrder : {Bool} + visit 0: + local maptolocal : _ + local gathRules : _ +-} +-- cata +sem_Child :: Child -> + T_Child +sem_Child (Child _name _tp _inh _syn _higherOrder ) = + (sem_Child_Child _name _tp _inh _syn _higherOrder ) +-- semantic domain +newtype T_Child = T_Child (([(Name,Type,Bool)]) -> + ([Name]) -> + ([(Name,Name)]) -> + Identifier -> + Attributes -> + Identifier -> + Bool -> + Attributes -> + ( ([(Name,Attributes,Attributes)]),(Map Name Attributes ),(Seq Error),((Name,Type,Bool)),([AltAttr]),(Seq CRule),(Seq (Name,Attributes)),(Seq (Name,Nonterminal)),([CRule]),([Name]))) +data Inh_Child = Inh_Child {allfields_Inh_Child :: [(Name,Type,Bool)],allnts_Inh_Child :: [Name],attrs_Inh_Child :: [(Name,Name)],con_Inh_Child :: Identifier,inh_Inh_Child :: Attributes,nt_Inh_Child :: Identifier,o_unbox_Inh_Child :: Bool,syn_Inh_Child :: Attributes} +data Syn_Child = Syn_Child {attributes_Syn_Child :: [(Name,Attributes,Attributes)],collectChildrenSyns_Syn_Child :: Map Name Attributes ,errors_Syn_Child :: Seq Error,field_Syn_Child :: (Name,Type,Bool),gathAltAttrs_Syn_Child :: [AltAttr],gathRules_Syn_Child :: Seq CRule,inhs_Syn_Child :: Seq (Name,Attributes),nts_Syn_Child :: Seq (Name,Nonterminal),singlevisits_Syn_Child :: [CRule],terminals_Syn_Child :: [Name]} +wrap_Child (T_Child sem ) (Inh_Child _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn ) = + (let ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfield,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals) = + (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn ) + in (Syn_Child _lhsOattributes _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals )) +sem_Child_Child :: Name -> + Type -> + Attributes -> + Attributes -> + Bool -> + T_Child +sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = + (T_Child (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIo_unbox + _lhsIsyn -> + (let _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOnts :: (Seq (Name,Nonterminal)) + _lhsOinhs :: (Seq (Name,Attributes)) + _lhsOcollectChildrenSyns :: (Map Name Attributes ) + _lhsOsinglevisits :: ([CRule]) + _lhsOterminals :: ([Name]) + _lhsOattributes :: ([(Name,Attributes,Attributes)]) + _lhsOfield :: ((Name,Type,Bool)) + _lhsOerrors :: (Seq Error) + _lhsOgathRules :: (Seq CRule) + -- "Order.ag"(line 153, column 13) + _maptolocal = + case tp_ of + NT nt -> Map.null syn_ + _ -> True + -- "Order.ag"(line 156, column 13) + _lhsOgathAltAttrs = + if _maptolocal + then [ AltAttr _LOC name_ True ] + else [ AltAttr name_ syn True | syn <- Map.keys syn_ ] + -- "Order.ag"(line 171, column 13) + _lhsOnts = + Seq.single (name_,getNtName tp_) + -- "Order.ag"(line 172, column 13) + _lhsOinhs = + Seq.single (name_,inh_) + -- "Order.ag"(line 188, column 13) + _gathRules = + if _maptolocal + then Seq.single (cRuleTerminal name_ _lhsInt _lhsIcon tp_) + else Seq.fromList [ cRuleRhsSyn syn _lhsInt _lhsIcon tp name_ (getNtName tp_) | (syn,tp) <- Map.assocs syn_] + -- "Order.ag"(line 310, column 12) + _lhsOcollectChildrenSyns = + Map.singleton name_ syn_ + -- "Order.ag"(line 473, column 11) + _lhsOsinglevisits = + if _maptolocal + then [] + else [CChildVisit name_ (getNtName tp_) 0 inh_ syn_ True] + -- "Order.ag"(line 494, column 11) + _lhsOterminals = + if _maptolocal + then [name_] + else [] + -- "Order.ag"(line 523, column 11) + _lhsOattributes = + [(name_, inh_, syn_)] + -- "Order.ag"(line 527, column 11) + _lhsOfield = + (name_, tp_, higherOrder_) + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + _gathRules + in ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfield,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals))) ) +-- Children ---------------------------------------------------- +{- + visit 0: + inherited attributes: + allfields : [(Name,Type,Bool)] + allnts : [Name] + attrs : [(Name,Name)] + con : Identifier + inh : Attributes + nt : Identifier + o_unbox : Bool + syn : Attributes + synthesized attributes: + attributes : [(Name,Attributes,Attributes)] + collectChildrenSyns : Map Name Attributes + errors : Seq Error + fields : [(Name,Type,Bool)] + gathAltAttrs : [AltAttr] + gathRules : Seq CRule + inhs : Seq (Name,Attributes) + nts : Seq (Name,Nonterminal) + singlevisits : [CRule] + terminals : [Name] + alternatives: + alternative Cons: + child hd : Child + child tl : Children + alternative Nil: +-} +-- cata +sem_Children :: Children -> + T_Children +sem_Children list = + (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) ) +-- semantic domain +newtype T_Children = T_Children (([(Name,Type,Bool)]) -> + ([Name]) -> + ([(Name,Name)]) -> + Identifier -> + Attributes -> + Identifier -> + Bool -> + Attributes -> + ( ([(Name,Attributes,Attributes)]),(Map Name Attributes ),(Seq Error),([(Name,Type,Bool)]),([AltAttr]),(Seq CRule),(Seq (Name,Attributes)),(Seq (Name,Nonterminal)),([CRule]),([Name]))) +data Inh_Children = Inh_Children {allfields_Inh_Children :: [(Name,Type,Bool)],allnts_Inh_Children :: [Name],attrs_Inh_Children :: [(Name,Name)],con_Inh_Children :: Identifier,inh_Inh_Children :: Attributes,nt_Inh_Children :: Identifier,o_unbox_Inh_Children :: Bool,syn_Inh_Children :: Attributes} +data Syn_Children = Syn_Children {attributes_Syn_Children :: [(Name,Attributes,Attributes)],collectChildrenSyns_Syn_Children :: Map Name Attributes ,errors_Syn_Children :: Seq Error,fields_Syn_Children :: [(Name,Type,Bool)],gathAltAttrs_Syn_Children :: [AltAttr],gathRules_Syn_Children :: Seq CRule,inhs_Syn_Children :: Seq (Name,Attributes),nts_Syn_Children :: Seq (Name,Nonterminal),singlevisits_Syn_Children :: [CRule],terminals_Syn_Children :: [Name]} +wrap_Children (T_Children sem ) (Inh_Children _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn ) = + (let ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfields,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals) = + (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn ) + in (Syn_Children _lhsOattributes _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals )) +sem_Children_Cons :: T_Child -> + T_Children -> + T_Children +sem_Children_Cons (T_Child hd_ ) (T_Children tl_ ) = + (T_Children (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIo_unbox + _lhsIsyn -> + (let _lhsOfields :: ([(Name,Type,Bool)]) + _lhsOattributes :: ([(Name,Attributes,Attributes)]) + _lhsOcollectChildrenSyns :: (Map Name Attributes ) + _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOgathRules :: (Seq CRule) + _lhsOinhs :: (Seq (Name,Attributes)) + _lhsOnts :: (Seq (Name,Nonterminal)) + _lhsOsinglevisits :: ([CRule]) + _lhsOterminals :: ([Name]) + _hdOallfields :: ([(Name,Type,Bool)]) + _hdOallnts :: ([Name]) + _hdOattrs :: ([(Name,Name)]) + _hdOcon :: Identifier + _hdOinh :: Attributes + _hdOnt :: Identifier + _hdOo_unbox :: Bool + _hdOsyn :: Attributes + _tlOallfields :: ([(Name,Type,Bool)]) + _tlOallnts :: ([Name]) + _tlOattrs :: ([(Name,Name)]) + _tlOcon :: Identifier + _tlOinh :: Attributes + _tlOnt :: Identifier + _tlOo_unbox :: Bool + _tlOsyn :: Attributes + _hdIattributes :: ([(Name,Attributes,Attributes)]) + _hdIcollectChildrenSyns :: (Map Name Attributes ) + _hdIerrors :: (Seq Error) + _hdIfield :: ((Name,Type,Bool)) + _hdIgathAltAttrs :: ([AltAttr]) + _hdIgathRules :: (Seq CRule) + _hdIinhs :: (Seq (Name,Attributes)) + _hdInts :: (Seq (Name,Nonterminal)) + _hdIsinglevisits :: ([CRule]) + _hdIterminals :: ([Name]) + _tlIattributes :: ([(Name,Attributes,Attributes)]) + _tlIcollectChildrenSyns :: (Map Name Attributes ) + _tlIerrors :: (Seq Error) + _tlIfields :: ([(Name,Type,Bool)]) + _tlIgathAltAttrs :: ([AltAttr]) + _tlIgathRules :: (Seq CRule) + _tlIinhs :: (Seq (Name,Attributes)) + _tlInts :: (Seq (Name,Nonterminal)) + _tlIsinglevisits :: ([CRule]) + _tlIterminals :: ([Name]) + -- "Order.ag"(line 530, column 11) + _lhsOfields = + _hdIfield : _tlIfields + -- use rule "Order.ag"(line 521, column 32) + _lhsOattributes = + _hdIattributes ++ _tlIattributes + -- use rule "Order.ag"(line 308, column 47) + _lhsOcollectChildrenSyns = + _hdIcollectChildrenSyns `Map.union` _tlIcollectChildrenSyns + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _hdIgathAltAttrs ++ _tlIgathAltAttrs + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + _hdIgathRules Seq.<> _tlIgathRules + -- use rule "Order.ag"(line 169, column 20) + _lhsOinhs = + _hdIinhs Seq.<> _tlIinhs + -- use rule "Order.ag"(line 168, column 19) + _lhsOnts = + _hdInts Seq.<> _tlInts + -- use rule "Order.ag"(line 471, column 40) + _lhsOsinglevisits = + _hdIsinglevisits ++ _tlIsinglevisits + -- use rule "Order.ag"(line 492, column 38) + _lhsOterminals = + _hdIterminals ++ _tlIterminals + -- copy rule (down) + _hdOallfields = + _lhsIallfields + -- copy rule (down) + _hdOallnts = + _lhsIallnts + -- copy rule (down) + _hdOattrs = + _lhsIattrs + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _tlOallfields = + _lhsIallfields + -- copy rule (down) + _tlOallnts = + _lhsIallnts + -- copy rule (down) + _tlOattrs = + _lhsIattrs + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOsyn = + _lhsIsyn + ( _hdIattributes,_hdIcollectChildrenSyns,_hdIerrors,_hdIfield,_hdIgathAltAttrs,_hdIgathRules,_hdIinhs,_hdInts,_hdIsinglevisits,_hdIterminals) = + (hd_ _hdOallfields _hdOallnts _hdOattrs _hdOcon _hdOinh _hdOnt _hdOo_unbox _hdOsyn ) + ( _tlIattributes,_tlIcollectChildrenSyns,_tlIerrors,_tlIfields,_tlIgathAltAttrs,_tlIgathRules,_tlIinhs,_tlInts,_tlIsinglevisits,_tlIterminals) = + (tl_ _tlOallfields _tlOallnts _tlOattrs _tlOcon _tlOinh _tlOnt _tlOo_unbox _tlOsyn ) + in ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfields,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals))) ) +sem_Children_Nil :: T_Children +sem_Children_Nil = + (T_Children (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIo_unbox + _lhsIsyn -> + (let _lhsOfields :: ([(Name,Type,Bool)]) + _lhsOattributes :: ([(Name,Attributes,Attributes)]) + _lhsOcollectChildrenSyns :: (Map Name Attributes ) + _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOgathRules :: (Seq CRule) + _lhsOinhs :: (Seq (Name,Attributes)) + _lhsOnts :: (Seq (Name,Nonterminal)) + _lhsOsinglevisits :: ([CRule]) + _lhsOterminals :: ([Name]) + -- "Order.ag"(line 531, column 11) + _lhsOfields = + [] + -- use rule "Order.ag"(line 521, column 32) + _lhsOattributes = + [] + -- use rule "Order.ag"(line 308, column 47) + _lhsOcollectChildrenSyns = + Map.empty + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + [] + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + Seq.empty + -- use rule "Order.ag"(line 169, column 20) + _lhsOinhs = + Seq.empty + -- use rule "Order.ag"(line 168, column 19) + _lhsOnts = + Seq.empty + -- use rule "Order.ag"(line 471, column 40) + _lhsOsinglevisits = + [] + -- use rule "Order.ag"(line 492, column 38) + _lhsOterminals = + [] + in ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfields,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals))) ) +-- Expression -------------------------------------------------- +{- + visit 0: + inherited attributes: + allfields : [(Name,Type,Bool)] + allnts : [Name] + attrs : [(Name,Name)] + con : Name + nt : Name + synthesized attributes: + allRhsVars : Set (Name,Name) + copy : SELF + errors : Seq Error + textLines : [String] + usedAttrs : [(Name,Name)] + usedFields : [Name] + usedLocals : [Name] + alternatives: + alternative Expression: + child pos : {Pos} + child txt : {String} + visit 0: + local _tup1 : _ + local errors : _ + local textLines : _ + local usedAttrs : _ + local usedLocals : _ + local usedFields : _ + local copy : _ +-} +-- cata +sem_Expression :: Expression -> + T_Expression +sem_Expression (Expression _pos _txt ) = + (sem_Expression_Expression _pos _txt ) +-- semantic domain +newtype T_Expression = T_Expression (([(Name,Type,Bool)]) -> + ([Name]) -> + ([(Name,Name)]) -> + Name -> + Name -> + ( (Set (Name,Name)),Expression,(Seq Error),([String]),([(Name,Name)]),([Name]),([Name]))) +data Inh_Expression = Inh_Expression {allfields_Inh_Expression :: [(Name,Type,Bool)],allnts_Inh_Expression :: [Name],attrs_Inh_Expression :: [(Name,Name)],con_Inh_Expression :: Name,nt_Inh_Expression :: Name} +data Syn_Expression = Syn_Expression {allRhsVars_Syn_Expression :: Set (Name,Name),copy_Syn_Expression :: Expression,errors_Syn_Expression :: Seq Error,textLines_Syn_Expression :: [String],usedAttrs_Syn_Expression :: [(Name,Name)],usedFields_Syn_Expression :: [Name],usedLocals_Syn_Expression :: [Name]} +wrap_Expression (T_Expression sem ) (Inh_Expression _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt ) = + (let ( _lhsOallRhsVars,_lhsOcopy,_lhsOerrors,_lhsOtextLines,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals) = + (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt ) + in (Syn_Expression _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals )) +sem_Expression_Expression :: Pos -> + String -> + T_Expression +sem_Expression_Expression pos_ txt_ = + (T_Expression (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsInt -> + (let _lhsOallRhsVars :: (Set (Name,Name)) + _lhsOcopy :: Expression + _lhsOerrors :: (Seq Error) + _lhsOtextLines :: ([String]) + _lhsOusedAttrs :: ([(Name,Name)]) + _lhsOusedFields :: ([Name]) + _lhsOusedLocals :: ([Name]) + -- "Order.ag"(line 330, column 21) + __tup1 = + let inherited = Inh_HsTokensRoot + { attrs_Inh_HsTokensRoot = _lhsIattrs + , con_Inh_HsTokensRoot = _lhsIcon + , allfields_Inh_HsTokensRoot = _lhsIallfields + , allnts_Inh_HsTokensRoot = _lhsIallnts + , nt_Inh_HsTokensRoot = _lhsInt + } + pos' = case pos_ of + Pos l k f -> Pos l 1 f + synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot $ lexTokens pos' txt_)) inherited + in case synthesized of + Syn_HsTokensRoot + { errors_Syn_HsTokensRoot = errors + , textLines_Syn_HsTokensRoot = textLines + , usedAttrs_Syn_HsTokensRoot = usedAttrs + , usedLocals_Syn_HsTokensRoot = usedLocals + , usedFields_Syn_HsTokensRoot = usedFields + } -> (errors,textLines,usedAttrs,usedLocals,usedFields) + -- "Order.ag"(line 330, column 21) + (_errors,_,_,_,_) = + __tup1 + -- "Order.ag"(line 330, column 21) + (_,_textLines,_,_,_) = + __tup1 + -- "Order.ag"(line 330, column 21) + (_,_,_usedAttrs,_,_) = + __tup1 + -- "Order.ag"(line 330, column 21) + (_,_,_,_usedLocals,_) = + __tup1 + -- "Order.ag"(line 330, column 21) + (_,_,_,_,_usedFields) = + __tup1 + -- "Order.ag"(line 351, column 17) + _lhsOallRhsVars = + Set.fromList _usedAttrs + `Set.union` + Set.fromList [ (_LOC, l) | l <- _usedLocals ] + `Set.union` + Set.fromList [ (_FIELD, fld) | fld <- _usedFields ] + -- self rule + _copy = + Expression pos_ txt_ + -- self rule + _lhsOcopy = + _copy + -- copy rule (from local) + _lhsOerrors = + _errors + -- copy rule (from local) + _lhsOtextLines = + _textLines + -- copy rule (from local) + _lhsOusedAttrs = + _usedAttrs + -- copy rule (from local) + _lhsOusedFields = + _usedFields + -- copy rule (from local) + _lhsOusedLocals = + _usedLocals + in ( _lhsOallRhsVars,_lhsOcopy,_lhsOerrors,_lhsOtextLines,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals))) ) +-- Grammar ----------------------------------------------------- +{- + visit 0: + inherited attribute: + options : Options + synthesized attributes: + errors : Seq Error + output : CGrammar + alternatives: + alternative Grammar: + child typeSyns : {TypeSyns} + child useMap : {UseMap} + child derivings : {Derivings} + child wrappers : {Set Nonterminal} + child prods : Productions + child pragmas : {PragmaMap} + child manualAttrOrderMap : {AttrOrderMap} + visit 0: + local ruleTable : _ + local attrTable : _ + local attrVertex : _ + local tdpToTds : _ + local tdsToTdp : _ + local directDep : _ + local instDep : _ + local info : _ + local _tup2 : _ + local cInterfaceMap : _ + local cVisitsMap : _ + local cyclesErrors : _ +-} +-- cata +sem_Grammar :: Grammar -> + T_Grammar +sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _prods _pragmas _manualAttrOrderMap ) = + (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Productions _prods ) _pragmas _manualAttrOrderMap ) +-- semantic domain +newtype T_Grammar = T_Grammar (Options -> + ( (Seq Error),CGrammar)) +data Inh_Grammar = Inh_Grammar {options_Inh_Grammar :: Options} +data Syn_Grammar = Syn_Grammar {errors_Syn_Grammar :: Seq Error,output_Syn_Grammar :: CGrammar} +wrap_Grammar (T_Grammar sem ) (Inh_Grammar _lhsIoptions ) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsIoptions ) + in (Syn_Grammar _lhsOerrors _lhsOoutput )) +sem_Grammar_Grammar :: TypeSyns -> + UseMap -> + Derivings -> + (Set Nonterminal) -> + T_Productions -> + PragmaMap -> + AttrOrderMap -> + T_Grammar +sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Productions prods_ ) pragmas_ manualAttrOrderMap_ = + (T_Grammar (\ _lhsIoptions -> + (let _prodsOo_cata :: Bool + _prodsOo_data :: Bool + _prodsOo_sig :: Bool + _prodsOo_sem :: Bool + _prodsOo_rename :: Bool + _prodsOo_newtypes :: Bool + _prodsOo_wantvisit :: Bool + _prodsOo_dovisit :: Bool + _prodsOo_unbox :: Bool + _prodsOo_case :: Bool + _prodsOprefix :: String + _prodsOvcount :: Int + _prodsOmanualAttrDepMap :: AttrOrderMap + _prodsOacount :: Int + _lhsOerrors :: (Seq Error) + _lhsOoutput :: CGrammar + _prodsOallnts :: ([Name]) + _prodsOcInterfaceMap :: CInterfaceMap + _prodsOcVisitsMap :: CVisitsMap + _prodsIacount :: Int + _prodsIadditionalDep :: (Seq Edge) + _prodsIaranges :: (Seq (Int,Int,Int)) + _prodsIcProductions :: CProductions + _prodsIdirectDep :: (Seq Edge) + _prodsIerrors :: (Seq Error) + _prodsIinstDep :: (Seq Edge) + _prodsIntattrs :: (Seq (Vertex,NTAttr)) + _prodsIprods :: ([(Nonterminal,[Constructor])]) + _prodsIrules :: (Seq (Vertex,CRule)) + _prodsIvcount :: Int + -- "Order.ag"(line 99, column 17) + _prodsOo_cata = + folds _lhsIoptions + -- "Order.ag"(line 99, column 17) + _prodsOo_data = + dataTypes _lhsIoptions + -- "Order.ag"(line 99, column 17) + _prodsOo_sig = + typeSigs _lhsIoptions + -- "Order.ag"(line 99, column 17) + _prodsOo_sem = + semfuns _lhsIoptions + -- "Order.ag"(line 99, column 17) + _prodsOo_rename = + rename _lhsIoptions + -- "Order.ag"(line 99, column 17) + _prodsOo_newtypes = + newtypes _lhsIoptions + -- "Order.ag"(line 99, column 17) + _prodsOo_wantvisit = + visit _lhsIoptions + -- "Order.ag"(line 99, column 17) + _prodsOo_dovisit = + visit _lhsIoptions && null _cyclesErrors + -- "Order.ag"(line 99, column 17) + _prodsOo_unbox = + unbox _lhsIoptions + -- "Order.ag"(line 99, column 17) + _prodsOo_case = + cases _lhsIoptions + -- "Order.ag"(line 99, column 17) + _prodsOprefix = + prefix _lhsIoptions + -- "Order.ag"(line 236, column 15) + _prodsOvcount = + 0 + -- "Order.ag"(line 261, column 7) + _prodsOmanualAttrDepMap = + manualAttrOrderMap_ + -- "Order.ag"(line 365, column 13) + _prodsOacount = + 0 + -- "Order.ag"(line 403, column 13) + _ruleTable = + Array.array (0,_prodsIvcount-1) (Seq.toList _prodsIrules) + -- "Order.ag"(line 404, column 13) + _attrTable = + Array.array (0,_prodsIacount-1) (Seq.toList _prodsIntattrs) + -- "Order.ag"(line 405, column 13) + _attrVertex = + Map.fromList (map swap (Seq.toList _prodsIntattrs)) + -- "Order.ag"(line 406, column 13) + _tdpToTds = + [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v _attrVertex) (ntattr cr)) + | (s,cr) <- Seq.toList _prodsIrules] + -- "Order.ag"(line 408, column 13) + _tdsToTdp = + let eq (_,v) (_,v') = v == v' + conv ((s,v):svs) | v == -1 = Nothing + | otherwise = Just (v,s:map fst svs) + in mapMaybe conv (eqClasses eq _tdpToTds) + -- "Order.ag"(line 412, column 13) + _directDep = + Seq.toList (_prodsIdirectDep Seq.<> _prodsIadditionalDep) + -- "Order.ag"(line 413, column 13) + _instDep = + Seq.toList _prodsIinstDep + -- "Order.ag"(line 414, column 13) + _info = + let def [] = -1 + def (v:vs) = v + in Info { tdsToTdp = Array.array (0,_prodsIacount-1) _tdsToTdp + , tdpToTds = Array.array (0,_prodsIvcount-1) _tdpToTds + , attrTable = _attrTable + , ruleTable = _ruleTable + , lmh = Seq.toList _prodsIaranges + , prods = _prodsIprods + , wraps = wrappers_ + } + -- "Order.ag"(line 425, column 17) + __tup2 = + case computeSequential _info _directDep _instDep of + CycleFree cim cvm -> ( cim + , cvm + , [] + ) + LocalCycle errs -> ( error "No interfaces for AG with local cycles" + , error "No visit sub-sequences for AG with local cycles" + , map (localCycleErr _ruleTable (visit _lhsIoptions)) errs + ) + InstCycle errs -> ( error "No interfaces for AG with cycles through insts" + , error "No visit sub-sequences for AG with cycles through insts" + , map (instCycleErr _ruleTable (visit _lhsIoptions)) errs + ) + DirectCycle errs -> ( error "No interfaces for AG with direct cycles" + , error "No visit sub-sequences for AG with direct cycles" + , directCycleErrs _attrTable _ruleTable (visit _lhsIoptions) errs + ) + InducedCycle cim errs -> ( cim + , error "No visit sub-sequences for AG with induced cycles" + , inducedCycleErrs _attrTable _ruleTable cim errs + ) + -- "Order.ag"(line 425, column 17) + (_cInterfaceMap,_,_) = + __tup2 + -- "Order.ag"(line 425, column 17) + (_,_cVisitsMap,_) = + __tup2 + -- "Order.ag"(line 425, column 17) + (_,_,_cyclesErrors) = + __tup2 + -- "Order.ag"(line 447, column 13) + _lhsOerrors = + (if withCycle _lhsIoptions then Seq.fromList _cyclesErrors else Seq.empty) + Seq.<> _prodsIerrors + -- "Order.ag"(line 479, column 15) + _lhsOoutput = + CGrammar typeSyns_ derivings_ wrappers_ _prodsIcProductions pragmas_ + -- "Order.ag"(line 506, column 13) + _prodsOallnts = + map fst (_prodsIprods) + -- copy rule (from local) + _prodsOcInterfaceMap = + _cInterfaceMap + -- copy rule (from local) + _prodsOcVisitsMap = + _cVisitsMap + ( _prodsIacount,_prodsIadditionalDep,_prodsIaranges,_prodsIcProductions,_prodsIdirectDep,_prodsIerrors,_prodsIinstDep,_prodsIntattrs,_prodsIprods,_prodsIrules,_prodsIvcount) = + (prods_ _prodsOacount _prodsOallnts _prodsOcInterfaceMap _prodsOcVisitsMap _prodsOmanualAttrDepMap _prodsOo_case _prodsOo_cata _prodsOo_data _prodsOo_dovisit _prodsOo_newtypes _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_unbox _prodsOo_wantvisit _prodsOprefix _prodsOvcount ) + in ( _lhsOerrors,_lhsOoutput))) ) +-- Pattern ----------------------------------------------------- +{- + visit 0: + inherited attributes: + allTypeSigs : Map Name Type + altAttrs : Map AltAttr Vertex + con : Identifier + inh : Attributes + nt : Identifier + syn : Attributes + synthesized attributes: + copy : SELF + errors : Seq Error + gathAltAttrs : [AltAttr] + instVars : [Name] + locVars : [Name] + patternAttrs : [(Name,Name,Bool,Patterns)] + alternatives: + alternative Alias: + child field : {Name} + child attr : {Name} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + alternative Constr: + child name : {Constructor} + child pats : Patterns + visit 0: + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts ) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) +sem_Pattern (Constr _name _pats ) = + (sem_Pattern_Constr _name (sem_Patterns _pats ) ) +sem_Pattern (Product _pos _pats ) = + (sem_Pattern_Product _pos (sem_Patterns _pats ) ) +sem_Pattern (Underscore _pos ) = + (sem_Pattern_Underscore _pos ) +-- semantic domain +newtype T_Pattern = T_Pattern ((Map Name Type) -> + (Map AltAttr Vertex) -> + Identifier -> + Attributes -> + Identifier -> + Attributes -> + ( Pattern,(Seq Error),([AltAttr]),([Name]),([Name]),([(Name,Name,Bool,Patterns)]))) +data Inh_Pattern = Inh_Pattern {allTypeSigs_Inh_Pattern :: Map Name Type,altAttrs_Inh_Pattern :: Map AltAttr Vertex,con_Inh_Pattern :: Identifier,inh_Inh_Pattern :: Attributes,nt_Inh_Pattern :: Identifier,syn_Inh_Pattern :: Attributes} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,errors_Syn_Pattern :: Seq Error,gathAltAttrs_Syn_Pattern :: [AltAttr],instVars_Syn_Pattern :: [Name],locVars_Syn_Pattern :: [Name],patternAttrs_Syn_Pattern :: [(Name,Name,Bool,Patterns)]} +wrap_Pattern (T_Pattern sem ) (Inh_Pattern _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn ) = + (let ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs) = + (sem _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn ) + in (Syn_Pattern _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs )) +sem_Pattern_Alias :: Name -> + Name -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = + (T_Pattern (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + _lhsOlocVars :: ([Name]) + _lhsOinstVars :: ([Name]) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _patOallTypeSigs :: (Map Name Type) + _patOaltAttrs :: (Map AltAttr Vertex) + _patOcon :: Identifier + _patOinh :: Attributes + _patOnt :: Identifier + _patOsyn :: Attributes + _partsOallTypeSigs :: (Map Name Type) + _partsOaltAttrs :: (Map AltAttr Vertex) + _partsOcon :: Identifier + _partsOinh :: Attributes + _partsOnt :: Identifier + _partsOsyn :: Attributes + _patIcopy :: Pattern + _patIerrors :: (Seq Error) + _patIgathAltAttrs :: ([AltAttr]) + _patIinstVars :: ([Name]) + _patIlocVars :: ([Name]) + _patIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + _partsIcopy :: Patterns + _partsIerrors :: (Seq Error) + _partsIgathAltAttrs :: ([AltAttr]) + _partsIinstVars :: ([Name]) + _partsIlocVars :: ([Name]) + _partsIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + -- "Order.ag"(line 160, column 12) + _lhsOgathAltAttrs = + [AltAttr field_ attr_ (field_ == _LOC || field_ == _INST)] + -- "Order.ag"(line 227, column 12) + _lhsOpatternAttrs = + [(field_,attr_,(field_ == _LOC || field_ == _INST),_partsIcopy)] + -- "Order.ag"(line 536, column 14) + _lhsOlocVars = + if field_ == _LOC + then [attr_] + else [] + -- "Order.ag"(line 539, column 14) + _lhsOinstVars = + if field_ == _INST + then [attr_] + else [] + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _patIerrors Seq.<> _partsIerrors + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _patOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _patOcon = + _lhsIcon + -- copy rule (down) + _patOinh = + _lhsIinh + -- copy rule (down) + _patOnt = + _lhsInt + -- copy rule (down) + _patOsyn = + _lhsIsyn + -- copy rule (down) + _partsOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _partsOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _partsOcon = + _lhsIcon + -- copy rule (down) + _partsOinh = + _lhsIinh + -- copy rule (down) + _partsOnt = + _lhsInt + -- copy rule (down) + _partsOsyn = + _lhsIsyn + ( _patIcopy,_patIerrors,_patIgathAltAttrs,_patIinstVars,_patIlocVars,_patIpatternAttrs) = + (pat_ _patOallTypeSigs _patOaltAttrs _patOcon _patOinh _patOnt _patOsyn ) + ( _partsIcopy,_partsIerrors,_partsIgathAltAttrs,_partsIinstVars,_partsIlocVars,_partsIpatternAttrs) = + (parts_ _partsOallTypeSigs _partsOaltAttrs _partsOcon _partsOinh _partsOnt _partsOsyn ) + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) +sem_Pattern_Constr :: Constructor -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_ ) = + (T_Pattern (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Name]) + _lhsOlocVars :: ([Name]) + _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + _lhsOcopy :: Pattern + _patsOallTypeSigs :: (Map Name Type) + _patsOaltAttrs :: (Map AltAttr Vertex) + _patsOcon :: Identifier + _patsOinh :: Attributes + _patsOnt :: Identifier + _patsOsyn :: Attributes + _patsIcopy :: Patterns + _patsIerrors :: (Seq Error) + _patsIgathAltAttrs :: ([AltAttr]) + _patsIinstVars :: ([Name]) + _patsIlocVars :: ([Name]) + _patsIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _patsIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _patsIgathAltAttrs + -- use rule "Order.ag"(line 533, column 80) + _lhsOinstVars = + _patsIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _patsIlocVars + -- use rule "Order.ag"(line 224, column 42) + _lhsOpatternAttrs = + _patsIpatternAttrs + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patsOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _patsOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOinh = + _lhsIinh + -- copy rule (down) + _patsOnt = + _lhsInt + -- copy rule (down) + _patsOsyn = + _lhsIsyn + ( _patsIcopy,_patsIerrors,_patsIgathAltAttrs,_patsIinstVars,_patsIlocVars,_patsIpatternAttrs) = + (pats_ _patsOallTypeSigs _patsOaltAttrs _patsOcon _patsOinh _patsOnt _patsOsyn ) + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_ ) = + (T_Pattern (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Name]) + _lhsOlocVars :: ([Name]) + _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + _lhsOcopy :: Pattern + _patsOallTypeSigs :: (Map Name Type) + _patsOaltAttrs :: (Map AltAttr Vertex) + _patsOcon :: Identifier + _patsOinh :: Attributes + _patsOnt :: Identifier + _patsOsyn :: Attributes + _patsIcopy :: Patterns + _patsIerrors :: (Seq Error) + _patsIgathAltAttrs :: ([AltAttr]) + _patsIinstVars :: ([Name]) + _patsIlocVars :: ([Name]) + _patsIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _patsIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _patsIgathAltAttrs + -- use rule "Order.ag"(line 533, column 80) + _lhsOinstVars = + _patsIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _patsIlocVars + -- use rule "Order.ag"(line 224, column 42) + _lhsOpatternAttrs = + _patsIpatternAttrs + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patsOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _patsOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOinh = + _lhsIinh + -- copy rule (down) + _patsOnt = + _lhsInt + -- copy rule (down) + _patsOsyn = + _lhsIsyn + ( _patsIcopy,_patsIerrors,_patsIgathAltAttrs,_patsIinstVars,_patsIlocVars,_patsIpatternAttrs) = + (pats_ _patsOallTypeSigs _patsOaltAttrs _patsOcon _patsOinh _patsOnt _patsOsyn ) + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Name]) + _lhsOlocVars :: ([Name]) + _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + _lhsOcopy :: Pattern + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + [] + -- use rule "Order.ag"(line 533, column 80) + _lhsOinstVars = + [] + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + [] + -- use rule "Order.ag"(line 224, column 42) + _lhsOpatternAttrs = + [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) +-- Patterns ---------------------------------------------------- +{- + visit 0: + inherited attributes: + allTypeSigs : Map Name Type + altAttrs : Map AltAttr Vertex + con : Identifier + inh : Attributes + nt : Identifier + syn : Attributes + synthesized attributes: + copy : SELF + errors : Seq Error + gathAltAttrs : [AltAttr] + instVars : [Name] + locVars : [Name] + patternAttrs : [(Name,Name,Bool,Patterns)] + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) +-- semantic domain +newtype T_Patterns = T_Patterns ((Map Name Type) -> + (Map AltAttr Vertex) -> + Identifier -> + Attributes -> + Identifier -> + Attributes -> + ( Patterns,(Seq Error),([AltAttr]),([Name]),([Name]),([(Name,Name,Bool,Patterns)]))) +data Inh_Patterns = Inh_Patterns {allTypeSigs_Inh_Patterns :: Map Name Type,altAttrs_Inh_Patterns :: Map AltAttr Vertex,con_Inh_Patterns :: Identifier,inh_Inh_Patterns :: Attributes,nt_Inh_Patterns :: Identifier,syn_Inh_Patterns :: Attributes} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,errors_Syn_Patterns :: Seq Error,gathAltAttrs_Syn_Patterns :: [AltAttr],instVars_Syn_Patterns :: [Name],locVars_Syn_Patterns :: [Name],patternAttrs_Syn_Patterns :: [(Name,Name,Bool,Patterns)]} +wrap_Patterns (T_Patterns sem ) (Inh_Patterns _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn ) = + (let ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs) = + (sem _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn ) + in (Syn_Patterns _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs )) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = + (T_Patterns (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Name]) + _lhsOlocVars :: ([Name]) + _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + _lhsOcopy :: Patterns + _hdOallTypeSigs :: (Map Name Type) + _hdOaltAttrs :: (Map AltAttr Vertex) + _hdOcon :: Identifier + _hdOinh :: Attributes + _hdOnt :: Identifier + _hdOsyn :: Attributes + _tlOallTypeSigs :: (Map Name Type) + _tlOaltAttrs :: (Map AltAttr Vertex) + _tlOcon :: Identifier + _tlOinh :: Attributes + _tlOnt :: Identifier + _tlOsyn :: Attributes + _hdIcopy :: Pattern + _hdIerrors :: (Seq Error) + _hdIgathAltAttrs :: ([AltAttr]) + _hdIinstVars :: ([Name]) + _hdIlocVars :: ([Name]) + _hdIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + _tlIcopy :: Patterns + _tlIerrors :: (Seq Error) + _tlIgathAltAttrs :: ([AltAttr]) + _tlIinstVars :: ([Name]) + _tlIlocVars :: ([Name]) + _tlIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _hdIgathAltAttrs ++ _tlIgathAltAttrs + -- use rule "Order.ag"(line 533, column 80) + _lhsOinstVars = + _hdIinstVars ++ _tlIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _hdIlocVars ++ _tlIlocVars + -- use rule "Order.ag"(line 224, column 42) + _lhsOpatternAttrs = + _hdIpatternAttrs ++ _tlIpatternAttrs + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _hdOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _hdOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _tlOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _tlOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOsyn = + _lhsIsyn + ( _hdIcopy,_hdIerrors,_hdIgathAltAttrs,_hdIinstVars,_hdIlocVars,_hdIpatternAttrs) = + (hd_ _hdOallTypeSigs _hdOaltAttrs _hdOcon _hdOinh _hdOnt _hdOsyn ) + ( _tlIcopy,_tlIerrors,_tlIgathAltAttrs,_tlIinstVars,_tlIlocVars,_tlIpatternAttrs) = + (tl_ _tlOallTypeSigs _tlOaltAttrs _tlOcon _tlOinh _tlOnt _tlOsyn ) + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Name]) + _lhsOlocVars :: ([Name]) + _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + _lhsOcopy :: Patterns + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + [] + -- use rule "Order.ag"(line 533, column 80) + _lhsOinstVars = + [] + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + [] + -- use rule "Order.ag"(line 224, column 42) + _lhsOpatternAttrs = + [] + -- self rule + _copy = + [] + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) +-- Production -------------------------------------------------- +{- + visit 0: + inherited attributes: + allnts : [Name] + cInterfaceMap : CInterfaceMap + cVisitsMap : CVisitsMap + manualAttrDepMap : AttrOrderMap + o_case : Bool + o_cata : Bool + o_data : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_unbox : Bool + o_wantvisit : Bool + prefix : String + chained attributes: + acount : Int + vcount : Int + synthesized attributes: + additionalDep : Seq Edge + aranges : Seq (Int,Int,Int) + cProduction : CProduction + directDep : Seq Edge + errors : Seq Error + instDep : Seq Edge + ntattrs : Seq (Vertex,NTAttr) + prods : [(Nonterminal,[Constructor])] + rules : Seq (Vertex,CRule) + alternatives: + alternative Production: + child nt : {Nonterminal} + child inh : {Attributes} + child syn : {Attributes} + child alts : Alternatives + visit 0: + local ntattrs : _ + local cInter : _ +-} +-- cata +sem_Production :: Production -> + T_Production +sem_Production (Production _nt _inh _syn _alts ) = + (sem_Production_Production _nt _inh _syn (sem_Alternatives _alts ) ) +-- semantic domain +newtype T_Production = T_Production (Int -> + ([Name]) -> + CInterfaceMap -> + CVisitsMap -> + AttrOrderMap -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Int -> + ( Int,(Seq Edge),(Seq (Int,Int,Int)),CProduction,(Seq Edge),(Seq Error),(Seq Edge),(Seq (Vertex,NTAttr)),([(Nonterminal,[Constructor])]),(Seq (Vertex,CRule)),Int)) +data Inh_Production = Inh_Production {acount_Inh_Production :: Int,allnts_Inh_Production :: [Name],cInterfaceMap_Inh_Production :: CInterfaceMap,cVisitsMap_Inh_Production :: CVisitsMap,manualAttrDepMap_Inh_Production :: AttrOrderMap,o_case_Inh_Production :: Bool,o_cata_Inh_Production :: Bool,o_data_Inh_Production :: Bool,o_dovisit_Inh_Production :: Bool,o_newtypes_Inh_Production :: Bool,o_rename_Inh_Production :: Bool,o_sem_Inh_Production :: Bool,o_sig_Inh_Production :: Bool,o_unbox_Inh_Production :: Bool,o_wantvisit_Inh_Production :: Bool,prefix_Inh_Production :: String,vcount_Inh_Production :: Int} +data Syn_Production = Syn_Production {acount_Syn_Production :: Int,additionalDep_Syn_Production :: Seq Edge,aranges_Syn_Production :: Seq (Int,Int,Int),cProduction_Syn_Production :: CProduction,directDep_Syn_Production :: Seq Edge,errors_Syn_Production :: Seq Error,instDep_Syn_Production :: Seq Edge,ntattrs_Syn_Production :: Seq (Vertex,NTAttr),prods_Syn_Production :: [(Nonterminal,[Constructor])],rules_Syn_Production :: Seq (Vertex,CRule),vcount_Syn_Production :: Int} +wrap_Production (T_Production sem ) (Inh_Production _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount ) = + (let ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcProduction,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOntattrs,_lhsOprods,_lhsOrules,_lhsOvcount) = + (sem _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount ) + in (Syn_Production _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOcProduction _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOntattrs _lhsOprods _lhsOrules _lhsOvcount )) +sem_Production_Production :: Nonterminal -> + Attributes -> + Attributes -> + T_Alternatives -> + T_Production +sem_Production_Production nt_ inh_ syn_ (T_Alternatives alts_ ) = + (T_Production (\ _lhsIacount + _lhsIallnts + _lhsIcInterfaceMap + _lhsIcVisitsMap + _lhsImanualAttrDepMap + _lhsIo_case + _lhsIo_cata + _lhsIo_data + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIvcount -> + (let _altsOnt :: Identifier + _altsOinh :: Attributes + _altsOsyn :: Attributes + _lhsOntattrs :: (Seq (Vertex,NTAttr)) + _lhsOacount :: Int + _lhsOaranges :: (Seq (Int,Int,Int)) + _lhsOprods :: ([(Nonterminal,[Constructor])]) + _lhsOcProduction :: CProduction + _lhsOadditionalDep :: (Seq Edge) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOvcount :: Int + _altsOallnts :: ([Name]) + _altsOcVisitsMap :: CVisitsMap + _altsOmanualAttrDepMap :: AttrOrderMap + _altsOo_case :: Bool + _altsOo_cata :: Bool + _altsOo_dovisit :: Bool + _altsOo_newtypes :: Bool + _altsOo_rename :: Bool + _altsOo_sem :: Bool + _altsOo_sig :: Bool + _altsOo_unbox :: Bool + _altsOo_wantvisit :: Bool + _altsOprefix :: String + _altsOvcount :: Int + _altsIadditionalDep :: (Seq Edge) + _altsIcAlternatives :: CAlternatives + _altsIcons :: ([Constructor]) + _altsIdirectDep :: (Seq Edge) + _altsIerrors :: (Seq Error) + _altsIinstDep :: (Seq Edge) + _altsIrules :: (Seq (Vertex,CRule)) + _altsIvcount :: Int + -- "Order.ag"(line 73, column 16) + _altsOnt = + nt_ + -- "Order.ag"(line 76, column 16) + _altsOinh = + inh_ + -- "Order.ag"(line 77, column 16) + _altsOsyn = + syn_ + -- "Order.ag"(line 368, column 16) + _ntattrs = + [ NTAInh nt_ inh tp | (inh,tp) <- Map.assocs inh_ ] + ++ [NTASyn nt_ syn tp | (syn,tp) <- Map.assocs syn_ ] + -- "Order.ag"(line 370, column 16) + _lhsOntattrs = + Seq.fromList (zip [_lhsIacount ..] _ntattrs) + -- "Order.ag"(line 371, column 16) + _lhsOacount = + _lhsIacount + Map.size inh_ + Map.size syn_ + -- "Order.ag"(line 372, column 16) + _lhsOaranges = + Seq.single + (_lhsIacount + ,_lhsIacount + Map.size inh_ + ,_lhsIacount + Map.size syn_ + Map.size inh_ - 1) + -- "Order.ag"(line 381, column 18) + _lhsOprods = + [(nt_,_altsIcons)] + -- "Order.ag"(line 456, column 18) + _cInter = + if _lhsIo_dovisit + then findWithErr1 "Production.cInter" nt_ _lhsIcInterfaceMap + else CInterface [CSegment inh_ syn_] + -- "Order.ag"(line 484, column 18) + _lhsOcProduction = + CProduction nt_ inh_ syn_ _altsIcAlternatives _cInter + -- use rule "Order.ag"(line 258, column 71) + _lhsOadditionalDep = + _altsIadditionalDep + -- use rule "Order.ag"(line 244, column 33) + _lhsOdirectDep = + _altsIdirectDep + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _altsIerrors + -- use rule "Order.ag"(line 289, column 31) + _lhsOinstDep = + _altsIinstDep + -- use rule "Order.ag"(line 234, column 18) + _lhsOrules = + _altsIrules + -- copy rule (up) + _lhsOvcount = + _altsIvcount + -- copy rule (down) + _altsOallnts = + _lhsIallnts + -- copy rule (down) + _altsOcVisitsMap = + _lhsIcVisitsMap + -- copy rule (down) + _altsOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _altsOo_case = + _lhsIo_case + -- copy rule (down) + _altsOo_cata = + _lhsIo_cata + -- copy rule (down) + _altsOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _altsOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _altsOo_rename = + _lhsIo_rename + -- copy rule (down) + _altsOo_sem = + _lhsIo_sem + -- copy rule (down) + _altsOo_sig = + _lhsIo_sig + -- copy rule (down) + _altsOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _altsOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _altsOprefix = + _lhsIprefix + -- copy rule (down) + _altsOvcount = + _lhsIvcount + ( _altsIadditionalDep,_altsIcAlternatives,_altsIcons,_altsIdirectDep,_altsIerrors,_altsIinstDep,_altsIrules,_altsIvcount) = + (alts_ _altsOallnts _altsOcVisitsMap _altsOinh _altsOmanualAttrDepMap _altsOnt _altsOo_case _altsOo_cata _altsOo_dovisit _altsOo_newtypes _altsOo_rename _altsOo_sem _altsOo_sig _altsOo_unbox _altsOo_wantvisit _altsOprefix _altsOsyn _altsOvcount ) + in ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcProduction,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOntattrs,_lhsOprods,_lhsOrules,_lhsOvcount))) ) +-- Productions ------------------------------------------------- +{- + visit 0: + inherited attributes: + allnts : [Name] + cInterfaceMap : CInterfaceMap + cVisitsMap : CVisitsMap + manualAttrDepMap : AttrOrderMap + o_case : Bool + o_cata : Bool + o_data : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_unbox : Bool + o_wantvisit : Bool + prefix : String + chained attributes: + acount : Int + vcount : Int + synthesized attributes: + additionalDep : Seq Edge + aranges : Seq (Int,Int,Int) + cProductions : CProductions + directDep : Seq Edge + errors : Seq Error + instDep : Seq Edge + ntattrs : Seq (Vertex,NTAttr) + prods : [(Nonterminal,[Constructor])] + rules : Seq (Vertex,CRule) + alternatives: + alternative Cons: + child hd : Production + child tl : Productions + alternative Nil: +-} +-- cata +sem_Productions :: Productions -> + T_Productions +sem_Productions list = + (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) ) +-- semantic domain +newtype T_Productions = T_Productions (Int -> + ([Name]) -> + CInterfaceMap -> + CVisitsMap -> + AttrOrderMap -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Int -> + ( Int,(Seq Edge),(Seq (Int,Int,Int)),CProductions,(Seq Edge),(Seq Error),(Seq Edge),(Seq (Vertex,NTAttr)),([(Nonterminal,[Constructor])]),(Seq (Vertex,CRule)),Int)) +data Inh_Productions = Inh_Productions {acount_Inh_Productions :: Int,allnts_Inh_Productions :: [Name],cInterfaceMap_Inh_Productions :: CInterfaceMap,cVisitsMap_Inh_Productions :: CVisitsMap,manualAttrDepMap_Inh_Productions :: AttrOrderMap,o_case_Inh_Productions :: Bool,o_cata_Inh_Productions :: Bool,o_data_Inh_Productions :: Bool,o_dovisit_Inh_Productions :: Bool,o_newtypes_Inh_Productions :: Bool,o_rename_Inh_Productions :: Bool,o_sem_Inh_Productions :: Bool,o_sig_Inh_Productions :: Bool,o_unbox_Inh_Productions :: Bool,o_wantvisit_Inh_Productions :: Bool,prefix_Inh_Productions :: String,vcount_Inh_Productions :: Int} +data Syn_Productions = Syn_Productions {acount_Syn_Productions :: Int,additionalDep_Syn_Productions :: Seq Edge,aranges_Syn_Productions :: Seq (Int,Int,Int),cProductions_Syn_Productions :: CProductions,directDep_Syn_Productions :: Seq Edge,errors_Syn_Productions :: Seq Error,instDep_Syn_Productions :: Seq Edge,ntattrs_Syn_Productions :: Seq (Vertex,NTAttr),prods_Syn_Productions :: [(Nonterminal,[Constructor])],rules_Syn_Productions :: Seq (Vertex,CRule),vcount_Syn_Productions :: Int} +wrap_Productions (T_Productions sem ) (Inh_Productions _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount ) = + (let ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcProductions,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOntattrs,_lhsOprods,_lhsOrules,_lhsOvcount) = + (sem _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount ) + in (Syn_Productions _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOcProductions _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOntattrs _lhsOprods _lhsOrules _lhsOvcount )) +sem_Productions_Cons :: T_Production -> + T_Productions -> + T_Productions +sem_Productions_Cons (T_Production hd_ ) (T_Productions tl_ ) = + (T_Productions (\ _lhsIacount + _lhsIallnts + _lhsIcInterfaceMap + _lhsIcVisitsMap + _lhsImanualAttrDepMap + _lhsIo_case + _lhsIo_cata + _lhsIo_data + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIvcount -> + (let _lhsOcProductions :: CProductions + _lhsOadditionalDep :: (Seq Edge) + _lhsOaranges :: (Seq (Int,Int,Int)) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _lhsOntattrs :: (Seq (Vertex,NTAttr)) + _lhsOprods :: ([(Nonterminal,[Constructor])]) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOacount :: Int + _lhsOvcount :: Int + _hdOacount :: Int + _hdOallnts :: ([Name]) + _hdOcInterfaceMap :: CInterfaceMap + _hdOcVisitsMap :: CVisitsMap + _hdOmanualAttrDepMap :: AttrOrderMap + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_data :: Bool + _hdOo_dovisit :: Bool + _hdOo_newtypes :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_unbox :: Bool + _hdOo_wantvisit :: Bool + _hdOprefix :: String + _hdOvcount :: Int + _tlOacount :: Int + _tlOallnts :: ([Name]) + _tlOcInterfaceMap :: CInterfaceMap + _tlOcVisitsMap :: CVisitsMap + _tlOmanualAttrDepMap :: AttrOrderMap + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_data :: Bool + _tlOo_dovisit :: Bool + _tlOo_newtypes :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_unbox :: Bool + _tlOo_wantvisit :: Bool + _tlOprefix :: String + _tlOvcount :: Int + _hdIacount :: Int + _hdIadditionalDep :: (Seq Edge) + _hdIaranges :: (Seq (Int,Int,Int)) + _hdIcProduction :: CProduction + _hdIdirectDep :: (Seq Edge) + _hdIerrors :: (Seq Error) + _hdIinstDep :: (Seq Edge) + _hdIntattrs :: (Seq (Vertex,NTAttr)) + _hdIprods :: ([(Nonterminal,[Constructor])]) + _hdIrules :: (Seq (Vertex,CRule)) + _hdIvcount :: Int + _tlIacount :: Int + _tlIadditionalDep :: (Seq Edge) + _tlIaranges :: (Seq (Int,Int,Int)) + _tlIcProductions :: CProductions + _tlIdirectDep :: (Seq Edge) + _tlIerrors :: (Seq Error) + _tlIinstDep :: (Seq Edge) + _tlIntattrs :: (Seq (Vertex,NTAttr)) + _tlIprods :: ([(Nonterminal,[Constructor])]) + _tlIrules :: (Seq (Vertex,CRule)) + _tlIvcount :: Int + -- "Order.ag"(line 481, column 12) + _lhsOcProductions = + _hdIcProduction : _tlIcProductions + -- use rule "Order.ag"(line 258, column 71) + _lhsOadditionalDep = + _hdIadditionalDep Seq.<> _tlIadditionalDep + -- use rule "Order.ag"(line 362, column 36) + _lhsOaranges = + _hdIaranges Seq.<> _tlIaranges + -- use rule "Order.ag"(line 244, column 33) + _lhsOdirectDep = + _hdIdirectDep Seq.<> _tlIdirectDep + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Order.ag"(line 289, column 31) + _lhsOinstDep = + _hdIinstDep Seq.<> _tlIinstDep + -- use rule "Order.ag"(line 361, column 35) + _lhsOntattrs = + _hdIntattrs Seq.<> _tlIntattrs + -- use rule "Order.ag"(line 379, column 41) + _lhsOprods = + _hdIprods ++ _tlIprods + -- use rule "Order.ag"(line 234, column 18) + _lhsOrules = + _hdIrules Seq.<> _tlIrules + -- copy rule (up) + _lhsOacount = + _tlIacount + -- copy rule (up) + _lhsOvcount = + _tlIvcount + -- copy rule (down) + _hdOacount = + _lhsIacount + -- copy rule (down) + _hdOallnts = + _lhsIallnts + -- copy rule (down) + _hdOcInterfaceMap = + _lhsIcInterfaceMap + -- copy rule (down) + _hdOcVisitsMap = + _lhsIcVisitsMap + -- copy rule (down) + _hdOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOvcount = + _lhsIvcount + -- copy rule (chain) + _tlOacount = + _hdIacount + -- copy rule (down) + _tlOallnts = + _lhsIallnts + -- copy rule (down) + _tlOcInterfaceMap = + _lhsIcInterfaceMap + -- copy rule (down) + _tlOcVisitsMap = + _lhsIcVisitsMap + -- copy rule (down) + _tlOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (chain) + _tlOvcount = + _hdIvcount + ( _hdIacount,_hdIadditionalDep,_hdIaranges,_hdIcProduction,_hdIdirectDep,_hdIerrors,_hdIinstDep,_hdIntattrs,_hdIprods,_hdIrules,_hdIvcount) = + (hd_ _hdOacount _hdOallnts _hdOcInterfaceMap _hdOcVisitsMap _hdOmanualAttrDepMap _hdOo_case _hdOo_cata _hdOo_data _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOprefix _hdOvcount ) + ( _tlIacount,_tlIadditionalDep,_tlIaranges,_tlIcProductions,_tlIdirectDep,_tlIerrors,_tlIinstDep,_tlIntattrs,_tlIprods,_tlIrules,_tlIvcount) = + (tl_ _tlOacount _tlOallnts _tlOcInterfaceMap _tlOcVisitsMap _tlOmanualAttrDepMap _tlOo_case _tlOo_cata _tlOo_data _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOprefix _tlOvcount ) + in ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcProductions,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOntattrs,_lhsOprods,_lhsOrules,_lhsOvcount))) ) +sem_Productions_Nil :: T_Productions +sem_Productions_Nil = + (T_Productions (\ _lhsIacount + _lhsIallnts + _lhsIcInterfaceMap + _lhsIcVisitsMap + _lhsImanualAttrDepMap + _lhsIo_case + _lhsIo_cata + _lhsIo_data + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIvcount -> + (let _lhsOcProductions :: CProductions + _lhsOadditionalDep :: (Seq Edge) + _lhsOaranges :: (Seq (Int,Int,Int)) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _lhsOntattrs :: (Seq (Vertex,NTAttr)) + _lhsOprods :: ([(Nonterminal,[Constructor])]) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOacount :: Int + _lhsOvcount :: Int + -- "Order.ag"(line 482, column 12) + _lhsOcProductions = + [] + -- use rule "Order.ag"(line 258, column 71) + _lhsOadditionalDep = + Seq.empty + -- use rule "Order.ag"(line 362, column 36) + _lhsOaranges = + Seq.empty + -- use rule "Order.ag"(line 244, column 33) + _lhsOdirectDep = + Seq.empty + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 289, column 31) + _lhsOinstDep = + Seq.empty + -- use rule "Order.ag"(line 361, column 35) + _lhsOntattrs = + Seq.empty + -- use rule "Order.ag"(line 379, column 41) + _lhsOprods = + [] + -- use rule "Order.ag"(line 234, column 18) + _lhsOrules = + Seq.empty + -- copy rule (chain) + _lhsOacount = + _lhsIacount + -- copy rule (chain) + _lhsOvcount = + _lhsIvcount + in ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcProductions,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOntattrs,_lhsOprods,_lhsOrules,_lhsOvcount))) ) +-- Rule -------------------------------------------------------- +{- + visit 0: + inherited attributes: + allTypeSigs : Map Name Type + allfields : [(Name,Type,Bool)] + allnts : [Name] + altAttrs : Map AltAttr Vertex + attrs : [(Name,Name)] + childInhs : Map Name Attributes + childNts : Map Name Nonterminal + con : Identifier + inh : Attributes + manualAttrDepMap : AttrOrderMap + nt : Identifier + o_case : Bool + o_cata : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_wantvisit : Bool + prefix : String + syn : Attributes + synsOfChildren : Map Name Attributes + synthesized attributes: + additionalDep : Seq Edge + directDep : Seq Edge + errors : Seq Error + gathAltAttrs : [AltAttr] + gathRules : Seq CRule + instDep : Seq Edge + instVars : [Name] + locVars : [Name] + alternatives: + alternative Rule: + child pattern : Pattern + child rhs : Expression + child owrt : {Bool} + child origin : {String} + visit 0: + local defines : _ + local gathRules : _ + local manualDeps : _ +-} +-- cata +sem_Rule :: Rule -> + T_Rule +sem_Rule (Rule _pattern _rhs _owrt _origin ) = + (sem_Rule_Rule (sem_Pattern _pattern ) (sem_Expression _rhs ) _owrt _origin ) +-- semantic domain +newtype T_Rule = T_Rule ((Map Name Type) -> + ([(Name,Type,Bool)]) -> + ([Name]) -> + (Map AltAttr Vertex) -> + ([(Name,Name)]) -> + (Map Name Attributes) -> + (Map Name Nonterminal) -> + Identifier -> + Attributes -> + AttrOrderMap -> + Identifier -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + (Map Name Attributes) -> + ( (Seq Edge),(Seq Edge),(Seq Error),([AltAttr]),(Seq CRule),(Seq Edge),([Name]),([Name]))) +data Inh_Rule = Inh_Rule {allTypeSigs_Inh_Rule :: Map Name Type,allfields_Inh_Rule :: [(Name,Type,Bool)],allnts_Inh_Rule :: [Name],altAttrs_Inh_Rule :: Map AltAttr Vertex,attrs_Inh_Rule :: [(Name,Name)],childInhs_Inh_Rule :: Map Name Attributes,childNts_Inh_Rule :: Map Name Nonterminal,con_Inh_Rule :: Identifier,inh_Inh_Rule :: Attributes,manualAttrDepMap_Inh_Rule :: AttrOrderMap,nt_Inh_Rule :: Identifier,o_case_Inh_Rule :: Bool,o_cata_Inh_Rule :: Bool,o_dovisit_Inh_Rule :: Bool,o_newtypes_Inh_Rule :: Bool,o_rename_Inh_Rule :: Bool,o_sem_Inh_Rule :: Bool,o_sig_Inh_Rule :: Bool,o_wantvisit_Inh_Rule :: Bool,prefix_Inh_Rule :: String,syn_Inh_Rule :: Attributes,synsOfChildren_Inh_Rule :: Map Name Attributes} +data Syn_Rule = Syn_Rule {additionalDep_Syn_Rule :: Seq Edge,directDep_Syn_Rule :: Seq Edge,errors_Syn_Rule :: Seq Error,gathAltAttrs_Syn_Rule :: [AltAttr],gathRules_Syn_Rule :: Seq CRule,instDep_Syn_Rule :: Seq Edge,instVars_Syn_Rule :: [Name],locVars_Syn_Rule :: [Name]} +wrap_Rule (T_Rule sem ) (Inh_Rule _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren ) = + (let ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars) = + (sem _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren ) + in (Syn_Rule _lhsOadditionalDep _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars )) +sem_Rule_Rule :: T_Pattern -> + T_Expression -> + Bool -> + String -> + T_Rule +sem_Rule_Rule (T_Pattern pattern_ ) (T_Expression rhs_ ) owrt_ origin_ = + (T_Rule (\ _lhsIallTypeSigs + _lhsIallfields + _lhsIallnts + _lhsIaltAttrs + _lhsIattrs + _lhsIchildInhs + _lhsIchildNts + _lhsIcon + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIsynsOfChildren -> + (let _lhsOdirectDep :: (Seq Edge) + _lhsOadditionalDep :: (Seq Edge) + _lhsOinstDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOgathRules :: (Seq CRule) + _lhsOinstVars :: ([Name]) + _lhsOlocVars :: ([Name]) + _patternOallTypeSigs :: (Map Name Type) + _patternOaltAttrs :: (Map AltAttr Vertex) + _patternOcon :: Identifier + _patternOinh :: Attributes + _patternOnt :: Identifier + _patternOsyn :: Attributes + _rhsOallfields :: ([(Name,Type,Bool)]) + _rhsOallnts :: ([Name]) + _rhsOattrs :: ([(Name,Name)]) + _rhsOcon :: Name + _rhsOnt :: Name + _patternIcopy :: Pattern + _patternIerrors :: (Seq Error) + _patternIgathAltAttrs :: ([AltAttr]) + _patternIinstVars :: ([Name]) + _patternIlocVars :: ([Name]) + _patternIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) + _rhsIallRhsVars :: (Set (Name,Name)) + _rhsIcopy :: Expression + _rhsIerrors :: (Seq Error) + _rhsItextLines :: ([String]) + _rhsIusedAttrs :: ([(Name,Name)]) + _rhsIusedFields :: ([Name]) + _rhsIusedLocals :: ([Name]) + -- "Order.ag"(line 193, column 12) + _defines = + let tp field attr parts | field == _LOC || field == _INST + = case parts of + [] -> Map.lookup attr _lhsIallTypeSigs + _ -> (sequence (map typ parts)) >>= (haskellTupel . map (substSelf _lhsInt)) + | field == _LHS = Map.lookup attr _lhsIsyn + | otherwise = Map.lookup attr (findWithErr1 "Rule.defines.tp" field _lhsIchildInhs) + typ :: Pattern -> Maybe Type + typ (Alias field attr _ parts) = tp field attr parts + typ (Underscore _) = Nothing + typ (Product _ pats) = tp _LOC undefined pats + typ _ = Nothing + in Map.fromList [ (findWithErr1 "Rule.defines" aa _lhsIaltAttrs, (field,attr,(tp field attr parts))) + | (field,attr,isLocalOrInst,parts) <- _patternIpatternAttrs + , let aa = AltAttr field attr isLocalOrInst + ] + -- "Order.ag"(line 209, column 12) + _gathRules = + let childnt field = Map.lookup field _lhsIchildNts + in Seq.fromList [ CRule attr False True _lhsInt _lhsIcon field (childnt field) tp _patternIcopy _rhsItextLines _defines owrt_ origin_ _rhsIallRhsVars + | (field,attr,tp) <- Map.elems _defines + ] + -- "Order.ag"(line 246, column 12) + _lhsOdirectDep = + let defined = Map.keys _defines + used = [ Map.lookup (AltAttr field attr True) _lhsIaltAttrs | (field,attr) <- _rhsIusedAttrs] + ++ [ Map.lookup (AltAttr _LOC attr True) _lhsIaltAttrs | attr <- _rhsIusedLocals ++ _rhsIusedFields ] + in Seq.fromList [ (x,y) | Just x <- used, y <- defined ] + -- "Order.ag"(line 264, column 7) + _manualDeps = + Set.toList $ Map.findWithDefault Set.empty _lhsIcon $ Map.findWithDefault Map.empty _lhsInt _lhsImanualAttrDepMap + -- "Order.ag"(line 266, column 7) + _lhsOadditionalDep = + Seq.fromList [ (vertexA, vertexB) + | Dependency (fldA,nmA) (fldB,nmB) <- _manualDeps + , let vertexA = findWithErr2 (AltAttr fldA nmA True) _lhsIaltAttrs + , vertexB <- lookupVertices fldB nmB _lhsIaltAttrs + ] + -- "Order.ag"(line 292, column 7) + _lhsOinstDep = + Seq.fromList $ + [ (instVert, synVert) + | (field,instNm,_) <- Map.elems _defines + , field == _INST + , synNm <- Map.keys (findWithErr2 instNm _lhsIsynsOfChildren) + , let instAttr = AltAttr _INST instNm True + synAttr = AltAttr instNm synNm True + instVert = findWithErr2 instAttr _lhsIaltAttrs + synVert = findWithErr2 synAttr _lhsIaltAttrs + ] + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _patternIerrors Seq.<> _rhsIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _patternIgathAltAttrs + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + _gathRules + -- use rule "Order.ag"(line 533, column 80) + _lhsOinstVars = + _patternIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _patternIlocVars + -- copy rule (down) + _patternOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _patternOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _patternOcon = + _lhsIcon + -- copy rule (down) + _patternOinh = + _lhsIinh + -- copy rule (down) + _patternOnt = + _lhsInt + -- copy rule (down) + _patternOsyn = + _lhsIsyn + -- copy rule (down) + _rhsOallfields = + _lhsIallfields + -- copy rule (down) + _rhsOallnts = + _lhsIallnts + -- copy rule (down) + _rhsOattrs = + _lhsIattrs + -- copy rule (down) + _rhsOcon = + _lhsIcon + -- copy rule (down) + _rhsOnt = + _lhsInt + ( _patternIcopy,_patternIerrors,_patternIgathAltAttrs,_patternIinstVars,_patternIlocVars,_patternIpatternAttrs) = + (pattern_ _patternOallTypeSigs _patternOaltAttrs _patternOcon _patternOinh _patternOnt _patternOsyn ) + ( _rhsIallRhsVars,_rhsIcopy,_rhsIerrors,_rhsItextLines,_rhsIusedAttrs,_rhsIusedFields,_rhsIusedLocals) = + (rhs_ _rhsOallfields _rhsOallnts _rhsOattrs _rhsOcon _rhsOnt ) + in ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars))) ) +-- Rules ------------------------------------------------------- +{- + visit 0: + inherited attributes: + allTypeSigs : Map Name Type + allfields : [(Name,Type,Bool)] + allnts : [Name] + altAttrs : Map AltAttr Vertex + attrs : [(Name,Name)] + childInhs : Map Name Attributes + childNts : Map Name Nonterminal + con : Identifier + inh : Attributes + manualAttrDepMap : AttrOrderMap + nt : Identifier + o_case : Bool + o_cata : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_wantvisit : Bool + prefix : String + syn : Attributes + synsOfChildren : Map Name Attributes + synthesized attributes: + additionalDep : Seq Edge + directDep : Seq Edge + errors : Seq Error + gathAltAttrs : [AltAttr] + gathRules : Seq CRule + instDep : Seq Edge + instVars : [Name] + locVars : [Name] + alternatives: + alternative Cons: + child hd : Rule + child tl : Rules + alternative Nil: +-} +-- cata +sem_Rules :: Rules -> + T_Rules +sem_Rules list = + (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) ) +-- semantic domain +newtype T_Rules = T_Rules ((Map Name Type) -> + ([(Name,Type,Bool)]) -> + ([Name]) -> + (Map AltAttr Vertex) -> + ([(Name,Name)]) -> + (Map Name Attributes) -> + (Map Name Nonterminal) -> + Identifier -> + Attributes -> + AttrOrderMap -> + Identifier -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + (Map Name Attributes) -> + ( (Seq Edge),(Seq Edge),(Seq Error),([AltAttr]),(Seq CRule),(Seq Edge),([Name]),([Name]))) +data Inh_Rules = Inh_Rules {allTypeSigs_Inh_Rules :: Map Name Type,allfields_Inh_Rules :: [(Name,Type,Bool)],allnts_Inh_Rules :: [Name],altAttrs_Inh_Rules :: Map AltAttr Vertex,attrs_Inh_Rules :: [(Name,Name)],childInhs_Inh_Rules :: Map Name Attributes,childNts_Inh_Rules :: Map Name Nonterminal,con_Inh_Rules :: Identifier,inh_Inh_Rules :: Attributes,manualAttrDepMap_Inh_Rules :: AttrOrderMap,nt_Inh_Rules :: Identifier,o_case_Inh_Rules :: Bool,o_cata_Inh_Rules :: Bool,o_dovisit_Inh_Rules :: Bool,o_newtypes_Inh_Rules :: Bool,o_rename_Inh_Rules :: Bool,o_sem_Inh_Rules :: Bool,o_sig_Inh_Rules :: Bool,o_wantvisit_Inh_Rules :: Bool,prefix_Inh_Rules :: String,syn_Inh_Rules :: Attributes,synsOfChildren_Inh_Rules :: Map Name Attributes} +data Syn_Rules = Syn_Rules {additionalDep_Syn_Rules :: Seq Edge,directDep_Syn_Rules :: Seq Edge,errors_Syn_Rules :: Seq Error,gathAltAttrs_Syn_Rules :: [AltAttr],gathRules_Syn_Rules :: Seq CRule,instDep_Syn_Rules :: Seq Edge,instVars_Syn_Rules :: [Name],locVars_Syn_Rules :: [Name]} +wrap_Rules (T_Rules sem ) (Inh_Rules _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren ) = + (let ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars) = + (sem _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren ) + in (Syn_Rules _lhsOadditionalDep _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars )) +sem_Rules_Cons :: T_Rule -> + T_Rules -> + T_Rules +sem_Rules_Cons (T_Rule hd_ ) (T_Rules tl_ ) = + (T_Rules (\ _lhsIallTypeSigs + _lhsIallfields + _lhsIallnts + _lhsIaltAttrs + _lhsIattrs + _lhsIchildInhs + _lhsIchildNts + _lhsIcon + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIsynsOfChildren -> + (let _lhsOadditionalDep :: (Seq Edge) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOgathRules :: (Seq CRule) + _lhsOinstDep :: (Seq Edge) + _lhsOinstVars :: ([Name]) + _lhsOlocVars :: ([Name]) + _hdOallTypeSigs :: (Map Name Type) + _hdOallfields :: ([(Name,Type,Bool)]) + _hdOallnts :: ([Name]) + _hdOaltAttrs :: (Map AltAttr Vertex) + _hdOattrs :: ([(Name,Name)]) + _hdOchildInhs :: (Map Name Attributes) + _hdOchildNts :: (Map Name Nonterminal) + _hdOcon :: Identifier + _hdOinh :: Attributes + _hdOmanualAttrDepMap :: AttrOrderMap + _hdOnt :: Identifier + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_dovisit :: Bool + _hdOo_newtypes :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_wantvisit :: Bool + _hdOprefix :: String + _hdOsyn :: Attributes + _hdOsynsOfChildren :: (Map Name Attributes) + _tlOallTypeSigs :: (Map Name Type) + _tlOallfields :: ([(Name,Type,Bool)]) + _tlOallnts :: ([Name]) + _tlOaltAttrs :: (Map AltAttr Vertex) + _tlOattrs :: ([(Name,Name)]) + _tlOchildInhs :: (Map Name Attributes) + _tlOchildNts :: (Map Name Nonterminal) + _tlOcon :: Identifier + _tlOinh :: Attributes + _tlOmanualAttrDepMap :: AttrOrderMap + _tlOnt :: Identifier + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_dovisit :: Bool + _tlOo_newtypes :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_wantvisit :: Bool + _tlOprefix :: String + _tlOsyn :: Attributes + _tlOsynsOfChildren :: (Map Name Attributes) + _hdIadditionalDep :: (Seq Edge) + _hdIdirectDep :: (Seq Edge) + _hdIerrors :: (Seq Error) + _hdIgathAltAttrs :: ([AltAttr]) + _hdIgathRules :: (Seq CRule) + _hdIinstDep :: (Seq Edge) + _hdIinstVars :: ([Name]) + _hdIlocVars :: ([Name]) + _tlIadditionalDep :: (Seq Edge) + _tlIdirectDep :: (Seq Edge) + _tlIerrors :: (Seq Error) + _tlIgathAltAttrs :: ([AltAttr]) + _tlIgathRules :: (Seq CRule) + _tlIinstDep :: (Seq Edge) + _tlIinstVars :: ([Name]) + _tlIlocVars :: ([Name]) + -- use rule "Order.ag"(line 258, column 71) + _lhsOadditionalDep = + _hdIadditionalDep Seq.<> _tlIadditionalDep + -- use rule "Order.ag"(line 244, column 33) + _lhsOdirectDep = + _hdIdirectDep Seq.<> _tlIdirectDep + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _hdIgathAltAttrs ++ _tlIgathAltAttrs + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + _hdIgathRules Seq.<> _tlIgathRules + -- use rule "Order.ag"(line 289, column 31) + _lhsOinstDep = + _hdIinstDep Seq.<> _tlIinstDep + -- use rule "Order.ag"(line 533, column 80) + _lhsOinstVars = + _hdIinstVars ++ _tlIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _hdIlocVars ++ _tlIlocVars + -- copy rule (down) + _hdOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _hdOallfields = + _lhsIallfields + -- copy rule (down) + _hdOallnts = + _lhsIallnts + -- copy rule (down) + _hdOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _hdOattrs = + _lhsIattrs + -- copy rule (down) + _hdOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _hdOchildNts = + _lhsIchildNts + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOsynsOfChildren = + _lhsIsynsOfChildren + -- copy rule (down) + _tlOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _tlOallfields = + _lhsIallfields + -- copy rule (down) + _tlOallnts = + _lhsIallnts + -- copy rule (down) + _tlOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _tlOattrs = + _lhsIattrs + -- copy rule (down) + _tlOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _tlOchildNts = + _lhsIchildNts + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (down) + _tlOsynsOfChildren = + _lhsIsynsOfChildren + ( _hdIadditionalDep,_hdIdirectDep,_hdIerrors,_hdIgathAltAttrs,_hdIgathRules,_hdIinstDep,_hdIinstVars,_hdIlocVars) = + (hd_ _hdOallTypeSigs _hdOallfields _hdOallnts _hdOaltAttrs _hdOattrs _hdOchildInhs _hdOchildNts _hdOcon _hdOinh _hdOmanualAttrDepMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_wantvisit _hdOprefix _hdOsyn _hdOsynsOfChildren ) + ( _tlIadditionalDep,_tlIdirectDep,_tlIerrors,_tlIgathAltAttrs,_tlIgathRules,_tlIinstDep,_tlIinstVars,_tlIlocVars) = + (tl_ _tlOallTypeSigs _tlOallfields _tlOallnts _tlOaltAttrs _tlOattrs _tlOchildInhs _tlOchildNts _tlOcon _tlOinh _tlOmanualAttrDepMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_wantvisit _tlOprefix _tlOsyn _tlOsynsOfChildren ) + in ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars))) ) +sem_Rules_Nil :: T_Rules +sem_Rules_Nil = + (T_Rules (\ _lhsIallTypeSigs + _lhsIallfields + _lhsIallnts + _lhsIaltAttrs + _lhsIattrs + _lhsIchildInhs + _lhsIchildNts + _lhsIcon + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIsynsOfChildren -> + (let _lhsOadditionalDep :: (Seq Edge) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOgathRules :: (Seq CRule) + _lhsOinstDep :: (Seq Edge) + _lhsOinstVars :: ([Name]) + _lhsOlocVars :: ([Name]) + -- use rule "Order.ag"(line 258, column 71) + _lhsOadditionalDep = + Seq.empty + -- use rule "Order.ag"(line 244, column 33) + _lhsOdirectDep = + Seq.empty + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + [] + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + Seq.empty + -- use rule "Order.ag"(line 289, column 31) + _lhsOinstDep = + Seq.empty + -- use rule "Order.ag"(line 533, column 80) + _lhsOinstVars = + [] + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + [] + in ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars))) ) +-- TypeSig ----------------------------------------------------- +{- + visit 0: + chained attribute: + typeSigs : Map Name Type + alternatives: + alternative TypeSig: + child name : {Name} + child tp : {Type} +-} +-- cata +sem_TypeSig :: TypeSig -> + T_TypeSig +sem_TypeSig (TypeSig _name _tp ) = + (sem_TypeSig_TypeSig _name _tp ) +-- semantic domain +newtype T_TypeSig = T_TypeSig ((Map Name Type) -> + ( (Map Name Type))) +data Inh_TypeSig = Inh_TypeSig {typeSigs_Inh_TypeSig :: Map Name Type} +data Syn_TypeSig = Syn_TypeSig {typeSigs_Syn_TypeSig :: Map Name Type} +wrap_TypeSig (T_TypeSig sem ) (Inh_TypeSig _lhsItypeSigs ) = + (let ( _lhsOtypeSigs) = + (sem _lhsItypeSigs ) + in (Syn_TypeSig _lhsOtypeSigs )) +sem_TypeSig_TypeSig :: Name -> + Type -> + T_TypeSig +sem_TypeSig_TypeSig name_ tp_ = + (T_TypeSig (\ _lhsItypeSigs -> + (let _lhsOtypeSigs :: (Map Name Type) + -- "Order.ag"(line 393, column 13) + _lhsOtypeSigs = + Map.insert name_ tp_ _lhsItypeSigs + in ( _lhsOtypeSigs))) ) +-- TypeSigs ---------------------------------------------------- +{- + visit 0: + chained attribute: + typeSigs : Map Name Type + alternatives: + alternative Cons: + child hd : TypeSig + child tl : TypeSigs + alternative Nil: +-} +-- cata +sem_TypeSigs :: TypeSigs -> + T_TypeSigs +sem_TypeSigs list = + (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) ) +-- semantic domain +newtype T_TypeSigs = T_TypeSigs ((Map Name Type) -> + ( (Map Name Type))) +data Inh_TypeSigs = Inh_TypeSigs {typeSigs_Inh_TypeSigs :: Map Name Type} +data Syn_TypeSigs = Syn_TypeSigs {typeSigs_Syn_TypeSigs :: Map Name Type} +wrap_TypeSigs (T_TypeSigs sem ) (Inh_TypeSigs _lhsItypeSigs ) = + (let ( _lhsOtypeSigs) = + (sem _lhsItypeSigs ) + in (Syn_TypeSigs _lhsOtypeSigs )) +sem_TypeSigs_Cons :: T_TypeSig -> + T_TypeSigs -> + T_TypeSigs +sem_TypeSigs_Cons (T_TypeSig hd_ ) (T_TypeSigs tl_ ) = + (T_TypeSigs (\ _lhsItypeSigs -> + (let _lhsOtypeSigs :: (Map Name Type) + _hdOtypeSigs :: (Map Name Type) + _tlOtypeSigs :: (Map Name Type) + _hdItypeSigs :: (Map Name Type) + _tlItypeSigs :: (Map Name Type) + -- copy rule (up) + _lhsOtypeSigs = + _tlItypeSigs + -- copy rule (down) + _hdOtypeSigs = + _lhsItypeSigs + -- copy rule (chain) + _tlOtypeSigs = + _hdItypeSigs + ( _hdItypeSigs) = + (hd_ _hdOtypeSigs ) + ( _tlItypeSigs) = + (tl_ _tlOtypeSigs ) + in ( _lhsOtypeSigs))) ) +sem_TypeSigs_Nil :: T_TypeSigs +sem_TypeSigs_Nil = + (T_TypeSigs (\ _lhsItypeSigs -> + (let _lhsOtypeSigs :: (Map Name Type) + -- copy rule (chain) + _lhsOtypeSigs = + _lhsItypeSigs + in ( _lhsOtypeSigs))) ) diff --git a/src-derived/Patterns.hs b/src-derived/Patterns.hs new file mode 100644 --- /dev/null +++ b/src-derived/Patterns.hs @@ -0,0 +1,56 @@ + +-- UUAGC 0.9.5 (Patterns.ag) +module Patterns where + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (Constructor,Name) +-- Pattern ----------------------------------------------------- +{- + visit 0: + synthesized attribute: + copy : SELF + alternatives: + alternative Alias: + child field : {Name} + child attr : {Name} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + alternative Constr: + child name : {Constructor} + child pats : Patterns + visit 0: + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +data Pattern = Alias (Name) (Name) (Pattern) (Patterns) + | Constr (Constructor) (Patterns) + | Product (Pos) (Patterns) + | Underscore (Pos) + deriving ( Show) +-- Patterns ---------------------------------------------------- +{- + visit 0: + synthesized attribute: + copy : SELF + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +type Patterns = [Pattern] diff --git a/src-derived/PrintCode.hs b/src-derived/PrintCode.hs new file mode 100644 --- /dev/null +++ b/src-derived/PrintCode.hs @@ -0,0 +1,2620 @@ + +-- UUAGC 0.9.5 (PrintCode.ag) +module PrintCode where + +import Char (isAlphaNum) +import Pretty +import Code +import Patterns +import Options +import CommonTypes (attrname, _LOC, getName, nullIdent) +import Data.List(intersperse) +import System.IO +import System.Directory + +import Pretty +import Patterns +import Data.List(partition) +import Data.Set(Set) +import qualified UU.DData.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (Constructor,Name) + +type PP_Docs = [PP_Doc] + +ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqH = ppMultiSeq' (>#<) + +ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqV = ppMultiSeq' (>-<) + +ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeq' next strictArgs expr + = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs + + +reallySimple :: String -> Bool +reallySimple = and . map (\x -> isAlphaNum x || x=='_') + +ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps +ppTuple False pps = "(" >|< pp_block " " ")" "," pps +ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps +ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps + + +locname' n = "_loc_" ++ getName n + +renderDocs :: [PP_Doc] -> String +renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" + +writeModule :: FilePath -> [PP_Doc] -> IO () +writeModule path docs + = do bExists <- doesFileExist path + if bExists + then do input <- readFile path + seq (length input) (return ()) + if input /= output + then dumpIt + else return () + else dumpIt + where + output = renderDocs docs + dumpIt = writeFile path output + +-- Unboxed tuples +-- unbox Whether unboxed tuples are wanted or not +-- inh The inherited attributes. +-- If there are none, no unboxing can take place, +-- because in that case the semantic function (a top-level identifier) would have an unboxed type. +-- Of course we can't have an unboxed 1-tuple +mkTupleExpr :: Bool -> Bool -> Exprs -> Expr +mkTupleExpr unbox noInh exprs | not unbox || noInh || length exprs == 1 = TupleExpr exprs + | otherwise = UnboxedTupleExpr exprs +mkTupleType :: Bool -> Bool -> Types -> Type +mkTupleType unbox noInh tps | not unbox || noInh || length tps == 1 = TupleType tps + | otherwise = UnboxedTupleType tps +mkTupleLhs :: Bool -> Bool -> [String] -> Lhs +mkTupleLhs unbox noInh comps | not unbox || noInh || length comps == 1 = TupleLhs comps + | otherwise = UnboxedTupleLhs comps +-- CaseAlt ----------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pps : PP_Docs + alternatives: + alternative CaseAlt: + child left : Lhs + child expr : Expr +-} +-- cata +sem_CaseAlt :: CaseAlt -> + T_CaseAlt +sem_CaseAlt (CaseAlt _left _expr ) = + (sem_CaseAlt_CaseAlt (sem_Lhs _left ) (sem_Expr _expr ) ) +-- semantic domain +newtype T_CaseAlt = T_CaseAlt (Bool -> + Options -> + String -> + ( PP_Docs)) +data Inh_CaseAlt = Inh_CaseAlt {nested_Inh_CaseAlt :: Bool,options_Inh_CaseAlt :: Options,outputfile_Inh_CaseAlt :: String} +data Syn_CaseAlt = Syn_CaseAlt {pps_Syn_CaseAlt :: PP_Docs} +wrap_CaseAlt (T_CaseAlt sem ) (Inh_CaseAlt _lhsInested _lhsIoptions _lhsIoutputfile ) = + (let ( _lhsOpps) = + (sem _lhsInested _lhsIoptions _lhsIoutputfile ) + in (Syn_CaseAlt _lhsOpps )) +sem_CaseAlt_CaseAlt :: T_Lhs -> + T_Expr -> + T_CaseAlt +sem_CaseAlt_CaseAlt (T_Lhs left_ ) (T_Expr expr_ ) = + (T_CaseAlt (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + _leftOisDeclOfLet :: Bool + _leftOnested :: Bool + _leftOoptions :: Options + _leftOoutputfile :: String + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _leftIpp :: PP_Doc + _exprIpp :: PP_Doc + -- "PrintCode.ag"(line 149, column 16) + _lhsOpps = + ["{" >#< _leftIpp >#< "->", _exprIpp >#< "}"] + -- "PrintCode.ag"(line 303, column 7) + _leftOisDeclOfLet = + False + -- copy rule (down) + _leftOnested = + _lhsInested + -- copy rule (down) + _leftOoptions = + _lhsIoptions + -- copy rule (down) + _leftOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + ( _leftIpp) = + (left_ _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile ) + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile ) + in ( _lhsOpps))) ) +-- CaseAlts ---------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pps : PP_Docs + alternatives: + alternative Cons: + child hd : CaseAlt + child tl : CaseAlts + alternative Nil: +-} +-- cata +sem_CaseAlts :: CaseAlts -> + T_CaseAlts +sem_CaseAlts list = + (Prelude.foldr sem_CaseAlts_Cons sem_CaseAlts_Nil (Prelude.map sem_CaseAlt list) ) +-- semantic domain +newtype T_CaseAlts = T_CaseAlts (Bool -> + Options -> + String -> + ( PP_Docs)) +data Inh_CaseAlts = Inh_CaseAlts {nested_Inh_CaseAlts :: Bool,options_Inh_CaseAlts :: Options,outputfile_Inh_CaseAlts :: String} +data Syn_CaseAlts = Syn_CaseAlts {pps_Syn_CaseAlts :: PP_Docs} +wrap_CaseAlts (T_CaseAlts sem ) (Inh_CaseAlts _lhsInested _lhsIoptions _lhsIoutputfile ) = + (let ( _lhsOpps) = + (sem _lhsInested _lhsIoptions _lhsIoutputfile ) + in (Syn_CaseAlts _lhsOpps )) +sem_CaseAlts_Cons :: T_CaseAlt -> + T_CaseAlts -> + T_CaseAlts +sem_CaseAlts_Cons (T_CaseAlt hd_ ) (T_CaseAlts tl_ ) = + (T_CaseAlts (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + _hdOnested :: Bool + _hdOoptions :: Options + _hdOoutputfile :: String + _tlOnested :: Bool + _tlOoptions :: Options + _tlOoutputfile :: String + _hdIpps :: PP_Docs + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 59, column 10) + _lhsOpps = + _hdIpps ++ _tlIpps + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _hdOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _tlOnested = + _lhsInested + -- copy rule (down) + _tlOoptions = + _lhsIoptions + -- copy rule (down) + _tlOoutputfile = + _lhsIoutputfile + ( _hdIpps) = + (hd_ _hdOnested _hdOoptions _hdOoutputfile ) + ( _tlIpps) = + (tl_ _tlOnested _tlOoptions _tlOoutputfile ) + in ( _lhsOpps))) ) +sem_CaseAlts_Nil :: T_CaseAlts +sem_CaseAlts_Nil = + (T_CaseAlts (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + -- "PrintCode.ag"(line 60, column 10) + _lhsOpps = + [] + in ( _lhsOpps))) ) +-- Chunk ------------------------------------------------------- +{- + visit 0: + inherited attributes: + importBlocks : PP_Doc + isDeclOfLet : Bool + mainFile : String + mainName : String + moduleHeader : String -> String -> String -> Bool -> String + nested : Bool + options : Options + optionsLine : String + pragmaBlocks : String + textBlocks : PP_Doc + synthesized attributes: + appendCommon : [[PP_Doc]] + appendMain : [[PP_Doc]] + genSems : IO () + imports : [String] + pps : PP_Docs + alternatives: + alternative Chunk: + child name : {String} + child comment : Decl + child info : Decls + child dataDef : Decls + child cataFun : Decls + child semDom : Decls + child semWrapper : Decls + child semFunctions : Decls + child semNames : {[String]} + visit 0: + local outputfile : _ + local exports : _ +-} +-- cata +sem_Chunk :: Chunk -> + T_Chunk +sem_Chunk (Chunk _name _comment _info _dataDef _cataFun _semDom _semWrapper _semFunctions _semNames ) = + (sem_Chunk_Chunk _name (sem_Decl _comment ) (sem_Decls _info ) (sem_Decls _dataDef ) (sem_Decls _cataFun ) (sem_Decls _semDom ) (sem_Decls _semWrapper ) (sem_Decls _semFunctions ) _semNames ) +-- semantic domain +newtype T_Chunk = T_Chunk (PP_Doc -> + Bool -> + String -> + String -> + (String -> String -> String -> Bool -> String) -> + Bool -> + Options -> + String -> + String -> + PP_Doc -> + ( ([[PP_Doc]]),([[PP_Doc]]),(IO ()),([String]),PP_Docs)) +data Inh_Chunk = Inh_Chunk {importBlocks_Inh_Chunk :: PP_Doc,isDeclOfLet_Inh_Chunk :: Bool,mainFile_Inh_Chunk :: String,mainName_Inh_Chunk :: String,moduleHeader_Inh_Chunk :: String -> String -> String -> Bool -> String,nested_Inh_Chunk :: Bool,options_Inh_Chunk :: Options,optionsLine_Inh_Chunk :: String,pragmaBlocks_Inh_Chunk :: String,textBlocks_Inh_Chunk :: PP_Doc} +data Syn_Chunk = Syn_Chunk {appendCommon_Syn_Chunk :: [[PP_Doc]],appendMain_Syn_Chunk :: [[PP_Doc]],genSems_Syn_Chunk :: IO (),imports_Syn_Chunk :: [String],pps_Syn_Chunk :: PP_Docs} +wrap_Chunk (T_Chunk sem ) (Inh_Chunk _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) = + (let ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps) = + (sem _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) + in (Syn_Chunk _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps )) +sem_Chunk_Chunk :: String -> + T_Decl -> + T_Decls -> + T_Decls -> + T_Decls -> + T_Decls -> + T_Decls -> + T_Decls -> + ([String]) -> + T_Chunk +sem_Chunk_Chunk name_ (T_Decl comment_ ) (T_Decls info_ ) (T_Decls dataDef_ ) (T_Decls cataFun_ ) (T_Decls semDom_ ) (T_Decls semWrapper_ ) (T_Decls semFunctions_ ) semNames_ = + (T_Chunk (\ _lhsIimportBlocks + _lhsIisDeclOfLet + _lhsImainFile + _lhsImainName + _lhsImoduleHeader + _lhsInested + _lhsIoptions + _lhsIoptionsLine + _lhsIpragmaBlocks + _lhsItextBlocks -> + (let _lhsOpps :: PP_Docs + _lhsOimports :: ([String]) + _lhsOappendCommon :: ([[PP_Doc]]) + _lhsOappendMain :: ([[PP_Doc]]) + _lhsOgenSems :: (IO ()) + _commentOisDeclOfLet :: Bool + _commentOnested :: Bool + _commentOoptions :: Options + _commentOoutputfile :: String + _infoOisDeclOfLet :: Bool + _infoOnested :: Bool + _infoOoptions :: Options + _infoOoutputfile :: String + _dataDefOisDeclOfLet :: Bool + _dataDefOnested :: Bool + _dataDefOoptions :: Options + _dataDefOoutputfile :: String + _cataFunOisDeclOfLet :: Bool + _cataFunOnested :: Bool + _cataFunOoptions :: Options + _cataFunOoutputfile :: String + _semDomOisDeclOfLet :: Bool + _semDomOnested :: Bool + _semDomOoptions :: Options + _semDomOoutputfile :: String + _semWrapperOisDeclOfLet :: Bool + _semWrapperOnested :: Bool + _semWrapperOoptions :: Options + _semWrapperOoutputfile :: String + _semFunctionsOisDeclOfLet :: Bool + _semFunctionsOnested :: Bool + _semFunctionsOoptions :: Options + _semFunctionsOoutputfile :: String + _commentIpp :: PP_Doc + _infoIpps :: PP_Docs + _dataDefIpps :: PP_Docs + _cataFunIpps :: PP_Docs + _semDomIpps :: PP_Docs + _semWrapperIpps :: PP_Docs + _semFunctionsIpps :: PP_Docs + -- "PrintCode.ag"(line 37, column 7) + _outputfile = + if sepSemMods _lhsIoptions + then _lhsImainFile ++ "_" ++ name_ ++ ".hs" + else _lhsImainFile ++ ".hs" + -- "PrintCode.ag"(line 83, column 16) + _lhsOpps = + _commentIpp + : _infoIpps + ++ _dataDefIpps + ++ _cataFunIpps + ++ _semDomIpps + ++ _semWrapperIpps + ++ _semFunctionsIpps + -- "PrintCode.ag"(line 360, column 7) + _lhsOimports = + ["import " ++ _lhsImainName ++ "_" ++ name_ ++ "\n"] + -- "PrintCode.ag"(line 366, column 7) + _lhsOappendCommon = + [ [_commentIpp] + , _dataDefIpps + , _semDomIpps + ] + -- "PrintCode.ag"(line 371, column 7) + _lhsOappendMain = + [ [_commentIpp] + , _cataFunIpps + , _semWrapperIpps + ] + -- "PrintCode.ag"(line 381, column 7) + _lhsOgenSems = + writeModule _outputfile + [ pp $ _lhsIpragmaBlocks + , pp $ _lhsIoptionsLine + , pp $ _lhsImoduleHeader _lhsImainName ("_" ++ name_) _exports True + , pp $ ("import " ++ _lhsImainName ++ "_common\n") + , _commentIpp + , vlist_sep "" _infoIpps + , vlist_sep "" _semFunctionsIpps + ] + -- "PrintCode.ag"(line 394, column 7) + _exports = + concat $ intersperse "," semNames_ + -- copy rule (down) + _commentOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _commentOnested = + _lhsInested + -- copy rule (down) + _commentOoptions = + _lhsIoptions + -- copy rule (from local) + _commentOoutputfile = + _outputfile + -- copy rule (down) + _infoOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _infoOnested = + _lhsInested + -- copy rule (down) + _infoOoptions = + _lhsIoptions + -- copy rule (from local) + _infoOoutputfile = + _outputfile + -- copy rule (down) + _dataDefOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _dataDefOnested = + _lhsInested + -- copy rule (down) + _dataDefOoptions = + _lhsIoptions + -- copy rule (from local) + _dataDefOoutputfile = + _outputfile + -- copy rule (down) + _cataFunOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _cataFunOnested = + _lhsInested + -- copy rule (down) + _cataFunOoptions = + _lhsIoptions + -- copy rule (from local) + _cataFunOoutputfile = + _outputfile + -- copy rule (down) + _semDomOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _semDomOnested = + _lhsInested + -- copy rule (down) + _semDomOoptions = + _lhsIoptions + -- copy rule (from local) + _semDomOoutputfile = + _outputfile + -- copy rule (down) + _semWrapperOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _semWrapperOnested = + _lhsInested + -- copy rule (down) + _semWrapperOoptions = + _lhsIoptions + -- copy rule (from local) + _semWrapperOoutputfile = + _outputfile + -- copy rule (down) + _semFunctionsOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _semFunctionsOnested = + _lhsInested + -- copy rule (down) + _semFunctionsOoptions = + _lhsIoptions + -- copy rule (from local) + _semFunctionsOoutputfile = + _outputfile + ( _commentIpp) = + (comment_ _commentOisDeclOfLet _commentOnested _commentOoptions _commentOoutputfile ) + ( _infoIpps) = + (info_ _infoOisDeclOfLet _infoOnested _infoOoptions _infoOoutputfile ) + ( _dataDefIpps) = + (dataDef_ _dataDefOisDeclOfLet _dataDefOnested _dataDefOoptions _dataDefOoutputfile ) + ( _cataFunIpps) = + (cataFun_ _cataFunOisDeclOfLet _cataFunOnested _cataFunOoptions _cataFunOoutputfile ) + ( _semDomIpps) = + (semDom_ _semDomOisDeclOfLet _semDomOnested _semDomOoptions _semDomOoutputfile ) + ( _semWrapperIpps) = + (semWrapper_ _semWrapperOisDeclOfLet _semWrapperOnested _semWrapperOoptions _semWrapperOoutputfile ) + ( _semFunctionsIpps) = + (semFunctions_ _semFunctionsOisDeclOfLet _semFunctionsOnested _semFunctionsOoptions _semFunctionsOoutputfile ) + in ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps))) ) +-- Chunks ------------------------------------------------------ +{- + visit 0: + inherited attributes: + importBlocks : PP_Doc + isDeclOfLet : Bool + mainFile : String + mainName : String + moduleHeader : String -> String -> String -> Bool -> String + nested : Bool + options : Options + optionsLine : String + pragmaBlocks : String + textBlocks : PP_Doc + synthesized attributes: + appendCommon : [[PP_Doc]] + appendMain : [[PP_Doc]] + genSems : IO () + imports : [String] + pps : PP_Docs + alternatives: + alternative Cons: + child hd : Chunk + child tl : Chunks + alternative Nil: +-} +-- cata +sem_Chunks :: Chunks -> + T_Chunks +sem_Chunks list = + (Prelude.foldr sem_Chunks_Cons sem_Chunks_Nil (Prelude.map sem_Chunk list) ) +-- semantic domain +newtype T_Chunks = T_Chunks (PP_Doc -> + Bool -> + String -> + String -> + (String -> String -> String -> Bool -> String) -> + Bool -> + Options -> + String -> + String -> + PP_Doc -> + ( ([[PP_Doc]]),([[PP_Doc]]),(IO ()),([String]),PP_Docs)) +data Inh_Chunks = Inh_Chunks {importBlocks_Inh_Chunks :: PP_Doc,isDeclOfLet_Inh_Chunks :: Bool,mainFile_Inh_Chunks :: String,mainName_Inh_Chunks :: String,moduleHeader_Inh_Chunks :: String -> String -> String -> Bool -> String,nested_Inh_Chunks :: Bool,options_Inh_Chunks :: Options,optionsLine_Inh_Chunks :: String,pragmaBlocks_Inh_Chunks :: String,textBlocks_Inh_Chunks :: PP_Doc} +data Syn_Chunks = Syn_Chunks {appendCommon_Syn_Chunks :: [[PP_Doc]],appendMain_Syn_Chunks :: [[PP_Doc]],genSems_Syn_Chunks :: IO (),imports_Syn_Chunks :: [String],pps_Syn_Chunks :: PP_Docs} +wrap_Chunks (T_Chunks sem ) (Inh_Chunks _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) = + (let ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps) = + (sem _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) + in (Syn_Chunks _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps )) +sem_Chunks_Cons :: T_Chunk -> + T_Chunks -> + T_Chunks +sem_Chunks_Cons (T_Chunk hd_ ) (T_Chunks tl_ ) = + (T_Chunks (\ _lhsIimportBlocks + _lhsIisDeclOfLet + _lhsImainFile + _lhsImainName + _lhsImoduleHeader + _lhsInested + _lhsIoptions + _lhsIoptionsLine + _lhsIpragmaBlocks + _lhsItextBlocks -> + (let _lhsOpps :: PP_Docs + _lhsOappendCommon :: ([[PP_Doc]]) + _lhsOappendMain :: ([[PP_Doc]]) + _lhsOgenSems :: (IO ()) + _lhsOimports :: ([String]) + _hdOimportBlocks :: PP_Doc + _hdOisDeclOfLet :: Bool + _hdOmainFile :: String + _hdOmainName :: String + _hdOmoduleHeader :: (String -> String -> String -> Bool -> String) + _hdOnested :: Bool + _hdOoptions :: Options + _hdOoptionsLine :: String + _hdOpragmaBlocks :: String + _hdOtextBlocks :: PP_Doc + _tlOimportBlocks :: PP_Doc + _tlOisDeclOfLet :: Bool + _tlOmainFile :: String + _tlOmainName :: String + _tlOmoduleHeader :: (String -> String -> String -> Bool -> String) + _tlOnested :: Bool + _tlOoptions :: Options + _tlOoptionsLine :: String + _tlOpragmaBlocks :: String + _tlOtextBlocks :: PP_Doc + _hdIappendCommon :: ([[PP_Doc]]) + _hdIappendMain :: ([[PP_Doc]]) + _hdIgenSems :: (IO ()) + _hdIimports :: ([String]) + _hdIpps :: PP_Docs + _tlIappendCommon :: ([[PP_Doc]]) + _tlIappendMain :: ([[PP_Doc]]) + _tlIgenSems :: (IO ()) + _tlIimports :: ([String]) + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 75, column 10) + _lhsOpps = + _hdIpps ++ _tlIpps + -- use rule "PrintCode.ag"(line 362, column 50) + _lhsOappendCommon = + _hdIappendCommon ++ _tlIappendCommon + -- use rule "PrintCode.ag"(line 362, column 50) + _lhsOappendMain = + _hdIappendMain ++ _tlIappendMain + -- use rule "PrintCode.ag"(line 377, column 33) + _lhsOgenSems = + _hdIgenSems >> _tlIgenSems + -- use rule "PrintCode.ag"(line 357, column 33) + _lhsOimports = + _hdIimports ++ _tlIimports + -- copy rule (down) + _hdOimportBlocks = + _lhsIimportBlocks + -- copy rule (down) + _hdOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _hdOmainFile = + _lhsImainFile + -- copy rule (down) + _hdOmainName = + _lhsImainName + -- copy rule (down) + _hdOmoduleHeader = + _lhsImoduleHeader + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _hdOoptionsLine = + _lhsIoptionsLine + -- copy rule (down) + _hdOpragmaBlocks = + _lhsIpragmaBlocks + -- copy rule (down) + _hdOtextBlocks = + _lhsItextBlocks + -- copy rule (down) + _tlOimportBlocks = + _lhsIimportBlocks + -- copy rule (down) + _tlOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _tlOmainFile = + _lhsImainFile + -- copy rule (down) + _tlOmainName = + _lhsImainName + -- copy rule (down) + _tlOmoduleHeader = + _lhsImoduleHeader + -- copy rule (down) + _tlOnested = + _lhsInested + -- copy rule (down) + _tlOoptions = + _lhsIoptions + -- copy rule (down) + _tlOoptionsLine = + _lhsIoptionsLine + -- copy rule (down) + _tlOpragmaBlocks = + _lhsIpragmaBlocks + -- copy rule (down) + _tlOtextBlocks = + _lhsItextBlocks + ( _hdIappendCommon,_hdIappendMain,_hdIgenSems,_hdIimports,_hdIpps) = + (hd_ _hdOimportBlocks _hdOisDeclOfLet _hdOmainFile _hdOmainName _hdOmoduleHeader _hdOnested _hdOoptions _hdOoptionsLine _hdOpragmaBlocks _hdOtextBlocks ) + ( _tlIappendCommon,_tlIappendMain,_tlIgenSems,_tlIimports,_tlIpps) = + (tl_ _tlOimportBlocks _tlOisDeclOfLet _tlOmainFile _tlOmainName _tlOmoduleHeader _tlOnested _tlOoptions _tlOoptionsLine _tlOpragmaBlocks _tlOtextBlocks ) + in ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps))) ) +sem_Chunks_Nil :: T_Chunks +sem_Chunks_Nil = + (T_Chunks (\ _lhsIimportBlocks + _lhsIisDeclOfLet + _lhsImainFile + _lhsImainName + _lhsImoduleHeader + _lhsInested + _lhsIoptions + _lhsIoptionsLine + _lhsIpragmaBlocks + _lhsItextBlocks -> + (let _lhsOpps :: PP_Docs + _lhsOappendCommon :: ([[PP_Doc]]) + _lhsOappendMain :: ([[PP_Doc]]) + _lhsOgenSems :: (IO ()) + _lhsOimports :: ([String]) + -- "PrintCode.ag"(line 76, column 10) + _lhsOpps = + [] + -- use rule "PrintCode.ag"(line 362, column 50) + _lhsOappendCommon = + [] + -- use rule "PrintCode.ag"(line 362, column 50) + _lhsOappendMain = + [] + -- use rule "PrintCode.ag"(line 377, column 33) + _lhsOgenSems = + return () + -- use rule "PrintCode.ag"(line 357, column 33) + _lhsOimports = + [] + in ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps))) ) +-- DataAlt ----------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + strictPre : PP_Doc + synthesized attribute: + pp : PP_Doc + alternatives: + alternative DataAlt: + child name : {String} + child args : {[String]} + alternative Record: + child name : {String} + child args : {[(String,String)]} +-} +-- cata +sem_DataAlt :: DataAlt -> + T_DataAlt +sem_DataAlt (DataAlt _name _args ) = + (sem_DataAlt_DataAlt _name _args ) +sem_DataAlt (Record _name _args ) = + (sem_DataAlt_Record _name _args ) +-- semantic domain +newtype T_DataAlt = T_DataAlt (Bool -> + PP_Doc -> + ( PP_Doc)) +data Inh_DataAlt = Inh_DataAlt {nested_Inh_DataAlt :: Bool,strictPre_Inh_DataAlt :: PP_Doc} +data Syn_DataAlt = Syn_DataAlt {pp_Syn_DataAlt :: PP_Doc} +wrap_DataAlt (T_DataAlt sem ) (Inh_DataAlt _lhsInested _lhsIstrictPre ) = + (let ( _lhsOpp) = + (sem _lhsInested _lhsIstrictPre ) + in (Syn_DataAlt _lhsOpp )) +sem_DataAlt_DataAlt :: String -> + ([String]) -> + T_DataAlt +sem_DataAlt_DataAlt name_ args_ = + (T_DataAlt (\ _lhsInested + _lhsIstrictPre -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 152, column 16) + _lhsOpp = + name_ >#< hv_sp (map ((_lhsIstrictPre >|<) . pp_parens . text) args_) + in ( _lhsOpp))) ) +sem_DataAlt_Record :: String -> + ([(String,String)]) -> + T_DataAlt +sem_DataAlt_Record name_ args_ = + (T_DataAlt (\ _lhsInested + _lhsIstrictPre -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 153, column 16) + _lhsOpp = + name_ >#< pp_block "{" "}" "," + [ f >#< "::" >#< t | (f,t) <- args_ ] + in ( _lhsOpp))) ) +-- DataAlts ---------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + strictPre : PP_Doc + synthesized attribute: + pps : PP_Docs + alternatives: + alternative Cons: + child hd : DataAlt + child tl : DataAlts + alternative Nil: +-} +-- cata +sem_DataAlts :: DataAlts -> + T_DataAlts +sem_DataAlts list = + (Prelude.foldr sem_DataAlts_Cons sem_DataAlts_Nil (Prelude.map sem_DataAlt list) ) +-- semantic domain +newtype T_DataAlts = T_DataAlts (Bool -> + PP_Doc -> + ( PP_Docs)) +data Inh_DataAlts = Inh_DataAlts {nested_Inh_DataAlts :: Bool,strictPre_Inh_DataAlts :: PP_Doc} +data Syn_DataAlts = Syn_DataAlts {pps_Syn_DataAlts :: PP_Docs} +wrap_DataAlts (T_DataAlts sem ) (Inh_DataAlts _lhsInested _lhsIstrictPre ) = + (let ( _lhsOpps) = + (sem _lhsInested _lhsIstrictPre ) + in (Syn_DataAlts _lhsOpps )) +sem_DataAlts_Cons :: T_DataAlt -> + T_DataAlts -> + T_DataAlts +sem_DataAlts_Cons (T_DataAlt hd_ ) (T_DataAlts tl_ ) = + (T_DataAlts (\ _lhsInested + _lhsIstrictPre -> + (let _lhsOpps :: PP_Docs + _hdOnested :: Bool + _hdOstrictPre :: PP_Doc + _tlOnested :: Bool + _tlOstrictPre :: PP_Doc + _hdIpp :: PP_Doc + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 63, column 10) + _lhsOpps = + _hdIpp : _tlIpps + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _hdOstrictPre = + _lhsIstrictPre + -- copy rule (down) + _tlOnested = + _lhsInested + -- copy rule (down) + _tlOstrictPre = + _lhsIstrictPre + ( _hdIpp) = + (hd_ _hdOnested _hdOstrictPre ) + ( _tlIpps) = + (tl_ _tlOnested _tlOstrictPre ) + in ( _lhsOpps))) ) +sem_DataAlts_Nil :: T_DataAlts +sem_DataAlts_Nil = + (T_DataAlts (\ _lhsInested + _lhsIstrictPre -> + (let _lhsOpps :: PP_Docs + -- "PrintCode.ag"(line 64, column 10) + _lhsOpps = + [] + in ( _lhsOpps))) ) +-- Decl -------------------------------------------------------- +{- + visit 0: + inherited attributes: + isDeclOfLet : Bool + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Comment: + child txt : {String} + alternative Data: + child name : {String} + child alts : DataAlts + child strict : {Bool} + child derivings : {[String]} + alternative Decl: + child left : Lhs + child rhs : Expr + child binds : {Set String} + child uses : {Set String} + alternative NewType: + child name : {String} + child con : {String} + child tp : Type + alternative PragmaDecl: + child txt : {String} + alternative TSig: + child name : {String} + child tp : Type + alternative Type: + child name : {String} + child tp : Type +-} +-- cata +sem_Decl :: Decl -> + T_Decl +sem_Decl (Comment _txt ) = + (sem_Decl_Comment _txt ) +sem_Decl (Data _name _alts _strict _derivings ) = + (sem_Decl_Data _name (sem_DataAlts _alts ) _strict _derivings ) +sem_Decl (Decl _left _rhs _binds _uses ) = + (sem_Decl_Decl (sem_Lhs _left ) (sem_Expr _rhs ) _binds _uses ) +sem_Decl (NewType _name _con _tp ) = + (sem_Decl_NewType _name _con (sem_Type _tp ) ) +sem_Decl (PragmaDecl _txt ) = + (sem_Decl_PragmaDecl _txt ) +sem_Decl (TSig _name _tp ) = + (sem_Decl_TSig _name (sem_Type _tp ) ) +sem_Decl (Type _name _tp ) = + (sem_Decl_Type _name (sem_Type _tp ) ) +-- semantic domain +newtype T_Decl = T_Decl (Bool -> + Bool -> + Options -> + String -> + ( PP_Doc)) +data Inh_Decl = Inh_Decl {isDeclOfLet_Inh_Decl :: Bool,nested_Inh_Decl :: Bool,options_Inh_Decl :: Options,outputfile_Inh_Decl :: String} +data Syn_Decl = Syn_Decl {pp_Syn_Decl :: PP_Doc} +wrap_Decl (T_Decl sem ) (Inh_Decl _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) = + (let ( _lhsOpp) = + (sem _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) + in (Syn_Decl _lhsOpp )) +sem_Decl_Comment :: String -> + T_Decl +sem_Decl_Comment txt_ = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 106, column 16) + _lhsOpp = + if '\n' `elem` txt_ + then "{-" >-< vlist (lines txt_) >-< "-}" + else "--" >#< txt_ + in ( _lhsOpp))) ) +sem_Decl_Data :: String -> + T_DataAlts -> + Bool -> + ([String]) -> + T_Decl +sem_Decl_Data name_ (T_DataAlts alts_ ) strict_ derivings_ = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _altsOstrictPre :: PP_Doc + _altsOnested :: Bool + _altsIpps :: PP_Docs + -- "PrintCode.ag"(line 94, column 16) + _lhsOpp = + "data" >#< name_ + >#< ( case _altsIpps of + [] -> empty + (x:xs) -> "=" >#< x + >-< vlist (map ("|" >#<) xs) + >-< if null derivings_ + then empty + else "deriving" >#< ppTuple False (map text derivings_) + ) + -- "PrintCode.ag"(line 218, column 10) + _altsOstrictPre = + if strict_ then pp "!" else empty + -- copy rule (down) + _altsOnested = + _lhsInested + ( _altsIpps) = + (alts_ _altsOnested _altsOstrictPre ) + in ( _lhsOpp))) ) +sem_Decl_Decl :: T_Lhs -> + T_Expr -> + (Set String) -> + (Set String) -> + T_Decl +sem_Decl_Decl (T_Lhs left_ ) (T_Expr rhs_ ) binds_ uses_ = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _leftOisDeclOfLet :: Bool + _leftOnested :: Bool + _leftOoptions :: Options + _leftOoutputfile :: String + _rhsOnested :: Bool + _rhsOoptions :: Options + _rhsOoutputfile :: String + _leftIpp :: PP_Doc + _rhsIpp :: PP_Doc + -- "PrintCode.ag"(line 92, column 16) + _lhsOpp = + _leftIpp >#< "=" + >-< indent 4 _rhsIpp + -- copy rule (down) + _leftOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _leftOnested = + _lhsInested + -- copy rule (down) + _leftOoptions = + _lhsIoptions + -- copy rule (down) + _leftOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _rhsOnested = + _lhsInested + -- copy rule (down) + _rhsOoptions = + _lhsIoptions + -- copy rule (down) + _rhsOoutputfile = + _lhsIoutputfile + ( _leftIpp) = + (left_ _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile ) + ( _rhsIpp) = + (rhs_ _rhsOnested _rhsOoptions _rhsOoutputfile ) + in ( _lhsOpp))) ) +sem_Decl_NewType :: String -> + String -> + T_Type -> + T_Decl +sem_Decl_NewType name_ con_ (T_Type tp_ ) = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _tpOnested :: Bool + _tpIpp :: PP_Doc + _tpIprec :: Int + -- "PrintCode.ag"(line 103, column 16) + _lhsOpp = + "newtype" >#< name_ >#< "=" >#< con_ >#< pp_parens _tpIpp + -- copy rule (down) + _tpOnested = + _lhsInested + ( _tpIpp,_tpIprec) = + (tp_ _tpOnested ) + in ( _lhsOpp))) ) +sem_Decl_PragmaDecl :: String -> + T_Decl +sem_Decl_PragmaDecl txt_ = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 109, column 16) + _lhsOpp = + "{-#" >#< text txt_ >#< "#-}" + in ( _lhsOpp))) ) +sem_Decl_TSig :: String -> + T_Type -> + T_Decl +sem_Decl_TSig name_ (T_Type tp_ ) = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _tpOnested :: Bool + _tpIpp :: PP_Doc + _tpIprec :: Int + -- "PrintCode.ag"(line 105, column 16) + _lhsOpp = + name_ >#< "::" >#< _tpIpp + -- copy rule (down) + _tpOnested = + _lhsInested + ( _tpIpp,_tpIprec) = + (tp_ _tpOnested ) + in ( _lhsOpp))) ) +sem_Decl_Type :: String -> + T_Type -> + T_Decl +sem_Decl_Type name_ (T_Type tp_ ) = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _tpOnested :: Bool + _tpIpp :: PP_Doc + _tpIprec :: Int + -- "PrintCode.ag"(line 104, column 16) + _lhsOpp = + "type" >#< name_ >#< "=" >#< _tpIpp + -- copy rule (down) + _tpOnested = + _lhsInested + ( _tpIpp,_tpIprec) = + (tp_ _tpOnested ) + in ( _lhsOpp))) ) +-- Decls ------------------------------------------------------- +{- + visit 0: + inherited attributes: + isDeclOfLet : Bool + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pps : PP_Docs + alternatives: + alternative Cons: + child hd : Decl + child tl : Decls + alternative Nil: +-} +-- cata +sem_Decls :: Decls -> + T_Decls +sem_Decls list = + (Prelude.foldr sem_Decls_Cons sem_Decls_Nil (Prelude.map sem_Decl list) ) +-- semantic domain +newtype T_Decls = T_Decls (Bool -> + Bool -> + Options -> + String -> + ( PP_Docs)) +data Inh_Decls = Inh_Decls {isDeclOfLet_Inh_Decls :: Bool,nested_Inh_Decls :: Bool,options_Inh_Decls :: Options,outputfile_Inh_Decls :: String} +data Syn_Decls = Syn_Decls {pps_Syn_Decls :: PP_Docs} +wrap_Decls (T_Decls sem ) (Inh_Decls _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) = + (let ( _lhsOpps) = + (sem _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) + in (Syn_Decls _lhsOpps )) +sem_Decls_Cons :: T_Decl -> + T_Decls -> + T_Decls +sem_Decls_Cons (T_Decl hd_ ) (T_Decls tl_ ) = + (T_Decls (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + _hdOisDeclOfLet :: Bool + _hdOnested :: Bool + _hdOoptions :: Options + _hdOoutputfile :: String + _tlOisDeclOfLet :: Bool + _tlOnested :: Bool + _tlOoptions :: Options + _tlOoutputfile :: String + _hdIpp :: PP_Doc + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 71, column 10) + _lhsOpps = + _hdIpp : _tlIpps + -- copy rule (down) + _hdOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _hdOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _tlOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _tlOnested = + _lhsInested + -- copy rule (down) + _tlOoptions = + _lhsIoptions + -- copy rule (down) + _tlOoutputfile = + _lhsIoutputfile + ( _hdIpp) = + (hd_ _hdOisDeclOfLet _hdOnested _hdOoptions _hdOoutputfile ) + ( _tlIpps) = + (tl_ _tlOisDeclOfLet _tlOnested _tlOoptions _tlOoutputfile ) + in ( _lhsOpps))) ) +sem_Decls_Nil :: T_Decls +sem_Decls_Nil = + (T_Decls (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + -- "PrintCode.ag"(line 72, column 10) + _lhsOpps = + [] + in ( _lhsOpps))) ) +-- Expr -------------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pp : PP_Doc + alternatives: + alternative App: + child name : {String} + child args : Exprs + alternative Case: + child expr : Expr + child alts : CaseAlts + alternative Lambda: + child args : {[String]} + child body : Expr + visit 0: + local strictParams : _ + local addBang : _ + alternative Let: + child decls : Decls + child body : Expr + alternative LineExpr: + child expr : Expr + alternative PragmaExpr: + child onLeftSide : {Bool} + child onNewLine : {Bool} + child txt : {String} + child expr : Expr + alternative SimpleExpr: + child txt : {String} + alternative TextExpr: + child lns : {[String]} + alternative Trace: + child txt : {String} + child expr : Expr + alternative TupleExpr: + child exprs : Exprs + alternative UnboxedTupleExpr: + child exprs : Exprs +-} +-- cata +sem_Expr :: Expr -> + T_Expr +sem_Expr (App _name _args ) = + (sem_Expr_App _name (sem_Exprs _args ) ) +sem_Expr (Case _expr _alts ) = + (sem_Expr_Case (sem_Expr _expr ) (sem_CaseAlts _alts ) ) +sem_Expr (Lambda _args _body ) = + (sem_Expr_Lambda _args (sem_Expr _body ) ) +sem_Expr (Let _decls _body ) = + (sem_Expr_Let (sem_Decls _decls ) (sem_Expr _body ) ) +sem_Expr (LineExpr _expr ) = + (sem_Expr_LineExpr (sem_Expr _expr ) ) +sem_Expr (PragmaExpr _onLeftSide _onNewLine _txt _expr ) = + (sem_Expr_PragmaExpr _onLeftSide _onNewLine _txt (sem_Expr _expr ) ) +sem_Expr (SimpleExpr _txt ) = + (sem_Expr_SimpleExpr _txt ) +sem_Expr (TextExpr _lns ) = + (sem_Expr_TextExpr _lns ) +sem_Expr (Trace _txt _expr ) = + (sem_Expr_Trace _txt (sem_Expr _expr ) ) +sem_Expr (TupleExpr _exprs ) = + (sem_Expr_TupleExpr (sem_Exprs _exprs ) ) +sem_Expr (UnboxedTupleExpr _exprs ) = + (sem_Expr_UnboxedTupleExpr (sem_Exprs _exprs ) ) +-- semantic domain +newtype T_Expr = T_Expr (Bool -> + Options -> + String -> + ( PP_Doc)) +data Inh_Expr = Inh_Expr {nested_Inh_Expr :: Bool,options_Inh_Expr :: Options,outputfile_Inh_Expr :: String} +data Syn_Expr = Syn_Expr {pp_Syn_Expr :: PP_Doc} +wrap_Expr (T_Expr sem ) (Inh_Expr _lhsInested _lhsIoptions _lhsIoutputfile ) = + (let ( _lhsOpp) = + (sem _lhsInested _lhsIoptions _lhsIoutputfile ) + in (Syn_Expr _lhsOpp )) +sem_Expr_App :: String -> + T_Exprs -> + T_Expr +sem_Expr_App name_ (T_Exprs args_ ) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _argsOnested :: Bool + _argsOoptions :: Options + _argsOoutputfile :: String + _argsIpps :: PP_Docs + -- "PrintCode.ag"(line 129, column 16) + _lhsOpp = + pp_parens $ name_ >#< hv_sp _argsIpps + -- copy rule (down) + _argsOnested = + _lhsInested + -- copy rule (down) + _argsOoptions = + _lhsIoptions + -- copy rule (down) + _argsOoutputfile = + _lhsIoutputfile + ( _argsIpps) = + (args_ _argsOnested _argsOoptions _argsOoutputfile ) + in ( _lhsOpp))) ) +sem_Expr_Case :: T_Expr -> + T_CaseAlts -> + T_Expr +sem_Expr_Case (T_Expr expr_ ) (T_CaseAlts alts_ ) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _altsOnested :: Bool + _altsOoptions :: Options + _altsOoutputfile :: String + _exprIpp :: PP_Doc + _altsIpps :: PP_Docs + -- "PrintCode.ag"(line 115, column 16) + _lhsOpp = + pp_parens ( "case" >#< pp_parens _exprIpp >#< "of" + >-< (vlist _altsIpps) + ) + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _altsOnested = + _lhsInested + -- copy rule (down) + _altsOoptions = + _lhsIoptions + -- copy rule (down) + _altsOoutputfile = + _lhsIoutputfile + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile ) + ( _altsIpps) = + (alts_ _altsOnested _altsOoptions _altsOoutputfile ) + in ( _lhsOpp))) ) +sem_Expr_Lambda :: ([String]) -> + T_Expr -> + T_Expr +sem_Expr_Lambda args_ (T_Expr body_ ) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _bodyOnested :: Bool + _bodyOoptions :: Options + _bodyOoutputfile :: String + _bodyIpp :: PP_Doc + -- "PrintCode.ag"(line 118, column 16) + _strictParams = + if strictSems _lhsIoptions + then map text args_ + else [] + -- "PrintCode.ag"(line 121, column 16) + _addBang = + if bangpats _lhsIoptions + then \p -> pp_parens ("!" >|< p) + else id + -- "PrintCode.ag"(line 124, column 16) + _lhsOpp = + pp_parens ( "\\" >#< (vlist (map (_addBang . pp) args_)) >#< "->" + >-< indent 4 (_strictParams `ppMultiSeqV` _bodyIpp) + ) + -- copy rule (down) + _bodyOnested = + _lhsInested + -- copy rule (down) + _bodyOoptions = + _lhsIoptions + -- copy rule (down) + _bodyOoutputfile = + _lhsIoutputfile + ( _bodyIpp) = + (body_ _bodyOnested _bodyOoptions _bodyOoutputfile ) + in ( _lhsOpp))) ) +sem_Expr_Let :: T_Decls -> + T_Expr -> + T_Expr +sem_Expr_Let (T_Decls decls_ ) (T_Expr body_ ) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _declsOisDeclOfLet :: Bool + _declsOnested :: Bool + _declsOoptions :: Options + _declsOoutputfile :: String + _bodyOnested :: Bool + _bodyOoptions :: Options + _bodyOoutputfile :: String + _declsIpps :: PP_Docs + _bodyIpp :: PP_Doc + -- "PrintCode.ag"(line 112, column 16) + _lhsOpp = + pp_parens ( "let" >#< (vlist _declsIpps) + >-< "in " >#< _bodyIpp + ) + -- "PrintCode.ag"(line 299, column 7) + _declsOisDeclOfLet = + True + -- copy rule (down) + _declsOnested = + _lhsInested + -- copy rule (down) + _declsOoptions = + _lhsIoptions + -- copy rule (down) + _declsOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _bodyOnested = + _lhsInested + -- copy rule (down) + _bodyOoptions = + _lhsIoptions + -- copy rule (down) + _bodyOoutputfile = + _lhsIoutputfile + ( _declsIpps) = + (decls_ _declsOisDeclOfLet _declsOnested _declsOoptions _declsOoutputfile ) + ( _bodyIpp) = + (body_ _bodyOnested _bodyOoptions _bodyOoutputfile ) + in ( _lhsOpp))) ) +sem_Expr_LineExpr :: T_Expr -> + T_Expr +sem_Expr_LineExpr (T_Expr expr_ ) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _exprIpp :: PP_Doc + -- "PrintCode.ag"(line 146, column 16) + _lhsOpp = + _exprIpp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show _lhsIoutputfile >#< "#-}" + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile ) + in ( _lhsOpp))) ) +sem_Expr_PragmaExpr :: Bool -> + Bool -> + String -> + T_Expr -> + T_Expr +sem_Expr_PragmaExpr onLeftSide_ onNewLine_ txt_ (T_Expr expr_ ) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _exprIpp :: PP_Doc + -- "PrintCode.ag"(line 135, column 16) + _lhsOpp = + let pragmaDoc = "{-#" >#< txt_ >#< "#-}" + op = if onNewLine_ + then (>-<) + else (>#<) + leftOp x y = if onLeftSide_ + then x `op` y + else y + rightOp x y = if onLeftSide_ + then x + else x `op` y + in pragmaDoc `leftOp` _exprIpp `rightOp` pragmaDoc + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile ) + in ( _lhsOpp))) ) +sem_Expr_SimpleExpr :: String -> + T_Expr +sem_Expr_SimpleExpr txt_ = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 130, column 16) + _lhsOpp = + text txt_ + in ( _lhsOpp))) ) +sem_Expr_TextExpr :: ([String]) -> + T_Expr +sem_Expr_TextExpr lns_ = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 131, column 16) + _lhsOpp = + vlist (map text lns_) + in ( _lhsOpp))) ) +sem_Expr_Trace :: String -> + T_Expr -> + T_Expr +sem_Expr_Trace txt_ (T_Expr expr_ ) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _exprIpp :: PP_Doc + -- "PrintCode.ag"(line 132, column 16) + _lhsOpp = + "trace" >#< ( pp_parens ("\"" >|< text txt_ >|< "\"") + >-< pp_parens _exprIpp + ) + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile ) + in ( _lhsOpp))) ) +sem_Expr_TupleExpr :: T_Exprs -> + T_Expr +sem_Expr_TupleExpr (T_Exprs exprs_ ) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprsOnested :: Bool + _exprsOoptions :: Options + _exprsOoutputfile :: String + _exprsIpps :: PP_Docs + -- "PrintCode.ag"(line 127, column 16) + _lhsOpp = + ppTuple _lhsInested _exprsIpps + -- copy rule (down) + _exprsOnested = + _lhsInested + -- copy rule (down) + _exprsOoptions = + _lhsIoptions + -- copy rule (down) + _exprsOoutputfile = + _lhsIoutputfile + ( _exprsIpps) = + (exprs_ _exprsOnested _exprsOoptions _exprsOoutputfile ) + in ( _lhsOpp))) ) +sem_Expr_UnboxedTupleExpr :: T_Exprs -> + T_Expr +sem_Expr_UnboxedTupleExpr (T_Exprs exprs_ ) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprsOnested :: Bool + _exprsOoptions :: Options + _exprsOoutputfile :: String + _exprsIpps :: PP_Docs + -- "PrintCode.ag"(line 128, column 23) + _lhsOpp = + ppUnboxedTuple _lhsInested _exprsIpps + -- copy rule (down) + _exprsOnested = + _lhsInested + -- copy rule (down) + _exprsOoptions = + _lhsIoptions + -- copy rule (down) + _exprsOoutputfile = + _lhsIoutputfile + ( _exprsIpps) = + (exprs_ _exprsOnested _exprsOoptions _exprsOoutputfile ) + in ( _lhsOpp))) ) +-- Exprs ------------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pps : PP_Docs + alternatives: + alternative Cons: + child hd : Expr + child tl : Exprs + alternative Nil: +-} +-- cata +sem_Exprs :: Exprs -> + T_Exprs +sem_Exprs list = + (Prelude.foldr sem_Exprs_Cons sem_Exprs_Nil (Prelude.map sem_Expr list) ) +-- semantic domain +newtype T_Exprs = T_Exprs (Bool -> + Options -> + String -> + ( PP_Docs)) +data Inh_Exprs = Inh_Exprs {nested_Inh_Exprs :: Bool,options_Inh_Exprs :: Options,outputfile_Inh_Exprs :: String} +data Syn_Exprs = Syn_Exprs {pps_Syn_Exprs :: PP_Docs} +wrap_Exprs (T_Exprs sem ) (Inh_Exprs _lhsInested _lhsIoptions _lhsIoutputfile ) = + (let ( _lhsOpps) = + (sem _lhsInested _lhsIoptions _lhsIoutputfile ) + in (Syn_Exprs _lhsOpps )) +sem_Exprs_Cons :: T_Expr -> + T_Exprs -> + T_Exprs +sem_Exprs_Cons (T_Expr hd_ ) (T_Exprs tl_ ) = + (T_Exprs (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + _hdOnested :: Bool + _hdOoptions :: Options + _hdOoutputfile :: String + _tlOnested :: Bool + _tlOoptions :: Options + _tlOoutputfile :: String + _hdIpp :: PP_Doc + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 55, column 10) + _lhsOpps = + _hdIpp : _tlIpps + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _hdOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _tlOnested = + _lhsInested + -- copy rule (down) + _tlOoptions = + _lhsIoptions + -- copy rule (down) + _tlOoutputfile = + _lhsIoutputfile + ( _hdIpp) = + (hd_ _hdOnested _hdOoptions _hdOoutputfile ) + ( _tlIpps) = + (tl_ _tlOnested _tlOoptions _tlOoutputfile ) + in ( _lhsOpps))) ) +sem_Exprs_Nil :: T_Exprs +sem_Exprs_Nil = + (T_Exprs (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + -- "PrintCode.ag"(line 56, column 10) + _lhsOpps = + [] + in ( _lhsOpps))) ) +-- Lhs --------------------------------------------------------- +{- + visit 0: + inherited attributes: + isDeclOfLet : Bool + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Fun: + child name : {String} + child args : Exprs + visit 0: + local addStrictGuard : _ + local strictGuard : _ + local addBang : _ + alternative Pattern3: + child pat3 : Pattern + visit 0: + local addStrictGuard : _ + local strictGuard : _ + alternative Pattern3SM: + child pat3 : Pattern + alternative TupleLhs: + child comps : {[String]} + visit 0: + local addStrictGuard : _ + local strictGuard : _ + local addBang : _ + alternative UnboxedTupleLhs: + child comps : {[String]} + visit 0: + local addStrictGuard : _ + local strictGuard : _ + local addBang : _ +-} +-- cata +sem_Lhs :: Lhs -> + T_Lhs +sem_Lhs (Fun _name _args ) = + (sem_Lhs_Fun _name (sem_Exprs _args ) ) +sem_Lhs (Pattern3 _pat3 ) = + (sem_Lhs_Pattern3 (sem_Pattern _pat3 ) ) +sem_Lhs (Pattern3SM _pat3 ) = + (sem_Lhs_Pattern3SM (sem_Pattern _pat3 ) ) +sem_Lhs (TupleLhs _comps ) = + (sem_Lhs_TupleLhs _comps ) +sem_Lhs (UnboxedTupleLhs _comps ) = + (sem_Lhs_UnboxedTupleLhs _comps ) +-- semantic domain +newtype T_Lhs = T_Lhs (Bool -> + Bool -> + Options -> + String -> + ( PP_Doc)) +data Inh_Lhs = Inh_Lhs {isDeclOfLet_Inh_Lhs :: Bool,nested_Inh_Lhs :: Bool,options_Inh_Lhs :: Options,outputfile_Inh_Lhs :: String} +data Syn_Lhs = Syn_Lhs {pp_Syn_Lhs :: PP_Doc} +wrap_Lhs (T_Lhs sem ) (Inh_Lhs _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) = + (let ( _lhsOpp) = + (sem _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) + in (Syn_Lhs _lhsOpp )) +sem_Lhs_Fun :: String -> + T_Exprs -> + T_Lhs +sem_Lhs_Fun name_ (T_Exprs args_ ) = + (T_Lhs (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _argsOnested :: Bool + _argsOoptions :: Options + _argsOoutputfile :: String + _argsIpps :: PP_Docs + -- "PrintCode.ag"(line 166, column 7) + _addStrictGuard = + if strictSems _lhsIoptions then \v -> v >#< "|" >#< _strictGuard else id + -- "PrintCode.ag"(line 167, column 7) + _strictGuard = + _argsIpps `ppMultiSeqH` (pp "True") + -- "PrintCode.ag"(line 170, column 7) + _addBang = + if bangpats _lhsIoptions + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 178, column 16) + _lhsOpp = + _addStrictGuard (name_ >#< hv_sp (map _addBang _argsIpps)) + -- copy rule (down) + _argsOnested = + _lhsInested + -- copy rule (down) + _argsOoptions = + _lhsIoptions + -- copy rule (down) + _argsOoutputfile = + _lhsIoutputfile + ( _argsIpps) = + (args_ _argsOnested _argsOoptions _argsOoutputfile ) + in ( _lhsOpp))) ) +sem_Lhs_Pattern3 :: T_Pattern -> + T_Lhs +sem_Lhs_Pattern3 (T_Pattern pat3_ ) = + (T_Lhs (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _pat3OisDeclOfLet :: Bool + _pat3Ooptions :: Options + _pat3Icopy :: Pattern + _pat3IisUnderscore :: Bool + _pat3Ipp :: PP_Doc + _pat3Ipp' :: PP_Doc + _pat3IstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 157, column 7) + _addStrictGuard = + if strictCases _lhsIoptions then \v -> v >#< "|" >#< _strictGuard else id + -- "PrintCode.ag"(line 159, column 7) + _strictGuard = + _pat3IstrictVars `ppMultiSeqH` (pp "True") + -- "PrintCode.ag"(line 174, column 16) + _lhsOpp = + _addStrictGuard _pat3Ipp + -- copy rule (down) + _pat3OisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _pat3Ooptions = + _lhsIoptions + ( _pat3Icopy,_pat3IisUnderscore,_pat3Ipp,_pat3Ipp',_pat3IstrictVars) = + (pat3_ _pat3OisDeclOfLet _pat3Ooptions ) + in ( _lhsOpp))) ) +sem_Lhs_Pattern3SM :: T_Pattern -> + T_Lhs +sem_Lhs_Pattern3SM (T_Pattern pat3_ ) = + (T_Lhs (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _pat3OisDeclOfLet :: Bool + _pat3Ooptions :: Options + _pat3Icopy :: Pattern + _pat3IisUnderscore :: Bool + _pat3Ipp :: PP_Doc + _pat3Ipp' :: PP_Doc + _pat3IstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 175, column 16) + _lhsOpp = + _pat3Ipp' + -- copy rule (down) + _pat3OisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _pat3Ooptions = + _lhsIoptions + ( _pat3Icopy,_pat3IisUnderscore,_pat3Ipp,_pat3Ipp',_pat3IstrictVars) = + (pat3_ _pat3OisDeclOfLet _pat3Ooptions ) + in ( _lhsOpp))) ) +sem_Lhs_TupleLhs :: ([String]) -> + T_Lhs +sem_Lhs_TupleLhs comps_ = + (T_Lhs (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 157, column 7) + _addStrictGuard = + if strictCases _lhsIoptions then \v -> v >#< "|" >#< _strictGuard else id + -- "PrintCode.ag"(line 161, column 7) + _strictGuard = + if stricterCases _lhsIoptions && not _lhsIisDeclOfLet + then map text comps_ `ppMultiSeqH` (pp "True") + else pp "True" + -- "PrintCode.ag"(line 170, column 7) + _addBang = + if bangpats _lhsIoptions + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 176, column 16) + _lhsOpp = + _addStrictGuard $ ppTuple _lhsInested (map (_addBang . text) comps_) + in ( _lhsOpp))) ) +sem_Lhs_UnboxedTupleLhs :: ([String]) -> + T_Lhs +sem_Lhs_UnboxedTupleLhs comps_ = + (T_Lhs (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 157, column 7) + _addStrictGuard = + if strictCases _lhsIoptions then \v -> v >#< "|" >#< _strictGuard else id + -- "PrintCode.ag"(line 161, column 7) + _strictGuard = + if stricterCases _lhsIoptions && not _lhsIisDeclOfLet + then map text comps_ `ppMultiSeqH` (pp "True") + else pp "True" + -- "PrintCode.ag"(line 170, column 7) + _addBang = + if bangpats _lhsIoptions + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 177, column 23) + _lhsOpp = + _addStrictGuard $ ppUnboxedTuple _lhsInested (map (_addBang . text) comps_) + in ( _lhsOpp))) ) +-- Pattern ----------------------------------------------------- +{- + visit 0: + inherited attributes: + isDeclOfLet : Bool + options : Options + synthesized attributes: + copy : SELF + isUnderscore : Bool + pp : PP_Doc + pp' : PP_Doc + strictVars : [PP_Doc] + alternatives: + alternative Alias: + child field : {Name} + child attr : {Name} + child pat : Pattern + child parts : Patterns + visit 0: + local strictVar : _ + local strictPatVars : _ + local addBang : _ + local ppVar : _ + local copy : _ + alternative Constr: + child name : {Constructor} + child pats : Patterns + visit 0: + local addBang : _ + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local addBang : _ + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts ) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) +sem_Pattern (Constr _name _pats ) = + (sem_Pattern_Constr _name (sem_Patterns _pats ) ) +sem_Pattern (Product _pos _pats ) = + (sem_Pattern_Product _pos (sem_Patterns _pats ) ) +sem_Pattern (Underscore _pos ) = + (sem_Pattern_Underscore _pos ) +-- semantic domain +newtype T_Pattern = T_Pattern (Bool -> + Options -> + ( Pattern,Bool,PP_Doc,PP_Doc,([PP_Doc]))) +data Inh_Pattern = Inh_Pattern {isDeclOfLet_Inh_Pattern :: Bool,options_Inh_Pattern :: Options} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,isUnderscore_Syn_Pattern :: Bool,pp_Syn_Pattern :: PP_Doc,pp'_Syn_Pattern :: PP_Doc,strictVars_Syn_Pattern :: [PP_Doc]} +wrap_Pattern (T_Pattern sem ) (Inh_Pattern _lhsIisDeclOfLet _lhsIoptions ) = + (let ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars) = + (sem _lhsIisDeclOfLet _lhsIoptions ) + in (Syn_Pattern _lhsOcopy _lhsOisUnderscore _lhsOpp _lhsOpp' _lhsOstrictVars )) +sem_Pattern_Alias :: Name -> + Name -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = + (T_Pattern (\ _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOstrictVars :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _lhsOisUnderscore :: Bool + _lhsOpp' :: PP_Doc + _lhsOcopy :: Pattern + _patOisDeclOfLet :: Bool + _patOoptions :: Options + _partsOisDeclOfLet :: Bool + _partsOoptions :: Options + _patIcopy :: Pattern + _patIisUnderscore :: Bool + _patIpp :: PP_Doc + _patIpp' :: PP_Doc + _patIstrictVars :: ([PP_Doc]) + _partsIcopy :: Patterns + _partsIpps :: ([PP_Doc]) + _partsIpps' :: ([PP_Doc]) + _partsIstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 227, column 7) + _strictVar = + if strictCases _lhsIoptions && not _lhsIisDeclOfLet + then [_ppVar ] + else [] + -- "PrintCode.ag"(line 231, column 7) + _strictPatVars = + if stricterCases _lhsIoptions && not _lhsIisDeclOfLet + then _patIstrictVars + else [] + -- "PrintCode.ag"(line 235, column 7) + _lhsOstrictVars = + _strictVar ++ _strictPatVars + -- "PrintCode.ag"(line 249, column 7) + _addBang = + if bangpats _lhsIoptions && not _lhsIisDeclOfLet + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 256, column 13) + _ppVar = + _addBang $ pp (attrname False field_ attr_) + -- "PrintCode.ag"(line 257, column 13) + _lhsOpp = + if _patIisUnderscore + then _ppVar + else _ppVar >|< "@" >|< _patIpp + -- "PrintCode.ag"(line 265, column 15) + _lhsOisUnderscore = + False + -- "PrintCode.ag"(line 279, column 13) + _lhsOpp' = + let attribute | field_ == _LOC || field_ == nullIdent = locname' attr_ + | otherwise = attrname False field_ attr_ + in attribute >|< "@" >|< _patIpp' + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _patOoptions = + _lhsIoptions + -- copy rule (down) + _partsOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _partsOoptions = + _lhsIoptions + ( _patIcopy,_patIisUnderscore,_patIpp,_patIpp',_patIstrictVars) = + (pat_ _patOisDeclOfLet _patOoptions ) + ( _partsIcopy,_partsIpps,_partsIpps',_partsIstrictVars) = + (parts_ _partsOisDeclOfLet _partsOoptions ) + in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars))) ) +sem_Pattern_Constr :: Constructor -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_ ) = + (T_Pattern (\ _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOpp :: PP_Doc + _lhsOisUnderscore :: Bool + _lhsOpp' :: PP_Doc + _lhsOstrictVars :: ([PP_Doc]) + _lhsOcopy :: Pattern + _patsOisDeclOfLet :: Bool + _patsOoptions :: Options + _patsIcopy :: Patterns + _patsIpps :: ([PP_Doc]) + _patsIpps' :: ([PP_Doc]) + _patsIstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 249, column 7) + _addBang = + if bangpats _lhsIoptions && not _lhsIisDeclOfLet + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 254, column 13) + _lhsOpp = + _addBang $ pp_parens $ name_ >#< hv_sp _patsIpps + -- "PrintCode.ag"(line 263, column 15) + _lhsOisUnderscore = + False + -- "PrintCode.ag"(line 277, column 13) + _lhsOpp' = + pp_parens $ name_ >#< hv_sp (map pp_parens _patsIpps') + -- use rule "PrintCode.ag"(line 224, column 40) + _lhsOstrictVars = + _patsIstrictVars + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patsOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _patsOoptions = + _lhsIoptions + ( _patsIcopy,_patsIpps,_patsIpps',_patsIstrictVars) = + (pats_ _patsOisDeclOfLet _patsOoptions ) + in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars))) ) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_ ) = + (T_Pattern (\ _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOpp :: PP_Doc + _lhsOisUnderscore :: Bool + _lhsOpp' :: PP_Doc + _lhsOstrictVars :: ([PP_Doc]) + _lhsOcopy :: Pattern + _patsOisDeclOfLet :: Bool + _patsOoptions :: Options + _patsIcopy :: Patterns + _patsIpps :: ([PP_Doc]) + _patsIpps' :: ([PP_Doc]) + _patsIstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 249, column 7) + _addBang = + if bangpats _lhsIoptions && not _lhsIisDeclOfLet + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 255, column 13) + _lhsOpp = + _addBang $ pp_block "(" ")" "," _patsIpps + -- "PrintCode.ag"(line 264, column 15) + _lhsOisUnderscore = + False + -- "PrintCode.ag"(line 278, column 13) + _lhsOpp' = + pp_block "(" ")" "," _patsIpps' + -- use rule "PrintCode.ag"(line 224, column 40) + _lhsOstrictVars = + _patsIstrictVars + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patsOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _patsOoptions = + _lhsIoptions + ( _patsIcopy,_patsIpps,_patsIpps',_patsIstrictVars) = + (pats_ _patsOisDeclOfLet _patsOoptions ) + in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars))) ) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (\ _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOpp :: PP_Doc + _lhsOisUnderscore :: Bool + _lhsOpp' :: PP_Doc + _lhsOstrictVars :: ([PP_Doc]) + _lhsOcopy :: Pattern + -- "PrintCode.ag"(line 260, column 16) + _lhsOpp = + text "_" + -- "PrintCode.ag"(line 266, column 15) + _lhsOisUnderscore = + True + -- "PrintCode.ag"(line 282, column 16) + _lhsOpp' = + text "_" + -- use rule "PrintCode.ag"(line 224, column 40) + _lhsOstrictVars = + [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars))) ) +-- Patterns ---------------------------------------------------- +{- + visit 0: + inherited attributes: + isDeclOfLet : Bool + options : Options + synthesized attributes: + copy : SELF + pps : [PP_Doc] + pps' : [PP_Doc] + strictVars : [PP_Doc] + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) +-- semantic domain +newtype T_Patterns = T_Patterns (Bool -> + Options -> + ( Patterns,([PP_Doc]),([PP_Doc]),([PP_Doc]))) +data Inh_Patterns = Inh_Patterns {isDeclOfLet_Inh_Patterns :: Bool,options_Inh_Patterns :: Options} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,pps_Syn_Patterns :: [PP_Doc],pps'_Syn_Patterns :: [PP_Doc],strictVars_Syn_Patterns :: [PP_Doc]} +wrap_Patterns (T_Patterns sem ) (Inh_Patterns _lhsIisDeclOfLet _lhsIoptions ) = + (let ( _lhsOcopy,_lhsOpps,_lhsOpps',_lhsOstrictVars) = + (sem _lhsIisDeclOfLet _lhsIoptions ) + in (Syn_Patterns _lhsOcopy _lhsOpps _lhsOpps' _lhsOstrictVars )) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = + (T_Patterns (\ _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOpps :: ([PP_Doc]) + _lhsOpps' :: ([PP_Doc]) + _lhsOstrictVars :: ([PP_Doc]) + _lhsOcopy :: Patterns + _hdOisDeclOfLet :: Bool + _hdOoptions :: Options + _tlOisDeclOfLet :: Bool + _tlOoptions :: Options + _hdIcopy :: Pattern + _hdIisUnderscore :: Bool + _hdIpp :: PP_Doc + _hdIpp' :: PP_Doc + _hdIstrictVars :: ([PP_Doc]) + _tlIcopy :: Patterns + _tlIpps :: ([PP_Doc]) + _tlIpps' :: ([PP_Doc]) + _tlIstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 244, column 10) + _lhsOpps = + _hdIpp : _tlIpps + -- "PrintCode.ag"(line 273, column 10) + _lhsOpps' = + _hdIpp' : _tlIpps' + -- use rule "PrintCode.ag"(line 224, column 40) + _lhsOstrictVars = + _hdIstrictVars ++ _tlIstrictVars + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _hdOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _tlOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _tlOoptions = + _lhsIoptions + ( _hdIcopy,_hdIisUnderscore,_hdIpp,_hdIpp',_hdIstrictVars) = + (hd_ _hdOisDeclOfLet _hdOoptions ) + ( _tlIcopy,_tlIpps,_tlIpps',_tlIstrictVars) = + (tl_ _tlOisDeclOfLet _tlOoptions ) + in ( _lhsOcopy,_lhsOpps,_lhsOpps',_lhsOstrictVars))) ) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (\ _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOpps :: ([PP_Doc]) + _lhsOpps' :: ([PP_Doc]) + _lhsOstrictVars :: ([PP_Doc]) + _lhsOcopy :: Patterns + -- "PrintCode.ag"(line 245, column 10) + _lhsOpps = + [] + -- "PrintCode.ag"(line 274, column 10) + _lhsOpps' = + [] + -- use rule "PrintCode.ag"(line 224, column 40) + _lhsOstrictVars = + [] + -- self rule + _copy = + [] + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOpps,_lhsOpps',_lhsOstrictVars))) ) +-- Program ----------------------------------------------------- +{- + visit 0: + inherited attributes: + importBlocks : PP_Doc + mainFile : String + mainName : String + moduleHeader : String -> String -> String -> Bool -> String + options : Options + optionsLine : String + pragmaBlocks : String + textBlocks : PP_Doc + synthesized attributes: + genIO : IO () + output : PP_Docs + alternatives: + alternative Program: + child chunks : Chunks + visit 0: + local mainModuleFile : _ + local genMainModule : _ + local commonFile : _ + local genCommonModule : _ +-} +-- cata +sem_Program :: Program -> + T_Program +sem_Program (Program _chunks ) = + (sem_Program_Program (sem_Chunks _chunks ) ) +-- semantic domain +newtype T_Program = T_Program (PP_Doc -> + String -> + String -> + (String -> String -> String -> Bool -> String) -> + Options -> + String -> + String -> + PP_Doc -> + ( (IO ()),PP_Docs)) +data Inh_Program = Inh_Program {importBlocks_Inh_Program :: PP_Doc,mainFile_Inh_Program :: String,mainName_Inh_Program :: String,moduleHeader_Inh_Program :: String -> String -> String -> Bool -> String,options_Inh_Program :: Options,optionsLine_Inh_Program :: String,pragmaBlocks_Inh_Program :: String,textBlocks_Inh_Program :: PP_Doc} +data Syn_Program = Syn_Program {genIO_Syn_Program :: IO (),output_Syn_Program :: PP_Docs} +wrap_Program (T_Program sem ) (Inh_Program _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) = + (let ( _lhsOgenIO,_lhsOoutput) = + (sem _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) + in (Syn_Program _lhsOgenIO _lhsOoutput )) +sem_Program_Program :: T_Chunks -> + T_Program +sem_Program_Program (T_Chunks chunks_ ) = + (T_Program (\ _lhsIimportBlocks + _lhsImainFile + _lhsImainName + _lhsImoduleHeader + _lhsIoptions + _lhsIoptionsLine + _lhsIpragmaBlocks + _lhsItextBlocks -> + (let _chunksOnested :: Bool + _lhsOoutput :: PP_Docs + _chunksOisDeclOfLet :: Bool + _lhsOgenIO :: (IO ()) + _chunksOimportBlocks :: PP_Doc + _chunksOmainFile :: String + _chunksOmainName :: String + _chunksOmoduleHeader :: (String -> String -> String -> Bool -> String) + _chunksOoptions :: Options + _chunksOoptionsLine :: String + _chunksOpragmaBlocks :: String + _chunksOtextBlocks :: PP_Doc + _chunksIappendCommon :: ([[PP_Doc]]) + _chunksIappendMain :: ([[PP_Doc]]) + _chunksIgenSems :: (IO ()) + _chunksIimports :: ([String]) + _chunksIpps :: PP_Docs + -- "PrintCode.ag"(line 52, column 13) + _chunksOnested = + nest _lhsIoptions + -- "PrintCode.ag"(line 80, column 16) + _lhsOoutput = + _chunksIpps + -- "PrintCode.ag"(line 295, column 7) + _chunksOisDeclOfLet = + False + -- "PrintCode.ag"(line 324, column 7) + _mainModuleFile = + _lhsImainFile ++ ".hs" + -- "PrintCode.ag"(line 325, column 7) + _genMainModule = + writeModule _mainModuleFile + ( [ pp $ _lhsIpragmaBlocks + , pp $ _lhsIoptionsLine + , pp $ _lhsImoduleHeader _lhsImainName "" "" False + , pp $ ("import " ++ _lhsImainName ++ "_common\n") + ] + ++ map pp _chunksIimports + ++ map vlist _chunksIappendMain + ) + -- "PrintCode.ag"(line 336, column 7) + _commonFile = + _lhsImainFile ++ "_common.hs" + -- "PrintCode.ag"(line 337, column 7) + _genCommonModule = + writeModule _commonFile + ( [ pp $ _lhsIpragmaBlocks + , pp $ _lhsIoptionsLine + , pp $ _lhsImoduleHeader _lhsImainName "_common" "" True + , _lhsIimportBlocks + , _lhsItextBlocks + ] + ++ map vlist _chunksIappendCommon + ) + -- "PrintCode.ag"(line 348, column 7) + _lhsOgenIO = + do _genMainModule + _genCommonModule + _chunksIgenSems + -- copy rule (down) + _chunksOimportBlocks = + _lhsIimportBlocks + -- copy rule (down) + _chunksOmainFile = + _lhsImainFile + -- copy rule (down) + _chunksOmainName = + _lhsImainName + -- copy rule (down) + _chunksOmoduleHeader = + _lhsImoduleHeader + -- copy rule (down) + _chunksOoptions = + _lhsIoptions + -- copy rule (down) + _chunksOoptionsLine = + _lhsIoptionsLine + -- copy rule (down) + _chunksOpragmaBlocks = + _lhsIpragmaBlocks + -- copy rule (down) + _chunksOtextBlocks = + _lhsItextBlocks + ( _chunksIappendCommon,_chunksIappendMain,_chunksIgenSems,_chunksIimports,_chunksIpps) = + (chunks_ _chunksOimportBlocks _chunksOisDeclOfLet _chunksOmainFile _chunksOmainName _chunksOmoduleHeader _chunksOnested _chunksOoptions _chunksOoptionsLine _chunksOpragmaBlocks _chunksOtextBlocks ) + in ( _lhsOgenIO,_lhsOoutput))) ) +-- Type -------------------------------------------------------- +{- + visit 0: + inherited attribute: + nested : Bool + synthesized attributes: + pp : PP_Doc + prec : Int + alternatives: + alternative Arr: + child left : Type + child right : Type + visit 0: + local l : _ + local r : _ + alternative List: + child tp : Type + alternative SimpleType: + child txt : {String} + alternative TupleType: + child tps : Types + alternative UnboxedTupleType: + child tps : Types +-} +-- cata +sem_Type :: Type -> + T_Type +sem_Type (Arr _left _right ) = + (sem_Type_Arr (sem_Type _left ) (sem_Type _right ) ) +sem_Type (List _tp ) = + (sem_Type_List (sem_Type _tp ) ) +sem_Type (SimpleType _txt ) = + (sem_Type_SimpleType _txt ) +sem_Type (TupleType _tps ) = + (sem_Type_TupleType (sem_Types _tps ) ) +sem_Type (UnboxedTupleType _tps ) = + (sem_Type_UnboxedTupleType (sem_Types _tps ) ) +-- semantic domain +newtype T_Type = T_Type (Bool -> + ( PP_Doc,Int)) +data Inh_Type = Inh_Type {nested_Inh_Type :: Bool} +data Syn_Type = Syn_Type {pp_Syn_Type :: PP_Doc,prec_Syn_Type :: Int} +wrap_Type (T_Type sem ) (Inh_Type _lhsInested ) = + (let ( _lhsOpp,_lhsOprec) = + (sem _lhsInested ) + in (Syn_Type _lhsOpp _lhsOprec )) +sem_Type_Arr :: T_Type -> + T_Type -> + T_Type +sem_Type_Arr (T_Type left_ ) (T_Type right_ ) = + (T_Type (\ _lhsInested -> + (let _lhsOprec :: Int + _lhsOpp :: PP_Doc + _leftOnested :: Bool + _rightOnested :: Bool + _leftIpp :: PP_Doc + _leftIprec :: Int + _rightIpp :: PP_Doc + _rightIprec :: Int + -- "PrintCode.ag"(line 181, column 16) + _lhsOprec = + 2 + -- "PrintCode.ag"(line 181, column 16) + _lhsOpp = + _l >#< "->" >-< _r + -- "PrintCode.ag"(line 183, column 16) + _l = + if _leftIprec <= 2 then pp_parens _leftIpp else _leftIpp + -- "PrintCode.ag"(line 183, column 16) + _r = + if _rightIprec < 2 then pp_parens _rightIpp else _rightIpp + -- copy rule (down) + _leftOnested = + _lhsInested + -- copy rule (down) + _rightOnested = + _lhsInested + ( _leftIpp,_leftIprec) = + (left_ _leftOnested ) + ( _rightIpp,_rightIprec) = + (right_ _rightOnested ) + in ( _lhsOpp,_lhsOprec))) ) +sem_Type_List :: T_Type -> + T_Type +sem_Type_List (T_Type tp_ ) = + (T_Type (\ _lhsInested -> + (let _lhsOprec :: Int + _lhsOpp :: PP_Doc + _tpOnested :: Bool + _tpIpp :: PP_Doc + _tpIprec :: Int + -- "PrintCode.ag"(line 192, column 16) + _lhsOprec = + 5 + -- "PrintCode.ag"(line 192, column 16) + _lhsOpp = + "[" >|< _tpIpp >|< "]" + -- copy rule (down) + _tpOnested = + _lhsInested + ( _tpIpp,_tpIprec) = + (tp_ _tpOnested ) + in ( _lhsOpp,_lhsOprec))) ) +sem_Type_SimpleType :: String -> + T_Type +sem_Type_SimpleType txt_ = + (T_Type (\ _lhsInested -> + (let _lhsOprec :: Int + _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 195, column 16) + _lhsOprec = + 5 + -- "PrintCode.ag"(line 195, column 16) + _lhsOpp = + if reallySimple txt_ then text txt_ else pp_parens (text txt_) + in ( _lhsOpp,_lhsOprec))) ) +sem_Type_TupleType :: T_Types -> + T_Type +sem_Type_TupleType (T_Types tps_ ) = + (T_Type (\ _lhsInested -> + (let _lhsOprec :: Int + _lhsOpp :: PP_Doc + _tpsOnested :: Bool + _tpsIpps :: PP_Docs + -- "PrintCode.ag"(line 186, column 16) + _lhsOprec = + 5 + -- "PrintCode.ag"(line 186, column 16) + _lhsOpp = + ppTuple _lhsInested _tpsIpps + -- copy rule (down) + _tpsOnested = + _lhsInested + ( _tpsIpps) = + (tps_ _tpsOnested ) + in ( _lhsOpp,_lhsOprec))) ) +sem_Type_UnboxedTupleType :: T_Types -> + T_Type +sem_Type_UnboxedTupleType (T_Types tps_ ) = + (T_Type (\ _lhsInested -> + (let _lhsOprec :: Int + _lhsOpp :: PP_Doc + _tpsOnested :: Bool + _tpsIpps :: PP_Docs + -- "PrintCode.ag"(line 189, column 23) + _lhsOprec = + 5 + -- "PrintCode.ag"(line 189, column 23) + _lhsOpp = + ppUnboxedTuple _lhsInested _tpsIpps + -- copy rule (down) + _tpsOnested = + _lhsInested + ( _tpsIpps) = + (tps_ _tpsOnested ) + in ( _lhsOpp,_lhsOprec))) ) +-- Types ------------------------------------------------------- +{- + visit 0: + inherited attribute: + nested : Bool + synthesized attribute: + pps : PP_Docs + alternatives: + alternative Cons: + child hd : Type + child tl : Types + alternative Nil: +-} +-- cata +sem_Types :: Types -> + T_Types +sem_Types list = + (Prelude.foldr sem_Types_Cons sem_Types_Nil (Prelude.map sem_Type list) ) +-- semantic domain +newtype T_Types = T_Types (Bool -> + ( PP_Docs)) +data Inh_Types = Inh_Types {nested_Inh_Types :: Bool} +data Syn_Types = Syn_Types {pps_Syn_Types :: PP_Docs} +wrap_Types (T_Types sem ) (Inh_Types _lhsInested ) = + (let ( _lhsOpps) = + (sem _lhsInested ) + in (Syn_Types _lhsOpps )) +sem_Types_Cons :: T_Type -> + T_Types -> + T_Types +sem_Types_Cons (T_Type hd_ ) (T_Types tl_ ) = + (T_Types (\ _lhsInested -> + (let _lhsOpps :: PP_Docs + _hdOnested :: Bool + _tlOnested :: Bool + _hdIpp :: PP_Doc + _hdIprec :: Int + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 67, column 10) + _lhsOpps = + _hdIpp : _tlIpps + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _tlOnested = + _lhsInested + ( _hdIpp,_hdIprec) = + (hd_ _hdOnested ) + ( _tlIpps) = + (tl_ _tlOnested ) + in ( _lhsOpps))) ) +sem_Types_Nil :: T_Types +sem_Types_Nil = + (T_Types (\ _lhsInested -> + (let _lhsOpps :: PP_Docs + -- "PrintCode.ag"(line 68, column 10) + _lhsOpps = + [] + in ( _lhsOpps))) ) diff --git a/src-derived/PrintErrorMessages.hs b/src-derived/PrintErrorMessages.hs new file mode 100644 --- /dev/null +++ b/src-derived/PrintErrorMessages.hs @@ -0,0 +1,1215 @@ + +-- UUAGC 0.9.5 (PrintErrorMessages.ag) +module PrintErrorMessages where + +import Pretty +import UU.Scanner.Position(Pos(..), noPos) +import ErrorMessages +import DepTypes +import Options (Options,verbose) +import Data.List(mapAccumL,intersect,(\\)) +import GrammarInfo + +import UU.Scanner.Position(Pos) +import Pretty +import DepTypes(Trace) +import CodeSyntax +import CommonTypes + +isError :: Error -> Bool +isError (ParserError _ _ _ ) = True +isError (DupAlt _ _ _ ) = False +isError (DupSynonym _ _ ) = False +isError (DupSet _ _ ) = False +isError (DupInhAttr _ _ _ ) = True +isError (DupSynAttr _ _ _ ) = True +isError (DupChild _ _ _ _ ) = False +isError (DupRule _ _ _ _ _) = True +isError (DupSig _ _ _ ) = True +isError (UndefNont _ ) = True +isError (UndefAlt _ _ ) = True +isError (UndefChild _ _ _ ) = True +isError (MissingRule _ _ _ _ ) = False +isError (SuperfluousRule _ _ _ _ ) = False +isError (UndefLocal _ _ _ ) = True +isError (ChildAsLocal _ _ _ ) = False +isError (UndefAttr _ _ _ _ ) = True +isError (CyclicSet _ ) = True +isError (CustomError w _ _ ) = not w +isError (LocalCirc _ _ _ _ _) = False +isError (InstCirc _ _ _ _ _) = False +isError (DirectCirc _ _ _ ) = False +isError (InducedCirc _ _ _ ) = False +isError (MissingTypeSig _ _ _ ) = False +isError (MissingInstSig _ _ _ ) = True +isError (ErroneousOrder _ _ _ ) = True + +toWidth n xs | k-< indent 4 (vlist (map text path2)) + >-< text "and back: " + >-< indent 4 (vlist (map text path1)) + +attrText inh syn + = if inh == syn + then "threaded attribute " ++ getName inh + else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn + + +ppTrace :: Trace -> PP_Doc +ppTrace (tr:rest) = wfill [showLineNr (lineNr tr) ++ ":", "SEM", getName (nt tr), "|", getName (prod tr) + , lhsFld tr +.+ lhsAttr tr, "=", "..." +#+ showRhs tr +#+ "..."] + >-< ppTrace rest +ppTrace [] = empty + +showRhs :: TraceElem -> String +showRhs tr = if null (getName field) + then "@" ++ getName attr + else "@" ++ (field +.+ attr) + where field = rhsFld tr + attr = rhsAttr tr + +showLineNr :: Int -> String +showLineNr i | i==(-1) = "CR" + | otherwise = show i + +showAttrDef f a | f == _LHS = "synthesized attribute " ++ getName a + | f == _LOC = "local attribute " ++ getName a + | f == _INST = "inst attribute " ++ getName a + | otherwise = "inherited attribute " ++ getName a ++ " of field " ++ getName f + +showAttrUse f a | f == _LHS = "inherited attribute " ++ getName a + | f == _LOC = "local attribute " ++ getName a + | f == _INST = "inst attribute " ++ getName a + | otherwise = "synthesized attribute " ++ getName a ++ " of field " ++ getName f + +ppAttr f a = text (getName f++"."++getName a) +ppAttrUse f a = "@" >|< ppAttr f a + +infixr 5 +#+ +(+#+) :: String -> String -> String +(+#+) s t = s ++ " " ++ t + +infixr 5 +.+ +(+.+) :: Identifier -> Identifier -> String +(+.+) s t = getName s ++ "." ++ getName t + +wfill = fill . addSpaces. concat . map words + where addSpaces (x:xs) = x:map addSpace xs + addSpaces [] = [] + addSpace [x] | x `elem` ".,;:!?" = [x] + addSpace xs = ' ':xs + +ppError :: Bool -- class of the error, True:error False:warning + -> Pos -- source position + -> PP_Doc -- error message + -> PP_Doc -- pattern + -> PP_Doc -- help, more info + -> PP_Doc -- action taken by AG + -> Bool -- verbose? show help and action? + -> PP_Doc +ppError isError pos mesg pat hlp act verbose + = let position = case pos of + Pos l c f | l >= 0 -> f >|< ":" >|< show l >|< ":" >|< show c + | otherwise -> pp "uuagc" + tp = if isError then "error" else "warning" + header = position >|< ":" >#< tp >|< ":" >#< mesg + pattern = "pattern :" >#< pat + help = "help :" >#< hlp + action = "action :" >#< act + in if verbose + then vlist [text "",header,pattern,help,action] + else header + +{- +-- old error reporting code + = let + cl = if isError then "ERROR" else "Warning" + position = case pos of + (Pos l c f) | l >= 0 -> f >|< ": line " >|< show l >|< ", column " >|< show c + | otherwise -> empty + header = "*** UU.AG" >#< cl >#< position >#< "***" + message = "problem :" >#< mesg + pattern = "pattern :" >#< pat + help = "help :" >#< hlp + action = "action :" >#< act + in + if verbose + then vlist [text "",header,message,pattern,help,action] + else vlist [text "",header,message] +-} + +showPos = show . getPos + +ppInterface inter = wfill ["interface:", show inter] + +-- Error ------------------------------------------------------- +{- + visit 0: + inherited attribute: + verbose : Bool + synthesized attributes: + me : SELF + pp : PP_Doc + alternatives: + alternative ChildAsLocal: + child nt : {Nonterminal} + child con : {Constructor} + child var : {Name} + visit 0: + local me : _ + alternative CustomError: + child isWarning : {Bool} + child pos : {Pos} + child mesg : {PP_Doc} + visit 0: + local me : _ + alternative CyclicSet: + child name : {Name} + visit 0: + local me : _ + alternative DirectCirc: + child nt : {Nonterminal} + child o_visit : {Bool} + child cyclic : {[((Name,Name),[String],[String])]} + visit 0: + local me : _ + alternative DupAlt: + child nt : {Nonterminal} + child con : {Constructor} + child occ1 : {Constructor} + visit 0: + local me : _ + alternative DupChild: + child nt : {Nonterminal} + child con : {Constructor} + child name : {Name} + child occ1 : {Name} + visit 0: + local me : _ + alternative DupInhAttr: + child nt : {Nonterminal} + child attr : {Name} + child occ1 : {Name} + visit 0: + local me : _ + alternative DupRule: + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child attr : {Name} + child occ1 : {Name} + visit 0: + local me : _ + alternative DupSet: + child name : {Nonterminal} + child occ1 : {Nonterminal} + visit 0: + local me : _ + alternative DupSig: + child nt : {Nonterminal} + child con : {Constructor} + child attr : {Name} + visit 0: + local me : _ + alternative DupSynAttr: + child nt : {Nonterminal} + child attr : {Name} + child occ1 : {Name} + visit 0: + local me : _ + alternative DupSynonym: + child nt : {Nonterminal} + child occ1 : {Nonterminal} + visit 0: + local me : _ + alternative ErroneousOrder: + child nt : {Nonterminal} + child con : {Constructor} + child order : {Dependency} + visit 0: + local me : _ + alternative InducedCirc: + child nt : {Nonterminal} + child cinter : {CInterface} + child cyclic : {[((Name,Name),[String],[String])]} + visit 0: + local me : _ + alternative InstCirc: + child nt : {Nonterminal} + child con : {Constructor} + child attr : {Name} + child o_visit : {Bool} + child path : {[String]} + visit 0: + local me : _ + alternative LocalCirc: + child nt : {Nonterminal} + child con : {Constructor} + child attr : {Name} + child o_visit : {Bool} + child path : {[String]} + visit 0: + local me : _ + alternative MissingInstSig: + child nt : {Nonterminal} + child con : {Constructor} + child attr : {Name} + visit 0: + local me : _ + alternative MissingRule: + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child attr : {Name} + visit 0: + local me : _ + alternative MissingTypeSig: + child nt : {Nonterminal} + child con : {Constructor} + child attr : {Name} + visit 0: + local me : _ + alternative ParserError: + child pos : {Pos} + child problem : {String} + child action : {String} + visit 0: + local me : _ + alternative SuperfluousRule: + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child attr : {Name} + visit 0: + local me : _ + alternative UndefAlt: + child nt : {Nonterminal} + child con : {Constructor} + visit 0: + local me : _ + alternative UndefAttr: + child nt : {Nonterminal} + child con : {Constructor} + child field : {Name} + child attr : {Name} + visit 0: + local me : _ + alternative UndefChild: + child nt : {Nonterminal} + child con : {Constructor} + child name : {Name} + visit 0: + local me : _ + alternative UndefLocal: + child nt : {Nonterminal} + child con : {Constructor} + child var : {Name} + visit 0: + local me : _ + alternative UndefNont: + child nt : {Nonterminal} + visit 0: + local me : _ +-} +-- cata +sem_Error :: Error -> + T_Error +sem_Error (ChildAsLocal _nt _con _var ) = + (sem_Error_ChildAsLocal _nt _con _var ) +sem_Error (CustomError _isWarning _pos _mesg ) = + (sem_Error_CustomError _isWarning _pos _mesg ) +sem_Error (CyclicSet _name ) = + (sem_Error_CyclicSet _name ) +sem_Error (DirectCirc _nt _o_visit _cyclic ) = + (sem_Error_DirectCirc _nt _o_visit _cyclic ) +sem_Error (DupAlt _nt _con _occ1 ) = + (sem_Error_DupAlt _nt _con _occ1 ) +sem_Error (DupChild _nt _con _name _occ1 ) = + (sem_Error_DupChild _nt _con _name _occ1 ) +sem_Error (DupInhAttr _nt _attr _occ1 ) = + (sem_Error_DupInhAttr _nt _attr _occ1 ) +sem_Error (DupRule _nt _con _field _attr _occ1 ) = + (sem_Error_DupRule _nt _con _field _attr _occ1 ) +sem_Error (DupSet _name _occ1 ) = + (sem_Error_DupSet _name _occ1 ) +sem_Error (DupSig _nt _con _attr ) = + (sem_Error_DupSig _nt _con _attr ) +sem_Error (DupSynAttr _nt _attr _occ1 ) = + (sem_Error_DupSynAttr _nt _attr _occ1 ) +sem_Error (DupSynonym _nt _occ1 ) = + (sem_Error_DupSynonym _nt _occ1 ) +sem_Error (ErroneousOrder _nt _con _order ) = + (sem_Error_ErroneousOrder _nt _con _order ) +sem_Error (InducedCirc _nt _cinter _cyclic ) = + (sem_Error_InducedCirc _nt _cinter _cyclic ) +sem_Error (InstCirc _nt _con _attr _o_visit _path ) = + (sem_Error_InstCirc _nt _con _attr _o_visit _path ) +sem_Error (LocalCirc _nt _con _attr _o_visit _path ) = + (sem_Error_LocalCirc _nt _con _attr _o_visit _path ) +sem_Error (MissingInstSig _nt _con _attr ) = + (sem_Error_MissingInstSig _nt _con _attr ) +sem_Error (MissingRule _nt _con _field _attr ) = + (sem_Error_MissingRule _nt _con _field _attr ) +sem_Error (MissingTypeSig _nt _con _attr ) = + (sem_Error_MissingTypeSig _nt _con _attr ) +sem_Error (ParserError _pos _problem _action ) = + (sem_Error_ParserError _pos _problem _action ) +sem_Error (SuperfluousRule _nt _con _field _attr ) = + (sem_Error_SuperfluousRule _nt _con _field _attr ) +sem_Error (UndefAlt _nt _con ) = + (sem_Error_UndefAlt _nt _con ) +sem_Error (UndefAttr _nt _con _field _attr ) = + (sem_Error_UndefAttr _nt _con _field _attr ) +sem_Error (UndefChild _nt _con _name ) = + (sem_Error_UndefChild _nt _con _name ) +sem_Error (UndefLocal _nt _con _var ) = + (sem_Error_UndefLocal _nt _con _var ) +sem_Error (UndefNont _nt ) = + (sem_Error_UndefNont _nt ) +-- semantic domain +newtype T_Error = T_Error (Bool -> + ( Error,PP_Doc)) +data Inh_Error = Inh_Error {verbose_Inh_Error :: Bool} +data Syn_Error = Syn_Error {me_Syn_Error :: Error,pp_Syn_Error :: PP_Doc} +wrap_Error (T_Error sem ) (Inh_Error _lhsIverbose ) = + (let ( _lhsOme,_lhsOpp) = + (sem _lhsIverbose ) + in (Syn_Error _lhsOme _lhsOpp )) +sem_Error_ChildAsLocal :: Nonterminal -> + Constructor -> + Name -> + T_Error +sem_Error_ChildAsLocal nt_ con_ var_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 297, column 21) + _lhsOpp = + let mesg = wfill ["Nontrivial field ",getName var_, "is used as local at constructor" + , getName con_ , "of nonterminal",getName nt_, "." + ] + pat = "SEM" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< "... = " + >#< "..." >#< "@" >|< getName var_ >#< "..." ) + help = wfill ["A rule in the definitions for alternative" , getName con_ ,"of nonterminal" + , getName nt_ , "contains a nontrivial field name", getName var_, "." + ,"You should use @", getName var_, ".self instead, where self is a SELF-attribute." + ] + act = wfill ["The generated program probably contains a type error or has undefined variables."] + in ppError (isError _me) (getPos var_) mesg pat help act _lhsIverbose + -- self rule + _me = + ChildAsLocal nt_ con_ var_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_CustomError :: Bool -> + Pos -> + PP_Doc -> + T_Error +sem_Error_CustomError isWarning_ pos_ mesg_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 335, column 21) + _lhsOpp = + let pat = text "unknown" + help = wfill ["not available."] + act = wfill ["unknown"] + in ppError (isError _me) pos_ mesg_ pat help act False + -- self rule + _me = + CustomError isWarning_ pos_ mesg_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_CyclicSet :: Name -> + T_Error +sem_Error_CyclicSet name_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 326, column 21) + _lhsOpp = + let mesg = wfill ["Cyclic definition for nonterminal set", getName name_] + pat = "SET" >#< getName name_ >#< "=" >#< "..." >#< getName name_ >#< "..." + help = wfill ["The defintion for a nonterminal set named" , getName name_ + ,"directly or indirectly refers to itself." + ,"Adapt the definition of the nonterminal set, to remove the cyclic dependency." + ] + act = wfill ["The nonterminal set", getName name_, "is considered to be empty."] + in ppError (isError _me) (getPos name_) mesg pat help act _lhsIverbose + -- self rule + _me = + CyclicSet name_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_DirectCirc :: Nonterminal -> + Bool -> + ([((Name,Name),[String],[String])]) -> + T_Error +sem_Error_DirectCirc nt_ o_visit_ cyclic_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 364, column 21) + _lhsOpp = + let mesg = wfill ["In nonterminal", getName nt_, "synthesized and inherited attributes are mutually dependent" ] + >-< vlist (map showEdge cyclic_) + pat = text "" + help = vlist (map showEdgeLong cyclic_) + act | o_visit_ = text "An unoptimized version was generated. It might hang when run." + | otherwise = text "The generated program might hang when run." + in ppError (isError _me) noPos mesg pat help act _lhsIverbose + -- self rule + _me = + DirectCirc nt_ o_visit_ cyclic_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_DupAlt :: Nonterminal -> + Constructor -> + Constructor -> + T_Error +sem_Error_DupAlt nt_ con_ occ1_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 70, column 21) + _lhsOpp = + let mesg = wfill ["Repeated definition for alternative", getName con_ + ,"of nonterminal", getName nt_, "." + ] >-< + wfill ["First definition:", (showPos occ1_),"."] >-< + wfill ["Other definition:", (showPos con_),"."] + pat = "DATA" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< "...") + >-< indent 2 ("|" >#< getName con_ >#< "...") + help = wfill ["The nonterminal",getName nt_,"has more than one alternative that" + ,"is labelled with the constructor name",getName con_,"." + ,"You should either rename or remove enough of them to make all" + ,"constructors of",getName nt_,"uniquely named." + ] + act = wfill [ "The first alternative of name",getName con_ + ,"you have given for nonterminal",getName nt_ + ,"is considered valid. All other alternatives have been discarded." + ] + in ppError (isError _me) (getPos con_) mesg pat help act _lhsIverbose + -- self rule + _me = + DupAlt nt_ con_ occ1_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_DupChild :: Nonterminal -> + Constructor -> + Name -> + Name -> + T_Error +sem_Error_DupChild nt_ con_ name_ occ1_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 163, column 21) + _lhsOpp = + let mesg = wfill ["Repeated declaration for field", getName name_, "of alternative" + ,getName con_, "of nonterminal", getName nt_, "." + ] >-< + wfill ["First definition:", (showPos occ1_),"."] >-< + wfill ["Other definition:", (showPos name_),"."] + pat = "DATA" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< (getName name_ >|< ":..." >-< getName name_ >|< ":...")) + help = wfill ["The alternative" ,getName con_ , "of nonterminal" ,getName nt_ + ,"has more than one field that is named" + , getName name_ ++ ". Possibly they have different types." + ,"You should either rename or remove enough of them to make all fields of" + ,getName con_ , "for nonterminal " , getName nt_ , "uniquely named." + ] + act = wfill ["The last declaration with its corresponding type is considered valid." + ,"All others have been discarded." + ] + in ppError (isError _me) (getPos name_) mesg pat help act _lhsIverbose + -- self rule + _me = + DupChild nt_ con_ name_ occ1_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_DupInhAttr :: Nonterminal -> + Name -> + Name -> + T_Error +sem_Error_DupInhAttr nt_ attr_ occ1_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 125, column 21) + _lhsOpp = + let mesg = wfill ["Repeated declaration of inherited attribute", getName attr_ + , "of nonterminal", getName nt_, "." + ] >-< + wfill ["First definition:", (showPos occ1_),"."] >-< + wfill ["Other definition:", (showPos attr_),"."] + pat = "ATTR" >#< getName nt_ >#< "[" >#< getName attr_ >|< ":...," + >#< getName attr_ >|< ":... | | ]" + help = wfill ["The identifier" , getName attr_ ,"has been declared" + ,"as an inherited (or chained) attribute for nonterminal" + ,getName nt_ , "more than once, with possibly different types." + ,"Delete all but one or rename them to make them unique." + ] + act = wfill ["One declaration with its corresponding type is considered valid." + ,"All others have been discarded. The generated program will probably not run." + ] + in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + -- self rule + _me = + DupInhAttr nt_ attr_ occ1_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_DupRule :: Nonterminal -> + Constructor -> + Name -> + Name -> + Name -> + T_Error +sem_Error_DupRule nt_ con_ field_ attr_ occ1_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 183, column 21) + _lhsOpp = + let mesg = wfill ["At constructor",getName con_, "of nonterminal", getName nt_, "there are two or more rules for" + ,showAttrDef field_ attr_,"." + ] >-< + wfill ["First rule:", (showPos occ1_),"."] >-< + wfill ["Other rule:", (showPos attr_),"."] + pat = "SEM" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< ppAttr field_ attr_ >#< "= ...") + >-< indent 2 ("|" >#< getName con_ >#< ppAttr field_ attr_ >#< "= ...") + help = wfill ["In the rules for alternative" , getName con_ , "of nonterminal" , getName nt_ + ,", there is more than one rule for the" , showAttrDef field_ attr_ + ,". You should either rename or remove enough of them to make all rules for alternative" + ,getName con_ , "of nonterminal " ,getName nt_ , "uniquely named." + ] + act = wfill ["The last rule given is considered valid. All others have been discarded."] + in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + -- self rule + _me = + DupRule nt_ con_ field_ attr_ occ1_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_DupSet :: Nonterminal -> + Nonterminal -> + T_Error +sem_Error_DupSet name_ occ1_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 109, column 21) + _lhsOpp = + let mesg = wfill ["Definition of nonterminal set", getName name_, "clashes with another" + ,"set, a type synonym or a data definition." + ] >-< + wfill ["First definition:", (showPos occ1_),"."] >-< + wfill ["Set definition:" , (showPos name_),"."] + pat = "SET" >#< getName name_ >#< "=" >#< "..." + >-< "SET" >#< getName name_ >#< "=" >#< "..." + help = wfill ["A nonterminal set with name", getName name_ + ,"has been given while there already is a SET, DATA, or TYPE" + ,"definition with the same name." + ,"You should either rename or remove the nonterminal set." + ] + act = wfill [ "The clashing nonterminal set will be ignored." + ] + in ppError (isError _me) (getPos name_) mesg pat help act _lhsIverbose + -- self rule + _me = + DupSet name_ occ1_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_DupSig :: Nonterminal -> + Constructor -> + Name -> + T_Error +sem_Error_DupSig nt_ con_ attr_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 201, column 21) + _lhsOpp = + let mesg = wfill ["At constructor",getName con_, "of nonterminal", getName nt_, "there are two or more typesignatures for" + ,showAttrDef _LOC attr_,"." + ] >-< + wfill ["First signature:", (showPos attr_),"."] + pat = "SEM" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< ppAttr _LOC attr_ >#< "= ...") + >-< indent 2 ("|" >#< getName con_ >#< ppAttr _LOC attr_ >#< "= ...") + help = wfill ["In the rules for alternative" , getName con_ , "of nonterminal" , getName nt_ + ,", there is more than one rule for the" , showAttrDef _LOC attr_ + ,". You should remove enough of them to make all typesignatures for alternative" + ,getName con_ , "of nonterminal " ,getName nt_ , "unique." + ] + act = wfill ["The last typesignature given is considered valid. All others have been discarded."] + in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + -- self rule + _me = + DupSig nt_ con_ attr_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_DupSynAttr :: Nonterminal -> + Name -> + Name -> + T_Error +sem_Error_DupSynAttr nt_ attr_ occ1_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 144, column 21) + _lhsOpp = + let mesg = wfill ["Repeated declaration of synthesized attribute", getName attr_ + , "of nonterminal", getName nt_, "." + ] >-< + wfill ["First definition:", (showPos occ1_),"."] >-< + wfill ["Other definition:", (showPos attr_),"."] + pat = "ATTR" >#< getName nt_ >#< "[ | |" >#< getName attr_ >|< ":...," + >#< getName attr_ >|< ":... ]" + help = wfill ["The identifier" , getName attr_ ,"has been declared" + ,"as a synthesized (or chained) attribute for nonterminal" + ,getName nt_ , "more than once, with possibly different types." + ,"Delete all but one or rename them to make them unique." + ] + act = wfill ["One declaration with its corresponding type is considered valid." + ,"All others have been discarded. The generated program will probably not run." + ] + in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + -- self rule + _me = + DupSynAttr nt_ attr_ occ1_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_DupSynonym :: Nonterminal -> + Nonterminal -> + T_Error +sem_Error_DupSynonym nt_ occ1_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 92, column 21) + _lhsOpp = + let mesg = wfill ["Definition of type synonym", getName nt_, "clashes with another" + ,"type synonym." + ] >-< + wfill ["First definition:", (showPos occ1_),"."] >-< + wfill ["Type synonym :" , (showPos nt_),"."] + pat = "DATA" >#< getName nt_ + >-< indent 2 ("|" >#< "...") + >-< "TYPE" >#< getName nt_ >#< "=" >#< "..." + help = wfill ["A type synonym with name", getName nt_ + ,"has been given while there already is TYPE" + ,"definition with the same name." + ,"You should either rename or remove the type synonym." + ] + act = wfill [ "The clashing type synonym will be ignored." + ] + in ppError (isError _me) (getPos nt_) mesg pat help act _lhsIverbose + -- self rule + _me = + DupSynonym nt_ occ1_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_ErroneousOrder :: Nonterminal -> + Constructor -> + Dependency -> + T_Error +sem_Error_ErroneousOrder nt_ con_ order_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 409, column 21) + _lhsOpp = + let (Dependency (fldA,nmA) (fldB,nmB)) = order_ + mesg = wfill ["At alternative",getName con_, "of nonterminal", getName nt_, "there is an erroneous order" + , showAttrDef fldA nmA + , "<" + , showAttrDef fldB nmB + ] + pat = "SEM" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< ppAttr fldA nmA >#< "<" >#< ppAttr fldB nmB) + help = wfill [ "In the rules for alternative" , getName con_ , "of nonterminal" , getName nt_ + , ", there is an erroneous attribute order defined" + , showAttrDef fldA nmA, "<", showAttrDef fldB nmB + , "because" + , showAttrDef fldA nmA + , "is not an In-attribute (inherited attribute of the production, or a synthesized attribute of a child)" + ] + act = wfill ["Please change the order definition."] + in ppError (isError _me) (getPos fldA) mesg pat help act _lhsIverbose + -- self rule + _me = + ErroneousOrder nt_ con_ order_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_InducedCirc :: Nonterminal -> + CInterface -> + ([((Name,Name),[String],[String])]) -> + T_Error +sem_Error_InducedCirc nt_ cinter_ cyclic_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 372, column 21) + _lhsOpp = + let mesg = wfill ["After scheduling, in nonterminal", getName nt_, "synthesized and inherited attributes have an INDUCED mutual dependency" ] + >-< vlist (map showEdge cyclic_) + pat = text "" + showInter (CInterface segs) = concat (snd (mapAccumL (\i c -> (i+1,("visit " ++ show i) : map ind (showsSegment c))) 0 segs)) + help = vlist (("Interface for nonterminal " ++ getName nt_ ++ ":") : map ind (showInter cinter_)) + >-< vlist (map showEdgeLong cyclic_) + act = text "An unoptimized version was generated. It might hang when run." + in ppError (isError _me) noPos mesg pat help act _lhsIverbose + -- self rule + _me = + InducedCirc nt_ cinter_ cyclic_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_InstCirc :: Nonterminal -> + Constructor -> + Name -> + Bool -> + ([String]) -> + T_Error +sem_Error_InstCirc nt_ con_ attr_ o_visit_ path_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 352, column 21) + _lhsOpp = + let mesg = wfill ["Circular dependency for inst attribute", getName attr_ + , "of alternative", getName con_, "of nonterminal", getName nt_] + pat = "SEM" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< "inst." >|< getName attr_ >#< "=" + >#< "..." >#< "@s." >#< "...") + help = if null path_ + then text "the definition is directly circular" + else hlist ("The following attributes are involved in the cycle:": path_) + act | o_visit_ = text "An unoptimized version was generated. It might hang when run." + | otherwise = text "The generated program might hang when run." + in ppError (isError _me) (getPos (attr_)) mesg pat help act _lhsIverbose + -- self rule + _me = + InstCirc nt_ con_ attr_ o_visit_ path_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_LocalCirc :: Nonterminal -> + Constructor -> + Name -> + Bool -> + ([String]) -> + T_Error +sem_Error_LocalCirc nt_ con_ attr_ o_visit_ path_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 340, column 21) + _lhsOpp = + let mesg = wfill ["Circular dependency for local attribute", getName attr_ + , "of alternative", getName con_, "of nonterminal", getName nt_] + pat = "SEM" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< "loc." >|< getName attr_ >#< "=" + >#< "..." >#< "@loc." >|< getName attr_ >#< "...") + help = if null path_ + then text "the definition is directly circular" + else hlist ("The following attributes are involved in the cycle:": path_) + act | o_visit_ = text "An unoptimized version was generated. It might hang when run." + | otherwise = text "The generated program might hang when run." + in ppError (isError _me) (getPos (attr_)) mesg pat help act _lhsIverbose + -- self rule + _me = + LocalCirc nt_ con_ attr_ o_visit_ path_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_MissingInstSig :: Nonterminal -> + Constructor -> + Name -> + T_Error +sem_Error_MissingInstSig nt_ con_ attr_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 395, column 21) + _lhsOpp = + let mesg = wfill ["Type signature needed, but not found for", showAttrDef _INST attr_ , "in alternative" + , getName con_ , "of nonterminal",getName nt_ ,"." + ]>-< + wfill ["Location:", (showPos attr_),"."] + pat = "SEM" >#< nt_ + >-< indent 2 ("|" >#< getName con_ >#< ppAttr _INST attr_ >#< ": ...") + help = wfill ["The", showAttrDef _INST attr_, "in alternative", getName con_ + ,"of nonterminal", getName nt_, "is a non-terminal attribute, so " + ,"its type is needed to attribute its value." + ,"Please supply its type." + ] + act = wfill ["It is not possible to proceed without this signature."] + in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + -- self rule + _me = + MissingInstSig nt_ con_ attr_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_MissingRule :: Nonterminal -> + Constructor -> + Name -> + Name -> + T_Error +sem_Error_MissingRule nt_ con_ field_ attr_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 255, column 21) + _lhsOpp = + let mesg = wfill ["Missing rule for", showAttrDef field_ attr_ , "in alternative" + , getName con_ , "of nonterminal",getName nt_ ,"." + ] + pat = "SEM" >#< nt_ + >-< indent 2 ("|" >#< getName con_ >#< ppAttr field_ attr_ >#< "= ...") + help = wfill ["The", showAttrDef field_ attr_, "in alternative", getName con_ + , "of nonterminal", getName nt_, "is missing and cannot be inferred" + ,"by a copy rule, so you should add an appropriate rule." + ] + act = wfill ["The value of the attribute has been set to undefined."] + in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + -- self rule + _me = + MissingRule nt_ con_ field_ attr_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_MissingTypeSig :: Nonterminal -> + Constructor -> + Name -> + T_Error +sem_Error_MissingTypeSig nt_ con_ attr_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 381, column 21) + _lhsOpp = + let mesg = wfill ["Type signature needed, but not found for", showAttrDef _LOC attr_ , "in alternative" + , getName con_ , "of nonterminal",getName nt_ ,"." + ]>-< + wfill ["Location:", (showPos attr_),"."] + pat = "SEM" >#< nt_ + >-< indent 2 ("|" >#< getName con_ >#< ppAttr _LOC attr_ >#< ": ...") + help = wfill ["The", showAttrDef _LOC attr_, "in alternative", getName con_ + ,"of nonterminal", getName nt_, "is needed in two separate visits to", getName nt_ + ,"so its type is needed to generate type signatures." + ,"Please supply its type." + ] + act = wfill ["The type signatures of semantic functions are not generated."] + in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + -- self rule + _me = + MissingTypeSig nt_ con_ attr_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_ParserError :: Pos -> + String -> + String -> + T_Error +sem_Error_ParserError pos_ problem_ action_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 64, column 21) + _lhsOpp = + let mesg = text ("parser expecting " ++ problem_) + pat = text "" + help = text "" + act = text action_ + in ppError (isError _me) pos_ mesg pat help act _lhsIverbose + -- self rule + _me = + ParserError pos_ problem_ action_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_SuperfluousRule :: Nonterminal -> + Constructor -> + Name -> + Name -> + T_Error +sem_Error_SuperfluousRule nt_ con_ field_ attr_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 268, column 21) + _lhsOpp = + let mesg = wfill ["Rule for non-existing", showAttrDef field_ attr_ , "at alternative" + , getName con_ , "of nonterminal",getName nt_, "." + ] + pat = "SEM" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< ppAttr field_ attr_ >#< "= ...") + help = wfill ["There is a rule for" , showAttrDef field_ attr_ , "in the definitions for alternative" , getName con_ + ,"of nonterminal" , getName nt_, ", but this attribute does not exist. Maybe you misspelled it?" + ,"Otherwise either remove the rule or add an appropriate attribute definition." + ] + act = wfill ["The rule has been ignored."] + in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + -- self rule + _me = + SuperfluousRule nt_ con_ field_ attr_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_UndefAlt :: Nonterminal -> + Constructor -> + T_Error +sem_Error_UndefAlt nt_ con_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 228, column 21) + _lhsOpp = + let mesg = wfill ["Constructor", getName con_, "of nonterminal" ,getName nt_, "is not defined." + ] + pat = "DATA" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< "...") + help = wfill ["There are rules for alternative", getName con_ , "of nonterminal" ,getName nt_ + ,", but there is no definition for this alternative in the definitions of the" + ,"nonterminal" , getName nt_, ". Maybe you misspelled it? Otherwise insert a definition." + ] + act = wfill ["All rules for the unknown alternative have been ignored."] + in ppError (isError _me) (getPos con_) mesg pat help act _lhsIverbose + -- self rule + _me = + UndefAlt nt_ con_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_UndefAttr :: Nonterminal -> + Constructor -> + Name -> + Name -> + T_Error +sem_Error_UndefAttr nt_ con_ field_ attr_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 311, column 21) + _lhsOpp = + let mesg = wfill ["Undefined", showAttrUse field_ attr_, "at constructor" + , getName con_ , "of nonterminal",getName nt_, "." + ] + pat = "SEM" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< ". = " + >#< "..." >#< ppAttrUse field_ attr_ >#< "...") + help = wfill ["A rule in the definitions for alternative" , getName con_ ,"of nonterminal" + ,getName nt_ , "contains an attribute that is not defined" + ,"Maybe you misspelled it?" + ,"Otherwise either remove the rule or add an appropriate attribute definition." + ] + act = wfill ["The generated program will not run."] + in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + -- self rule + _me = + UndefAttr nt_ con_ field_ attr_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_UndefChild :: Nonterminal -> + Constructor -> + Name -> + T_Error +sem_Error_UndefChild nt_ con_ name_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 240, column 21) + _lhsOpp = + let mesg = wfill ["Constructor", getName con_, "of nonterminal" ,getName nt_ + , "does not have a nontrivial field named", getName name_ , "." + ] + pat = "SEM" >#< nt_ + >-< indent 2 ("|" >#< getName con_ >#< ppAttr name_ (identifier "") >#< "= ...") + help = wfill ["There are rules that define or use attributes of field" , getName name_ + ,"in alternative" , getName con_ , "of nonterminal" , getName nt_ + ,", but there is no field with AG-type in the definition of the alternative." + ,"Maybe you misspelled it? Otherwise insert the field into the definition," + ,"or change its type from an HS-type to an AG-type." + ] + act = wfill ["All rules for the unknown field have been ignored."] + in ppError (isError _me) (getPos name_) mesg pat help act _lhsIverbose + -- self rule + _me = + UndefChild nt_ con_ name_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_UndefLocal :: Nonterminal -> + Constructor -> + Name -> + T_Error +sem_Error_UndefLocal nt_ con_ var_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 282, column 21) + _lhsOpp = + let mesg = wfill ["Undefined local variable or field",getName var_, "at constructor" + , getName con_ , "of nonterminal",getName nt_, "." + ] + pat = "SEM" >#< getName nt_ + >-< indent 2 ("|" >#< getName con_ >#< ". = " + >#< "..." >#< "@" >|< getName var_ >#< "..." ) + help = wfill ["A rule in the definitions for alternative" , getName con_ ,"of nonterminal" + , getName nt_ , "contains a local variable or field name that is not defined" + ,"Maybe you misspelled it?" + ,"Otherwise either remove the rule or add an appropriate definition." + ] + act = wfill ["The generated program will not run."] + in ppError (isError _me) (getPos var_) mesg pat help act _lhsIverbose + -- self rule + _me = + UndefLocal nt_ con_ var_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +sem_Error_UndefNont :: Nonterminal -> + T_Error +sem_Error_UndefNont nt_ = + (T_Error (\ _lhsIverbose -> + (let _lhsOpp :: PP_Doc + _lhsOme :: Error + -- "PrintErrorMessages.ag"(line 218, column 21) + _lhsOpp = + let mesg = wfill ["Nonterminal", getName nt_, "is not defined." + ] + pat = "DATA" >#< getName nt_ >#< "..." + help = wfill ["There are attributes and/or rules for nonterminal" , getName nt_ ,", but there is no definition" + , "for" ,getName nt_, ". Maybe you misspelled it? Otherwise insert a definition." + ] + act = wfill ["Everything regarding the unknown nonterminal has been ignored."] + in ppError (isError _me) (getPos nt_) mesg pat help act _lhsIverbose + -- self rule + _me = + UndefNont nt_ + -- self rule + _lhsOme = + _me + in ( _lhsOme,_lhsOpp))) ) +-- Errors ------------------------------------------------------ +{- + visit 0: + inherited attribute: + options : Options + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Cons: + child hd : Error + child tl : Errors + visit 0: + local verbose : _ + alternative Nil: + visit 0: + local verbose : _ +-} +-- cata +sem_Errors :: Errors -> + T_Errors +sem_Errors list = + (Prelude.foldr sem_Errors_Cons sem_Errors_Nil (Prelude.map sem_Error list) ) +-- semantic domain +newtype T_Errors = T_Errors (Options -> + ( PP_Doc)) +data Inh_Errors = Inh_Errors {options_Inh_Errors :: Options} +data Syn_Errors = Syn_Errors {pp_Syn_Errors :: PP_Doc} +wrap_Errors (T_Errors sem ) (Inh_Errors _lhsIoptions ) = + (let ( _lhsOpp) = + (sem _lhsIoptions ) + in (Syn_Errors _lhsOpp )) +sem_Errors_Cons :: T_Error -> + T_Errors -> + T_Errors +sem_Errors_Cons (T_Error hd_ ) (T_Errors tl_ ) = + (T_Errors (\ _lhsIoptions -> + (let _lhsOpp :: PP_Doc + _hdOverbose :: Bool + _tlOoptions :: Options + _hdIme :: Error + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + -- "PrintErrorMessages.ag"(line 59, column 8) + _verbose = + verbose _lhsIoptions + -- use rule "PrintErrorMessages.ag"(line 55, column 49) + _lhsOpp = + _hdIpp >-< _tlIpp + -- copy rule (from local) + _hdOverbose = + _verbose + -- copy rule (down) + _tlOoptions = + _lhsIoptions + ( _hdIme,_hdIpp) = + (hd_ _hdOverbose ) + ( _tlIpp) = + (tl_ _tlOoptions ) + in ( _lhsOpp))) ) +sem_Errors_Nil :: T_Errors +sem_Errors_Nil = + (T_Errors (\ _lhsIoptions -> + (let _lhsOpp :: PP_Doc + -- "PrintErrorMessages.ag"(line 59, column 8) + _verbose = + verbose _lhsIoptions + -- use rule "PrintErrorMessages.ag"(line 55, column 49) + _lhsOpp = + text "" + in ( _lhsOpp))) ) diff --git a/src-derived/SemHsTokens.hs b/src-derived/SemHsTokens.hs new file mode 100644 --- /dev/null +++ b/src-derived/SemHsTokens.hs @@ -0,0 +1,561 @@ +-- UUAGC 0.9.5 (SemHsTokens.ag) +module SemHsTokens where + +import UU.DData.Seq as Seq(Seq,empty,single,(<>),toList) +import Pretty + +import TokenDef +import HsToken +import ErrorMessages + +import CommonTypes +import UU.Scanner.Position(Pos) + +isNTname allnts (Just (NT nt)) = nt `elem` allnts +isNTname allnts _ = False +-- HsToken ----------------------------------------------------- +{- + visit 0: + inherited attributes: + allfields : [(Name,Type,Bool)] + allnts : [Name] + attrs : [(Identifier,Identifier)] + con : Identifier + fieldnames : [Identifier] + nt : Identifier + synthesized attributes: + errors : Seq Error + tok : (Pos,String) + usedAttrs : [(Identifier,Identifier)] + usedFields : Seq Identifier + usedLocals : [Identifier] + alternatives: + alternative AGField: + child field : {Name} + child attr : {Name} + child pos : {Pos} + alternative AGLocal: + child var : {Name} + child pos : {Pos} + visit 0: + local _tup1 : _ + local errors : _ + local tok : _ + local usedLocals : _ + alternative CharToken: + child value : {String} + child pos : {Pos} + alternative Err: + child mesg : {String} + child pos : {Pos} + alternative HsToken: + child value : {String} + child pos : {Pos} + alternative StrToken: + child value : {String} + child pos : {Pos} +-} +-- cata +sem_HsToken :: HsToken -> + T_HsToken +sem_HsToken (AGField _field _attr _pos) = + (sem_HsToken_AGField _field _attr _pos) +sem_HsToken (AGLocal _var _pos) = + (sem_HsToken_AGLocal _var _pos) +sem_HsToken (CharToken _value _pos) = + (sem_HsToken_CharToken _value _pos) +sem_HsToken (Err _mesg _pos) = + (sem_HsToken_Err _mesg _pos) +sem_HsToken (HsToken _value _pos) = + (sem_HsToken_HsToken _value _pos) +sem_HsToken (StrToken _value _pos) = + (sem_HsToken_StrToken _value _pos) +-- semantic domain +newtype T_HsToken = T_HsToken (([(Name,Type,Bool)]) -> + ([Name]) -> + ([(Identifier,Identifier)]) -> + Identifier -> + ([Identifier]) -> + Identifier -> + ( (Seq Error),((Pos,String)),([(Identifier,Identifier)]),(Seq Identifier),([Identifier]))) +data Inh_HsToken = Inh_HsToken {allfields_Inh_HsToken :: [(Name,Type,Bool)],allnts_Inh_HsToken :: [Name],attrs_Inh_HsToken :: [(Identifier,Identifier)],con_Inh_HsToken :: Identifier,fieldnames_Inh_HsToken :: [Identifier],nt_Inh_HsToken :: Identifier} +data Syn_HsToken = Syn_HsToken {errors_Syn_HsToken :: Seq Error,tok_Syn_HsToken :: (Pos,String),usedAttrs_Syn_HsToken :: [(Identifier,Identifier)],usedFields_Syn_HsToken :: Seq Identifier,usedLocals_Syn_HsToken :: [Identifier]} +wrap_HsToken (T_HsToken sem) (Inh_HsToken _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) = + (let ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals) = + (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) + in (Syn_HsToken _lhsOerrors _lhsOtok _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals)) +sem_HsToken_AGField :: Name -> + Name -> + Pos -> + T_HsToken +sem_HsToken_AGField field_ attr_ pos_ = + (T_HsToken (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIfieldnames + _lhsInt -> + (let _lhsOerrors :: (Seq Error) + _lhsOusedAttrs :: ([(Identifier,Identifier)]) + _lhsOtok :: ((Pos,String)) + _lhsOusedFields :: (Seq Identifier) + _lhsOusedLocals :: ([Identifier]) + -- "SemHsTokens.ag"(line 73, column 15) + _lhsOerrors = + if (field_,attr_) `elem` _lhsIattrs + then Seq.empty + else if not(field_ `elem` (_LHS : _LOC: _lhsIfieldnames)) + then Seq.single (UndefChild _lhsInt _lhsIcon field_) + else Seq.single (UndefAttr _lhsInt _lhsIcon field_ attr_) + -- "SemHsTokens.ag"(line 87, column 13) + _lhsOusedAttrs = + [(field_,attr_)] + -- "SemHsTokens.ag"(line 113, column 14) + _lhsOtok = + (pos_, attrname True field_ attr_) + -- use rule "SemHsTokens.ag"(line 92, column 40) + _lhsOusedFields = + Seq.empty + -- use rule "SemHsTokens.ag"(line 83, column 40) + _lhsOusedLocals = + [] + in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) +sem_HsToken_AGLocal :: Name -> + Pos -> + T_HsToken +sem_HsToken_AGLocal var_ pos_ = + (T_HsToken (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIfieldnames + _lhsInt -> + (let _lhsOusedFields :: (Seq Identifier) + _lhsOerrors :: (Seq Error) + _lhsOusedAttrs :: ([(Identifier,Identifier)]) + _lhsOusedLocals :: ([Identifier]) + _lhsOtok :: ((Pos,String)) + -- "SemHsTokens.ag"(line 63, column 19) + __tup1 = + if var_ `elem` _lhsIfieldnames + then if isNTname _lhsIallnts (lookup var_ (map (\(n,t,_) -> (n,t)) _lhsIallfields)) + then (Seq.single(ChildAsLocal _lhsInt _lhsIcon var_), (pos_,fieldname var_), [] ) + else (Seq.empty, (pos_,fieldname var_), [] ) + else if (_LOC,var_) `elem` _lhsIattrs + then (Seq.empty , (pos_,locname var_), [var_]) + else (Seq.single(UndefLocal _lhsInt _lhsIcon var_), (pos_,locname var_), [] ) + -- "SemHsTokens.ag"(line 63, column 19) + (_errors,_,_) = + __tup1 + -- "SemHsTokens.ag"(line 63, column 19) + (_,_tok,_) = + __tup1 + -- "SemHsTokens.ag"(line 63, column 19) + (_,_,_usedLocals) = + __tup1 + -- "SemHsTokens.ag"(line 95, column 13) + _lhsOusedFields = + if var_ `elem` _lhsIfieldnames + then Seq.single var_ + else Seq.empty + -- use rule "SemHsTokens.ag"(line 42, column 37) + _lhsOerrors = + _errors + -- use rule "SemHsTokens.ag"(line 84, column 40) + _lhsOusedAttrs = + [] + -- use rule "SemHsTokens.ag"(line 83, column 40) + _lhsOusedLocals = + _usedLocals + -- copy rule (from local) + _lhsOtok = + _tok + in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) +sem_HsToken_CharToken :: String -> + Pos -> + T_HsToken +sem_HsToken_CharToken value_ pos_ = + (T_HsToken (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIfieldnames + _lhsInt -> + (let _lhsOtok :: ((Pos,String)) + _lhsOerrors :: (Seq Error) + _lhsOusedAttrs :: ([(Identifier,Identifier)]) + _lhsOusedFields :: (Seq Identifier) + _lhsOusedLocals :: ([Identifier]) + -- "SemHsTokens.ag"(line 117, column 16) + _lhsOtok = + (pos_, if null value_ + then "" + else showCharShort (head value_) + ) + -- use rule "SemHsTokens.ag"(line 42, column 37) + _lhsOerrors = + Seq.empty + -- use rule "SemHsTokens.ag"(line 84, column 40) + _lhsOusedAttrs = + [] + -- use rule "SemHsTokens.ag"(line 92, column 40) + _lhsOusedFields = + Seq.empty + -- use rule "SemHsTokens.ag"(line 83, column 40) + _lhsOusedLocals = + [] + in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) +sem_HsToken_Err :: String -> + Pos -> + T_HsToken +sem_HsToken_Err mesg_ pos_ = + (T_HsToken (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIfieldnames + _lhsInt -> + (let _lhsOerrors :: (Seq Error) + _lhsOtok :: ((Pos,String)) + _lhsOusedAttrs :: ([(Identifier,Identifier)]) + _lhsOusedFields :: (Seq Identifier) + _lhsOusedLocals :: ([Identifier]) + -- "SemHsTokens.ag"(line 49, column 9) + _lhsOerrors = + let m = text mesg_ + in Seq.single (CustomError False pos_ m) + -- "SemHsTokens.ag"(line 123, column 16) + _lhsOtok = + (pos_, "") + -- use rule "SemHsTokens.ag"(line 84, column 40) + _lhsOusedAttrs = + [] + -- use rule "SemHsTokens.ag"(line 92, column 40) + _lhsOusedFields = + Seq.empty + -- use rule "SemHsTokens.ag"(line 83, column 40) + _lhsOusedLocals = + [] + in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) +sem_HsToken_HsToken :: String -> + Pos -> + T_HsToken +sem_HsToken_HsToken value_ pos_ = + (T_HsToken (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIfieldnames + _lhsInt -> + (let _lhsOtok :: ((Pos,String)) + _lhsOerrors :: (Seq Error) + _lhsOusedAttrs :: ([(Identifier,Identifier)]) + _lhsOusedFields :: (Seq Identifier) + _lhsOusedLocals :: ([Identifier]) + -- "SemHsTokens.ag"(line 115, column 14) + _lhsOtok = + (pos_, value_) + -- use rule "SemHsTokens.ag"(line 42, column 37) + _lhsOerrors = + Seq.empty + -- use rule "SemHsTokens.ag"(line 84, column 40) + _lhsOusedAttrs = + [] + -- use rule "SemHsTokens.ag"(line 92, column 40) + _lhsOusedFields = + Seq.empty + -- use rule "SemHsTokens.ag"(line 83, column 40) + _lhsOusedLocals = + [] + in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) +sem_HsToken_StrToken :: String -> + Pos -> + T_HsToken +sem_HsToken_StrToken value_ pos_ = + (T_HsToken (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIfieldnames + _lhsInt -> + (let _lhsOtok :: ((Pos,String)) + _lhsOerrors :: (Seq Error) + _lhsOusedAttrs :: ([(Identifier,Identifier)]) + _lhsOusedFields :: (Seq Identifier) + _lhsOusedLocals :: ([Identifier]) + -- "SemHsTokens.ag"(line 122, column 16) + _lhsOtok = + (pos_, showStrShort value_) + -- use rule "SemHsTokens.ag"(line 42, column 37) + _lhsOerrors = + Seq.empty + -- use rule "SemHsTokens.ag"(line 84, column 40) + _lhsOusedAttrs = + [] + -- use rule "SemHsTokens.ag"(line 92, column 40) + _lhsOusedFields = + Seq.empty + -- use rule "SemHsTokens.ag"(line 83, column 40) + _lhsOusedLocals = + [] + in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) +-- HsTokens ---------------------------------------------------- +{- + visit 0: + inherited attributes: + allfields : [(Name,Type,Bool)] + allnts : [Name] + attrs : [(Identifier,Identifier)] + con : Identifier + fieldnames : [Identifier] + nt : Identifier + synthesized attributes: + errors : Seq Error + tks : [(Pos,String)] + usedAttrs : [(Identifier,Identifier)] + usedFields : Seq Identifier + usedLocals : [Identifier] + alternatives: + alternative Cons: + child hd : HsToken + child tl : HsTokens + alternative Nil: +-} +-- cata +sem_HsTokens :: HsTokens -> + T_HsTokens +sem_HsTokens list = + (Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list)) +-- semantic domain +newtype T_HsTokens = T_HsTokens (([(Name,Type,Bool)]) -> + ([Name]) -> + ([(Identifier,Identifier)]) -> + Identifier -> + ([Identifier]) -> + Identifier -> + ( (Seq Error),([(Pos,String)]),([(Identifier,Identifier)]),(Seq Identifier),([Identifier]))) +data Inh_HsTokens = Inh_HsTokens {allfields_Inh_HsTokens :: [(Name,Type,Bool)],allnts_Inh_HsTokens :: [Name],attrs_Inh_HsTokens :: [(Identifier,Identifier)],con_Inh_HsTokens :: Identifier,fieldnames_Inh_HsTokens :: [Identifier],nt_Inh_HsTokens :: Identifier} +data Syn_HsTokens = Syn_HsTokens {errors_Syn_HsTokens :: Seq Error,tks_Syn_HsTokens :: [(Pos,String)],usedAttrs_Syn_HsTokens :: [(Identifier,Identifier)],usedFields_Syn_HsTokens :: Seq Identifier,usedLocals_Syn_HsTokens :: [Identifier]} +wrap_HsTokens (T_HsTokens sem) (Inh_HsTokens _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) = + (let ( _lhsOerrors,_lhsOtks,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals) = + (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) + in (Syn_HsTokens _lhsOerrors _lhsOtks _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals)) +sem_HsTokens_Cons :: T_HsToken -> + T_HsTokens -> + T_HsTokens +sem_HsTokens_Cons (T_HsToken hd_) (T_HsTokens tl_) = + (T_HsTokens (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIfieldnames + _lhsInt -> + (let _lhsOtks :: ([(Pos,String)]) + _lhsOerrors :: (Seq Error) + _lhsOusedAttrs :: ([(Identifier,Identifier)]) + _lhsOusedFields :: (Seq Identifier) + _lhsOusedLocals :: ([Identifier]) + _hdOallfields :: ([(Name,Type,Bool)]) + _hdOallnts :: ([Name]) + _hdOattrs :: ([(Identifier,Identifier)]) + _hdOcon :: Identifier + _hdOfieldnames :: ([Identifier]) + _hdOnt :: Identifier + _tlOallfields :: ([(Name,Type,Bool)]) + _tlOallnts :: ([Name]) + _tlOattrs :: ([(Identifier,Identifier)]) + _tlOcon :: Identifier + _tlOfieldnames :: ([Identifier]) + _tlOnt :: Identifier + _hdIerrors :: (Seq Error) + _hdItok :: ((Pos,String)) + _hdIusedAttrs :: ([(Identifier,Identifier)]) + _hdIusedFields :: (Seq Identifier) + _hdIusedLocals :: ([Identifier]) + _tlIerrors :: (Seq Error) + _tlItks :: ([(Pos,String)]) + _tlIusedAttrs :: ([(Identifier,Identifier)]) + _tlIusedFields :: (Seq Identifier) + _tlIusedLocals :: ([Identifier]) + -- "SemHsTokens.ag"(line 109, column 10) + _lhsOtks = + _hdItok : _tlItks + -- use rule "SemHsTokens.ag"(line 42, column 37) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "SemHsTokens.ag"(line 84, column 40) + _lhsOusedAttrs = + _hdIusedAttrs ++ _tlIusedAttrs + -- use rule "SemHsTokens.ag"(line 92, column 40) + _lhsOusedFields = + _hdIusedFields Seq.<> _tlIusedFields + -- use rule "SemHsTokens.ag"(line 83, column 40) + _lhsOusedLocals = + _hdIusedLocals ++ _tlIusedLocals + -- copy rule (down) + _hdOallfields = + _lhsIallfields + -- copy rule (down) + _hdOallnts = + _lhsIallnts + -- copy rule (down) + _hdOattrs = + _lhsIattrs + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOfieldnames = + _lhsIfieldnames + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _tlOallfields = + _lhsIallfields + -- copy rule (down) + _tlOallnts = + _lhsIallnts + -- copy rule (down) + _tlOattrs = + _lhsIattrs + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOfieldnames = + _lhsIfieldnames + -- copy rule (down) + _tlOnt = + _lhsInt + ( _hdIerrors,_hdItok,_hdIusedAttrs,_hdIusedFields,_hdIusedLocals) = + (hd_ _hdOallfields _hdOallnts _hdOattrs _hdOcon _hdOfieldnames _hdOnt) + ( _tlIerrors,_tlItks,_tlIusedAttrs,_tlIusedFields,_tlIusedLocals) = + (tl_ _tlOallfields _tlOallnts _tlOattrs _tlOcon _tlOfieldnames _tlOnt) + in ( _lhsOerrors,_lhsOtks,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) +sem_HsTokens_Nil :: T_HsTokens +sem_HsTokens_Nil = + (T_HsTokens (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIfieldnames + _lhsInt -> + (let _lhsOtks :: ([(Pos,String)]) + _lhsOerrors :: (Seq Error) + _lhsOusedAttrs :: ([(Identifier,Identifier)]) + _lhsOusedFields :: (Seq Identifier) + _lhsOusedLocals :: ([Identifier]) + -- "SemHsTokens.ag"(line 110, column 10) + _lhsOtks = + [] + -- use rule "SemHsTokens.ag"(line 42, column 37) + _lhsOerrors = + Seq.empty + -- use rule "SemHsTokens.ag"(line 84, column 40) + _lhsOusedAttrs = + [] + -- use rule "SemHsTokens.ag"(line 92, column 40) + _lhsOusedFields = + Seq.empty + -- use rule "SemHsTokens.ag"(line 83, column 40) + _lhsOusedLocals = + [] + in ( _lhsOerrors,_lhsOtks,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) +-- HsTokensRoot ------------------------------------------------ +{- + visit 0: + inherited attributes: + allfields : [(Name,Type,Bool)] + allnts : [Name] + attrs : [(Identifier,Identifier)] + con : Identifier + nt : Identifier + synthesized attributes: + errors : Seq Error + textLines : [String] + usedAttrs : [(Identifier,Identifier)] + usedFields : [Identifier] + usedLocals : [Identifier] + alternatives: + alternative HsTokensRoot: + child tokens : HsTokens +-} +-- cata +sem_HsTokensRoot :: HsTokensRoot -> + T_HsTokensRoot +sem_HsTokensRoot (HsTokensRoot _tokens) = + (sem_HsTokensRoot_HsTokensRoot (sem_HsTokens _tokens)) +-- semantic domain +newtype T_HsTokensRoot = T_HsTokensRoot (([(Name,Type,Bool)]) -> + ([Name]) -> + ([(Identifier,Identifier)]) -> + Identifier -> + Identifier -> + ( (Seq Error),([String]),([(Identifier,Identifier)]),([Identifier]),([Identifier]))) +data Inh_HsTokensRoot = Inh_HsTokensRoot {allfields_Inh_HsTokensRoot :: [(Name,Type,Bool)],allnts_Inh_HsTokensRoot :: [Name],attrs_Inh_HsTokensRoot :: [(Identifier,Identifier)],con_Inh_HsTokensRoot :: Identifier,nt_Inh_HsTokensRoot :: Identifier} +data Syn_HsTokensRoot = Syn_HsTokensRoot {errors_Syn_HsTokensRoot :: Seq Error,textLines_Syn_HsTokensRoot :: [String],usedAttrs_Syn_HsTokensRoot :: [(Identifier,Identifier)],usedFields_Syn_HsTokensRoot :: [Identifier],usedLocals_Syn_HsTokensRoot :: [Identifier]} +wrap_HsTokensRoot (T_HsTokensRoot sem) (Inh_HsTokensRoot _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt) = + (let ( _lhsOerrors,_lhsOtextLines,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals) = + (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt) + in (Syn_HsTokensRoot _lhsOerrors _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals)) +sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> + T_HsTokensRoot +sem_HsTokensRoot_HsTokensRoot (T_HsTokens tokens_) = + (T_HsTokensRoot (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsInt -> + (let _tokensOfieldnames :: ([Identifier]) + _lhsOusedFields :: ([Identifier]) + _lhsOtextLines :: ([String]) + _lhsOerrors :: (Seq Error) + _lhsOusedAttrs :: ([(Identifier,Identifier)]) + _lhsOusedLocals :: ([Identifier]) + _tokensOallfields :: ([(Name,Type,Bool)]) + _tokensOallnts :: ([Name]) + _tokensOattrs :: ([(Identifier,Identifier)]) + _tokensOcon :: Identifier + _tokensOnt :: Identifier + _tokensIerrors :: (Seq Error) + _tokensItks :: ([(Pos,String)]) + _tokensIusedAttrs :: ([(Identifier,Identifier)]) + _tokensIusedFields :: (Seq Identifier) + _tokensIusedLocals :: ([Identifier]) + -- "SemHsTokens.ag"(line 37, column 18) + _tokensOfieldnames = + map (\(n,_,_) -> n) _lhsIallfields + -- "SemHsTokens.ag"(line 99, column 18) + _lhsOusedFields = + Seq.toList _tokensIusedFields + -- "SemHsTokens.ag"(line 106, column 18) + _lhsOtextLines = + showTokens _tokensItks + -- use rule "SemHsTokens.ag"(line 16, column 18) + _lhsOerrors = + _tokensIerrors + -- copy rule (up) + _lhsOusedAttrs = + _tokensIusedAttrs + -- copy rule (up) + _lhsOusedLocals = + _tokensIusedLocals + -- copy rule (down) + _tokensOallfields = + _lhsIallfields + -- copy rule (down) + _tokensOallnts = + _lhsIallnts + -- copy rule (down) + _tokensOattrs = + _lhsIattrs + -- copy rule (down) + _tokensOcon = + _lhsIcon + -- copy rule (down) + _tokensOnt = + _lhsInt + ( _tokensIerrors,_tokensItks,_tokensIusedAttrs,_tokensIusedFields,_tokensIusedLocals) = + (tokens_ _tokensOallfields _tokensOallnts _tokensOattrs _tokensOcon _tokensOfieldnames _tokensOnt) + in ( _lhsOerrors,_lhsOtextLines,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) diff --git a/src-derived/Transform.hs b/src-derived/Transform.hs new file mode 100644 --- /dev/null +++ b/src-derived/Transform.hs @@ -0,0 +1,3548 @@ +-- UUAGC 0.9.5 (Transform.ag) +module Transform where + +import Control.Monad(mplus,mzero) +import List (partition, elem) +import Data.Maybe +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Set as Set (Set, member, union, toList, fromList, empty, singleton, member, unions, size, fold, intersection, difference, insert) +import UU.DData.Seq as Seq (Seq, empty, (<>), single, cons, toList, fromList) +import UU.Scanner.Position(noPos) + +import ConcreteSyntax +import AbstractSyntax +import ErrorMessages +import Patterns (Patterns(..),Pattern(..)) +import Expression (Expression(..)) + +import Options +import CommonTypes + +import UU.Scanner.Position (Pos) +import Patterns (Pattern) +import Expression (Expression) +import CommonTypes + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (Constructor,Name) +type DefinedSets = Map Name (Set Nonterminal) +type FieldMap = [(Name, Type)] +type DataTypes = Map.Map Nonterminal (Map.Map Constructor FieldMap) +type AttrName = (Name,Name) +type RuleInfo = ([AttrName]->Pattern, Expression, [AttrName], Bool, String) +type SigInfo = (Identifier,Type) + + +checkDuplicate :: (Identifier -> Identifier -> Error) + -> Identifier -> val -> Map Identifier val -> (Map Identifier val,Seq Error) +checkDuplicate dupError key val m + = case Map.lookupIndex key m of + Just ix -> let (key',_) = Map.elemAt ix m + in (m,Seq.single (dupError key key')) + Nothing -> (Map.insert key val m,Seq.empty) + +checkDuplicates :: (Identifier -> Identifier -> Error) + -> [(Identifier, val)] -> Map Identifier val -> (Map Identifier val,Seq Error) +checkDuplicates dupError new m = foldErrors check m new + where check = uncurry (checkDuplicate dupError) + +foldErrors f e xs = foldl g (e,Seq.empty) xs + where g ~(e,es) x = let (e',es') = f x e + in (e', es <> es') + + +checkForDuplicates :: (Identifier -> Identifier -> Error) -> [Identifier] -> [Error] +checkForDuplicates err [] = [] +checkForDuplicates err (x:xs) = let (same,other) = List.partition (equalId x) xs + in map (err x) same ++ checkForDuplicates err other + +equalId :: Identifier -> Identifier -> Bool +equalId x y = getName x == getName y + + +type RulesAndErrors = ([Rule], Seq Error) +type SigsAndErrors = ([TypeSig], Seq Error) +type InstsAndErrors = ([(Identifier, Type)], Seq Error) +type AttrOverwrite = Map AttrName Bool +type AccumRuleCheck = (RulesAndErrors, AttrOverwrite) +type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName]) + +checkRules :: Map Nonterminal (Attributes, Attributes) -> Map Nonterminal (Map Constructor FieldMap) -> + Map Nonterminal (Map Constructor [Identifier]) -> Map Nonterminal (Map Constructor [SigInfo]) -> + Nonterminal -> Constructor -> [RuleInfo] -> RulesAndErrors +checkRules attributes fields allinsts allsigs nt con rs + = let fieldmap :: FieldMap + fieldmap = (_LHS,NT nt) : (_LOC,NT undefined) : (_INST, NT undefined) : (_FIRST, NT undefined) : (_LAST, NT undefined) + : Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fields) + ++ mapMaybe (\instNm -> lookup instNm sigs >>= \tp -> return (instNm, tp)) (Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allinsts)) + + sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allsigs) + + hasAttrib f tp attr = Map.member attr (f (Map.findWithDefault (Map.empty,Map.empty) tp attributes)) + + checkRule :: RuleInfo -> AccumRuleCheck -> AccumRuleCheck + checkRule (pat,exp,as,owrt,str) ((r1,e1),m1) + = let (e2,m2,u2,b2) = foldr (checkDefi owrt) (e1,m1,[],[]) as + in ( (Rule (pat u2) exp owrt str : r1, e2), m2) + + checkDefi :: Bool -> AttrName -> AccumDefiCheck -> AccumDefiCheck + checkDefi owrt fa@(field,attr) (e,m,u,bs) + = case lookup field fieldmap + of Just (NT tp) -> if field == _LOC || field == _INST || field == _FIRST || field == _LAST + || hasAttrib (if getName field==getName _LHS then snd else fst) tp attr + then case Map.lookupIndex fa m + of Just ix -> let ((_,attr2),b) = Map.elemAt ix m + in if b && not (fa `elem` bs) + then ( e, Map.insert fa owrt m, fa:u, fa:bs) + else (Seq.cons (DupRule nt con field attr2 attr) e, m, fa:u, bs) + Nothing -> ( e, Map.insert fa owrt m, u, fa:bs) + else (Seq.cons (SuperfluousRule nt con field attr) e, m, fa:u, bs) + _ -> (Seq.cons (UndefChild nt con field) e, m, fa:u, bs ) + + in fst (foldr checkRule (([],Seq.empty),Map.empty) rs) + +checkSigs :: Nonterminal -> Constructor -> [SigInfo] -> SigsAndErrors +checkSigs nt con sis + = let checkSig (ide,typ) (sigs,errs) + = if ide `elem` map (\(TypeSig n t)-> n) sigs + then (sigs, Seq.cons (DupSig nt con ide) errs) + -- else if not (ide `elem` locattrdefs) + -- then (sigs, Seq.cons (SupSig nt con ide) errs) + else (TypeSig ide typ:sigs, errs) + in foldr checkSig ([],Seq.empty) sis + +checkInsts :: Map Nonterminal (Map Constructor [SigInfo]) -> Nonterminal -> Constructor -> [Identifier] -> InstsAndErrors +checkInsts sigMap nt con + = foldr (\inst (insts, errs) -> maybe (insts, Seq.single (MissingInstSig nt con inst) <> errs) + (\info -> (info : insts, errs)) $ findSig inst) ([], Seq.empty) + where + sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt sigMap) + + findSig name + = do tp@(NT _) <- lookup name sigs + return (name, tp) + +flattenDatas :: DataTypes -> Map Nonterminal (Set Nonterminal) +flattenDatas ds = Map.map flatten ds + where flatten cs = Set.fromList [ nt | (_,NT nt) <- concatMap snd (Map.toList cs)] + +reachableFrom :: Map Nonterminal (Set Nonterminal) -> Set Nonterminal -> Set Nonterminal +reachableFrom table nts = reach nts + where reach nts = let nts' = Set.unions (nts : [ ns | nt <- Set.toList nts + , let ns = Map.findWithDefault Set.empty nt table ]) + in if Set.size nts' > Set.size nts + then reach nts' + else nts +invert :: Map Nonterminal (Set Nonterminal) -> Map Nonterminal (Set Nonterminal) +invert m = foldr inv Map.empty (Map.toList m) + where inv (x,ns) m = fold (\n m -> Map.insertWith Set.union n (Set.singleton x) m) m ns + +path :: Map Nonterminal (Set Nonterminal) -> Nonterminal -> Nonterminal -> Set Nonterminal +path table from to = let children = Map.findWithDefault Set.empty from table + forward = reachableFrom table children + backward = reachableFrom (invert table) + (Set.singleton to) + in Set.intersection forward backward + +pragmaMapUnion :: PragmaMap -> PragmaMap -> PragmaMap +pragmaMapUnion = Map.unionWith (Map.unionWith Set.union) + +pragmaMapSingle :: Nonterminal -> Constructor -> Set Name -> PragmaMap +pragmaMapSingle nt con nms = Map.singleton nt (Map.singleton con nms) + +orderMapUnion :: AttrOrderMap -> AttrOrderMap -> AttrOrderMap +orderMapUnion = Map.unionWith (Map.unionWith Set.union) + +orderMapSingle :: Nonterminal -> Constructor -> Set Dependency -> AttrOrderMap +orderMapSingle nt con deps = Map.singleton nt (Map.singleton con deps) + +mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1) + +merge x y = foldr f y (Map.toList x) + where f ~(k,v) m = Map.insertWith (Map.union) k v m + +checkAttrs allFields nts inherited synthesized decls = foldErrors check decls nts where + check nt decls | not (nt `Map.member` allFields) = (decls,Seq.single(UndefNont nt)) + | otherwise = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt decls + (inh',einh) = checkDuplicates (DupInhAttr nt) inherited inh + (syn',esyn) = checkDuplicates (DupSynAttr nt) synthesized syn + in (Map.insert nt (inh',syn') decls,einh <> esyn) + +addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap + in Map.insert name (eInh, Map.insert (Ident "self" noPos) (NT _SELF) eSyn)atMap + +makeType :: Set Nonterminal -> Type -> Type +makeType nts tp@(NT x) | x == _SELF = tp + | Set.member x nts = tp + | otherwise = Haskell (getName x) +makeType _ tp = tp + +constructGrammar :: Set Nonterminal + -> DataTypes + -> Map Nonterminal (Attributes, Attributes) + -> Map Nonterminal (Map Name (String, String, String)) + -> Derivings + -> Set Nonterminal + -> Map Nonterminal (Map Constructor [Rule]) + -> Map Nonterminal (Map Constructor [TypeSig]) + -> Map Nonterminal (Map Constructor [(Identifier, Type)]) + -> TypeSyns + -> PragmaMap + -> AttrOrderMap + -> Grammar + +constructGrammar nts gram attrs uses derivings wrappers allrules tsigs allinsts tsyns pragmaMap orderMap = + let gr = [ (nt,Map.toList alts) | (nt,alts) <- Map.toList gram] + prods = map prod gr + prod (nt,alts) = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs + rmap = Map.findWithDefault Map.empty nt allrules + tsmap = Map.findWithDefault Map.empty nt tsigs + instsmap = Map.findWithDefault Map.empty nt allinsts + alt (con,flds) = + let rules = maybe [] id (Map.lookup con rmap) + tsigs = maybe [] id (Map.lookup con tsmap) + insts = maybe [] id (Map.lookup con instsmap) + cldrn = map (child False) flds ++ map (child True) insts + child isVirtual (nm, tp) = + let (inh,syn) = case tp of + NT nt -> Map.findWithDefault (Map.empty,Map.empty) nt attrs + _ -> (Map.empty,Map.empty) + in Child nm tp inh syn isVirtual + in Alternative con cldrn rules tsigs + in Production nt inh syn (map alt alts) + in Grammar tsyns uses derivings wrappers prods pragmaMap orderMap + +mapUnionWithSetUnion = Map.unionWith Set.union +mapUnionWithPlusPlus = Map.unionWith (++) +-- AG ---------------------------------------------------------- +{- + visit 0: + inherited attribute: + options : Options + synthesized attributes: + blocks : Blocks + errors : Seq Error + moduleDecl : Maybe (String,String,String) + output : Grammar + pragmas : Options -> Options + alternatives: + alternative AG: + child elems : Elems + visit 0: + local allFields : _ + local allConstrs : _ + local allRules : _ + local allSigs : _ + local allInsts : _ + local allRulesErrs : _ + local allSigsErrs : _ + local allInstsErrs : _ + local checkedRules : _ + local checkedSigs : _ + local checkedInsts : _ + local errs1 : _ + local errs2 : _ + local errs3 : _ + local errs4 : _ + local errs5 : _ + local errs6 : _ + local allNonterminals : _ + local allAttrDecls : _ +-} +-- cata +sem_AG :: AG -> + T_AG +sem_AG (AG _elems) = + (sem_AG_AG (sem_Elems _elems)) +-- semantic domain +newtype T_AG = T_AG (Options -> + ( Blocks,(Seq Error),(Maybe (String,String,String)),Grammar,(Options -> Options))) +data Inh_AG = Inh_AG {options_Inh_AG :: Options} +data Syn_AG = Syn_AG {blocks_Syn_AG :: Blocks,errors_Syn_AG :: Seq Error,moduleDecl_Syn_AG :: Maybe (String,String,String),output_Syn_AG :: Grammar,pragmas_Syn_AG :: Options -> Options} +wrap_AG (T_AG sem) (Inh_AG _lhsIoptions) = + (let ( _lhsOblocks,_lhsOerrors,_lhsOmoduleDecl,_lhsOoutput,_lhsOpragmas) = + (sem _lhsIoptions) + in (Syn_AG _lhsOblocks _lhsOerrors _lhsOmoduleDecl _lhsOoutput _lhsOpragmas)) +sem_AG_AG :: T_Elems -> + T_AG +sem_AG_AG (T_Elems elems_) = + (T_AG (\ _lhsIoptions -> + (let _lhsOoutput :: Grammar + _lhsOerrors :: (Seq Error) + _elemsOallConstructors :: (Map Nonterminal (Set Constructor)) + _elemsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + _elemsOdefinedSets :: DefinedSets + _elemsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOblocks :: Blocks + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOpragmas :: (Options -> Options) + _elemsOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) + _elemsOallFields :: DataTypes + _elemsOallNonterminals :: (Set Nonterminal) + _elemsIattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _elemsIattrOrderCollect :: AttrOrderMap + _elemsIblocks :: Blocks + _elemsIcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _elemsIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _elemsIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _elemsIcollectedNames :: (Set Name) + _elemsIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _elemsIcollectedSetNames :: (Set Name) + _elemsIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _elemsIdefSets :: (Map Name (Set Nonterminal,Set Name)) + _elemsIderivings :: Derivings + _elemsIerrors :: (Seq Error) + _elemsImoduleDecl :: (Maybe (String,String,String)) + _elemsIorderDepErrorsCollect :: (Seq Error) + _elemsIpragmas :: (Options -> Options) + _elemsIsemPragmasCollect :: PragmaMap + _elemsItypeSyns :: TypeSyns + _elemsIuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _elemsIwrappers :: (Set Nonterminal) + -- "Transform.ag"(line 45, column 8) + _lhsOoutput = + constructGrammar _allNonterminals + _allFields + _allAttrDecls + _elemsIuseMap + _elemsIderivings + (if wrappers _lhsIoptions then _allNonterminals else _elemsIwrappers) + _checkedRules + _checkedSigs + _checkedInsts + _elemsItypeSyns + _elemsIsemPragmasCollect + _elemsIattrOrderCollect + -- "Transform.ag"(line 217, column 10) + _allFields = + let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) + in foldr f (Map.empty) _elemsIcollectedFields + -- "Transform.ag"(line 220, column 10) + _allConstrs = + let f (nt,con,_) = Map.insertWith (++) nt [con] + in foldr f (Map.empty) _elemsIcollectedFields + -- "Transform.ag"(line 223, column 10) + _allRules = + let f (nt,con,r) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [r]) + in foldr f (Map.empty) _elemsIcollectedRules + -- "Transform.ag"(line 226, column 10) + _allSigs = + let f (nt,con,t) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [t]) + in foldr f (Map.empty) _elemsIcollectedSigs + -- "Transform.ag"(line 229, column 10) + _allInsts = + let f (nt,con,is) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con is) + in foldr f (Map.empty) _elemsIcollectedInsts + -- "Transform.ag"(line 232, column 10) + _allRulesErrs = + Map.mapWithKey (Map.mapWithKey . (checkRules _allAttrDecls _allFields _allInsts _allSigs )) _allRules + -- "Transform.ag"(line 233, column 10) + _allSigsErrs = + Map.mapWithKey (Map.mapWithKey . (checkSigs )) _allSigs + -- "Transform.ag"(line 234, column 10) + _allInstsErrs = + Map.mapWithKey (Map.mapWithKey . (checkInsts _allSigs )) _allInsts + -- "Transform.ag"(line 236, column 10) + _checkedRules = + Map.map (Map.map fst) _allRulesErrs + -- "Transform.ag"(line 237, column 10) + _checkedSigs = + Map.map (Map.map fst) _allSigsErrs + -- "Transform.ag"(line 238, column 10) + _checkedInsts = + Map.map (Map.map fst) _allInstsErrs + -- "Transform.ag"(line 240, column 10) + _errs1 = + let f = checkForDuplicates (DupSynonym) + in Seq.fromList . f . map fst $ _elemsItypeSyns + -- "Transform.ag"(line 243, column 10) + _errs2 = + let g nt (con,fm) = checkForDuplicates (DupChild nt con) (map fst fm) + f (nt,cfm) = concat . map (g nt) . Map.toList $ cfm + in Seq.fromList . concat . map f . Map.toList $ _allFields + -- "Transform.ag"(line 247, column 10) + _errs3 = + let f (nt,cons) = checkForDuplicates (DupAlt nt) cons + in Seq.empty + -- "Transform.ag"(line 251, column 10) + _errs4 = + let f m s = Map.fold ((<>) . snd) s m + in Map.fold f Seq.empty _allRulesErrs + -- "Transform.ag"(line 254, column 10) + _errs5 = + let f m s = Map.fold ((<>) . snd) s m + in Map.fold f Seq.empty _allSigsErrs + -- "Transform.ag"(line 257, column 10) + _errs6 = + let f m s = Map.fold ((<>) . snd) s m + in Map.fold f Seq.empty _allInstsErrs + -- "Transform.ag"(line 260, column 10) + _lhsOerrors = + _elemsIerrors <> _errs1 <> _errs2 <> _errs3 <> _errs4 <> _errs5 <> _errs6 <> _elemsIorderDepErrorsCollect + -- "Transform.ag"(line 343, column 10) + _allNonterminals = + _elemsIcollectedNames `Set.difference` _elemsIcollectedSetNames + -- "Transform.ag"(line 363, column 8) + _elemsOallConstructors = + _elemsIcollectedConstructorsMap + -- "Transform.ag"(line 417, column 8) + _elemsOdefSets = + Map.fromList (map (\x->(x,(Set.singleton x, Set.empty))) (Set.toList _allNonterminals )) + -- "Transform.ag"(line 418, column 8) + _elemsOdefinedSets = + Map.map fst _elemsIdefSets + -- "Transform.ag"(line 612, column 8) + _elemsOattrDecls = + Map.empty + -- "Transform.ag"(line 651, column 9) + _allAttrDecls = + if withSelf _lhsIoptions + then foldr addSelf _elemsIattrDecls (Set.toList _allNonterminals ) + else _elemsIattrDecls + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + _elemsIblocks + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + _elemsImoduleDecl + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + _elemsIpragmas + -- copy rule (from local) + _elemsOallAttrDecls = + _allAttrDecls + -- copy rule (from local) + _elemsOallFields = + _allFields + -- copy rule (from local) + _elemsOallNonterminals = + _allNonterminals + ( _elemsIattrDecls,_elemsIattrOrderCollect,_elemsIblocks,_elemsIcollectedConstructorsMap,_elemsIcollectedFields,_elemsIcollectedInsts,_elemsIcollectedNames,_elemsIcollectedRules,_elemsIcollectedSetNames,_elemsIcollectedSigs,_elemsIdefSets,_elemsIderivings,_elemsIerrors,_elemsImoduleDecl,_elemsIorderDepErrorsCollect,_elemsIpragmas,_elemsIsemPragmasCollect,_elemsItypeSyns,_elemsIuseMap,_elemsIwrappers) = + (elems_ _elemsOallAttrDecls _elemsOallConstructors _elemsOallFields _elemsOallNonterminals _elemsOattrDecls _elemsOdefSets _elemsOdefinedSets) + in ( _lhsOblocks,_lhsOerrors,_lhsOmoduleDecl,_lhsOoutput,_lhsOpragmas)))) +-- Alt --------------------------------------------------------- +{- + visit 0: + inherited attributes: + allConstructors : Map Nonterminal (Set Constructor) + allNonterminals : Set Nonterminal + nts : Set Nonterminal + synthesized attributes: + collectedConstructorNames : Set Constructor + collectedFields : [(Nonterminal, Constructor, FieldMap)] + alternatives: + alternative Alt: + child pos : {Pos} + child names : ConstructorSet + child fields : {Fields} +-} +-- cata +sem_Alt :: Alt -> + T_Alt +sem_Alt (Alt _pos _names _fields) = + (sem_Alt_Alt _pos (sem_ConstructorSet _names) _fields) +-- semantic domain +newtype T_Alt = T_Alt ((Map Nonterminal (Set Constructor)) -> + (Set Nonterminal) -> + (Set Nonterminal) -> + ( (Set Constructor),([(Nonterminal, Constructor, FieldMap)]))) +data Inh_Alt = Inh_Alt {allConstructors_Inh_Alt :: Map Nonterminal (Set Constructor),allNonterminals_Inh_Alt :: Set Nonterminal,nts_Inh_Alt :: Set Nonterminal} +data Syn_Alt = Syn_Alt {collectedConstructorNames_Syn_Alt :: Set Constructor,collectedFields_Syn_Alt :: [(Nonterminal, Constructor, FieldMap)]} +wrap_Alt (T_Alt sem) (Inh_Alt _lhsIallConstructors _lhsIallNonterminals _lhsInts) = + (let ( _lhsOcollectedConstructorNames,_lhsOcollectedFields) = + (sem _lhsIallConstructors _lhsIallNonterminals _lhsInts) + in (Syn_Alt _lhsOcollectedConstructorNames _lhsOcollectedFields)) +sem_Alt_Alt :: Pos -> + T_ConstructorSet -> + Fields -> + T_Alt +sem_Alt_Alt pos_ (T_ConstructorSet names_) fields_ = + (T_Alt (\ _lhsIallConstructors + _lhsIallNonterminals + _lhsInts -> + (let _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedConstructorNames :: (Set Constructor) + _namesIcollectedConstructorNames :: (Set Constructor) + _namesIconstructors :: ((Set Constructor->Set Constructor)) + _namesIerrors :: (Seq Error) + -- "Transform.ag"(line 202, column 10) + _lhsOcollectedFields = + let fieldTable = + [ (attr, makeType _lhsIallNonterminals tp) + | (attr, tp) <- fields_ + ] + in [ (nt, con, fieldTable) + | nt <- Set.toList _lhsInts + , con <- Set.toList (_namesIconstructors (Map.findWithDefault Set.empty nt _lhsIallConstructors)) + ] + -- use rule "Transform.ag"(line 80, column 62) + _lhsOcollectedConstructorNames = + _namesIcollectedConstructorNames + ( _namesIcollectedConstructorNames,_namesIconstructors,_namesIerrors) = + (names_ ) + in ( _lhsOcollectedConstructorNames,_lhsOcollectedFields)))) +-- Alts -------------------------------------------------------- +{- + visit 0: + inherited attributes: + allConstructors : Map Nonterminal (Set Constructor) + allNonterminals : Set Nonterminal + nts : Set Nonterminal + synthesized attributes: + collectedConstructorNames : Set Constructor + collectedFields : [(Nonterminal, Constructor, FieldMap)] + alternatives: + alternative Cons: + child hd : Alt + child tl : Alts + alternative Nil: +-} +-- cata +sem_Alts :: Alts -> + T_Alts +sem_Alts list = + (Prelude.foldr sem_Alts_Cons sem_Alts_Nil (Prelude.map sem_Alt list)) +-- semantic domain +newtype T_Alts = T_Alts ((Map Nonterminal (Set Constructor)) -> + (Set Nonterminal) -> + (Set Nonterminal) -> + ( (Set Constructor),([(Nonterminal, Constructor, FieldMap)]))) +data Inh_Alts = Inh_Alts {allConstructors_Inh_Alts :: Map Nonterminal (Set Constructor),allNonterminals_Inh_Alts :: Set Nonterminal,nts_Inh_Alts :: Set Nonterminal} +data Syn_Alts = Syn_Alts {collectedConstructorNames_Syn_Alts :: Set Constructor,collectedFields_Syn_Alts :: [(Nonterminal, Constructor, FieldMap)]} +wrap_Alts (T_Alts sem) (Inh_Alts _lhsIallConstructors _lhsIallNonterminals _lhsInts) = + (let ( _lhsOcollectedConstructorNames,_lhsOcollectedFields) = + (sem _lhsIallConstructors _lhsIallNonterminals _lhsInts) + in (Syn_Alts _lhsOcollectedConstructorNames _lhsOcollectedFields)) +sem_Alts_Cons :: T_Alt -> + T_Alts -> + T_Alts +sem_Alts_Cons (T_Alt hd_) (T_Alts tl_) = + (T_Alts (\ _lhsIallConstructors + _lhsIallNonterminals + _lhsInts -> + (let _lhsOcollectedConstructorNames :: (Set Constructor) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _hdOallConstructors :: (Map Nonterminal (Set Constructor)) + _hdOallNonterminals :: (Set Nonterminal) + _hdOnts :: (Set Nonterminal) + _tlOallConstructors :: (Map Nonterminal (Set Constructor)) + _tlOallNonterminals :: (Set Nonterminal) + _tlOnts :: (Set Nonterminal) + _hdIcollectedConstructorNames :: (Set Constructor) + _hdIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _tlIcollectedConstructorNames :: (Set Constructor) + _tlIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + -- use rule "Transform.ag"(line 80, column 62) + _lhsOcollectedConstructorNames = + _hdIcollectedConstructorNames `Set.union` _tlIcollectedConstructorNames + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + _hdIcollectedFields ++ _tlIcollectedFields + -- copy rule (down) + _hdOallConstructors = + _lhsIallConstructors + -- copy rule (down) + _hdOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _hdOnts = + _lhsInts + -- copy rule (down) + _tlOallConstructors = + _lhsIallConstructors + -- copy rule (down) + _tlOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _tlOnts = + _lhsInts + ( _hdIcollectedConstructorNames,_hdIcollectedFields) = + (hd_ _hdOallConstructors _hdOallNonterminals _hdOnts) + ( _tlIcollectedConstructorNames,_tlIcollectedFields) = + (tl_ _tlOallConstructors _tlOallNonterminals _tlOnts) + in ( _lhsOcollectedConstructorNames,_lhsOcollectedFields)))) +sem_Alts_Nil :: T_Alts +sem_Alts_Nil = + (T_Alts (\ _lhsIallConstructors + _lhsIallNonterminals + _lhsInts -> + (let _lhsOcollectedConstructorNames :: (Set Constructor) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + -- use rule "Transform.ag"(line 80, column 62) + _lhsOcollectedConstructorNames = + Set.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + [] + in ( _lhsOcollectedConstructorNames,_lhsOcollectedFields)))) +-- Attrs ------------------------------------------------------- +{- + visit 0: + inherited attributes: + allFields : DataTypes + allNonterminals : Set Nonterminal + nts : Set Nonterminal + chained attribute: + attrDecls : Map Nonterminal (Attributes, Attributes) + synthesized attributes: + errors : Seq Error + useMap : Map Nonterminal (Map Name (String,String,String)) + alternatives: + alternative Attrs: + child pos : {Pos} + child inh : {AttrNames} + child chn : {AttrNames} + child syn : {AttrNames} + visit 0: + local _tup1 : _ + local attrDecls : _ + local errors : _ + local _tup2 : _ + local inherited : _ + local synthesized : _ + local useMap : _ +-} +-- cata +sem_Attrs :: Attrs -> + T_Attrs +sem_Attrs (Attrs _pos _inh _chn _syn) = + (sem_Attrs_Attrs _pos _inh _chn _syn) +-- semantic domain +newtype T_Attrs = T_Attrs (DataTypes -> + (Set Nonterminal) -> + (Map Nonterminal (Attributes, Attributes)) -> + (Set Nonterminal) -> + ( (Map Nonterminal (Attributes, Attributes)),(Seq Error),(Map Nonterminal (Map Name (String,String,String))))) +data Inh_Attrs = Inh_Attrs {allFields_Inh_Attrs :: DataTypes,allNonterminals_Inh_Attrs :: Set Nonterminal,attrDecls_Inh_Attrs :: Map Nonterminal (Attributes, Attributes),nts_Inh_Attrs :: Set Nonterminal} +data Syn_Attrs = Syn_Attrs {attrDecls_Syn_Attrs :: Map Nonterminal (Attributes, Attributes),errors_Syn_Attrs :: Seq Error,useMap_Syn_Attrs :: Map Nonterminal (Map Name (String,String,String))} +wrap_Attrs (T_Attrs sem) (Inh_Attrs _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsInts) = + (let ( _lhsOattrDecls,_lhsOerrors,_lhsOuseMap) = + (sem _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsInts) + in (Syn_Attrs _lhsOattrDecls _lhsOerrors _lhsOuseMap)) +sem_Attrs_Attrs :: Pos -> + AttrNames -> + AttrNames -> + AttrNames -> + T_Attrs +sem_Attrs_Attrs pos_ inh_ chn_ syn_ = + (T_Attrs (\ _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsInts -> + (let _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOerrors :: (Seq Error) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + -- "Transform.ag"(line 620, column 15) + __tup1 = + checkAttrs _lhsIallFields (Set.toList _lhsInts) _inherited _synthesized _lhsIattrDecls + -- "Transform.ag"(line 620, column 15) + (_attrDecls,_) = + __tup1 + -- "Transform.ag"(line 620, column 15) + (_,_errors) = + __tup1 + -- "Transform.ag"(line 622, column 15) + __tup2 = + let splitAttrs xs = unzip [ ((n,makeType _lhsIallNonterminals t),(n,ud)) + | (n,t,ud) <- xs + ] + (inh,_) = splitAttrs inh_ + (chn,uses1) = splitAttrs chn_ + (syn,uses2) = splitAttrs syn_ + isUse (n,(e1,e2,_)) = not (null e1 || null e2) + in (inh++chn,chn++syn, Map.fromList (Prelude.filter isUse (uses1++uses2))) + -- "Transform.ag"(line 622, column 15) + (_inherited,_,_) = + __tup2 + -- "Transform.ag"(line 622, column 15) + (_,_synthesized,_) = + __tup2 + -- "Transform.ag"(line 622, column 15) + (_,_,_useMap) = + __tup2 + -- "Transform.ag"(line 630, column 11) + _lhsOuseMap = + Map.fromList (zip (Set.toList _lhsInts) (repeat _useMap)) + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _errors + -- copy rule (from local) + _lhsOattrDecls = + _attrDecls + in ( _lhsOattrDecls,_lhsOerrors,_lhsOuseMap)))) +-- ConstructorSet ---------------------------------------------- +{- + visit 0: + synthesized attributes: + collectedConstructorNames : Set Constructor + constructors : (Set Constructor->Set Constructor) + errors : Seq Error + alternatives: + alternative CAll: + alternative CDifference: + child set1 : ConstructorSet + child set2 : ConstructorSet + alternative CName: + child name : {Constructor} + alternative CUnion: + child set1 : ConstructorSet + child set2 : ConstructorSet +-} +-- cata +sem_ConstructorSet :: ConstructorSet -> + T_ConstructorSet +sem_ConstructorSet (CAll ) = + (sem_ConstructorSet_CAll ) +sem_ConstructorSet (CDifference _set1 _set2) = + (sem_ConstructorSet_CDifference (sem_ConstructorSet _set1) (sem_ConstructorSet _set2)) +sem_ConstructorSet (CName _name) = + (sem_ConstructorSet_CName _name) +sem_ConstructorSet (CUnion _set1 _set2) = + (sem_ConstructorSet_CUnion (sem_ConstructorSet _set1) (sem_ConstructorSet _set2)) +-- semantic domain +newtype T_ConstructorSet = T_ConstructorSet (( (Set Constructor),((Set Constructor->Set Constructor)),(Seq Error))) +data Inh_ConstructorSet = Inh_ConstructorSet {} +data Syn_ConstructorSet = Syn_ConstructorSet {collectedConstructorNames_Syn_ConstructorSet :: Set Constructor,constructors_Syn_ConstructorSet :: (Set Constructor->Set Constructor),errors_Syn_ConstructorSet :: Seq Error} +wrap_ConstructorSet (T_ConstructorSet sem) (Inh_ConstructorSet ) = + (let ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors) = + (sem ) + in (Syn_ConstructorSet _lhsOcollectedConstructorNames _lhsOconstructors _lhsOerrors)) +sem_ConstructorSet_CAll :: T_ConstructorSet +sem_ConstructorSet_CAll = + (T_ConstructorSet (let _lhsOconstructors :: ((Set Constructor->Set Constructor)) + _lhsOcollectedConstructorNames :: (Set Constructor) + _lhsOerrors :: (Seq Error) + -- "Transform.ag"(line 484, column 17) + _lhsOconstructors = + \ds -> ds + -- use rule "Transform.ag"(line 80, column 62) + _lhsOcollectedConstructorNames = + Set.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) +sem_ConstructorSet_CDifference :: T_ConstructorSet -> + T_ConstructorSet -> + T_ConstructorSet +sem_ConstructorSet_CDifference (T_ConstructorSet set1_) (T_ConstructorSet set2_) = + (T_ConstructorSet (let _lhsOconstructors :: ((Set Constructor->Set Constructor)) + _lhsOcollectedConstructorNames :: (Set Constructor) + _lhsOerrors :: (Seq Error) + _set1IcollectedConstructorNames :: (Set Constructor) + _set1Iconstructors :: ((Set Constructor->Set Constructor)) + _set1Ierrors :: (Seq Error) + _set2IcollectedConstructorNames :: (Set Constructor) + _set2Iconstructors :: ((Set Constructor->Set Constructor)) + _set2Ierrors :: (Seq Error) + -- "Transform.ag"(line 483, column 17) + _lhsOconstructors = + \ds -> _set1Iconstructors ds `Set.difference` _set2Iconstructors ds + -- use rule "Transform.ag"(line 80, column 62) + _lhsOcollectedConstructorNames = + _set1IcollectedConstructorNames `Set.union` _set2IcollectedConstructorNames + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _set1Ierrors Seq.<> _set2Ierrors + ( _set1IcollectedConstructorNames,_set1Iconstructors,_set1Ierrors) = + (set1_ ) + ( _set2IcollectedConstructorNames,_set2Iconstructors,_set2Ierrors) = + (set2_ ) + in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) +sem_ConstructorSet_CName :: Constructor -> + T_ConstructorSet +sem_ConstructorSet_CName name_ = + (T_ConstructorSet (let _lhsOcollectedConstructorNames :: (Set Constructor) + _lhsOconstructors :: ((Set Constructor->Set Constructor)) + _lhsOerrors :: (Seq Error) + -- "Transform.ag"(line 351, column 11) + _lhsOcollectedConstructorNames = + Set.singleton name_ + -- "Transform.ag"(line 481, column 17) + _lhsOconstructors = + \ds -> Set.singleton name_ + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) +sem_ConstructorSet_CUnion :: T_ConstructorSet -> + T_ConstructorSet -> + T_ConstructorSet +sem_ConstructorSet_CUnion (T_ConstructorSet set1_) (T_ConstructorSet set2_) = + (T_ConstructorSet (let _lhsOconstructors :: ((Set Constructor->Set Constructor)) + _lhsOcollectedConstructorNames :: (Set Constructor) + _lhsOerrors :: (Seq Error) + _set1IcollectedConstructorNames :: (Set Constructor) + _set1Iconstructors :: ((Set Constructor->Set Constructor)) + _set1Ierrors :: (Seq Error) + _set2IcollectedConstructorNames :: (Set Constructor) + _set2Iconstructors :: ((Set Constructor->Set Constructor)) + _set2Ierrors :: (Seq Error) + -- "Transform.ag"(line 482, column 17) + _lhsOconstructors = + \ds -> _set1Iconstructors ds `Set.union` _set2Iconstructors ds + -- use rule "Transform.ag"(line 80, column 62) + _lhsOcollectedConstructorNames = + _set1IcollectedConstructorNames `Set.union` _set2IcollectedConstructorNames + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _set1Ierrors Seq.<> _set2Ierrors + ( _set1IcollectedConstructorNames,_set1Iconstructors,_set1Ierrors) = + (set1_ ) + ( _set2IcollectedConstructorNames,_set2Iconstructors,_set2Ierrors) = + (set2_ ) + in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) +-- Elem -------------------------------------------------------- +{- + visit 0: + inherited attributes: + allAttrDecls : Map Nonterminal (Attributes, Attributes) + allConstructors : Map Nonterminal (Set Constructor) + allFields : DataTypes + allNonterminals : Set Nonterminal + definedSets : DefinedSets + chained attributes: + attrDecls : Map Nonterminal (Attributes, Attributes) + defSets : Map Name (Set Nonterminal,Set Name) + synthesized attributes: + attrOrderCollect : AttrOrderMap + blocks : Blocks + collectedConstructorsMap : Map Nonterminal (Set Constructor) + collectedFields : [(Nonterminal, Constructor, FieldMap)] + collectedInsts : [ (Nonterminal, Constructor, [Identifier]) ] + collectedNames : Set Name + collectedRules : [ (Nonterminal, Constructor, RuleInfo)] + collectedSetNames : Set Name + collectedSigs : [ (Nonterminal, Constructor, SigInfo) ] + derivings : Derivings + errors : Seq Error + moduleDecl : Maybe (String,String,String) + orderDepErrorsCollect : Seq Error + pragmas : Options -> Options + semPragmasCollect : PragmaMap + typeSyns : TypeSyns + useMap : Map Nonterminal (Map Name (String,String,String)) + wrappers : Set Nonterminal + alternatives: + alternative Attr: + child pos : {Pos} + child names : NontSet + child attrs : Attrs + alternative Data: + child pos : {Pos} + child names : NontSet + child attrs : Attrs + child alts : Alts + child ext : {Bool} + alternative Deriving: + child pos : {Pos} + child set : NontSet + child classes : {[Name]} + alternative Module: + child pos : {Pos} + child name : {String} + child exports : {String} + child imports : {String} + alternative Pragma: + child pos : {Pos} + child names : {[Name]} + alternative Sem: + child pos : {Pos} + child names : NontSet + child attrs : Attrs + child alts : SemAlts + alternative Set: + child pos : {Pos} + child name : {Name} + child set : NontSet + visit 0: + local _tup3 : _ + local defSets2 : _ + local errs : _ + alternative Txt: + child pos : {Pos} + child name : {Name} + child lines : {[String]} + alternative Type: + child pos : {Pos} + child name : {Nonterminal} + child type : {ComplexType} + visit 0: + local expanded : _ + local argType : _ + alternative Wrapper: + child pos : {Pos} + child set : NontSet +-} +-- cata +sem_Elem :: Elem -> + T_Elem +sem_Elem (Attr _pos _names _attrs) = + (sem_Elem_Attr _pos (sem_NontSet _names) (sem_Attrs _attrs)) +sem_Elem (Data _pos _names _attrs _alts _ext) = + (sem_Elem_Data _pos (sem_NontSet _names) (sem_Attrs _attrs) (sem_Alts _alts) _ext) +sem_Elem (Deriving _pos _set _classes) = + (sem_Elem_Deriving _pos (sem_NontSet _set) _classes) +sem_Elem (Module _pos _name _exports _imports) = + (sem_Elem_Module _pos _name _exports _imports) +sem_Elem (Pragma _pos _names) = + (sem_Elem_Pragma _pos _names) +sem_Elem (Sem _pos _names _attrs _alts) = + (sem_Elem_Sem _pos (sem_NontSet _names) (sem_Attrs _attrs) (sem_SemAlts _alts)) +sem_Elem (Set _pos _name _set) = + (sem_Elem_Set _pos _name (sem_NontSet _set)) +sem_Elem (Txt _pos _name _lines) = + (sem_Elem_Txt _pos _name _lines) +sem_Elem (Type _pos _name _type) = + (sem_Elem_Type _pos _name _type) +sem_Elem (Wrapper _pos _set) = + (sem_Elem_Wrapper _pos (sem_NontSet _set)) +-- semantic domain +newtype T_Elem = T_Elem ((Map Nonterminal (Attributes, Attributes)) -> + (Map Nonterminal (Set Constructor)) -> + DataTypes -> + (Set Nonterminal) -> + (Map Nonterminal (Attributes, Attributes)) -> + (Map Name (Set Nonterminal,Set Name)) -> + DefinedSets -> + ( (Map Nonterminal (Attributes, Attributes)),AttrOrderMap,Blocks,(Map Nonterminal (Set Constructor)),([(Nonterminal, Constructor, FieldMap)]),([ (Nonterminal, Constructor, [Identifier]) ]),(Set Name),([ (Nonterminal, Constructor, RuleInfo)]),(Set Name),([ (Nonterminal, Constructor, SigInfo) ]),(Map Name (Set Nonterminal,Set Name)),Derivings,(Seq Error),(Maybe (String,String,String)),(Seq Error),(Options -> Options),PragmaMap,TypeSyns,(Map Nonterminal (Map Name (String,String,String))),(Set Nonterminal))) +data Inh_Elem = Inh_Elem {allAttrDecls_Inh_Elem :: Map Nonterminal (Attributes, Attributes),allConstructors_Inh_Elem :: Map Nonterminal (Set Constructor),allFields_Inh_Elem :: DataTypes,allNonterminals_Inh_Elem :: Set Nonterminal,attrDecls_Inh_Elem :: Map Nonterminal (Attributes, Attributes),defSets_Inh_Elem :: Map Name (Set Nonterminal,Set Name),definedSets_Inh_Elem :: DefinedSets} +data Syn_Elem = Syn_Elem {attrDecls_Syn_Elem :: Map Nonterminal (Attributes, Attributes),attrOrderCollect_Syn_Elem :: AttrOrderMap,blocks_Syn_Elem :: Blocks,collectedConstructorsMap_Syn_Elem :: Map Nonterminal (Set Constructor),collectedFields_Syn_Elem :: [(Nonterminal, Constructor, FieldMap)],collectedInsts_Syn_Elem :: [ (Nonterminal, Constructor, [Identifier]) ],collectedNames_Syn_Elem :: Set Name,collectedRules_Syn_Elem :: [ (Nonterminal, Constructor, RuleInfo)],collectedSetNames_Syn_Elem :: Set Name,collectedSigs_Syn_Elem :: [ (Nonterminal, Constructor, SigInfo) ],defSets_Syn_Elem :: Map Name (Set Nonterminal,Set Name),derivings_Syn_Elem :: Derivings,errors_Syn_Elem :: Seq Error,moduleDecl_Syn_Elem :: Maybe (String,String,String),orderDepErrorsCollect_Syn_Elem :: Seq Error,pragmas_Syn_Elem :: Options -> Options,semPragmasCollect_Syn_Elem :: PragmaMap,typeSyns_Syn_Elem :: TypeSyns,useMap_Syn_Elem :: Map Nonterminal (Map Name (String,String,String)),wrappers_Syn_Elem :: Set Nonterminal} +wrap_Elem (T_Elem sem) (Inh_Elem _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) = + (let ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers) = + (sem _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) + in (Syn_Elem _lhsOattrDecls _lhsOattrOrderCollect _lhsOblocks _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOorderDepErrorsCollect _lhsOpragmas _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers)) +sem_Elem_Attr :: Pos -> + T_NontSet -> + T_Attrs -> + T_Elem +sem_Elem_Attr pos_ (T_NontSet names_) (T_Attrs attrs_) = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _attrsOnts :: (Set Nonterminal) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + _namesOallFields :: DataTypes + _namesOallNonterminals :: (Set Nonterminal) + _namesOdefinedSets :: DefinedSets + _attrsOallFields :: DataTypes + _attrsOallNonterminals :: (Set Nonterminal) + _attrsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _namesIcollectedNames :: (Set Name) + _namesIerrors :: (Seq Error) + _namesInontSet :: (Set Nonterminal) + _attrsIattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _attrsIerrors :: (Seq Error) + _attrsIuseMap :: (Map Nonterminal (Map Name (String,String,String))) + -- "Transform.ag"(line 616, column 10) + _attrsOnts = + _namesInontSet + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + _namesIcollectedNames + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _namesIerrors Seq.<> _attrsIerrors + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + _attrsIuseMap + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (up) + _lhsOattrDecls = + _attrsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + -- copy rule (down) + _namesOallFields = + _lhsIallFields + -- copy rule (down) + _namesOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _namesOdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _attrsOallFields = + _lhsIallFields + -- copy rule (down) + _attrsOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _attrsOattrDecls = + _lhsIattrDecls + ( _namesIcollectedNames,_namesIerrors,_namesInontSet) = + (names_ _namesOallFields _namesOallNonterminals _namesOdefinedSets) + ( _attrsIattrDecls,_attrsIerrors,_attrsIuseMap) = + (attrs_ _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOnts) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Data :: Pos -> + T_NontSet -> + T_Attrs -> + T_Alts -> + Bool -> + T_Elem +sem_Elem_Data pos_ (T_NontSet names_) (T_Attrs attrs_) (T_Alts alts_) ext_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _altsOnts :: (Set Nonterminal) + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _attrsOnts :: (Set Nonterminal) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + _namesOallFields :: DataTypes + _namesOallNonterminals :: (Set Nonterminal) + _namesOdefinedSets :: DefinedSets + _attrsOallFields :: DataTypes + _attrsOallNonterminals :: (Set Nonterminal) + _attrsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _altsOallConstructors :: (Map Nonterminal (Set Constructor)) + _altsOallNonterminals :: (Set Nonterminal) + _namesIcollectedNames :: (Set Name) + _namesIerrors :: (Seq Error) + _namesInontSet :: (Set Nonterminal) + _attrsIattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _attrsIerrors :: (Seq Error) + _attrsIuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _altsIcollectedConstructorNames :: (Set Constructor) + _altsIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + -- "Transform.ag"(line 149, column 10) + _altsOnts = + _namesInontSet + -- "Transform.ag"(line 357, column 11) + _lhsOcollectedConstructorsMap = + Map.fromList + [ (n, _altsIcollectedConstructorNames) + | n <- Set.toList _namesInontSet + ] + -- "Transform.ag"(line 615, column 10) + _attrsOnts = + _namesInontSet + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + _altsIcollectedFields + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + _namesIcollectedNames + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _namesIerrors Seq.<> _attrsIerrors + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + _attrsIuseMap + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (up) + _lhsOattrDecls = + _attrsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + -- copy rule (down) + _namesOallFields = + _lhsIallFields + -- copy rule (down) + _namesOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _namesOdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _attrsOallFields = + _lhsIallFields + -- copy rule (down) + _attrsOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _attrsOattrDecls = + _lhsIattrDecls + -- copy rule (down) + _altsOallConstructors = + _lhsIallConstructors + -- copy rule (down) + _altsOallNonterminals = + _lhsIallNonterminals + ( _namesIcollectedNames,_namesIerrors,_namesInontSet) = + (names_ _namesOallFields _namesOallNonterminals _namesOdefinedSets) + ( _attrsIattrDecls,_attrsIerrors,_attrsIuseMap) = + (attrs_ _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOnts) + ( _altsIcollectedConstructorNames,_altsIcollectedFields) = + (alts_ _altsOallConstructors _altsOallNonterminals _altsOnts) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Deriving :: Pos -> + T_NontSet -> + ([Name]) -> + T_Elem +sem_Elem_Deriving pos_ (T_NontSet set_) classes_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOderivings :: Derivings + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + _setOallFields :: DataTypes + _setOallNonterminals :: (Set Nonterminal) + _setOdefinedSets :: DefinedSets + _setIcollectedNames :: (Set Name) + _setIerrors :: (Seq Error) + _setInontSet :: (Set Nonterminal) + -- "Transform.ag"(line 600, column 14) + _lhsOderivings = + Map.fromList [(nt,Set.fromList classes_) | nt <- Set.toList _setInontSet] + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + _setIcollectedNames + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _setIerrors + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + -- copy rule (down) + _setOallFields = + _lhsIallFields + -- copy rule (down) + _setOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _setOdefinedSets = + _lhsIdefinedSets + ( _setIcollectedNames,_setIerrors,_setInontSet) = + (set_ _setOallFields _setOallNonterminals _setOdefinedSets) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Module :: Pos -> + String -> + String -> + String -> + T_Elem +sem_Elem_Module pos_ name_ exports_ imports_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + -- "Transform.ag"(line 738, column 7) + _lhsOmoduleDecl = + Just (name_, exports_, imports_) + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + Set.empty + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Pragma :: Pos -> + ([Name]) -> + T_Elem +sem_Elem_Pragma pos_ names_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOpragmas :: (Options -> Options) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + -- "Transform.ag"(line 502, column 13) + _lhsOpragmas = + let mk n o = case getName n of + "nocycle" -> o { withCycle = False } + "cycle" -> o { withCycle = True } + "nostrictdata" -> o { strictData = False } + "strictdata" -> o { strictData = True } + "nostrictcase" -> o { strictCases = False } + "strictcase" -> o { strictCases = True } + "strictercase" -> o { strictCases = True, stricterCases = True } + "nostrictwrap" -> o { strictWrap = False } + "strictwrap" -> o { strictWrap = True } + "novisit" -> o { visit = False } + "visit" -> o { visit = True } + "nocase" -> o { cases = False } + "case" -> o { cases = True } + "noseq" -> o { withSeq = False } + "seq" -> o { withSeq = True } + "nounbox" -> o { unbox = False } + "unbox" -> o { unbox = True } + "bangpats" -> o { bangpats = True } + "nooptimize" -> o { cases = False , visit = False } + "optimize" -> o { cases = True , visit = True } + "strictsem" -> o { strictSems = True } + "gentraces" -> o { genTraces = True } + "splitsems" -> o { splitSems = True } + "gencostcentres" -> o { genCostCentres = True } + "sepsemmods" -> o { sepSemMods = True } + "genlinepragmas" -> o { genLinePragmas = True } + _ -> o + in \o -> foldr mk o names_ + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + Set.empty + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Sem :: Pos -> + T_NontSet -> + T_Attrs -> + T_SemAlts -> + T_Elem +sem_Elem_Sem pos_ (T_NontSet names_) (T_Attrs attrs_) (T_SemAlts alts_) = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _altsOnts :: (Set Nonterminal) + _attrsOnts :: (Set Nonterminal) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + _namesOallFields :: DataTypes + _namesOallNonterminals :: (Set Nonterminal) + _namesOdefinedSets :: DefinedSets + _attrsOallFields :: DataTypes + _attrsOallNonterminals :: (Set Nonterminal) + _attrsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _altsOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) + _altsOallFields :: DataTypes + _namesIcollectedNames :: (Set Name) + _namesIerrors :: (Seq Error) + _namesInontSet :: (Set Nonterminal) + _attrsIattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _attrsIerrors :: (Seq Error) + _attrsIuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _altsIattrOrderCollect :: AttrOrderMap + _altsIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _altsIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _altsIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _altsIerrors :: (Seq Error) + _altsIorderDepErrorsCollect :: (Seq Error) + _altsIsemPragmasCollect :: PragmaMap + -- "Transform.ag"(line 150, column 10) + _altsOnts = + _namesInontSet + -- "Transform.ag"(line 617, column 10) + _attrsOnts = + _namesInontSet + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + _altsIattrOrderCollect + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + _altsIcollectedInsts + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + _namesIcollectedNames + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + _altsIcollectedRules + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + _altsIcollectedSigs + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _namesIerrors Seq.<> _attrsIerrors Seq.<> _altsIerrors + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + _altsIorderDepErrorsCollect + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + _altsIsemPragmasCollect + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + _attrsIuseMap + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (up) + _lhsOattrDecls = + _attrsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + -- copy rule (down) + _namesOallFields = + _lhsIallFields + -- copy rule (down) + _namesOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _namesOdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _attrsOallFields = + _lhsIallFields + -- copy rule (down) + _attrsOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _attrsOattrDecls = + _lhsIattrDecls + -- copy rule (down) + _altsOallAttrDecls = + _lhsIallAttrDecls + -- copy rule (down) + _altsOallFields = + _lhsIallFields + ( _namesIcollectedNames,_namesIerrors,_namesInontSet) = + (names_ _namesOallFields _namesOallNonterminals _namesOdefinedSets) + ( _attrsIattrDecls,_attrsIerrors,_attrsIuseMap) = + (attrs_ _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOnts) + ( _altsIattrOrderCollect,_altsIcollectedInsts,_altsIcollectedRules,_altsIcollectedSigs,_altsIerrors,_altsIorderDepErrorsCollect,_altsIsemPragmasCollect) = + (alts_ _altsOallAttrDecls _altsOallFields _altsOnts) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Set :: Pos -> + Name -> + T_NontSet -> + T_Elem +sem_Elem_Set pos_ name_ (T_NontSet set_) = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOcollectedSetNames :: (Set Name) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + _lhsOerrors :: (Seq Error) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _setOallFields :: DataTypes + _setOallNonterminals :: (Set Nonterminal) + _setOdefinedSets :: DefinedSets + _setIcollectedNames :: (Set Name) + _setIerrors :: (Seq Error) + _setInontSet :: (Set Nonterminal) + -- "Transform.ag"(line 334, column 10) + _lhsOcollectedSetNames = + Set.singleton name_ + -- "Transform.ag"(line 422, column 13) + __tup3 = + let allUsedNames = Set.unions [ maybe (Set.singleton n) + snd + (Map.lookup n _lhsIdefSets) + | n <- Set.toList _setIcollectedNames + ] + (nontSet,e1) | Set.member name_ allUsedNames + = (Set.empty, Seq.single(CyclicSet name_)) + | otherwise = (_setInontSet, Seq.empty) + (res, e2) = checkDuplicate DupSet name_ (nontSet,Set.insert name_ allUsedNames) _lhsIdefSets + in (res, e1 Seq.<> e2) + -- "Transform.ag"(line 422, column 13) + (_defSets2,_) = + __tup3 + -- "Transform.ag"(line 422, column 13) + (_,_errs) = + __tup3 + -- "Transform.ag"(line 432, column 9) + _lhsOdefSets = + _defSets2 + -- "Transform.ag"(line 432, column 9) + _lhsOerrors = + _errs <> _setIerrors + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + _setIcollectedNames + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (down) + _setOallFields = + _lhsIallFields + -- copy rule (down) + _setOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _setOdefinedSets = + _lhsIdefinedSets + ( _setIcollectedNames,_setIerrors,_setInontSet) = + (set_ _setOallFields _setOallNonterminals _setOdefinedSets) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Txt :: Pos -> + Name -> + ([String]) -> + T_Elem +sem_Elem_Txt pos_ name_ lines_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOblocks :: Blocks + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + -- "Transform.ag"(line 159, column 11) + _lhsOblocks = + Map.singleton (getName name_) [(lines_, pos_)] + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + Set.empty + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Type :: Pos -> + Nonterminal -> + ComplexType -> + T_Elem +sem_Elem_Type pos_ name_ type_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedNames :: (Set Name) + _lhsOtypeSyns :: TypeSyns + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + -- "Transform.ag"(line 212, column 10) + _lhsOcollectedFields = + map (\(x,y)->(name_, x, y)) _expanded + -- "Transform.ag"(line 337, column 11) + _lhsOcollectedNames = + Set.singleton name_ + -- "Transform.ag"(line 391, column 11) + _expanded = + case _argType of + List tp -> [(Ident "Cons" pos_, [(Ident "hd" pos_, tp) + ,(Ident "tl" pos_, NT name_) + ] + ) + ,(Ident "Nil" pos_, []) + ] + Maybe tp -> [(Ident "Just" pos_, [(Ident "just" pos_, tp) + ] + ) + ,(Ident "Nothing" pos_, []) + ] + Tuple xs -> [(Ident "Tuple" pos_, xs)] + -- "Transform.ag"(line 404, column 11) + _argType = + case type_ of + Maybe tp -> Maybe ( makeType _lhsIallNonterminals tp) + List tp -> List ( makeType _lhsIallNonterminals tp) + Tuple xs -> Tuple [(f,makeType _lhsIallNonterminals tp) | (f,tp) <- xs] + -- "Transform.ag"(line 408, column 11) + _lhsOtypeSyns = + [(name_,_argType)] + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Wrapper :: Pos -> + T_NontSet -> + T_Elem +sem_Elem_Wrapper pos_ (T_NontSet set_) = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOwrappers :: (Set Nonterminal) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + _setOallFields :: DataTypes + _setOallNonterminals :: (Set Nonterminal) + _setOdefinedSets :: DefinedSets + _setIcollectedNames :: (Set Name) + _setIerrors :: (Seq Error) + _setInontSet :: (Set Nonterminal) + -- "Transform.ag"(line 493, column 13) + _lhsOwrappers = + _setInontSet + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + _setIcollectedNames + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _setIerrors + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + Map.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + -- copy rule (down) + _setOallFields = + _lhsIallFields + -- copy rule (down) + _setOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _setOdefinedSets = + _lhsIdefinedSets + ( _setIcollectedNames,_setIerrors,_setInontSet) = + (set_ _setOallFields _setOallNonterminals _setOdefinedSets) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +-- Elems ------------------------------------------------------- +{- + visit 0: + inherited attributes: + allAttrDecls : Map Nonterminal (Attributes, Attributes) + allConstructors : Map Nonterminal (Set Constructor) + allFields : DataTypes + allNonterminals : Set Nonterminal + definedSets : DefinedSets + chained attributes: + attrDecls : Map Nonterminal (Attributes, Attributes) + defSets : Map Name (Set Nonterminal,Set Name) + synthesized attributes: + attrOrderCollect : AttrOrderMap + blocks : Blocks + collectedConstructorsMap : Map Nonterminal (Set Constructor) + collectedFields : [(Nonterminal, Constructor, FieldMap)] + collectedInsts : [ (Nonterminal, Constructor, [Identifier]) ] + collectedNames : Set Name + collectedRules : [ (Nonterminal, Constructor, RuleInfo)] + collectedSetNames : Set Name + collectedSigs : [ (Nonterminal, Constructor, SigInfo) ] + derivings : Derivings + errors : Seq Error + moduleDecl : Maybe (String,String,String) + orderDepErrorsCollect : Seq Error + pragmas : Options -> Options + semPragmasCollect : PragmaMap + typeSyns : TypeSyns + useMap : Map Nonterminal (Map Name (String,String,String)) + wrappers : Set Nonterminal + alternatives: + alternative Cons: + child hd : Elem + child tl : Elems + alternative Nil: +-} +-- cata +sem_Elems :: Elems -> + T_Elems +sem_Elems list = + (Prelude.foldr sem_Elems_Cons sem_Elems_Nil (Prelude.map sem_Elem list)) +-- semantic domain +newtype T_Elems = T_Elems ((Map Nonterminal (Attributes, Attributes)) -> + (Map Nonterminal (Set Constructor)) -> + DataTypes -> + (Set Nonterminal) -> + (Map Nonterminal (Attributes, Attributes)) -> + (Map Name (Set Nonterminal,Set Name)) -> + DefinedSets -> + ( (Map Nonterminal (Attributes, Attributes)),AttrOrderMap,Blocks,(Map Nonterminal (Set Constructor)),([(Nonterminal, Constructor, FieldMap)]),([ (Nonterminal, Constructor, [Identifier]) ]),(Set Name),([ (Nonterminal, Constructor, RuleInfo)]),(Set Name),([ (Nonterminal, Constructor, SigInfo) ]),(Map Name (Set Nonterminal,Set Name)),Derivings,(Seq Error),(Maybe (String,String,String)),(Seq Error),(Options -> Options),PragmaMap,TypeSyns,(Map Nonterminal (Map Name (String,String,String))),(Set Nonterminal))) +data Inh_Elems = Inh_Elems {allAttrDecls_Inh_Elems :: Map Nonterminal (Attributes, Attributes),allConstructors_Inh_Elems :: Map Nonterminal (Set Constructor),allFields_Inh_Elems :: DataTypes,allNonterminals_Inh_Elems :: Set Nonterminal,attrDecls_Inh_Elems :: Map Nonterminal (Attributes, Attributes),defSets_Inh_Elems :: Map Name (Set Nonterminal,Set Name),definedSets_Inh_Elems :: DefinedSets} +data Syn_Elems = Syn_Elems {attrDecls_Syn_Elems :: Map Nonterminal (Attributes, Attributes),attrOrderCollect_Syn_Elems :: AttrOrderMap,blocks_Syn_Elems :: Blocks,collectedConstructorsMap_Syn_Elems :: Map Nonterminal (Set Constructor),collectedFields_Syn_Elems :: [(Nonterminal, Constructor, FieldMap)],collectedInsts_Syn_Elems :: [ (Nonterminal, Constructor, [Identifier]) ],collectedNames_Syn_Elems :: Set Name,collectedRules_Syn_Elems :: [ (Nonterminal, Constructor, RuleInfo)],collectedSetNames_Syn_Elems :: Set Name,collectedSigs_Syn_Elems :: [ (Nonterminal, Constructor, SigInfo) ],defSets_Syn_Elems :: Map Name (Set Nonterminal,Set Name),derivings_Syn_Elems :: Derivings,errors_Syn_Elems :: Seq Error,moduleDecl_Syn_Elems :: Maybe (String,String,String),orderDepErrorsCollect_Syn_Elems :: Seq Error,pragmas_Syn_Elems :: Options -> Options,semPragmasCollect_Syn_Elems :: PragmaMap,typeSyns_Syn_Elems :: TypeSyns,useMap_Syn_Elems :: Map Nonterminal (Map Name (String,String,String)),wrappers_Syn_Elems :: Set Nonterminal} +wrap_Elems (T_Elems sem) (Inh_Elems _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) = + (let ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers) = + (sem _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) + in (Syn_Elems _lhsOattrDecls _lhsOattrOrderCollect _lhsOblocks _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOorderDepErrorsCollect _lhsOpragmas _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers)) +sem_Elems_Cons :: T_Elem -> + T_Elems -> + T_Elems +sem_Elems_Cons (T_Elem hd_) (T_Elems tl_) = + (T_Elems (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + _hdOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) + _hdOallConstructors :: (Map Nonterminal (Set Constructor)) + _hdOallFields :: DataTypes + _hdOallNonterminals :: (Set Nonterminal) + _hdOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _hdOdefSets :: (Map Name (Set Nonterminal,Set Name)) + _hdOdefinedSets :: DefinedSets + _tlOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) + _tlOallConstructors :: (Map Nonterminal (Set Constructor)) + _tlOallFields :: DataTypes + _tlOallNonterminals :: (Set Nonterminal) + _tlOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _tlOdefSets :: (Map Name (Set Nonterminal,Set Name)) + _tlOdefinedSets :: DefinedSets + _hdIattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _hdIattrOrderCollect :: AttrOrderMap + _hdIblocks :: Blocks + _hdIcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _hdIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _hdIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _hdIcollectedNames :: (Set Name) + _hdIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _hdIcollectedSetNames :: (Set Name) + _hdIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _hdIdefSets :: (Map Name (Set Nonterminal,Set Name)) + _hdIderivings :: Derivings + _hdIerrors :: (Seq Error) + _hdImoduleDecl :: (Maybe (String,String,String)) + _hdIorderDepErrorsCollect :: (Seq Error) + _hdIpragmas :: (Options -> Options) + _hdIsemPragmasCollect :: PragmaMap + _hdItypeSyns :: TypeSyns + _hdIuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _hdIwrappers :: (Set Nonterminal) + _tlIattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _tlIattrOrderCollect :: AttrOrderMap + _tlIblocks :: Blocks + _tlIcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _tlIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _tlIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _tlIcollectedNames :: (Set Name) + _tlIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _tlIcollectedSetNames :: (Set Name) + _tlIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _tlIdefSets :: (Map Name (Set Nonterminal,Set Name)) + _tlIderivings :: Derivings + _tlIerrors :: (Seq Error) + _tlImoduleDecl :: (Maybe (String,String,String)) + _tlIorderDepErrorsCollect :: (Seq Error) + _tlIpragmas :: (Options -> Options) + _tlIsemPragmasCollect :: PragmaMap + _tlItypeSyns :: TypeSyns + _tlIuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _tlIwrappers :: (Set Nonterminal) + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + _hdIattrOrderCollect `orderMapUnion` _tlIattrOrderCollect + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + _hdIblocks `mapUnionWithPlusPlus` _tlIblocks + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + _hdIcollectedConstructorsMap `mapUnionWithSetUnion` _tlIcollectedConstructorsMap + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + _hdIcollectedFields ++ _tlIcollectedFields + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + _hdIcollectedInsts ++ _tlIcollectedInsts + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + _hdIcollectedNames `Set.union` _tlIcollectedNames + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + _hdIcollectedRules ++ _tlIcollectedRules + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + _hdIcollectedSetNames `Set.union` _tlIcollectedSetNames + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + _hdIcollectedSigs ++ _tlIcollectedSigs + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + _hdIderivings `mergeDerivings` _tlIderivings + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + _hdImoduleDecl `mplus` _tlImoduleDecl + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + _hdIorderDepErrorsCollect Seq.<> _tlIorderDepErrorsCollect + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + _hdIpragmas . _tlIpragmas + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + _hdIsemPragmasCollect `pragmaMapUnion` _tlIsemPragmasCollect + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + _hdItypeSyns ++ _tlItypeSyns + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + _hdIuseMap `merge` _tlIuseMap + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + _hdIwrappers `Set.union` _tlIwrappers + -- copy rule (up) + _lhsOattrDecls = + _tlIattrDecls + -- copy rule (up) + _lhsOdefSets = + _tlIdefSets + -- copy rule (down) + _hdOallAttrDecls = + _lhsIallAttrDecls + -- copy rule (down) + _hdOallConstructors = + _lhsIallConstructors + -- copy rule (down) + _hdOallFields = + _lhsIallFields + -- copy rule (down) + _hdOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _hdOattrDecls = + _lhsIattrDecls + -- copy rule (down) + _hdOdefSets = + _lhsIdefSets + -- copy rule (down) + _hdOdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _tlOallAttrDecls = + _lhsIallAttrDecls + -- copy rule (down) + _tlOallConstructors = + _lhsIallConstructors + -- copy rule (down) + _tlOallFields = + _lhsIallFields + -- copy rule (down) + _tlOallNonterminals = + _lhsIallNonterminals + -- copy rule (chain) + _tlOattrDecls = + _hdIattrDecls + -- copy rule (chain) + _tlOdefSets = + _hdIdefSets + -- copy rule (down) + _tlOdefinedSets = + _lhsIdefinedSets + ( _hdIattrDecls,_hdIattrOrderCollect,_hdIblocks,_hdIcollectedConstructorsMap,_hdIcollectedFields,_hdIcollectedInsts,_hdIcollectedNames,_hdIcollectedRules,_hdIcollectedSetNames,_hdIcollectedSigs,_hdIdefSets,_hdIderivings,_hdIerrors,_hdImoduleDecl,_hdIorderDepErrorsCollect,_hdIpragmas,_hdIsemPragmasCollect,_hdItypeSyns,_hdIuseMap,_hdIwrappers) = + (hd_ _hdOallAttrDecls _hdOallConstructors _hdOallFields _hdOallNonterminals _hdOattrDecls _hdOdefSets _hdOdefinedSets) + ( _tlIattrDecls,_tlIattrOrderCollect,_tlIblocks,_tlIcollectedConstructorsMap,_tlIcollectedFields,_tlIcollectedInsts,_tlIcollectedNames,_tlIcollectedRules,_tlIcollectedSetNames,_tlIcollectedSigs,_tlIdefSets,_tlIderivings,_tlIerrors,_tlImoduleDecl,_tlIorderDepErrorsCollect,_tlIpragmas,_tlIsemPragmasCollect,_tlItypeSyns,_tlIuseMap,_tlIwrappers) = + (tl_ _tlOallAttrDecls _tlOallConstructors _tlOallFields _tlOallNonterminals _tlOattrDecls _tlOdefSets _tlOdefinedSets) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elems_Nil :: T_Elems +sem_Elems_Nil = + (T_Elems (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) + _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedNames :: (Set Name) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Name) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) + _lhsOwrappers :: (Set Nonterminal) + _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) + _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 81, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 112, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + Set.empty + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 72, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 593, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 734, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 499, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 378, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 124, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 490, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +-- NontSet ----------------------------------------------------- +{- + visit 0: + inherited attributes: + allFields : DataTypes + allNonterminals : Set Nonterminal + definedSets : DefinedSets + synthesized attributes: + collectedNames : Set Name + errors : Seq Error + nontSet : Set Nonterminal + alternatives: + alternative All: + alternative Difference: + child set1 : NontSet + child set2 : NontSet + alternative Intersect: + child set1 : NontSet + child set2 : NontSet + alternative NamedSet: + child name : {Nonterminal} + visit 0: + local _tup4 : _ + local nontSet : _ + local errors : _ + alternative Path: + child from : {Nonterminal} + child to : {Nonterminal} + alternative Union: + child set1 : NontSet + child set2 : NontSet +-} +-- cata +sem_NontSet :: NontSet -> + T_NontSet +sem_NontSet (All ) = + (sem_NontSet_All ) +sem_NontSet (Difference _set1 _set2) = + (sem_NontSet_Difference (sem_NontSet _set1) (sem_NontSet _set2)) +sem_NontSet (Intersect _set1 _set2) = + (sem_NontSet_Intersect (sem_NontSet _set1) (sem_NontSet _set2)) +sem_NontSet (NamedSet _name) = + (sem_NontSet_NamedSet _name) +sem_NontSet (Path _from _to) = + (sem_NontSet_Path _from _to) +sem_NontSet (Union _set1 _set2) = + (sem_NontSet_Union (sem_NontSet _set1) (sem_NontSet _set2)) +-- semantic domain +newtype T_NontSet = T_NontSet (DataTypes -> + (Set Nonterminal) -> + DefinedSets -> + ( (Set Name),(Seq Error),(Set Nonterminal))) +data Inh_NontSet = Inh_NontSet {allFields_Inh_NontSet :: DataTypes,allNonterminals_Inh_NontSet :: Set Nonterminal,definedSets_Inh_NontSet :: DefinedSets} +data Syn_NontSet = Syn_NontSet {collectedNames_Syn_NontSet :: Set Name,errors_Syn_NontSet :: Seq Error,nontSet_Syn_NontSet :: Set Nonterminal} +wrap_NontSet (T_NontSet sem) (Inh_NontSet _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) = + (let ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet) = + (sem _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) + in (Syn_NontSet _lhsOcollectedNames _lhsOerrors _lhsOnontSet)) +sem_NontSet_All :: T_NontSet +sem_NontSet_All = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOnontSet :: (Set Nonterminal) + _lhsOcollectedNames :: (Set Name) + _lhsOerrors :: (Seq Error) + -- "Transform.ag"(line 436, column 16) + _lhsOnontSet = + _lhsIallNonterminals + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + Set.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +sem_NontSet_Difference :: T_NontSet -> + T_NontSet -> + T_NontSet +sem_NontSet_Difference (T_NontSet set1_) (T_NontSet set2_) = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOnontSet :: (Set Nonterminal) + _lhsOcollectedNames :: (Set Name) + _lhsOerrors :: (Seq Error) + _set1OallFields :: DataTypes + _set1OallNonterminals :: (Set Nonterminal) + _set1OdefinedSets :: DefinedSets + _set2OallFields :: DataTypes + _set2OallNonterminals :: (Set Nonterminal) + _set2OdefinedSets :: DefinedSets + _set1IcollectedNames :: (Set Name) + _set1Ierrors :: (Seq Error) + _set1InontSet :: (Set Nonterminal) + _set2IcollectedNames :: (Set Name) + _set2Ierrors :: (Seq Error) + _set2InontSet :: (Set Nonterminal) + -- "Transform.ag"(line 442, column 16) + _lhsOnontSet = + Set.difference _set1InontSet _set2InontSet + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + _set1IcollectedNames `Set.union` _set2IcollectedNames + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _set1Ierrors Seq.<> _set2Ierrors + -- copy rule (down) + _set1OallFields = + _lhsIallFields + -- copy rule (down) + _set1OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set1OdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _set2OallFields = + _lhsIallFields + -- copy rule (down) + _set2OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set2OdefinedSets = + _lhsIdefinedSets + ( _set1IcollectedNames,_set1Ierrors,_set1InontSet) = + (set1_ _set1OallFields _set1OallNonterminals _set1OdefinedSets) + ( _set2IcollectedNames,_set2Ierrors,_set2InontSet) = + (set2_ _set2OallFields _set2OallNonterminals _set2OdefinedSets) + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +sem_NontSet_Intersect :: T_NontSet -> + T_NontSet -> + T_NontSet +sem_NontSet_Intersect (T_NontSet set1_) (T_NontSet set2_) = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOnontSet :: (Set Nonterminal) + _lhsOcollectedNames :: (Set Name) + _lhsOerrors :: (Seq Error) + _set1OallFields :: DataTypes + _set1OallNonterminals :: (Set Nonterminal) + _set1OdefinedSets :: DefinedSets + _set2OallFields :: DataTypes + _set2OallNonterminals :: (Set Nonterminal) + _set2OdefinedSets :: DefinedSets + _set1IcollectedNames :: (Set Name) + _set1Ierrors :: (Seq Error) + _set1InontSet :: (Set Nonterminal) + _set2IcollectedNames :: (Set Name) + _set2Ierrors :: (Seq Error) + _set2InontSet :: (Set Nonterminal) + -- "Transform.ag"(line 441, column 16) + _lhsOnontSet = + Set.intersection _set1InontSet _set2InontSet + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + _set1IcollectedNames `Set.union` _set2IcollectedNames + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _set1Ierrors Seq.<> _set2Ierrors + -- copy rule (down) + _set1OallFields = + _lhsIallFields + -- copy rule (down) + _set1OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set1OdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _set2OallFields = + _lhsIallFields + -- copy rule (down) + _set2OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set2OdefinedSets = + _lhsIdefinedSets + ( _set1IcollectedNames,_set1Ierrors,_set1InontSet) = + (set1_ _set1OallFields _set1OallNonterminals _set1OdefinedSets) + ( _set2IcollectedNames,_set2Ierrors,_set2InontSet) = + (set2_ _set2OallFields _set2OallNonterminals _set2OdefinedSets) + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +sem_NontSet_NamedSet :: Nonterminal -> + T_NontSet +sem_NontSet_NamedSet name_ = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOcollectedNames :: (Set Name) + _lhsOerrors :: (Seq Error) + _lhsOnontSet :: (Set Nonterminal) + -- "Transform.ag"(line 340, column 14) + _lhsOcollectedNames = + Set.singleton name_ + -- "Transform.ag"(line 437, column 20) + __tup4 = + case Map.lookup name_ _lhsIdefinedSets of + Nothing -> (Set.empty, Seq.single (UndefNont name_)) + Just set -> (set, Seq.empty) + -- "Transform.ag"(line 437, column 20) + (_nontSet,_) = + __tup4 + -- "Transform.ag"(line 437, column 20) + (_,_errors) = + __tup4 + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _errors + -- copy rule (from local) + _lhsOnontSet = + _nontSet + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +sem_NontSet_Path :: Nonterminal -> + Nonterminal -> + T_NontSet +sem_NontSet_Path from_ to_ = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOnontSet :: (Set Nonterminal) + _lhsOerrors :: (Seq Error) + _lhsOcollectedNames :: (Set Name) + -- "Transform.ag"(line 443, column 16) + _lhsOnontSet = + let table = flattenDatas _lhsIallFields + in path table from_ to_ + -- "Transform.ag"(line 445, column 16) + _lhsOerrors = + let check name | Set.member name _lhsIallNonterminals + = Seq.empty + | otherwise = Seq.single (UndefNont name) + in check from_ <> check to_ + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + Set.empty + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +sem_NontSet_Union :: T_NontSet -> + T_NontSet -> + T_NontSet +sem_NontSet_Union (T_NontSet set1_) (T_NontSet set2_) = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOnontSet :: (Set Nonterminal) + _lhsOcollectedNames :: (Set Name) + _lhsOerrors :: (Seq Error) + _set1OallFields :: DataTypes + _set1OallNonterminals :: (Set Nonterminal) + _set1OdefinedSets :: DefinedSets + _set2OallFields :: DataTypes + _set2OallNonterminals :: (Set Nonterminal) + _set2OdefinedSets :: DefinedSets + _set1IcollectedNames :: (Set Name) + _set1Ierrors :: (Seq Error) + _set1InontSet :: (Set Nonterminal) + _set2IcollectedNames :: (Set Name) + _set2Ierrors :: (Seq Error) + _set2InontSet :: (Set Nonterminal) + -- "Transform.ag"(line 440, column 16) + _lhsOnontSet = + Set.union _set1InontSet _set2InontSet + -- use rule "Transform.ag"(line 73, column 50) + _lhsOcollectedNames = + _set1IcollectedNames `Set.union` _set2IcollectedNames + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _set1Ierrors Seq.<> _set2Ierrors + -- copy rule (down) + _set1OallFields = + _lhsIallFields + -- copy rule (down) + _set1OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set1OdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _set2OallFields = + _lhsIallFields + -- copy rule (down) + _set2OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set2OdefinedSets = + _lhsIdefinedSets + ( _set1IcollectedNames,_set1Ierrors,_set1InontSet) = + (set1_ _set1OallFields _set1OallNonterminals _set1OdefinedSets) + ( _set2IcollectedNames,_set2Ierrors,_set2InontSet) = + (set2_ _set2OallFields _set2OallNonterminals _set2OdefinedSets) + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +-- Pattern ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + definedAttrs : [AttrName] + definedInsts : [Identifier] + patunder : [AttrName]->Pattern + stpos : Pos + alternatives: + alternative Alias: + child field : {Name} + child attr : {Name} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + alternative Constr: + child name : {Constructor} + child pats : Patterns + visit 0: + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) +sem_Pattern (Constr _name _pats) = + (sem_Pattern_Constr _name (sem_Patterns _pats)) +sem_Pattern (Product _pos _pats) = + (sem_Pattern_Product _pos (sem_Patterns _pats)) +sem_Pattern (Underscore _pos) = + (sem_Pattern_Underscore _pos) +-- semantic domain +newtype T_Pattern = T_Pattern (( Pattern,([AttrName]),([Identifier]),([AttrName]->Pattern),Pos)) +data Inh_Pattern = Inh_Pattern {} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,definedAttrs_Syn_Pattern :: [AttrName],definedInsts_Syn_Pattern :: [Identifier],patunder_Syn_Pattern :: [AttrName]->Pattern,stpos_Syn_Pattern :: Pos} +wrap_Pattern (T_Pattern sem) (Inh_Pattern ) = + (let ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos) = + (sem ) + in (Syn_Pattern _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder _lhsOstpos)) +sem_Pattern_Alias :: Name -> + Name -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = + (T_Pattern (let _lhsOdefinedAttrs :: ([AttrName]) + _lhsOpatunder :: ([AttrName]->Pattern) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOstpos :: Pos + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIdefinedAttrs :: ([AttrName]) + _patIdefinedInsts :: ([Identifier]) + _patIpatunder :: ([AttrName]->Pattern) + _patIstpos :: Pos + _partsIcopy :: Patterns + _partsIdefinedAttrs :: ([AttrName]) + _partsIdefinedInsts :: ([Identifier]) + _partsIpatunder :: ([AttrName]->Patterns) + -- "Transform.ag"(line 711, column 11) + _lhsOdefinedAttrs = + (field_, attr_) : _patIdefinedAttrs + -- "Transform.ag"(line 712, column 11) + _lhsOpatunder = + \us -> if ((field_,attr_) `elem` us) then Underscore noPos else _copy + -- "Transform.ag"(line 713, column 11) + _lhsOdefinedInsts = + (if field_ == _INST then [attr_] else []) ++ _patIdefinedInsts + -- "Transform.ag"(line 727, column 16) + _lhsOstpos = + getPos field_ + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patIcopy,_patIdefinedAttrs,_patIdefinedInsts,_patIpatunder,_patIstpos) = + (pat_ ) + ( _partsIcopy,_partsIdefinedAttrs,_partsIdefinedInsts,_partsIpatunder) = + (parts_ ) + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) +sem_Pattern_Constr :: Constructor -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_) = + (T_Pattern (let _lhsOpatunder :: ([AttrName]->Pattern) + _lhsOstpos :: Pos + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIdefinedAttrs :: ([AttrName]) + _patsIdefinedInsts :: ([Identifier]) + _patsIpatunder :: ([AttrName]->Patterns) + -- "Transform.ag"(line 715, column 12) + _lhsOpatunder = + \us -> Constr name_ (_patsIpatunder us) + -- "Transform.ag"(line 725, column 16) + _lhsOstpos = + getPos name_ + -- use rule "Transform.ag"(line 706, column 42) + _lhsOdefinedAttrs = + _patsIdefinedAttrs + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + _patsIdefinedInsts + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIdefinedAttrs,_patsIdefinedInsts,_patsIpatunder) = + (pats_ ) + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_) = + (T_Pattern (let _lhsOpatunder :: ([AttrName]->Pattern) + _lhsOstpos :: Pos + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIdefinedAttrs :: ([AttrName]) + _patsIdefinedInsts :: ([Identifier]) + _patsIpatunder :: ([AttrName]->Patterns) + -- "Transform.ag"(line 716, column 13) + _lhsOpatunder = + \us -> Product pos_ (_patsIpatunder us) + -- "Transform.ag"(line 726, column 16) + _lhsOstpos = + pos_ + -- use rule "Transform.ag"(line 706, column 42) + _lhsOdefinedAttrs = + _patsIdefinedAttrs + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + _patsIdefinedInsts + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIdefinedAttrs,_patsIdefinedInsts,_patsIpatunder) = + (pats_ ) + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (let _lhsOpatunder :: ([AttrName]->Pattern) + _lhsOstpos :: Pos + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Pattern + -- "Transform.ag"(line 714, column 16) + _lhsOpatunder = + \us -> _copy + -- "Transform.ag"(line 728, column 16) + _lhsOstpos = + pos_ + -- use rule "Transform.ag"(line 706, column 42) + _lhsOdefinedAttrs = + [] + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) +-- Patterns ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + definedAttrs : [AttrName] + definedInsts : [Identifier] + patunder : [AttrName]->Patterns + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) +-- semantic domain +newtype T_Patterns = T_Patterns (( Patterns,([AttrName]),([Identifier]),([AttrName]->Patterns))) +data Inh_Patterns = Inh_Patterns {} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,definedAttrs_Syn_Patterns :: [AttrName],definedInsts_Syn_Patterns :: [Identifier],patunder_Syn_Patterns :: [AttrName]->Patterns} +wrap_Patterns (T_Patterns sem) (Inh_Patterns ) = + (let ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder) = + (sem ) + in (Syn_Patterns _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder)) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = + (T_Patterns (let _lhsOpatunder :: ([AttrName]->Patterns) + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Patterns + _hdIcopy :: Pattern + _hdIdefinedAttrs :: ([AttrName]) + _hdIdefinedInsts :: ([Identifier]) + _hdIpatunder :: ([AttrName]->Pattern) + _hdIstpos :: Pos + _tlIcopy :: Patterns + _tlIdefinedAttrs :: ([AttrName]) + _tlIdefinedInsts :: ([Identifier]) + _tlIpatunder :: ([AttrName]->Patterns) + -- "Transform.ag"(line 720, column 10) + _lhsOpatunder = + \us -> (_hdIpatunder us) : (_tlIpatunder us) + -- use rule "Transform.ag"(line 706, column 42) + _lhsOdefinedAttrs = + _hdIdefinedAttrs ++ _tlIdefinedAttrs + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + _hdIdefinedInsts ++ _tlIdefinedInsts + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _lhsOcopy = + _copy + ( _hdIcopy,_hdIdefinedAttrs,_hdIdefinedInsts,_hdIpatunder,_hdIstpos) = + (hd_ ) + ( _tlIcopy,_tlIdefinedAttrs,_tlIdefinedInsts,_tlIpatunder) = + (tl_ ) + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder))) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (let _lhsOpatunder :: ([AttrName]->Patterns) + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Patterns + -- "Transform.ag"(line 719, column 9) + _lhsOpatunder = + \us -> [] + -- use rule "Transform.ag"(line 706, column 42) + _lhsOdefinedAttrs = + [] + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + [] + -- self rule + _copy = + [] + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder))) +-- SemAlt ------------------------------------------------------ +{- + visit 0: + inherited attributes: + allAttrDecls : Map Nonterminal (Attributes, Attributes) + allFields : DataTypes + nts : Set Nonterminal + synthesized attributes: + attrOrderCollect : AttrOrderMap + collectedInsts : [ (Nonterminal, Constructor, [Identifier]) ] + collectedRules : [ (Nonterminal, Constructor, RuleInfo)] + collectedSigs : [ (Nonterminal, Constructor, SigInfo) ] + errors : Seq Error + orderDepErrorsCollect : Seq Error + semPragmasCollect : PragmaMap + alternatives: + alternative SemAlt: + child pos : {Pos} + child constructorSet : ConstructorSet + child rules : SemDefs + visit 0: + local pragmaNames : _ + local attrOrders : _ + local coninfo : _ +-} +-- cata +sem_SemAlt :: SemAlt -> + T_SemAlt +sem_SemAlt (SemAlt _pos _constructorSet _rules) = + (sem_SemAlt_SemAlt _pos (sem_ConstructorSet _constructorSet) (sem_SemDefs _rules)) +-- semantic domain +newtype T_SemAlt = T_SemAlt ((Map Nonterminal (Attributes, Attributes)) -> + DataTypes -> + (Set Nonterminal) -> + ( AttrOrderMap,([ (Nonterminal, Constructor, [Identifier]) ]),([ (Nonterminal, Constructor, RuleInfo)]),([ (Nonterminal, Constructor, SigInfo) ]),(Seq Error),(Seq Error),PragmaMap)) +data Inh_SemAlt = Inh_SemAlt {allAttrDecls_Inh_SemAlt :: Map Nonterminal (Attributes, Attributes),allFields_Inh_SemAlt :: DataTypes,nts_Inh_SemAlt :: Set Nonterminal} +data Syn_SemAlt = Syn_SemAlt {attrOrderCollect_Syn_SemAlt :: AttrOrderMap,collectedInsts_Syn_SemAlt :: [ (Nonterminal, Constructor, [Identifier]) ],collectedRules_Syn_SemAlt :: [ (Nonterminal, Constructor, RuleInfo)],collectedSigs_Syn_SemAlt :: [ (Nonterminal, Constructor, SigInfo) ],errors_Syn_SemAlt :: Seq Error,orderDepErrorsCollect_Syn_SemAlt :: Seq Error,semPragmasCollect_Syn_SemAlt :: PragmaMap} +wrap_SemAlt (T_SemAlt sem) (Inh_SemAlt _lhsIallAttrDecls _lhsIallFields _lhsInts) = + (let ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOorderDepErrorsCollect,_lhsOsemPragmasCollect) = + (sem _lhsIallAttrDecls _lhsIallFields _lhsInts) + in (Syn_SemAlt _lhsOattrOrderCollect _lhsOcollectedInsts _lhsOcollectedRules _lhsOcollectedSigs _lhsOerrors _lhsOorderDepErrorsCollect _lhsOsemPragmasCollect)) +sem_SemAlt_SemAlt :: Pos -> + T_ConstructorSet -> + T_SemDefs -> + T_SemAlt +sem_SemAlt_SemAlt pos_ (T_ConstructorSet constructorSet_) (T_SemDefs rules_) = + (T_SemAlt (\ _lhsIallAttrDecls + _lhsIallFields + _lhsInts -> + (let _lhsOsemPragmasCollect :: PragmaMap + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOerrors :: (Seq Error) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOorderDepErrorsCollect :: (Seq Error) + _constructorSetIcollectedConstructorNames :: (Set Constructor) + _constructorSetIconstructors :: ((Set Constructor->Set Constructor)) + _constructorSetIerrors :: (Seq Error) + _rulesIdefinedInsts :: ([Identifier]) + _rulesIorderDepsCollect :: (Set Dependency) + _rulesIpragmaNamesCollect :: ([Name]) + _rulesIruleInfos :: ([RuleInfo]) + _rulesIsigInfos :: ([SigInfo] ) + -- "Transform.ag"(line 536, column 7) + _pragmaNames = + Set.fromList _rulesIpragmaNamesCollect + -- "Transform.ag"(line 537, column 7) + _lhsOsemPragmasCollect = + foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con _pragmaNames + | (nt, conset, _) <- _coninfo + , con <- Set.toList conset + ] + -- "Transform.ag"(line 566, column 7) + _attrOrders = + [ orderMapSingle nt con _rulesIorderDepsCollect + | (nt, conset, _) <- _coninfo + , con <- Set.toList conset + ] + -- "Transform.ag"(line 572, column 7) + _lhsOattrOrderCollect = + foldr orderMapUnion Map.empty _attrOrders + -- "Transform.ag"(line 666, column 12) + _coninfo = + [ (nt, conset, conkeys) + | nt <- Set.toList _lhsInts + , let conmap = Map.findWithDefault Map.empty nt _lhsIallFields + , let conkeys = Set.fromList (Map.keys conmap) + , let conset = _constructorSetIconstructors conkeys + ] + -- "Transform.ag"(line 673, column 12) + _lhsOerrors = + Seq.fromList + [ UndefAlt nt con + | (nt, conset, conkeys) <- _coninfo + , con <- Set.toList (Set.difference conset conkeys) + ] + -- "Transform.ag"(line 678, column 12) + _lhsOcollectedRules = + [ (nt,con,r) + | (nt, conset, _) <- _coninfo + , con <- Set.toList conset + , r <- _rulesIruleInfos + ] + -- "Transform.ag"(line 684, column 12) + _lhsOcollectedSigs = + [ (nt,con,ts) + | (nt, conset, _) <- _coninfo + , con <- Set.toList conset + , ts <- _rulesIsigInfos + ] + -- "Transform.ag"(line 691, column 12) + _lhsOcollectedInsts = + [ (nt,con,_rulesIdefinedInsts) + | (nt, conset, _) <- _coninfo + , con <- Set.toList conset + ] + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + ( _constructorSetIcollectedConstructorNames,_constructorSetIconstructors,_constructorSetIerrors) = + (constructorSet_ ) + ( _rulesIdefinedInsts,_rulesIorderDepsCollect,_rulesIpragmaNamesCollect,_rulesIruleInfos,_rulesIsigInfos) = + (rules_ ) + in ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOorderDepErrorsCollect,_lhsOsemPragmasCollect)))) +-- SemAlts ----------------------------------------------------- +{- + visit 0: + inherited attributes: + allAttrDecls : Map Nonterminal (Attributes, Attributes) + allFields : DataTypes + nts : Set Nonterminal + synthesized attributes: + attrOrderCollect : AttrOrderMap + collectedInsts : [ (Nonterminal, Constructor, [Identifier]) ] + collectedRules : [ (Nonterminal, Constructor, RuleInfo)] + collectedSigs : [ (Nonterminal, Constructor, SigInfo) ] + errors : Seq Error + orderDepErrorsCollect : Seq Error + semPragmasCollect : PragmaMap + alternatives: + alternative Cons: + child hd : SemAlt + child tl : SemAlts + alternative Nil: +-} +-- cata +sem_SemAlts :: SemAlts -> + T_SemAlts +sem_SemAlts list = + (Prelude.foldr sem_SemAlts_Cons sem_SemAlts_Nil (Prelude.map sem_SemAlt list)) +-- semantic domain +newtype T_SemAlts = T_SemAlts ((Map Nonterminal (Attributes, Attributes)) -> + DataTypes -> + (Set Nonterminal) -> + ( AttrOrderMap,([ (Nonterminal, Constructor, [Identifier]) ]),([ (Nonterminal, Constructor, RuleInfo)]),([ (Nonterminal, Constructor, SigInfo) ]),(Seq Error),(Seq Error),PragmaMap)) +data Inh_SemAlts = Inh_SemAlts {allAttrDecls_Inh_SemAlts :: Map Nonterminal (Attributes, Attributes),allFields_Inh_SemAlts :: DataTypes,nts_Inh_SemAlts :: Set Nonterminal} +data Syn_SemAlts = Syn_SemAlts {attrOrderCollect_Syn_SemAlts :: AttrOrderMap,collectedInsts_Syn_SemAlts :: [ (Nonterminal, Constructor, [Identifier]) ],collectedRules_Syn_SemAlts :: [ (Nonterminal, Constructor, RuleInfo)],collectedSigs_Syn_SemAlts :: [ (Nonterminal, Constructor, SigInfo) ],errors_Syn_SemAlts :: Seq Error,orderDepErrorsCollect_Syn_SemAlts :: Seq Error,semPragmasCollect_Syn_SemAlts :: PragmaMap} +wrap_SemAlts (T_SemAlts sem) (Inh_SemAlts _lhsIallAttrDecls _lhsIallFields _lhsInts) = + (let ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOorderDepErrorsCollect,_lhsOsemPragmasCollect) = + (sem _lhsIallAttrDecls _lhsIallFields _lhsInts) + in (Syn_SemAlts _lhsOattrOrderCollect _lhsOcollectedInsts _lhsOcollectedRules _lhsOcollectedSigs _lhsOerrors _lhsOorderDepErrorsCollect _lhsOsemPragmasCollect)) +sem_SemAlts_Cons :: T_SemAlt -> + T_SemAlts -> + T_SemAlts +sem_SemAlts_Cons (T_SemAlt hd_) (T_SemAlts tl_) = + (T_SemAlts (\ _lhsIallAttrDecls + _lhsIallFields + _lhsInts -> + (let _lhsOattrOrderCollect :: AttrOrderMap + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOerrors :: (Seq Error) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOsemPragmasCollect :: PragmaMap + _hdOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) + _hdOallFields :: DataTypes + _hdOnts :: (Set Nonterminal) + _tlOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) + _tlOallFields :: DataTypes + _tlOnts :: (Set Nonterminal) + _hdIattrOrderCollect :: AttrOrderMap + _hdIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _hdIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _hdIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _hdIerrors :: (Seq Error) + _hdIorderDepErrorsCollect :: (Seq Error) + _hdIsemPragmasCollect :: PragmaMap + _tlIattrOrderCollect :: AttrOrderMap + _tlIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _tlIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _tlIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _tlIerrors :: (Seq Error) + _tlIorderDepErrorsCollect :: (Seq Error) + _tlIsemPragmasCollect :: PragmaMap + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + _hdIattrOrderCollect `orderMapUnion` _tlIattrOrderCollect + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + _hdIcollectedInsts ++ _tlIcollectedInsts + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + _hdIcollectedRules ++ _tlIcollectedRules + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + _hdIcollectedSigs ++ _tlIcollectedSigs + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + _hdIorderDepErrorsCollect Seq.<> _tlIorderDepErrorsCollect + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + _hdIsemPragmasCollect `pragmaMapUnion` _tlIsemPragmasCollect + -- copy rule (down) + _hdOallAttrDecls = + _lhsIallAttrDecls + -- copy rule (down) + _hdOallFields = + _lhsIallFields + -- copy rule (down) + _hdOnts = + _lhsInts + -- copy rule (down) + _tlOallAttrDecls = + _lhsIallAttrDecls + -- copy rule (down) + _tlOallFields = + _lhsIallFields + -- copy rule (down) + _tlOnts = + _lhsInts + ( _hdIattrOrderCollect,_hdIcollectedInsts,_hdIcollectedRules,_hdIcollectedSigs,_hdIerrors,_hdIorderDepErrorsCollect,_hdIsemPragmasCollect) = + (hd_ _hdOallAttrDecls _hdOallFields _hdOnts) + ( _tlIattrOrderCollect,_tlIcollectedInsts,_tlIcollectedRules,_tlIcollectedSigs,_tlIerrors,_tlIorderDepErrorsCollect,_tlIsemPragmasCollect) = + (tl_ _tlOallAttrDecls _tlOallFields _tlOnts) + in ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOorderDepErrorsCollect,_lhsOsemPragmasCollect)))) +sem_SemAlts_Nil :: T_SemAlts +sem_SemAlts_Nil = + (T_SemAlts (\ _lhsIallAttrDecls + _lhsIallFields + _lhsInts -> + (let _lhsOattrOrderCollect :: AttrOrderMap + _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) + _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) + _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) + _lhsOerrors :: (Seq Error) + _lhsOorderDepErrorsCollect :: (Seq Error) + _lhsOsemPragmasCollect :: PragmaMap + -- use rule "Transform.ag"(line 560, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 134, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 135, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 561, column 60) + _lhsOorderDepErrorsCollect = + Seq.empty + -- use rule "Transform.ag"(line 532, column 56) + _lhsOsemPragmasCollect = + Map.empty + in ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOorderDepErrorsCollect,_lhsOsemPragmasCollect)))) +-- SemDef ------------------------------------------------------ +{- + visit 0: + synthesized attributes: + definedInsts : [Identifier] + orderDepsCollect : Set Dependency + pragmaNamesCollect : [Name] + ruleInfos : [RuleInfo] + sigInfos : [SigInfo] + alternatives: + alternative AttrOrderBefore: + child before : {(Identifier,Identifier)} + child after : {(Identifier,Identifier)} + visit 0: + local dependency : _ + alternative Def: + child pattern : Pattern + child rhs : {Expression} + child owrt : {Bool} + alternative SemPragma: + child names : {[Name]} + alternative TypeDef: + child ident : {Identifier} + child tp : {Type} +-} +-- cata +sem_SemDef :: SemDef -> + T_SemDef +sem_SemDef (AttrOrderBefore _before _after) = + (sem_SemDef_AttrOrderBefore _before _after) +sem_SemDef (Def _pattern _rhs _owrt) = + (sem_SemDef_Def (sem_Pattern _pattern) _rhs _owrt) +sem_SemDef (SemPragma _names) = + (sem_SemDef_SemPragma _names) +sem_SemDef (TypeDef _ident _tp) = + (sem_SemDef_TypeDef _ident _tp) +-- semantic domain +newtype T_SemDef = T_SemDef (( ([Identifier]),(Set Dependency),([Name]),([RuleInfo]),([SigInfo] ))) +data Inh_SemDef = Inh_SemDef {} +data Syn_SemDef = Syn_SemDef {definedInsts_Syn_SemDef :: [Identifier],orderDepsCollect_Syn_SemDef :: Set Dependency,pragmaNamesCollect_Syn_SemDef :: [Name],ruleInfos_Syn_SemDef :: [RuleInfo],sigInfos_Syn_SemDef :: [SigInfo] } +wrap_SemDef (T_SemDef sem) (Inh_SemDef ) = + (let ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos) = + (sem ) + in (Syn_SemDef _lhsOdefinedInsts _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos)) +sem_SemDef_AttrOrderBefore :: ((Identifier,Identifier)) -> + ((Identifier,Identifier)) -> + T_SemDef +sem_SemDef_AttrOrderBefore before_ after_ = + (T_SemDef (let _lhsOorderDepsCollect :: (Set Dependency) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOpragmaNamesCollect :: ([Name]) + _lhsOruleInfos :: ([RuleInfo]) + _lhsOsigInfos :: ([SigInfo] ) + -- "Transform.ag"(line 578, column 7) + _dependency = + Dependency before_ after_ + -- "Transform.ag"(line 579, column 7) + _lhsOorderDepsCollect = + Set.singleton _dependency + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + [] + -- use rule "Transform.ag"(line 542, column 46) + _lhsOpragmaNamesCollect = + [] + -- use rule "Transform.ag"(line 660, column 37) + _lhsOruleInfos = + [] + -- use rule "Transform.ag"(line 661, column 37) + _lhsOsigInfos = + [] + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) +sem_SemDef_Def :: T_Pattern -> + Expression -> + Bool -> + T_SemDef +sem_SemDef_Def (T_Pattern pattern_) rhs_ owrt_ = + (T_SemDef (let _lhsOruleInfos :: ([RuleInfo]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOorderDepsCollect :: (Set Dependency) + _lhsOpragmaNamesCollect :: ([Name]) + _lhsOsigInfos :: ([SigInfo] ) + _patternIcopy :: Pattern + _patternIdefinedAttrs :: ([AttrName]) + _patternIdefinedInsts :: ([Identifier]) + _patternIpatunder :: ([AttrName]->Pattern) + _patternIstpos :: Pos + -- "Transform.ag"(line 699, column 10) + _lhsOruleInfos = + [ (_patternIpatunder, rhs_, _patternIdefinedAttrs, owrt_, show _patternIstpos) ] + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + _patternIdefinedInsts + -- use rule "Transform.ag"(line 574, column 44) + _lhsOorderDepsCollect = + Set.empty + -- use rule "Transform.ag"(line 542, column 46) + _lhsOpragmaNamesCollect = + [] + -- use rule "Transform.ag"(line 661, column 37) + _lhsOsigInfos = + [] + ( _patternIcopy,_patternIdefinedAttrs,_patternIdefinedInsts,_patternIpatunder,_patternIstpos) = + (pattern_ ) + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) +sem_SemDef_SemPragma :: ([Name]) -> + T_SemDef +sem_SemDef_SemPragma names_ = + (T_SemDef (let _lhsOpragmaNamesCollect :: ([Name]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOorderDepsCollect :: (Set Dependency) + _lhsOruleInfos :: ([RuleInfo]) + _lhsOsigInfos :: ([SigInfo] ) + -- "Transform.ag"(line 546, column 7) + _lhsOpragmaNamesCollect = + names_ + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + [] + -- use rule "Transform.ag"(line 574, column 44) + _lhsOorderDepsCollect = + Set.empty + -- use rule "Transform.ag"(line 660, column 37) + _lhsOruleInfos = + [] + -- use rule "Transform.ag"(line 661, column 37) + _lhsOsigInfos = + [] + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) +sem_SemDef_TypeDef :: Identifier -> + Type -> + T_SemDef +sem_SemDef_TypeDef ident_ tp_ = + (T_SemDef (let _lhsOsigInfos :: ([SigInfo] ) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOorderDepsCollect :: (Set Dependency) + _lhsOpragmaNamesCollect :: ([Name]) + _lhsOruleInfos :: ([RuleInfo]) + -- "Transform.ag"(line 702, column 14) + _lhsOsigInfos = + [ (ident_, tp_) ] + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + [] + -- use rule "Transform.ag"(line 574, column 44) + _lhsOorderDepsCollect = + Set.empty + -- use rule "Transform.ag"(line 542, column 46) + _lhsOpragmaNamesCollect = + [] + -- use rule "Transform.ag"(line 660, column 37) + _lhsOruleInfos = + [] + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) +-- SemDefs ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + definedInsts : [Identifier] + orderDepsCollect : Set Dependency + pragmaNamesCollect : [Name] + ruleInfos : [RuleInfo] + sigInfos : [SigInfo] + alternatives: + alternative Cons: + child hd : SemDef + child tl : SemDefs + alternative Nil: +-} +-- cata +sem_SemDefs :: SemDefs -> + T_SemDefs +sem_SemDefs list = + (Prelude.foldr sem_SemDefs_Cons sem_SemDefs_Nil (Prelude.map sem_SemDef list)) +-- semantic domain +newtype T_SemDefs = T_SemDefs (( ([Identifier]),(Set Dependency),([Name]),([RuleInfo]),([SigInfo] ))) +data Inh_SemDefs = Inh_SemDefs {} +data Syn_SemDefs = Syn_SemDefs {definedInsts_Syn_SemDefs :: [Identifier],orderDepsCollect_Syn_SemDefs :: Set Dependency,pragmaNamesCollect_Syn_SemDefs :: [Name],ruleInfos_Syn_SemDefs :: [RuleInfo],sigInfos_Syn_SemDefs :: [SigInfo] } +wrap_SemDefs (T_SemDefs sem) (Inh_SemDefs ) = + (let ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos) = + (sem ) + in (Syn_SemDefs _lhsOdefinedInsts _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos)) +sem_SemDefs_Cons :: T_SemDef -> + T_SemDefs -> + T_SemDefs +sem_SemDefs_Cons (T_SemDef hd_) (T_SemDefs tl_) = + (T_SemDefs (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOorderDepsCollect :: (Set Dependency) + _lhsOpragmaNamesCollect :: ([Name]) + _lhsOruleInfos :: ([RuleInfo]) + _lhsOsigInfos :: ([SigInfo] ) + _hdIdefinedInsts :: ([Identifier]) + _hdIorderDepsCollect :: (Set Dependency) + _hdIpragmaNamesCollect :: ([Name]) + _hdIruleInfos :: ([RuleInfo]) + _hdIsigInfos :: ([SigInfo] ) + _tlIdefinedInsts :: ([Identifier]) + _tlIorderDepsCollect :: (Set Dependency) + _tlIpragmaNamesCollect :: ([Name]) + _tlIruleInfos :: ([RuleInfo]) + _tlIsigInfos :: ([SigInfo] ) + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + _hdIdefinedInsts ++ _tlIdefinedInsts + -- use rule "Transform.ag"(line 574, column 44) + _lhsOorderDepsCollect = + _hdIorderDepsCollect `Set.union` _tlIorderDepsCollect + -- use rule "Transform.ag"(line 542, column 46) + _lhsOpragmaNamesCollect = + _hdIpragmaNamesCollect ++ _tlIpragmaNamesCollect + -- use rule "Transform.ag"(line 660, column 37) + _lhsOruleInfos = + _hdIruleInfos ++ _tlIruleInfos + -- use rule "Transform.ag"(line 661, column 37) + _lhsOsigInfos = + _hdIsigInfos ++ _tlIsigInfos + ( _hdIdefinedInsts,_hdIorderDepsCollect,_hdIpragmaNamesCollect,_hdIruleInfos,_hdIsigInfos) = + (hd_ ) + ( _tlIdefinedInsts,_tlIorderDepsCollect,_tlIpragmaNamesCollect,_tlIruleInfos,_tlIsigInfos) = + (tl_ ) + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) +sem_SemDefs_Nil :: T_SemDefs +sem_SemDefs_Nil = + (T_SemDefs (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOorderDepsCollect :: (Set Dependency) + _lhsOpragmaNamesCollect :: ([Name]) + _lhsOruleInfos :: ([RuleInfo]) + _lhsOsigInfos :: ([SigInfo] ) + -- use rule "Transform.ag"(line 705, column 55) + _lhsOdefinedInsts = + [] + -- use rule "Transform.ag"(line 574, column 44) + _lhsOorderDepsCollect = + Set.empty + -- use rule "Transform.ag"(line 542, column 46) + _lhsOpragmaNamesCollect = + [] + -- use rule "Transform.ag"(line 660, column 37) + _lhsOruleInfos = + [] + -- use rule "Transform.ag"(line 661, column 37) + _lhsOsigInfos = + [] + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) diff --git a/src/Ag.hs b/src/Ag.hs new file mode 100644 --- /dev/null +++ b/src/Ag.hs @@ -0,0 +1,261 @@ +module Main where + +import System (getArgs, getProgName, exitFailure) +import System.Console.GetOpt (usageInfo) +import List (isSuffixOf) +import Monad (zipWithM_) +import Data.Maybe + +import qualified Data.Map as Map (elems, partitionWithKey, unionWith) +import qualified UU.DData.Seq as Seq ((<>),toList) +import Pretty + +import UU.Parsing (Message(..), Action(..)) +import UU.Scanner.Position (Pos, line, file) +import UU.Scanner.Token (Token) + +import qualified Transform as Pass1 (sem_AG , wrap_AG , Syn_AG (..), Inh_AG (..)) +import qualified Desugar as Pass1a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified DefaultRules as Pass2 (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified Order as Pass3 (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified GenerateCode as Pass4 (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..)) +import qualified PrintCode as Pass5 (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) +import qualified PrintErrorMessages as PrErr (sem_Errors , wrap_Errors , Syn_Errors (..), Inh_Errors (..), isError) + +import qualified AbstractSyntaxDump as GrammarDump (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified CodeSyntaxDump as CGrammarDump (sem_CGrammar, wrap_CGrammar, Syn_CGrammar (..), Inh_CGrammar (..)) + +import Options +import Version (banner) +import Parser (parseAG, depsAG) +import ErrorMessages (Error(ParserError), Errors) +import CommonTypes (Blocks) + + +main :: IO () +main + = do args <- getArgs + progName <- getProgName + + let usageheader = "Usage info:\n " ++ progName ++ " options file ...\n\nList of options:" + (flags,files,errs) = getOptions args + + if showVersion flags + then putStrLn banner + else if null files || showHelp flags || (not.null) errs + then mapM_ putStrLn (usageInfo usageheader options : errs) + else if genFileDeps flags + then reportDeps flags files + else zipWithM_ (compile flags) files (outputFiles flags++repeat "") + + +compile :: Options -> String -> String -> IO () +compile flags input output + = do (output0,parseErrors) <- parseAG (searchPath flags) (inputFile input) + + let output1 = Pass1.wrap_AG (Pass1.sem_AG output0 ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags} + flags' = Pass1.pragmas_Syn_AG output1 $ flags + grammar1 = Pass1.output_Syn_AG output1 + output1a = Pass1a.wrap_Grammar (Pass1a.sem_Grammar grammar1 ) Pass1a.Inh_Grammar {Pass1a.options_Inh_Grammar = flags'} + grammar1a =Pass1a.output_Syn_Grammar output1a + output2 = Pass2.wrap_Grammar (Pass2.sem_Grammar grammar1a ) Pass2.Inh_Grammar {Pass2.options_Inh_Grammar = flags'} + grammar2 = Pass2.output_Syn_Grammar output2 + output3 = Pass3.wrap_Grammar (Pass3.sem_Grammar grammar2 ) Pass3.Inh_Grammar {Pass3.options_Inh_Grammar = flags'} + grammar3 = Pass3.output_Syn_Grammar output3 + output4 = Pass4.wrap_CGrammar (Pass4.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4.Inh_CGrammar {Pass4.options_Inh_CGrammar = flags'} + output5 = Pass5.wrap_Program (Pass5.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5.Inh_Program {Pass5.options_Inh_Program = flags', Pass5.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5.importBlocks_Inh_Program = importBlocksTxt, Pass5.textBlocks_Inh_Program = textBlocksDoc, Pass5.optionsLine_Inh_Program = optionsLine, Pass5.mainFile_Inh_Program = mainFile, Pass5.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1} + output6 = PrErr.wrap_Errors (PrErr.sem_Errors errorsToReport) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags'} + + dump1 = GrammarDump.wrap_Grammar (GrammarDump.sem_Grammar grammar1 ) GrammarDump.Inh_Grammar + dump2 = GrammarDump.wrap_Grammar (GrammarDump.sem_Grammar grammar2 ) GrammarDump.Inh_Grammar + dump3 = CGrammarDump.wrap_CGrammar (CGrammarDump.sem_CGrammar grammar3 ) CGrammarDump.Inh_CGrammar + + parseErrorList = map message2error parseErrors + errorList = parseErrorList + ++ Seq.toList ( Pass1.errors_Syn_AG output1 + Seq.<> Pass1a.errors_Syn_Grammar output1a + Seq.<> Pass2.errors_Syn_Grammar output2 + Seq.<> Pass3.errors_Syn_Grammar output3 + Seq.<> Pass4.errors_Syn_CGrammar output4 + ) + + fatalErrorList = filter PrErr.isError errorList + + allErrors = if null parseErrors + then if wignore flags' + then fatalErrorList + else errorsToFront errorList + else take 1 parseErrorList + -- the other 1000 or so parse errors are usually not that informative + + errorsToReport = take (wmaxerrs flags') allErrors + + errorsToStopOn = if werrors flags' + then errorList + else fatalErrorList + + blocks1 = (Pass1.blocks_Syn_AG output1) {-SM `Map.unionWith (++)` (Pass3.blocks_Syn_Grammar output3)-} + (pragmaBlocks, blocks2) = Map.partitionWithKey (\k _->k=="optpragmas") blocks1 + (importBlocks, textBlocks) = Map.partitionWithKey (\k _->k=="imports" ) blocks2 + + importBlocksTxt = vlist_sep "" . map addLocationPragma . concat . Map.elems $ importBlocks + textBlocksDoc = vlist_sep "" . map addLocationPragma . concat . Map.elems $ textBlocks + pragmaBlocksTxt = unlines . concat . map fst . concat . Map.elems $ pragmaBlocks + + outputfile = if null output then outputFile input else output + + addLocationPragma :: ([String], Pos) -> PP_Doc + addLocationPragma (strs, p) + | genLinePragmas flags' + = "{-# LINE" >#< pp (show (line p)) >#< show (file p) >#< "#-}" >-< vlist (map pp strs) >-< "{-# LINE" >#< ppWithLineNr (pp.show.(+1)) >#< show outputfile >#< "#-}" + | otherwise + = vlist (map pp strs) + + optionsGHC = option (unbox flags') "-fglasgow-exts" ++ option (bangpats flags') "-fbang-patterns" + option True s = [s] + option False _ = [] + optionsLine | null optionsGHC = "" + | otherwise = "{-# OPTIONS_GHC " ++ unwords optionsGHC ++ " #-}" + + mainName = stripPath $ defaultModuleName input + mainFile = defaultModuleName input + + nrOfErrorsToReport = length $ filter PrErr.isError errorsToReport + nrOfWarningsToReport = length $ filter (not.PrErr.isError) errorsToReport + totalNrOfErrors = length $ filter PrErr.isError allErrors + totalNrOfWarnings = length $ filter (not.PrErr.isError) allErrors + additionalErrors = totalNrOfErrors - nrOfErrorsToReport + additionalWarnings = totalNrOfWarnings - nrOfWarningsToReport + pluralS n = if n == 1 then "" else "s" + + putStr . formatErrors $ PrErr.pp_Syn_Errors output6 + + if additionalErrors > 0 + then putStr $ "\nPlus " ++ show additionalErrors ++ " more error" ++ pluralS additionalErrors ++ + if additionalWarnings > 0 + then " and " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n" + else ".\n" + else if additionalWarnings > 0 + then putStr $ "\nPlus " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n" + else return () + + if not (null fatalErrorList) + then exitFailure + else if sepSemMods flags' + then do -- alternative module gen + Pass5.genIO_Syn_Program output5 + if not (null errorsToStopOn) then exitFailure else return () + else do -- conventional module gen + let doc = vlist [ pp optionsLine + , pp $ take 70 ("-- UUAGC " ++ drop 50 banner ++ " (" ++ input) ++ ")" + , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 + then moduleHeader flags' mainName + else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False + , pp importBlocksTxt + , textBlocksDoc + , vlist $ Pass5.output_Syn_Program output5 + , if dumpgrammar flags' + then vlist [ pp "{- Dump of grammar without default rules" + , GrammarDump.pp_Syn_Grammar dump1 + , pp "-}" + , pp "{- Dump of grammar with default rules" + , GrammarDump.pp_Syn_Grammar dump2 + , pp "-}" + ] + else empty + , if dumpcgrammar flags' + then vlist [ pp "{- Dump of cgrammar" + , CGrammarDump.pp_Syn_CGrammar dump3 + , pp "-}" + ] + else empty + ] + + let docTxt = disp doc 50000 "" + writeFile outputfile docTxt + if not (null errorsToStopOn) then exitFailure else return () + + + +formatErrors :: PP_Doc -> String +formatErrors pp = disp pp 5000 "" + + +message2error :: Message Token Pos -> Error +message2error (Msg expect pos action) = ParserError pos (show expect) actionString + where actionString + = case action + of Insert s -> "inserting: " ++ show s + + Delete s -> "deleting: " ++ show s + + Other ms -> ms + +errorsToFront :: [Error] -> [Error] +errorsToFront mesgs = filter PrErr.isError mesgs ++ filter (not.PrErr.isError) mesgs + + +moduleHeader :: Options -> String -> String +moduleHeader flags input + = case moduleName flags + of Name nm -> genMod nm + Default -> genMod (defaultModuleName input) + NoName -> "" + where genMod x = "module " ++ x ++ " where" + +inputFile :: String -> String +inputFile name + = if ".ag" `isSuffixOf` name || ".lag" `isSuffixOf` name + then name + else name ++ ".ag" + +outputFile :: String -> String +outputFile name + = defaultModuleName name ++ ".hs" + +defaultModuleName :: String -> String +defaultModuleName name + = if ".ag" `isSuffixOf` name + then take (length name - 3) name + else if ".lag" `isSuffixOf` name + then take (length name - 4) name + else name + +stripPath :: String -> String +stripPath + = reverse . takeWhile (\c -> c /= '/' && c /= '\\') . reverse + +mkMainName :: String -> Maybe (String, String,String) -> String +mkMainName defaultName Nothing + = defaultName +mkMainName _ (Just (name, _, _)) + = name + +mkModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String +mkModuleHeader Nothing defaultName _ _ _ + = "module " ++ defaultName ++ " where" +mkModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports + = "module " ++ name ++ suffix ++ exp ++ " where\n" ++ imports ++ "\n" + where + exp = if null exports || (replaceExports && null addExports) + then "" + else if null addExports + then "(" ++ exports ++ ")" + else if replaceExports + then "(" ++ addExports ++ ")" + else "(" ++ exports ++ "," ++ addExports ++ ")" + +reportDeps :: Options -> [String] -> IO () +reportDeps flags files + = do results <- mapM (depsAG (searchPath flags)) files + let (fs, mesgs) = foldr combine ([],[]) results + let errs = take (wmaxerrs flags) (map message2error mesgs) + let ppErrs = PrErr.wrap_Errors (PrErr.sem_Errors errs) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags} + if null errs + then mapM_ putStrLn fs + else putStr . formatErrors $ PrErr.pp_Syn_Errors ppErrs + where + combine :: ([a],[b]) -> ([a], [b]) -> ([a], [b]) + combine (fs, mesgs) (fsr, mesgsr) + = (fs ++ fsr, mesgs ++ mesgsr) + diff --git a/src/CommonTypes.hs b/src/CommonTypes.hs new file mode 100644 --- /dev/null +++ b/src/CommonTypes.hs @@ -0,0 +1,129 @@ +module CommonTypes where + +--import UU.Pretty (PP,text,pp) +import Pretty +import UU.Scanner.Position(Pos,noPos) +import qualified Data.Map as Map +import Data.Map(Map) +import Data.Set(Set) +import qualified Data.Set as Set + + +type Blocks = Map String [([String], Pos)] + +data Identifier = Ident {getName::String , getPos::Pos} + +instance Eq Identifier where + Ident x _ == Ident y _ = x == y + +instance Ord Identifier where + compare (Ident x _) (Ident y _) = compare x y + +instance Show Identifier where + show ident = getName ident + +instance PP Identifier where + pp = text . getName + +data Type = Haskell String + | NT Name + +data ComplexType = List Type + | Tuple [(Identifier, Type)] + | Maybe Type + +instance Show ComplexType where + show (List t ) = "[" ++ show t ++ "]" + show (Tuple ts) = "(" ++ showList [ show n ++ ": " ++ show t | (n,t) <- ts ] "" ++ ")" + show (Maybe t ) = "Maybe " ++ show t + +instance Show Type where + show (Haskell t) = t + show (NT nt ) = getName nt + +instance Eq Type where + NT x == NT y = x == y + _ == _ = False + +type Attributes = Map Name Type +type TypeSyns = [(Nonterminal,ComplexType)] + +type AttrNames = [(Name,Type,(String,String,String))] +type UseMap = Map Nonterminal (Map Name (String,String,String)) +type PragmaMap = Map Nonterminal (Map Constructor (Set Name)) +type Fields = [(Name,Type)] +type Derivings = Map Nonterminal (Set Name) +type Strings = [String] +type Name = Identifier +type Nonterminal = Name +type Constructor = Name +type AttrOrderMap = Map Nonterminal (Map Constructor (Set Dependency)) +data Dependency = Dependency (Identifier,Identifier) (Identifier,Identifier) deriving (Eq,Ord,Show) + +type AttrEnv = ( [Name] + , [(Name,Name)] + ) + +identifier x = Ident x noPos +nullIdent = identifier "" +_LHS = identifier "lhs" +_SELF = identifier "SELF" +_LOC = identifier "loc" +_INST = identifier "inst" +_INST' = identifier "inst'" +_FIELD = identifier "field" +_FIRST = identifier "first" +_LAST = identifier "last" + +sdtype :: Nonterminal -> String +sdtype nt = "T_"++getName nt + +cataname :: String -> Name -> String +cataname pre name = pre++getName name + +conname :: Bool -> Nonterminal -> Constructor -> String +conname rename nt con | rename = getName nt ++ "_" ++ getName con + | otherwise = getName con + +semname :: String -> Nonterminal -> Constructor -> String +semname pre nt con = pre ++ (getName nt ++ "_" ++ getName con) + +lhsname :: Bool -> Name -> String +lhsname isIn = attrname isIn _LHS + +attrname :: Bool -> Name -> Name -> String +attrname isIn field attr | field == _LOC = locname attr + | field == _INST = instname attr + | field == _INST' = inst'name attr + | field == _FIELD = fieldname attr + | otherwise = let direction | isIn = "I" + | otherwise = "O" + in '_' : getName field ++ direction ++ getName attr + +locname v = '_' : getName v +instname v = getName v ++ "_val_" +inst'name v = getName v ++ "_" +fieldname v = getName v++"_" + +typeToString :: Nonterminal -> Type -> String +typeToString _ (Haskell t) = t +typeToString nt (NT t ) | t == _SELF = getName nt + | otherwise = getName t + +ind :: String -> String +ind s = replicate 3 ' ' ++ s + +_NOCASE :: Name +_NOCASE = identifier "nocase" + +hasPragma :: PragmaMap -> Nonterminal -> Constructor -> Name -> Bool +hasPragma mp nt con nm + = nm `Set.member` Map.findWithDefault Set.empty con (Map.findWithDefault Map.empty nt mp) + +isNonterminal :: Type -> Bool +isNonterminal (NT _) = True +isNonterminal _ = False + +extractNonterminal :: Type -> Nonterminal +extractNonterminal (NT n) = n + diff --git a/src/DepTypes.hs b/src/DepTypes.hs new file mode 100644 --- /dev/null +++ b/src/DepTypes.hs @@ -0,0 +1,141 @@ +module DepTypes where + +import CommonTypes + +------------------------------------------------------------------------------- +-- Class definitions +------------------------------------------------------------------------------- + +class HasAttrAndField a where + getField :: a -> Identifier + getAttr :: a -> Identifier + +class ContainsTrace a where + addTraceElem :: TraceElem -> a -> a + addTrace :: Trace -> a -> a + +------------------------------------------------------------------------------- +-- Vertices +------------------------------------------------------------------------------- + +-- kan helaas niet met named fields, want dat levert een conflict op in de uniekheid vd naamgeving. +-- ERROR "CommonTypes.hs" (line 44): Repeated definition for selector "nt" + +data Vertex = Local Name Name Name -- lhs nt, constructor, attribute + | LHSInh Name Name Name -- lhs nt, constructor, attribute + | LHSSyn Name Name Name -- lhs nt, constructor, attribute + | ShRHSInh Name Name Name Name -- lhs nt, constructor, field, attribute !!rhs nt not known, equal to RHSInh!! + | ShRHSSyn Name Name Name Name -- lhs nt, constructor, field, attribute !!rhs nt not known, equal to RHSSyn!! + | RHSInh Name Name Name Name Name -- rhs nt, lhs nt, constructor, field, attribute + | RHSSyn Name Name Name Name Name -- rhs nt, lhs nt, constructor, field, attribute + | NTInh Name Name -- nt, attribute + | NTSyn Name Name -- nt, attribute + +instance Eq Vertex where + Local lhs1 con1 attr1 == Local lhs2 con2 attr2 = lhs1==lhs2 && con1==con2 && attr1==attr2 + LHSInh lhs1 con1 attr1 == LHSInh lhs2 con2 attr2 = lhs1==lhs2 && con1==con2 && attr1==attr2 + LHSSyn lhs1 con1 attr1 == LHSSyn lhs2 con2 attr2 = lhs1==lhs2 && con1==con2 && attr1==attr2 + ShRHSInh lhs1 con1 name1 attr1 == ShRHSInh lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2 + ShRHSSyn lhs1 con1 name1 attr1 == ShRHSSyn lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2 + RHSInh rhs1 lhs1 con1 name1 attr1 == RHSInh rhs2 lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2 + RHSSyn rhs1 lhs1 con1 name1 attr1 == RHSSyn rhs2 lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2 + ShRHSInh lhs1 con1 name1 attr1 == RHSInh _ lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2 + ShRHSSyn lhs1 con1 name1 attr1 == RHSSyn _ lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2 + RHSInh _ lhs1 con1 name1 attr1 == ShRHSInh lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2 + RHSSyn _ lhs1 con1 name1 attr1 == ShRHSSyn lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2 + NTInh nt1 attr1 == NTInh nt2 attr2 = nt1==nt2 && attr1==attr2 + NTSyn nt1 attr1 == NTSyn nt2 attr2 = nt1==nt2 && attr1==attr2 + _ == _ = False + +instance HasAttrAndField Vertex where + getAttr (Local _ _ attr) = attr + getAttr (LHSInh _ _ attr) = attr + getAttr (LHSSyn _ _ attr) = attr + getAttr (ShRHSInh _ _ _ attr) = attr + getAttr (ShRHSSyn _ _ _ attr) = attr + getAttr (RHSInh _ _ _ _ attr) = attr + getAttr (RHSSyn _ _ _ _ attr) = attr + getAttr (NTInh _ attr) = attr + getAttr (NTSyn _ attr) = attr + getField (Local _ _ _) = nullIdent + getField (LHSInh _ _ _) = _LHS + getField (LHSSyn _ _ _) = _LHS + getField (ShRHSInh _ _ fld _) = fld + getField (ShRHSSyn _ _ fld _) = fld + getField (RHSInh _ _ _ fld _) = fld + getField (RHSSyn _ _ _ fld _) = fld + getField (NTInh _ _) = nullIdent + getField (NTSyn _ _) = nullIdent + +instance Show Vertex where + show (Local lhs con attr) = show lhs ++ "." ++ show attr ++ "(L," ++ show lhs ++ "." ++ show con ++ ")" + show (LHSInh lhs con attr) = show lhs ++ "." ++ show attr ++ "(I," ++ show lhs ++ "." ++ show con ++ ".lhs)" + show (LHSSyn lhs con attr) = show lhs ++ "." ++ show attr ++ "(S," ++ show lhs ++ "." ++ show con ++ ".lhs)" + show (ShRHSInh lhs con name attr) = "" + show (ShRHSSyn lhs con name attr) = "" + show (RHSInh rhs lhs con name attr) = show rhs ++ "." ++ show attr ++ "(I," ++ show lhs ++ "." ++ show con ++ "." ++ show name ++ ")" + show (RHSSyn rhs lhs con name attr) = show rhs ++ "." ++ show attr ++ "(S," ++ show lhs ++ "." ++ show con ++ "." ++ show name ++ ")" + show (NTInh nt attr) = "" + show (NTSyn nt attr) = "" + + +------------------------------------------------------------------------------- +-- Streams, results +------------------------------------------------------------------------------- + +type UseStream = (Vertex,Stream) +type Stream = [Result] +type Result = ([UsedAttr],[UsedAttr]) +data UsedAttr = Loc Name Name Trace -- field name and attribute name + | Glo Name Trace -- attribute name + +-- lhs en rhs slaan op de lhs en rhs van een attribute equation en niet van de productie!! +data TraceElem = TE { lineNr :: Int + , nt :: Nonterminal + , prod :: Name + , lhsNt :: Nonterminal + , lhsFld :: Name + , lhsAttr :: Name + , rhsFld :: Name + , rhsAttr :: Name } deriving Show + +type Trace = [TraceElem] + +getTrace :: UsedAttr -> Trace +getTrace (Loc _ _ trace) = trace +getTrace (Glo _ trace) = trace + +toPair :: UsedAttr -> (Name,Trace) +toPair (Loc _ attr trace) = (attr,trace) +toPair (Glo attr trace) = (attr,trace) + +-- de Eq op Res negeert de trace, want dit is geen onderdeel van het resultaat, maar een oorzaak ervan. +-- hierdoor kan gewoon de elem functie op sets van resultaten gebruikt worden. +instance Eq UsedAttr where + Loc fld1 attr1 _ == Loc fld2 attr2 _ = fld1==fld2 && attr1==attr2 + Glo attr1 _ == Glo attr2 _ = attr1==attr2 + _ == _ = False + +instance Show UsedAttr where + show (Loc fld attr trace) = "(" ++ show fld ++ "," ++ show attr ++ ")" + show (Glo attr trace) = show attr + +instance HasAttrAndField UsedAttr where + getAttr (Loc _ attr _) = attr + getAttr (Glo attr _) = attr + getField (Loc fld attr _) = fld + getField _ = nullIdent + +instance ContainsTrace UsedAttr where + addTraceElem newtre (Loc fld attr oldtr) = Loc fld attr (newtre:oldtr) + addTraceElem newtre (Glo attr oldtr) = Glo attr (newtre:oldtr) + addTrace newtr (Loc fld attr oldtr) = Loc fld attr (newtr++oldtr) + addTrace newtr (Glo attr oldtr) = Glo attr (newtr++oldtr) + +instance ContainsTrace Result where + addTraceElem newcs (set,upd) = (map (addTraceElem newcs) set,map (addTraceElem newcs) upd) + addTrace newcss (set,upd) = (map (addTrace newcss) set,map (addTrace newcss) upd) + +instance ContainsTrace Stream where + addTraceElem newcs stream = map (addTraceElem newcs) stream + addTrace newcss stream = map (addTrace newcss) stream diff --git a/src/GrammarInfo.hs b/src/GrammarInfo.hs new file mode 100644 --- /dev/null +++ b/src/GrammarInfo.hs @@ -0,0 +1,52 @@ +module GrammarInfo where + +import SequentialTypes +import CodeSyntax +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Set(Set) +import qualified Data.Set as Set +import CommonTypes +import Data.List(intersect,(\\)) + +type LMH = (Vertex,Vertex,Vertex) +data Info = Info { tdpToTds :: Table Vertex + , tdsToTdp :: Table [Vertex] + , attrTable :: Table NTAttr + , ruleTable :: Table CRule + , lmh :: [LMH] + , prods :: [(Nonterminal,[Constructor])] + , wraps :: Set Nonterminal + } + deriving Show + +instance Show CRule + where show (CRule name isIn hasCode nt con field childnt tp pattern rhs defines owrt origin uses) + = "CRule " ++ show name ++ " nt: " ++ show nt ++ " con: " ++ show con ++ " field: " ++ show field + ++ " childnt: " ++ show childnt ++ " rhs: " ++ concat rhs ++ " uses: " ++ show [ attrname True fld nm | (fld,nm) <- Set.toList uses ] + +type CInterfaceMap = Map Nonterminal CInterface +type CVisitsMap = Map Nonterminal (Map Constructor CVisits) + +data CycleStatus + = CycleFree CInterfaceMap CVisitsMap + | LocalCycle [Route] + | InstCycle [Route] + | DirectCycle [EdgeRoutes] + | InducedCycle CInterfaceMap [EdgeRoutes] + +showsSegment :: CSegment -> [String] +showsSegment (CSegment inh syn) + = let syn' = map toString (Map.toList syn) + inh' = map toString (Map.toList inh) + toString (a,t) = (getName a, case t of (NT nt) -> getName nt; Haskell t -> t) + chnn = inh' `intersect` syn' + inhn = inh' \\ chnn + synn = syn' \\ chnn + disp name [] = [] + disp name as = (name ++ if length as == 1 then " attribute:" else " attributes:") : + map (\(x,y) -> ind x ++ replicate ((20 - length x) `max` 0) ' ' ++ " : " ++ y) as + in disp "inherited" inhn + ++ disp "chained" chnn + ++ disp "synthesized" synn + diff --git a/src/HsTokenScanner.hs b/src/HsTokenScanner.hs new file mode 100644 --- /dev/null +++ b/src/HsTokenScanner.hs @@ -0,0 +1,160 @@ + +module HsTokenScanner where +import HsToken +import UU.Scanner.Position +import List(sort) +import UU.Util.BinaryTrees +import CommonTypes +import Maybe +import Char +isAGesc c = c == '@' + +lexTokens :: Pos -> String -> [HsToken] +lexTokens = scanTokens keywordstxt keywordsops specialchars opchars + where keywordstxt = [] + keywordsops = [".","=", ":=", ":","|","@"] + specialchars = ";()[],_{}`" + opchars = "!#$%&*+./<=>?@\\^|-~:" + + +scanTokens :: [String] -> [String] -> String -> String -> Pos -> String -> [HsToken] +scanTokens keywordstxt keywordsops specchars opchars pos input + = doScan pos input + + where + locatein :: Ord a => [a] -> a -> Bool + locatein es = isJust . btLocateIn compare (tab2tree (sort es)) + iskw = locatein keywordstxt + isop = locatein keywordsops + isSymbol = locatein specchars + isOpsym = locatein opchars + + isIdStart c = isLower c || c == '_' + + isIdChar c = isAlphaNum c + || c == '\'' + || c == '_' + + scanIdent p s = let (name,rest) = span isIdChar s + in (name,advc (length name) p,rest) + + doScan p [] = [] + doScan p (c:s) | isSpace c = let (sp,next) = span isSpace s + in doScan (foldl (flip updPos) p (c:sp)) next + doScan p (c:d:s) | isAGesc c && isIdStart d = + let (fld,p2,rest) = scanIdent (advc 2 p) s + field = d:fld + in case rest of + ('.':r:rs) + | isIdStart r -> let (at,p3,rest2) = scanIdent (advc 2 p2) rs + attr = r : at + in AGField (Ident field p) (Ident attr p) p : doScan p3 rest2 + _ -> AGLocal (Ident field p) p : doScan p2 rest + + doScan p ('-':'-':s) = doScan p (dropWhile (/= '\n') s) + doScan p ('{':'-':s) = advc' 2 p (lexNest doScan) s -- } + doScan p ('"':ss) + = let (s,swidth,rest) = scanString ss + in if null rest || head rest /= '"' + then Err "Unterminated string literal" p : advc' swidth p doScan rest + else StrToken s p : advc' (swidth+2) p doScan (tail rest) + + doScan p ('\'':ss) + = let (mc,cwidth,rest) = scanChar ss + in case mc of + Nothing -> Err "Error in character literal" p : advc' cwidth p doScan rest + Just c -> if null rest || head rest /= '\'' + then Err "Unterminated character literal" p : advc' (cwidth+1) p doScan rest + else CharToken [c] p : advc' (cwidth+2) p doScan (tail rest) + doScan p cs@(c:s) + + | isIdStart c || isUpper c + = let (name', p', s') = scanIdent (advc 1 p) s + name = c:name' + tok = if iskw name + then HsToken name p -- keyword + else if null name' && isSymbol c + then HsToken [c] p -- '_' + else HsToken name p -- varid / conid + in tok : doScan p' s' + | isOpsym c = let (name, s') = span isOpsym cs + tok | isop name = HsToken name p + | otherwise = HsToken name p + in tok : doScan (foldl (flip updPos) p name) s' + | isDigit c = let (base,digs,width,s') = getNumber cs + number = case base of + 8 -> "0o"++digs + 10 -> digs + 16 -> "0x"++digs + in HsToken number p : advc' width p doScan s' + | isSymbol c = HsToken [c] p : advc' 1 p doScan s + | otherwise = Err ("Unexpected character " ++ show c) p : updPos' c p doScan s + + +lexNest cont pos inp = lexNest' cont pos inp + where lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s + lexNest' c p ('-':'}':s) = c (advc 2 p) s + lexNest' c p (x:s) = lexNest' c (updPos x p) s + lexNest' _ _ [] = [Err "Unterminated nested comment" pos] + + +scanString [] = ("",0,[]) +scanString ('\\':'&':xs) = let (str,w,r) = scanString xs + in (str,w+2,r) +scanString ('\'':xs) = let (str,w,r) = scanString xs + in ('\'': str,w+1,r) +scanString xs = let (ch,cw,cr) = getchar xs + (str,w,r) = scanString cr + str' = maybe "" (:str) ch + in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch + +scanChar ('"' :xs) = (Just '"',1,xs) +scanChar xs = getchar xs + +getchar [] = (Nothing,0,[]) +getchar s@('\n':_ ) = (Nothing,0,s ) +getchar s@('\t':_ ) = (Nothing,0,s) +getchar s@('\'':_ ) = (Nothing,0,s) +getchar s@('"' :_ ) = (Nothing,0,s) +getchar ('\\':xs) = let (c,l,r) = getEscChar xs + in (c,l+1,r) +getchar (x:xs) = (Just x,1,xs) + +getEscChar [] = (Nothing,0,[]) +getEscChar s@(x:xs) | isDigit x = let (base,n,len,rest) = getNumber s + val = readn base n + in if val >= 0 && val <= 255 + then (Just (chr val),len, rest) + else (Nothing,1,rest) + | otherwise = case x `lookup` cntrChars of + Nothing -> (Nothing,0,s) + Just c -> (Just c,1,xs) + where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t') + ,('v','\v'),('\\','\\'),('"','\"'),('\'','\'')] + +readn base n = foldl (\r x -> value x + base * r) 0 n + +getNumber cs@(c:s) + | c /= '0' = num10 + | null s = const0 + | hs == 'x' || hs == 'X' = num16 + | hs == 'o' || hs == 'O' = num8 + | otherwise = num10 + where (hs:ts) = s + const0 = (10, "0",1,s) + num10 = let (n,r) = span isDigit cs + in (10,n,length n,r) + num16 = readNum isHexaDigit ts 16 + num8 = readNum isOctalDigit ts 8 + readNum p ts tk + = let nrs@(n,rs) = span p ts + in if null n then const0 + else (tk , n, 2+length n,rs) + +isHexaDigit d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f') +isOctalDigit d = d >= '0' && d <= '7' + +value c | isDigit c = ord c - ord '0' + | isUpper c = ord c - ord 'A' + 10 + | isLower c = ord c - ord 'a' + 10 + diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -0,0 +1,197 @@ +module Options where + +import System.Console.GetOpt + +options :: [OptDescr (Options -> Options)] +options = [ Option ['m'] [] (NoArg (moduleOpt Nothing)) "generate default module header" + , Option [] ["module"] (OptArg moduleOpt "name") "generate module header, specify module name" + , Option ['d'] ["data"] (NoArg dataOpt) "generate data type definition" + , Option [] ["strictdata"] (NoArg strictDataOpt) "generate strict data fields (when data is generated)" + , Option [] ["strictwrap"] (NoArg strictWrapOpt) "generate strict wrap fields for WRAPPER generated data" + , Option ['c'] ["catas"] (NoArg cataOpt) "generate catamorphisms" + , Option ['f'] ["semfuns"] (NoArg semfunsOpt) "generate semantic functions" + , Option ['s'] ["signatures"] (NoArg signaturesOpt) "generate signatures for semantic functions" + , Option [] ["newtypes"] (NoArg newtypesOpt) "use newtypes instead of type synonyms" + , Option ['p'] ["pretty"] (NoArg prettyOpt) "generate pretty printed list of attributes" + , Option ['w'] ["wrappers"] (NoArg wrappersOpt) "generate wappers for semantic domains" + , Option ['r'] ["rename"] (NoArg renameOpt) "rename data constructors" + , Option [] ["modcopy"] (NoArg modcopyOpt) "use modified copy rule" + , Option [] ["nest"] (NoArg nestOpt) "use nested tuples" + , Option [] ["syntaxmacro"] (NoArg smacroOpt) "experimental: generate syntax macro code (using knit catas)" + , Option ['o'] ["output"] (ReqArg outputOpt "file") "specify output file" + , Option ['v'] ["verbose"] (NoArg verboseOpt) "verbose error message format" + , Option ['h','?'] ["help"] (NoArg helpOpt) "get (this) usage information" + , Option ['a'] ["all"] (NoArg allOpt) ("do everything (-" ++ allc ++ ")") + , Option ['P'] [""] (ReqArg searchPathOpt "search path") ("specify seach path") + , Option [] ["prefix"] (ReqArg prefixOpt "prefix") "set prefix for semantic functions" + , Option [] ["self"] (NoArg selfOpt) "generate self attribute" + , Option [] ["cycle"] (NoArg cycleOpt) "check for cyclic definitions" + , Option [] ["version"] (NoArg versionOpt) "get version information" + , Option ['O'] ["optimize"] (NoArg optimizeOpt) "optimize generated code (--visit --case)" + , Option [] ["visit"] (NoArg visitOpt) "try generating visit functions" + , Option [] ["seq"] (NoArg seqOpt) "force evaluation using function seq (visit functions only)" + , Option [] ["unbox"] (NoArg unboxOpt) "use unboxed tuples" + , Option [] ["bangpats"] (NoArg bangpatsOpt) "use bang patterns (visit functions only)" + , Option [] ["case"] (NoArg casesOpt) "Use nested cases instead of let (visit functions only)" + , Option [] ["strictcase"] (NoArg strictCasesOpt) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)" + , Option [] ["strictercase"] (NoArg stricterCasesOpt) "Force evaluation of all variables bound by a case statement (in generated code)" + , Option [] ["strictsem"] (NoArg strictSemOpt) "Force evaluation of sem-function arguments (in generated code)" + , Option [] ["localcps"] (NoArg localCpsOpt) "Apply a local CPS transformation (in generated code, visit functions only)" + , Option [] ["splitsems"] (NoArg splitSemsOpt) "Split semantic functions into smaller pieces" + , Option [] ["Werrors"] (NoArg werrorsOpt) "Turn warnings into fatal errors" + , Option [] ["Wignore"] (NoArg wignoreOpt) "Ignore warnings" + , Option [] ["Wmax"] (ReqArg wmaxErrsOpt "") "Sets the maximum number of errors that are reported" + , Option [] ["dumpgrammar"] (NoArg dumpgrammarOpt) "Dump internal grammar representation (in generated code)" + , Option [] ["dumpcgrammar"] (NoArg dumpcgrammarOpt) "Dump internal cgrammar representation (in generated code)" + , Option [] ["gentraces"] (NoArg genTracesOpt) "Generate trace expressions (in generated code)" + , Option [] ["gencostcentres"] (NoArg genCostCentresOpt) "Generate cost centre pragmas (in generated code)" + , Option [] ["genlinepragmas"] (NoArg genLinePragmasOpt) "Generate GHC LINE pragmas (in generated code)" + , Option [] ["sepsemmods"] (NoArg sepSemModsOpt) "Generate separate modules for semantic functions (in generated code)" + , Option ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) "Generate a list of dependencies on the input AG files" + ] + +allc = "dcfsprm" + +data Options = Options{ moduleName :: ModuleHeader + , dataTypes :: Bool + , strictData :: Bool + , strictWrap :: Bool + , folds :: Bool + , semfuns :: Bool + , typeSigs :: Bool + , attrInfo :: Bool + , rename :: Bool + , wrappers :: Bool + , modcopy :: Bool + , newtypes :: Bool + , nest :: Bool + , smacro :: Bool + , outputFiles :: [String] + , searchPath :: [String] + , verbose :: Bool + , prefix :: String + , withSelf :: Bool + , withCycle :: Bool + , showHelp :: Bool + , showVersion :: Bool + , visit :: Bool + , withSeq :: Bool + , unbox :: Bool + , bangpats :: Bool + , cases :: Bool + , strictCases :: Bool + , stricterCases :: Bool + , strictSems :: Bool + , localCps :: Bool + , splitSems :: Bool + , werrors :: Bool + , wignore :: Bool + , wmaxerrs :: Int + , dumpgrammar :: Bool + , dumpcgrammar :: Bool + , genTraces :: Bool + , genCostCentres :: Bool + , sepSemMods :: Bool + , genFileDeps :: Bool + , genLinePragmas :: Bool + } deriving Show +noOptions = Options { moduleName = NoName + , dataTypes = False + , strictData = False + , strictWrap = False + , folds = False + , semfuns = False + , typeSigs = False + , attrInfo = False + , rename = False + , wrappers = False + , modcopy = False + , newtypes = False + , nest = False + , smacro = False + , outputFiles = [] + , searchPath = [] + , verbose = False + , showHelp = False + , showVersion = False + , prefix = "sem_" + , withSelf = False + , withCycle = False + , visit = False + , withSeq = False + , unbox = False + , bangpats = False + , cases = False + , strictCases = False + , stricterCases = False + , strictSems = False + , localCps = False + , splitSems = False + , werrors = False + , wignore = False + , wmaxerrs = 99999 + , dumpgrammar = False + , dumpcgrammar = False + , genTraces = False + , genCostCentres = False + , sepSemMods = False + , genFileDeps = False + , genLinePragmas = False + } + + +moduleOpt nm opts = opts{moduleName = maybe Default Name nm} +dataOpt opts = opts{dataTypes = True} +strictDataOpt opts = opts{strictData = True} +strictWrapOpt opts = opts{strictWrap = True} +cataOpt opts = opts{folds = True} +semfunsOpt opts = opts{semfuns = True} +signaturesOpt opts = opts{typeSigs = True} +prettyOpt opts = opts{attrInfo = True} +renameOpt opts = opts{rename = True} +wrappersOpt opts = opts{wrappers = True} +modcopyOpt opts = opts{modcopy = True} +newtypesOpt opts = opts{newtypes = True} +nestOpt opts = opts{nest = True} +smacroOpt opts = opts{smacro = True} +verboseOpt opts = opts{verbose = True} +helpOpt opts = opts{showHelp = True} +versionOpt opts = opts{showVersion = True} +prefixOpt pre opts = opts{prefix = pre } +selfOpt opts = opts{withSelf = True} +cycleOpt opts = opts{withCycle = True} +visitOpt opts = opts{visit = True, withCycle = True} +seqOpt opts = opts{withSeq = True} +unboxOpt opts = opts{unbox = True} +bangpatsOpt opts = opts{bangpats = True} +casesOpt opts = opts{cases = True} +strictCasesOpt opts = opts{strictCases = True} +stricterCasesOpt opts = opts{strictCases = True, stricterCases = True} +strictSemOpt opts = opts{strictSems = True} +localCpsOpt opts = opts{localCps = True} +splitSemsOpt opts = opts{splitSems = True} +werrorsOpt opts = opts{werrors = True} +wignoreOpt opts = opts{wignore = True} +wmaxErrsOpt n opts = opts{wmaxerrs = read n} +dumpgrammarOpt opts = opts{dumpgrammar = True} +dumpcgrammarOpt opts = opts{dumpcgrammar = True} +genTracesOpt opts = opts{genTraces = True} +genCostCentresOpt opts = opts{genCostCentres = True} +sepSemModsOpt opts = opts{sepSemMods = True} +genFileDepsOpt opts = opts{genFileDeps = True} +genLinePragmasOpt opts = opts{genLinePragmas = True} + +outputOpt file opts = opts{outputFiles = file : outputFiles opts} +searchPathOpt path opts = opts{searchPath = extract path ++ searchPath opts} + where extract xs = let (p,ps) = break (\x -> x == ';' || x == ':') xs + in if null p then [] else p : extract ps +allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt +optimizeOpt = visitOpt . casesOpt + +getOptions args = let (flags,files,errors) = getOpt Permute options args + in (foldl (flip ($)) noOptions flags,files,errors) + +data ModuleHeader = NoName + | Name String + | Default deriving Show + diff --git a/src/PPUtil.hs b/src/PPUtil.hs new file mode 100644 --- /dev/null +++ b/src/PPUtil.hs @@ -0,0 +1,51 @@ +module PPUtil where + +-- +-- Some additional pretty-print functions +-- for pretty-printing abstract syntax trees. +-- + +import Data.List +import qualified Data.Map as Map +import Pretty + +ppListSep :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc +ppListSep o c s pps = o >|< hlist (intersperse (pp s) (map pp pps)) >|< c + +ppSpaced :: PP a => [a] -> PP_Doc +ppSpaced = ppListSep "" "" " " + +ppCommas :: PP a => [a] -> PP_Doc +ppCommas = ppListSep "" "" ", " + +ppVList :: PP a => [a] -> PP_Doc +ppVList = pp_block "[ " "] " ", " . map pp + +ppMap :: (Show a, Show b) => Map.Map a b -> PP_Doc +ppMap m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- Map.toList m ] + +ppAssocL :: (Show a, Show b) => [(a,b)] -> PP_Doc +ppAssocL m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- m ] + +ppF :: String -> PP_Doc -> PP_Doc +ppF s x = s >|< ":" >#< x + +ppNest :: PP a => [a] -> [PP_Doc] -> [PP_Doc] -> PP_Doc +ppNest nms attrs ps = ppNestInfo {- defaultEHCOpts -} nms attrs ps [] + +ppNestInfo :: PP a => {- EHCOpts -> -} [a] -> [PP_Doc] -> [PP_Doc] -> [(String,PP_Doc)] -> PP_Doc +ppNestInfo {- opts -} nms attrs ps infos + = ppListSep "" "" "_" nms + >#< ( (if null attrs then empty else ppSpaced attrs) + >-< (if False {- ehcOptDebug opts -} then vlist (map (\(i,p) -> pp i >|< ":" >#< p) infos) else empty) + ) + >-< indent 2 (vlist ps) + +ppNm :: String -> PP_Doc +ppNm = text . show + +ppShow :: Show x => x -> PP_Doc +ppShow x = pp $ show x + +mkInfo1 :: String -> PP_Doc -> (String,PP_Doc) +mkInfo1 = (,) diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,369 @@ +module Parser --(parseAG) +where +import Data.Maybe +import UU.Parsing +import UU.Parsing.Machine(RealParser(..),RealRecogn(..),anaDynE,mkPR) +import ConcreteSyntax +import CommonTypes +import Patterns +import UU.Pretty(text,PP_Doc,empty,(>-<)) +import TokenDef +import List (intersperse) +import Char +import Scanner (Input(..),scanLit,input) +import List +import Expression +import UU.Scanner.Token +import UU.Scanner.TokenParser +import UU.Scanner.GenToken +import UU.Scanner.GenTokenParser +import UU.Scanner.Position +import UU.Scanner.TokenShow() +import System.Directory + + +type AGParser = AnaParser Input Pair Token Pos + +pIdentifier, pIdentifierU :: AGParser Identifier +pIdentifierU = uncurry Ident <$> pConidPos +pIdentifier = uncurry Ident <$> pVaridPos + + +parseAG :: [FilePath] -> String -> IO (AG,[Message Token Pos]) +parseAG searchPath file + = do (es,_,_,mesg) <- parseFile searchPath file + return (AG es, mesg) + +depsAG :: [FilePath] -> String -> IO ([String], [Message Token Pos]) +depsAG searchPath file + = do (_,_,fs,mesgs) <- parseFile searchPath file + return (fs, mesgs) + +parseFile :: [FilePath] -> String -> IO ([Elem],[String],[String],[Message Token Pos ]) +parseFile searchPath file + = do txt <- readFile file + let litMode = ".lag" `isSuffixOf` file + (files,text) = if litMode then scanLit txt + else ([],txt) + tokens = input (initPos file) text + + steps = parse pElemsFiles tokens + stop (_,fs,_,_) = null fs + cont (es,fs,allfs,msg) + = do files <- mapM (resolveFile searchPath) fs + res <- mapM (parseFile searchPath) files + let (ess,fss,allfss, msgs) = unzip4 res + return (es ++ concat ess, concat fss, concat allfss ++ allfs, msg ++ concat msgs) + let (Pair (es,fls) _ ,mesg) = evalStepsMessages steps + let allfs = files ++ fls + loopp stop cont (es,allfs,allfs,mesg) + +resolveFile :: [FilePath] -> FilePath -> IO FilePath +resolveFile path fname = search (path ++ ["."]) + where search (p:ps) = do dExists <- doesDirectoryExist p + if dExists + then do let filename = p++pathSeparator++fname + fExists <- doesFileExist filename + if fExists + then return filename + else search ps + else search ps + search [] = error ("File: " ++ show fname ++ " not found in search path: " ++ show (concat (intersperse ";" (path ++ ["."]))) ) + +pathSeparator = "/" + +evalStepsMessages :: (Eq s, Show s, Show p) => Steps a s p -> (a,[Message s p]) +evalStepsMessages steps = case steps of + OkVal v rest -> let (arg,ms) = evalStepsMessages rest + in (v arg,ms) + Ok rest -> evalStepsMessages rest + Cost _ rest -> evalStepsMessages rest + StRepair _ msg rest -> let (v,ms) = evalStepsMessages rest + in (v, msg:ms) + Best _ rest _ -> evalStepsMessages rest + NoMoreSteps v -> (v,[]) + +loopp ::(a->Bool) -> (a->IO a) -> a -> IO a +loopp pred cont x | pred x = return x + | otherwise = do x' <- cont x + loopp pred cont x' + +pElemsFiles :: AGParser ([Elem],[String]) +pElemsFiles = pFoldr (($),([],[])) pElem' + where pElem' = addElem <$> pElem + <|> pINCLUDE *> (addInc <$> pStringPos) + addElem e (es,fs) = (e:es, fs) + addInc (fn,_) (es,fs) = ( es,fn:fs) + +pCodescrapL = (\(ValToken _ str pos) -> (str, pos))<$> + parseScrapL "a code block" + +parseScrapL :: AGParser Token +parseScrapL = let p acc = (\k (Input pos str next) -> + let (sc,rest) = case next of + Just (t@(ValToken TkTextln _ _), rs) -> (t,rs) + _ -> let (tok,p2,inp2) = codescrapL pos str + in (tok, input p2 inp2) + steps = k ( rest) + in (val (acc sc) steps) + ) + in anaDynE (mkPR (P (p ), R (p (const id)))) + +codescrapL p [] = (valueToken TkTextln "" p,p,[]) +codescrapL p (x:xs) | isSpace x = (updPos' x p) codescrapL xs + | otherwise = let refcol = column p + (p',sc,rest) = scrapL refcol p (x:xs) + in (valueToken TkTextln sc p,p',rest) + +scrapL ref p (x:xs) | isSpace x || column p >= ref = + let (p'',sc,inp) = updPos' x p (scrapL ref) xs + in (p'',x:sc,inp) + | otherwise =(p,[],x:xs) +scrapL ref p [] = (p,[],[]) + +pNontSet = set0 + where set0 = pChainr (Intersect <$ pIntersect) set1 + set1 = pChainl (Difference <$ pMinus) set2 + set2 = pChainr (pSucceed Union) set3 + set3 = pIdentifierU <**> opt (flip Path <$ pArrow <*> pIdentifierU) NamedSet + <|> All <$ pStar + <|> pParens set0 + +pNames :: AGParser [Name] +pNames = pList1 pIdentifier + +pAG :: AGParser AG +pAG = AG <$> pElems + +pElems :: AGParser Elems +pElems = pList_ng pElem + +pComplexType = List <$> pBracks pType + <|> Maybe <$ pMAYBE <*> pType + <|> tuple <$> pParens (pListSep pComma field) + where field = (,) <$> ((Just <$> pIdentifier <* pColon) `opt` Nothing) <*> pType + tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t) + | (n,(f,t)) <- zip [1..] xs + ] +pElem :: AGParser Elem +pElem = Data <$> pDATA + <*> pNontSet + <*> pOptAttrs + <*> pAlts + <*> pSucceed False + <|> Attr <$> pATTR + <*> pNontSet + <*> pAttrs + <|> Type <$> pTYPE + <*> pIdentifierU + <* pEquals + <*> pComplexType + <|> Sem <$> pSEM + <*> pNontSet + <*> pOptAttrs + <*> pSemAlts + <|> Set <$> pSET + <*> pIdentifierU + <* pEquals + <*> pNontSet + <|> Deriving + <$> pDERIVING + <*> pNontSet + <* pColon + <*> pListSep pComma pIdentifierU + <|> Wrapper + <$> pWRAPPER + <*> pNontSet + <|> Pragma + <$> pPRAGMA + <*> pNames + <|> Module + <$> pMODULE + <*> pCodescrap' + <*> pCodescrap' + <*> pCodescrap' + <|> codeBlock <$> (pIdentifier <|> pSucceed (Ident "" noPos)) <*> pCodeBlock "a statement" + where codeBlock nm (txt,pos) = Txt pos nm (lines txt) + +-- Insertion is expensive for pCodeBlock in order to prevent infinite inserts. +pCodeBlock :: AGParser (String,Pos) +pCodeBlock = pCostValToken 90 TkTextln "" "a code block" + + +pAttrs :: AGParser Attrs +pAttrs = Attrs <$> pOBrackPos <*> (concat <$> pList pInhAttrNames "inherited attribute declarations") + <* pBar <*> (concat <$> pList pAttrNames "chained attribute declarations" ) + <* pBar <*> (concat <$> pList pAttrNames "synthesised attribute declarations" ) + <* pCBrack + +pOptAttrs :: AGParser Attrs +pOptAttrs = pAttrs `opt` Attrs noPos [] [] [] + +pType :: AGParser Type +pType = NT <$> pIdentifierU + <|> Haskell <$> pCodescrap' "a type" + + +pInhAttrNames :: AGParser AttrNames +pInhAttrNames = (\vs tp -> map (\v -> (v,tp,("","",""))) vs) + <$> pIdentifiers <* pColon <*> pType "attribute declarations" + +pIdentifiers :: AGParser [Identifier] +pIdentifiers = pList1Sep pComma pIdentifier "lowercase identifiers" + + +pAttrNames :: AGParser AttrNames +pAttrNames = (\vs use tp -> map (\v -> (v,tp,use)) vs) + <$> pIdentifiers <*> pUse <* pColon <*> pType "attribute declarations" + +pUse :: AGParser (String,String,String) +pUse = ( (\u x y->(x,y,show u)) <$> pUSE <*> pCodescrap' <*> pCodescrap')` opt` ("","","") "USE declaration" + +pAlt :: AGParser Alt +pAlt = Alt <$> pBar <*> pSimpleConstructorSet <*> pFields "a datatype alternative" + +pAlts :: AGParser Alts +pAlts = pList_ng pAlt "datatype alternatives" + +pFields :: AGParser Fields +pFields = concat <$> pList_ng pField "fields" + +pField :: AGParser Fields +pField = (\nms tp -> map (flip (,) tp) nms) + <$> pIdentifiers <* pColon <*> pType + <|> (\s -> [(Ident (mklower (getName s)) (getPos s) ,NT s)]) <$> pIdentifierU + +mklower :: String -> String +mklower (x:xs) = toLower x : xs +mklower [] = [] + +pSemAlt :: AGParser SemAlt +pSemAlt = SemAlt + <$> pBar <*> pConstructorSet <*> pSemDefs "SEM alternative" + +pSimpleConstructorSet :: AGParser ConstructorSet +pSimpleConstructorSet = CName <$> pIdentifierU + <|> CAll <$ pStar + <|> pParens pConstructorSet + +pConstructorSet :: AGParser ConstructorSet +pConstructorSet = pChainl (CDifference <$ pMinus) term2 + where term2 = pChainr (pSucceed CUnion) term1 + term1 = CName <$> pIdentifierU + <|> CAll <$ pStar + + +pSemAlts :: AGParser SemAlts +pSemAlts = pList pSemAlt "SEM alternatives" + +pFieldIdentifier = pIdentifier + <|> Ident "lhs" <$> pLHS + <|> Ident "loc" <$> pLOC + <|> Ident "inst" <$> pINST + +pSemDef :: AGParser [SemDef] +pSemDef = (\x fs -> map ($ x) fs)<$> pFieldIdentifier <*> pList1 pAttrDef + <|> pLOC *> pList1 pLocDecl + <|> pINST *> pList1 pInstDecl + <|> pSEMPRAGMA *> pList1 (SemPragma <$> pNames) + <|> (\a b -> [AttrOrderBefore a b]) <$> pAttr <* pSmaller <*> pAttr + <|> (\pat owrt exp -> [Def (pat ()) exp owrt]) <$> pPattern (const <$> pAttr) <*> pAssign <*> pExpr + +pAttr = (,) <$> pFieldIdentifier <* pDot <*> pIdentifier + +pAttrDef :: AGParser (Name -> SemDef) +pAttrDef = (\pat owrt exp fld -> Def (pat fld) exp owrt) + <$ pDot <*> pattern <*> pAssign <*> pExpr + where pattern = pPattern pVar + <|> (\a fld -> Alias fld a (Underscore noPos) []) <$> pIdentifier + + +nl2sp :: Char -> Char +nl2sp '\n' = ' ' +nl2sp '\r' = ' ' +nl2sp x = x + +pLocDecl :: AGParser SemDef +pLocDecl = (\ident tp -> TypeDef ident tp) + <$ pDot <*> pIdentifier <* pColon <*> pLocType + +pLocType = (Haskell . getName) <$> pIdentifierU + <|> Haskell <$> pCodescrap' "a type" + +pInstDecl :: AGParser SemDef +pInstDecl = (\ident tp -> TypeDef ident tp) + <$ pDot <*> pIdentifier <* pColon <*> (NT <$> pIdentifierU) + +pSemDefs :: AGParser SemDefs +pSemDefs = concat <$> pList_ng pSemDef "attribute rules" + +pVar :: AGParser (Name -> (Name, Name)) +pVar = (\att fld -> (fld,att)) <$> pIdentifier + + +pExpr :: AGParser Expression +pExpr = (\(str,pos) -> Expression pos str) <$> ( pCodescrapL ) "an expression" + +pAssign :: AGParser Bool +pAssign = False <$ pReserved "=" + <|> True <$ pReserved ":=" + +pAttrDefs :: AGParser (Name -> [SemDef]) +pAttrDefs = (\fs field -> map ($ field) fs) <$> pList1 pAttrDef "attribute definitions" + +pPattern :: AGParser (a -> (Name,Name)) -> AGParser (a -> Pattern) +pPattern pvar = pPattern2 where + pPattern0 = (\i pats a -> Constr i (map ($ a) pats)) + <$> pIdentifierU <*> pList pPattern1 + <|> pPattern1 "a pattern" + pPattern1 = pvariable + <|> pPattern2 + pvariable = (\var pat a -> case var a of (fld,att) -> Alias fld att (pat a) []) + <$> pvar <*> ((pAt *> pPattern1) `opt` const (Underscore noPos)) + pPattern2 = (mkTuple <$> pOParenPos <*> pListSep pComma pPattern0 <* pCParen ) + <|> (const . Underscore) <$> pUScore "a pattern" + where mkTuple _ [x] a = x a + mkTuple p xs a = Product p (map ($ a) xs) + +pCostSym' c t = pCostSym c t t + +pCodescrap' :: AGParser String +pCodescrap' = fst <$> pCodescrap + +pCodescrap :: AGParser (String,Pos) +pCodescrap = pCodeBlock + +pSEM, pATTR, pDATA, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, + pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pArrow, + pDot, pUScore, pEXT,pAt,pStar, pSmaller, pWRAPPER, pMAYBE, pMODULE + :: AGParser Pos +pSET = pCostReserved 90 "SET" "SET" +pDERIVING = pCostReserved 90 "DERIVING" "DERIVING" +pWRAPPER = pCostReserved 90 "WRAPPER" "WRAPPER" +pPRAGMA = pCostReserved 90 "PRAGMA" "PRAGMA" +pSEMPRAGMA = pCostReserved 90 "SEMPRAGMA" "SEMPRAGMA" +pDATA = pCostReserved 90 "DATA" "DATA" +pEXT = pCostReserved 90 "EXT" "EXT" +pATTR = pCostReserved 90 "ATTR" "ATTR" +pSEM = pCostReserved 90 "SEM" "SEM" +pINCLUDE = pCostReserved 90 "INCLUDE" "INCLUDE" +pTYPE = pCostReserved 90 "TYPE" "TYPE" +pMAYBE = pCostReserved 5 "MAYBE" "MAYBE" +pUSE = pCostReserved 5 "USE" "USE" +pLOC = pCostReserved 5 "loc" "loc" +pLHS = pCostReserved 5 "lhs" "loc" +pINST = pCostReserved 5 "inst" "inst" +pAt = pCostReserved 5 "@" "@" +pDot = pCostReserved 5 "." "." +pUScore = pCostReserved 5 "_" "_" +pColon = pCostReserved 5 ":" ":" +pEquals = pCostReserved 5 "=" "=" +pColonEquals = pCostReserved 5 ":=" ":=" +pBar = pCostReserved 5 "|" "|" +pIntersect = pCostReserved 5 "/\\" "/\\" +pMinus = pCostReserved 5 "-" "-" +pArrow = pCostReserved 5 "->" "->" +pStar = pCostReserved 5 "*" "*" +pSmaller = pCostReserved 5 "<" "<" +pMODULE = pCostReserved 5 "MODULE" "MODULE" + diff --git a/src/Pretty.hs b/src/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Pretty.hs @@ -0,0 +1,151 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +-- Layer on top of the original UU.Pretty class +module Pretty + ( (>|<) + , (>-<) + , (>#<) + , text + , empty + , indent + , pp_block + , hlist + , vlist + , vlist_sep + , fill + , pp_parens + , hv_sp + , ppWithLineNr + , disp + , PP_Doc + , PP (..) + ) where + +import qualified UU.Pretty as U +import Data.List(intersperse) + + +-- +-- Type classes and data types that mimic UU.Pretty +-- + +class Show a => PP a where + pp :: a -> PP_Doc + pp = text . show + + ppList :: [a] -> PP_Doc + ppList as = if null as + then empty + else foldr (>|<) empty . map pp $ as + +instance PP PP_Doc where + pp = id + +instance Show PP_Doc where + show (PP_Doc f) = let (doc, _, _) = f 1 + in show doc + +instance PP String where + pp = text + +instance PP Char where + pp = text . (\c -> [c]) + + +newtype PP_Doc = PP_Doc (Int -> (U.PP_Doc, Int, Bool)) + +fromInternal :: PP a => a -> Int -> (U.PP_Doc, Int, Bool) +fromInternal x l + = let (PP_Doc f) = pp x + in f l + + +-- +-- Layer on top of primitive combinators +-- + +infixr 3 >|< +infixr 2 >-< +infixr 3 >#< + +(>|<) :: (PP a, PP b) => a -> b -> PP_Doc +x >|< y + = PP_Doc $ + \l -> let (p, n, s) = fromInternal x l + (q, m, t) = fromInternal y n + in (p U.>|< q, m, s && t) + +(>-<) :: (PP a, PP b) => a -> b -> PP_Doc +x >-< y + = PP_Doc $ + \l -> let (p, n, s) = fromInternal x l + (q, m, t) = fromInternal y (if s then n else n+1) + in (p U.>-< q, if t then m-1 else m, s && t) + +text :: String -> PP_Doc +text s + = let ls = lines s + ls' | null ls = [""] + | otherwise = ls + in vlist (map ppLine ls') + where + ppLine txt + = PP_Doc $ + \l -> (U.text txt, l, False) + +empty :: PP_Doc +empty + = PP_Doc $ + \l -> (U.empty, l, True) + + +-- +-- Layer on top of the higher-level combinators +-- (shameless copy of their definition) +-- + +(>#<) :: (PP a, PP b) => a -> b -> PP_Doc +l >#< r = l >|< " " >|< r + +hlist :: PP a => [a] -> PP_Doc +hlist = foldr (>|<) empty + +vlist :: PP a => [a] -> PP_Doc +vlist = foldr (>-<) empty + +vlist_sep :: (PP a, PP b) => a -> [b] -> PP_Doc +vlist_sep sep lst + = vlist (intersperse (pp sep) (map pp lst)) + +pp_block:: (PP a, PP b, PP c) => a -> b -> c -> [PP_Doc] -> PP_Doc +pp_block o c s as = pp o >|< hlist (intersperse (pp s) as) >|< pp c + +pp_parens :: PP a => a -> PP_Doc +pp_parens p = '(' >|< p >|< ')' + + +-- +-- Layer on top of the higher-level "smart" combinators +-- (dump alternative implementation) +-- + +indent :: PP a => Int -> a -> PP_Doc +indent n p = foldr (>#<) (pp p) (replicate n empty) + +fill :: PP a => [a] -> PP_Doc +fill = foldr (>#<) empty + +hv_sp :: PP a => [a] -> PP_Doc +hv_sp = foldr (>#<) empty + + +-- Special combinator that exposes the line number +ppWithLineNr :: (Int -> PP_Doc) -> PP_Doc +ppWithLineNr f + = PP_Doc $ + \l -> fromInternal (f l) l + +-- Render function +disp :: PP a => a -> Int -> String -> String +disp p n = let (doc, _, _) = fromInternal (pp p) 1 + in U.disp doc n + diff --git a/src/Scanner.hs b/src/Scanner.hs new file mode 100644 --- /dev/null +++ b/src/Scanner.hs @@ -0,0 +1,192 @@ + +module Scanner where +import TokenDef +import UU.Scanner.Position +import UU.Scanner.Token +import UU.Parsing(InputState(..),Either'(..)) +import Maybe +import List +import Char +import UU.Scanner.GenToken + +data Input = Input !Pos String (Maybe (Token, Input)) + +instance InputState Input Token Pos where + splitStateE input@(Input _ _ next) = + case next of + Nothing -> Right' input + Just (s, rest) -> Left' s rest + splitState (Input _ _ next) = + case next of + Nothing -> error "splitState on empty input" + Just (s, rest) -> ( s, rest) + getPosition (Input pos _ next) = case next of + Just (s,_) -> position s + Nothing -> pos -- end of file + + +input :: Pos -> String -> Input +input pos inp = Input pos + inp + (case scan pos inp of + Nothing -> Nothing + Just (s,p,r) -> Just (s, input p r) + ) + +type Lexer s = Pos -> String -> Maybe (s,Pos,String) + +scan :: Lexer Token +scan p [] = Nothing +scan p ('-':'-':xs) = let (com,rest) = span (/= '\n') xs + in advc' (2+length com) p scan rest +scan p ('{':'-':xs) = advc' 2 p (ncomment scan) xs +scan p ('{' :xs) = advc' 1 p codescrap xs +scan p ('\CR':xs) = case xs of + '\LF':ys -> newl' p scanBeginOfLine ys --ms newline + _ -> newl' p scanBeginOfLine xs --mac newline +scan p ('\LF':xs) = newl' p scanBeginOfLine xs --unix newline +scan p (x:xs) | isSpace x = updPos' x p scan xs +scan p xs = Just (scan' xs) + where scan' ('.' :rs) = (reserved "." p, advc 1 p, rs) + scan' ('@' :rs) = (reserved "@" p, advc 1 p, rs) + scan' (',' :rs) = (reserved "," p, advc 1 p, rs) + scan' ('_' :rs) = (reserved "_" p, advc 1 p, rs) + scan' ('<' :rs) = (reserved "<" p, advc 1 p, rs) + scan' ('[' :rs) = (reserved "[" p, advc 1 p, rs) + scan' (']' :rs) = (reserved "]" p, advc 1 p, rs) + scan' ('(' :rs) = (reserved "(" p, advc 1 p, rs) + scan' (')' :rs) = (reserved ")" p, advc 1 p, rs) +-- scan' ('{' :rs) = (OBrace p, advc 1 p, rs) +-- scan' ('}' :rs) = (CBrace p, advc 1 p, rs) + + scan' ('\"' :rs) = let isOk c = c /= '"' && c /= '\n' + (str,rest) = span isOk rs + in if null rest || head rest /= '"' + then (errToken "unterminated string literal" p + , advc (1+length str) p,rest) + else (valueToken TkString str p, advc (2+length str) p, tail rest) + + scan' ('=' :rs) = (reserved "=" p, advc 1 p, rs) + scan' (':':'=':rs) = (reserved ":=" p, advc 2 p, rs) + + scan' (':' :rs) = (reserved ":" p, advc 1 p, rs) + scan' ('|' :rs) = (reserved "|" p, advc 1 p, rs) + + scan' ('/':'\\':rs) = (reserved "/\\" p, advc 2 p, rs) + scan' ('-':'>' :rs) = (reserved "->" p, advc 2 p, rs) + scan' ('-' :rs) = (reserved "-" p, advc 1 p, rs) + scan' ('*' :rs) = (reserved "*" p, advc 1 p, rs) + + scan' (x:rs) | isLower x = let (var,rest) = ident rs + str = (x:var) + tok | str `elem` keywords = reserved str + | otherwise = valueToken TkVarid str + in (tok p, advc (length var+1) p, rest) + | isUpper x = let (var,rest) = ident rs + str = (x:var) + tok | str `elem` keywords = reserved str + | otherwise = valueToken TkConid str + in (tok p, advc (length var+1) p,rest) + | otherwise = (errToken ("unexpected character " ++ show x) p, advc 1 p, rs) + +scanBeginOfLine :: Lexer Token +scanBeginOfLine p ('{' : '-' : ' ' : 'L' : 'I' : 'N' : 'E' : ' ' : xs) + | isOkBegin rs && isOkEnd rs' + = scan (advc (8 + length r + 2 + length s + 4) p') (drop 4 rs') + | otherwise + = Just (errToken ("Invalid LINE pragma: " ++ show r) p, advc 8 p, xs) + where + (r,rs) = span isDigit xs + (s, rs') = span (/= '"') (drop 2 rs) + p' = Pos (read r - 1) (column p) s -- LINE pragma indicates the line number of the /next/ line! + + isOkBegin (' ' : '"' : _) = True + isOkBegin _ = False + + isOkEnd ('"' : ' ' : '-' : '}' : _) = True + isOkEnd _ = False +scanBeginOfLine p xs + = scan p xs + + +ident = span isValid + where isValid x = isAlphaNum x || x =='_' || x == '\'' +keywords = [ "DATA", "EXT", "ATTR", "SEM","TYPE", "USE", "loc","lhs", "inst", "INCLUDE" + , "SET","DERIVING","FOR", "WRAPPER", "MAYBE" + , "PRAGMA", "SEMPRAGMA", "MODULE" + ] + +ncomment c p ('-':'}':xs) = advc' 2 p c xs +ncomment c p ('{':'-':xs) = advc' 2 p (ncomment (ncomment c)) xs +ncomment c p (x:xs) = updPos' x p (ncomment c) xs +ncomment c p [] = Just (errToken "unterminated nested comment" p, p,[]) + +codescrap p xs = let (p2,xs2,sc) = codescrap' 1 p xs + in case xs2 of + ('}':rest) -> Just (valueToken TkTextln sc p,advc 1 p2,rest) + _ -> Just (errToken "unterminated codescrap" p,p2,xs2) + + +codescrap' d p [] = (p,[],[]) +{- +codescrap' d p ('{':'{':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs + in (p2,xs2,'{':' ':sc) +codescrap' d p ('}':'}':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs + in (p2,xs2,'}':' ':sc) +-} +codescrap' d p ('{':xs) = let (p2,xs2,sc) = advc' 1 p (codescrap' (d+1)) xs + in (p2,xs2,'{' : sc) +codescrap' d p ('}':xs) | d == 1 = (p,'}':xs,[]) + | otherwise = let (p2,xs2,sc) = advc' 1 p (codescrap' (d-1)) xs + in (p2,xs2,'}' : sc) +codescrap' d p (x :xs) = let (p2,xs2,sc) = updPos' x p (codescrap' d) xs + in (p2,xs2,x:sc) +--Literate Mode +scanLit xs = (fs, foldr insNL (const "") codeLns 1) + where insNL (n,line) rec = \n1 -> replicate (n-n1) '\n' ++ line ++ rec n + (fs,codeLns,_) = getBlocks ([1..] `zip` toLines xs) + getBlocks [] = ([],[],[]) + getBlocks xs = let (files1,txt1,r1) = getBlock xs + (files2,txt2,r2) = getBlocks r1 + in (files1++files2, txt1++txt2, r2) + + + getBlock = getLines . dropWhile comment + getLines [] = ([],[],[]) + getLines ((n,l):ls) | "\\begin{code}" `isPrefixOf` l = let (lns,rest) = codelines ls + in ([],lns,rest) + | "\\begin{Code}" `isPrefixOf` l = let (lns,rest) = codeLines ls + in ([],lns,rest) + | "\\IN{" `isPrefixOf` l = + let name = getName l + in ([name],[],ls) + | otherwise = getBlock ls + comment = not . ("\\" `isPrefixOf`) .snd + +toLines :: String -> [String] +toLines "" = [] +toLines s = let (l,s') = breakLine s + in l : toLines s' +breakLine xs = case xs of + '\CR' : ys -> case ys of + '\LF' : zs -> ([],zs) + _ -> ([],ys) + '\LF' : ys -> ([], ys) + x : ys -> let (l,s) = breakLine ys + in (x:l,s) + [] -> ([],[]) + +codelines [] = error "Unterminated literate code block" +codelines ((n,l):ls) | "\\end{code}" `isPrefixOf` l = ([],ls) + | otherwise = let (lns,r) = codelines ls + in ((n,l):lns,r) + +codeLines [] = error "Unterminated literate Code block" +codeLines ((n,l):ls) | "\\end{Code}" `isPrefixOf` l = ([],ls) + | otherwise = let (lns,r) = codeLines ls + in ((n,l):lns,r) + +getName l = case r of + ('}':_) -> nm + _ -> error $ "missing '}' in \\IN" + where (nm,r) = span (/='}') (drop 4 l) diff --git a/src/SequentialComputation.lhs b/src/SequentialComputation.lhs new file mode 100644 --- /dev/null +++ b/src/SequentialComputation.lhs @@ -0,0 +1,394 @@ +\begin{code} +module SequentialComputation (computeSequential,Vertex,Edge,Table) where +import SequentialTypes +import CommonTypes +import Interfaces +import InterfacesRules +import CodeSyntax +import GrammarInfo + +import Debug.Trace +import Control.Monad(liftM,when,unless) +import Control.Monad.ST(ST, runST) +import Data.Array(Array,(!),bounds,elems) +import Data.Array.ST(STArray, newArray, readArray, writeArray, freeze) +import Data.Maybe(listToMaybe,mapMaybe,isJust,fromJust) +import Data.List(partition,nub,(\\),delete,minimumBy) +import qualified Data.Set as Set +import qualified Data.Map as Map + +\end{code} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Collecting information} + +In the Data.Graph library, +a graph is represented as |Array Vertex [Vertex]|, +mapping each vertex to a list of adjacent vertices. +A |Vertex| is simply encoded by an |Int|. +So to test whether an edge |(x,y)| belongs to |g| +we can evaluate |y `elem` g!x| + +For more efficiency, we use Maps instead of lists. +Sets would also have done, but we also want to each edge to have a path as a witness. + +Moreover, as we will mostly be adding edges to the graph, +we use a mutable array. +If we want to use any of the library +functions, we can convert our representation by |fmap Map.keys . freeze|. + +\begin{code} +type Graph = Array Vertex [Vertex] +type MGraph = Array Vertex (Map.Map Vertex Path) +type MMGraph s = STArray s Vertex (Map.Map Vertex Path) + +singleStep :: (Vertex->Vertex->PathStep) -> Edge -> EdgePath +singleStep f e@(s,t) = (e, [f s t]) + +\end{code} + +We can add an edge to a graph, or remove it. These functions return +whether they did something (resp. addition or removal) or not. hasEdge +only checks whether a graph contains an edge or not. + +\begin{code} +addEdge :: MMGraph s -> EdgePath -> ST s Bool +addEdge graph ((s,t),p) + = do m <- readArray graph s + let b = not (Map.member t m) + when b (writeArray graph s (Map.insert t p m)) + return b + +hasEdge :: MMGraph s -> EdgePath -> ST s Bool +hasEdge graph ((s,t),_) + = do m <- readArray graph s + return (Map.member t m) +\end{code} + +The first step is to assign a number to all attributes, and a +different one to all attribute occurrences. We create an array mapping +the numbers to the information about the attribute occurrences +(|ruleTable|), so we can look up this information in $O(1)$ time. We +also build mappings from attributes to their occurrences (|tdsToTdp|) +and vice versa (|tdpToTds|). |LMH| indicates the division of the +attributes - an element |(l,m,h) `elem` LMH| means that vertices |i, l +<= i <= h| are attributes of the same nonterminal, with vertices |j, l +<= j < m| being inherited and |k, m <= k <= h| being synthesized +attributes. + +See the |SequentialTypes.Info| and |SequentialTypes.LMH| + +Then we collect the direct dependencies, using the integer +representations. This list of tuples (edges in the dependency graph) +all information that is collected is passed to a function that will +compute the interfaces and visit sub-sequences. We cannot do this +computation in AG, because mutable arrays require the ST monad, which +cannot be used inside AG. + +Now we can build a graph for attributes, and a graph for ao's, and add +the direct dependencies to the ao graph. Like Pennings we will call +the attribte graph Tds (transitive dependencies of symbols), and the +ao-graph Tdp (transitive dependencies of productions). Unlike him, we +will have only one Tds and one Tdp graph. In |STGraph|, we can lookup +outgoing edges in |O(1)| time, but looking up incoming edges will take +|O(e)| time, where |e| is the number of edges in the graph. As we will +be doing this quite often it is worthwhile to keep both Tdp and its +transposed version. The computation will involve both Tds and Tdp. It +treats specially. TODO elaborate on that. + +\begin{code} +type Tdp s = (MMGraph s, MMGraph s) +type Tds s = MMGraph s +type Comp s = (Tds s, Tdp s) +\end{code} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Generating IDS} + +As we insert edges into Tdp we keep it transitively closed, so every +time we add the edge $(s,t)$ to V, we also add the edges +$\{ (r,t) || (r,s) \in V \}$ and +$\{ (s,u) || (t,u) \in V \}$. + +\begin{code} +insertTdp :: Info -> Comp s -> EdgePath -> ST s () +insertTdp info comp@(_,(tdpN,tdpT)) e@((s,t),ee) -- how to insert an edge (s,t): + = do b <- hasEdge tdpN e -- if it's not yet present + unless b + (do rs <- readArray tdpT s -- find all sources r for an edge to s + us <- readArray tdpN t -- find all targets u for an edge from t + let edges = e :[ ((r,t),er++ee ) | (r,er) <- Map.toList rs ] + ++ [ ((s,u), ee++eu) | (u,eu) <- Map.toList us ] + ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ] + mapM_ (addTdpEdge info comp) edges -- and add all of them, without having to bother about transitive closure anymore + ) +\end{code} + +Edges in |Tdp| can induce edges in |Tds|, so whenever we add +an edge, we also add the induced edge if necessary + +\begin{code} +addTdpEdge :: Info -> Comp s -> EdgePath -> ST s () -- how to add an edge (s,t) when not having to bother about the transitive closure: +addTdpEdge info comp@(_,(tdpN,tdpT)) e@((s,t),ee) + = do b <- addEdge tdpN e -- add it to the normal graph + when b -- if it was a new edge + (do addEdge tdpT ((t,s),ee) -- also add it to the transposed graph + let u = tdpToTds info ! s -- find the corresponding attributes... + v = tdpToTds info ! t + nonlocal = u /= -1 && v /= -1 + equalfield = isEqualField (ruleTable info ! s) (ruleTable info ! t) + when (nonlocal && equalfield) -- ...and when necessary... + (insertTds info comp ((u,v),ee)) -- ...insert it to the Tds graph + ) +\end{code} + +Inserting edges into |Tds| will insert edges between the occurrences +of the attributes into |Tdp|. + +\begin{code} +insertTds :: Info -> Comp s -> EdgePath -> ST s () +insertTds info comp@(tds,_) e@((u,v),ee) + = do b <- addEdge tds e + when b + (mapM_ (insertTdp info comp) [ ( (s,t), [AttrStep u v] ) + | s <- tdsToTdp info ! u + , not (getIsIn (ruleTable info ! s)) -- inherited at LHS, or synthesized at RHS + , t <- tdsToTdp info ! v + , getIsIn (ruleTable info ! t) -- synthesized at LHS, or inherited at RHS + , isEqualField (ruleTable info ! s) (ruleTable info ! t) + ] + ) + +\end{code} + +If we add the direct dependencies to the Tdp graph in the way above, the +Tds graph is filled with IDS. +Below is a way to only build up the Tdp graph, without reflect the changes in the Tds graph. + +\begin{code} +simpleInsert :: Tdp s -> EdgePath -> ST s () +simpleInsert tdp@(tdpN,tdpT) e@((s,t),ee) + = do b <- hasEdge tdpT ((t,s),undefined) + unless b (do rs <- readArray tdpT s + us <- readArray tdpN t + let edges = e :[ ((r,t),er++ee ) | (r,er) <- Map.toList rs ] + ++ [ ((s,u), ee++eu) | (u,eu) <- Map.toList us ] + ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ] + mapM_ (addSimpleEdge tdp) edges + ) + +addSimpleEdge :: Tdp s -> EdgePath -> ST s () +addSimpleEdge (tdpN,tdpT) e@((s,t),ee) + = do b <- addEdge tdpN e + when b (do addEdge tdpT ((t,s),ee) + return () + ) +\end{code} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Interfaces} + +In absence of cycles we can find the interfaces. We only take +attributes that are used. + +When an attribute has no incoming edges it can be computed. As the +emphasis is on incoming edges, we will work with the transposed Tds +graph. The funtion |used| indicates which vertices are included in the +interfaces. + +See modules Interfaces and InterfacesRules for more information. + +%format sem_IRoot_IRoot = "sem_{IRoot}" +%format sem_Interface_Interface = "sem_{Interface}" +%format sem_Interfaces_Cons = ":_{Interfaces}" +%format sem_Interfaces_Nil = "[]_{Interfaces}" +%format sem_Segments_Cons = ":_{Segments}" +%format sem_Segments_Nil = "[]_{Segments}" + +\begin{code} +makeInterfaces :: Info -> Graph -> T_IRoot +makeInterfaces info tds + = let interslist = reverse . makeInterface tds [] + mkSegments = foldr (sem_Segments_Cons . uncurry sem_Segment_Segment) sem_Segments_Nil . interslist + mkInter ((nt,cons),lmh) = sem_Interface_Interface nt cons (mkSegments lmh) + inters = foldr (sem_Interfaces_Cons . mkInter) sem_Interfaces_Nil (zip (prods info) (lmh info)) + in sem_IRoot_IRoot inters +\end{code} + +The sinks of a graph are those vertices that have no outgoing +edges. We define a function that determines whether a vertex is a sink +if a set |del| of vertices had been removed from the graph. This means +that the attribute can be computed if all attributes in |del| have +been computed. + +\begin{code} +isSink :: Graph -> [Vertex] -> Vertex -> Bool +isSink graph del v = null (graph ! v \\ del) +\end{code} + +Now we can make interfaces by taking inherited sinks and synthesized +sinks alternatively. If there are no synthesized attributes at all, +generate an interface with one visit computing nothing. + +\begin{code} +makeInterface :: Graph -> [Vertex] -> LMH -> [([Vertex],[Vertex])] +makeInterface tds del (l,m,h) + | m > h = [([],[])] + | otherwise = let syn = filter (isSink tds del) ([m..h] \\ del) + del' = del ++ syn + inh = filter (isSink tds del') ([l..(m-1)] \\ del') + del'' = del' ++ inh + rest = makeInterface tds del'' (l,m,h) + in if null inh && null syn + then [] + else (inh,syn) : rest +\end{code} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Detecting of cycles} + +We only want to return s2i edges. + +\begin{code} +findCycles :: Info -> MGraph -> [EdgePaths] +findCycles info tds + = [ ((u,v),p1,p2) + | (l,m,h) <- lmh info -- for every nonterminal: [l..m-1] are inherited, [m..h] are synthesized + , v <- [m..h] -- for every synthesized attribute + , (u,p1) <- Map.toList (tds ! v) -- find dependent attributes... + , l <= u, u < m -- ...that are inherited... + , let mbp2 = Map.lookup v (tds ! u) -- ...and have a cycle back + , isJust mbp2 + , let p2 = fromJust mbp2 + ] + +findLocCycles :: MGraph -> [EdgePath] +findLocCycles tdp + = let (low, high) = bounds tdp + in [ ((u,u),p) + | u <- [low..high] + , (v,p) <- Map.toList (tdp ! u) + , v==u + ] + +findInstCycles :: [Edge] -> MGraph -> [EdgePath] +findInstCycles instToSynEdges tdp + = [ ((i,s), fromJust mbp) + | (i, s) <- instToSynEdges + , let mbp = Map.lookup i (tdp ! s) + , isJust mbp + ] +\end{code} + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Tying it together} + +\begin{code} +generateVisits :: Info -> MGraph -> MGraph -> [Edge] -> (CInterfaceMap, CVisitsMap, [Edge]) +generateVisits info tds tdp dpr + = let inters = makeInterfaces info (fmap Map.keys tds) + inhs = Inh_IRoot{ info_Inh_IRoot = info + , tdp_Inh_IRoot = fmap Map.keys tdp + , dpr_Inh_IRoot = dpr + } + iroot = wrap_IRoot inters inhs + in (inters_Syn_IRoot iroot, visits_Syn_IRoot iroot, edp_Syn_IRoot iroot) + +reportLocalCycle :: MGraph -> [EdgePath] -> [[Vertex]] +reportLocalCycle tds cyc + = fst (foldr f ([],Set.empty) (map (edgePathToEdgeRoute tds) cyc)) + where f ((x,_),p) res@(paths,syms) | Set.member x syms = res -- don't report a cyclic vertex if it appears on a path of an earlier reported one + | otherwise = (p:paths, Set.union syms (Set.fromList p)) + +reportCycle :: Info -> MGraph -> [EdgePaths] -> [EdgeRoutes] +reportCycle info tds cyc + = fst (foldr f ([],Set.empty) (map (edgePathsToEdgeRoutes tds) cyc)) + where f epp@((x,y),p1,p2) res@(paths,syms) | Set.member x syms && + Set.member y syms = res -- don't report mutually dependent vertices if both appear on paths reported earlier + | otherwise = (epp:paths, Set.union syms (Set.fromList (map tdp2tds (p1++p2)))) + tdp2tds (-2) = -2 + tdp2tds v = tdpToTds info ! v + +edgePathsToEdgeRoutes :: MGraph -> EdgePaths -> EdgeRoutes +edgePathsToEdgeRoutes tds (e,p1,p2) = ( e, pathToRoute tds p1, pathToRoute tds p2 ) + +edgePathToEdgeRoute :: MGraph -> EdgePath -> EdgeRoute +edgePathToEdgeRoute tds (e,p) = ( e, pathToRoute tds p ) + +pathToRoute :: MGraph -> Path -> Route +pathToRoute tds p = convertPath (expandAll p) + where expandAll :: Path -> Path + expandAll p | hasAttrStep p = expandAll (expandOne p) + | otherwise = p + expandOne :: Path -> Path + expandOne p = shortcut (concatMap expandStep p) + expandStep :: PathStep -> Path + expandStep (AttrStep u v) = fromJust (Map.lookup v (tds!u)) + expandStep x = [x] + convertPath :: Path -> Route + convertPath p = concatMap convertStep p + convertStep :: PathStep -> Route + convertStep (AtOcStep s t) = [s,t] + convertStep (AttrIndu s t) = [-2,-2] + +hasAttrStep :: Path -> Bool +hasAttrStep [] = False +hasAttrStep (AttrStep _ _ : _ ) = True +hasAttrStep (_ : xs) = hasAttrStep xs + +shortcut :: Eq a => [a] -> [a] +shortcut [] = [] +shortcut (x:xs) = x : shortcut (removeBefore x xs) + +removeBefore :: Eq a => a -> [a] -> [a] +removeBefore x ys = reverse (takeWhile (/=x) (reverse ys)) + + +isLocLoc :: Table CRule -> EdgePath -> Bool +isLocLoc rt ((s,t),_) = isLocal (rt ! s) && isLocal (rt ! t) + -- || (isInst (rt ! s) && isInst (rt ! t)) + +computeSequential :: Info -> [Edge] -> [Edge] -> CycleStatus +computeSequential info dpr instToSynEdges + = runST + (do let bigBounds = bounds (tdpToTds info) + smallBounds = bounds (tdsToTdp info) + (ll,es) = partition (isLocLoc (ruleTable info)) (map (singleStep AtOcStep) (dpr ++ instToSynEdges)) + tds <- newArray smallBounds Map.empty + tdpN <- newArray bigBounds Map.empty + tdpT <- newArray bigBounds Map.empty + let tdp = (tdpN,tdpT) + comp = (tds,tdp) + mapM_ (simpleInsert tdp) ll -- insert the local dependencies + tdp1 <- freeze tdpN + let cyc1 = findLocCycles tdp1 + if not (null cyc1) -- are they cyclic? + then do return (LocalCycle (reportLocalCycle undefined cyc1)) -- then report an error. + else do mapM_ (insertTdp info comp) es -- insert the other dependencies + tds2 <- freeze tds + let cyc2 = findCycles info tds2 + if not (null cyc2) -- are they cyclic? + then do return (DirectCycle (reportCycle info tds2 cyc2)) -- then report an error. + else do tdp2 <- freeze tdpN + let cyc4 = findInstCycles instToSynEdges tdp2 + if not (null cyc4) + then do return (InstCycle (reportLocalCycle tds2 cyc4)) -- then report an error. + else do let (cim,cvm,edp) = generateVisits info tds2 tdp2 dpr + mapM_ (insertTds info comp) (map (singleStep AttrIndu) edp) -- insert dependencies induced by visit scheduling + tds3 <- freeze tds + let cyc3 = findCycles info tds3 + if not (null cyc3) -- are they cyclic? + then return (InducedCycle cim (reportCycle info tds3 cyc3)) -- then report an error. + else do tdp3 <- freeze tdpN + let cyc5 = findInstCycles instToSynEdges tdp3 + if not (null cyc5) + then do return (InstCycle (reportLocalCycle tds3 cyc5)) -- then report an error. + else do return (CycleFree cim cvm) -- otherwise we succeed. + ) +\end{code} + + +\end{document} diff --git a/src/SequentialTypes.hs b/src/SequentialTypes.hs new file mode 100644 --- /dev/null +++ b/src/SequentialTypes.hs @@ -0,0 +1,137 @@ +module SequentialTypes where + +import CodeSyntax +import CommonTypes +import Data.Array(Array) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Maybe(fromJust) +import Data.List(partition) +import UU.Pretty + + +type Vertex = Int +data PathStep = AttrStep Vertex Vertex + | AtOcStep Vertex Vertex + | AttrIndu Vertex Vertex + deriving (Show, Eq) + +type Path = [PathStep] +type Route = [Vertex] + +type Edge = (Int,Int) +type EdgePath = (Edge,Path) +type EdgePaths = (Edge,Path,Path) +type EdgeRoute = (Edge,Route) +type EdgeRoutes= (Edge,Route,Route) + +type Table a = Array Vertex a + + +data ChildVisit = ChildVisit Name Name Int [Vertex] [Vertex] deriving (Eq,Show) -- field, rhs nt, visit nr., inh, syn +data NTAttr = NTAInh Nonterminal Name Type -- nt, attribute, type + | NTASyn Nonterminal Name Type -- nt, attribute, type + deriving Show + +getNtaNameType (NTAInh nt name tp) = (name,tp) +getNtaNameType (NTASyn nt name tp) = (name,tp) + +getAttr (CRule name ii hc nt con field childnt tp pattern rhs defines owrt origin uses) = name +getIsIn (CRule name ii hc nt con field childnt tp pattern rhs defines owrt origin uses) = ii +getHasCode (CRule name ii hc nt con field childnt tp pattern rhs defines owrt origin uses) = hc +getLhsNt (CRule name ii hc nt con field childnt tp pattern rhs defines owrt origin uses) = nt +getCon (CRule name ii hc nt con field childnt tp pattern rhs defines owrt origin uses) = con +getField (CRule name ii hc nt con field childnt tp pattern rhs defines owrt origin uses) = field +getRhsNt (CRule name ii hc nt con field childnt tp pattern rhs defines owrt origin uses) = childnt +getType (CRule name ii hc nt con field childnt tp pattern rhs defines owrt origin uses) = tp +getDefines (CRule name ii hc nt con field childnt tp pattern rhs defines owrt origin uses) = defines +getUses (CRule name ii hc nt con field childnt tp pattern rhs defines owrt origin uses) = uses + +isLocal = (_LOC==) . getField +isInst = (_INST==) . getField +isLhs = (_LHS==) . getField +isRhs cr = not (isLhs cr || isLocal cr) +isSyn cr | isLocal cr = False + | getIsIn cr = isRhs cr + | otherwise = isLhs cr +isInh = not . isSyn +hasCode cr = isLocal cr || (isLhs cr && isInh cr) || (isRhs cr && isSyn cr) + +isEqualField a b = isEqualCon a b && getField a == getField b +isDifferentField a b = isEqualCon a b && getField a /= getField b +isEqualCon a b = getLhsNt a == getLhsNt b && getCon a == getCon b +isRhsOfSameCon a b = isEqualCon a b && isRhs a && isRhs b + +isSynAttr (NTAInh _ _ _) = False +isSynAttr (NTASyn _ _ _) = True +isInhAttr = not . isSynAttr + +ntattr :: CRule -> Maybe NTAttr +ntattr cr | isLocal cr = Nothing + | isInst cr = Nothing -- an inst definition is just considered as a local attribute definition + | otherwise = let at = if isSyn cr then NTASyn else NTAInh + getNt cr = if isRhs cr then fromJust (getRhsNt cr) else getLhsNt cr + in Just (at (getNt cr) (getAttr cr) (fromJust (getType cr))) + +cRuleLhsInh :: Name -> Nonterminal -> Constructor -> Type -> CRule +cRuleLhsInh attr nt con tp = CRule attr True False nt con _LHS Nothing (Just tp) (error "cRuleLhsInh") [] Map.empty False "" Set.empty +cRuleTerminal :: Name -> Nonterminal -> Constructor -> Type -> CRule +cRuleTerminal attr nt con tp = CRule attr True False nt con _LOC Nothing (Just tp) (error ("cRuleTerminal: " ++ show (attr, nt, con, tp))) [] Map.empty False "" Set.empty +cRuleRhsSyn :: Name -> Nonterminal -> Constructor -> Type -> Name -> Nonterminal -> CRule +cRuleRhsSyn attr nt con tp field childnt = CRule attr True False nt con field (Just childnt) (Just tp) (error ("cRuleRhsSyn: " ++ show (attr, nt, con, tp, field))) [] Map.empty False "" Set.empty + +defaultRule :: Name -> Nonterminal -> Constructor -> Name -> CRule +defaultRule attr nt con field = CRule attr (er 1) (er 2) nt con field (er 3) (er 4) (er 5) (er 6) (er 7) (er 8) (er 9) (er 10) + where er i = error ("Default rule has no code " ++ show i) + +instance Eq CRule where + a == b = getAttr a == getAttr b && isEqualField a b +instance Ord CRule where + compare a b = compare (getLhsNt a) (getLhsNt b) + >/< compare (getCon a) (getCon b) + >/< compare (getField a) (getField b) + >/< compare (getAttr a) (getAttr b) +instance Eq NTAttr where + (NTAInh nt name _) == (NTASyn nt' name' _) = False + (NTASyn nt name _) == (NTAInh nt' name' _) = False + (NTAInh nt name _) == (NTAInh nt' name' _) = nt == nt' && name == name' + (NTASyn nt name _) == (NTASyn nt' name' _) = nt == nt' && name == name' +instance Ord NTAttr where + compare (NTAInh _ _ _) (NTASyn _ _ _) = LT + compare (NTASyn _ _ _) (NTAInh _ _ _) = GT + compare (NTAInh nt name _) (NTAInh nt' name' _) = compare nt nt' >/< compare name name' + compare (NTASyn nt name _) (NTASyn nt' name' _) = compare nt nt' >/< compare name name' + +eqCRuleDefines :: CRule -> CRule -> Bool +eqCRuleDefines a b + = Map.keys (getDefines a) == Map.keys (getDefines b) + +(>/<) :: Ordering -> Ordering -> Ordering +EQ >/< b = b +a >/< _ = a + + +eqClasses :: (a -> a -> Bool) -> [a] -> [[a]] +eqClasses p [] = [] +eqClasses p (a:as) = let (isA,rest) = partition (p a) as + in (a:isA):eqClasses p rest + +lhsshow (NTAInh field attr _) = lhsname True attr +lhsshow (NTASyn field attr _) = lhsname False attr + +rhsshow :: Name -> NTAttr -> String +rhsshow field (NTAInh _ attr _) = attrname False field attr +rhsshow field (NTASyn _ attr _) = attrname True field attr + +prettyCRule :: CRule -> String +prettyCRule cr + = let descr | isLocal cr = "local attribute " ++ show (getAttr cr) + | otherwise = (if isSyn cr then "synthesized " else "inherited ") + ++ "attribute " + ++ (if isRhs cr then show (getField cr) ++ "." else "") + ++ (if isLhs cr then "lhs." else "") + ++ (show (getAttr cr)) + in show (getLhsNt cr) ++ "." ++ show (getCon cr) ++ ", " ++ descr + diff --git a/src/Streaming.hs b/src/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Streaming.hs @@ -0,0 +1,107 @@ +module Streaming where + +import CommonTypes(Name) +import DepTypes +import List(partition) +import Maybe(fromMaybe,fromJust) + +mapp :: (a -> b) -> (a,a) -> (b,b) +mapp f (l,r) = (f l,f r) + +-- vervangt nub, bepaald wel de nub maar accumuleert tevens de causes +reduce :: [UsedAttr] -> [UsedAttr] +reduce set = red set [] where + red (res:rest) set' = red rest (r res set') + red [] set' = set' + r res [] = [res] + r (r1@(Loc f1 a1 c1)) ((r2@(Loc f2 a2 c2)):rest) = if f1==f2 && a1==a2 + then if length c1 < length c2 + then (Loc f2 a2 c1):rest + else r2:rest + else r2:(r r1 rest) + r (r1@(Glo a1 c1)) ((r2@(Glo a2 c2)):rest) = if a1==a2 + then if length c1 < length c2 + then (Glo a2 c1):rest + else r2:rest + else r2:(r r1 rest) + r (r1@(Loc f1 a1 c1)) ((r2@(Glo a2 c2)):rest) = r2:(r r1 rest) + r (r1@(Glo a1 c1)) ((r2@(Loc f2 a2 c2)):rest) = r2:(r r1 rest) + +-- NB: de rechter (update-) zijde van een streamelement is nooit bevat in de linker (set-) zijde!! +-- nieuwe update set (nu) is de concat van linker en rechter (lu & ru), maar met de al gevonden resultaten (ls' & rs') eruit gefilterd (lu' & ru'). +-- deze al gevonden resultaten kunnen onbekende causes bevatten, zijn worden daarom meegenomen in de reductie van de al gevonden resltaten (ls & rs). +-- deze resultaten zijn dus 100% zeker dubbel, maar worden meegenomen voor bepaling van de causes in het nieuwe resultaat +stUnion :: Stream -> Stream -> Stream +stUnion [] _ = [] +stUnion _ [] = [] +stUnion ((ls,lu):lr) ((rs,ru):rr) = (ns,nu):nr where + (lu',ls') = partition (flip notElem rs) lu + (ru',rs') = partition (flip notElem ls) ru + nu = lu' ++ ru' + ns = reduce (ls++ls'++rs++rs') + nr = stUnion lr rr + +{- +-- oude versie, met nub ipv reduce +stUnion :: Stream -> Stream -> Stream +stUnion [] _ = [] +stUnion _ [] = [] +stUnion ((xset,xupd):xrest) ((yset,yupd):yrest) = (nub (xset++yset),new):(stUnion xrest yrest) where + new = (filter (flip notElem yset) xupd) ++ (filter (flip notElem xset) yupd) +-} + +{- +-- de x wordt gebruikt om te kijken of de poort open staat, de y wordt doorgegeven als de poort openstaat +-- ouder versie, zonder kortste cause +stPort :: Name -> Stream -> Stream -> Stream +stPort attr ((xset,xupd):xrest) ((yset,yupd):yrest) = case lookup attr (map toPair xupd) of + Just causes -> addTrace causes (([],yset++yupd):yrest) + Nothing -> ([],[]):(stPort attr xrest yrest) +-} +-- de x wordt gebruikt om te kijken of de poort open staat, de y wordt doorgegeven als de poort openstaat +-- de recursieve aanroep van stPortRest wordt gedaan om in het uiteindelijke resultaat de kortste cause te krijgen +-- waarom de cause niet initiëel de kortste is, weet ik niet. Maar er worden wel kortere causes gevonden later in het proces +{- +stPort :: Name -> Stream -> Stream -> Stream +stPort attr ((xset,xupd):xrest) ((yset,yupd):yrest) = case lookup attr (map toPair xupd) of + Just causes -> (addTrace causes ([],yset++yupd)):(stPortRest attr xrest yrest) + Nothing -> ([],[]):(stPort attr xrest yrest) + where + stPortRest attr ((xset,xupd):xrest) (y:yrest) = case lookup attr (map toPair xset) of + Just causes -> (addTrace causes y):(stPortRest attr xrest yrest) + Nothing -> (error "Dit mag nooit gebeuren!" ([],[])):(stPortRest attr xrest yrest) +-} + + +-- 20 januari: herschrijving van bovenstaande versie in 1 functie (zonder where)... +stPort :: Name -> Stream -> Stream -> Stream +stPort attr ((xset,xupd):xrest) ((yset,yupd):yrest) = case lookup attr (map toPair xupd) of + Just causes -> (addTrace causes ([],yset++yupd)):(zipWith (\(xset,xupd) y -> addTrace (fromJust . lookup attr . map toPair $ xset) y) xrest yrest) + Nothing -> ([],[]):(stPort attr xrest yrest) + +-- stStart biedt geen functionaliteit voor een initiële cause, want er zijn geen initiële causes: +-- het begin van een stream is namelijk altijd een attribuut dat zichzelf bepaalt. Dat heeft geen oorzaak nodig. +stStart :: Name -> Name -> Stream +stStart field attr = first:(repeat other) where + first = ([],[Loc field attr []]) + other = ([Loc field attr []],[]) + +stEmpty :: Stream +stEmpty = repeat ([],[]) + +getStream :: Vertex -> [UseStream] -> Stream +getStream vertex streams = fromMaybe stEmpty (lookup vertex streams) + +stLocal2global :: Stream -> Stream +stLocal2global = map (mapp (map (\res -> Glo (getAttr res) (getTrace res)))) +-- de nub hoeft niet, want het filter op fieldname van een lokaal resultaat filtert doublures er al uit +--stLocal2global = map (mapp (nub . (map (\res -> Glo (getAttr res))))) + +stFilterInclSide :: UseStream -> Stream +stFilterInclSide (vertex,stream) = stFilterOnField ((getField vertex)==) stream + +stFilterExclSide :: UseStream -> Stream +stFilterExclSide (vertex,stream) = stFilterOnField ((getField vertex)/=) stream + +stFilterOnField :: (Name -> Bool) -> Stream -> Stream +stFilterOnField f = map (mapp (filter (f . getField))) diff --git a/src/TokenDef.hs b/src/TokenDef.hs new file mode 100644 --- /dev/null +++ b/src/TokenDef.hs @@ -0,0 +1,67 @@ + +module TokenDef where + +import UU.Scanner.Token +import UU.Scanner.GenToken +import UU.Scanner.GenTokenOrd +import UU.Scanner.Position +import UU.Parsing.MachineInterface(Symbol(..)) +import Char(isPrint,ord) + + + +instance Symbol Token where + deleteCost (Reserved key _) = case key of + "DATA" -> 7 + "EXT" -> 7 + "ATTR" -> 7 + "SEM" -> 7 + "USE" -> 7 + "INCLUDE" -> 7 + _ -> 5 + deleteCost (ValToken v _ _) = case v of + TkError -> 0 + _ -> 5 + + +showTokens :: [(Pos,String)] -> [String] +showTokens [] = [] +showTokens xs = map showLine . shiftLeft . getLines $ xs + +getLines [] = [] +getLines ((p,t):xs) = let (txs,rest) = span sameLine xs + sameLine (q,_) = line p == line q + in ((p,t):txs) : getLines rest + +shiftLeft lns = let sh = let m = minimum . checkEmpty . filter (>=1) . map (column.fst.head) $ lns + checkEmpty [] = [1] + checkEmpty x = x + in if m >= 1 then m-1 else 0 + shift (p,t) = (if column p >= 1 then case p of (Pos l c f) -> Pos l (c - sh) f else p, t) + in map (map shift) lns + +showLine ts = let f (p,t) r = let ct = column p + in \c -> spaces (ct-c) ++ t ++ r (length t+ct) + spaces x | x < 0 = "" + | otherwise = replicate x ' ' + in foldr f (const "") ts 1 + + +showStrShort xs = "\"" ++ concatMap f xs ++ "\"" + where f '"' = "\\\"" + f x = showCharShort' x + +showCharShort '\'' = "'" ++ "\\'" ++ "'" +showCharShort c = "'" ++ showCharShort' c ++ "'" + +showCharShort' '\a' = "\\a" +showCharShort' '\b' = "\\b" +showCharShort' '\t' = "\\t" +showCharShort' '\n' = "\\n" +showCharShort' '\r' = "\\r" +showCharShort' '\f' = "\\f" +showCharShort' '\v' = "\\v" +showCharShort' '\\' = "\\\\" +showCharShort' x | isPrint x = [x] + | otherwise = '\\' : show (ord x) + diff --git a/src/Version.hs b/src/Version.hs new file mode 100644 --- /dev/null +++ b/src/Version.hs @@ -0,0 +1,4 @@ +module Version where + +banner :: String +banner = "Attribute Grammar compiler / HUT project. Version 0.9.5" diff --git a/uuagc.cabal b/uuagc.cabal new file mode 100644 --- /dev/null +++ b/uuagc.cabal @@ -0,0 +1,64 @@ +cabal-version: >=1.2 +build-type: Simple +name: uuagc +version: 0.9.5 +license: GPL +license-file: LICENSE +maintainer: Arie Middelkoop +homepage: http://www.cs.uu.nl/wiki/HUT/WebHome +description: Generates Haskell files from an attribute grammar specification +synopsis: Attribute Grammar System of Universiteit Utrecht +category: Development +stability: Stable +copyright: Universiteit Utrecht +extra-source-files: README, uuagc.cabal-for-ghc-6.6 + +flag small_base + description: Choose the new smaller, split-up base package. +executable uuagc + if flag(small_base) + build-depends: base >= 3, containers, directory, array + else + build-depends: base < 3 + + build-depends: haskell98, uulib + main-is: Ag.hs + other-modules: Ag + , CommonTypes + , DepTypes + , GrammarInfo + , HsTokenScanner + , Options + , PPUtil + , Parser + , Pretty + , Scanner + , SequentialComputation + , SequentialTypes + , Streaming + , TokenDef + , Version + , AbstractSyntax + , AbstractSyntaxDump + , Code + , CodeSyntax + , CodeSyntaxDump + , ConcreteSyntax + , DeclBlocks + , DefaultRules + , Desugar + , ErrorMessages + , Expression + , GenerateCode + , HsToken + , Interfaces + , InterfacesRules + , Order + , Patterns + , PrintCode + , PrintErrorMessages + , SemHsTokens + , Transform + extensions: TypeSynonymInstances, MultiParamTypeClasses + hs-source-dirs: src, src-derived + diff --git a/uuagc.cabal-for-ghc-6.6 b/uuagc.cabal-for-ghc-6.6 new file mode 100644 --- /dev/null +++ b/uuagc.cabal-for-ghc-6.6 @@ -0,0 +1,47 @@ +name: uuagc +version: 0.9.5 +license: GPL +license-file: LICENSE +maintainer: Arie Middelkoop +Build-Depends: base, haskell98, uulib + +Executable: uuagc +Main-Is: Ag.hs +Other-Modules: Ag + , CommonTypes + , DepTypes + , GrammarInfo + , HsTokenScanner + , Options + , PPUtil + , Parser + , Pretty + , Scanner + , SequentialComputation + , SequentialTypes + , Streaming + , TokenDef + , Version + , AbstractSyntax + , AbstractSyntaxDump + , Code + , CodeSyntax + , CodeSyntaxDump + , ConcreteSyntax + , DeclBlocks + , DefaultRules + , Desugar + , ErrorMessages + , Expression + , GenerateCode + , HsToken + , Interfaces + , InterfacesRules + , Order + , Patterns + , PrintCode + , PrintErrorMessages + , SemHsTokens + , Transform +Extensions: TypeSynonymInstances, MultiParamTypeClasses +Hs-Source-Dirs: src, src-derived