AspectAG 0.3.6.1 → 0.5.0.0

raw patch · 40 files changed

+3176/−4425 lines, 40 filesdep +ghc-primdep +taggeddep +th-strict-compatdep −HListdep ~basedep ~containersdep ~mtlsetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-prim, tagged, th-strict-compat

Dependencies removed: HList

Dependency ranges changed: base, containers, mtl, template-haskell

API changes (from Hackage documentation)

Files

• AspectAG.cabal +149/−21
• COPYRIGHT +0/−28
• ChangeLog.md +5/−0
• LICENSE +674/−0
• LICENSE-LGPL +0/−507
• README +0/−38
• Setup.hs +0/−1
• examples/Expr.hs +95/−0
• examples/ExprExt.hs +184/−0
• examples/LangDef.hs +0/−115
• examples/LangExt.hs +0/−236
• examples/LangExt.old +0/−315
• examples/List.hs +128/−0
• examples/Main.hs +0/−111
• examples/RepminTH.lhs +117/−0
• examples/RepminTHExt.lhs +69/−0
• examples/calc.hs +0/−80
• examples/calcM.hs +0/−97
• examples/repmin.hs +0/−83
• examples/repminM.hs +0/−72
• examples/test1.hs +0/−107
• examples/test1TH.hs +0/−86
• examples/test2.hs +0/−123
• examples/test2TH.hs +0/−93
• examples/test3.hs +0/−115
• examples/test3TH.hs +0/−91
• examples/test4.hs +0/−94
• examples/test4TH.hs +0/−70
• examples/test5.hs +0/−117
• examples/test5TH.hs +0/−93
• examples/testEmptyNode.hs +0/−43
• examples/testList.hs +0/−48
• src/Language/Grammars/AspectAG.hs +655/−1357
• src/Language/Grammars/AspectAG/Derive.hs +0/−284
• src/Language/Grammars/AspectAG/GenRecord.hs +243/−0
• src/Language/Grammars/AspectAG/HList.hs +83/−0
• src/Language/Grammars/AspectAG/RecordInstances.hs +279/−0
• src/Language/Grammars/AspectAG/Require.hs +77/−0
• src/Language/Grammars/AspectAG/TH.hs +283/−0
• src/Language/Grammars/AspectAG/TPrelude.hs +135/−0

@@ -1,23 +1,151 @@-name:               AspectAG -version:            0.3.6.1-cabal-version:      >= 1.2.3  -license:            LGPL-license-file:       COPYRIGHT-maintainer:         Marcos Viera <mviera@fing.edu.uy>-homepage:           http://www.cs.uu.nl/wiki/bin/view/Center/AspectAG -description:        Library of strongly typed Attribute Grammars implemented using type-level programming   -synopsis:           Attribute Grammars in the form of an EDSL-build-type:         Simple-category:           Development -stability:          Experimental-copyright:          Universiteit Utrecht-extra-source-files: README, LICENSE-LGPL +-- Initial AspectAG.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/ +-- The name of the package.+name:                AspectAG++-- The package version.  See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- https://wiki.haskell.org/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.5.0.0++-- A short (one-line) description of the package.+synopsis:            Strongly typed Attribute Grammars implemented using type-level programming.++-- A longer description of the package.+description: An EDSL implementing strongly typed -and strongly kinded!- attribute grammars+             implemented using type-level programming. We make an effort to encode precise EDSL+             type errors.++-- URL for the project homepage or repository.+homepage:            www.fing.edu.uy/~jpgarcia/AspectAG++-- The license under which the package is released.+license:             GPL-3++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Juan García Garland, Marcos Viera++-- An email address to which users can send suggestions, bug reports, and+-- patches.+maintainer:          jpgarcia@fing.edu.uy++-- A copyright notice.+-- copyright:++category:            Language++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a+-- README.+extra-source-files:  ChangeLog.md,+                     LICENSE,+                     examples/ExprExt.hs,+                     examples/Expr.hs,+                     examples/List.hs,+                     examples/RepminTHExt.lhs,+                     examples/RepminTH.lhs++++--source-repository:+--    type: git+--    location: https://gitlab.fing.edu.uy/jpgarcia/attribute-grammars++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10++ library-        build-depends:      base>=4 && <5, template-haskell>=2.4.0.1, HList>=0.2.2, containers>=0.2.0.0, mtl>=1.1.0.2-        exposed-modules:    Language.Grammars.AspectAG, Language.Grammars.AspectAG.Derive-        extensions:         EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies,-                            MultiParamTypeClasses, RankNTypes, ScopedTypeVariables,-                            TypeSynonymInstances, UndecidableInstances, GADTs-        hs-source-dirs:     src -        ghc-options:        -Wall+  -- Modules exported by the library.+  exposed-modules:     Language.Grammars.AspectAG,+                       Language.Grammars.AspectAG.TH,+                       Language.Grammars.AspectAG.HList,+                       Language.Grammars.AspectAG.TPrelude,+                       Language.Grammars.AspectAG.GenRecord,+                       Language.Grammars.AspectAG.RecordInstances,+                       Language.Grammars.AspectAG.Require+  -- LANGUAGE extensions used by modules in this package.+  other-extensions:    TypeInType,+                       TypeFamilies,+                       FlexibleContexts,+                       ScopedTypeVariables,+                       NoMonomorphismRestriction,+                       AllowAmbiguousTypes,+                       ImplicitParams,+                       ExtendedDefaultRules,+                       UnicodeSyntax,+                       DataKinds,+                       GADTs,+                       KindSignatures,+                       TypeOperators,+                       MultiParamTypeClasses,+                       FlexibleInstances,+                       StandaloneDeriving,+                       UndecidableInstances,+                       FunctionalDependencies,+                       ConstraintKinds,+                       PolyKinds,+                       RankNTypes,+                       InstanceSigs++  -- Other library packages from which modules are imported.+  build-depends:       base >=4.11 && <4.13,+                       tagged >=0.8,+                       containers >= 0.5,+                       template-haskell >= 2.13,+                       th-strict-compat >= 0.1,+                       mtl >= 2.0,+                       ghc-prim >= 0.5+ ++  -- Directories containing source files.+  hs-source-dirs:      src, examples++  -- Base language which the package is written in.+  default-language:    Haskell2010++-- Test-Suite test-Repmin+--     type:             exitcode-stdio-1.0+--     main-is:          test/Repmin.hs+--     build-depends:    base >=4.11 && <4.12,+--                       tagged >=0.8 && <0.9,+--                       AspectAG >= 0.4,+--                       QuickCheck+--     default-language: Haskell2010++-- Test-Suite test-Repmin-TH+--     type:             exitcode-stdio-1.0+--     main-is:          test/RepminTH.hs+--     build-depends:    base >=4.11 && <4.12,+--                       tagged >=0.8 && <0.9,+--                       AspectAG >= 0.4,+--                       QuickCheck+--     default-language: Haskell2010+    +-- Test-Suite test-Arith+--     type:             exitcode-stdio-1.0+--     main-is:          test/Arith.hs+--     build-depends:    base >=4.11 && <4.12,+--                       containers >= 0.5,+--                       tagged >=0.8 && <0.9,+--                       AspectAG >= 0.4,+--                       QuickCheck+--     default-language: Haskell2010++-- Test-Suite test-Graphs+--     type:             exitcode-stdio-1.0+--     main-is:          test/Graphs.hs+--     build-depends:    base >=4.11 && <4.12,+--                       tagged >=0.8 && <0.9,+--                       AspectAG >= 0.4,+--                       containers >= 0.5,+--                       QuickCheck+--     default-language: Haskell2010

@@ -1,28 +0,0 @@-The AspectAG package is (c) copyright 2008-to the original authors and other contributors listed here.  If you add-or modify code, please add your name here.--Original authors:-        Marcos Viera-	Doaitse Swierstra-        Wouter Swierstra	-------The AspectAG package is licensed under the terms of the GNU Lesser General Public-Licence (LGPL), which can be found in the file called LICENCE-LGPL, with-the following special exception:--    As a relaxation of clause 6 of the LGPL, the copyright holders of this-    library give permission to use, copy, link, modify, and distribute,-    binary-only object-code versions of an executable linked with the-    original unmodified Library, without requiring the supply of any-    mechanism to modify or replace the Library and relink (clauses 6a,-    6b, 6c, 6d, 6e), provided that all the other terms of clause 6 are-    complied with.--This software 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-License for more details.--

@@ -0,0 +1,5 @@+# Revision history for AspectAG++## 0.4 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

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

