diff --git a/AspectAG.cabal b/AspectAG.cabal --- a/AspectAG.cabal +++ b/AspectAG.cabal @@ -1,23 +1,151 @@ -name: AspectAG -version: 0.3.6.1 -cabal-version: >= 1.2.3 -license: LGPL -license-file: COPYRIGHT -maintainer: Marcos Viera -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 diff --git a/COPYRIGHT b/COPYRIGHT deleted file mode 100644 --- a/COPYRIGHT +++ /dev/null @@ -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. - - diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for AspectAG + +## 0.4 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 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 . + +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: + + Copyright (C) + 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 +. + + 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 +. diff --git a/LICENSE-LGPL b/LICENSE-LGPL deleted file mode 100644 --- a/LICENSE-LGPL +++ /dev/null @@ -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. - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -Also add information on how to contact you by electronic and paper mail. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the library, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James Random Hacker. - - , 1 April 1990 - Ty Coon, President of Vice - -That's all there is to it! - diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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 - diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,2 @@ - import Distribution.Simple main = defaultMain diff --git a/examples/Expr.hs b/examples/Expr.hs new file mode 100644 --- /dev/null +++ b/examples/Expr.hs @@ -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) + + diff --git a/examples/ExprExt.hs b/examples/ExprExt.hs new file mode 100644 --- /dev/null +++ b/examples/ExprExt.hs @@ -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''))) + diff --git a/examples/LangDef.hs b/examples/LangDef.hs deleted file mode 100644 --- a/examples/LangDef.hs +++ /dev/null @@ -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 - - - diff --git a/examples/LangExt.hs b/examples/LangExt.hs deleted file mode 100644 --- a/examples/LangExt.hs +++ /dev/null @@ -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 - - diff --git a/examples/LangExt.old b/examples/LangExt.old deleted file mode 100644 --- a/examples/LangExt.old +++ /dev/null @@ -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 - --} diff --git a/examples/List.hs b/examples/List.hs new file mode 100644 --- /dev/null +++ b/examples/List.hs @@ -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 diff --git a/examples/Main.hs b/examples/Main.hs deleted file mode 100644 --- a/examples/Main.hs +++ /dev/null @@ -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 - diff --git a/examples/RepminTH.lhs b/examples/RepminTH.lhs new file mode 100644 --- /dev/null +++ b/examples/RepminTH.lhs @@ -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 diff --git a/examples/RepminTHExt.lhs b/examples/RepminTHExt.lhs new file mode 100644 --- /dev/null +++ b/examples/RepminTHExt.lhs @@ -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) diff --git a/examples/calc.hs b/examples/calc.hs deleted file mode 100644 --- a/examples/calc.hs +++ /dev/null @@ -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 - diff --git a/examples/calcM.hs b/examples/calcM.hs deleted file mode 100644 --- a/examples/calcM.hs +++ /dev/null @@ -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 - - diff --git a/examples/repmin.hs b/examples/repmin.hs deleted file mode 100644 --- a/examples/repmin.hs +++ /dev/null @@ -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 - - diff --git a/examples/repminM.hs b/examples/repminM.hs deleted file mode 100644 --- a/examples/repminM.hs +++ /dev/null @@ -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 - - diff --git a/examples/test1.hs b/examples/test1.hs deleted file mode 100644 --- a/examples/test1.hs +++ /dev/null @@ -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 - diff --git a/examples/test1TH.hs b/examples/test1TH.hs deleted file mode 100644 --- a/examples/test1TH.hs +++ /dev/null @@ -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 - diff --git a/examples/test2.hs b/examples/test2.hs deleted file mode 100644 --- a/examples/test2.hs +++ /dev/null @@ -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 - diff --git a/examples/test2TH.hs b/examples/test2TH.hs deleted file mode 100644 --- a/examples/test2TH.hs +++ /dev/null @@ -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 - diff --git a/examples/test3.hs b/examples/test3.hs deleted file mode 100644 --- a/examples/test3.hs +++ /dev/null @@ -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 - diff --git a/examples/test3TH.hs b/examples/test3TH.hs deleted file mode 100644 --- a/examples/test3TH.hs +++ /dev/null @@ -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 - diff --git a/examples/test4.hs b/examples/test4.hs deleted file mode 100644 --- a/examples/test4.hs +++ /dev/null @@ -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 - - diff --git a/examples/test4TH.hs b/examples/test4TH.hs deleted file mode 100644 --- a/examples/test4TH.hs +++ /dev/null @@ -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 - - diff --git a/examples/test5.hs b/examples/test5.hs deleted file mode 100644 --- a/examples/test5.hs +++ /dev/null @@ -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 - diff --git a/examples/test5TH.hs b/examples/test5TH.hs deleted file mode 100644 --- a/examples/test5TH.hs +++ /dev/null @@ -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 - diff --git a/examples/testEmptyNode.hs b/examples/testEmptyNode.hs deleted file mode 100644 --- a/examples/testEmptyNode.hs +++ /dev/null @@ -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 - diff --git a/examples/testList.hs b/examples/testList.hs deleted file mode 100644 --- a/examples/testList.hs +++ /dev/null @@ -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 - diff --git a/src/Language/Grammars/AspectAG.hs b/src/Language/Grammars/AspectAG.hs --- a/src/Language/Grammars/AspectAG.hs +++ b/src/Language/Grammars/AspectAG.hs @@ -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: - . --} - - -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 diff --git a/src/Language/Grammars/AspectAG/Derive.hs b/src/Language/Grammars/AspectAG/Derive.hs deleted file mode 100644 --- a/src/Language/Grammars/AspectAG/Derive.hs +++ /dev/null @@ -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 diff --git a/src/Language/Grammars/AspectAG/GenRecord.hs b/src/Language/Grammars/AspectAG/GenRecord.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/AspectAG/GenRecord.hs @@ -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 {} diff --git a/src/Language/Grammars/AspectAG/HList.hs b/src/Language/Grammars/AspectAG/HList.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/AspectAG/HList.hs @@ -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 diff --git a/src/Language/Grammars/AspectAG/RecordInstances.hs b/src/Language/Grammars/AspectAG/RecordInstances.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/AspectAG/RecordInstances.hs @@ -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 " diff --git a/src/Language/Grammars/AspectAG/Require.hs b/src/Language/Grammars/AspectAG/Require.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/AspectAG/Require.hs @@ -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) + diff --git a/src/Language/Grammars/AspectAG/TH.hs b/src/Language/Grammars/AspectAG/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/AspectAG/TH.hs @@ -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 ] + + diff --git a/src/Language/Grammars/AspectAG/TPrelude.hs b/src/Language/Grammars/AspectAG/TPrelude.hs new file mode 100644 --- /dev/null +++ b/src/Language/Grammars/AspectAG/TPrelude.hs @@ -0,0 +1,135 @@ +{-| +Module : Language.Grammars.AspectAG.TPrelude +Description : Some type level functions, needed for AspectAG +Copyright : (c) Juan García Garland, 2018 +License : LGPL +Maintainer : jpgarcia@fing.edu.uy +Stability : experimental +Portability : POSIX + + +-} +{-# LANGUAGE GADTs, + KindSignatures, + TypeOperators, + TypeFamilies, + MultiParamTypeClasses, + FlexibleInstances, + FlexibleContexts, + StandaloneDeriving, + UndecidableInstances, + FunctionalDependencies, + ConstraintKinds, + ScopedTypeVariables, + PolyKinds, + DataKinds +#-} + +module Language.Grammars.AspectAG.TPrelude where +import Data.Kind +import Data.Type.Equality +import GHC.TypeLits +import Data.Proxy + + +data Label l = Label +sndLabel :: Label '(a,b) -> Label b +sndLabel _ = undefined + +getProxy :: a -> Proxy a ; getProxy _ = Proxy +getLabel :: a -> Label a ; getLabel _ = Label + +proxyFrom :: t a -> Proxy a +proxyFrom _ = Proxy + + +-- | If construction, purely computed at type level +type family If (cond:: Bool) (thn :: k) (els :: k) :: k where + If 'True thn els = thn + If 'False thn els = els + +-- | Or, purely computed at type level +type family Or (l :: Bool)(r :: Bool) :: Bool where + Or False b = b + Or True b = 'True + + +-- | And, purely computed at type level +type family And (l :: Bool)(r :: Bool) :: Bool where + And False b = False + And True b = b + +-- | Not, purely computed at type level +type family Not (l :: Bool) :: Bool where + Not False = True + Not True = False + + +-- | LabelSet is a predicate over lists of pairs. +--We assume the list represent a (partial) mapping from k1 to k2. +--k1 is a label, k2 possibly a value. +--The first member of each pair must be unique, this is a predicate of +--well formedness +-- class LabelSet (l :: [(k1,k2)]) + +type family LabelSetF (r :: [(k, k')]) :: Bool where + LabelSetF '[] = True + LabelSetF '[ '(l, v)] = True + LabelSetF ( '(l, v) ': '(l', v') ': r) = And3 (Not (l == l')) + (LabelSetF ( '(l, v) ': r) ) + (LabelSetF ( '(l', v') ': r) ) + +{- +class LabelSet (r :: [(k, k')]) where {} +instance LabelSetF r ~ True => LabelSet r +-} + +type LabelSet r = LabelSetF r ~ True + +type family And3 (a1 :: Bool) (a2 :: Bool) (a3 :: Bool) where + And3 True True True = True + And3 _ _ _ = False + +-- | Predicate of membership, for lists at type level +type family HMemberT (e::k)(l ::[k]) :: Bool where + HMemberT k '[] = 'False + HMemberT k ( k' ': l) = If (k==k') 'True (HMemberT k l) + + +-- | Predicate of membership, for labels at type level +type family HasLabelT (l::k) (lst :: [(k,Type)]) :: Bool where + HasLabelT l '[] = 'False + HasLabelT l ( '(k,v) ': tail) = If (l == k) 'True (HasLabelT l tail) + + +-- |This is used for type Equality +class HEq (x :: k) (y :: k) (b :: Bool) | x y -> b +type HEqK (x :: k1) (y :: k2) (b :: Bool) = HEq (Proxy x) (Proxy y) b +instance ((Proxy x == Proxy y) ~ b) => HEq x y b + +type family HEqKF (a :: k)(b :: k) :: Bool +type instance HEqKF a b = a == b + + +-- | heterogeneous equality at type level +type family (a :: k1) === (b :: k2) where + a === b = (Proxy a) == (Proxy b) + + +type family TPair (a :: k) b where + TPair a b = '(a, b) + + +type family LabelsOf (r :: [(k, k')]) :: [k] where + LabelsOf '[] = '[] + LabelsOf ( '(k, ks) ': ls) = k ': LabelsOf ls + +type family HasLabel (l :: k) (r :: [(k, k')]) :: Bool where + HasLabel l '[] = False + HasLabel l ( '(l', v) ': r) = Or (l == l') (HasLabel l r) + + +type family Equal (a:: k)(b :: k') :: Bool where +-- Equal (f a) (g b) = And (Equal f g) (Equal a b) + Equal a a = True + Equal a b = False