@@ -1,507 +0,0 @@-                  GNU LESSER GENERAL PUBLIC LICENSE-                       Version 2.1, February 1999-- Copyright (C) 1991, 1999 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 Lesser GPL.  It also counts- as the successor of the GNU Library Public License, version 2, hence- the version number 2.1.]--                            Preamble--  The licenses for most software are designed to take away your-freedom to share and change it.  By contrast, the GNU General Public-Licenses are intended to guarantee your freedom to share and change-free software--to make sure the software is free for all its users.--  This license, the Lesser General Public License, applies to some-specially designated software packages--typically libraries--of the-Free Software Foundation and other authors who decide to use it.  You-can use it too, but we suggest you first think carefully about whether-this license or the ordinary General Public License is the better-strategy to use in any particular case, based on the explanations-below.--  When we speak of free software, we are referring to freedom of use,-not price.  Our General Public Licenses are designed to make sure that-you have the freedom to distribute copies of free software (and charge-for this service if you wish); that you receive source code or can get-it if you want it; that you can change the software and use pieces of-it in new free programs; and that you are informed that you can do-these things.--  To protect your rights, we need to make restrictions that forbid-distributors to deny you these rights or to ask you to surrender these-rights.  These restrictions translate to certain responsibilities for-you if you distribute copies of the library or if you modify it.--  For example, if you distribute copies of the library, whether gratis-or for a fee, you must give the recipients all the rights that we gave-you.  You must make sure that they, too, receive or can get the source-code.  If you link other code with the library, you must provide-complete object files to the recipients, so that they can relink them-with the library after making changes to the library and recompiling-it.  And you must show them these terms so they know their rights.--  We protect your rights with a two-step method: (1) we copyright the-library, and (2) we offer you this license, which gives you legal-permission to copy, distribute and/or modify the library.--  To protect each distributor, we want to make it very clear that-there is no warranty for the free library.  Also, if the library is-modified by someone else and passed on, the recipients should know-that what they have is not the original version, so that the original-author's reputation will not be affected by problems that might be-introduced by others.--  Finally, software patents pose a constant threat to the existence of-any free program.  We wish to make sure that a company cannot-effectively restrict the users of a free program by obtaining a-restrictive license from a patent holder.  Therefore, we insist that-any patent license obtained for a version of the library must be-consistent with the full freedom of use specified in this license.--  Most GNU software, including some libraries, is covered by the-ordinary GNU General Public License.  This license, the GNU Lesser-General Public License, applies to certain designated libraries, and-is quite different from the ordinary General Public License.  We use-this license for certain libraries in order to permit linking those-libraries into non-free programs.--  When a program is linked with a library, whether statically or using-a shared library, the combination of the two is legally speaking a-combined work, a derivative of the original library.  The ordinary-General Public License therefore permits such linking only if the-entire combination fits its criteria of freedom.  The Lesser General-Public License permits more lax criteria for linking other code with-the library.--  We call this license the "Lesser" General Public License because it-does Less to protect the user's freedom than the ordinary General-Public License.  It also provides other free software developers Less-of an advantage over competing non-free programs.  These disadvantages-are the reason we use the ordinary General Public License for many-libraries.  However, the Lesser license provides advantages in certain-special circumstances.--  For example, on rare occasions, there may be a special need to-encourage the widest possible use of a certain library, so that it-becomes a de-facto standard.  To achieve this, non-free programs must-be allowed to use the library.  A more frequent case is that a free-library does the same job as widely used non-free libraries.  In this-case, there is little to gain by limiting the free library to free-software only, so we use the Lesser General Public License.--  In other cases, permission to use a particular library in non-free-programs enables a greater number of people to use a large body of-free software.  For example, permission to use the GNU C Library in-non-free programs enables many more people to use the whole GNU-operating system, as well as its variant, the GNU/Linux operating-system.--  Although the Lesser General Public License is Less protective of the-users' freedom, it does ensure that the user of a program that is-linked with the Library has the freedom and the wherewithal to run-that program using a modified version of the Library.--  The precise terms and conditions for copying, distribution and-modification follow.  Pay close attention to the difference between a-"work based on the library" and a "work that uses the library".  The-former contains code derived from the library, whereas the latter must-be combined with the library in order to run.---                  GNU LESSER GENERAL PUBLIC LICENSE-   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION--  0. This License Agreement applies to any software library or other-program which contains a notice placed by the copyright holder or-other authorized party saying it may be distributed under the terms of-this Lesser General Public License (also called "this License").-Each licensee is addressed as "you".--  A "library" means a collection of software functions and/or data-prepared so as to be conveniently linked with application programs-(which use some of those functions and data) to form executables.--  The "Library", below, refers to any such software library or work-which has been distributed under these terms.  A "work based on the-Library" means either the Library or any derivative work under-copyright law: that is to say, a work containing the Library or a-portion of it, either verbatim or with modifications and/or translated-straightforwardly into another language.  (Hereinafter, translation is-included without limitation in the term "modification".)--  "Source code" for a work means the preferred form of the work for-making modifications to it.  For a library, complete source code means-all the source code for all modules it contains, plus any associated-interface definition files, plus the scripts used to control-compilation and installation of the library.--  Activities other than copying, distribution and modification are not-covered by this License; they are outside its scope.  The act of-running a program using the Library is not restricted, and output from-such a program is covered only if its contents constitute a work based-on the Library (independent of the use of the Library in a tool for-writing it).  Whether that is true depends on what the Library does-and what the program that uses the Library does.--  1. You may copy and distribute verbatim copies of the Library's-complete source code as you receive it, in any medium, provided that-you conspicuously and appropriately publish on each copy an-appropriate copyright notice and disclaimer of warranty; keep intact-all the notices that refer to this License and to the absence of any-warranty; and distribute a copy of this License along with the-Library.--  You may charge a fee for the physical act of transferring a copy,-and you may at your option offer warranty protection in exchange for a-fee.--  2. You may modify your copy or copies of the Library or any portion-of it, thus forming a work based on the Library, and copy and-distribute such modifications or work under the terms of Section 1-above, provided that you also meet all of these conditions:--    a) The modified work must itself be a software library.--    b) You must cause the files modified to carry prominent notices-    stating that you changed the files and the date of any change.--    c) You must cause the whole of the work to be licensed at no-    charge to all third parties under the terms of this License.--    d) If a facility in the modified Library refers to a function or a-    table of data to be supplied by an application program that uses-    the facility, other than as an argument passed when the facility-    is invoked, then you must make a good faith effort to ensure that,-    in the event an application does not supply such function or-    table, the facility still operates, and performs whatever part of-    its purpose remains meaningful.--    (For example, a function in a library to compute square roots has-    a purpose that is entirely well-defined independent of the-    application.  Therefore, Subsection 2d requires that any-    application-supplied function or table used by this function must-    be optional: if the application does not supply it, the square-    root function must still compute square roots.)--These requirements apply to the modified work as a whole.  If-identifiable sections of that work are not derived from the Library,-and can be reasonably considered independent and separate works in-themselves, then this License, and its terms, do not apply to those-sections when you distribute them as separate works.  But when you-distribute the same sections as part of a whole which is a work based-on the Library, the distribution of the whole must be on the terms of-this License, whose permissions for other licensees extend to the-entire whole, and thus to each and every part regardless of who wrote-it.--Thus, it is not the intent of this section to claim rights or contest-your rights to work written entirely by you; rather, the intent is to-exercise the right to control the distribution of derivative or-collective works based on the Library.--In addition, mere aggregation of another work not based on the Library-with the Library (or with a work based on the Library) on a volume of-a storage or distribution medium does not bring the other work under-the scope of this License.--  3. You may opt to apply the terms of the ordinary GNU General Public-License instead of this License to a given copy of the Library.  To do-this, you must alter all the notices that refer to this License, so-that they refer to the ordinary GNU General Public License, version 2,-instead of to this License.  (If a newer version than version 2 of the-ordinary GNU General Public License has appeared, then you can specify-that version instead if you wish.)  Do not make any other change in-these notices.--  Once this change is made in a given copy, it is irreversible for-that copy, so the ordinary GNU General Public License applies to all-subsequent copies and derivative works made from that copy.--  This option is useful when you wish to copy part of the code of-the Library into a program that is not a library.--  4. You may copy and distribute the Library (or a portion or-derivative of it, under Section 2) in object code or executable form-under the terms of Sections 1 and 2 above provided that you accompany-it with the complete corresponding machine-readable source code, which-must be distributed under the terms of Sections 1 and 2 above on a-medium customarily used for software interchange.--  If distribution of object code is made by offering access to copy-from a designated place, then offering equivalent access to copy the-source code from the same place satisfies the requirement to-distribute the source code, even though third parties are not-compelled to copy the source along with the object code.--  5. A program that contains no derivative of any portion of the-Library, but is designed to work with the Library by being compiled or-linked with it, is called a "work that uses the Library".  Such a-work, in isolation, is not a derivative work of the Library, and-therefore falls outside the scope of this License.--  However, linking a "work that uses the Library" with the Library-creates an executable that is a derivative of the Library (because it-contains portions of the Library), rather than a "work that uses the-library".  The executable is therefore covered by this License.-Section 6 states terms for distribution of such executables.--  When a "work that uses the Library" uses material from a header file-that is part of the Library, the object code for the work may be a-derivative work of the Library even though the source code is not.-Whether this is true is especially significant if the work can be-linked without the Library, or if the work is itself a library.  The-threshold for this to be true is not precisely defined by law.--  If such an object file uses only numerical parameters, data-structure layouts and accessors, and small macros and small inline-functions (ten lines or less in length), then the use of the object-file is unrestricted, regardless of whether it is legally a derivative-work.  (Executables containing this object code plus portions of the-Library will still fall under Section 6.)--  Otherwise, if the work is a derivative of the Library, you may-distribute the object code for the work under the terms of Section 6.-Any executables containing that work also fall under Section 6,-whether or not they are linked directly with the Library itself.--  6. As an exception to the Sections above, you may also combine or-link a "work that uses the Library" with the Library to produce a-work containing portions of the Library, and distribute that work-under terms of your choice, provided that the terms permit-modification of the work for the customer's own use and reverse-engineering for debugging such modifications.--  You must give prominent notice with each copy of the work that the-Library is used in it and that the Library and its use are covered by-this License.  You must supply a copy of this License.  If the work-during execution displays copyright notices, you must include the-copyright notice for the Library among them, as well as a reference-directing the user to the copy of this License.  Also, you must do one-of these things:--    a) Accompany the work with the complete corresponding-    machine-readable source code for the Library including whatever-    changes were used in the work (which must be distributed under-    Sections 1 and 2 above); and, if the work is an executable linked-    with the Library, with the complete machine-readable "work that-    uses the Library", as object code and/or source code, so that the-    user can modify the Library and then relink to produce a modified-    executable containing the modified Library.  (It is understood-    that the user who changes the contents of definitions files in the-    Library will not necessarily be able to recompile the application-    to use the modified definitions.)--    b) Use a suitable shared library mechanism for linking with the-    Library.  A suitable mechanism is one that (1) uses at run time a-    copy of the library already present on the user's computer system,-    rather than copying library functions into the executable, and (2)-    will operate properly with a modified version of the library, if-    the user installs one, as long as the modified version is-    interface-compatible with the version that the work was made with.--    c) Accompany the work with a written offer, valid for at least-    three years, to give the same user the materials specified in-    Subsection 6a, above, for a charge no more than the cost of-    performing this distribution.--    d) If distribution of the work is made by offering access to copy-    from a designated place, offer equivalent access to copy the above-    specified materials from the same place.--    e) Verify that the user has already received a copy of these-    materials or that you have already sent this user a copy.--  For an executable, the required form of the "work that uses the-Library" must include any data and utility programs needed for-reproducing the executable from it.  However, as a special exception,-the materials to be distributed need not include anything that is-normally distributed (in either source or binary form) with the major-components (compiler, kernel, and so on) of the operating system on-which the executable runs, unless that component itself accompanies-the executable.--  It may happen that this requirement contradicts the license-restrictions of other proprietary libraries that do not normally-accompany the operating system.  Such a contradiction means you cannot-use both them and the Library together in an executable that you-distribute.--  7. You may place library facilities that are a work based on the-Library side-by-side in a single library together with other library-facilities not covered by this License, and distribute such a combined-library, provided that the separate distribution of the work based on-the Library and of the other library facilities is otherwise-permitted, and provided that you do these two things:--    a) Accompany the combined library with a copy of the same work-    based on the Library, uncombined with any other library-    facilities.  This must be distributed under the terms of the-    Sections above.--    b) Give prominent notice with the combined library of the fact-    that part of it is a work based on the Library, and explaining-    where to find the accompanying uncombined form of the same work.--  8. You may not copy, modify, sublicense, link with, or distribute-the Library except as expressly provided under this License.  Any-attempt otherwise to copy, modify, sublicense, link with, or-distribute the Library is void, and will automatically terminate your-rights under this License.  However, parties who have received copies,-or rights, from you under this License will not have their licenses-terminated so long as such parties remain in full compliance.--  9. You are not required to accept this License, since you have not-signed it.  However, nothing else grants you permission to modify or-distribute the Library or its derivative works.  These actions are-prohibited by law if you do not accept this License.  Therefore, by-modifying or distributing the Library (or any work based on the-Library), you indicate your acceptance of this License to do so, and-all its terms and conditions for copying, distributing or modifying-the Library or works based on it.--  10. Each time you redistribute the Library (or any work based on the-Library), the recipient automatically receives a license from the-original licensor to copy, distribute, link with or modify the Library-subject to these terms and conditions.  You may not impose any further-restrictions on the recipients' exercise of the rights granted herein.-You are not responsible for enforcing compliance by third parties with-this License.--  11. If, as a consequence of a court judgment or allegation of patent-infringement or for any other reason (not limited to patent issues),-conditions are imposed on you (whether by court order, agreement or-otherwise) that contradict the conditions of this License, they do not-excuse you from the conditions of this License.  If you cannot-distribute so as to satisfy simultaneously your obligations under this-License and any other pertinent obligations, then as a consequence you-may not distribute the Library at all.  For example, if a patent-license would not permit royalty-free redistribution of the Library by-all those who receive copies directly or indirectly through you, then-the only way you could satisfy both it and this License would be to-refrain entirely from distribution of the Library.--If any portion of this section is held invalid or unenforceable under-any particular circumstance, the balance of the section is intended to-apply, and the section as a whole is intended to apply in other-circumstances.--It is not the purpose of this section to induce you to infringe any-patents or other property right claims or to contest validity of any-such claims; this section has the sole purpose of protecting the-integrity of the free software distribution system which is-implemented by public license practices.  Many people have made-generous contributions to the wide range of software distributed-through that system in reliance on consistent application of that-system; it is up to the author/donor to decide if he or she is willing-to distribute software through any other system and a licensee cannot-impose that choice.--This section is intended to make thoroughly clear what is believed to-be a consequence of the rest of this License.--  12. If the distribution and/or use of the Library is restricted in-certain countries either by patents or by copyrighted interfaces, the-original copyright holder who places the Library under this License-may add an explicit geographical distribution limitation excluding those-countries, so that distribution is permitted only in or among-countries not thus excluded.  In such case, this License incorporates-the limitation as if written in the body of this License.--  13. The Free Software Foundation may publish revised and/or new-versions of the Lesser General Public License from time to time.-Such new versions will be similar in spirit to the present version,-but may differ in detail to address new problems or concerns.--Each version is given a distinguishing version number.  If the Library-specifies a version number of this License which applies to it and-"any later version", you have the option of following the terms and-conditions either of that version or of any later version published by-the Free Software Foundation.  If the Library does not specify a-license version number, you may choose any version ever published by-the Free Software Foundation.--  14. If you wish to incorporate parts of the Library into other free-programs whose distribution conditions are incompatible with these,-write to the author to ask for permission.  For software which is-copyrighted by the Free Software Foundation, write to the Free-Software Foundation; we sometimes make exceptions for this.  Our-decision will be guided by the two goals of preserving the free status-of all derivatives of our free software and of promoting the sharing-and reuse of software generally.--                            NO WARRANTY--  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO-WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.-EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR-OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY-KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE-LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME-THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.--  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN-WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY-AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU-FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR-CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE-LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING-RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A-FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF-SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH-DAMAGES.--                     END OF TERMS AND CONDITIONS---           How to Apply These Terms to Your New Libraries--  If you develop a new library, and you want it to be of the greatest-possible use to the public, we recommend making it free software that-everyone can redistribute and change.  You can do so by permitting-redistribution under these terms (or, alternatively, under the terms of the-ordinary General Public License).--  To apply these terms, attach the following notices to the library.  It is-safest to attach them to the start of each source file to most effectively-convey the exclusion of warranty; and each file should have at least the-"copyright" line and a pointer to where the full notice is found.--    <one line to give the library's name and a brief idea of what it does.>-    Copyright (C) <year>  <name of author>--    This library is free software; you can redistribute it and/or-    modify it under the terms of the GNU Lesser General Public-    License as published by the Free Software Foundation; either-    version 2.1 of the License, or (at your option) any later version.--    This library is distributed in the hope that it will be useful,-    but WITHOUT ANY WARRANTY; without even the implied warranty of-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU-    Lesser General Public License for more details.--    You should have received a copy of the GNU Lesser General Public-    License along with this library; if not, write to the Free Software-    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA--Also add information on how to contact you by electronic and paper mail.--You should also get your employer (if you work as a programmer) or your-school, if any, to sign a "copyright disclaimer" for the library, if-necessary.  Here is a sample; alter the names:--  Yoyodyne, Inc., hereby disclaims all copyright interest in the-  library `Frob' (a library for tweaking knobs) written by James Random Hacker.--  <signature of Ty Coon>, 1 April 1990-  Ty Coon, President of Vice--That's all there is to it!-

@@ -1,38 +0,0 @@-Please check the right section in this file for instructions depending on how you obtained the source files.---Installing AspectAG from a source distribution----------------------------------------------  System wide installation (assumming GHC is the-  Haskell compiler) can be done like this:--    ghc --make Setup.hs -o setup -package Cabal-    ./setup configure-    ./setup build-    ./setup install---Installing uulib to a non-standard location----------------------------------------------  This is useful if you don't want (or can't)-  modify system wide settings.--    ghc --make Setup.hs -o setup -package Cabal-    ./setup configure --prefix=/foo-    ./setup build-    ./setup install --user--  The last command registers the package only for-  the user.----Optionally generating Haddock Documentation----------------------------------------------  Output generated in dist/doc/html--    ./setup haddock-

@@ -1,3 +1,2 @@- import Distribution.Simple main = defaultMain

@@ -0,0 +1,95 @@+{-# LANGUAGE TypeOperators #-}++{-# LANGUAGE+             TypeFamilies,+             FlexibleContexts,+             ScopedTypeVariables,+             NoMonomorphismRestriction,+             ImplicitParams,+             ExtendedDefaultRules,+             UnicodeSyntax,+             DataKinds,+             TypeApplications,+             PartialTypeSignatures,+             AllowAmbiguousTypes+#-}+++module Expr where++import System.Exit (exitFailure)+import Language.Grammars.AspectAG+import Control.Monad+import Control.Applicative+import Data.Proxy+import GHC.TypeLits+import Data.Map+import Data.Maybe+import Debug.Trace+import Language.Grammars.AspectAG.TH++type Nt_Expr = 'NT "Expr"+expr = Label @ Nt_Expr++type P_Add = 'Prd "p_Add" Nt_Expr+add = Label @ P_Add++type P_Val = 'Prd "p_Val" Nt_Expr+val = Label @ P_Val++type P_Var = 'Prd "p_Var" Nt_Expr+var = Label @ P_Var+++leftAdd   = Label @ ('Chi "leftAdd"   P_Add ('Left Nt_Expr))+rightAdd  = Label @ ('Chi "rightAdd"  P_Add ('Left Nt_Expr))+ival      = Label @ ('Chi "ival"      P_Val ('Right ('T Int)))+vname     = Label @ ('Chi "vname"     P_Var ('Right ('T String)))++eval = Label @ ('Att "eval" Int)+env  = Label @ ('Att "env"  (Map String Int))++add_eval  =  syndefM eval add  $ (+) <$> at leftAdd eval <*> at rightAdd eval+val_eval  =  syndefM eval val  $ ter ival+var_eval  =  syndefM eval var  $ slookup <$> ter vname <*> at lhs env++slookup nm = fromJust . Data.Map.lookup nm++aspEval   =  traceAspect (Proxy @ ('Text "eval"))+          $  add_eval .+: val_eval .+: var_eval .+: emptyAspect+++add_leftAdd_env  = inhdefM env add leftAdd  $ at lhs env+add_rightAdd_env = inhdefM env add rightAdd $ at lhs env+-- val_ival_env = inhdefM env val ival $ at lhs env++aspEnv  =  traceAspect (Proxy @ ('Text "env"))+        $  add_leftAdd_env .+: add_rightAdd_env .+: emptyAspect +++asp = aspEval .:+: aspEnv+++data Expr = Val Int+          | Var String+          | Add Expr Expr+       deriving Show++++sem_Expr asp (Add l r) = knitAspect add asp+                           $  leftAdd  .=. sem_Expr asp l+                          .*. rightAdd .=. sem_Expr asp r+                          .*.  EmptyRec+sem_Expr asp (Val i)   = knitAspect val asp$+                          ival  .=. sem_Lit i .*. EmptyRec+sem_Expr asp (Var v)   = knitAspect var asp$+                          vname .=. sem_Lit v .*. EmptyRec++evalExpr e m = sem_Expr asp e (env =. m .*. emptyAtt) #. eval+++exampleExpr =  Add (Val (-9)) (Add (Var "x") (Val 2))+exampleEval =  evalExpr exampleExpr (insert "x" 5 Data.Map.empty)++

@@ -0,0 +1,184 @@+{-# LANGUAGE TypeOperators #-}++{-# LANGUAGE+             TypeFamilies,+             FlexibleContexts,+             ScopedTypeVariables,+             NoMonomorphismRestriction,+             ImplicitParams,+             ExtendedDefaultRules,+             UnicodeSyntax,+             DataKinds,+             TypeApplications,+             PartialTypeSignatures,+             AllowAmbiguousTypes+#-}++module ExprExt where++import Language.Grammars.AspectAG+import Control.Monad+import Control.Applicative+import Data.Proxy+import GHC.TypeLits+import Data.Map+import Data.Maybe+import Expr+++type P_Let = 'Prd "p_Let" Nt_Expr+elet = Label @ P_Let+++exprLet   = Label @ ('Chi "exprLet"   P_Let ('Left Nt_Expr))+bodyLet   = Label @ ('Chi "bodyLet"   P_Let ('Left Nt_Expr))+vlet      = Label @ ('Chi "vlet"      P_Let ('Right ('T String)))+++aspEval2  = traceAspect (Proxy @ ('Text "eval2"))+          $ syndefM eval elet (at bodyLet eval) .+: aspEval+++aspEnv2   =   traceAspect (Proxy @ ('Text "env2"))+          $   inhdefM env elet exprLet (at lhs env)+         .+:  inhdefM env elet bodyLet (insert  <$> ter vlet+                                                <*> at exprLet eval+                                                <*> at lhs env)+         .+:  aspEnv+++asp2 = aspEval2 .:+: aspEnv2++data Expr' = Val' Int+           | Var' String+           | Add' Expr' Expr'+           | Let String Expr' Expr'+       deriving Show++sem_Expr' asp (Add' l r) = knitAspect add asp+                           $  leftAdd  .=. sem_Expr' asp l+                          .*. rightAdd .=. sem_Expr' asp r+                          .*.  EmptyRec+sem_Expr' asp (Val' i)   = knitAspect val asp+                          $ ival  .=. sem_Lit i .*. EmptyRec+sem_Expr' asp (Var' v)   = knitAspect var asp+                          $ vname .=. sem_Lit v .*. EmptyRec++sem_Expr' asp (Let v e b) = knitAspect elet asp+                           $   vlet     .=. sem_Lit v+                          .*.  exprLet  .=. sem_Expr' asp e+                          .*.  bodyLet  .=. sem_Expr' asp b+                          .*.  EmptyRec++evalExpr' e m = sem_Expr' asp2 e (env =. m .*. emptyAtt) #. eval ++exampleExpr' =  Add' (Val' (-9))+                     (Add' (Var' "x") (Let "x" (Val' 2)+                                               (Var' "x")))+exampleEval' =  evalExpr' exampleExpr'+                          (insert "x" 5 Data.Map.empty)++val_eval'  =  synmodM eval val  $ abs <$> ter ival+++type P_Abs = 'Prd "p_Abs" Nt_Expr+eabs = Label @ P_Abs+type P_App = 'Prd "p_App" Nt_Expr+eapp = Label @ P_App++tAbs   = Label @ ('Chi "tAbs"   P_Abs ('Left Nt_Expr))+xAbs   = Label @ ('Chi "xAbs"   P_Abs ('Right ('T String)))++tApp   = Label @ ('Chi "tApp"   P_App ('Left Nt_Expr))+uApp   = Label @ ('Chi "uApp"   P_App ('Left Nt_Expr))++++appStack = Label @ ('Att "appStack" [Int])++app_eval      = syndefM eval eapp $ at tApp eval+app_env_t     = inhdefM env eapp tApp $ at lhs env+app_env_u     = inhdefM env eapp uApp $ at lhs env+app_appStk_t  = inhdefM appStack eapp tApp+  $ do u      <- at uApp eval+       oldStk <- at lhs appStack+       return (u:oldStk)+app_appStk_u = inhdefM appStack eapp uApp $ pure []++abs_eval = syndefM eval eabs $ at tAbs eval+abs_env = inhdefM env eabs tAbs+  $ do x      <- ter xAbs+       envi   <- at lhs env+       st  <- at lhs appStack+       case st of+        -- [] -> return envi+         (s:_) -> return (insert x s envi)+abs_appStk_t = inhdefM appStack eabs tAbs+  $ tail <$> at lhs appStack++add_appStk_l  = inhdefM appStack add leftAdd  $ pure []+add_appStk_r  = inhdefM appStack add rightAdd $ pure []++let_appStk_r = inhdefM appStack elet bodyLet $ pure []+let_appStk_l = inhdefM appStack elet exprLet $ pure []++(.:+.) = flip (.+:)++aspLam = asp2 .:+. app_env_t .:+. app_env_u .:+. abs_env .:+. app_eval .:+. abs_eval+  .:+. abs_appStk_t .:+. app_appStk_t .:+. app_appStk_u+  .:+. let_appStk_l .:+. let_appStk_r .:+. add_appStk_r .:+. add_appStk_l++evalExpr'' e = sem_Expr'' aspLam e ( (appStack =. []) .*. (env =. (Data.Map.empty :: Map String Int )) .*. emptyAtt) #. eval+++data Expr'' = Val'' Int+            | Var'' String+            | Add'' Expr'' Expr''+            | Let'' String Expr'' Expr''+            | App Expr'' Expr''+            | Abs String Expr''++sem_Expr'' asp (Add'' l r) = knitAspect add asp+                           $  leftAdd  .=. sem_Expr'' asp l+                          .*. rightAdd .=. sem_Expr'' asp r+                          .*.  EmptyRec+sem_Expr'' asp (Val'' i)   = knitAspect val asp+                         $ ival  .=. sem_Lit i .*. EmptyRec+sem_Expr'' asp (Var'' v)   = knitAspect var asp+                         $ vname .=. sem_Lit v .*. EmptyRec++sem_Expr'' asp (Let'' v e b) = knitAspect elet asp+                          $   vlet     .=. sem_Lit v+                         .*.  exprLet  .=. sem_Expr'' asp e+                         .*.  bodyLet  .=. sem_Expr'' asp b+                         .*.  EmptyRec+sem_Expr'' asp (Abs x t) = knitAspect eabs asp+                          $   xAbs   .=. sem_Lit x+                         .*.  tAbs   .=. sem_Expr'' asp t+                         .*.  EmptyRec+sem_Expr'' asp (App t u) = knitAspect eapp asp+                          $   uApp   .=. sem_Expr'' asp u+                         .*.  tApp   .=. sem_Expr'' asp t+                         .*.  EmptyRec+++--evalExpr'' e = sem_Expr'' asp_All e (emptyAtt) #. eval+++fun = Abs "x" (Var'' "x" `Add''` Val'' 4)++ex1 = fun `App` Val'' 89++f $$ x = App f x++instance Num Expr'' where+  fromInteger = Val'' . fromIntegral++lam = Abs+leti = Let''+v = Var''+++f = (lam ("x") ((v "x") `Add''` (5 :: Expr'')))+g = (lam ("y") ((v "y") `Add''` (4::Expr'')))+

@@ -1,115 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}--module LangDef where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1--import Data.Maybe--import UU.Pretty--import Control.Monad ---data AGItf = AGItf { expr :: T_Expr}-          deriving Show--data T_Expr  =  Cst {cv  :: Int}-             |  Var {vnm :: String}-             |  Mul {me1 :: T_Expr, me2 :: T_Expr}-             |  Add {ae1 :: T_Expr, ae2 :: T_Expr}-             |  Let {lnm :: String, val :: T_Expr, body :: T_Expr}-          deriving Show----syn = syndefM-inh = inhdefM---$(deriveAG ''AGItf)--exprNT = nt_T_Expr .*. hNil-allNT  = nt_AGItf .*. exprNT- --$(attLabels ["spp"])--sppAGItf  = syn spp $ liftM (# spp) (at ch_expr)-sppCst    = syn spp $ liftM pp      (at ch_cv)-sppVar    = syn spp $ liftM pp      (at ch_vnm)-sppMul    = syn spp $ do  e1 <- at ch_me1 -                          e2 <- at ch_me2-                          return $ e1 # spp >|< " * " >|< e2 # spp -sppAdd    = syn spp $ do  e1 <- at ch_ae1 -                          e2 <- at ch_ae2-                          return $ e1 # spp >|< " + " >|< e2 # spp --sppLet    = syn spp $ do  lnm  <- at ch_lnm-                          val  <- at ch_val-                          body <- at ch_body-                          return $ "let " >|< pp lnm >|< " = " >|< val # spp >|< " in " >|< body # spp    ---$(attLabels ["ienv","sval"])---ienvRule  = copy ienv exprNT  -ienvAGItf = inh ienv exprNT $ do return  (ch_expr .=. ([] :: [(String,Int)]) .*.  emptyRecord)-ienvCst   = ienvRule-ienvVar   = ienvRule-ienvMul   = ienvRule-ienvAdd   = ienvRule-ienvLet   = inh ienv exprNT $ do lnm <- at ch_lnm-                                 val <- at ch_val-                                 lhs <- at lhs-                                 return  $  ch_val   .=.  lhs # ienv .*.-                                            ch_body  .=.  (lnm, val # sval) : lhs # ienv .*.  -                                            emptyRecord---svalRule  f = use sval allNT f  (0::Int)  -svalAGItf = svalRule ((*)::Int->Int->Int)-svalCst   = syn sval $ liftM id (at ch_cv)-svalVar   = syn sval $ do  vnm <- at ch_vnm -                           lhs <- at lhs-                           return $ fromJust (lookup vnm (lhs # ienv)) -svalMul   = svalRule ((*)::Int->Int->Int)-svalAdd   = svalRule ((+)::Int->Int->Int)-svalLet   = syn sval $ liftM (# sval) (at ch_body)---aspAGItf = sppAGItf `ext` ienvAGItf `ext` svalAGItf-aspCst   = sppCst   `ext` ienvCst   `ext` svalCst  -aspVar   = sppVar   `ext` ienvVar   `ext` svalVar  -aspMul   = sppMul   `ext` ienvMul   `ext` svalMul  -aspAdd   = sppAdd   `ext` ienvAdd   `ext` svalAdd  -aspLet   = sppLet   `ext` ienvLet   `ext` svalLet---semAGItf  = semP_AGItf aspAGItf -semCst    = semP_Cst aspCst -semVar    = semP_Var aspVar -semMul    = semP_Mul aspMul-semAdd    = semP_Add aspAdd-semLet    = semP_Let aspLet ---ex1Expr = semLet  (sem_Lit "x")  (semCst $ sem_Lit  2) -                  (semAdd (semVar $ sem_Lit "x") (semCst $ sem_Lit  3)) --eval ex = do-        let res = ex (ienv .=. [] .*. emptyRecord)-        print $ res  # spp-        print $ res  # sval--ex1 = eval ex1Expr---

@@ -1,236 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}--module LangExt where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1--import Data.Maybe--import UU.Pretty--import Control.Monad --import LangDef----- modifications of the semantics-synM = synmodM-inhM = inhmodM--- ---Square--- $(chLabel "se" ''T_Expr)-$(addProd "Sq" [ ("se",''T_Expr) ])--sppSq = synM spp $ do me1 <- at ch_se -                      return $ "square" >#< (me1 # spp)   --se2m r = (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)-m2se r = (ch_se .=. (r # ch_me1) .*. emptyRecord)----- aspSq = sppSq `ext` (adapt aspMul se2m se2m m2se)-aspSq = sppSq `ext` (mapChildren aspMul (ch_me1 .=. ch_se .*. ch_me2 .=. ch_se .*. emptyRecord))---- semSq = \s -> knit aspSq (s .*. emptyRecord)  -semSq = semP_Sq aspSq----ex2Expr = semLet  (sem_Lit "x")  (semCst $ sem_Lit  2) -                  (semSq (semVar $ sem_Lit "x")) --ex2 = eval ex2Expr-----Pyth--- $(chLabels ["pe1","pe2"] ''T_Expr)-$(addProd "Pyth" [ ("pe1",''T_Expr), ("pe2",''T_Expr) ])--sppSq' = synM spp $ do liftM (# spp) (at ch_se) -aspSq' = sppSq' `ext` aspSq --sppPyth  = synM spp  $ do  pe1 <- at ch_pe1-                           pe2 <- at ch_pe2 -                           return $ "pyth" >#< (pe1 # spp) >#< (pe2 # spp)   -{--aspAdd' =  graft  (graft  aspAdd-                          (ch_ae2 .=. ch_ae2 .*. emptyRecord)-                          ch_ae1 -                          aspSq' -                          (ch_se .=. ch_pe1 .*. emptyRecord))-                  (ch_pe1 .=. ch_pe1 .*. emptyRecord)-                  ch_ae2-                  aspSq' -                  (ch_se .=. ch_pe2 .*. emptyRecord)--}--aspAdd' =  agMacro  (aspAdd   ,   ch_ae1 ==> (aspSq', ch_se --> ch_pe1)   -                             <.>  ch_ae2 ==> (aspSq', ch_se --> ch_pe2))--aspPyth    = sppPyth `ext` aspAdd'--- semPyth = \p1 p2 -> knit  aspPyth (p1 .*. p2 .*. emptyRecord)  -semPyth = semP_Pyth aspPyth--ex3Expr = semLet  (sem_Lit "x")  (semCst $ sem_Lit  2) -                  (semPyth (semVar $ sem_Lit "x") (semCst $ sem_Lit  3) ) --ex3 = eval ex3Expr-----AddSq-$(addProd "AddSq" [ ("as1",''T_Expr), ("as2",''T_Expr) ])---sppAddSq  = synM spp  $ do  as1 <- at ch_as1-                            as2 <- at ch_as2 -                            return $ "addsq" >#< (as1 # spp) >#< (as2 # spp)   ----{--aspAddSq = sppAddSq `ext`-           (graft  (graft  aspMul-                           (ch_me2 .=. ch_me2 .*. emptyRecord)-                           ch_me1 -                           aspAdd -                           (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))-                   (ch_as1 .=. ch_as1 .*. ch_as2 .=. ch_as2 .*. emptyRecord)-                   ch_me2-                   aspAdd -                   (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))--}--aspAddSq = sppAddSq `ext`-            agMacro  (aspMul   ,   ch_me1 ==> (aspAdd, ch_ae1 --> ch_as1 <.> ch_ae2 --> ch_as2)-                              <.>  ch_me2 ==> (aspAdd, ch_ae1 --> ch_as1 <.> ch_ae2 --> ch_as2))---semAddSq = semP_AddSq aspAddSq--ex4Expr = (semAddSq (semCst $ sem_Lit 2) (semCst $ sem_Lit  3) ) --ex4 = eval ex4Expr-----Double--- $(chLabel "de" ''T_Expr)-$(addProd "Db" [ ("de",''T_Expr) ])--aspTwo = fixCst aspCst ch_cv 2-{--aspMul' =  graft  aspMul-                  (ch_me2 .=. ch_de .*. emptyRecord) -                  ch_me1-                  aspTwo-                  emptyRecord --}--aspMul' =  agMacro  (aspMul   ,   ch_me1 ==> (aspTwo, flip const)-                             <.>  ch_me2 --> ch_de)-                  --sppDb = synM spp $ do de <- at ch_de -                      return $ "double" >#< (de # spp)   --aspDb = sppDb `ext` aspMul'-                ---semDb = \d -> knit aspDb (d .*. emptyRecord)-semDb = semP_Db aspDb-           --ex5Expr = (semAdd (semCst $ sem_Lit 2) (semDb (semCst $ sem_Lit  3)) ) --ex5 = eval ex5Expr------AddMul--- $(chLabels ["am1","am2","am3"] ''T_Expr)-$(addProd "AddMul" [ ("am1",''T_Expr), ("am2",''T_Expr), ("am3",''T_Expr) ])---sppAddMul = synM spp $ do  am1 <- at ch_am1 -                           am2 <- at ch_am2 -                           am3 <- at ch_am3 -                           return $ "addmul" >#< (am1 # spp) >#< (am2 # spp) >#< (am3 # spp)  -{--aspAddMul = ext sppAddMul $  graft  aspAdd-                                    (ch_ae1 .=. ch_am1 .*. emptyRecord)-                                    ch_ae2 -                                    aspMul-                                    (ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. emptyRecord)--}-aspAddMul = sppAddMul `ext`-            agMacro  (aspAdd   ,  ch_ae1 --> ch_am1-                              <.> ch_ae2 ==> (aspMul, ch_me1 --> ch_am2 <.> ch_me2 --> ch_am3))-- --- semAddMul = \p1 p2 p3 -> knit aspAddMul (p1 .*. p2 .*. p3 .*. emptyRecord)-semAddMul = semP_AddMul aspAddMul                          --ex6Expr = (semAddMul (semCst $ sem_Lit 2) (semCst $ sem_Lit  3) (semCst $ sem_Lit  4)) --ex6 = eval ex6Expr-----LetX-$(addProd "LetX" [ {-("valx",''T_Expr),-} ("bodyx",''T_Expr) ])---sppLetX = synM spp $ do -- valx  <- at ch_valx-                        bodyx <- at ch_bodyx-                        return $ "x =" >#< {-(valx # spp)-} "10" >#< "=>" >#< (bodyx # spp)  --{--aspLet' = fixCst aspLet ch_lnm "x"--aspLetX = sppLetX `ext` (mapChildren aspLet' (ch_val .=. ch_valx .*. ch_body .=. ch_bodyx .*. emptyRecord))--}                --aspLetX = sppLetX `ext` -           agMacro (aspLet ,  ch_lnm ~~> "x" <.>-                              ch_val ~~> (sval .=. 10 .*. spp .=. "10" .*. emptyRecord) <.> -- --> ch_valx <.> -                              ch_body --> ch_bodyx) --semLetX = semP_LetX aspLetX-           --ex7Expr = (semLetX {-(semCst $ sem_Lit 10)-} (semDb (semVar $ sem_Lit  "x")) ) --ex7 = eval ex7Expr-----AddMulMul-$(addProd "AddMulSq" [ ("ams1",''T_Expr), ("ams2",''T_Expr), ("ams3",''T_Expr) ])---sppAddMulSq = -            synM spp $ do  ams1 <- at ch_ams1 -                           ams2 <- at ch_ams2 -                           ams3 <- at ch_ams3 -                           return $ "addmulsq" >#< (ams1 # spp) >#< (ams2 # spp) >#< (ams3 # spp)  --aspAddMulSq = sppAddMulSq `ext`-                   agMacro  (aspAdd   ,  ch_ae1 --> ch_ams1-                                     <.> ch_ae2 ==> (aspMul, ch_me1 --> ch_ams2 <.>-                                                             ch_me2 ==> (aspMul, ch_me1 --> ch_ams3 <.> ch_me2 --> ch_ams3)))---semAddMulSq = semP_AddMulSq aspAddMulSq                          --ex8Expr = semAddMulSq (semCst $ sem_Lit 2) (semCst $ sem_Lit  3) (semCst $ sem_Lit  4)--ex8 = eval ex8Expr---main = ex1 >> ex2 >> ex3 >> ex4 >> ex5 >> ex6 >> ex7 >> ex8--

@@ -1,315 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}--module Main where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1--import Data.Maybe--import UU.Pretty--import Control.Monad ---data AGItf = AGItf { expr :: T_Expr}-          deriving Show--data T_Expr  =  Cst {cv  :: Int}-             |  Var {vnm :: String}-             |  Mul {me1 :: T_Expr, me2 :: T_Expr}-             |  Add {ae1 :: T_Expr, ae2 :: T_Expr}-             |  Let {lnm :: String, val :: T_Expr, body :: T_Expr}-          deriving Show----syn = syndefM-inh = inhdefM---$(deriveAG ''AGItf)--exprNT = nt_T_Expr .*. hNil-allNT  = nt_AGItf .*. exprNT- --$(attLabels ["spp"])--sppAGItf  = syn spp $ liftM (# spp) (at ch_expr)-sppCst    = syn spp $ liftM pp      (at ch_cv)-sppVar    = syn spp $ liftM pp      (at ch_vnm)-sppMul    = syn spp $ do  e1 <- at ch_me1 -                          e2 <- at ch_me2-                          return $ e1 # spp >|< " * " >|< e2 # spp -sppAdd    = syn spp $ do  e1 <- at ch_ae1 -                          e2 <- at ch_ae2-                          return $ e1 # spp >|< " + " >|< e2 # spp --sppLet    = syn spp $ do  lnm  <- at ch_lnm-                          val  <- at ch_val-                          body <- at ch_body-                          return $ "let " >|< pp lnm >|< " = " >|< val # spp >|< " in " >|< body # spp    ---$(attLabels ["ienv","sval"])---ienvRule  = copy ienv exprNT  -ienvAGItf = inh ienv exprNT $ do return  (ch_expr .=. ([] :: [(String,Int)]) .*.  emptyRecord)-ienvCst   = ienvRule-ienvVar   = ienvRule-ienvMul   = ienvRule-ienvAdd   = ienvRule-ienvLet   = inh ienv exprNT $ do lnm <- at ch_lnm-                                 val <- at ch_val-                                 lhs <- at lhs-                                 return  $  ch_val   .=.  lhs # ienv .*.-                                            ch_body  .=.  (lnm, val # sval) : lhs # ienv .*.  -                                            emptyRecord---svalRule  f = use sval allNT f  (0::Int)  -svalAGItf = svalRule ((*)::Int->Int->Int)-svalCst   = syn sval $ liftM id (at ch_cv)-svalVar   = syn sval $ do  vnm <- at ch_vnm -                           lhs <- at lhs-                           return $ fromJust (lookup vnm (lhs # ienv)) -svalMul   = svalRule ((*)::Int->Int->Int)-svalAdd   = svalRule ((+)::Int->Int->Int)-svalLet   = syn sval $ liftM (# sval) (at ch_body)---aspAGItf = sppAGItf `ext` ienvAGItf `ext` svalAGItf-aspCst   = sppCst   `ext` ienvCst   `ext` svalCst  -aspVar   = sppVar   `ext` ienvVar   `ext` svalVar  -aspMul   = sppMul   `ext` ienvMul   `ext` svalMul  -aspAdd   = sppAdd   `ext` ienvAdd   `ext` svalAdd  -aspLet   = sppLet   `ext` ienvLet   `ext` svalLet---semAGItf  = semP_AGItf aspAGItf -semCst    = semP_Cst aspCst -semVar    = semP_Var aspVar -semMul    = semP_Mul aspMul-semAdd    = semP_Add aspAdd-semLet    = semP_Let aspLet ---ex1Expr = semLet  (sem_Lit "x")  (semCst $ sem_Lit  2) -                  (semAdd (semVar $ sem_Lit "x") (semCst $ sem_Lit  3)) --eval ex = do-        let res = ex (ienv .=. [] .*. emptyRecord)-        print $ res  # spp-        print $ res  # sval--ex1 = eval ex1Expr----- modifications of the semantics-synM = synmodM-inhM = inhmodM--- ---Square--- $(chLabel "se" ''T_Expr)-$(addProd "Sq" [ ("se",''T_Expr) ])--sppSq = synM spp $ do me1 <- at ch_se -                      return $ "square" >#< (me1 # spp)   --se2m r = (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)-m2se r = (ch_se .=. (r # ch_me1) .*. emptyRecord)----- aspSq = sppSq `ext` (adapt aspMul se2m se2m m2se)-aspSq = sppSq `ext` (mapChildren aspMul (ch_me1 .=. ch_se .*. ch_me2 .=. ch_se .*. emptyRecord))---- semSq = \s -> knit aspSq (s .*. emptyRecord)  -semSq = semP_Sq aspSq----ex2Expr = semLet  (sem_Lit "x")  (semCst $ sem_Lit  2) -                  (semSq (semVar $ sem_Lit "x")) --ex2 = eval ex2Expr-----Pyth--- $(chLabels ["pe1","pe2"] ''T_Expr)-$(addProd "Pyth" [ ("pe1",''T_Expr), ("pe2",''T_Expr) ])--sppSq' = synM spp $ do liftM (# spp) (at ch_se) -aspSq' = sppSq' `ext` aspSq --sppPyth  = synM spp  $ do  pe1 <- at ch_pe1-                           pe2 <- at ch_pe2 -                           return $ "pyth" >#< (pe1 # spp) >#< (pe2 # spp)   -{--aspAdd' =  graft  (graft  aspAdd-                          (ch_ae2 .=. ch_ae2 .*. emptyRecord)-                          ch_ae1 -                          aspSq' -                          (ch_se .=. ch_pe1 .*. emptyRecord))-                  (ch_pe1 .=. ch_pe1 .*. emptyRecord)-                  ch_ae2-                  aspSq' -                  (ch_se .=. ch_pe2 .*. emptyRecord)--}-{--aspAdd' =  macro  aspAdd $ ch_ae1 ==> (aspSq', ch_se .=. ch_pe1 .*. emptyRecord)-                           <.> -                           ch_ae2 ==> (aspSq', ch_se .=. ch_pe2 .*. emptyRecord)--}-aspAdd' =  macro  aspAdd $ ch_ae1 ==> (aspSq', ch_se --> ch_pe1)-                           <.> -                           ch_ae2 ==> (aspSq', ch_se --> ch_pe2)--aspPyth    = sppPyth `ext` aspAdd'--- semPyth = \p1 p2 -> knit  aspPyth (p1 .*. p2 .*. emptyRecord)  -semPyth = semP_Pyth aspPyth--ex3Expr = semLet  (sem_Lit "x")  (semCst $ sem_Lit  2) -                  (semPyth (semVar $ sem_Lit "x") (semCst $ sem_Lit  3) ) --ex3 = eval ex3Expr--{----AddSq-$(addProd "AddSq" [ ("as1",''T_Expr), ("as2",''T_Expr) ])---sppAddSq  = synM spp  $ do  as1 <- at ch_as1-                            as2 <- at ch_as2 -                            return $ "addsq" >#< (as1 # spp) >#< (as2 # spp)   ----{--aspAddSq = sppAddSq `ext`-           (graft  (graft  aspMul-                           (ch_me2 .=. ch_me2 .*. emptyRecord)-                           ch_me1 -                           aspAdd -                           (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))-                   (ch_as1 .=. ch_as1 .*. ch_as2 .=. ch_as2 .*. emptyRecord)-                   ch_me2-                   aspAdd -                   (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))--}--aspAddSq = sppAddSq `ext`-           (macro  aspMul $ ch_me1 ==> (aspAdd, ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord)-                            <.>-                            ch_me2 ==> (aspAdd, ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))---semAddSq = semP_AddSq aspAddSq--ex4Expr = (semAddSq (semCst $ sem_Lit 2) (semCst $ sem_Lit  3) ) --ex4 = eval ex4Expr-----Double--- $(chLabel "de" ''T_Expr)-$(addProd "Db" [ ("de",''T_Expr) ])--aspTwo = fixCst aspCst ch_cv 2-{--aspMul' =  graft  aspMul-                  (ch_me2 .=. ch_de .*. emptyRecord) -                  ch_me1-                  aspTwo-                  emptyRecord --}--aspMul' =  macro  aspMul $ ch_me1 ==> (aspTwo, emptyRecord)-                           <.>-                           ch_me2 --> ch_de -                  --sppDb = synM spp $ do de <- at ch_de -                      return $ "double" >#< (de # spp)   --aspDb = sppDb `ext` aspMul'-                ---semDb = \d -> knit aspDb (d .*. emptyRecord)-semDb = semP_Db aspDb-           --ex5Expr = (semAdd (semCst $ sem_Lit 2) (semDb (semCst $ sem_Lit  3)) ) --ex5 = eval ex5Expr------AddMul--- $(chLabels ["am1","am2","am3"] ''T_Expr)-$(addProd "AddMul" [ ("am1",''T_Expr), ("am2",''T_Expr), ("am3",''T_Expr) ])---sppAddMul = synM spp $ do  am1 <- at ch_am1 -                           am2 <- at ch_am2 -                           am3 <- at ch_am3 -                           return $ "addmul" >#< (am1 # spp) >#< (am2 # spp) >#< (am3 # spp)  -{--aspAddMul = ext sppAddMul $  graft  aspAdd-                                    (ch_ae1 .=. ch_am1 .*. emptyRecord)-                                    ch_ae2 -                                    aspMul-                                    (ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. emptyRecord)--}-aspAddMul = sppAddMul `ext`-           (macro  aspAdd $ ch_ae1 --> ch_am1-                            <.>-                            ch_ae2 ==> (aspMul, ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. emptyRecord))-- --- semAddMul = \p1 p2 p3 -> knit aspAddMul (p1 .*. p2 .*. p3 .*. emptyRecord)-semAddMul = semP_AddMul aspAddMul                          --ex6Expr = (semAddMul (semCst $ sem_Lit 2) (semCst $ sem_Lit  3) (semCst $ sem_Lit  4)) --ex6 = eval ex6Expr-----LetX-$(addProd "LetX" [ {-("valx",''T_Expr),-} ("bodyx",''T_Expr) ])---sppLetX = synM spp $ do -- valx  <- at ch_valx-                        bodyx <- at ch_bodyx-                        return $ "x =" >#< {-(valx # spp)-} "10" >#< "=>" >#< (bodyx # spp)  --{--aspLet' = fixCst aspLet ch_lnm "x"--aspLetX = sppLetX `ext` (mapChildren aspLet' (ch_val .=. ch_valx .*. ch_body .=. ch_bodyx .*. emptyRecord))--}                --aspLetX = sppLetX `ext` -           (macro aspLet $ ch_lnm ~~> "x" <.>-                           ch_val ~~> (sval .=. 10 .*. spp .=. "10" .*. emptyRecord) <.> -- --> ch_valx <.> -                           ch_body --> ch_bodyx) --semLetX = semP_LetX aspLetX-           --ex7Expr = (semLetX {-(semCst $ sem_Lit 10)-} (semDb (semVar $ sem_Lit  "x")) ) --ex7 = eval ex7Expr----main = ex1 >> ex2 >> ex3 >> ex4 >> ex5 >> ex6 >> ex7---}

@@ -0,0 +1,128 @@+{-# LANGUAGE TypeOperators #-}++{-# LANGUAGE+             TypeFamilies,+             FlexibleContexts,+             ScopedTypeVariables,+             NoMonomorphismRestriction,+             ImplicitParams,+             ExtendedDefaultRules,+             UnicodeSyntax,+             DataKinds,+             TypeApplications,+             PartialTypeSignatures,+             AllowAmbiguousTypes,+             RankNTypes,+             ScopedTypeVariables+#-}+++module List where++import Prelude hiding (head, tail, sum, all, length, null, last)++import Language.Grammars.AspectAG+import Control.Monad+import Control.Applicative+import Data.Proxy+import GHC.TypeLits++type Nt_List = 'NT "List"+list = Label @ Nt_List++type P_Cons = 'Prd "Cons" Nt_List+cons = Label @ P_Cons+++type P_Nil = 'Prd "Nil" Nt_List+nil = Label @ P_Nil++head :: forall a . Label ('Chi "head" P_Cons ('Right ('T a)))+head   = Label++tail   = Label @ ('Chi "tail"   P_Cons ('Left Nt_List))+nilCh :: Label ('Chi "nilCh"  P_Nil  ('Right ('T ())))+nilCh = Label+++  -- data List a = Cons a (List a) | Nil () deriving Show++sem_List (proxy :: Proxy a) asp (x:xs)+  = knitAspect cons asp+  $    head @ a .=. sem_Lit @ a x+ .*.   tail  .=. sem_List proxy asp xs+ .*.   EmptyRec+sem_List (_ :: Proxy a) asp []+  = knitAspect nil asp+  $ nilCh  .=. sem_Lit () .*. EmptyRec++scata :: forall b . Label ('Att "cata" b)+scata = Label++asp_cata (Proxy :: Proxy a) f e+  =   (syndefM (scata @ a) cons $ f <$> ter head <*> at tail (scata @ a))+  .+: (syndefM (scata @ a) nil $ pure e)+  .+: emptyAspect++sum :: [Integer] -> Integer+sum xs+  = sem_List (Proxy @ Integer)+    (asp_cata (Proxy @ Integer) (+) 0) xs emptyAtt #. (scata @ Integer)++all xs+  = sem_List (Proxy @ Bool)+    (asp_cata (Proxy @ Bool) (&&) True) xs emptyAtt #. (scata @ Bool)+++cata :: (a -> b -> b) -> b -> [a] -> b+cata (f :: a -> b -> b) e xs+  = sem_List (Proxy @ a) (asp_cata (Proxy @ b) f e) xs emptyAtt #. (scata @ b)+++tyApp :: (forall a. Label ('Att "cata" a)) -> Proxy a+      -> (Label ('Att "cata" a))+tyApp poly (Proxy :: Proxy a) = poly @ a++slen = Label @ ('Att "slen" Integer)++asp_slen+  =   syndefM slen cons ((1+) <$> at tail slen)+  .+: syndefM slen nil (pure 0) .+: emptyAspect++length xs+  = sem_List (proxyFrom xs) asp_slen xs emptyAtt #. slen++sempty = Label @ ('Att "sempty" Bool)+asp_sempty+  = syndefM sempty cons (pure False) .+: syndefM sempty nil (pure True) .+: emptyAspect++null xs = sem_List (proxyFrom xs) asp_sempty xs emptyAtt #. sempty++sid :: forall a . Label ('Att "sid" [a]) ; sid = Label++asp_sid+  = \(Proxy :: Proxy a)+    ->   syndefM (sid @ a) cons ((:) <$> ter head <*> at tail sid)+     .+: syndefM (sid @ a) nil (pure []) .+: emptyAspect++idList (xs :: [a])+  = sem_List (proxyFrom xs) (asp_sid (proxyFrom xs)) xs emptyAtt #. (sid @ a) -- TODO+-- Si queremos evitar anotar tipos, los atributos polimorficos pueden tomar un proxy como+-- parametro, y usar proxyFrom++++slast :: forall a . Label ('Att "slast" a); slast = Label+asp_slast (Proxy :: Proxy a)+  = syndefM (slast @ a) cons (+    do isLast <- at tail sempty+       case isLast of+         True  -> ter head+         False -> at tail slast+    )+   .+: syndefM (slast @ a) nil (error "Exception: empty list")+   .+: emptyAspect++last (xs :: [a])+  = sem_List (proxyFrom xs) (asp_slast (proxyFrom xs) .:+: asp_sempty)+    xs emptyAtt #. slast @ a

@@ -1,111 +0,0 @@------------------------------------------------------------------------------------ Module      :  Main--- Copyright   :--- License     :  AllRightsReserved------ Maintainer  :--- Stability   :--- Portability :------ |----------------------------------------------------------------------------------{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Main where---import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1---- data DefinitionList---    = DLCons { dlHd :: Definition, dlTl :: DefinitionList } | DLNil { dlNil :: () }---data Const-    =   ConstString String-    |   ConstInt    Int-    |   ConstChar   Char-    deriving(Show, Eq)--type WrapConst = Const-type StringList = [String]---- $(typeList "EList" "Expression")--- fromListEList = foldr ConsEList NilEList -- could be generated by typeList--data Definition-    =   Definition {-            dName       :: String-    ,       dArgs       :: StringList-    ,       dExpression :: Expression-    ,       dWhere      :: DefinitionList-    }  --type DefinitionList = [Definition]-type EList = [Expression]--data Expression-    =   Application { eFn :: Expression, eArgs :: EList }-    |   Atom { eAtom :: String }-    |   Lambda { eFormalArgs :: StringList, eBody :: Expression }-    |   Constant { eConst :: WrapConst }---$(deriveAG ''Definition)--fromListEList = foldr ConsEList NilEList--$(attLabels ["xerror", "diLevel", "xerror2"])---asp_xerrorD () = synAspect xerror (nt_Definition .*. nt_Expression .*. nt_EList .*. hNil)-        ((++)::[String] -> [String] -> [String])  ([]::[String])-        ( p_Application .*. p_Definition .*. p_Atom .*. p_Lambda .*. p_Constant .*. hNil ) $ -- use rule-        emptyRecord---- could also be generated by typeList-asp_foldrEList f s = synAspect xerror (nt_EList .*. nt_Expression .*. hNil)-                f  s-                (p_ConsEList .*. p_NilEList .*. hNil)-                emptyRecord---asp_xerror () = asp_xerrorD () .+. asp_foldrEList ((\lhd ltl -> "o" : lhd ++ ltl)::[String] -> [String] -> [String]) ([]::[String])--asp_xerror2 () = synAspect xerror2 (nt_Definition .*. nt_Expression .*. nt_EList .*. hNil)-        ((++)::[String] -> [String] -> [String])  ([]::[String])-        ( p_Application .*. p_Atom .*. p_Lambda .*. p_Constant .*. p_ConsEList .*. p_NilEList .*. hNil ) $ -- use rule-        p_Definition .=. (def $ at lhs >>= \lhs -> do return [show $ lhs # diLevel ]) .*.-        emptyRecord--{--asp_diLevel () = inhAspect diLevel ( nt_Expression .*. hNil ) ( p_Application .*. p_Lambda .*. hNil ) $-    p_Definition .=. (def $ at lhs >>= \lhs -> return $ (ch_dExpression .=. (lhs # diLevel) + 1) .*. emptyRecord)-    .*. emptyRecord--}---ex :: Expression-ex = Application (Lambda ["foo"] (Atom "x")) $ fromListEList $ map (Constant . ConstInt) [2, 2, 5]--dd = Definition {-        dName = "bar"-    ,   dArgs = ["x", "y"]-    ,   dExpression = ex-    ,   dWhere = []-    }--sem1 = sem_Definition (asp_xerror  ()) dd (diLevel .=. 55 .*. emptyRecord) # xerror-sem2 = sem_Definition (asp_xerror2 ()) dd (diLevel .=. 55 .*. emptyRecord) # xerror2--sem3 = sem_Definition (asp_xerror () .+. asp_xerror2 ())  dd (diLevel .=. 55 .*. emptyRecord) # xerror2--main = print sem1 >> print sem2 >> print sem3-

@@ -0,0 +1,117 @@+++++To use AspectAG in a module, some extensions must be enabled,+otherwise type errors we won't have readable type errors.+++> {-# LANGUAGE TemplateHaskell #-}+> {-# LANGUAGE FlexibleContexts  #-}+> {-# LANGUAGE GADTs #-}+> {-# LANGUAGE TypeFamilies #-}++> {-# LANGUAGE AllowAmbiguousTypes #-}+> {-# LANGUAGE NoMonomorphismRestriction #-}+> {-# LANGUAGE DataKinds #-}++> {-# LANGUAGE FlexibleInstances #-}+> {-# LANGUAGE MultiParamTypeClasses #-}+> {-# LANGUAGE TypeApplications #-}+++> module RepminTH where++> import Language.Grammars.AspectAG+> import Language.Grammars.AspectAG.TH+++To add a nonterminal we can use the TH function |addNont|:++> $(addNont "Root")+> $(addNont "Tree")++The produce the following code:++< type Nt_Root = NT "Root"+< nt_Root = Label :: Label Nt_Root++< type Nt_Tree = NT "Tree"+< nt_Tree = Label :: Label (Nt_Tree)+++After, we generate productions:+++> $(addProd "Leaf" ''Nt_Tree [("val", Ter ''Int)])+> $(addProd "Node" ''Nt_Tree [("l", NonTer ''Nt_Tree),("r", NonTer ''Nt_Tree)])+> $(addProd "Root" ''Nt_Root [("tree",NonTer ''Nt_Tree)])+++Semantic functions and a datatype by hand (for now)++> data Root = Root Tree deriving Show+> data Tree = Leaf Int | Node Tree Tree deriving Show+++> sem_Root asp (Root t)+>  = knitAspect p_Root asp $ ch_tree .=. sem_Tree asp t .*. EmptyRec++> sem_Tree asp (Leaf i)+>  = knitAspect p_Leaf asp $ ch_val .=. sem_Lit i .*. EmptyRec+> sem_Tree asp (Node l r)+>  = knitAspect p_Node asp+>  $   ch_l .=. sem_Tree asp l+>  .*. ch_r .=. sem_Tree asp r+>  .*. EmptyRec+++> $(attLabels [("sres", ''Tree), ("smin", ''Int), ("ival", ''Int)])++> asp_smin+>  =   syn smin p_Node (min @ Int <$> at ch_l smin <*> at ch_r smin)+>  .+: syn smin p_Leaf (ter ch_val)+>  .+: emptyAspect++> asp_sres+>  =    syn sres p_Node (Node <$> at ch_l sres <*> at ch_r sres)+>  .+:  syn sres p_Leaf (Leaf <$> at lhs ival)+>  .+:  syn sres p_Root (at ch_tree sres)+>  .+:  emptyAspect++> asp_ival+>  =    inh ival p_Root ch_tree (at ch_tree smin)+>  .+:  inh ival p_Node ch_l (at lhs ival)+>  .+:  inh ival p_Node ch_r (at lhs ival)+>  .+:  emptyAspect++> asp_repmin+>   = asp_smin .:+: asp_sres .:+: asp_ival++> repmin t+>   = sem_Root asp_repmin (Root t)+>          emptyAtt #. sres+++Another way to build  semantic functions:++> semRoot_Root asp tree+>  = knitAspect p_Root asp+>  $ ch_tree .=. tree .*. EmptyRec++> semTree_Node asp l r+>  = knitAspect p_Node asp+>  $    ch_l .=. l+>  .*.  ch_r .=. r+>  .*.  EmptyRec++> semTree_Leaf asp i+>  = knitAspect p_Leaf asp+>  $ ch_val .=. i .*. EmptyRec++> semR asp (Root t)    = semRoot_Root asp (semT asp t)+> semT asp (Node l r)  = semTree_Node asp (semT asp l) (semT asp r)+> semT asp (Leaf i)    = semTree_Leaf asp (sem_Lit i)+++> repmin' t = semR asp_repmin (Root t) emptyAtt #. sres

@@ -0,0 +1,69 @@+> {-# LANGUAGE DataKinds #-}+> {-# LANGUAGE TemplateHaskell #-}+> {-# LANGUAGE FlexibleContexts  #-}+> {-# LANGUAGE GADTs #-}+> {-# LANGUAGE TypeFamilies #-}++> {-# LANGUAGE AllowAmbiguousTypes #-}+> {-# LANGUAGE NoMonomorphismRestriction #-}+++> {-# LANGUAGE TypeApplications #-}+++> module RepminTHExt where++> import Language.Grammars.AspectAG+> import Language.Grammars.AspectAG.TH++> import RepminTH hiding (Tree, semT, Leaf)++Extending the grammar: New production, a ternary node++> $(addProd "Node3" ''Nt_Tree [("l3", NonTer ''Nt_Tree),+>                              ("c3", NonTer ''Nt_Tree),+>                              ("r3", NonTer ''Nt_Tree)])++A support datatype++> data Tree3+>   = Node2 Tree3 Tree3+>   | Node3 Tree3 Tree3 Tree3+>   | Leaf Int++semantic function for the new production++> semTree_Node3 asp l c r+>   =   knitAspect p_Node3 asp+>  $    ch_l3 .=. l+>  .*.  ch_c3 .=. c+>  .*.  ch_r3 .=. r+>  .*.  EmptyRec++> semT asp (Node2 l r)+>   = semTree_Node asp (semT asp l) (semT asp r)+> semT asp (Node3 l c r)+>   = semTree_Node3 asp (semT asp l) (semT asp c) (semT asp r)+> semT asp (Leaf i)+>   = semTree_Leaf asp (sem_Lit i)++> asp_repmin3+>  =    syn sres p_Node3 (do x <- at ch_l3 sres+>                            y <- at ch_c3 sres+>                            z <- at ch_r3 sres+>                            return (Node x (Node y z)))+>  .+: syn smin p_Node3 (min3  <$> at ch_l3 smin+>                              <*> at ch_c3 smin+>                              <*> at ch_r3 smin)+>  .+: inh ival p_Node3 ch_l3 (at lhs ival)+>  .+: inh ival p_Node3 ch_c3 (at lhs ival)+>  .+: inh ival p_Node3 ch_r3 (at lhs ival)+>  .+: asp_repmin+>  where min3 a b c = a `min` b `min` c++-- TODO: invert arg order+++> repmin'' t = semR3 asp_repmin3 (Root3 t) emptyAtt #. sres+> data Root3 = Root3 Tree3+> semR3 asp (Root3 t) = semRoot_Root asp (semT asp t)

@@ -1,80 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Calc where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1--import UU.Pretty hiding (par)----data types---------------------------------------------------------------------data AGItf = AGItf { expr :: Expr}-          deriving Show--data Expr = IConst {int::Int}-          | Add    {e1::Expr, e2::Expr}-          | Let    {lnm::String, val::Expr, body::Expr}-          | Var    {vnm::String}-          deriving Show---$(deriveAG ''AGItf)---allNT = nt_AGItf .*. nt_Expr .*. hNil- -----------------------------------------------------------------------------------$(attLabel "spp")--asp_spp () = synAspect spp allNT ((>|<)::PP_Doc->PP_Doc->PP_Doc)  (empty::PP_Doc) ( p_AGItf .*. hNil )-                       (   p_IConst .=. (\(Fam _ _ chi _) -> pp (chi # ch_int))-                       .*. p_Add    .=. (\(Fam _ _ chi _) -> ((chi # ch_e1) # spp) >|< "+" >|< ((chi # ch_e2) # spp))    -                       .*. p_Var    .=. (\(Fam _ _ chi _) -> pp (chi # ch_vnm))-                       .*. p_Let    .=. (\(Fam _ _ chi _) -> "[" >|< (chi # ch_lnm) >|< "=" >|<-                                                             ((chi # ch_val) # spp) >|< ":" >|< ((chi # ch_body) # spp) >|< "]")    -                       .*. emptyRecord )---$(attLabels ["ienv","sval"])--asp_ienv () = inhAspect ienv ( nt_Expr .*. hNil ) ( p_Add .*. p_Let .*. hNil )-                       (   p_Let    .=. (\(Fam _ _ chi par) -> (    ch_body .=. ((chi # ch_lnm), ((chi # ch_val) # sval)) : (par # ienv)  -                                                               .*.  emptyRecord))-                       .*. p_AGItf  .=. (\(Fam _ _ chi _)   -> (    ch_expr .=. ([] :: [(String,Int)])-                                                               .*.  emptyRecord))-                       .*. emptyRecord )--asp_sval () = synAspect sval allNT ((+)::Int->Int->Int)  (0::Int) ( p_AGItf .*. p_Add .*. hNil )-                       (   p_IConst .=. (\(Fam _ _ chi _)   -> chi # ch_int)-                       .*. p_Var    .=. (\(Fam _ _ chi par) -> maybe 0 id (lookup (chi # ch_vnm) (par # ienv)))-                       .*. p_Let    .=. (\(Fam _ _ chi _)   -> (chi # ch_body) # sval)    -                       .*. emptyRecord )---$(attLabel "ccount")---asp_ccount () =   chnAspect ccount allNT ( p_AGItf .*. p_IConst .*. p_Add .*. p_Let .*. p_Var .*. hNil )-                       emptyRecord-                       (   p_Add    .=. (\(Fam _ _ chi _) -> ((chi # ch_e2) # ccount) + 1 )    -                       .*. emptyRecord )-------example-----------------------------------------------------------------------ex = Let "x" (Add (Add (IConst 2) (IConst 3)) (IConst 1)) (Add (Var "x") (Var "x"))-- -expp  = sem_AGItf (asp_spp ()) (AGItf ex) () # spp-exval = sem_AGItf (asp_sval () .+. asp_ienv ()) (AGItf ex) () # sval-excnt = sem_AGItf (asp_ccount ()) (AGItf ex)  (ccount .=. 0 .*. emptyRecord) # ccount-

@@ -1,97 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Calc where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1--import UU.Pretty hiding (par)-----data types---------------------------------------------------------------------data AGItf = AGItf { expr :: Expr}-          deriving Show--data Expr = IConst {int::Int}-          | Add    {e1::Expr, e2::Expr}-          | Let    {lnm::String, val::Expr, body::Expr}-          | Var    {vnm::String}-          deriving Show---$(deriveAG ''AGItf)---allNT = nt_AGItf .*. nt_Expr .*. hNil- ----------------------------------------------------------------------------------$(attLabel "spp")--asp_spp () = synAspect spp allNT ((>|<)::PP_Doc->PP_Doc->PP_Doc)  (empty::PP_Doc) ( p_AGItf .*. hNil )-                       (   p_IConst .=. (def $ do  int <- at ch_int-                                                   return $ pp int )-                       .*. p_Add    .=. (def $ do  e1 <- at ch_e1-                                                   e2 <- at ch_e2-                                                   return $ (e1 # spp) >|< "+" >|< (e2 # spp) )    -                       .*. p_Var    .=. (def $ do  vnm <- at ch_vnm -                                                   return $ pp vnm )-                       .*. p_Let    .=. (def $ do  lnm  <- at ch_lnm-                                                   val  <- at ch_val-                                                   body <- at ch_body-                                                   return $ "[" >|< lnm >|< "=" >|< (val # spp) >|< ":" >|< (body # spp) >|< "]")    -                       .*. emptyRecord )---$(attLabels ["ienv","sval"])---asp_ienv () = inhAspect ienv ( nt_Expr .*. hNil ) ( p_Add .*. p_Let .*. hNil )-                       (   p_Let    .=. (def $ do  lnm <- at ch_lnm-                                                   val <- at ch_val-                                                   lhs <- at lhs-                                                   return  (    ch_body .=. ((lnm, val # sval) : (lhs # ienv))-                                                           .*.  emptyRecord))-                       .*. p_AGItf  .=. (def $ do  return  (    ch_expr .=. ([] :: [(String,Int)])-                                                           .*.  emptyRecord))--                       .*. emptyRecord )--asp_sval () = synAspect sval allNT ((+)::Int->Int->Int)  (0::Int) ( p_AGItf .*. p_Add .*. hNil )-                       (   p_IConst .=. (def $ do  int <- at ch_int-                                                   return int)-                       .*. p_Var    .=. (def $ do  vnm <- at ch_vnm-                                                   lhs <- at lhs-                                                   return $ maybe 0 id (lookup vnm (lhs # ienv)))-                       .*. p_Let    .=. (def $ do  body <- at ch_body-                                                   return $ body # sval)    -                       .*. emptyRecord )---$(attLabel "ccount")---asp_ccount () =   chnAspect ccount allNT ( p_AGItf .*. p_IConst .*. p_Add .*. p_Let .*. p_Var .*. hNil )-                       emptyRecord-                       (   p_Add    .=. (def $ do  e2 <- at ch_e2-                                                   return $ (e2 # ccount) + 1 )    -                       .*. emptyRecord )-------example-----------------------------------------------------------------------ex = Let "x" (Add (Add (IConst 2) (IConst 3)) (IConst 1)) (Add (Var "x") (Var "x"))-- -expp  = sem_AGItf (asp_spp ()) (AGItf ex) () # spp-exval = sem_AGItf (asp_sval () .+. asp_ienv ()) (AGItf ex) () # sval-excnt = sem_AGItf (asp_ccount ()) (AGItf ex)  (ccount .=. 0 .*. emptyRecord) # ccount--

@@ -1,83 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Repmin where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types---------------------------------------------------------------------data Root = Root { tree :: Tree}-          deriving Show--data Tree = Node {l::Tree, r::Tree}-          | Leaf {i::Int}-          deriving Show---$(deriveAG ''Root)-- ---repmin--------------------------------------------------------------------------$(attLabels ["smin","ival","sres"])--asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival () = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (   ch_tree .=. ((chi # ch_tree) # smin)-                                                            .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres () = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ _ _ par) -> Leaf (par # ival))-                        .*. emptyRecord )---asp_repmin () =   asp_sres () .+. asp_ival () .+. asp_smin ()--repmin tree = sem_Root (asp_repmin ()) (Root tree) () # sres---------example-----------------------------------------------------------------------examplet =    (Node (Node (Node (Leaf 1) (Leaf 4))-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Node (Leaf 9) (Leaf 8))-                          (Leaf 6)-                    )-              )--slidest = Node  {  l = Node  {  l = Node  {  l = Leaf { i = 5}-                                          ,  r = Leaf { i = 4}-                                          }-                             ,  r = Node  {  l = Leaf { i = 2}-                                          ,  r = Leaf { i = 3}-                                          }-                             }-                ,  r = Node  {  l = Leaf  {  i = 9 }-                             ,  r = Node  {  l = Leaf { i = 7}-                                          ,  r = Leaf { i = 6}-                                          }-                             }-                } --res_repmin = repmin examplet--

@@ -1,72 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Repmin where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types---------------------------------------------------------------------data Root = Root { tree :: Tree}-          deriving Show--data Tree = Node {l::Tree, r::Tree}-          | Leaf {i::Int}-          deriving Show---$(deriveAG ''Root)-- ---repmin--------------------------------------------------------------------------$(attLabels ["smin","ival","sres"])--asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (def $ liftM id (at ch_i))-                        .*. emptyRecord )--asp_ival () = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (def $ do  tree <- at ch_tree -                                                  return (   ch_tree .=. tree # smin-                                                         .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres () = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (def $ do  tree <- at ch_tree-                                                  return $ tree # sres)-                        .*. p_Leaf .=. (def $ do  lhs  <- at lhs -                                                  return $ Leaf (lhs # ival))-                        .*. emptyRecord )---asp_repmin () =  asp_smin () .+. asp_sres () .+. asp_ival ()--repmin tree = sem_Root (asp_repmin ()) (Root tree) () # sres---------example-----------------------------------------------------------------------examplet =    (Node (Node (Node (Leaf 1) (Leaf 4))-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Node (Leaf 9) (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--

@@ -1,107 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE EmptyDataDecls #-}--module Test where--import Language.Grammars.AspectAG--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types--------------------------------------------------------------------data Root = Root Tree-          deriving Show--data Tree = Node Tree Tree-          | Leaf Int-          deriving Show-----data types' dependent definitions------non terminals-nt_Root = proxy::Proxy Root-nt_Tree = proxy::Proxy Tree------productions-data P_Root;   p_Root    = proxy::Proxy P_Root-data P_Node;   p_Node    = proxy::Proxy P_Node-data P_Leaf;   p_Leaf    = proxy::Proxy P_Leaf------children labels-data Ch_tree;   ch_tree  = proxy::Proxy (Ch_tree, Tree)-data Ch_l;      ch_l     = proxy::Proxy (Ch_l,    Tree)-data Ch_r;      ch_r     = proxy::Proxy (Ch_r,    Tree)-data Ch_i;      ch_i     = proxy::Proxy (Ch_i,    Int)------catamorphism-sem_Tree  asp (Node left right) = knit (asp # p_Node) (   ch_l .=. sem_Tree asp left -                                                      .*. ch_r .=. sem_Tree asp right -                                                      .*. emptyRecord )-sem_Tree  asp (Leaf i         ) = knit (asp # p_Leaf) (   ch_i .=. sem_Lit i -                                                      .*. emptyRecord )-sem_Root  asp (Root t         ) = knit (asp # p_Root) (   ch_tree .=. sem_Tree asp t -                                                      .*. emptyRecord )-----repmin-------------------------------------------------------------------------data Att_smin;   smin    = proxy::Proxy Att_smin-data Att_ival;   ival    = proxy::Proxy Att_ival-data Att_sres;   sres    = proxy::Proxy Att_sres---asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival f  = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (   ch_tree .=. f (chi # ch_tree) -                                                            .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres () = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ _ _ par) -> Leaf (par # ival))-                        .*. emptyRecord )---asp_repmin () =  asp_smin () .+. asp_sres () .+. asp_ival (\c -> c # smin)--repmin tree = sem_Root (asp_repmin ()) (Root tree) () # sres-----average------------------------------------------------------------------------data Att_ssum;   ssum    = proxy::Proxy Att_ssum-data Att_scnt;   scnt    = proxy::Proxy Att_scnt--asp_ssum att f  = -              synAspect att ( nt_Tree .*. hNil ) ((+)::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> f chi )-                        .*. emptyRecord )--asp_avg () = asp_ssum scnt (const 1) .+. asp_ssum ssum (\c -> c # ch_i) .+. asp_sres () .+. asp_ival (\c -> div (c # ssum) (c # scnt))--avg tree  = sem_Root (asp_avg ()) (Root tree) () # sres-------example-----------------------------------------------------------------------examplet =    (Node (Node (Node (Leaf 1) (Leaf 4))-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Node (Leaf 9) (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--res_avg = avg examplet-

@@ -1,86 +0,0 @@-{-# OPTIONS -XEmptyDataDecls #-}-{-# LANGUAGE TemplateHaskell #-}--module Test where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types---------------------------------------------------------------------data Root = Root { tree :: Tree}-          deriving Show--data Tree = Node {l::Tree, r::Tree}-          | Leaf {i::Int}-          deriving Show---$(deriveAG ''Root)-- ---repmin--------------------------------------------------------------------------$(attLabels ["smin","ival","sres"])--asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival f  = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam chi _) -> (   ch_tree .=. f (chi # ch_tree) -                                                        .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres () = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ par) -> Leaf (par # ival))-                        .*. emptyRecord )---asp_repmin () =  asp_smin () .+. asp_sres () .+. asp_ival (\c -> c # smin)--repmin tree = sem_Root (asp_repmin ()) (Root tree) () # sres-------average------------------------------------------------------------------------$(attLabels ["ssum","scnt"])---asp_ssum att f  = -              synAspect att ( nt_Tree .*. hNil ) ((+)::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam chi _) -> f chi )-                        .*. emptyRecord )--asp_avg () = asp_ssum scnt (const 1) .+. asp_ssum ssum (\c -> c # ch_i) .+. asp_sres () .+. asp_ival (\c -> div (c # ssum) (c # scnt))--avg tree  = sem_Root (asp_avg ()) (Root tree) () # sres--------example-----------------------------------------------------------------------examplet =    (Node (Node (Node (Leaf 1) (Leaf 4))-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Node (Leaf 9) (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--res_avg = avg examplet-

@@ -1,123 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE EmptyDataDecls #-}--module Test where--import Language.Grammars.AspectAG--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types--------------------------------------------------------------------data Root = Root Tree-          deriving Show--data Tree = Node Tree Tree-          | Bin  Tree Int Tree-          | Leaf Int-          deriving Show--- ---data types' dependent definitions------non terminals-nt_Root = proxy::Proxy Root-nt_Tree = proxy::Proxy Tree------productions-data P_Root;   p_Root    = proxy::Proxy P_Root-data P_Node;   p_Node    = proxy::Proxy P_Node-data P_Bin;    p_Bin     = proxy::Proxy P_Bin-data P_Leaf;   p_Leaf    = proxy::Proxy P_Leaf------children labels-data Ch_tree;   ch_tree  = proxy::Proxy (Ch_tree, Tree)-data Ch_l;      ch_l     = proxy::Proxy (Ch_l,    Tree)-data Ch_r;      ch_r     = proxy::Proxy (Ch_r,    Tree)-data Ch_i;      ch_i     = proxy::Proxy (Ch_i,    Int)-data Ch_lb;     ch_lb    = proxy::Proxy (Ch_lb,   Tree)-data Ch_rb;     ch_rb    = proxy::Proxy (Ch_rb,   Tree)-data Ch_ib;     ch_ib    = proxy::Proxy (Ch_ib,   Int)------catamorphism-sem_Tree  asp (Node left right) = knit (asp # p_Node) (   ch_l .=. sem_Tree asp left -                                                      .*. ch_r .=. sem_Tree asp right -                                                      .*. emptyRecord )-sem_Tree  asp (Bin left i right) = knit (asp # p_Bin) (   ch_lb .=. sem_Tree asp left -                                                      .*. ch_ib .=. sem_Lit i -                                                      .*. ch_rb .=. sem_Tree asp right -                                                      .*. emptyRecord )-sem_Tree  asp (Leaf i         ) = knit (asp # p_Leaf) (   ch_i .=. sem_Lit i -                                                      .*. emptyRecord )--sem_Root  asp (Root t         ) = knit (asp # p_Root) (   ch_tree .=. sem_Tree asp t -                                                      .*. emptyRecord )-----repmin-------------------------------------------------------------------------data Att_smin;   smin    = proxy::Proxy Att_smin-data Att_ival;   ival    = proxy::Proxy Att_ival-data Att_sres;   sres    = proxy::Proxy Att_sres---asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int)  ( p_Node .*. p_Bin .*.  hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival f  = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. p_Bin .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (   ch_tree .=. f (chi # ch_tree) -                                                            .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres () = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ _ _ par) -> Leaf (par # ival))-                        .*. p_Bin  .=. (\(Fam _ _ chi _) -> Bin ((chi # ch_lb) # sres) (chi # ch_ib) ((chi # ch_rb) # sres))-                        .*. emptyRecord )---asp_repmin () =  asp_smin () .+. asp_sres () .+. asp_ival (\c -> c # smin)--repmin tree = sem_Root (asp_repmin ()) (Root tree) () # sres-----average------------------------------------------------------------------------data Att_ssum;   ssum    = proxy::Proxy Att_ssum-data Att_scnt;   scnt    = proxy::Proxy Att_scnt--asp_ssum ()  = -              synAspect ssum ( nt_Tree .*. hNil ) ((+)::Int->Int->Int)  (0::Int) ( p_Node .*. p_Bin .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi  # ch_i)-                        .*. emptyRecord )--asp_scnt ()  = -              synAspect scnt ( nt_Tree .*. hNil ) ((+)::Int->Int->Int)  (0::Int) ( p_Node .*. p_Bin .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> 1)-                        .*. emptyRecord )--asp_avg () = asp_scnt () .+. asp_ssum () .+. asp_sres () .+. asp_ival (\c -> div (c # ssum) (c # scnt))--avg tree  = sem_Root (asp_avg ()) (Root tree) () # sres------example----------------------------------------------------------------------examplet =    (Node (Bin  (Node (Leaf 1) (Leaf 4))-                          100-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Bin  (Leaf 9) 300 (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--res_avg = avg examplet-

@@ -1,93 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Test where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive---import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types---------------------------------------------------------------------data Root = Root { tree :: Tree}-          deriving Show--data Tree = Node {l::Tree, r::Tree}-          | Bin  {lb::Tree, ib::Int, rb::Tree}-          | Leaf {i::Int}-          deriving Show---$(deriveAG ''Root)-- ----repmin--------------------------------------------------------------------------$(attLabels ["smin","ival","sres"])---asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int)  ( p_Node .*. p_Bin .*.  hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival f  = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. p_Bin .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (   ch_tree .=. f (chi # ch_tree) -                                                            .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres () = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ _ _ par) -> Leaf (par # ival))-                        .*. p_Bin  .=. (\(Fam _ _ chi _) -> Bin ((chi # ch_lb) # sres) (chi # ch_ib) ((chi # ch_rb) # sres))-                        .*. emptyRecord )---asp_repmin () =  asp_smin () .+. asp_sres () .+. asp_ival (\c -> c # smin)--repmin tree = sem_Root (asp_repmin ()) (Root tree) () # sres------average------------------------------------------------------------------------$(attLabels ["ssum","scnt"])--asp_ssum ()  = -              synAspect ssum ( nt_Tree .*. hNil ) ((+)::Int->Int->Int)  (0::Int) ( p_Node .*. p_Bin .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi  # ch_i)-                        .*. emptyRecord )--asp_scnt ()  = -              synAspect scnt ( nt_Tree .*. hNil ) ((+)::Int->Int->Int)  (0::Int) ( p_Node .*. p_Bin .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> 1)-                        .*. emptyRecord )--asp_avg () = asp_scnt () .+. asp_ssum () .+. asp_sres () .+. asp_ival (\c -> div (c # ssum) (c # scnt))--avg tree  = sem_Root (asp_avg ()) (Root tree) () # sres-------example----------------------------------------------------------------------examplet =    (Node (Bin  (Node (Leaf 1) (Leaf 4))-                          100-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Bin  (Leaf 9) 300 (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--res_avg = avg examplet-

@@ -1,115 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE EmptyDataDecls #-}--module Test where--import Language.Grammars.AspectAG--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types--------------------------------------------------------------------data Root = Root Tree-          deriving Show--data Tree = Node Tree Tree-          | Leaf Int-          deriving Show-----data types' dependent definitions------non terminals-nt_Root = proxy::Proxy Root-nt_Tree = proxy::Proxy Tree------productions-data P_Root;   p_Root    = proxy::Proxy P_Root-data P_Node;   p_Node    = proxy::Proxy P_Node-data P_Leaf;   p_Leaf    = proxy::Proxy P_Leaf------children labels-data Ch_tree;   ch_tree  = proxy::Proxy (Ch_tree, Tree)-data Ch_l;      ch_l     = proxy::Proxy (Ch_l,    Tree)-data Ch_r;      ch_r     = proxy::Proxy (Ch_r,    Tree)-data Ch_i;      ch_i     = proxy::Proxy (Ch_i,    Int)------catamorphism-sem_Tree  asp (Node left right) = knit (asp # p_Node) (   ch_l .=. sem_Tree asp left -                                                      .*. ch_r .=. sem_Tree asp right -                                                      .*. emptyRecord )-sem_Tree  asp (Leaf i         ) = knit (asp # p_Leaf) (   ch_i .=. sem_Lit i -                                                      .*. emptyRecord )-sem_Root  asp (Root t         ) = knit (asp # p_Root) (   ch_tree .=. sem_Tree asp t -                                                      .*. emptyRecord )-----repmin-------------------------------------------------------------------------data Att_smin;   smin    = proxy::Proxy Att_smin-data Att_ival;   ival    = proxy::Proxy Att_ival-data Att_sres;   sres    = proxy::Proxy Att_sres---asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival a  = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (   ch_tree .=. (chi # ch_tree) # a-                                                            .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres a  = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ _ _ par) -> Leaf (par # a))-                        .*. emptyRecord )---asp_repmin a =  asp_smin () .+. asp_sres a .+. asp_ival smin--repmin tree = sem_Root (asp_repmin ival) (Root tree) () # sres-----chained attribute--------------------------------------------------------------data Att_ccnt;   ccnt    = proxy::Proxy Att_ccnt---asp_ccnt () = chnAspect ccnt (nt_Root .*. nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ _ _) -> (   ch_tree .=. (0::Int)-                                                          .*. emptyRecord ) ) -                        .*. emptyRecord )-                        (   p_Leaf .=. (\(Fam _ _ chi par) -> -                                            if chi # ch_i == (par # ival) -                                                 then (par # ccnt) +1 -                                                 else  par # ccnt-                                       )-                        .*. emptyRecord )----asp_cnt () = asp_ccnt () .+. asp_repmin ccnt--cnt tree  = sem_Root (asp_cnt ()) (Root tree) () # sres-------example-----------------------------------------------------------------------examplet =    (Node (Node (Node (Leaf 1) (Leaf 4))-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Node (Leaf 9) (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--res_cnt = cnt examplet-

@@ -1,91 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Test where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types---------------------------------------------------------------------data Root = Root { tree :: Tree}-          deriving Show--data Tree = Node {l::Tree, r::Tree}-          | Leaf {i::Int}-          deriving Show---$(deriveAG ''Root)-----repmin-------------------------------------------------------------------------$(attLabels ["smin","ival","sres"])---asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival a  = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (   ch_tree .=. (chi # ch_tree) # a-                                                            .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres a  = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ _ _ par) -> Leaf (par # a))-                        .*. emptyRecord )---asp_repmin a =  asp_smin () .+. asp_sres a .+. asp_ival smin--repmin tree = sem_Root (asp_repmin ival) (Root tree) () # sres-----chained attribute--------------------------------------------------------------$(attLabel "ccnt")---asp_ccnt () = chnAspect ccnt (nt_Root .*. nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ _ _) -> (   ch_tree .=. (0::Int)-                                                          .*. emptyRecord ) ) -                        .*. emptyRecord )-                        (   p_Leaf .=. (\(Fam _ _ chi par) -> -                                            if chi # ch_i == (par # ival) -                                                 then (par # ccnt) +1 -                                                 else  par # ccnt-                                       )-                        .*. emptyRecord )----asp_cnt () = asp_ccnt () .+. asp_repmin ccnt--cnt tree  = sem_Root (asp_cnt ()) (Root tree) () # sres-------example-----------------------------------------------------------------------examplet =    (Node (Node (Node (Leaf 1) (Leaf 4))-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Node (Leaf 9) (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--res_cnt = cnt examplet-

@@ -1,94 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE EmptyDataDecls #-}--module Test where--import Language.Grammars.AspectAG--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types--------------------------------------------------------------------data Root = Root Tree-          deriving Show--data Tree = Node Tree Tree-          | Leaf Int-          deriving Show-----data types' dependent definitions------non terminals-nt_Root = proxy::Proxy Root-nt_Tree = proxy::Proxy Tree------productions-data P_Root;   p_Root    = proxy::Proxy P_Root-data P_Node;   p_Node    = proxy::Proxy P_Node-data P_Leaf;   p_Leaf    = proxy::Proxy P_Leaf------children labels-data Ch_tree;   ch_tree  = proxy::Proxy (Ch_tree, Tree)-data Ch_l;      ch_l     = proxy::Proxy (Ch_l,    Tree)-data Ch_r;      ch_r     = proxy::Proxy (Ch_r,    Tree)-data Ch_i;      ch_i     = proxy::Proxy (Ch_i,    Int)------catamorphism-sem_Tree  asp (Node left right) = knit (asp # p_Node) (   ch_l .=. sem_Tree asp left -                                                      .*. ch_r .=. sem_Tree asp right -                                                      .*. emptyRecord )-sem_Tree  asp (Leaf i         ) = knit (asp # p_Leaf) (   ch_i .=. sem_Lit i -                                                      .*. emptyRecord )-sem_Root  asp (Root t         ) = knit (asp # p_Root) (   ch_tree .=. sem_Tree asp t -                                                      .*. emptyRecord )-----repmin-------------------------------------------------------------------------data Att_smin;   smin    = proxy::Proxy Att_smin-data Att_ival;   ival    = proxy::Proxy Att_ival-data Att_sres;   sres    = proxy::Proxy Att_sres---asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival f  = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (   ch_tree .=. f (chi # ch_tree) -                                                            .*. emptyRecord ) )-                        .*. p_Node .=. (\(Fam _ _ _ par) -> (   ch_l .=. (par # ival) + 1    -- difference with repmin (doesn't apply copy rule for ch_l)-                                                            .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres () = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ _ _ par) -> Leaf (par # ival))-                        .*. emptyRecord )---asp_repmin () =  asp_smin () .+. asp_sres () .+. asp_ival (\c -> c # smin)--repmin tree = sem_Root (asp_repmin ()) (Root tree) () # sres--------example-----------------------------------------------------------------------examplet =    (Node (Node (Node (Leaf 1) (Leaf 4))-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Node (Leaf 9) (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--

@@ -1,70 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Test where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types---------------------------------------------------------------------data Root = Root { tree :: Tree}-          deriving Show--data Tree = Node {l::Tree, r::Tree}-          | Leaf {i::Int}-          deriving Show---$(deriveAG ''Root)-----repmin-------------------------------------------------------------------------$(attLabels ["smin","ival","sres"])---asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival f  = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (   ch_tree .=. f (chi # ch_tree) -                                                            .*. emptyRecord ) )-                        .*. p_Node .=. (\(Fam _ _ _ par) -> (   ch_l .=. (par # ival) + 1    -- difference with repmin (doesn't apply copy rule for ch_l)-                                                            .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres () = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ _ _ par) -> Leaf (par # ival))-                        .*. emptyRecord )---asp_repmin () =  asp_smin () .+. asp_sres () .+. asp_ival (\c -> c # smin)--repmin tree = sem_Root (asp_repmin ()) (Root tree) () # sres--------example-----------------------------------------------------------------------examplet =    (Node (Node (Node (Leaf 1) (Leaf 4))-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Node (Leaf 9) (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--

@@ -1,117 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE EmptyDataDecls #-}--module Test where--import Language.Grammars.AspectAG--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types--------------------------------------------------------------------data Root = Root Tree-          deriving Show--data Tree = Node Tree Tree-          | Leaf Int-          deriving Show-----data types' dependent definitions------non terminals-nt_Root = proxy::Proxy Root-nt_Tree = proxy::Proxy Tree------productions-data P_Root;   p_Root    = proxy::Proxy P_Root-data P_Node;   p_Node    = proxy::Proxy P_Node-data P_Leaf;   p_Leaf    = proxy::Proxy P_Leaf------children labels-data Ch_tree;   ch_tree  = proxy::Proxy (Ch_tree, Tree)-data Ch_l;      ch_l     = proxy::Proxy (Ch_l,    Tree)-data Ch_r;      ch_r     = proxy::Proxy (Ch_r,    Tree)-data Ch_i;      ch_i     = proxy::Proxy (Ch_i,    Int)------catamorphism-sem_Tree  asp (Node left right) = knit (asp # p_Node) (   ch_l .=. sem_Tree asp left -                                                      .*. ch_r .=. sem_Tree asp right -                                                      .*. emptyRecord )-sem_Tree  asp (Leaf i         ) = knit (asp # p_Leaf) (   ch_i .=. sem_Lit i -                                                      .*. emptyRecord )-sem_Root  asp (Root t         ) = knit (asp # p_Root) (   ch_tree .=. sem_Tree asp t -                                                      .*. emptyRecord )-----repmin-------------------------------------------------------------------------data Att_smin;   smin    = proxy::Proxy Att_smin-data Att_ival;   ival    = proxy::Proxy Att_ival-data Att_sres;   sres    = proxy::Proxy Att_sres---asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival a  = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (   ch_tree .=. (chi # ch_tree) # a-                                                            .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres a  = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ _ _ par) -> Leaf (par # a))-                        .*. emptyRecord )---asp_repmin a =  asp_smin () .+. asp_sres a .+. asp_ival smin--repmin tree = sem_Root (asp_repmin ival) (Root tree) () # sres-----chained attribute--------------------------------------------------------------data Att_ccnt;   ccnt    = proxy::Proxy Att_ccnt---asp_ccnt () = chnAspect ccnt (nt_Root .*. nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ _ _)   -> (   ch_tree .=. (0::Int)-                                                            .*. emptyRecord ) )-                        .*. p_Node .=. (\(Fam _ _ _ par) -> (   ch_l .=. (par # ccnt) + 10  -- diference with scn (doesn't use chain rule for ch_l) -                                                            .*. emptyRecord) )  -                        .*. emptyRecord )-                        (   p_Leaf .=. (\(Fam _ _ chi par) -> -                                            if chi # ch_i == (par # ival) -                                                 then (par # ccnt) +1 -                                                 else  par # ccnt-                                       )-                        .*. emptyRecord )----asp_cnt () = asp_ccnt () .+. asp_repmin ccnt--cnt tree  = sem_Root (asp_cnt ()) (Root tree) () # sres-------example-----------------------------------------------------------------------examplet =    (Node (Node (Node (Leaf 1) (Leaf 4))-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Node (Leaf 9) (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--res_cnt = cnt examplet-

@@ -1,93 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Test where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1------data types---------------------------------------------------------------------data Root = Root { tree :: Tree}-          deriving Show--data Tree = Node {l::Tree, r::Tree}-          | Leaf {i::Int}-          deriving Show---$(deriveAG ''Root)-----repmin-------------------------------------------------------------------------$(attLabels ["smin","ival","sres"])---asp_smin () = synAspect smin ( nt_Tree .*. hNil ) (min::Int->Int->Int)  (0::Int) ( p_Node .*. hNil )-                        (   p_Leaf .=. (\(Fam _ _ chi _) -> chi # ch_i)-                        .*. emptyRecord )--asp_ival a  = inhAspect ival ( nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (   ch_tree .=. (chi # ch_tree) # a-                                                            .*. emptyRecord ) )-                        .*. emptyRecord )--asp_sres a  = synAspect sres ( nt_Root .*. nt_Tree .*. hNil ) Node (Leaf 0) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ chi _) -> (chi # ch_tree) # sres)-                        .*. p_Leaf .=. (\(Fam _ _ _ par) -> Leaf (par # a))-                        .*. emptyRecord )---asp_repmin a =  asp_smin () .+. asp_sres a .+. asp_ival smin--repmin tree = sem_Root (asp_repmin ival) (Root tree) () # sres-----chained attribute--------------------------------------------------------------$(attLabel "ccnt")---asp_ccnt () = chnAspect ccnt (nt_Root .*. nt_Tree .*. hNil ) ( p_Node .*. hNil )-                        (   p_Root .=. (\(Fam _ _ _ _) ->   (   ch_tree .=. (0::Int)-                                                            .*. emptyRecord ) )-                        .*. p_Node .=. (\(Fam _ _ _ par) -> (   ch_l .=. (par # ccnt) + 10  -- diference with scn (doesn't use chain rule for ch_l) -                                                            .*. emptyRecord) )  -                        .*. emptyRecord )-                        (   p_Leaf .=. (\(Fam _ _ chi par) -> -                                            if chi # ch_i == (par # ival) -                                                 then (par # ccnt) +1 -                                                 else  par # ccnt-                                       )-                        .*. emptyRecord )----asp_cnt () = asp_ccnt () .+. asp_repmin ccnt--cnt tree  = sem_Root (asp_cnt ()) (Root tree) () # sres-------example-----------------------------------------------------------------------examplet =    (Node (Node (Node (Leaf 1) (Leaf 4))-                          (Node (Leaf 2) (Leaf 1))-                    )--                    (Node (Node (Leaf 9) (Leaf 8))-                          (Leaf 6)-                    )-              )--res_repmin = repmin examplet--res_cnt = cnt examplet-

@@ -1,43 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Test where---import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1-- -data EList = ECons {e :: Expression, es :: EList} | ENil---data Expression-    =   Application { eFn :: Expression, eArgs :: EList }-    |   Atom { eAtom :: String }-    |   Lambda { eFormalArgs :: [String], eBody :: Expression }-    |   Constant { eConst :: Int }-- -$(deriveAG ''Expression)--$(attLabel "cantArgs")--allNT = nt_Expression .*. nt_EList .*. hNil---- counts the total number of 'eArgs' in an expression-asp_cantArgs () = synAspect cantArgs allNT -                            ((+)::Int->Int->Int)  (0::Int) ( p_Application .*. p_Atom .*. p_Lambda .*. p_Constant .*. p_ENil .*. hNil ) -- use rule-                            (   p_ECons .=. (def $ do  e  <- at ch_e                     -                                                       es <- at ch_es-                                                       return $ (e # cantArgs) + 1 + (es # cantArgs) )  -- add 1 for each element of the list-                            .*. emptyRecord )---ex = Application (Lambda ["x","y"] (Atom "x")) (ECons (Constant 2) $ ECons (Constant 5) ENil)--main = sem_Expression (asp_cantArgs ()) ex emptyRecord # cantArgs    -

@@ -1,48 +0,0 @@-{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Test where-import qualified Data.Set as S---import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1--import Language.Haskell.TH- -type EList = [Expression]-type MaybeInt = Maybe Int--data Expression-    =   Application { eFn :: Expression, eArgs :: EList }-    |   Atom { eAtom :: String }-    |   Lambda { eFormalArgs :: [String], eBody :: Expression }-    |   Constant { eConst :: MaybeInt } ---$(deriveAG ''Expression)--$(attLabel "cantArgs")--allNT = nt_Expression .*. nt_EList .*. hNil---- counts the total number of 'eArgs' in an expression-asp_cantArgs () = synAspect cantArgs allNT -                            ((+)::Int->Int->Int)  (0::Int) ( p_Application .*. p_Atom .*. p_Lambda .*. p_Constant .*. p_EList_Nil .*. -                                                             p_MaybeInt_Just .*. p_MaybeInt_Nothing .*. hNil ) -- use rule-                            (   p_EList_Cons .=. (def $ do  e  <- at ch_hd_EList_Cons                     -                                                            es <- at ch_tl_EList_Cons-                                                            return $ (e # cantArgs) + 1 + (es # cantArgs) )  -- add 1 for each element of the list-                            .*. emptyRecord )----ex = Application (Lambda ["x","y"] (Atom "x")) [Constant Nothing, Application (Atom "y") [Constant $ Just 3] ]---main = sem_Expression (asp_cantArgs ()) ex emptyRecord # cantArgs    -

@@ -1,1357 +1,655 @@-{-# OPTIONS -XMultiParamTypeClasses -XFunctionalDependencies 
-            -XFlexibleContexts -XFlexibleInstances 
-            -XUndecidableInstances 
-            -XExistentialQuantification 
-            -XEmptyDataDecls -XRank2Types
-            -XTypeSynonymInstances #-}
-
-{-| 
-    Library for First-Class Attribute Grammars.
-
-    The library is documented in the paper: /Attribute Grammars Fly First-Class. How to do aspect oriented programming in Haskell/
-
-
-    For more documentation see the AspectAG webpage: 
-    <http://www.cs.uu.nl/wiki/bin/view/Center/AspectAG>.
--}
-
-
-module Language.Grammars.AspectAG (
-
-              -- * Rules
-              Att, Fam(..), Chi, Rule,
- 
-              emptyRule,
-
-              instdef, locdef,
-              inhdef, syndef, 
-              inhmod, synmod,
-              inhupd, synupd,
-
-              -- ** Monadic
-
-              At(..), lhs, loc, def,
-              instdefM, locdefM,
-              inhdefM, syndefM, inh, syn,
-              inhmodM, synmodM,
-              inhupdM, synupdM,
-
-              -- ** Rules Composition
-              ext, adapt, rename, mapChildren, fixCst, graft,
-              agMacro, (~~>), (==>), (-->), (<.>), ignore, noChild,
-
-              withChild, withChildAtt,
-
-              -- * Aspects
-              Prd, (.+.),
-
-              -- * Semantic Functions
-              sem_Lit, knit,
-              SemType(),
-
-              -- * Common Patterns
-              copy, use, chain,
-
-              -- * Defining Aspects
-              inhAspect, synAspect, chnAspect,
-              attAspect, defAspect, 
-              Defs(..),
-              -- * Others
-              ListNT(..),
-
-              module Data.HList
-
-            ) where
-
-import Data.HList hiding ((.+.), hUpdateAtLabel)
-import Data.HList.FakePrelude
-
-import Control.Monad.Reader
-
--- | Field of an attribution.
-type Att att val = LVPair att val
-
--- | A Family 'Fam' contains a single attribution 'p' for the parent,
---   'l' for local attributes, 'ho' for higer-order attributes and
---   a collection of attributions 'c' for the children. 
-data Fam l ho c p = Fam l ho c p
-
-
--- | Field of the record of attributions for the children.
-type Chi ch atts = LVPair ch atts
-
--- | The type 'Rule' states that a rule takes as input the local attributes 'lf',
---   the higher-order attributes 'hof', the synthesized attributes 
---   of the children 'sc' and the inherited attributes of the parent 'ip' and returns
---   a function from the output constructed thus far 
---   (local attributes 'l', higher-order attributes 'ho', inherited attributes of the children 
---   'ic' and synthesized attributes of the parent 'sp') to the extended output.
-type Rule lf hof sc ip l ho ic sp l' ho' ic' sp' 
-          = Fam lf hof sc ip -> Fam l ho ic sp -> Fam l' ho' ic' sp'
-
--- | An 'emptyRule' does not introduce any new attribute.
-emptyRule :: Rule lf hof sc ip l ho ic sp l ho ic sp 
-emptyRule =  const id
-
--- | The function 'instdef' adds the definition of a higher-order attribute.
---   It takes a label 'att' representing the name of the new attribute, 
---   a value 'val' to be assigned to this attribute, and it builds a function which 
---   updates the output constructed thus far.
-instdef  ::  HExtend (Att att val) ho ho'
-         =>  att -> val -> (Fam l ho ic sp -> Fam l ho' ic sp)
-instdef  att val (Fam l ho ic sp) = Fam l (att .=. val .*. ho) ic sp
-
- 
--- | The function 'locdef' adds the definition of a local attribute.
---   It takes a label 'att' representing the name of the new attribute, 
---   a value 'val' to be assigned to this attribute, and it builds a function which 
---   updates the output constructed thus far.
-locdef  ::  HExtend (Att att val) l l'
-        =>  att -> val -> (Fam l ho ic sp -> Fam l' ho ic sp)
-locdef  att val (Fam l ho ic sp) = Fam (att .=. val .*. l) ho ic sp
-
-
--- | The function 'syndef' adds the definition of a synthesized attribute.
---   It takes a label 'att' representing the name of the new attribute, 
---   a value 'val' to be assigned to this attribute, and it builds a function which 
---   updates the output constructed thus far.
-syndef  ::  HExtend (Att att val) sp sp'
-        =>  att -> val -> (Fam l ho ic sp -> Fam l ho ic sp')
-syndef  att val (Fam l ho ic sp) = Fam l ho ic (att .=. val .*. sp)
-
-
--- | The function 'synmod' modifies the definition of a synthesized attribute.
---   It takes a label 'att' representing the name of the attribute, 
---   a value 'val' to be assigned to this attribute, and it builds a function which 
---   updates the output constructed thus far.
-synmod  ::  HUpdateAtLabel att val sp sp' 
-        =>  att -> val -> Fam l ho ic sp -> Fam l ho ic sp' 
-synmod att v (Fam l ho ic sp) = Fam l ho ic (hUpdateAtLabel att v sp) 
-
-
-synupd  :: (HasField att sp val, HUpdateAtLabel att val' sp sp') 
-        => att -> (val -> val') -> Fam l ho ic sp -> Fam l ho ic sp'
-synupd att f (Fam l ho ic sp) =  r'
-                               where  v  =  f (sp # att)
-                                      r' =  Fam l ho ic (hUpdateAtLabel att v sp) 
-
-
--- | The function 'inhdef' introduces a new inherited attribute for 
---   a collection of non-terminals.
---   It takes the following parameters:
---     'att': the attribute which is being defined,
---     'nts': the non-terminals with which this attribute is being associated, and
---     'vals': a record labelled with child names and containing values, 
---              describing how to compute the attribute being defined at each 
---              of the applicable child  positions.
---   It builds a function which updates the output constructed thus far.
-inhdef  ::  Defs att nts vals ic ic' 
-        =>  att -> nts -> vals -> (Fam l ho ic sp -> Fam l ho ic' sp)
-inhdef att nts vals (Fam l ho ic sp) = 
-        Fam l ho (defs att nts vals ic) sp
-
-
--- | The class 'Defs' is defined by induction over the record 'vals' 
---   containing the new definitions. 
---   The function 'defs' inserts each definition into the attribution 
---   of the corresponding child. 
-class Defs att nts vals ic ic'  | vals ic -> ic' where
-  defs :: att -> nts -> vals -> ic -> ic'
-
-instance Defs att nts (Record HNil) ic ic where
-  defs _ _ _ ic = ic
-
-instance  ( Defs att nts (Record vs) ic ic'
-          , HasLabel (Proxy (lch,t)) ic' mch
-          , HMember (Proxy t) nts mnts
-          , SingleDef  mch mnts att 
-                  (Chi (Proxy (lch,t)) vch) 
-                  ic' ic'' ) 
-      => Defs  att nts 
-               (Record (HCons  (Chi (Proxy (lch,t)) vch) vs)) 
-               ic ic'' 
-      where 
-  defs att nts ~(Record (HCons pch vs)) ic = 
-         singledef mch mnts att pch ic'  
-         where  ic'     = defs att nts (Record vs) ic
-                lch     = labelLVPair pch
-                mch     = hasLabel lch ic'
-                mnts    = hMember (sndProxy lch) nts
-
-
-class  SingleDef mch mnts att pv ic ic' 
-       | mch mnts pv ic -> ic' 
-  where singledef :: mch -> mnts -> att -> pv -> ic -> ic'
-
-
-data IncorrectDef l lch err
-data UndefNT t
-data UndefProd t
-data UndefAtt t
-
-instance Fail (IncorrectDef l lch (UndefNT t)) 
-         => SingleDef HTrue HFalse (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
- singledef = undefined
-
-instance Fail (IncorrectDef l lch (UndefProd (lch,t))) 
-         => SingleDef HFalse HTrue (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
- singledef = undefined
-
-
-instance  ( HasField lch ic och
-          , HExtend (Att att vch) och och'
-          , HUpdateAtLabel lch och' ic ic') 
-      => SingleDef  HTrue HTrue att (Chi lch vch) ic ic' 
-  where singledef _ _ att pch ic = 
-           hUpdateAtLabel lch (att .=. vch .*. och) ic  
-           where  lch  = labelLVPair  pch
-                  vch  = valueLVPair  pch
-                  och  = hLookupByLabel lch ic 
-
-
-
-
--- | The function 'inhmod' modifies an inherited attribute for 
---   a collection of non-terminals.
---   It takes the following parameters:
---     'att': the attribute which is being defined,
---     'nts': the non-terminals with which this attribute is being associated, and
---     'vals': a record labelled with child names and containing values, 
---              describing how to compute the attribute being defined at each 
---              of the applicable child  positions.
---   It builds a function which updates the output constructed thus far.||
-inhmod  ::  Mods att nts vals ic ic' 
-        =>  att -> nts -> vals -> (Fam l ho ic sp -> Fam l ho ic' sp)
-inhmod att nts vals (Fam l ho ic sp) = 
-        Fam l ho (mods att nts vals ic) sp
-
-
-
--- | The class 'Mods' is defined by induction over the record 'vals' 
---   containing the new definitions. 
---   The function 'mods' inserts each definition into the attribution 
---   of the corresponding child. 
-class Mods att nts vals ic ic'  | vals ic -> ic' where
-  mods :: att -> nts -> vals -> ic -> ic'
-
-instance Mods att nts (Record HNil) ic ic where
-  mods _ _ _ ic = ic
-
-instance  ( Mods att nts (Record vs) ic ic'
-          , HasLabel (Proxy (lch,t)) ic' mch
-          , HMember (Proxy t) nts mnts
-          , SingleMod  mch mnts att 
-                  (Chi (Proxy (lch,t)) vch) 
-                  ic' ic'' ) 
-      => Mods  att nts 
-               (Record (HCons  (Chi (Proxy (lch,t)) vch) vs)) 
-               ic ic'' 
-      where 
-  mods att nts ~(Record (HCons pch vs)) ic = 
-         singlemod mch mnts att pch ic'  
-         where  ic'     = mods att nts (Record vs) ic
-                lch     = labelLVPair pch
-                mch     = hasLabel lch ic'
-                mnts    = hMember (sndProxy lch) nts
-
-
-
-class  SingleMod mch mnts att pv ic ic' 
-       | mch mnts pv ic -> ic' 
-  where singlemod :: mch -> mnts -> att -> pv -> ic -> ic'
-
-
-data IncorrectMod l lch err
-
-instance Fail (IncorrectMod l lch (UndefNT t)) 
-         => SingleMod HTrue HFalse (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
- singlemod = undefined
-
-instance Fail (IncorrectMod l lch (UndefProd (lch,t))) 
-         => SingleMod HFalse HTrue (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
- singlemod = undefined
-
-
-instance  ( HasField lch ic och
-          , HUpdateAtLabel att vch och och'
-          , HUpdateAtLabel lch och' ic ic') 
-      => SingleMod  HTrue HTrue att (Chi lch vch) ic ic' 
-  where singlemod _ _ att pch ic = 
-           hUpdateAtLabel lch (hUpdateAtLabel att vch och) ic  
-           where  lch  = labelLVPair  pch
-                  vch  = valueLVPair  pch
-                  och  = hLookupByLabel lch ic 
-
-
--------------------------------------------------------------------------------
-inhupd  ::  Upds att nts vals ic ic' 
-        =>  att -> nts -> vals -> (Fam l ho ic sp -> Fam l ho ic' sp)
-inhupd att nts vals (Fam l ho ic sp) = 
-        Fam l ho (upds att nts vals ic) sp
-
-
-
-class Upds att nts vals ic ic'  | vals ic -> ic' where
-  upds :: att -> nts -> vals -> ic -> ic'
-
-instance Upds att nts (Record HNil) ic ic where
-  upds _ _ _ ic = ic
-
-instance  ( Upds att nts (Record vs) ic ic'
-          , HasLabel (Proxy (lch,t)) ic' mch
-          , HMember (Proxy t) nts mnts
-          , SingleUpd  mch mnts att 
-                  (Chi (Proxy (lch,t)) vch) 
-                  ic' ic'' ) 
-      => Upds  att nts 
-               (Record (HCons  (Chi (Proxy (lch,t)) vch) vs)) 
-               ic ic'' 
-      where 
-  upds att nts ~(Record (HCons pch vs)) ic = 
-         singleupd mch mnts att pch ic'  
-         where  ic'     = upds att nts (Record vs) ic
-                lch     = labelLVPair pch
-                mch     = hasLabel lch ic'
-                mnts    = hMember (sndProxy lch) nts
-
-
-
-class  SingleUpd mch mnts att pv ic ic' 
-       | mch mnts pv ic -> ic' 
-  where singleupd :: mch -> mnts -> att -> pv -> ic -> ic'
-
-
-data IncorrectUpd l lch err
-
-instance Fail (IncorrectUpd l lch (UndefNT t)) 
-         => SingleUpd HTrue HFalse (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
- singleupd = undefined
-
-instance Fail (IncorrectUpd l lch (UndefProd (lch,t))) 
-         => SingleUpd HFalse HTrue (Proxy l) (LVPair (Proxy (lch,t)) c) r r' where
- singleupd = undefined
-
-
-instance  ( HasField lch ic och
-          , HasField att och vch
-          , HUpdateAtLabel att vch' och och'
-          , HUpdateAtLabel lch och' ic ic') 
-      => SingleUpd  HTrue HTrue att (Chi lch (vch->vch')) ic ic' 
-  where singleupd _ _ att pch ic = 
-           hUpdateAtLabel lch (hUpdateAtLabel att vch' och) ic  
-           where  lch  = labelLVPair  pch
-                  fch  = valueLVPair  pch
-                  och  = hLookupByLabel lch ic 
-                  vch' = fch (och # att)
-
-
--------------------------------------------------------------------------------
-
--- Rules Composition
-
-
--- | Composition of two rules.
-ext  ::  Rule lf hof sc ip l' ho' ic' sp' l'' ho'' ic'' sp'' 
-     ->  Rule lf hof sc ip l  ho  ic  sp  l'  ho'  ic'  sp'
-     ->  Rule lf hof sc ip l  ho  ic  sp  l'' ho'' ic'' sp''  
-ext f g input = f input . g input
-
-
--- | Adaption of the childen of a rule.
-adapt  ::  Rule lf hof sc  ip li hoi ici  spi lo hoo ico  spo 
-       ->  (sc' -> sc) -> (ici' -> ici) -> (ico -> ico')
-       ->  Rule lf hof sc' ip li hoi ici' spi lo hoo ico' spo
-
-adapt rule fsc fici fico (Fam lf hof sc ip) (Fam li hoi ici spi) =
-               let (Fam lo hoo ico spo) = rule (Fam lf hof (fsc sc) ip) (Fam li hoi (fici ici) spi)
-               in  (Fam lo hoo (fico ico) spo)
-
--- | Children renaming.
-rename :: (RenRL s sc' sc, RenRL s ici' ici, RenLR s ico ico')  
-     => Rule lf hof sc  ip li hoi ici  spi lo hoo ico  spo
-     -> s
-     -> Rule lf hof sc' ip li hoi ici' spi lo hoo ico' spo
-rename asp s = adapt asp (renRL s) (renRL s) (renLR s)  
-
-class RenLR s r r'  | s r -> r' where  
-  renLR :: s -> r -> r'
-
-instance RenLR HNil r r where
-  renLR _ r = r           
-
-
-instance ( RenLR s (Record r') (Record r'') 
-         , HRLabelSet (HCons (LVPair lr' v) r''), HasField lr r v, H2ProjectByLabels (HCons lr HNil) r t r')
-         => RenLR    (HCons (LVPair lr lr')      s) 
-                     (Record r) 
-                     (Record (HCons (LVPair lr' v) r''))
-         where
-  renLR (HCons lp s) r =  hExtend (newLVPair lr' v) r''
-   where
-     lr  = labelLVPair lp
-     lr' = valueLVPair lp
-     v   = hLookupByLabel lr r
-     r'  = hDeleteAtLabel lr r
-     r'' = renLR s r'
-
-
-class RenRL s r r'  | s r -> r' where  
-  renRL :: s -> r -> r'
-
-instance RenRL HNil r r where
-  renRL _ r = r           
-
-                     
-instance ( RenRL s (Record r') (Record r'') 
-         , HRLabelSet (HCons (LVPair lr' v) r''), HasField lr r v, H2ProjectByLabels (HCons lr HNil) r t r')
-         => RenRL    (HCons (LVPair lr' lr)      s) 
-                     (Record r) 
-                     (Record (HCons (LVPair lr' v) r''))
-         where
-  renRL (HCons lp s) r =  hExtend (newLVPair lr' v) r''
-   where
-     lr' = labelLVPair lp
-     lr  = valueLVPair lp
-     v   = hLookupByLabel lr r
-     r'  = hDeleteAtLabel lr r
-     r'' = renRL s r'
-
-
--- | Children mapping.
-mapChildren :: (MapRL s sc' sc, MapRL s ici' ici, MapLR s ico ico')  
-     => Rule lf hof sc  ip li hoi ici  spi lo hoo ico  spo
-     -> s
-     -> Rule lf hof sc' ip li hoi ici' spi lo hoo ico' spo
-mapChildren asp s = adapt asp (mapRL s) (mapRL s) (mapLR s)  
-
-class MapLR s r r'  | s r -> r' where  
-  mapLR :: s -> r -> r'
-
-
-instance ( MapLR l r r') => MapLR (Record l) r r'
-         where
-  mapLR (Record l) r =  mapLR l r
-
-
-instance MapLR HNil r (Record HNil) where
-  mapLR _ _ = emptyRecord           
-
-
-instance ( MapLR s (Record r) (Record r'),
-           RecordLabels r' ls, HMember lr' ls b, 
-           MapLRB b (LVPair lr lr') (Record r) (Record r') (Record r''))
-         => MapLR    (HCons (LVPair lr lr')      s) 
-                     (Record r)
-                     (Record r'')
-         where
-  mapLR (HCons lp s) r =  mapLRB b lp r r'
-   where
-     lr' = valueLVPair lp
-     r'  = mapLR s r
-     b   = hMember lr' (recordLabels r')
-
-
-class MapLRB b s r r' r''  | b s r r' -> r'' where  
-  mapLRB :: b -> s -> r -> r' -> r''
-
-instance ( HRLabelSet (HCons (LVPair lr' v) r'), HasField lr r v)
-         => MapLRB   HFalse
-                     (LVPair lr lr') 
-                     (Record r)
-                     (Record r')
-                     (Record (HCons (LVPair lr' v) r'))
-         where
-  mapLRB _ lp r r' =  hExtend (newLVPair lr' v) r'
-   where
-     lr  = labelLVPair lp
-     lr' = valueLVPair lp
-     v   = hLookupByLabel lr r
-
-instance MapLRB   HTrue
-                     (LVPair lr lr')
-                     (Record r)
-                     (Record r')
-                     (Record r')
-         where
-  mapLRB _ _ _ r' =  r'
-
-
-
-class MapRL s r r'  | s r -> r' where  
-  mapRL :: s -> r -> r'
-
-instance ( MapRL l r r') => MapRL (Record l) r r'
-         where
-  mapRL (Record l) r =  mapRL l r
-
-
-instance MapRL HNil r (Record HNil) where
-  mapRL _ _ = emptyRecord
-
-                     
-instance ( MapRL s (Record r) (Record r') 
-         , HRLabelSet (HCons (LVPair lr' v) r'), HasField lr r v)
-         => MapRL    (HCons (LVPair lr' lr)      s) 
-                     (Record r) 
-                     (Record (HCons (LVPair lr' v) r'))
-         where
-  mapRL (HCons lp s) r =  hExtend (newLVPair lr' v) r'
-   where
-     lr' = labelLVPair lp
-     lr  = valueLVPair lp
-     v   = hLookupByLabel lr r
-     r'  = mapRL s r
-
-
-
-
--- | Fixing a constant as a child.
-fixCst
-  :: (RecordLabels r ls,
-      HRLabelSet (HCons (LVPair l (Record HNil)) r),
-      HExtend (LVPair l v) t2 l',
-      HRearrange ls r1 r',
-      HLabelSet ls,
-      H2ProjectByLabels (HCons l HNil) t10 t11 r1) =>
-     (Fam t t1 l' t3
-      -> Fam t4 t5 (Record (HCons (LVPair l (Record HNil)) r)) t6
-      -> Fam t7 t8 (Record t10) t9)
-     -> l
-     -> v
-     -> Fam t t1 t2 t3
-     -> Fam t4 t5 (Record r) t6
-     -> Fam t7 t8 (Record r') t9
-fixCst rule lch cst (Fam lf hof sc ip) (Fam li hoi ici spi) =
-               let  (Fam lo hoo ico spo) = rule (Fam lf hof (lch .=. cst .*. sc) ip) (Fam li hoi (lch .=. emptyRecord .*. ici) spi)
-                    ls = recordLabels ici 
-                    ico' = hRearrange ls (hDeleteAtLabel lch ico)
-               in   (Fam lo hoo ico' spo)
-
--- | Grafting one tree as a child of the other.
-graft ::                (HasField' b e (HCons (LVPair e v2) a3) v,
-                         HasField' b e (HCons (LVPair e (Record HNil)) a2) v1,
-                         HasField e t2 ip1,
-                         RecordLabels t ls2,
-                         HEq e e b,
-                         HRLabelSet a1,
-                         HRLabelSet (HCons (LVPair e (Record HNil)) a2),
-                         HRLabelSet a3,
-                         HRLabelSet (HCons (LVPair e e) r1),
-                         HRLabelSet (HCons (LVPair e v2) a3),
-                         HRLabelSet (HCons (LVPair e v) r'),
-                         HRLabelSet (HCons (LVPair e v1) r'1),
-                         HRLabelSet a2,
-                         HRLabelSet a,
-                         MapLR r ico1 r3,
-                         MapLR (HCons (LVPair e e) r1) ico (Record t2),
-                         MapRL r1 (Record (HCons (LVPair e (Record HNil)) a2)) (Record r'1),
-                         MapRL r (Record a1) sc,
-                         MapRL r (Record a) ici,
-                         MapRL r1 (Record (HCons (LVPair e v2) a3)) (Record r'),
-                         H2ProjectByLabels ls t1 a1 b2,
-                         H2ProjectByLabels ls1 t1 a3 b4,
-                         H2ProjectByLabels (HCons e HNil) t2 t3 t4,
-                         H2ProjectByLabels ls1 t a2 b3,
-                         H2ProjectByLabels ls t a b1,
-                         RecordValues r1 ls1,
-                         RecordValues r ls,
-                         HLeftUnion r3 (Record t4) (Record r2),
-                         HRearrange ls2 r2 r'2,
-                         HLabelSet ls2) =>
-                        Rule
-                          lf
-                          hof
-                          (Record (HCons (LVPair e v) r'))
-                          ip
-                          li
-                          hoi
-                          (Record (HCons (LVPair e v1) r'1))
-                          spi
-                          li1
-                          hoi1
-                          ico
-                          p
-                        -> Record r1
-                        -> e
-                        -> Rule lf hof sc ip1 li1 hoi1 ici (Record HNil) l ho ico1 v2
-                        -> Record r
-                        -> Fam lf hof (Record t1) ip
-                        -> Fam li hoi (Record t) spi
-                        -> Fam l ho (Record r'2) p
-
-graft rule1 chs1 lch rule2 chs2  (Fam lf hof sc ip) (Fam l ho ici spi)  =
-               let  spi1 = spi
-                    spi2 = emptyRecord
-
-                    -- ls1' and ls2 don't need to be disjoint
-                    ls1'   = recordValues chs1
-                    ls2    = recordValues chs2
-                    ici1'  = hProjectByLabels ls1' ici
-                    ici2   = hProjectByLabels ls2  ici
-                    ici1   = lch .=. emptyRecord .*. ici1' 
-                    sc1'   = hProjectByLabels ls1' sc
-                    sc2    = hProjectByLabels ls2  sc
-                    sc1    = lch .=. spo2 .*. sc1'
-
-                    ip1 = ip
-                    ip2 = ico1 # lch
-
-                    (Fam l1 ho1 ico1 spo1) = (mapChildren rule1 (lch .=. lch .*. chs1))  (Fam lf hof sc1 ip1) (Fam l  ho  ici1 spi1) 
-                    (Fam l2 ho2 ico2 spo2) = (mapChildren rule2 chs2)                    (Fam lf hof sc2 ip2) (Fam l1 ho1 ici2 spi2)
-
-                    ls = recordLabels ici 
-                    ico = hRearrange ls $ hLeftUnion ico2 (hDeleteAtLabel lch ico1)
-                    spo = spo1
-               in   (Fam l2 ho2 ico spo)
-
-
--- | A generalized version of 'graft' that grafts into or maps every children.
-agMacro ::              (RecordLabels r ls, HRearrange ls r1 r', HLabelSet ls) =>
-                        (  (Fam l1 ho1 c p1 -> Fam l ho c1 p -> Fam t t1 t2 p2)
-                        ,  ((l1, ho1, c2, Record r)
-                             -> (t, t1, t2, Record HNil, Record HNil)
-                             -> (l2, ho2, Record r1, c1, c)))
-                        -> Fam l1 ho1 c2 p1
-                        -> Fam l ho (Record r) p
-                        -> Fam l2 ho2 (Record r') p2
- 
-agMacro (rule1, chMap) (Fam lf hof sc ip) (Fam l ho ici spi)  =
-               let  spi1 = spi
-                    ip1  = ip
-
-                    (Fam l1 ho1 ico1 spo1) = rule1  (Fam lf hof sc1 ip1) (Fam l  ho  ici1 spi1) 
-                    (l2, ho2, ico, ici1, sc1) = chMap (lf, hof, sc, ici) (l1, ho1, ico1, emptyRecord, emptyRecord) 
-
-                    ls = recordLabels ici 
-                    ico' = hRearrange ls ico
-                    spo = spo1
-               in   (Fam l2 ho2 ico' spo)
-
-
-infixr 4 ~~>
-
--- | Child mapping definition, it reads /replaced by the constant/. 
-(~~>) ::                (HExtend (LVPair e (Record HNil)) l1 t9,
-                         HExtend (LVPair e v) l t10,
-                         H2ProjectByLabels (HCons e HNil) t4 t5 t6) =>
-                        e
-                        -> v
-                        -> (t, t1, t2, t3)
-                        -> (t7, t8, Record t4, l1, l)
-                        -> (t7, t8, Record t6, t9, t10)
-
-lch ~~> cst = \(_, _, _, _) (l1,ho1,ico1,ici1,sc1)  ->
-               let  ico1' = hDeleteAtLabel lch ico1
-                    ici1' = lch .=. emptyRecord .*. ici1
-                    sc1'  = lch .=. cst .*. sc1
-               in   (l1, ho1, ico1', ici1',  sc1')
-
-
-
-
-infixr 4 ==>
-
--- | Child mapping definition, it reads /replaced by/. 
-(==>) ::                (HExtend (LVPair l3 v) l2 t14,
-                         HExtend (LVPair l3 (Record HNil)) l t13,
-                         HasField l3 t7 p,
-                         H2ProjectByLabels (HCons l3 HNil) t7 t8 t9,
-                         HLeftUnion r (Record t9) t12) =>
-                        l3
-                        -> (Fam t t1 c p -> Fam l1 ho c1 (Record HNil) -> Fam t4 t5 t6 v,
-                            (t, t1, t2, t3)
-                            -> (t4, t5, t6, Record HNil, Record HNil)
-                            -> (t10, t11, r, c1, c))
-                        -> (t, t1, t2, t3)
-                        -> (l1, ho, Record t7, l, l2)
-                        -> (t10, t11, t12, t13, t14)
-
-lch ==> (rule2, chMap) = \(lf, hof, sc, ici) (l1,ho1,ico1,ici1,sc1)  ->
-               let  spi2 = emptyRecord
-
-
-                    ip2 = ico1 # lch
-
-                    (Fam l2 ho2 ico2 spo2) = rule2  (Fam lf hof sc2 ip2) (Fam l1 ho1 ici2 spi2)
-                                       
-                    (l2', ho2', ico2', ici2, sc2) = chMap (lf, hof, sc, ici) (l2, ho2, ico2, emptyRecord, emptyRecord) 
-  
-                    ico1' = hLeftUnion ico2' (hDeleteAtLabel lch ico1)
-                    ici1' = lch .=. emptyRecord .*. ici1
-                    sc1'  = lch .=. spo2 .*. sc1
-               in   (l2', ho2', ico1', ici1', sc1')
-
- 
-infixr 4 -->
-
--- | Child mapping definition, it reads /binds to/.
-(-->) ::                (HasField l2 t2 v2, HasField l3 r1 v1, HasField l3 r v,
-                         HRLabelSet (HCons (LVPair l3 v2) t6),
-                         H2ProjectByLabels (HCons l2 HNil) t2 t3 t4,
-                         H2ProjectByLabels (HCons l3 HNil) t4 t5 t6,
-                         HExtend (LVPair l2 v1) l1 t9, HExtend (LVPair l2 v) l t10) =>
-                        l2
-                        -> l3
-                        -> (t, t1, r, r1)
-                        -> (t7, t8, Record t2, l1, l)
-                        -> (t7, t8, Record (HCons (LVPair l3 v2) t6), t9, t10)
-
-lch --> lch2 = \(_, _, sc, ici) (l1,ho1,ico1,ici1,sc1)  ->
-               let  ico1' = hRenameLabel' lch lch2 ico1 --(hDeleteAtLabel lch2 ico1)
-                    ici1' = lch .=. (ici # lch2) .*. ici1
-                    sc1'  = lch .=. (sc # lch2) .*. sc1
-               in   (l1, ho1, ico1', ici1',  sc1')
-
-
-hRenameLabel' ::                (HasField l t v, HRLabelSet (HCons (LVPair l1 v) t4),
-                                 H2ProjectByLabels (HCons l1 HNil) t2 t3 t4,
-                                 H2ProjectByLabels (HCons l HNil) t t1 t2) =>
-                                l -> l1 -> Record t -> Record (HCons (LVPair l1 v) t4)
-hRenameLabel' l l' r = r'''
- where
-  v    = hLookupByLabel l  r
-  r'   = hDeleteAtLabel l  r
-  r''  = hDeleteAtLabel l' r'
-  r''' = hExtend (newLVPair l' v) r''
-
-infixr 2 <.>
-
-
-ignore :: HExtend (LVPair lch (Record HNil)) l t6
-       => lch
-       -> (t, t1, t2, t3) -> (t4, t5, l, t7, t8) -> (t4, t5, t6, t7, t8)
-ignore lch2 = \(_, _, sc, ici) (l1,ho1,ico1,ici1,sc1)  ->
-               let  ico1' = lch2 .=. emptyRecord .*. ico1
-                    ici1' = ici1
-                    sc1'  = sc1
-               in   (l1, ho1, ico1', ici1',  sc1')
-
-
-noChild ::  (t, t1, t2, t3) -> (t4, t5, t6, t7, t8) -> (t4, t5, t6, t7, t8)
-noChild (_, _, _, _) = id
-
-
--- | Composition of children mapping definitions for the function 'macro'.
-(<.>)  ::  ((lf,hof,sc,ici) -> (l2,ho2,ico1',ici1',sc1') -> (l3,ho3,ico1'',ici1'',sc1'')) 
-       ->  ((lf,hof,sc,ici) -> (l1,ho1,ico1,ici1,sc1) -> (l2,ho2,ico1',ici1',sc1')) 
-       ->  (lf,hof,sc,ici) -> (l1,ho1,ico1,ici1,sc1) -> (l3,ho3,ico1'',ici1'',sc1'')
-ch1 <.> ch2 = \inp -> (ch1 inp) . (ch2 inp)
-
-
-
-withChild ::  HasField lch sc v 
-          =>  lch -> (v -> Rule lf hof sc ip l ho ic sp l' ho' ic' sp')
-          ->  Rule lf hof sc ip l ho ic sp l' ho' ic' sp'
-withChild lch rule (Fam lf hof sc ip) (Fam li hoi ici spi) =
-                   rule (sc # lch) (Fam lf hof sc ip) (Fam li hoi ici spi)
-
-
-withChildAtt ::  (HasField lch sc r, HasField att r v) 
-             =>  lch -> att -> (v -> Rule lf hof sc ip l ho ic sp l' ho' ic' sp')
-             ->  Rule lf hof sc ip l ho ic sp l' ho' ic' sp'
-withChildAtt lch att rule (Fam lf hof sc ip) (Fam li hoi ici spi) =
-                   rule ((sc # lch) # att) (Fam lf hof sc ip) (Fam li hoi ici spi)
-
-
--- Monadic Interface 
-
-data Lhs
-lhs :: Proxy Lhs
-lhs = proxy 
-
-data Loc
-loc :: Proxy Loc
-loc = proxy 
-
-class At l m v | l -> v where
-  at :: l -> m v
-
-instance (HasField (Proxy (lch,nt)) chi v, MonadReader (Fam l ho chi par) m) 
-       => At (Proxy (lch,nt)) m v where
-  at lbl = liftM (\(Fam _ _ chi _) -> chi # lbl) ask
-
-
-instance MonadReader (Fam l ho chi par) m
-       => At (Proxy Lhs) m par where
-  at _ = liftM (\(Fam _ _ _ par) -> par) ask
-
-instance MonadReader (Fam l ho chi par) m
-       => At (Proxy Loc) m l where
-  at _ = liftM (\(Fam l _ _ _) -> l) ask
-
-
--- for the static case
-instance (MonadReader (Fam l ho chi par) m) 
-       => At (chi -> v) m v where
-  at lbl = liftM (\(Fam _ _ chi _) -> lbl chi) ask
-
-
-def :: Reader (Fam l ho chi par) a -> ((Fam l ho chi par) -> a)
-def = runReader
-
-
-
-instdefM  ::  (HExtend (Att att a) ho ho') 
-          =>  att -> Reader (Fam lf hof sc ip) a 
-          ->  Rule lf hof sc ip l ho ic sp l ho' ic sp
-instdefM att d inp  = instdef att (def d inp) 
-
-locdefM  ::  (HExtend (Att att a) l l') 
-         =>  att -> Reader (Fam lf hof sc ip) a 
-         ->  Rule lf hof sc ip l ho ic sp l' ho ic sp
-locdefM att d inp  = locdef att (def d inp) 
-
-inhdefM  ::  (Defs att nts a ic ic') 
-         =>  att-> nts-> Reader (Fam lf hof sc ip) a 
-         ->  Rule lf hof sc ip l ho ic sp l ho ic' sp
-inhdefM att nts d inp  = inhdef att nts (def d inp)
-
-
-inh  ::  (Defs att nts a ic ic') 
-     =>  att-> nts-> Reader (Fam lf hof sc ip) a 
-     ->  Rule lf hof sc ip l ho ic sp l ho ic' sp
-inh = inhdefM
-
-syndefM  ::  (HExtend (Att att a) sp sp') 
-         =>  att-> Reader (Fam lf hof sc ip) a 
-         ->  Rule lf hof sc ip l ho ic sp l ho ic sp'
-syndefM att d inp  = syndef att (def d inp) 
-
-
-syn  ::  (HExtend (Att att a) sp sp') 
-     =>  att-> Reader (Fam lf hof sc ip) a 
-     ->  Rule lf hof sc ip l ho ic sp l ho ic sp'
-syn = syndefM
-
-inhmodM  ::  (Mods att nts a ic ic') 
-         =>  att -> nts -> Reader (Fam lf hof sc ip) a 
-         ->  Rule lf hof sc ip l ho ic sp l ho ic' sp
-inhmodM att nts d inp  = inhmod att nts (def d inp) 
-
-inhupdM att nts d inp  = inhupd att nts (def d inp) 
-
-
-
-synmodM  ::  (HUpdateAtHNat n (Att att a) sp sp',HFind att ls n,RecordLabels sp ls) 
-         =>  att-> Reader (Fam lf hof sc ip) a 
-         ->  Rule lf hof sc ip l ho ic (Record sp) l ho ic (Record sp') 
-synmodM att d inp    = synmod att (def d inp) 
-
-synupdM att d inp    = synupd att (def d inp) 
-
-
--- | Field of an aspect. It associates a production 'prd' with a rule 'rule'.
-type Prd prd rule = LVPair prd rule
-
--- | The class 'Com' combines two aspects.
-class  Com r r' r'' | r r' -> r''
-  where (.+.) :: r -> r' -> r''
-
-instance Com r (Record HNil) r
-  where   r .+. _ = r
-
-instance  (  HasLabel lprd r b
-          ,  ComSingle b (Prd lprd rprd) r r'''
-          ,  Com r''' (Record r') r'')
-        => Com  r (Record (HCons (Prd lprd rprd) r')) r''
-  where
-   r .+. (Record (HCons prd r')) = r''
-    where  b       = hasLabel (labelLVPair prd) r
-           r'''    = comsingle b prd r
-           r''     = r''' .+. (Record r')
-
-
-class  ComSingle b f r r' | b f r -> r'
-  where comsingle :: b -> f -> r -> r'
-
-instance  (  HasField  lprd  r (Rule lf hof sc ip l' ho' ic' sp' l'' ho'' ic'' sp'')
-          ,  HUpdateAtLabel  lprd (Rule  lf   hof  sc    ip 
-                                         l    ho   ic    sp 
-                                         l''  ho'' ic''  sp'') 
-                             r r')
-         => ComSingle   HTrue (Prd lprd (Rule lf hof sc ip l ho ic sp l' ho' ic' sp')) 
-                        r r'
-   where 
-    comsingle _ f r  = hUpdateAtLabel n ((r # n) `ext` v) r
-     where  n  = labelLVPair f
-            v  = valueLVPair f
-
-instance ComSingle  HFalse f (Record r) (Record (HCons f r))
-   where comsingle _ f (Record r) = Record (HCons f r)
-
-
-
--- | Semantic function of a terminal
-sem_Lit :: a -> Record HNil -> a
-sem_Lit e (Record HNil) = e
-
-
--- | The function 'knit' takes the combined rules for a node and the 
---   semantic functions of the children, and builds a
---   function from the inherited attributes of the parent to its
---   synthesized attributes.
-knit  ::  (HLeftUnion fc ho fc', Kn fc' ic sc,  Empties fc' ec) 
-      =>  Rule l ho sc ip (Record HNil) (Record HNil) ec (Record HNil) l ho ic sp
-          -> fc -> ip -> sp
-knit  rule fc ip =  
-  let  fc' = hLeftUnion fc ho 
-       ec = empties fc'
-
-       (Fam l ho ic sp)   = rule  (Fam l            ho           sc  ip) 
-                                  (Fam emptyRecord  emptyRecord  ec  emptyRecord)
-       sc = kn fc' ic
-  in   sp
-
-
-class Kn fc ic sc | fc -> ic sc where  
-  kn :: fc -> ic -> sc
-
-instance Kn fc ic sc 
- => Kn (Record fc) (Record ic) (Record sc)  where
-  kn (Record fc) (Record ic) = Record $ kn fc ic
-
-
-instance Kn HNil HNil HNil where
-  kn _ _ = hNil
-
-instance Kn fcr icr scr
-         => Kn    (HCons (Chi lch (ich->sch))     fcr) 
-                  (HCons (Chi lch ich)            icr) 
-                  (HCons (Chi lch sch)            scr) 
-         where
-  kn  ~(HCons pfch fcr) ~(HCons pich icr) = 
-    let  scr        = kn fcr icr
-         lch        = labelLVPair  pfch
-         fch        = valueLVPair  pfch
-         ich        = valueLVPair  pich
-    in   HCons  (newLVPair lch (fch ich)) scr
-
-
-class Empties fc ec | fc -> ec where
-  empties :: fc -> ec
-
-instance Empties fc ec => Empties (Record fc) (Record ec)
-        where empties (Record fc) = Record $ empties fc
-
-instance Empties fcr ecr
-         => Empties  (HCons (Chi lch fch)            fcr) 
-                     (HCons (Chi lch (Record HNil))  ecr) 
-         where
-  empties  ~(HCons pch fcr)  = 
-    let  ecr     = empties fcr
-         lch     = labelLVPair  pch
-    in   HCons  (newLVPair lch emptyRecord) ecr 
-
-instance Empties HNil HNil where
-  empties _ = hNil
-
-
-class SemType t nt | t -> nt
-
-class ListNT nt tHd tTl where
- ch_hd :: Proxy (tHd, nt)
- ch_tl :: Proxy (tTl, [nt])
-
- ch_hd = proxy
- ch_tl = proxy
-
-
-
--- | A /copy/ rule copies an inherited attribute from the parent to all its children.
---   The function 'copy' takes the name of an attribute 'att' and 
---   an heterogeneous list of non-terminals 'nts' for which the attribute has to be defined,
---   and generates a copy rule for this.
-copy  ::   (Copy att nts vp ic ic', HasField att ip vp) 
-      =>   att -> nts -> Rule lf hof sc ip l ho ic sp l ho ic' sp
-copy att nts (Fam _ _ _ ip) = defcp att nts (ip # att)
-
-defcp  ::  Copy att nts vp ic ic' 
-       =>  att -> nts -> vp -> (Fam l ho ic sp -> Fam l ho ic' sp)
-defcp att nts vp (Fam l ho ic sp)  = 
-        Fam l ho (cpychi att nts vp ic) sp
-
-class  Copy att nts vp ic ic' | ic -> ic' where
-  cpychi  ::  att -> nts -> vp -> ic -> ic'
-
-instance Copy att nts vp (Record HNil) (Record HNil) where
-  cpychi  _ _ _ _ = emptyRecord
-
-instance  ( Copy att nts vp (Record ics) ics'
-          , HMember (Proxy t) nts mnts
-          , HasLabel att vch mvch 
-          , Copy'  mnts mvch att vp 
-                   (Chi (Proxy (lch, t)) vch)  
-                   pch
-          , HExtend pch ics' ic) 
-      => Copy  att nts vp 
-               (Record (HCons (Chi (Proxy (lch, t)) vch) ics))
-               ic
-      where 
-  cpychi att nts vp (Record (HCons pch ics)) = 
-            cpychi' mnts mvch att vp pch .*. ics'
-           where  ics'  = cpychi att nts vp (Record ics) 
-                  lch   = sndProxy (labelLVPair pch)
-                  vch   = valueLVPair pch
-                  mnts  = hMember lch nts
-                  mvch  = hasLabel att vch
-
-class Copy' mnts mvch att vp pch pch'  | mnts mvch pch -> pch' 
-  where
-   cpychi'  ::  mnts -> mvch -> att -> vp -> pch -> pch'
-
-instance Copy' HFalse mvch att vp pch pch where 
-  cpychi' _ _ _ _ pch = pch
-
-instance Copy' HTrue HTrue att vp pch pch where 
-  cpychi' _ _ _ _ pch = pch
- 
-instance HExtend (Att att vp) vch vch' 
-    => Copy' HTrue HFalse att vp  (Chi lch vch) 
-                           (Chi lch vch') where
-  cpychi' _ _ att vp pch = lch .=. (att .=. vp .*. vch) 
-            where  lch  = labelLVPair pch
-                   vch  = valueLVPair pch
-                   
-
-
--- | A /use/ rule declares a synthesized attribute that collects information
---   from some of the children.
---   The function 'use' takes the following arguments: the attribute to be defined, 
---   the list of non-terminals for which the attribute is defined,
---   a monoidal operator which combines the attribute values, 
---   and a unit value to be used in those cases where none of 
---   the children has such an attribute. 
-use  ::  (Use att nts a sc, HExtend (Att att a) sp sp') 
-     =>  att -> nts -> (a -> a -> a) -> a 
-         -> Rule lf hof sc ip l ho ic sp l ho ic sp'
-
-use att nts oper unit (Fam _ _ sc _) = syndef att val
-                    where val = case usechi att nts oper sc of
-                                  Just r  -> r
-                                  Nothing -> unit 
-
-
-class Use att nts a sc  where
-  usechi :: att -> nts -> (a -> a -> a) -> sc -> Maybe a
-
-instance Use att nts a sc => Use att nts a (Record sc) where
- usechi att nts oper (Record sc) = usechi att nts oper sc
-
-instance Use l nt a HNil where
- usechi _ _ _ _ = Nothing
-
-
-instance ( HMember (Proxy t) nts mnts
-         , Use' mnts att nts a (HCons (LVPair (Proxy (lch, t)) vch) scr))   
-       => Use att nts a (HCons (LVPair (Proxy (lch, t)) vch) scr) where
- usechi att nts oper ~sc@(HCons fa _) = usechi' mnts att nts oper sc
-                            where mnts = hMember (sndProxy $ labelLVPair fa) nts
-
-class Use' mnts att nts a sc where
- usechi' :: mnts -> att -> nts -> (a -> a -> a) -> sc -> Maybe a
-
-instance (HasField att (Record vch) a, Use att nts a scr)  => 
-         Use' HTrue att nts a (HCons (LVPair lch (Record vch)) scr) where
- usechi' _ att nts oper ~(HCons fa scr) = Just $ case usechi att nts oper scr of
-                                                   Just r  -> oper a r
-                                                   Nothing -> a 
-                            where a = valueLVPair fa # att
-
-instance (Use att nts a scr)  => 
-         Use' HFalse att nts a (HCons (LVPair lch b) scr) where
- usechi' _ att nts oper ~(HCons _ scr) = usechi att nts oper scr
-
-
--- | In the /chain/ rule a value is threaded in a depth-first way through the tree, 
---   being updated every now and then. For this we have chained attributes 
---   (both inherited and synthesized). If a definition for a synthesized attribute 
---   of the parent with this name is missing we look for the right-most child with a 
---   synthesized attribute of this name. If we are missing a definition for one 
---   of the children, we look for the right-most of its left siblings which 
---   can provide such a value, and if we cannot find it there, 
---   we look at the inherited attributes of the father.  
-chain  ::  (  Chain att nts val sc l ho ic sp ic' sp' 
-           ,  HasField att ip val )
-      => att -> nts -> Rule lf hof sc ip l ho ic sp l ho ic' sp'
-chain att nts (Fam _ _ sc ip) = defchn att nts (ip # att) sc
-
-
-class Chain att nts val sc l ho ic sp ic' sp' | sc ic sp -> ic' sp' where
-  defchn :: att -> nts -> val -> sc -> (Fam l ho ic sp -> Fam l ho ic' sp')
-
-instance  (  Chain' msp att nts val sc l ho ic sp ic' sp' 
-          ,  HasLabel att sp msp )
-      => Chain att nts val sc l ho ic sp ic' sp'
-  where
-  defchn att nts val sc inp@(Fam _ _ _ sp)  = defchn' msp att nts val sc inp 
-        where   msp        = hasLabel att sp
-               
-
-
-class Chain' msp att nts val sc l ho  ic sp ic' sp' | msp sc ic sp -> ic' sp' where
-  defchn' :: msp -> att -> nts -> val -> sc -> Fam l ho ic sp -> Fam l ho ic' sp'
-
-
-instance   (  ChnChi att nts val sc ic ic' 
-           ,  HExtend (Att att val) sp sp' )
-      => Chain' HFalse att nts val sc l ho ic sp ic' sp'
-  where
-  defchn' _ att nts val sc (Fam l ho ic sp)  = 
-        let (val',ic') = chnchi att nts val sc ic
-        in  Fam l ho ic' (att .=. val' .*. sp)
-
-instance   (  ChnChi att nts val sc ic ic' )
-      => Chain' HTrue att nts val sc l ho ic sp ic' sp
-  where
-  defchn' _ att nts val sc (Fam l ho ic sp)  = 
-        let (_,ic') = chnchi att nts val sc ic
-        in  Fam l ho ic' sp
-
-
-class ChnChi att nts val sc ic ic' | sc ic -> ic' where
-  chnchi :: att -> nts -> val -> sc -> ic -> (val,ic')
-
-
-instance ChnChi att nts val (Record HNil) (Record HNil) (Record HNil) where
-  chnchi  _ _ val _ _ = (val, emptyRecord)
-
-instance  ( ChnChi att nts val (Record scs) (Record ics) ics'
-          , HMember (Proxy t) nts mnts
-          , ChnChi'  mnts att val
-                     (Chi (Proxy (lch, t)) sch)  
-                     (Chi (Proxy (lch, t)) ich)  
-                     pch
-          , HExtend pch ics' ic) 
-      => ChnChi  att nts val 
-                 (Record (HCons (Chi (Proxy (lch, t)) sch) scs))
-                 (Record (HCons (Chi (Proxy (lch, t)) ich) ics))
-                 ic
-      where 
-  chnchi att nts val (Record (HCons psch scs)) (Record (HCons pich ics)) =  
-            let (val'',ics') = chnchi att nts val' (Record scs) (Record ics)  
-            in (val'',ich'.*. ics')
-           where  (val',ich') = chnchi' mnts att val psch pich  
-                  lch   = sndProxy (labelLVPair psch)
-                  mnts  = hMember lch nts
-
-class ChnChi' mnts att val sch ich ich'  | mnts sch ich -> ich' 
-  where
-   chnchi'  ::  mnts -> att -> val -> sch -> ich -> (val,ich')
-
-
-instance ChnChi' HFalse att val sch ich ich where 
-  chnchi' _ _ val _ ich = (val,ich)
-
-instance  ( HasLabel att sch msch 
-          , HasLabel att ich mich 
-          , ChnChi'' msch mich att val
-                     (Chi (Proxy (lch, t)) sch)  
-                     (Chi (Proxy (lch, t)) ich)  
-                     pch )
-      => ChnChi'  HTrue att val
-                  (Chi (Proxy (lch, t)) sch)  
-                  (Chi (Proxy (lch, t)) ich)  
-                  pch
-  where
-  chnchi' _ att val psch pich = chnchi'' msch mich att val psch pich
-           where  sch   = valueLVPair psch
-                  ich   = valueLVPair pich
-                  msch  = hasLabel att sch
-                  mich  = hasLabel att ich
-
-
-class ChnChi'' msch mich att val sch ich ich'  | msch mich sch ich -> ich' 
-  where
-   chnchi''  ::  msch -> mich -> att -> val -> sch -> ich -> (val,ich')
-
-
-
-instance Fail (IncorrectDef att lch (UndefAtt att)) 
-        => ChnChi'' HFalse HTrue att val sch (Chi lch ich) ich' where 
-  chnchi'' _ _ _ _ _ _ = undefined
-
-instance Fail (IncorrectDef att lch (UndefAtt att)) 
-        => ChnChi'' HFalse HFalse att val sch (Chi lch ich) ich' where 
-  chnchi'' _ _ _ _ _ _ = undefined
-
-instance HasField att sch val
-        => ChnChi'' HTrue HTrue att val (Chi lch sch) ich ich where 
-  chnchi'' _ _ att _ psch ich = (sch # att,ich)
-             where sch = valueLVPair psch
-
-instance  (  HasField att sch val
-          ,  HExtend (Att att val) ich ich' )
-        => ChnChi'' HTrue HFalse att val (Chi lch sch) (Chi lch ich) (Chi lch ich') where 
-  chnchi'' _ _ att val psch pich = (sch # att, lch .=. (att .=. val .*. ich))
-             where  lch = labelLVPair psch
-                    sch = valueLVPair psch
-                    ich = valueLVPair pich 
-
--- | The function 'inhAspect' defines an inherited attribute aspect.
---   It takes as arguments: the name of the attribute 'att', 
---   the list 'nts' of non-terminals where the attribute is defined,
---   the list 'cpys' of productions where the copy rule has to be applied, 
---   and a record 'defs' containing the explicit definitions for some productions.
-inhAspect ::  (  AttAspect (FnInh att nts) defs defasp
-              ,  DefAspect (FnCpy att nts) cpys cpyasp
-              ,  Com cpyasp defasp inhasp)
-         => att -> nts -> cpys -> defs -> inhasp
-inhAspect att nts cpys defs 
-   =     (defAspect  (FnCpy att nts)  cpys)
-   .+.   (attAspect  (FnInh att nts)  defs) 
-
-
--- | The function 'synAspect' defines a synthesized attribute aspect. 
----  The rule applied is the use rule, 
---   which takes 'op' as the monoidal operator and 'unit' as the unit value. 
-synAspect ::  (  AttAspect (FnSyn att) defs defasp
-              ,  DefAspect (FnUse att nts op unit) uses useasp
-              ,  Com useasp defasp synasp) 
-         => att -> nts -> op -> unit -> uses -> defs -> synasp
-synAspect att nts op unit uses defs 
-   =     (defAspect  (FnUse att nts op unit)    uses)
-   .+.   (attAspect  (FnSyn att)                defs)
-
-
--- | A chained attribute definition introduces both an inherited 
---   and a synthesized attribute. In this case the pattern to be applied is the chain rule. 
-chnAspect ::  (  DefAspect (FnChn att nts) chns chnasp
-              ,  AttAspect (FnInh att nts) inhdefs inhasp
-              ,  Com chnasp inhasp asp
-              ,  AttAspect (FnSyn att) syndefs synasp
-              ,  Com asp synasp  asp') 
-         => att -> nts -> chns -> inhdefs -> syndefs -> asp'
-chnAspect att nts chns inhdefs syndefs 
-   =     (defAspect  (FnChn att nts)   chns)
-   .+.   (attAspect  (FnInh att nts)   inhdefs)
-   .+.   (attAspect  (FnSyn att)       syndefs)
-
-
-
-class AttAspect rdef defs rules | rdef defs -> rules 
-   where attAspect :: rdef -> defs -> rules
-
-instance  (  AttAspect rdef (Record defs) rules
-          ,  Apply rdef def rule  
-          ,  HExtend (Prd lprd rule) rules rules' )  
-         => AttAspect  rdef 
-                       (Record (HCons  (Prd lprd def) 
-                                       defs)) 
-                       rules' 
-  where
-   attAspect rdef (Record (HCons def defs)) = 
-         let  lprd = (labelLVPair def)
-         in   lprd .=. apply rdef (valueLVPair def) 
-              .*.  attAspect rdef (Record defs)   
-
-
-instance AttAspect rdef (Record HNil) (Record HNil) 
-  where attAspect _ _ = emptyRecord
-
-{-
-data FnSyn att = FnSyn att
-
-instance  (HExtend (LVPair att val) sp sp', TypeCast (Rule sc ip ic sp ic sp') r)
-         => Apply  (FnSyn att) (Fam sc ip -> val) r
-                    where 
-  apply (FnSyn att) f =  typeCast $ syndef att . f 
-
-data FnInh att nt = FnInh att nt
-
-instance  (Defs att nts vals ic ic', TypeCast (Rule sc ip ic sp ic' sp) r)
-         => Apply  (FnInh att nts) (Fam sc ip -> vals) r
-                    where 
-  apply (FnInh att nts) f = typeCast $ inhdef att nts . f 
--}
-
-data FnSyn att = FnSyn att
-
-instance  HExtend (LVPair att val) sp sp'
-         => Apply  (FnSyn att) (Fam lf hof sc ip -> val) 
-                   (Rule lf hof sc ip l ho ic sp l ho ic sp') where 
-  apply (FnSyn att) f =  syndef att . f 
-
-data FnInh att nt = FnInh att nt
-
-instance  Defs att nts vals ic ic'
-         => Apply  (FnInh att nts) (Fam lf hof sc ip -> vals) 
-                   (Rule lf hof sc ip l ho ic sp l ho ic' sp) where 
-  apply (FnInh att nts) f = inhdef att nts . f 
-
-
-
-class DefAspect deff prds rules | deff prds -> rules 
-  where defAspect :: deff -> prds -> rules
-
-instance DefAspect deff HNil (Record HNil) where
-  defAspect _ _ = emptyRecord
-
-instance  (  Poly deff deff'
-          ,  DefAspect deff prds rules
-          ,  HExtend (Prd prd deff') rules rules' )  
-         => DefAspect deff (HCons prd prds) rules' where
-  defAspect deff (HCons prd prds)  =
-              prd .=. poly deff  .*.  defAspect deff prds   
-
-
-class Poly a b where
-  poly :: a -> b
-
-data FnCpy att nts = FnCpy att nts
-
-instance  (  Copy att nts vp ic ic'
-          ,  HasField att ip vp
-          ,  TypeCast (Rule lf hof sc ip l ho ic sp l ho ic' sp) r) 
-         => Poly  (FnCpy att nts) r  where 
-  poly (FnCpy att nts)  = typeCast $ copy att nts 
-
-
-data FnUse att nt op unit = FnUse att nt op unit
-
-instance  (  Use att nts a sc
-          ,  HExtend (LVPair att a) sp sp'
-          ,  TypeCast (Rule lf hof sc ip l ho ic sp l ho ic sp') r) 
-         => Poly  (FnUse att nts (a -> a -> a) a) r where 
-  poly (FnUse att nts op unit)  = typeCast $ use att nts op unit 
-
-
-data FnChn att nt = FnChn att nt
-
-instance  (  Chain att nts val sc l ho ic sp ic' sp'
-          ,  HasLabel att sp msp
-          ,  Chain' msp att nts val sc l ho ic sp ic' sp' 
-          ,  HasField att ip val 
-          ,  TypeCast (Rule lf hof sc ip l ho ic sp l ho ic' sp') r) 
-      => Poly   (FnChn att nts) r where 
-  poly (FnChn att nts) = typeCast $ chain att nts
-
-
-
------- HList
-
-class HBool b => HasLabel l r b | l r -> b
-instance HasLabel l r b => HasLabel l (Record r) b
-instance (HEq l lp b, HasLabel l r b', HOr b b' b'') 
-   => HasLabel l (HCons (LVPair lp vp) r) b''
-instance HasLabel l HNil HFalse
-
-hasLabel :: HasLabel l r b => l -> r -> b
-hasLabel = undefined
-
-class HUpdateAtLabel l v r r' | l v r -> r' where
-  hUpdateAtLabel :: l -> v -> r -> r'
-
-instance  (  RecordLabels r ls, HFind l ls n
-          ,  HUpdateAtHNat n (LVPair l v) r r')
-      => HUpdateAtLabel l v (Record r) (Record r')
-  where
-   hUpdateAtLabel l v rec@(Record r) = Record r'
-    where
-     n    = hFind l (recordLabels rec)
-     r'   = hUpdateAtHNat n (newLVPair l v) r
-
-
-
-sndProxy :: Proxy (a,b) -> Proxy b
-sndProxy _ = undefined
-
+{-|+Module      : Language.Grammars.AspectAG+Description : Main module, First-class attribute grammars+Copyright   : (c) Juan García Garland, Marcos Viera, 2019+License     : GPL+Maintainer  : jpgarcia@fing.edu.uy+Stability   : experimental+Portability : POSIX++-}++{-# LANGUAGE PolyKinds                 #-}+{-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE FunctionalDependencies    #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE PartialTypeSignatures     #-}+{-# LANGUAGE IncoherentInstances       #-}+{-# LANGUAGE AllowAmbiguousTypes       #-}++module Language.Grammars.AspectAG (+              module Language.Grammars.AspectAG,+              module Language.Grammars.AspectAG.HList,+              module Language.Grammars.AspectAG.GenRecord,+              module Language.Grammars.AspectAG.RecordInstances,+              module Language.Grammars.AspectAG.TPrelude+            ) where+++import Language.Grammars.AspectAG.HList+import Data.Kind+import Language.Grammars.AspectAG.TPrelude+import Data.Proxy+++import Language.Grammars.AspectAG.RecordInstances+import Language.Grammars.AspectAG.Require+import Language.Grammars.AspectAG.GenRecord+import GHC.TypeLits++import Data.Maybe+import GHC.Types+import Data.Type.Equality+import Control.Monad.Reader++class SemLit a where+  sem_Lit :: a -> Attribution ('[] :: [(Att,Type)])+               -> Attribution '[ '( 'Att "term" a , a)]+  lit     :: Label ('Att "term" a)+instance SemLit a where+  sem_Lit a _ = (Label =. a) *. emptyAtt+  lit         = Label @ ('Att "term" a)+++-- * Families and Rules++-- | In each node of the grammar, the "Fam" contains a single attribution+-- for the parent, and a collection (Record) of attributions for the children:+data Fam (prd :: Prod)+         (c :: [(Child, [(Att, Type)])])+         (p :: [(Att, Type)]) :: Type+ where+  Fam :: ChAttsRec prd c -> Attribution p -> Fam prd c p+++-- | Getters+chi :: Fam prd c p -> ChAttsRec prd c+chi (Fam c p) = c++par :: Fam prd c p -> Attribution p+par (Fam c p) = p++prd :: Fam prd c p -> Label prd+prd (Fam c p) = Label++-- | Rules are a function from the input family to the output family.+-- They are indexed by a production.+type Rule+  (prd  :: Prod)+  (sc   :: [(Child, [(Att, Type)])])+  (ip   :: [(Att,       Type)])+  (ic   :: [(Child, [(Att, Type)])])+  (sp   :: [(Att,       Type)])+  (ic'  :: [(Child, [(Att, Type)])])+  (sp'  :: [(Att,       Type)])+  = Fam prd sc ip -> Fam prd ic sp -> Fam prd ic' sp'++-- | Rules with context.+newtype CRule (ctx :: [ErrorMessage]) prd sc ip ic sp ic' sp'+  = CRule { mkRule :: (Proxy ctx -> Rule prd sc ip ic sp ic' sp')}+++-- * Aspects++-- | Context tagged aspects.+newtype CAspect (ctx :: [ErrorMessage]) (asp :: [(Prod, Type)] )+  = CAspect { mkAspect :: Proxy ctx -> Aspect asp}++-- | Empty Aspect.+emptyAspect :: CAspect ctx '[]+emptyAspect  = CAspect $ const EmptyRec+++-- | combination of Aspects+comAspect ::+ ( Require (OpComAsp al ar) ctx+ , ReqR (OpComAsp al ar) ~ Aspect asp)+ =>  CAspect ctx al -> CAspect ctx ar -> CAspect ctx asp+comAspect al ar+  = CAspect $ \ctx -> req ctx (OpComAsp (mkAspect al ctx) (mkAspect ar ctx))+++-- * Trace utils++-- | |traceAspect| adds context to an aspect.+traceAspect (_ :: Proxy (e::ErrorMessage))+  = mapCAspect $ \(_ :: Proxy ctx) -> Proxy @ ((Text "aspect ":<>: e) : ctx)++traceRule (_ :: Proxy (e::ErrorMessage))+  = mapCRule $ \(_ :: Proxy ctx) -> Proxy @ ((Text "rule ":<>: e) : ctx)+++mapCRule :: (Proxy ctx -> Proxy ctx')+          -> CRule ctx' prd sc ip ic sp ic' sp'+          -> CRule ctx  prd sc ip ic sp ic' sp'+mapCRule fctx (CRule frule) = CRule $ frule . fctx++mapCAspect fctx (CAspect fasp) = CAspect $+       mapCtxRec fctx . fasp . fctx++class MapCtxAsp (r :: [(Prod,Type)]) (ctx :: [ErrorMessage])+                                     (ctx' :: [ErrorMessage])  where+  type ResMapCtx r ctx ctx' :: [(Prod,Type)]+  mapCtxRec :: (Proxy ctx -> Proxy ctx')+            -> Aspect r -> Aspect (ResMapCtx r ctx ctx')++instance ( MapCtxAsp r ctx ctx' +         , ResMapCtx r ctx ctx' ~ r'+         , LabelSetF ('(l, CRule ctx prd sc ip ic sp ic' sp') : r')+         ~ True) =>+  MapCtxAsp ( '(l, CRule ctx' prd sc ip ic sp ic' sp') ': r) ctx ctx' where+  type ResMapCtx ( '(l, CRule ctx' prd sc ip ic sp ic' sp') ': r) ctx ctx'+     =  '(l, CRule ctx prd sc ip ic sp ic' sp') ':  ResMapCtx r ctx ctx'+  mapCtxRec fctx (ConsRec (TagField c l r) rs) = (ConsRec (TagField c l+                                                            (mapCRule fctx r))+                                                          (mapCtxRec fctx rs))++instance MapCtxAsp ('[] :: [(Prod,Type)]) ctx ctx' where+  type ResMapCtx ('[] :: [(Prod,Type)]) ctx ctx'+     =  '[]+  mapCtxRec _ EmptyRec = EmptyRec++extAspect+  :: RequireR (OpComRA ctx prd sc ip ic sp ic' sp' a) ctx (Aspect asp)+  => CRule ctx prd sc ip ic sp ic' sp'+     -> CAspect ctx a -> CAspect ctx asp+extAspect rule (CAspect fasp)+  = CAspect $ \ctx -> req ctx (OpComRA rule (fasp ctx))++(.+:) = extAspect+infixr 3 .+:++(.:+.) = flip extAspect+infixl 3 .:+.++(.:+:) = comAspect+infixr 4 .:+:++data OpComAsp  (al :: [(Prod, Type)])+               (ar :: [(Prod, Type)]) where+  OpComAsp :: Aspect al -> Aspect ar -> OpComAsp al ar++instance Require (OpComAsp al '[]) ctx where+  type ReqR (OpComAsp al '[]) = Aspect al+  req ctx (OpComAsp al _) = al++instance+  ( RequireR (OpComAsp al ar) ctx  (Aspect ar')+  , Require  (OpComRA ctx prd sc ip ic sp ic' sp' ar') ctx+  )+  => Require (OpComAsp al+       ( '(prd, CRule ctx prd sc ip ic sp ic' sp') ': ar)) ctx where+  type ReqR (OpComAsp al+       ( '(prd, CRule ctx prd sc ip ic sp ic' sp') ': ar))+    = ReqR (OpComRA ctx prd sc ip ic sp ic' sp'+            (UnWrap (ReqR (OpComAsp al ar))))+  req ctx (OpComAsp al (ConsRec prdrule ar))+   = req ctx (OpComRA (untagField prdrule)+                      (req ctx (OpComAsp al ar)))+++data OpComRA  (ctx  :: [ErrorMessage])+              (prd  :: Prod)+              (sc   :: [(Child, [(Att, Type)])])+              (ip   :: [(Att, Type)])+              (ic   :: [(Child, [(Att, Type)])])+              (sp   :: [(Att, Type)])+              (ic'  :: [(Child, [(Att, Type)])])+              (sp'  :: [(Att, Type)])+              (a     :: [(Prod, Type)])  where+  OpComRA :: CRule ctx prd sc ip ic sp ic' sp'+          -> Aspect a -> OpComRA ctx prd sc ip ic sp ic' sp' a++data OpComRA' (b :: Bool)+              (ctx  :: [ErrorMessage])+              (prd  :: Prod)+              (sc   :: [(Child, [(Att, Type)])])+              (ip   :: [(Att, Type)])+              (ic   :: [(Child, [(Att, Type)])])+              (sp   :: [(Att, Type)])+              (ic'  :: [(Child, [(Att, Type)])])+              (sp'  :: [(Att, Type)])+              (a     :: [(Prod, Type)])  where+  OpComRA' :: Proxy b -> CRule ctx prd sc ip ic sp ic' sp'+          -> Aspect a -> OpComRA' b ctx  prd sc ip ic sp ic' sp' a+++instance+ (Require (OpComRA' (HasLabel prd a) ctx prd sc ip ic sp ic' sp' a) ctx)+  => Require (OpComRA ctx prd sc ip ic sp ic' sp' a) ctx where+  type ReqR (OpComRA ctx prd sc ip ic sp ic' sp' a)+     = ReqR (OpComRA' (HasLabel prd a) ctx prd sc ip ic sp ic' sp' a)+  req ctx (OpComRA rule a)+     = req ctx (OpComRA' (Proxy @ (HasLabel prd a)) rule a)++instance+  (Require (OpExtend PrdReco prd (CRule ctx prd sc ip ic sp ic' sp') a)) ctx+  => Require (OpComRA' 'False ctx prd sc ip ic sp ic' sp' a) ctx where+  type ReqR (OpComRA' 'False ctx prd sc ip ic sp ic' sp' a)+    = ReqR (OpExtend PrdReco prd (CRule ctx prd sc ip ic sp ic' sp') a)+  req ctx (OpComRA' _ (rule :: CRule ctx prd sc ip ic sp ic' sp') asp)+    = req ctx (OpExtend (Label @ prd) rule asp)++instance+ ( Require (OpUpdate PrdReco prd (CRule ctx prd sc ip ic sp ic'' sp'') a) ctx+ , RequireR (OpLookup PrdReco prd a) ctx (CRule ctx prd sc ip ic sp ic' sp') + , (IC (ReqR (OpLookup PrdReco prd a))) ~ ic+ , (SP (ReqR (OpLookup PrdReco prd a))) ~ sp+ ) =>+  Require (OpComRA' 'True ctx prd sc ip ic' sp' ic'' sp'' a) ctx where+  type ReqR (OpComRA' 'True ctx prd sc ip ic' sp' ic'' sp'' a)+    = ReqR (OpUpdate PrdReco prd+           (CRule ctx prd sc ip+             (IC (ReqR (OpLookup PrdReco prd a)))+             (SP (ReqR (OpLookup PrdReco prd a)))+            ic'' sp'') a)+  req ctx (OpComRA' _ rule asp)+    = let prd     = Label @ prd+          oldRule = req ctx (OpLookup prd asp)+          newRule = rule `ext` oldRule+      in  req ctx (OpUpdate prd newRule asp)++++type family IC (rule :: Type) where+  IC (Rule prd sc ip ic sp ic' sp') = ic+  IC (CRule ctx prd sc ip ic sp ic' sp') = ic+type family SP (rule :: Type) where+  SP (Rule prd sc ip ic sp ic' sp') = sp+  SP (CRule ctx prd sc ip ic sp ic' sp') = sp++syndef+  :: ( RequireEq t t' ctx'+     , RequireR (OpExtend AttReco ('Att att t) t sp) ctx (Attribution sp')+     , ctx'+         ~ ((Text "syndef("+             :<>: ShowT ('Att att t) :<>: Text ", "+             :<>: ShowT prd :<>: Text ")") ': ctx)+     )+     => Label ('Att att t)+     -> Label prd+     -> (Proxy ctx' -> Fam prd sc ip -> t')+     -> CRule ctx prd sc ip ic sp ic sp'+syndef att prd f+  = CRule $ \ctx inp (Fam ic sp)+   ->  Fam ic $ req ctx (OpExtend att (f Proxy inp) sp)+++syndefM+  :: ( RequireEq t t' ctx'+     , RequireR (OpExtend AttReco ('Att att t) t sp) ctx (Attribution sp')+     , ctx'+         ~ ((Text "syndef("+             :<>: ShowT ('Att att t) :<>: Text ", "+             :<>: ShowT prd :<>: Text ")") ': ctx)+     )+     => Label ('Att att t)+     -> Label prd+     -> Reader (Proxy ctx', Fam prd sc ip) t'+     -> CRule ctx prd sc ip ic sp ic sp'+syndefM att prd = syndef att prd . def++syn = syndefM+inh = inhdefM+++synmod+  :: RequireR (OpUpdate AttReco ('Att att t) t r) ctx (Attribution sp')+  => Label ('Att att t)+     -> Label prd+     -> (Proxy+           ((('Text "synmod(" ':<>: ShowT ('Att att t)) :<>: Text ", "+                              ':<>: ShowT prd :<>: Text ")")+              : ctx)+         -> Fam prd sc ip -> t)+     -> CRule ctx prd sc ip ic' r ic' sp'+synmod att prd f+  = CRule $ \ctx  inp (Fam ic sp)+           -> Fam ic $ req ctx (OpUpdate att (f Proxy inp) sp)+++synmodM+  :: RequireR (OpUpdate AttReco ('Att att t) t r) ctx (Attribution sp')+  => Label ('Att att t)+     -> Label prd+     -> Reader ( Proxy ((('Text "synmod(" ':<>: ShowT ('Att att t)) :<>: Text ", "+                                          ':<>: ShowT prd :<>: Text ")")+                       : ctx)+               , Fam prd sc ip)+               t+     -> CRule ctx prd sc ip ic' r ic' sp'+synmodM att prd = synmod att prd . def++++inhdef+  :: ( RequireEq t t' ctx'+     , RequireR  (OpExtend AttReco ('Att att t) t r) ctx (Attribution v2)+     , RequireR (OpUpdate (ChiReco ('Prd prd nt))+                ('Chi chi ('Prd prd nt) ntch) v2 ic) ctx+                (ChAttsRec ('Prd prd nt) ic')+     , RequireR (OpLookup (ChiReco ('Prd prd nt))+                ('Chi chi ('Prd prd nt) ntch) ic) ctx+                (Attribution r)+     , RequireEq ntch ('Left n) ctx'+     , ctx' ~ ((Text "inhdef("+                :<>: ShowT ('Att att t)  :<>: Text ", "+                :<>: ShowT ('Prd prd nt) :<>: Text ", "+                :<>: ShowT ('Chi chi ('Prd prd nt) ntch) :<>: Text ")")+                ': ctx))+     =>+     Label ('Att att t)+     -> Label ('Prd prd nt)+     -> Label ('Chi chi ('Prd prd nt) ntch)+     -> (Proxy ctx' -> Fam ('Prd prd nt) sc ip -> t')+     -> CRule ctx ('Prd prd nt) sc ip ic sp ic' sp+inhdef  att prd chi f+  = CRule $ \ctx inp (Fam ic sp)+       -> let ic'   = req ctx (OpUpdate chi catts' ic)+              catts = req ctx (OpLookup chi ic)+              catts'= req ctx (OpExtend  att (f Proxy inp) catts)+          in  Fam ic' sp++++inhdefM+  :: ( RequireEq t t' ctx'+     -- , RequireR  (OpExtend AttReco ('Att att t) t r) ctx (Attribution v2)+     , RequireR  (OpExtend' (LabelSetF ('( 'Att att t, t) : r)) AttReco ('Att att t) t r) ctx (Attribution v2)+     , RequireR (OpUpdate (ChiReco ('Prd prd nt))+                ('Chi chi ('Prd prd nt) ntch) v2 ic) ctx+                (ChAttsRec ('Prd prd nt) ic')+     , RequireR (OpLookup (ChiReco ('Prd prd nt))+                ('Chi chi ('Prd prd nt) ntch) ic) ctx+                (Attribution r)+     , RequireEq ntch ('Left n) ctx'+     , ctx' ~ ((Text "inhdef("+                :<>: ShowT ('Att att t')  :<>: Text ", "+                :<>: ShowT ('Prd prd nt) :<>: Text ", "+                :<>: ShowT ('Chi chi ('Prd prd nt) ntch) :<>: Text ")")+                ': ctx))+     =>+     Label ('Att att t)+     -> Label ('Prd prd nt)+     -> Label ('Chi chi ('Prd prd nt) ntch)+     -> Reader (Proxy ctx', Fam ('Prd prd nt) sc ip) t'+     -> CRule ctx ('Prd prd nt) sc ip ic sp ic' sp +inhdefM att prd chi = inhdef att prd chi . def+++++inhmod+  :: ( RequireEq t t' ctx'+     , RequireR (OpUpdate AttReco ('Att att t) t r) ctx+                (Attribution v2)+     , RequireR (OpUpdate (ChiReco ('Prd prd nt))+                ('Chi chi ('Prd prd nt) ntch) v2 ic) ctx+                (ChAttsRec ('Prd prd nt) ic')+     , RequireR (OpLookup (ChiReco ('Prd prd nt))+                ('Chi chi ('Prd prd nt) ntch) ic) ctx+                (Attribution r)+     , RequireEq ntch ('Left n) ctx'+     , ctx' ~ ((Text "inhmod("+                :<>: ShowT ('Att att t)  :<>: Text ", "+                :<>: ShowT ('Prd prd nt) :<>: Text ", "+                :<>: ShowT ('Chi chi ('Prd prd nt) ntch) :<>: Text ")")+                ': ctx))+     =>+     Label ('Att att t)+     -> Label ('Prd prd nt)+     -> Label ('Chi chi ('Prd prd nt) ntch)+     -> (Proxy ctx' -> Fam ('Prd prd nt) sc ip -> t')+     -> CRule ctx ('Prd prd nt) sc ip ic sp ic' sp+inhmod att prd chi f+  = CRule $ \ctx inp (Fam ic sp)+       -> let ic'   = req ctx (OpUpdate chi catts' ic)+              catts = req ctx (OpLookup  chi ic)+              catts'= req ctx (OpUpdate  att (f Proxy inp) catts)+          in  Fam ic' sp+++inhmodM+  :: ( RequireEq t t' ctx'+     , RequireR (OpUpdate AttReco ('Att att t) t r) ctx+                (Attribution v2)+     , RequireR (OpUpdate (ChiReco ('Prd prd nt))+                ('Chi chi ('Prd prd nt) ntch) v2 ic) ctx+                (ChAttsRec ('Prd prd nt) ic')+     , RequireR (OpLookup (ChiReco ('Prd prd nt))+                ('Chi chi ('Prd prd nt) ntch) ic) ctx+                (Attribution r)+     , RequireEq ntch ('Left n) ctx'+     , ctx' ~ ((Text "inhmod("+                :<>: ShowT ('Att att t)  :<>: Text ", "+                :<>: ShowT ('Prd prd nt) :<>: Text ", "+                :<>: ShowT ('Chi chi ('Prd prd nt) ntch) :<>: Text ")")+                ': ctx))+     =>+     Label ('Att att t)+     -> Label ('Prd prd nt)+     -> Label ('Chi chi ('Prd prd nt) ntch)+     -> Reader (Proxy ctx', Fam ('Prd prd nt) sc ip) t'+     -> CRule ctx ('Prd prd nt) sc ip ic sp ic' sp+inhmodM att prd chi = inhmod att prd chi . def++ext' ::  CRule ctx prd sc ip ic sp ic' sp'+     ->  CRule ctx prd sc ip a b ic sp+     ->  CRule ctx prd sc ip a b ic' sp'+(CRule f) `ext'` (CRule g)+ = CRule $ \ctx input -> f ctx input . g ctx input++ext ::  RequireEq prd prd' (Text "ext":ctx) +     => CRule ctx prd sc ip ic sp ic' sp'+     -> CRule ctx prd' sc ip a b ic sp+     -> CRule ctx prd sc ip a b ic' sp'+ext = ext'+++infixr 6 .+.+(.+.) = ext+++data Lhs+lhs :: Label Lhs+lhs = Label++class At pos att m  where+ type ResAt pos att m+ at :: Label pos -> Label att -> m (ResAt pos att m)+++instance ( RequireR (OpLookup (ChiReco prd) ('Chi ch prd nt) chi) ctx+                    (Attribution r)+         , RequireR (OpLookup AttReco ('Att att t) r) ctx t'+         , RequireEq prd prd' ctx+         , RequireEq t t' ctx+         , RequireEq ('Chi ch prd nt) ('Chi ch prd ('Left ('NT n)))  ctx+         )+      => At ('Chi ch prd nt) ('Att att t)+            (Reader (Proxy ctx, Fam prd' chi par))  where+ type ResAt ('Chi ch prd nt) ('Att att t) (Reader (Proxy ctx, Fam prd' chi par))+         = t + at ch att+  = liftM (\(ctx, Fam chi _)  -> let atts = req ctx (OpLookup ch chi)+                                 in  req ctx (OpLookup att atts))+          ask++++instance+         ( RequireR (OpLookup AttReco ('Att att t) par) ctx t'+         , RequireEq t t' ctx+         )+ => At Lhs ('Att att t) (Reader (Proxy ctx, Fam prd chi par))  where+ type ResAt Lhs ('Att att t) (Reader (Proxy ctx, Fam prd chi par))+    = t+ at lhs att+  = liftM (\(ctx, Fam _ par) -> req ctx (OpLookup att par)) ask++def :: Reader (Proxy ctx, Fam prd chi par) a+    -> (Proxy ctx -> (Fam prd chi par) -> a)+def = curry . runReader++ter :: ( RequireR (OpLookup (ChiReco prd) pos chi) ctx+                  (Attribution r)+       , RequireR (OpLookup AttReco ('Att "term" t) r) ctx t'+       , RequireEq prd prd' ctx+       , RequireEq t t' ctx+       , RequireEq pos ('Chi ch prd (Right ('T t))) ctx+       , m ~ Reader (Proxy ctx, Fam prd' chi par) )+    =>  Label pos -> m (ResAt pos ('Att "term" t) m) + -- ter (ch :: Label ('Chi ch prd (Right ('T a))))  = at ch (lit @ a)+ter (ch :: Label ('Chi ch prd (Right ('T t))))+  = liftM (\(ctx, Fam chi _)  -> let atts = req ctx (OpLookup ch chi)+                                 in  req ctx (OpLookup (lit @ t) atts))+          ask++++class Kn (fcr :: [(Child, Type)]) (prd :: Prod) where+  type ICh fcr :: [(Child, [(Att, Type)])]+  type SCh fcr :: [(Child, [(Att, Type)])]+  kn :: Record fcr -> ChAttsRec prd (ICh fcr) -> ChAttsRec prd (SCh fcr)++instance Kn '[] prod where+  type ICh '[] = '[]+  type SCh '[] = '[] +  kn _ _ = emptyCh++instance ( lch ~ 'Chi l prd nt+         , Kn fc prd+         , LabelSet ('(lch, sch) : SCh fc)+         , LabelSet ('(lch, ich) : ICh fc)+         ) =>+  Kn ( '(lch , Attribution ich -> Attribution sch) ': fc) prd where+  type ICh ( '(lch , Attribution ich -> Attribution sch) ': fc)+    = '(lch , ich) ': ICh fc+  type SCh ( '(lch , Attribution ich -> Attribution sch) ': fc)+    = '(lch , sch) ': SCh fc+  kn ((ConsRec (TagField _ lch fch) (fcr :: Record fc)))+   = \((ConsCh pich icr) :: ChAttsRec prd ( '(lch, ich) ': ICh fc))+   -> let scr = kn fcr icr+          ich = unTaggedChAttr pich+      in ConsCh (TaggedChAttr lch+               (fch ich)) scr++++emptyCtx = Proxy @ '[]++knit' :: ( Kn fc prd+        , Empties fc prd)+ => CRule '[] prd (SCh fc) ip (EmptiesR fc) '[] (ICh fc) sp+  -> Record fc -> Attribution ip -> Attribution sp+knit' (rule :: CRule '[] prd (SCh fc) ip+              (EmptiesR fc) '[] (ICh fc) sp)+              (fc :: Record fc) ip+  = let (Fam ic sp) = mkRule rule emptyCtx+                       (Fam sc ip) (Fam ec emptyAtt)+        sc          = kn fc ic+        ec          = empties fc+    in  sp+++class Empties (fc :: [(Child,Type)]) (prd :: Prod) where+  type EmptiesR fc :: [(Child, [(Att, Type)])] +  empties :: Record fc -> ChAttsRec prd (EmptiesR fc)++instance Empties '[] prd where+  type EmptiesR '[] = '[]+  empties _ = emptyCh++instance ( Empties fcr prd+         , chi ~ 'Chi ch prd nt+         , LabelSet ( '(chi, '[]) ': EmptiesR fcr))+ => Empties ( '(chi, Attribution e -> Attribution a) ': fcr) prd where+  type EmptiesR ( '(chi, Attribution e -> Attribution a) ': fcr)+    = '(chi, '[]) ': EmptiesR fcr+  empties (ConsRec pch fcr)+    = let lch = labelTChAtt pch+      in  (lch .= emptyAtt) .* (empties fcr)++knit (ctx  :: Proxy ctx)+     (rule :: CRule ctx prd (SCh fc) ip (EmptiesR fc) '[] (ICh fc) sp)+     (fc   :: Record fc)+     (ip   :: Attribution ip)+  = let (Fam ic sp) = mkRule rule ctx+                       (Fam sc ip) (Fam ec emptyAtt)+        sc          = kn fc ic+        ec          = empties fc+    in  sp+++knitAspect (prd :: Label prd) asp fc ip+  = let ctx  = Proxy @ '[]+        ctx' = Proxy @ '[Text "knit" :<>: ShowT prd]+    in  knit ctx (req ctx' (OpLookup prd ((mkAspect asp) ctx))) fc ip+++class Use (att :: Att) (prd :: Prod) (nts :: [NT]) (a :: Type) sc+ where+  usechi :: Label att -> Label prd -> KList nts -> (a -> a -> a) -> ChAttsRec prd sc+         -> Maybe a++class Use' (mnts :: Bool) (att :: Att) (prd :: Prod) (nts :: [NT])+           (a :: Type) sc+ where+  usechi' :: Proxy mnts -> Label att -> Label prd -> KList nts+   -> (a -> a -> a)+   -> ChAttsRec prd sc -> Maybe a++instance Use prd att nts a '[] where+  usechi _ _ _ _ _ = Nothing++instance( HMember' nt nts+        , HMemberRes' nt nts ~ mnts+        , Use' mnts att prd nts a ( '( 'Chi ch prd ('Left nt), attr) ': cs))+  => Use att prd nts a ( '( 'Chi ch prd ('Left nt), attr) ': cs) where+  usechi att prd nts op ch+    = usechi' (Proxy @ mnts) att prd nts op ch++instance ( LabelSet ( '( 'Chi ch prd ('Left nt), attr) : cs)+         , Use att prd nts a cs)+  => Use' False att prd nts a ( '( 'Chi ch prd ('Left nt), attr) ': cs)+ where+  usechi' _ att prd nts op (ConsCh _ cs) = usechi att prd nts op cs++instance ( Require (OpLookup AttReco att attr)+           '[('Text "looking up attribute " ':<>: ShowT att)+              ':$$: ('Text "on " ':<>: ShowT attr)]+         , ReqR (OpLookup AttReco att attr) ~ a+         , Use att prd nts a cs+         , LabelSet ( '( 'Chi ch prd ('Left nt), attr) : cs)+         , WrapField (ChiReco prd) attr ~ Attribution attr)  --ayudín+  => Use' True att prd nts a ( '( 'Chi ch prd ('Left nt), attr) : cs) where+  usechi' _ att prd nts op (ConsCh lattr scr)+    = let attr = unTaggedChAttr lattr+          val  = attr #. att+      in  Just $ maybe val (op val) $ usechi att prd nts op scr++use att prd nts op unit+  = singAsp $ syndef att prd $ \_ fam -> maybe unit id (usechi att prd nts op $ chi fam)++singAsp r = r .+: emptyAspect+++tyAppAtt :: (forall b. Label ('Att name b)) -> Proxy a -> Label ('Att name a)+att `tyAppAtt` Proxy = att++tyAppChi :: (forall b. Label ('Chi name prd b)) -> Proxy a -> Label ('Chi name prd a)+att `tyAppChi` Proxy = att

@@ -1,284 +0,0 @@-{-# LANGUAGE TemplateHaskell, CPP #-}-{-# OPTIONS -XEmptyDataDecls #-}--module Language.Grammars.AspectAG.Derive (deriveAG, extendAG, deriveLang, addNT, addProd, attLabel, attLabels, chLabel, chLabels) where--import Language.Haskell.TH--import Data.Set (Set)-import Data.List (isPrefixOf, isSuffixOf, sort)-import qualified Data.Set as S--import Language.Grammars.AspectAG---- import Debug.Trace--data UserType  = UserD Name [Name] [Con]-type TypeDecls = (Set Name, [Dec])---declareLabel :: Name -> Name -> TypeQ -> Q [Dec]-declareLabel ndata nlabel t = do -            dtl <- dataD (cxt []) ndata [] [] []-            lbl <- declareFnLabel nlabel t-            return $ dtl:lbl--declareFnLabel ::  Name -> TypeQ -> Q [Dec]-declareFnLabel nlabel t = -             do sgn <- sigD nlabel (appT (conT $ mkName "Proxy") t)  -                let pxy = normalB [| proxy |]-                lbl <- funD nlabel [clause [] pxy []]-                return [sgn,lbl]--attLabel ::  String -> Q [Dec]-attLabel att = declareLabel attn (mkName att) (conT $ attn) -  where-      attn  = mkName $ "Att_" ++ att-      --attLabels ::  [String] -> Q [Dec]-attLabels = liftM concat . mapM attLabel--chLabel ::  String -> Name -> Q [Dec]-chLabel n t = chLabels [n] t--chLabels ::  [String] -> Name -> Q [Dec]-chLabels ns ty = (liftM concat) $ mapM (label ty . mkName) ns-  where-      label t n = declareLabel (chTName n) (chName n) (tyLabel (chTName n) t) -      tyLabel n t = appT (appT (conT $ mkName "(,)") (conT n)) (conT t) ---chLabels2 ::  [Name] -> [Type] -> Q [Dec]-chLabels2 ns ts = (liftM concat) $ zipWithM label ns ts-  where-      label n t = declareLabel (chTName n) (chName n) (tyLabel (chTName n) t) -      tyLabel n t = appT (appT (conT $ mkName "(,)") (conT n)) (return t) --chName,chTName,ntName,prdName,prdTName ::  Name -> Name-chName   cn = mkName $ "ch_" ++ nameBase cn -chTName  cn = mkName $ "Ch_" ++ nameBase cn -ntName   cn = mkName $ "nt_" ++ nameBase cn -prdName  cn = mkName $ "p_"  ++ nameBase cn -prdTName cn = mkName $ "P_"  ++ nameBase cn ---deriveAG :: Name -> Q [Dec]-deriveAG n = do-              (_,decl) <- derive n (S.empty,[]) --eval)-              return decl---extendAG :: Name -> [Name] -> Q [Dec]-extendAG n used = do-              (_,decl) <- derive n (S.fromList(used),[]) --eval)-              return decl--addNT :: String -> Q [Dec]-addNT nt = declareLabel ntn (ntName ntn ) (conT $ ntn)-    where ntn = mkName nt--addProd :: String -> [ (String, Name) ] -> Q [Dec]-addProd prod children = do-                let pn = mkName prod-                p  <- declareLabel (prdTName pn) (prdName pn) (conT $ prdTName pn)-                ch <- (liftM concat . mapM (\(a,b) -> chLabel a b)) children--                conargs <- newNames children-                bodyP <- [| knit $(aspV) $(childsP (map (mkName . fst) children) conargs) |] -                let semFCons = FunD (semPName pn) -                                    [(Clause (aspP:(map VarP conargs)) (NormalB bodyP) [])]---                return (semFCons:p++ch)--semName ::  Name -> Name-semName t = mkName ("sem_"++(nameBase t))--semPName ::  Name -> Name-semPName t = mkName ("semP_"++(nameBase t))--derive :: Name -> TypeDecls -> Q TypeDecls -derive n (stn,decl) = -    do-       info <- reify n -       if (S.member n stn || not (isNT info))  -          then return (stn,decl)-          else let stn' = S.insert n stn-               in  do-                      (UserD _ _ lc) <- getUserType info-                      ((s,d),fc)   <- foldM deriveCons ((stn',decl),[]) lc-                      if (isPrefixOf "EXT" (nameBase n))  -- type extensions start with EXT-                       then return (s,d)                      -                       else do let semDecl = FunD (semName n) fc-                               nt <- declareFnLabel (ntName n) (conT $ n)-                               return (s,semDecl:(nt++d))--deriveCons :: (TypeDecls,[Clause]) -> Con -> Q (TypeDecls,[Clause])-deriveCons ((stn,decl),fc) c =                     -    do-      let (cht,chn,cn) = getCtx c-      (stn',decl') <- foldM (\td t -> deriveList (typeNames t) td) (stn,decl) cht-      conargs <- newNames cht-      body <- [| knit ($(aspV) # $(attVar cn)) $(childs cht chn conargs) |]-      bodyP <- [| knit $(aspV) $(childsP chn conargs) |] -      let semF = Clause (pat cn conargs) (NormalB body) []-      let semFCons = FunD (semPName cn) -                          [(Clause (aspP:(map VarP conargs)) (NormalB bodyP) [])] -      lp <- declareLabel (prdTName cn) (prdName cn) (conT $ prdTName cn)-      lc <- chLabels2 chn cht-      return ((stn',semFCons:(lp++lc++decl')),semF:fc)---newNames ::  [t] -> Q [Name]-newNames []     = return []-newNames (_:as) = do-                   na  <- newName "x"-                   nas <- newNames as-                   return (na:nas)--pat ::  Name -> [Name] -> [Pat]-pat cn args | isSuffixOf ("_Cons") (nameBase cn) = [aspP, InfixP (VarP $ args !! 0) (mkName ":") (VarP $ args !! 1) ]-            | isSuffixOf ("_Nil")  (nameBase cn) = [aspP, ListP [] ]-            | isSuffixOf ("_Just") (nameBase cn) = [aspP, ConP (mkName "Just") (map VarP args) ]-            | isSuffixOf ("_Nothing")  (nameBase cn) = [aspP, ConP (mkName "Nothing") [] ]-            | otherwise =  [aspP, ConP cn (map VarP args)] --aspP ::  Pat-aspP = VarP $ mkName "asp"-aspV ::  ExpQ-aspV = varE $ mkName "asp"-attVar ::  Name -> ExpQ-attVar cn  = varE $ prdName cn-chVar ::  Name -> ExpQ-chVar  cn  = varE $ chName cn--childs ::  [Type] -> [Name] -> [Name] -> Q Exp-childs []     _      _      = [| emptyRecord |]-childs (t:ts) (n:ns) (p:ps) = case (typeName1 t) of-                                Just tn -> [| $(chVar n) .=. $(chFun tn p)  .*. $(childs ts ns ps) |]-                                Nothing -> [| $(childs ts ns ps) |]-childs _      _      _      = error "Impossible case!!"--childsP ::  [Name] -> [Name] -> Q Exp-childsP []     _      = [| emptyRecord |]-childsP (n:ns) (p:ps) = [| $(chVar n) .=. $(varE p)  .*. $(childsP ns ps) |]-childsP _      _      = error "Impossible case!!"--deriveList ::  [Name] -> TypeDecls -> Q TypeDecls-deriveList ns td = foldM (flip $ derive) td ns--chFun ::  Name -> Name -> Q Exp-chFun tn n =  -         do-             i <- reify (tn)-             if isNT i-              then [| $(varE (semName tn)) $(aspV) $(varE n) |]-              else [| ( \(Record HNil) -> $(varE n) ) |]-      ----#if __GLASGOW_HASKELL__ < 612 -getUserType :: Info -> Q UserType-getUserType info = do-    case info of-        TyConI d -> case d of-            (DataD     _ uname args cs  _)  -> return $ UserD uname args cs -            (NewtypeD  _ uname args c   _)  -> return $ UserD uname args [c]-            _                               -> scopeError-        _ -> scopeError-    where scopeError = error $ "Can only be used on algebraic datatypes"-#endif--#if __GLASGOW_HASKELL__ >= 612-getUserType :: Info -> Q UserType-getUserType info = do-    case info of-        TyConI d -> case d of-            (DataD     _ uname args cs  _)  -> return $ UserD uname (map f args) cs -            (NewtypeD  _ uname args c   _)  -> return $ UserD uname (map f args) [c]-            (TySynD    uname args t)        -> let  name = nameBase uname-                                                    cs = case t of-                                                                (AppT ListT lt) -> [ NormalC (mkName $ name ++ "_Nil") []-                                                                                   , RecC (mkName $ name ++ "_Cons") -                                                                                          [ (mkName ("hd_" ++ name ++ "_Cons"),NotStrict,lt) -                                                                                          , (mkName ("tl_" ++ name ++ "_Cons"),NotStrict,ConT uname) ]]-                                                                (AppT (ConT nt) pt) ->-                                                                            case (nameBase nt) of-                                                                                "Maybe" ->   [ NormalC (mkName $ name ++ "_Nothing") []-                                                                                             , RecC (mkName $ name ++ "_Just") -                                                                                                    [ (mkName ("just_" ++ name ++ "_Just"),NotStrict,pt) ]]-                                                                                _ -> error "Not allowed type synonym"-                                                                _ -> error "Not allowed type synonym"-                                               in   return (UserD uname (map f args) cs)-            _                               -> scopeError-        _ -> scopeError-    where scopeError = error $ "Can only be used on algebraic datatypes"-          f (PlainTV n)    = n-          f (KindedTV n _) = n-#endif--getCtx :: Con -> ([Type],[Name], Name) -getCtx (RecC           name args) = (map thd args, map fst' args, name)-getCtx (NormalC name []) = ([],[],name)-getCtx (NormalC name _)  = error $ "Constructor " ++ (show name) ++ " is not a record."-getCtx (InfixC _ name _) = error $ "Constructor " ++ (show name) ++ " is not a record."	-getCtx _ = error $ "Cannot derive a 'forall' constructor."	--thd :: (a, b, c) -> c-thd (_, _, c) = c--fst' :: (a, b, c) -> a-fst' (a, _, _) = a----isNT ::  Info -> Bool-isNT (PrimTyConI _ _ _)          =  False-isNT (TyConI (DataD _ n _ _ _))  =  not $ isPrefixOf "GHC" (show n)         -- GHC types can't be non-terminals-isNT (TyConI (TySynD n _ _))     =  (not $ isPrefixOf "GHC" (show n)) &&    -- GHC types can't be non-terminals-                                    (not $ isPrefixOf "GHC" (nameBase n))   -- type synonyms starting with GHC to escape (example: GHC_MyType)-isNT  _                          =  True---typeNames :: Type -> [ Name ]-typeNames t = case t of-    VarT _                   -> [  ]-    ConT conname             -> [ conname ]-    AppT t1 t2               -> typeNames t1 ++ typeNames t2-    ListT                    -> [ ]-    _                        -> error $ "Not valid type " ++ (show t)---typeName1 :: Type -> Maybe Name -typeName1 t = case t of-    VarT _                   -> Nothing-    ConT conname             -> Just conname-    AppT t1 _                -> typeName1 t1-    ListT                    -> Nothing-    _                        -> error $ "Not valid type " ++ (show t)----mkNames (_,fields,cname) = ( mkName ('p' : nameBase cname)-                           , mkName ('_' : nameBase cname)-                           , map (\n -> mkName ('_' : nameBase n)) fields)--recField (pc,c,fs) = (pc, NotStrict, foldr (\n t -> AppT (AppT ArrowT (VarT n)) t) (VarT c) fs)--deriveLang :: String -> [Name] -> Q [Dec]-deriveLang l ns =  -  let recName = mkName (l ++ "SF")-  in  do cs <- mapM getCs ns -         let names = sort $ map (mkNames . getCtx) (concat cs)-         let ts = map (\(_,c,fs) -> (PlainTV c) : (map PlainTV fs)) names-         let rec = DataD [] recName (concat ts) [RecC recName (map recField names) ] []-         let semp t = VarE $ mkName ("semP"++(nameBase t))-         let body = NormalB $ RecConE recName (map  (\(pc,_c,_) -> (pc, AppE (semp _c) (VarE _c)) ) names)-         let mk  = FunD  (mkName ("mk" ++ l)) [ Clause (map (\(_,c,_) -> VarP c) names) body [] ]-         return [ rec, mk ]--getCs n =  do info <- reify n -              (UserD _ _ lc) <- getUserType info-              return lc

@@ -0,0 +1,243 @@+{-|+Module      : Language.Grammars.AspectAG.GenRecord+Description : Record library, this will be eventually forked out+              from AAG codebase and used as a standalone library, depending on it+Copyright   : (c) Juan García Garland, Marcos Viera, 2019+License     : GPL+Maintainer  : jpgarcia@fing.edu.uy+Stability   : experimental+Portability : POSIX+-}++{-# OPTIONS_GHC -fno-warn-missing-methods #-}++{-# LANGUAGE DataKinds,+             TypeOperators,+             PolyKinds,+             GADTs,+             TypeInType,+             RankNTypes,+             StandaloneDeriving,+             FlexibleInstances,+             FlexibleContexts,+             ConstraintKinds,+             MultiParamTypeClasses,+             FunctionalDependencies,+             UndecidableInstances,+             ScopedTypeVariables,+             TypeFamilies,+             InstanceSigs,+             AllowAmbiguousTypes,+             TypeApplications,+             PatternSynonyms+#-}++module Language.Grammars.AspectAG.GenRecord where++import Data.Kind+--import Data.Type.Equality hiding ((==))+import Data.Proxy+import Language.Grammars.AspectAG.TPrelude+import Language.Grammars.AspectAG.Require++import GHC.TypeLits+++type family a == b where+  a == b = Equal a b++-- * Pretty constructors++infixr 2 .*.+(.*.) :: LabelSet ( '(l, v) ': r) =>+    TagField c l v -> Rec c r -> Rec c ( '(l,v) ': r)+(.*.) = ConsRec++-- * destructors++-- | A getter, also a predicate+-- class HasField (l :: k) (r :: [(k, k')]) field where+--   type LookupByLabel field l r :: Type+--   (#) :: REC field r -> Label l -> LookupByLabel field l v+++tailRec :: Rec c ( '(l,v) ': r) -> Rec c r+tailRec (ConsRec _ t) = t++data Rec (c :: k) (r :: [(k', k'')]) :: Type where+  EmptyRec :: Rec c '[]+  ConsRec  :: LabelSet ( '(l,v) ': r) =>+              TagField c l v -> Rec c r -> Rec c ( '(l,v) ': r)++data TagField (cat :: k) (l :: k') (v :: k'') where+  TagField :: Label c -> Label l -> WrapField c v -> TagField c l v++untagField :: TagField c l v -> WrapField c v+untagField (TagField lc lv v) = v++type family    WrapField (c :: k')  (v :: k) -- = ftype | ftype c -> v++{-+Node:+We cannot encode the dependency {ftype, c} -> v since TypeFamilyDependencies+does not support this general dependencies. So from (WrapField c v) we+can't infer c.++-}+++data OpLookup (c :: Type)+              (l  :: k)+              (r  :: [(k, k')]) :: Type where+  OpLookup :: Label l -> Rec c r -> OpLookup c l r++data OpLookup' (b  :: Bool)+               (c  :: Type)+               (l  :: k)+               (r  :: [(k, k')]) :: Type where+  OpLookup' :: Proxy b -> Label l -> Rec c r -> OpLookup' b c l r+++++instance (Require (OpLookup' (l == l') c l ( '(l', v) ': r)) ctx)+  => Require (OpLookup c l ( '(l', v) ': r)) ctx where+  type ReqR (OpLookup c l ( '(l', v) ': r))+    = ReqR (OpLookup' (l == l') c l ( '(l', v) ': r))+  req ctx (OpLookup l r) = req ctx (OpLookup' (Proxy @ (l == l')) l r)++instance Require (OpLookup' 'True c l ( '(l, v) ': r)) ctx where+  type ReqR (OpLookup' 'True c l ( '(l, v) ': r)) = WrapField c v+  req Proxy (OpLookup' Proxy Label (ConsRec f _)) = untagField f++instance (Require (OpLookup c l r) ctx)+  => Require (OpLookup' False c l ( '(l', v) ': r)) ctx where+  type ReqR (OpLookup' False c l ( '(l', v) ': r)) = ReqR (OpLookup c l r)+  req ctx (OpLookup' Proxy l (ConsRec _ r)) = req ctx (OpLookup l r)+++++instance+  Require (OpError (Text "field not Found on " :<>: Text (ShowRec c)+                     :$$: Text "looking up the " :<>: Text (ShowField c)+                           :<>: ShowT l+                          )) ctx+  => Require (OpLookup c l ( '[] :: [(k,k')])) ctx where+  type ReqR (OpLookup c l ('[] :: [(k,k')])  ) = ()+  req = undefined++type family ShowRec c :: Symbol+type family ShowField c :: Symbol++instance (Require (OpError (Text "field not Found on " :<>: Text (ShowRec c)+                    :$$: Text "updating the " :<>: Text (ShowField c)+                     :<>: ShowT l)) ctx)+  => Require (OpUpdate c l v '[]) ctx where+  type ReqR (OpUpdate c l v ('[] )  ) = Rec c '[]+  req = undefined++-- | update+data OpUpdate (c  :: Type)+              (l  :: k)+              (v  :: k')+              (r  :: [(k, k')]) :: Type where+  OpUpdate :: Label l -> WrapField c v -> Rec c r+           -> OpUpdate c l v r++data OpUpdate' (b  :: Bool)+               (c  :: Type)+               (l  :: k)+               (v  :: k')+               (r  :: [(k, k')]) :: Type where+  OpUpdate' :: Proxy p -> Label l -> WrapField c v ->  Rec c r+           -> OpUpdate' b c l v r+++instance (Require (OpUpdate' (l == l') c l v ( '(l', v') ': r) ) ctx )+  => Require (OpUpdate c l v ( '(l', v') ': r) ) ctx where+  type ReqR (OpUpdate c l v ( '(l', v') ': r) )+    = ReqR (OpUpdate' (l == l') c l v ( '(l', v') ': r) )+  req ctx (OpUpdate l f r)+    = (req @(OpUpdate' (l == l') _ _ v _ ))+       ctx (OpUpdate' (Proxy @(l == l')) l f r)+++instance ( LabelSet ( '(l, v) ': r)+         , LabelSet ( '(l, v') ': r))+  => Require (OpUpdate' 'True c l v ( '(l, v') ': r)) ctx where+  type ReqR (OpUpdate' 'True c l v ( '(l, v') ': r))+    = Rec c ( '(l, v) ': r)+  req ctx (OpUpdate' proxy label field (ConsRec tgf r))+    = ConsRec (TagField Label label field) r+++instance ( Require (OpUpdate c l v r) ctx+         , UnWrap (ReqR (OpUpdate c l v r)) ~ r0+         , LabelSet ( '(l', v') : r0)+         , ReqR (OpUpdate c l v r) ~ Rec c r0)+  => Require (OpUpdate' 'False c l v ( '(l',v') ': r)) ctx where+  type ReqR (OpUpdate' 'False c l v ( '(l',v') ': r))+    = Rec c ( '(l',v') ': (UnWrap (ReqR (OpUpdate c l v r))))+  req ctx (OpUpdate' _ l f (ConsRec field r))+    = ConsRec field $ (req @(OpUpdate _ _ v r)) ctx (OpUpdate l f r)++++type family UnWrap t :: [(k,k')]+type instance UnWrap (Rec c r) = r+++++data OpExtend (c :: Type)+              (l  :: k)+              (v  :: k')+              (r  :: [(k, k')]) :: Type where+  OpExtend :: Label l -> WrapField c v -> Rec c r+           -> OpExtend c l v r++data OpExtend' (b :: Bool)+               (c :: Type)+               (l  :: k)+               (v  :: k')+               (r  :: [(k, k')]) :: Type where+  OpExtend' :: Proxy b -> Label l -> WrapField c v -> Rec c r+           -> OpExtend' b c l v r+++instance (LabelSetF ( '(l, v) ': r) ~ 'True)+  => Require (OpExtend' True  c l v r) ctx where+  type ReqR (OpExtend' True c l v r) = Rec c ( '(l, v) ': r)+  req ctx (OpExtend' _ l f r) = ConsRec (TagField (Label @c) l f) r+++instance ( LabelSetF ( '(l, v) ':  r) ~ b+         , Require (OpExtend' b c l v r) ctx)+  => Require (OpExtend c l v r) ctx where+  type ReqR (OpExtend c l v r)+    = ReqR (OpExtend' (LabelSetF ( '(l, v) ': r)) c l v r)+  req ctx (OpExtend l v r)+    = req @(OpExtend' (LabelSetF ( '(l, v) ': r)) _ _ v _ )+      ctx (OpExtend' Proxy l v r) ++instance Require (OpError (Text "Duplicated Labels on " :<>: Text (ShowRec c)+                          :$$: Text "on the " :<>: Text (ShowField c)+                           :<>: ShowT l+                          )) ctx+  => Require (OpExtend' False c l v (r :: [(k, k')])) ctx where+  type ReqR (OpExtend' False c l v r) = Rec c (r :: [(k, k')])+  req ctx (OpExtend' p l v r) = undefined++++data OpNonEmpty (c :: Type) (r :: [(k, k')]) where+  OpNonEmpty :: Rec c r -> OpNonEmpty c r+++instance Require (OpNonEmpty c ( '(l, v) ': r)) ctx where {}++instance (Require (OpError (Text "Empty " :<>: Text (ShowRec c)+                          :$$: Text " Required to be nonempty "+                          )) ctx)+  => Require (OpNonEmpty c '[]) ctx where {}

@@ -0,0 +1,83 @@+{-|+Module      : Language.Grammars.AspectAG.HList+Description : Heterogeneous Lists for AAG, inspired on HList+Copyright   : (c) Juan García Garland, 2018 +License     : LGPL+Maintainer  : jpgarcia@fing.edu.uy+Stability   : experimental+Portability : POSIX++Implementation of strongly typed heterogeneous lists.+-}++{-# LANGUAGE TypeInType,+             GADTs,+             KindSignatures,+             TypeOperators,+             TypeFamilies,+             MultiParamTypeClasses,+             FlexibleInstances,+             FlexibleContexts,+             StandaloneDeriving,+             UndecidableInstances,+             FunctionalDependencies,+             ConstraintKinds,+             ScopedTypeVariables+#-}++module Language.Grammars.AspectAG.HList where+import Language.Grammars.AspectAG.TPrelude+import Data.Proxy+import Data.Type.Equality+import Data.Kind+import GHC.Exts++-- |Heterogeneous lists are implemented as a GADT+data HList (l :: [Type]) :: Type  where+  HNil :: HList '[]+  HCons :: x -> HList xs -> HList (x ': xs)+++-- | HMember is a test membership function.+--Since we are in Haskell the value level function computes with the evidence +class HMember (t :: Type) (l :: [Type]) where+  type HMemberRes t l :: Bool+  hMember :: Label t -> HList l -> Proxy (HMemberRes t l)++instance HMember t '[] where+  type HMemberRes t '[] = 'False+  hMember _ _ = Proxy++instance HMember t (t' ': ts) where+  type HMemberRes t (t' ': ts) = Or (t == t') (HMemberRes t ts)+  hMember _ _ = Proxy++-- | HMember' is a test membership function.+-- But looking up in a list of Labels+class HMember' (t :: k) (l :: [k]) where+  type HMemberRes' t l :: Bool+  hMember' :: f t -> KList l -> Proxy (HMemberRes' t l)++instance HMember' t '[] where+  type HMemberRes' t '[] = 'False+  hMember' _ _ = Proxy++instance HMember' t (t' ': ts) where+  type HMemberRes' t (t' ': ts) = Or (t == t') (HMemberRes' t ts)+  hMember' _ _ = Proxy+++-- | No other functionality is needed for AAG++infixr 2 .:+(.:) = HCons+ε = HNil++-- | a polykinded heteogeneous list+data KList (l :: [k]) :: Type where+  KNil :: KList '[]+  KCons :: Label h -> KList l -> KList (h ': l)++infixr 2 .:.+(.:.) = KCons+eL = KNil

@@ -0,0 +1,279 @@++{-# OPTIONS_GHC -fno-warn-missing-methods #-}++{-# LANGUAGE DataKinds,+             TypeOperators,+             PolyKinds,+             GADTs,+             TypeInType,+             RankNTypes,+             StandaloneDeriving,+             FlexibleInstances,+             FlexibleContexts,+             ConstraintKinds,+             MultiParamTypeClasses,+             FunctionalDependencies,+             UndecidableInstances,+             ScopedTypeVariables,+             TypeFamilies,+             InstanceSigs,+             AllowAmbiguousTypes,+             TypeApplications,+             PatternSynonyms+#-}++module Language.Grammars.AspectAG.RecordInstances where++import Language.Grammars.AspectAG.Require+import Language.Grammars.AspectAG.GenRecord+import Language.Grammars.AspectAG.TPrelude+import GHC.TypeLits+import Data.Kind+import Data.Proxy++data Att   = Att Symbol Type               -- deriving Eq+data Prod  = Prd Symbol NT                  --deriving Eq+data Child = Chi Symbol Prod (Either NT T)  --deriving Eq+data NT    = NT Symbol                      --deriving Eq+data T     = T Type                        -- deriving Eq+++++type instance  ShowT ('Att l t)   = Text  "Attribute " :<>: Text l+                                                       :<>: Text ":"+                                                       :<>: ShowT t +type instance  ShowT ('Prd l nt)  = ShowT nt :<>: Text "::Production "+                                             :<>: Text l+type instance  ShowT ('Chi l p s) = ShowT p :<>:  Text "::Child " :<>: Text l +                                            :<>:  Text ":" :<>: ShowT s+type instance  ShowT ('Left l)    = ShowT l+type instance  ShowT ('Right r)   = ShowT r+type instance  ShowT ('NT l)      = Text "Non-Terminal " :<>: Text l+type instance  ShowT ('T  l)      = Text "Terminal " :<>: ShowT l++++-- | * Records++-- | datatype definition+type Record        = Rec Reco++-- | index type+data Reco++-- | field type+type instance  WrapField Reco     (v :: Type) = v++-- | Type level show utilities+type instance ShowRec Reco         = "Record"+type instance ShowField Reco       = "field named "++++-- | ** Pattern Synonyms+pattern EmptyR :: Rec Reco '[]+pattern EmptyR = EmptyRec :: Rec Reco '[]+pattern ConsR :: (LabelSet ( '(l,v ) ': xs))+  => Tagged l v -> Rec Reco xs -> Rec Reco ( '(l,v ) ': xs) +pattern ConsR lv r = ConsRec lv r+++type Tagged = TagField Reco+pattern Tagged :: v -> Tagged l v+pattern Tagged v = TagField Label Label v+++-- ** Constructors++-- | Pretty Constructor+infixr 4 .=.+(.=.) :: Label l -> v -> Tagged l v+l .=. v = Tagged v++-- | For the empty Record+emptyRecord :: Record '[]+emptyRecord = EmptyR++unTagged :: Tagged l v -> v+unTagged (TagField _ _ v) = v++-- * Destructors+-- | Get a label+label :: Tagged l v -> Label l+label _ = Label++-- | Same, mnemonically defined+labelTChAtt :: Tagged l v -> Label l+labelTChAtt _ = Label+++-- | Show instance, used for debugging+instance Show (Record '[]) where+  show _ = "{}"++instance (Show v, Show (Record xs), (LabelSet ('(l, v) : xs))) =>+         Show (Record ( '(l,v) ': xs ) ) where+  show (ConsR lv xs) = let tail = show xs+                       in "{" ++ show (unTagged lv)+                          ++ "," ++ drop 1 tail++++-- | * Attribution+-- | An attribution is a record constructed from attributes++-- | datatype implementation+type Attribution (attr :: [(Att,Type)]) =  Rec AttReco attr++-- | index type+data AttReco++-- | field type+type instance  WrapField AttReco  (v :: Type) = v++-- | type level utilities+type instance ShowRec AttReco      = "Attribution"+type instance ShowField AttReco       = "attribute named "++-- | Pattern Synonyms+pattern EmptyAtt :: Attribution '[]+pattern EmptyAtt = EmptyRec+pattern ConsAtt :: LabelSet ( '(att, val) ': atts) =>+    Attribute att val -> Attribution atts -> Attribution ( '(att,val) ': atts)+pattern ConsAtt att atts = ConsRec att atts++-- | Attribute++type Attribute (l :: Att) (v :: Type) = TagField AttReco l v+pattern Attribute :: v -> TagField AttReco l v+pattern Attribute v = TagField Label Label v++-- ** Constructors+-- | Apretty constructor for an attribute +infixr 4 =.++(=.) :: Label l -> v -> Attribute l v+Label =. v = Attribute v+++-- | Extending+infixr 2 *.+(*.) :: LabelSet ('(att, val) : atts) =>+    Attribute att val -> Attribution atts+      -> Attribution ('(att, val) : atts)+(*.) = ConsRec++-- | Empty+emptyAtt :: Attribution '[]+emptyAtt = EmptyRec++-- ** Destructors+infixl 7 #.++(#.) ::+  ( msg ~ '[Text "looking up attribute " :<>: ShowT l :$$:+            Text "on " :<>: ShowT r+           ]+  , Require (OpLookup AttReco l r) msg+  )+  => Attribution r -> Label l -> ReqR (OpLookup AttReco l r)+(attr :: Attribution r) #. (l :: Label l)+  = let prctx = Proxy @ '[Text "looking up attribute " :<>: ShowT l :$$:+                          Text "on " :<>: ShowT r+                         ]+    in req prctx (OpLookup @_ @(AttReco) l attr)+++++-- * Children+-- | operations for the children++-- | datatype implementation+type ChAttsRec prd (chs :: [(Child,[(Att,Type)])])+   = Rec (ChiReco prd) chs++-- | index type+data ChiReco (prd :: Prod)++-- | Field type+type instance  WrapField (ChiReco prd) v+  = Attribution v++-- | Type level Show utilities+type instance ShowRec (ChiReco a)     = "Children Map"+type instance ShowField (ChiReco a)   = "child labelled "++-- ** Pattern synonyms++-- |since now we implement ChAttsRec as a generic record, this allows us to+--   recover pattern matching+pattern EmptyCh :: ChAttsRec prd '[]+pattern EmptyCh = EmptyRec+pattern ConsCh :: (LabelSet ( '( 'Chi ch prd nt, v) ': xs)) =>+  TaggedChAttr prd ( 'Chi ch prd nt) v -> ChAttsRec prd xs+                         -> ChAttsRec prd ( '( 'Chi ch prd nt,v) ': xs)+pattern ConsCh h t = ConsRec h t++-- | Attributions tagged by a child+type TaggedChAttr prd = TagField (ChiReco prd)+pattern TaggedChAttr :: Label l -> WrapField (ChiReco prd) v+                     -> TaggedChAttr prd l v+pattern TaggedChAttr l v+  = TagField (Label :: Label (ChiReco prd)) l v+++-- ** Constructors+-- | Pretty constructor for tagging a child+infixr 4 .=+(.=) :: Label l -> WrapField (ChiReco prd) v -> TaggedChAttr prd l v+(.=) = TaggedChAttr++-- | Pretty constructors+infixr 2 .*+(.*) :: LabelSet ('(ch, attrib) ':  attribs) =>+  TaggedChAttr prd ch attrib -> ChAttsRec prd attribs+    -> ChAttsRec prd ('(ch, attrib) ': attribs)+(.*) = ConsRec++-- | empty+emptyCh :: ChAttsRec prd '[]+emptyCh = EmptyRec++-- ** Destructors+unTaggedChAttr :: TaggedChAttr prd l v -> WrapField (ChiReco prd) v+unTaggedChAttr (TaggedChAttr _ a) = a++labelChAttr :: TaggedChAttr prd l a -> Label l+labelChAttr _ = Label++infixl 8 .#+(.#) ::+  (  c ~ ('Chi ch prd nt)+  ,  ctx ~ '[Text "looking up " :<>: ShowT c :$$:+            Text "on " :<>: ShowT r :$$:+            Text "producion: " :<>: ShowT prd+           ]+  , Require (OpLookup (ChiReco prd) c r) ctx+  ) =>+     Rec (ChiReco prd) r -> Label c -> ReqR (OpLookup (ChiReco prd) c r)+(chi :: Rec (ChiReco prd) r) .# (l :: Label c)+  = let prctx = Proxy @ '[Text "looking up " :<>: ShowT c :$$:+                          Text "on " :<>: ShowT r :$$:+                          Text "producion: " :<>: ShowT prd+                         ]+    in req prctx (OpLookup @_ @(ChiReco prd) l chi)++++-- * Productions++data PrdReco++type instance  WrapField PrdReco (rule :: Type)+  = rule++type Aspect (asp :: [(Prod, Type)]) = Rec PrdReco asp+type instance ShowRec PrdReco      = "Aspect"+type instance ShowField PrdReco       = "production named "

@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# LANGUAGE DataKinds,+             TypeOperators,+             PolyKinds,+             GADTs,+             TypeInType,+             RankNTypes,+             StandaloneDeriving,+             FlexibleInstances,+             FlexibleContexts,+             ConstraintKinds,+             MultiParamTypeClasses,+             FunctionalDependencies,+             UndecidableInstances,+             ScopedTypeVariables,+             TypeFamilies,+             InstanceSigs,+             AllowAmbiguousTypes,+             TypeApplications,+             PatternSynonyms+#-}++module Language.Grammars.AspectAG.Require where++import Data.Kind+import Data.Proxy+import GHC.TypeLits+import Language.Grammars.AspectAG.TPrelude+import Data.Type.Equality++class Require (op   :: Type)+              (ctx  :: [ErrorMessage])  where+   type ReqR op :: Type+   req :: Proxy ctx -> op -> ReqR op++instance (TypeError (Text "Error: " :<>: m :$$:+                     Text "trace: " :<>: ShowCTX ctx))+  => Require (OpError m) ctx where {}++data OpError (m :: ErrorMessage) where {}++type family ShowCTX (ctx :: [ErrorMessage]) :: ErrorMessage where+  ShowCTX '[] = Text ""+  ShowCTX (m ': ms) = m :$$: ShowCTX ms+++type family ShowEM (m :: ErrorMessage) :: ErrorMessage++type family ShowT (t :: k) :: ErrorMessage+type instance ShowT (t :: Type) = ShowType t+{-+Abro esta familia para poder definirla de manera extensible, porque no sabemos+en GenReord como se muestran los tipos para instancias concretas. El problema es+que estaba definida con un pattern que capturaba todos los demas casos al final+y en tf cerradas no se admite overlap. Entonces defino aca una instancia para el+kind t (era a fin de cuentas lo que caia en el último pattern)+-}++type RequireR (op :: Type ) (ctx:: [ErrorMessage]) (res :: Type)+     = (Require op ctx, ReqR op ~ res)+++type RequireEq (t1 :: k )(t2 :: k) (ctx:: [ErrorMessage])+    = (Require (OpEq t1 t2) ctx, t1 ~ t2)++data OpEq t1 t2++instance RequireEqRes t1 t2 ctx+  => Require (OpEq t1 t2) ctx where+  type ReqR (OpEq t1 t2) = ()+  req = undefined++type family RequireEqRes (t1 :: k) (t2 :: k)+                     (ctx :: [ErrorMessage]) ::  Constraint where+  RequireEqRes t1 t2 ctx = If (t1 `Equal` t2) (() :: Constraint)+    (Require (OpError (Text "" :<>: ShowT t1 :<>: Text " /= " :<>: ShowT t2)) ctx)+

@@ -0,0 +1,283 @@+{-|+Module      : Language.Grammars.AspectAG.TH+Description : Boilerplate generation+Copyright   : (c) Juan García Garland+License     : GPL+Maintainer  : jpgarcia@fing.edu.uy+Stability   : experimental+Portability : POSIX+-}++{-# LANGUAGE PolyKinds                 #-}+{-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE FunctionalDependencies    #-}+{-# LANGUAGE TemplateHaskell           #-}++module Language.Grammars.AspectAG.TH where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax (showName)+import Data.Proxy+import Data.Either+import GHC.TypeLits+import Data.List+import Data.Set (Set)+import qualified Data.Set as S++import Control.Monad++import Language.Grammars.AspectAG+import qualified Data.Kind as DK++import qualified Language.Haskell.TH.Compat.Strict as Comp++-- * Attribute labels++-- | makes a type level lit (Symbol) from a String+str2Sym s = litT$ strTyLit s -- th provides nametoSymbol, btw+++-- | TH function to define a typed attribute label given a name+-- and a quoted type+attLabel :: String -> Name -> DecsQ+attLabel s t+  = [d| $(varP (mkName s)) = Label :: Label ( 'Att $(str2Sym s)+                                            $(conT t)) |]++-- | for completness, to have a name as the next one+attMono = attLabel++-- | TH function to define a polymorphic attribute+attPoly :: String -> DecsQ+attPoly s+    = [d| $(varP (mkName s)) = Label :: forall a . Label ( 'Att $(str2Sym s) a) |]++-- | multiple monomorphic attributes at once+attLabels :: [(String,Name)] -> Q [Dec]+attLabels xs = liftM concat . sequence $ [attLabel att ty | (att,ty) <- xs ]++-- * Non terminals++-- | add a non terminal symbol+addNont :: String -> Q [Dec]+addNont s+  = liftM concat . sequence $ [addNTLabel s, addNTType s]++addNTLabel :: String -> Q [Dec]+addNTLabel s+  = [d| $(varP (mkName ("nt_" ++ s))) = Label :: Label ('NT $(str2Sym s)) |]++addNTType :: String -> Q [Dec]+addNTType s+  = return [TySynD (mkName ("Nt_"++ s)) [] (AppT (PromotedT 'NT) (LitT (StrTyLit s)))]+++-- * Productions+--data Symbol = N String | Te Name+type family Terminal s :: Either NT T where+  Terminal s = 'Right ('T s)++type family NonTerminal s where+  NonTerminal s = 'Left s+++data SymTH = Ter Name | NonTer Name | Poly+++addChi  :: String -- chi name+        -> Name   -- prd+        -> SymTH  -- symbol type+        -> Q [Dec]+addChi chi prd (Ter typ)+  = [d| $(varP (mkName ("ch_" ++chi)))+           = Label :: Label ( 'Chi $(str2Sym chi)+                                   $(conT prd)+                                    (Terminal $(conT typ)))|]+addChi chi prd (NonTer typ)+  = [d| $(varP (mkName ("ch_" ++chi)))+           = Label :: Label ( 'Chi $(str2Sym chi)+                                   $(conT prd)+                                    (NonTerminal $(conT typ)))|]+addChi chi prd poly+  = [d| $(varP (mkName ("ch_" ++chi)))+           = Label :: forall a . Label ( 'Chi $(str2Sym chi)+                                   $(conT prd)+                                    ('Right ('T a)))|]++-- | only prod symbol+addPrd :: String  --name+       -> Name    --nonterm+       -> Q [Dec]+addPrd prd nt = liftM concat . sequence+              $ [addPrdType prd nt, addPrdLabel prd nt]++addPrdLabel prd nt+  = [d| $(varP (mkName ("p_" ++ prd)))+         = Label :: Label ('Prd $(str2Sym prd) $(conT nt))|]++addPrdType prd nt+  = return [TySynD (mkName ("P_"++ prd)) []+            (AppT (AppT (PromotedT 'Prd) (LitT (StrTyLit prd))) (ConT nt))]+++-- | Productions+addProd :: String             -- name+        -> Name               -- nt+        -> [(String, SymTH)]  -- chiLst+        -> Q [Dec]+addProd prd nt xs+  = liftM concat . sequence $+      addPrd prd nt+    : addInstance nt prd (map preProc xs)+    : [addChi chi (mkName ("P_" ++ prd)) sym | (chi, sym) <- xs]+    where preProc (n, Ter a)    = (mkName n, a)+          preProc (n, NonTer a) = (mkName n, a) +++-- | class+class Prods (lhs :: NT) (name :: Symbol) (rhs :: [(Symbol, Symbol)]) where {}++-- get a list of instances+getInstances :: Q [InstanceDec]+getInstances = do+  ClassI _ instances <- reify ''Prods+  return instances++-- convert the list of instances into an Exp so they can be displayed in GHCi+showInstances :: Q Exp+showInstances = do+  ins <- getInstances+  return . LitE . stringL $ show $ head ins++addInstance :: Name -> String -> [(Name, Name)] -> Q [Dec]+addInstance nt name rhs+  = [d| instance Prods $(conT nt) $(str2Sym name) $(typeList rhs) where {}  |]++typeList :: [(Name, Name)] -> Q Type+typeList = foldr f promotedNilT+    -- where f = \x xs -> appT (appT promotedConsT (nameToSymbolBase x)) xs+  where f = \(n,t) xs+          -> appT (appT promotedConsT (appT (appT (promotedTupleT 2)+                                              (nameToSymbol n))+                                       (nameToSymbolBase t))) xs+  -- where f = \x xs -> if isNTName x+  --         then ((appT (appT promotedConsT+  --                      ((appT [t| Left |]) (conT x))))) xs+  --         else ((appT (appT promotedConsT+  --                      ((appT [t| Right |])+  --                       (appT [t| 'T |] (conT x)))))) xs++nameToSymbol = litT . strTyLit . show+nameToSymbolBase = litT . strTyLit . nameBase++isNTName :: Name -> Bool+isNTName n+  = "Nt_" `isPrefixOf` nameBase n+++closeNT :: Name -> Q [Dec]+closeNT nt+  = do decs <- getInstances+       let consts = map mkCon $ filter (isInstanceOf nt) decs+       return [ DataD []+                (mkName $ drop 3 $ nameBase nt) [] Nothing+                consts [DerivClause Nothing [ConT ''Show, ConT ''Eq, ConT ''Read]]]++isInstanceOf nt (InstanceD _ _ (AppT (AppT (AppT (ConT prods) (ConT nt')) _ ) _) _)+  = nameBase nt == nameBase nt'+isInstanceOf _ _ = False++mkCon :: InstanceDec -> Con+mkCon i+  = case i of+  InstanceD _ [] (AppT (AppT (AppT (ConT _prods) (ConT nt)) (LitT (StrTyLit prdname))) tlist) _+    -> RecC (mkName prdname) (map mkBangPR $ getTList tlist)++mkBangP  (_, a) = (Bang NoSourceUnpackedness NoSourceStrictness, ConT a)+mkBangPR (n, a) = (n, Bang NoSourceUnpackedness NoSourceStrictness, ConT a)++getTList :: Type -> [(Name, Name)]+getTList (SigT _ _) = []+getTList (AppT (AppT (PromotedConsT)+                (AppT (AppT (PromotedTupleT 2)+                       (LitT (StrTyLit n)))+                  (LitT (StrTyLit pos))))+           ts)+  = (mkName n,+     if "Nt_" `isPrefixOf` pos then mkName $ drop 3 pos else mkName pos)+    : getTList ts+getTList _ = []++++-- | keeps nt info+getTListNT :: Type -> [(Name, Name)]+getTListNT (SigT _ _) = []+getTListNT (AppT (AppT (PromotedConsT)+                (AppT (AppT (PromotedTupleT 2)+                       (LitT (StrTyLit n)))+                  (LitT (StrTyLit pos))))+           ts)+  = (mkName n, mkName pos) : getTListNT ts+getTListNT _ = []++-- | like |mkCon| in semantic functions, builds a case+mkClause :: InstanceDec -> Clause+mkClause i+  = case i of+  InstanceD _ [] (AppT (AppT (AppT (ConT _prods)+                               (ConT nt))+                         (LitT (StrTyLit prdname)))+                   tlist) _+    -> Clause [VarP (mkName "asp"),+               ConP (mkName $ prdname) [ VarP a | a <- map fst (getTList tlist)]]+    (NormalB ((AppE (AppE (AppE (VarE $ mkName "knitAspect")+                           (VarE $ mkName $ "p_"++ prdname))+                      (VarE $ mkName "asp"))+                (toSemRec (getTListNT tlist)))))+    []++toSemRec :: [(Name, Name)] -> Exp+toSemRec+  = foldr mkChSem (VarE (mkName "emptyRecord"))+  where mkChSem (n,pos) xs+          | "Nt_" `isPrefixOf` nameBase pos =+          (AppE (AppE (VarE $ mkName ".*.")+                 (AppE (AppE (VarE $ mkName ".=.")+                        (VarE $ mkName $ "ch_" ++ nameBase n))+                   (AppE (AppE (VarE $ mkName $ "sem_" ++ (drop 3 $ nameBase pos))+                          (VarE $ mkName "asp"))+                     (VarE $ n))))+            xs)+          | otherwise =+            (AppE (AppE (VarE $ mkName ".*.")+                   (AppE (AppE (VarE $ mkName ".=.")+                          (VarE $ mkName $ "ch_" ++ nameBase n))+                    (AppE (VarE $ mkName "sem_Lit")+                      (VarE $ n))))+            xs)+closeNTs :: [Name] -> Q [Dec]+closeNTs = liftM concat . sequence . map (closeNT)++mkSemFunc :: Name -- nonterm+          -> Q [Dec]+mkSemFunc nt =+  do decs <- getInstances+     let clauses = map mkClause $ filter (isInstanceOf nt) decs+     return [FunD (mkName $ "sem_" ++ drop 3 (nameBase nt)) clauses ]++