diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,35 @@ +# Revision history for descript-lang + +## 0.1.0 -- 2017-05-29 + +## 0.2.0 -- 2018-04-09 + +- Starting almost from Scratch. Keeping the same syntax, name, general + concept / philosophy, and language. Getting rid of the "logical" + idea where when a value implies something else, it still "remembers" its old self - + e.g. if `a: b` and `a: c`, before `a: b | c`, now you would get an ambiguity error. + That made the time complexity way too high. + +## 0.2.1 -- 2018-04-23 + +- Got the CLI able to interpret and print out (evaluate) simple + programs. + +## 0.2.2 -- 2018-05-01 + +- Got the core language working: + - Parses + - Validates + - Interprets + - Evaluates + - Compiles + - Reprints + - Refactors (currently just renames record heads) + +## 0.2.3 -- 2018-05-11 + +- Added a basic language server, a few bugs but usable. + +## 0.2.4 -- 2018-05-17 + +- Added importing and dependencies, refactored build model. 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,252 @@ +# Descript-lang + +Simple programming language, work-in-progress. + +The name comes from the philosophy that code "describes" what you want +the computer to do. + +Currently Implemented: + +- Information can be encoded multiple ways in a single value. +- Minimal syntax, flexible (like LISP). +- Macros +- Refactoring - being developed alongside an IDE, `descript-lang-vscode`. + +> Future Plans: +> +> - Gradual, "ad-hoc" typing +> - Strict syntax and semantics, to reduce careless mistakes. + +## Setup + +This is a Stack package. It should be installable via: + +```repl +> stack install descript-lang +``` + +otherwise, clone this repository and install manually. + +## Examples + +Skip to [[Overview]] for specific semantics. These examples are all +located in `docs/examples` (not yet). + +> Most of these examples should actually compile in the current version +> of Descript. If not, they should compile in a future version. Any +> example could be modified in the future as the language develops. + +### Basic + +Here's an example program: + +```descript +//Records. These are data structures and function signatures. +//These records define natural numbers and addition. +Zero[]. //0 - in other languages this would be an ADT or singleton. +Succ[prev]. //1 + prev - in other languages this would be an ADT, structure, or object. +Add[a, b]. //a + b - in other languages this would be a function. + +//Reducers. Reducers are like function implementations. These reducers "implement" Add. +Add[a: Zero[], b]: b //Adding 0 to anything produces 0. +Add[a: Succ[prev], b]: Add[a>prev, Succ[prev: b]] //Adding 1 + n to anything produces n + (1 + anything). + +//The main value. In other languages this would be the "main" function. +//When the program is run, it will apply the reducers to this value and output the result. +Add[ + Succ[prev: Succ[prev: Succ[prev: Zero[]]]] + Succ[prev: Succ[prev: Zero[]]] +]? //This encodes (2 + 3). What does it reduce to? +``` + +Assuming the above program is in a file named `Basic.dscr`, it can be +evaluated in a terminal: + +```repl +> descript-cli eval Basic.dscr +Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]]] +``` + +### Types + +The above example doesn't include types. Here's another example which +does contain types. Notice that this example is exactly the same as the +above example with some extra code (the types) added. + +```descript +//Records. These are data structures and function signatures. +//These records define natural numbers and addition. +Nat[]. //A natural number - in other languages this would be a type. +Untyped[]. //Denotes that a value needs to be typed. +Zero[]. //0 - in other languages this would be an ADT or singleton. +Succ[prev]. //1 + prev - in other languages this would be an ADT, structure, or object. +Add[a, b]. //a + b - in other languages this would be a function. + +//Reducers. Reducers are like function implementations. These reducers "implement" Add. +Add[a: Nat[], b: Nat[]] | Untyped[]: Nat[] //Adding naturals produces a natural. +Add[a: Zero[], b]: b //Adding 0 to anything produces 0. +Add[a: Succ[prev], b]: Add[a: a>prev, b: Succ[prev: b]] //Adding 1 + n to anything produces n + (1 + anything). + +//More reducers. These reducers aren't really function implementations. +//In other languages, these would assign the types to the instances. +Zero[] | Untyped[]: Zero[] | Nat[] //Zero is a natural. Need `Zero[]` in RHS so it isn't consumed. +Succ[prev: Nat[]] | Untyped[]: Nat[] //1 + n is a natural if n is a natural. Don't need `Succ[...]` in RHS because the only part consumed is the type. + +//The main value. In other languages this would be the "main" function. +//When the program is run, it will apply the reducers to this value and output the result. +Add[ + a: Succ[prev: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]] | Untyped[] + b: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[] +] | Untyped[]? //What does this reduce to? + +``` + +This above program evaluated: + +```repl +> descript-cli eval Types.dscr +Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Zero[] | Nat[]] | Nat[]] | Nat[]] | Nat[]] | Nat[]] | Nat[] +``` + +### Primitives and Built-ins + +Descript has built-in support for basic things like numbers and +addition. The following example: + +```descript +Add[left, right]. + +Add[left: #Number[], right: #Number[]]: #Add[a: left, b: right] + +Add[left: 3, right: 2]? +``` + +evaluated: + +```repl +> descript-cli eval Primitive.dscr +5 +``` + +### Modules + +Descript also allows one file to import another, via modules: + +```descript +//Module declaration. +//If not provided, all files will implicitly have `module `. +//This is required for a file import other files outside its directory. +module Import + +import Base{Add} + +Exp2[5]? +``` + +evaluated: + +```repl +> descript-cli eval Import.dscr +25 +``` + +### Compiled + +All of the above examples would be considered "interpreted". A Descript +program can also be compiled, if you make its main value reduce to code +block - a record which represents source code. + +```descript +import Base + +Prgm[statement]. +Print[text]. + +Prgm[statement: Code[lang: "C", content: String]]: Code[ + lang: "C" + content: App3[left: "int main(string[] args) { ", center: statement>content, right: "}"] +] +Print[text: String]: Code[lang: "C", content: App3[left: "println(\"", center: text, right: "\");"] + +Prgm[statement: Print[text: "Hello world"]]? +``` + +the above program evaluates: + +```repl +> descript-cli eval Import.dscr +Code[lang: "C", content: "int main(string[] args) { println(\"Hello world!\"); }"] +``` + +but it can also be compiled: + +```repl +> descript-cli compile Import.dscr +``` + +the above command will generate a new file, `Import.c`. When fed to a C +compiler, this will create a simple "Hello world" program. + +> In the future, the Descript CLI will probably invoke the C compiler +> itself. Multi-file packages (compiled outputs) will also be implemented. + +### Syntax Sugar + +> ... TODO Specify - what is the syntax sugar, and how should it be +implemented? + +### Macros + +> ... TODO Describe macros + +## Overview + +See [[Specs]] for a full, more detailed specification. + +There are 2 types of expressions - **values** and **reducers**. +**Values** are unions of **parts**. Example: `A[] | "B" | C[d: E[]]`. +There are 2 types of **parts**: + +- **Atoms**: Numbers, strings. Examples: `4`, `"Hello", "B"`. +- **Records**: These are like records in Haskell - each record has a + unique name, and can contain properties, which are other values. Examples: + `Hello[]`, `Foo[content: 3], A[], C[d: E[]]`. + +**Reducers** transform values, like functions in other language. +Example: `Foo[a: Bar[b]]: Baz[c: a>b]`. They consist of an +**input value** (`Foo[a: Bar[b]]`) and an **output value** +(`Baz[c: a>b]`). Input and output values are special: + +- Input values can contain properties without values. An example is the + `b` in `Bar[b]`. +- Output values can contain **property paths**. An example is `a>c` in + `Baz[c: a>c]`. + +A reducer can be **applied** to a value if its input **matches** parts +of it. The reducer **consumes** the parts of the value matched by its +input, and **produces** extra parts using its output. Examples: + +- Applying `Foo[a: Bar[b]]: Baz[c: a>b]` to `Foo[a: Bar[b: Qux[d: 7]]]` + yields `Baz[c: Qux[d: 7]]`. +- Applying `Foo[a: Bar[b]]: Baz[c: a>b]` to + `8 | Foo[a: Bar[b: Qux[d: 7]]] | XML[z: 15]` yields + `8 | Baz[c: Qux[d: 7]] | XML[z: 15]`. +- Applying `Foo[a: Bar[b]] | XML[z]: Baz[c: a>b]` to + `8 | Foo[a: Bar[b: Qux[d: 7]]] | XML[z: 15]` yields + `8 | Baz[c: Qux[d: 7]]`. +- You can't apply `Foo[a: Bar[b]] | XML[z]: Baz[c: a>b]` to + `Foo[a: Bar[b: Qux[d: 7]]]` (`XML[z]` doesn't match anything). + +Every program contains reducers, and a value called the **query**. The +program is **interpreted** by taking the query, and applying the +reducers to it as much as possible, until no reducers can be applied. + +Reducers can also be applied to input and output values - in these +cases, the reducers are **macros**. + +> ... TODO Better overview: +> +> - Improve readability +> - Describe how input and output are matched/consumed/produced +> (preferrably not verbosely?) +> - Maybe add record types and injections diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Action.hs b/app/Action.hs new file mode 100644 --- /dev/null +++ b/app/Action.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveFunctor #-} + +-- | Defines different actions and their arguments. +module Action + ( Action (..) + , IndivAction (..) + , Compile (..) + , Eval (..) + , Refactor (..) + , Watcher (..) + , PathAction (..) + , mkCompile + , mkRefactor + ) where + +import Data.Maybe +import System.FilePath + +data Action + = ActionServe + | ActionIndiv (Watcher IndivAction) + +data IndivAction + = ActionCompile Compile + | ActionEval Eval + | ActionRefactor Refactor + +data Compile + = Compile + { compilePath :: FilePath + , compileOutDir :: FilePath + } + +newtype Eval = Eval{ evalPath :: FilePath } + +data Refactor + = Refactor + { refactorAction :: String + , refactorArgs :: [String] + , refactorPath :: FilePath + , refactorOutPath :: FilePath + } + +data Watcher a = Watcher Bool a deriving (Functor) + +class PathAction a where + getSrcPath :: a -> FilePath + setSrcPath :: FilePath -> a -> a + +instance PathAction IndivAction where + getSrcPath (ActionCompile x) = getSrcPath x + getSrcPath (ActionEval x) = getSrcPath x + getSrcPath (ActionRefactor x) = getSrcPath x + setSrcPath new (ActionCompile x) = ActionCompile $ setSrcPath new x + setSrcPath new (ActionEval x) = ActionEval $ setSrcPath new x + setSrcPath new (ActionRefactor x) = ActionRefactor $ setSrcPath new x + +instance PathAction Compile where + getSrcPath = compilePath + setSrcPath new x = x{ compilePath = new } + +instance PathAction Eval where + getSrcPath = evalPath + setSrcPath new x = x{ evalPath = new } + +instance PathAction Refactor where + getSrcPath = refactorPath + setSrcPath new x = x{ refactorPath = new } + +mkCompile :: FilePath -> Maybe FilePath -> Compile +mkCompile path optOutDir + = Compile + { compilePath = path + , compileOutDir = takeDirectory path `fromMaybe` optOutDir + } + +mkRefactor :: String -> [String] -> FilePath -> Maybe FilePath -> Refactor +mkRefactor action args path optOutPath + = Refactor + { refactorAction = action + , refactorArgs = args + , refactorPath = path + , refactorOutPath = path `fromMaybe` optOutPath + } diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Run +import Parse + +main :: IO () +main = run =<< prompt diff --git a/app/Parse.hs b/app/Parse.hs new file mode 100644 --- /dev/null +++ b/app/Parse.hs @@ -0,0 +1,143 @@ +-- | Parses actions from the command line. +module Parse + ( prompt + ) where + +import Action +import Options.Applicative hiding (Success, Failure, action) +import Data.Semigroup ((<>)) + +prompt :: IO Action +prompt = execParser actionP + +actionP :: ParserInfo Action +actionP = info (helper <*> actionP_) actionInfo + +serveP :: ParserInfo () +serveP = info (helper <*> serveP_) serveInfo + +augCompileP :: ParserInfo (Watcher Compile) +augCompileP = info (helper <*> watchP_ compileP_) compileInfo + +augEvalP :: ParserInfo (Watcher Eval) +augEvalP = info (helper <*> watchP_ evalP_) evalInfo + +augRefactorP :: ParserInfo (Watcher Refactor) +augRefactorP = info (helper <*> watchP_ refactorP_) refactorInfo + +serveP_ :: Parser () +serveP_ = pure () + +actionP_ :: Parser Action +actionP_ = subparser $ mconcat actionCommands + +actionCommands :: [Mod CommandFields Action] +actionCommands = + [ command "serve" $ ActionServe <$ serveP + , commandGroup "Individual Comamnds:" + , command "compile" $ ActionIndiv . fmap ActionCompile <$> augCompileP + , command "eval" $ ActionIndiv . fmap ActionEval <$> augEvalP + , command "refactor" $ ActionIndiv . fmap ActionRefactor <$> augRefactorP + ] + +watchP_ :: Parser a -> Parser (Watcher a) +watchP_ subP_ = flip Watcher <$> subP_ <*> doWatch + where doWatch + = switch + $ long "watch" + <> short 'w' + <> help "Makes the source (SRC) a directory instead of a file. \ + \Every time a file in this directory (or subdirectory) changes, \ + \the action will be run on that specific file." + +compileP_ :: Parser Compile +compileP_ = mkCompile <$> src <*> optional out + where src + = strArgument + $ metavar "SRC" + <> help "Path to the source code" + out + = strOption + $ metavar "OUT" + <> long "output" + <> short 'o' + <> help "Directory where the compiled package will be saved. \ + \Defaults to the same directory as the source" + +evalP_ :: Parser Eval +evalP_ = Eval <$> src + where src + = strArgument + $ metavar "SRC" + <> help "Path to the source code" + +refactorP_ :: Parser Refactor +refactorP_ = mkRefactor <$> action <*> many arg <*> inPath <*> optional outPath + where action + = strArgument + $ metavar "ACTION" + <> help "The refactor action to run. --list for a full list" + arg + = strArgument + $ metavar "ARG" + <> help "Argument to the action. --list for a full list" + inPath + = strOption + $ metavar "SRC" + <> long "input" + <> short 'i' + <> help "Path to the source code" + outPath + = strOption + $ metavar "OUT" + <> long "output" + <> short 'o' + <> help "File where the refactored code will be saved. \ + \Defaults to the original path, so the original source is overwritten" + +actionInfo :: InfoMod a +actionInfo + = fullDesc + <> progDesc "Command-line interface for the Descript programming language" + <> header "descript-cli - command-line interface for the Descript programming language" + <> footer "This is the interface for the Descript programming language.\n\ + \It includes commands for simple actions, such as compiling individual files or doing basic refactors.\n\ + \It also includes a language server ('descript serve'), which adds Descript support to editors like VSCode." + +serveInfo :: InfoMod a +serveInfo + = fullDesc + <> progDesc "Start the language server" + <> header "descript-cli serve - start the language server" + <> footer "Only need one server per system, even if there are multiple workspaces and clients.\n\ + \This command should be called by language clients, such as the 'descript-lang' VSCode plugin,\n\ + \once they want to edit Descript files." + +compileInfo :: InfoMod a +compileInfo + = fullDesc + <> progDesc "Compile a Descript program" + <> header "descript-cli compile - compile a Descript program" + <> footer "Parses and interprets the program. \ + \Expects it's query to reduce into a compiled datatype (a primitive or 'Code' record). \ + \Generates a new file or directory with the output, \ + \in the same directory as the source. \ + \If you don't want to compile the query, \ + \you just want to see what it reduces to, \ + \use 'descript eval' instead." + +evalInfo :: InfoMod a +evalInfo + = fullDesc + <> progDesc "Evaluate a Descript program" + <> header "descript-cli eval - evaluate a Descript program" + <> footer "Parses and interprets the program. Then reprints its query. \ + \Useful for just experimenting with Descript. \ + \Also useful for debugging bad programs, e.g. ones which don't compile." + +refactorInfo :: InfoMod a +refactorInfo + = fullDesc + <> progDesc "Refactor a Descript source" + <> header "descript-cli refactor - refactor a Descript source" + <> footer "Modify a Descript source - for instance, rename a record" diff --git a/app/Run.hs b/app/Run.hs new file mode 100644 --- /dev/null +++ b/app/Run.hs @@ -0,0 +1,128 @@ +-- | Runs actions - actually does them. +module Run + ( run + ) where + +import Server.Run +import Action +import Descript +import Data.Char +import qualified Data.Text.IO as Text +import Control.Monad +import Rainbow hiding ((<>)) +import System.FilePath +import System.FSNotify hiding (Action) + +run :: Action -> IO () +run ActionServe = runServe +run (ActionIndiv indiv) = runWatcher runIndivAction indiv + +runWatcher :: (PathAction a) => (a -> IO ()) -> Watcher a -> IO () +runWatcher f (Watcher watch x) + | watch = withManager $ \mgr -> do + let runEvt = f . (`setSrcPath` x) . eventPath + stop <- watchTree mgr (getSrcPath x) rerunForEvt runEvt + putStrLn "Press 'enter' to stop watching" + _ <- getLine + stop + | otherwise = f x + +runIndivAction :: IndivAction -> IO () +runIndivAction (ActionCompile x) = runCompile x +runIndivAction (ActionEval x) = runEval x +runIndivAction (ActionRefactor x) = runRefactor x + +runCompile :: Compile -> IO () +runCompile (Compile path outDir) = do + file <- loadFile path + res <- runResultT $ compile file + case res of + Failure err -> do + putFailureLn + putStrLn $ summaryF (sfile file) err + Success package -> do + putAlmostLn + savePackage outDir package + putSuccessLn + putStrLn $ "Compiled to " ++ outDir packageName package + +runEval :: Eval -> IO () +runEval (Eval path) = do + file <- loadFile path + res <- runResultT $ eval file + case res of + Failure err -> do + putFailureLn + putStrLn $ summaryF (sfile file) err + Success x -> do + putAlmostLn + x `seq` pure () + putSuccessLn + Text.putStrLn x + +runRefactor :: Refactor -> IO () +runRefactor (Refactor action args path outPath) = do + file <- loadFile path + Dirty warnings res <- runDirtyResT $ parseRefactor action args file + case res of + Failure err -> do + putFailureLn + putStrLn $ summaryF (sfile file) err + Success patch -> do + if null warnings then + continueRefactor + else do + putWarningLn + $ "the refactor might create problems - \ + \the refactored file might have different semantics." + forM_ warnings $ \warning -> + putStrLn $ summary warning + doContinue <- promptContinue + if doContinue then + continueRefactor + else + putAbortedLn + where continueRefactor = do + putAlmostLn + let out = apPatch patch $ fileContents file + Text.writeFile outPath out + putSuccessLn + if path == outPath then + putStrLn $ "Refactored" + else + putStrLn $ "Refactored to " ++ outPath + +putFailureLn :: IO () +putFailureLn = putChunkLn $ fore red $ chunk $ "Failure:" + +putAbortedLn :: IO () +putAbortedLn = putChunkLn $ fore red $ chunk "Aborted" + +putWarningLn :: String -> IO () +putWarningLn msg = putChunkLn $ fore yellow $ chunk $ "Warning: " ++ msg + +putAlmostLn :: IO () +putAlmostLn = putChunkLn $ faint $ chunk "..." + +putSuccessLn :: IO () +putSuccessLn = putChunkLn $ fore green $ chunk "Success:" + +promptContinue :: IO Bool +promptContinue = do + putChunkLn $ fore yellow $ chunk "Continue? (yes or no)" + prompt + +prompt :: IO Bool +prompt = do + res <- map toLower <$> getLine + case res of + "yes" -> pure True + "no" -> pure False + _ -> do + putStrLn "Type either 'yes' or 'no'" + prompt + +rerunForEvt :: Event -> Bool +rerunForEvt (Added _ _) = True +rerunForEvt (Modified _ _) = True +rerunForEvt (Removed _ _) = False diff --git a/app/Server/Decode.hs b/app/Server/Decode.hs new file mode 100644 --- /dev/null +++ b/app/Server/Decode.hs @@ -0,0 +1,51 @@ +module Server.Decode + ( decodeChange + , decodeRange + , decodeLoc + , decodeUri + ) where + +import Descript.Misc +import qualified Language.Haskell.LSP.Types as J +import qualified Data.Text as Text +import Network.URI + +decodeChange :: (J.List J.TextDocumentContentChangeEvent) -> Change +-- LSP stores patches from bottom to top, Descript lib stores from top +-- to bottom. Maybe in the future should switch lib to bottom to top. +decodeChange (J.List xs) + = foldMap liftCPatch <$> traverse decodeCChange (reverse xs) + +decodeCChange :: J.TextDocumentContentChangeEvent -> CChange +decodeCChange (J.TextDocumentContentChangeEvent Nothing _ text) + = Left text +decodeCChange (J.TextDocumentContentChangeEvent (Just range) _ text) + = Right CPatch + { cpatchRange = decodeRange range + , cpatchText = text + } + +decodeRange :: J.Range -> Range +decodeRange (J.Range start' end') + = Range + { start = decodeLoc start' + , end = decodeLoc end' + } + +decodeLoc :: J.Position -> Loc +decodeLoc (J.Position line' column') + = Loc + { line = mkPos $ succ line' + , column = mkPos $ succ column' + } + +-- TODO Maybe should preserve other URI information, and use MonadThrow +-- instead of error for bad URIs (although both should be caught). +decodeUri :: J.Uri -> FilePath +decodeUri = uriPath . forceParseURI . Text.unpack . J.getUri + +forceParseURI :: String -> URI +forceParseURI x + = case parseURI x of + Nothing -> error "Not a valid URI" + Just res -> res diff --git a/app/Server/Encode.hs b/app/Server/Encode.hs new file mode 100644 --- /dev/null +++ b/app/Server/Encode.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Server.Encode + ( encodeDiagnostic + , encodeParseError + , encodePatch + , encodeRange + , encodeLoc + , encodeUri + ) where + +import Descript.Misc +import qualified Language.Haskell.LSP.Types as J +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Monoid +import Network.URI + +encodeDiagnostic :: Diagnostic Range -> J.Diagnostic +encodeDiagnostic diag + = J.Diagnostic range' severity code source message relatedInformation + where range' = encodeRange $ getAnn diag + -- Technically an error, but warnings aren't implemented, and + -- this distinguishes from parse errors which are more severe. + severity = Just $ diagTypeSeverity $ diagType + code = Nothing + source = Just $ diagTypeSource diagType + message = Text.pack $ baseSummary diag + relatedInformation = Just $ J.List [] + diagType = getDiagType diag + +diagTypeSeverity :: DiagType -> J.DiagnosticSeverity +diagTypeSeverity DiagProblemType = J.DsWarning +diagTypeSeverity DiagEvalType = J.DsHint + +diagTypeSource :: DiagType -> Text +diagTypeSource DiagProblemType = "validate" +diagTypeSource DiagEvalType = "eval" + +encodeParseError :: ParseError Char -> [J.Diagnostic] +encodeParseError = map encodeRangedErrMsg . splitParseError + +encodeRangedErrMsg :: RangedErrorMsg -> J.Diagnostic +encodeRangedErrMsg (RangedErrorMsg range msg) + = J.Diagnostic range' severity code source message relatedInformation + where range' = encodeRange range + severity = Just J.DsError + code = Nothing + source = Just "parse" + message = "Parse error: " <> Text.pack msg + relatedInformation = Just $ J.List [] + +encodePatch :: Patch -> J.List J.TextEdit +-- LSP stores patches from bottom to top, Descript lib stores from top +-- to bottom. Maybe in the future should switch lib to bottom to top. +encodePatch = J.List . map encodeCPatch . reverse . cpatches + +encodeCPatch :: CPatch -> J.TextEdit +encodeCPatch (CPatch range text) = J.TextEdit (encodeRange range) text + +encodeRange :: Range -> J.Range +encodeRange (Range start' end') = J.Range (encodeLoc start') (encodeLoc end') + +encodeLoc :: Loc -> J.Position +encodeLoc (Loc line' column') = J.Position (pred $ unPos line') (pred $ unPos column') + +-- TODO Maybe should preserve other URI information, and use MonadThrow +-- instead of error for bad URIs (although both should be caught). +encodeUri :: FilePath -> J.Uri +encodeUri = J.Uri . Text.pack . uriToString' . mkPathURI + +uriToString' :: URI -> String +uriToString' x = uriToString id x "" + +mkPathURI :: FilePath -> URI +mkPathURI path' + = URI + { uriScheme = "file:" + , uriAuthority = Just nullURIAuth + , uriPath = path' + , uriQuery = "" + , uriFragment = "" + } + +nullURIAuth :: URIAuth +nullURIAuth + = URIAuth + { uriUserInfo = "" + , uriRegName = "" + , uriPort = "" + } diff --git a/app/Server/Run.hs b/app/Server/Run.hs new file mode 100644 --- /dev/null +++ b/app/Server/Run.hs @@ -0,0 +1,679 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Server.Run + ( runServe + ) where + +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Lens +import Control.Monad +import qualified Control.Monad.Catch as E +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.STM +import qualified Data.Aeson as J +import Data.Default +import Data.Monoid +import qualified Data.Text as T +import Descript.Build +import qualified Descript.BasicInj as BasicInj +import Descript.Misc +import qualified Language.Haskell.LSP.Control as CTRL +import qualified Language.Haskell.LSP.Core as Core +import Language.Haskell.LSP.Diagnostics +import Language.Haskell.LSP.Messages +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Utility as U +import Server.Decode +import Server.Encode +import System.Exit +import qualified System.Log.Logger as L + +runServe :: IO () +runServe = do + -- putStrLn "Starting server..." + serve handleServerStart >>= \case + 0 -> do + putStrLn "Server stopped" + exitSuccess + c -> do + putStrLn $ "Server stopped with error or interrupt" + exitWith . ExitFailure $ c + +handleServerStart :: IO () +handleServerStart = do + -- putStrLn "Server started. Ctrl-C to stop" + pure () + +-- Derived from Haskell LSP example +-- (https://github.com/alanz/haskell-lsp/blob/master/example/Main.hs) +-- and Haskell IDE Engine implementation +-- (https://github.com/alanz/haskell-ide-engine/blob/master/src/Haskell/Ide/Engine/Transport/LspStdio.hs) +-- --------------------------------------------------------------------- + +serve :: IO () -> IO Int +serve dispatcherProc = E.handle finishErr $ do + rin <- atomically newTChan :: IO (TChan ReactorInput) + let dp lf = do + liftIO $ U.logs $ "main.run:dp entered" + dispatcherProc + liftIO $ U.logs $ "main.run:dp after dispatcher" + _ <- forkIO $ reactor lf rin + pure Nothing + Core.setupLogger (Just "/tmp/descript-server.log") [] L.DEBUG + res <- CTRL.run (getConfig, dp) (lspHandlers rin) lspOptions + U.logs $ "****** FINISHED WITH CODE: " ++ show res + finish + pure res + where finishErr (e :: E.SomeException) = do + U.logs $ "****** FINISHED WITH ERROR: " ++ show e + finish + pure 1 + finish = L.removeAllHandlers + +-- --------------------------------------------------------------------- + +-- | Callback from haskell-lsp core to convert the generic message to the +-- specific one for hie +getConfig :: J.DidChangeConfigurationNotification -> Either T.Text Config +getConfig (J.NotificationMessage _ _ (J.DidChangeConfigurationParams p)) = + case J.fromJSON p of + J.Success c -> Right c + J.Error err -> Left $ T.pack err + +newtype Config = + Config + { maxNumberOfProblems :: Int + } deriving (Show) + +instance J.FromJSON Config where + parseJSON = J.withObject "Config" $ \v -> do + s <- v J..: "descript" + flip (J.withObject "Config.settings") s $ \o -> Config + <$> o J..: "maxNumberOfProblems" + +-- --------------------------------------------------------------------- + +-- The reactor is a process that serialises and buffers all requests from the +-- LSP client, so they can be sent to the backend compiler one at a time, and a +-- reply sent. + +data ReactorInput + = HandlerRequest Core.OutMessage + -- ^ injected into the reactor input by each of the individual callback handlers + +-- --------------------------------------------------------------------- + +-- | The monad used in the reactor +type R a = ReaderT (Core.LspFuncs Config) IO a + +-- --------------------------------------------------------------------- +-- reactor monad functions +-- --------------------------------------------------------------------- + +-- Unlike makeResponseMessage, allows for a response for an arbitrary +-- request (without request type). +makeResponseMessage' :: J.LspIdRsp -> resp -> J.ResponseMessage resp +makeResponseMessage' rid result + = J.ResponseMessage "2.0" rid (Just result) Nothing + +-- --------------------------------------------------------------------- + +reactorSend :: (J.ToJSON a) => a -> R () +reactorSend msg = do + lf <- ask + liftIO $ Core.sendFunc lf msg + +-- --------------------------------------------------------------------- + +publishDiagnostics :: J.Uri -> Maybe J.TextDocumentVersion -> DiagnosticsBySource -> R () +publishDiagnostics uri mv diags = do + lf <- ask + config <- liftIO $ Core.config lf + let maxNumProbs + = case maxNumberOfProblems <$> config of + Nothing -> maxBound + Just (-1) -> maxBound + Just x -> x + liftIO $ (Core.publishDiagnosticsFunc lf) maxNumProbs uri mv diags + +-- --------------------------------------------------------------------- + +nextLspReqId :: R J.LspId +nextLspReqId = do + f <- asks Core.getNextReqId + liftIO $ f + +-- --------------------------------------------------------------------- + +-- | The single point that all events flow through, allowing management of state +-- to stitch replies and requests together from the two asynchronous sides: lsp +-- server and backend compiler +reactor :: Core.LspFuncs Config -> TChan ReactorInput -> IO () +reactor lf inp = flip runReaderT lf $ do + liftIO $ U.logs $ "reactor:entered" + cache <- newGlobalCache + let handlers = [ E.Handler onSomeExcept + ] + onSomeExcept (e :: E.SomeException) = do + liftIO $ U.logm $ "****** EXCEPTION ******" + liftIO $ U.logs $ show e + forever $ (`E.catches` handlers) $ do + HandlerRequest inval <- liftIO $ atomically $ readTChan inp + case inval of + + -- Handle any response from a message originating at the server, such as + -- "workspace/applyEdit" + Core.RspFromClient rm -> do + liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show rm + + -- ------------------------------- + + Core.NotInitialized _notification -> do + liftIO $ U.logm $ "****** reactor: processing Initialized Notification" + -- Server is ready, register any specific capabilities we need + + {- + Example: + { + "method": "client/registerCapability", + "params": { + "registrations": [ + { + "id": "79eee87c-c409-4664-8102-e03263673f6f", + "method": "textDocument/willSaveWaitUntil", + "registerOptions": { + "documentSelector": [ + { "language": "javascript" } + ] + } + } + ] + } + } + -} + let registration = J.Registration "descript-server-registered" J.WorkspaceExecuteCommand Nothing + registrations = J.RegistrationParams $ J.List [registration] + rid <- nextLspReqId + + reactorSend $ fmServerRegisterCapabilityRequest rid registrations + + -- ------------------------------- + + Core.NotDidOpenTextDocument notification -> do + liftIO $ U.logm $ "****** reactor: processing NotDidOpenTextDocument" + let doc = notification ^. J.params . J.textDocument + uri = decodeUri $ doc ^. J.uri + version = doc ^. J.version + text = doc ^. J.text + liftIO $ U.logs $ "********* uri = " ++ show uri + addFile (inDelegate uri) uri version text cache + + -- ------------------------------- + + Core.NotDidCloseTextDocument notification -> do + liftIO $ U.logm $ "****** reactor: processing NotDidCloseTextDocument" + let uri = decodeUri $ notification ^. J.params . J.textDocument . J.uri + liftIO $ U.logs $ "********* uri = " ++ show uri + delFile uri cache + + -- ------------------------------- + + Core.NotDidChangeTextDocument notification -> do + liftIO $ U.logm $ "****** reactor: processing NotDidChangeTextDocument" + let params = notification ^. J.params + doc = params ^. J.textDocument + uri = decodeUri $ doc ^. J.uri + version = doc ^. J.version + change = decodeChange $ params ^. J.contentChanges + liftIO $ U.logs $ "********* uri = " ++ show uri + changeFile (inDelegate uri) uri version change cache + + -- ------------------------------- + + Core.NotDidSaveTextDocument notification -> do + liftIO $ U.logm "****** reactor: processing NotDidSaveTextDocument" + let uri = decodeUri $ notification ^. J.params . J.textDocument . J.uri + liftIO $ U.logs $ "********* uri = " ++ show uri + + -- ------------------------------- + + Core.ReqRename req -> do + liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req + let rid = J.responseId $ req ^. J.id + params = req ^. J.params + doc = params ^. J.textDocument + uri = decodeUri $ doc ^. J.uri + loc = decodeLoc $ params ^. J.position + newName = T.unpack $ params ^. J.newName + refactorFile (outDelegate rid uri) uri (BasicInj.renameSymbolAt loc newName) cache + + -- ------------------------------- + + Core.ReqHover req -> do + liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req + {- let J.TextDocumentPositionParams _doc pos = req ^. J.params + + let ht = J.Hover ms (Just range) + ms = J.List [J.CodeString $ J.LanguageString "descript" "TYPE INFO" ] + range = J.Range pos pos + reactorSend $ Core.makeResponseMessage req ht -} + + -- ------------------------------- + + Core.ReqCodeAction req -> do + liftIO $ U.logs $ "reactor:got CodeActionRequest:" ++ show req + {- let params = req ^. J.params + doc = params ^. J.textDocument + -- fileName = drop (length ("file://"::String)) doc + -- J.Range from to = J._range (params :: J.CodeActionParams) + (J.List diags) = params ^. J.context . J.diagnostics + + let + -- makeCommand only generates commands for diagnostics whose source is us + makeCommand (J.Diagnostic (J.Range start _) _s _c (Just "descript") _m _l) = [J.Command title cmd cmdparams] + where + title = "Apply Descript command:" <> head (T.lines _m) + -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above + cmd = "rename" + -- need 'file' and 'start_pos' + args = J.Array$ V.fromList + [ J.Object $ H.fromList [("file", J.Object $ H.fromList [("textDocument",J.toJSON doc)])] + , J.Object $ H.fromList [("start_pos",J.Object $ H.fromList [("position", J.toJSON start)])] + ] + cmdparams = Just args + makeCommand (J.Diagnostic _r _s _c _source _m _l) = [] + let body = J.List $ concatMap makeCommand diags + reactorSend $ Core.makeResponseMessage req body -} + + -- ------------------------------- + + Core.ReqExecuteCommand req -> do + liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req + {- let params = req ^. J.params + margs = params ^. J.arguments + + liftIO $ U.logs $ "reactor:ExecuteCommandRequest:margs=" ++ show margs + + let + reply v = reactorSend $ Core.makeResponseMessage req v + -- When we get a RefactorResult or HieDiff, we need to send a + -- separate WorkspaceEdit Notification + r = J.List [] :: J.List Int + liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show r + case toWorkspaceEdit r of + Just we -> do + reply (J.Object mempty) + lid <- nextLspReqId + -- reactorSend $ J.RequestMessage "2.0" lid "workspace/applyEdit" (Just we) + reactorSend $ fmServerApplyWorkspaceEditRequest lid we + Nothing -> + reply (J.Object mempty) -} + + -- ------------------------------- + + Core.ReqCompletion req -> do + liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req + {- let params = req ^. J.params + filePath = J.uriToFilePath $ params ^. J.textDocument ^. J.uri + pos = params ^. J.position + + mprefix <- getPrefixAtPos doc pos + + callback <- hieResponseHelper (req ^. J.id) $ \compls -> do + let rspMsg = Core.makeResponseMessage req + $ J.Completions $ J.List compls + reactorSend rspMsg + case mprefix of + Nothing -> liftIO $ callback $ IdeResponseOk [] + Just prefix -> do + let hreq = IReq (req ^. J.id) callback + $ Hie.getCompletions doc prefix + makeRequest hreq -} + + Core.ReqCompletionItemResolve req -> do + liftIO $ U.logs $ "reactor:got CompletionItemResolveRequest:" ++ show req + {- let origCompl = req ^. J.params + mquery = case J.fromJSON <$> origCompl ^. J.xdata of + Just (J.Success q) -> Just q + _ -> Nothing + callback <- hieResponseHelper (req ^. J.id) $ \docs -> do + let rspMsg = Core.makeResponseMessage req $ + origCompl & J.documentation .~ docs + reactorSend rspMsg + let hreq = GReq Nothing Nothing (Just $ req ^. J.id) callback $ runExceptT $ do + case mquery of + Nothing -> return Nothing + Just query -> do + res <- lift $ liftToGhc $ Hoogle.infoCmd' query + case res of + Right x -> return $ Just x + _ -> return Nothing + makeRequest hreq -} + + -- ------------------------------- + + Core.ReqDocumentHighlights req -> do + liftIO $ U.logs $ "reactor:got DocumentHighlightsRequest:" ++ show req + {- let rid = J.responseId $ req ^. J.id + params = req ^. J.params + doc = params ^. J.textDocument + uri = decodeUri $ doc ^. J.uri + loc = decodeLoc $ params ^. J.position + refsRes <- inspectFile uri (BasicInj.refsToSymbolAt loc) cache + case refsRes of + Failure err -> do + let msg = Text.pack $ summary err + rerr = J.ResponseError J.InvalidRequest msg Nothing + Core.makeResponseError req rerr + Just refs -> do + let erefs = encodeReferences refs + rsp = Core.makeResponseMessage req erefs + reactorSend rsp -} + + {- let params = req ^. J.params + doc = params ^. J.textDocument ^. J.uri + pos = params ^. J.position + callback <- hieResponseHelper (req ^. J.id) $ \highlights -> do + let rspMsg = Core.makeResponseMessage req $ J.List highlights + reactorSend rspMsg + let hreq = IReq (req ^. J.id) callback + $ Hie.getReferencesInDoc doc pos + makeRequest hreq -} + + -- ------------------------------- + + Core.ReqDefinition req -> do + liftIO $ U.logs $ "reactor:got DefinitionRequest:" ++ show req + {- let params = req ^. J.params + doc = params ^. J.textDocument . J.uri + pos = params ^. J.position + callback <- hieResponseHelper (req ^. J.id) $ \loc -> do + let rspMsg = Core.makeResponseMessage req loc + reactorSend rspMsg + let hreq = GReq (Just doc) Nothing (Just $ req ^. J.id) callback + $ fmap J.MultiLoc <$> Hie.findDef doc pos + makeRequest hreq -} + + Core.ReqFindReferences req -> do + liftIO $ U.logs $ "reactor:got FindReferences:" ++ show req + {- let params = req ^. J.params + doc = params ^. J.textDocument ^. J.uri + pos = params ^. J.position + callback <- hieResponseHelper (req ^. J.id) $ \highlights -> do + let rspMsg = Core.makeResponseMessage req $ J.List highlights + reactorSend rspMsg + let hreq = IReq (req ^. J.id) callback + $ fmap (map (J.Location doc . (^. J.range))) + <$> Hie.getReferencesInDoc doc pos + makeRequest hreq -} + + -- ------------------------------- + + Core.ReqDocumentFormatting req -> do + liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req + {- let params = req ^. J.params + doc = params ^. J.textDocument . J.uri + tabSize = params ^. J.options . J.tabSize + callback <- hieResponseHelper (req ^. J.id) $ \textEdit -> do + let rspMsg = Core.makeResponseMessage req $ J.List textEdit + reactorSend rspMsg + let hreq = GReq (Just doc) Nothing (Just $ req ^. J.id) callback + $ Brittany.brittanyCmd tabSize doc Nothing + makeRequest hreq -} + + -- ------------------------------- + + Core.ReqDocumentRangeFormatting req -> do + liftIO $ U.logs $ "reactor:got FormatRequest:" ++ show req + {- let params = req ^. J.params + doc = params ^. J.textDocument . J.uri + range = params ^. J.range + tabSize = params ^. J.options . J.tabSize + callback <- hieResponseHelper (req ^. J.id) $ \textEdit -> do + let rspMsg = Core.makeResponseMessage req $ J.List textEdit + reactorSend rspMsg + let hreq = GReq (Just doc) Nothing (Just $ req ^. J.id) callback + $ Brittany.brittanyCmd tabSize doc (Just range) + makeRequest hreq -} + + -- ------------------------------- + + Core.ReqDocumentSymbols req -> do + liftIO $ U.logs $ "reactor:got Document symbol request:" ++ show req + {- let uri = req ^. J.params . J.textDocument . J.uri + callback <- hieResponseHelper (req ^. J.id) $ \docSymbols -> do + let rspMsg = Core.makeResponseMessage req $ J.List docSymbols + reactorSend rspMsg + let hreq = IReq (req ^. J.id) callback + $ Hie.getSymbols uri + makeRequest hreq -} + + -- ------------------------------- + + Core.NotCancelRequest notif -> do + liftIO $ U.logs $ "reactor:got CancelRequest:" ++ show notif + {- let lid = notif ^. J.params . J.id + liftIO $ atomically $ do + wip <- readTVar wipTVar + when (S.member lid wip) $ do + modifyTVar' cancelReqTVar (S.insert lid) -} + + -- ------------------------------- + + Core.NotDidChangeConfigurationParams notif -> do + liftIO $ U.logs $ "reactor:didChangeConfiguration notification:" ++ show notif + {- -- if hlint has been turned off, flush the disgnostics + diagsOn <- configVal True hlintOn + maxDiagnosticsToSend <- configVal 50 maxNumberOfProblems + liftIO $ U.logs $ "reactor:didChangeConfiguration diagsOn:" ++ show diagsOn + -- If hlint is off, remove the diags. But make sure they get sent, in + -- case maxDiagnosticsToSend has changed. + if diagsOn + then flushDiagnosticsBySource maxDiagnosticsToSend Nothing + else flushDiagnosticsBySource maxDiagnosticsToSend (Just "hlint") -} + + -- ------------------------------- + + om -> do + liftIO $ U.logs $ "reactor:got HandlerRequest:" ++ show om + +-- --------------------------------------------------------------------- + +inDelegate :: FilePath + -> CacheDelegate (ReaderT (Core.LspFuncs Config) IO) +inDelegate uri + = CacheDelegate + { onUpdateFile = onInUpdateFile uri + , onWarning = onInWarning + , onError = onInError uri + } + +outDelegate :: J.LspIdRsp + -> FilePath + -> CacheDelegate (ReaderT (Core.LspFuncs Config) IO) +outDelegate rid uri + = CacheDelegate + { onUpdateFile = onOutUpdateFile rid uri + , onWarning = onOutWarning + , onError = onOutError rid uri + } + +onInUpdateFile :: FilePath + -> FileUpdate + -> FileCache + -> R () +onInUpdateFile uri (UpdateBasicInj _) x = do + liftIO $ U.logs $ "********* updating basic" + let uri' = encodeUri uri + version = fileVersion x + let diags = BasicInj.diagnose $ forceGetPhaseCache $ srcBasicInj x + ediags = partitionBySource $ map encodeDiagnostic diags + publishDiagnostics uri' (Just version) ediags +onInUpdateFile _ _ _ = pure () + +onOutUpdateFile :: J.LspIdRsp + -> FilePath + -> FileUpdate + -> FileCache + -> R () +onOutUpdateFile rid uri (UpdateText new patchOpt) x = do + liftIO $ U.logs "********* updating text" + let old = phaseCached $ srcText x + patchOpt' = patchOpt <|> fmap (`replacePatch` new) old + case patchOpt' of + Nothing -> onOutError rid uri CachePatchBeforeText + Just patch -> do + let uri' = encodeUri uri + doc = J.VersionedTextDocumentIdentifier uri' $ fileVersion x + de = J.TextDocumentEdit doc $ encodePatch patch + we = J.WorkspaceEdit Nothing $ Just $ J.List [de] + rspMsg = makeResponseMessage' rid we + reactorSend rspMsg +onOutUpdateFile _ _ _ _ = pure () + +onInWarning :: CacheWarning + -> R () + -> R () +onInWarning _ continue = continue + +onOutWarning :: CacheWarning + -> R () + -> R () +onOutWarning (CacheRefactorWarning _ _) continue = continue + {- do + let params = J.ShowMessageRequestParams J.MtWarning ... + (Just [J.MessageActionItem "Continue", J.MessageActionItem "Cancel"]) + rid <- nextLspReqId + + reactorSend $ fmServerShowMessageRequest rid params -} + +onInError :: FilePath + -> CacheError + -> R () +onInError uri (CacheParseError x err) = do + liftIO $ U.logs "********* got error: CacheParseError" + let uri' = encodeUri uri + version = fileVersion x + eerr = encodeParseError err + diags = partitionBySource eerr + publishDiagnostics uri' (Just version) diags +onInError _ err = do + liftIO $ U.logs $ "******** got unexpected in error: " ++ show err + +onOutError :: J.LspIdRsp + -> FilePath + -> CacheError + -> R () +onOutError rid _ CacheFileNotFound = do + liftIO $ U.logs "********* got error: CacheFileNotFound" + let err = J.ResponseError J.InternalError fileNotFoundErrMsg Nothing + rspMsg = Core.makeResponseError rid err + reactorSend rspMsg +onOutError rid _ CachePatchBeforeText = do + liftIO $ U.logs "********* got error: CachePathBeforeText" + let err = J.ResponseError J.InternalError patchBeforeTextErrMsg Nothing + rspMsg = Core.makeResponseError rid err + reactorSend rspMsg +onOutError rid _ CacheRefactorBeforeParse = do + liftIO $ U.logs "********* got error: CacheRefactorBeforeParse" + let err = J.ResponseError J.InternalError refactorBeforeParseErrMsg Nothing + rspMsg = Core.makeResponseError rid err + reactorSend rspMsg +onOutError rid uri (CacheRefactorError x err) = do + let file = mkSFile uri $ forceGetPhaseCache $ srcText x + msg = "Refactor error: " <> T.pack (summaryF file err) + rerr = J.ResponseError J.InvalidRequest msg Nothing + rspMsg = Core.makeResponseError rid rerr + reactorSend rspMsg +onOutError _ _ err = do + liftIO $ U.logs $ "********* got unexpected out error: " ++ show err + +fileNotFoundErrMsg :: T.Text +fileNotFoundErrMsg = "No file cached at this path. Reopen the file to fix." + +patchBeforeTextErrMsg :: T.Text +patchBeforeTextErrMsg = "No text cached at this path. Reopen the file to fix." + +refactorBeforeParseErrMsg :: T.Text +refactorBeforeParseErrMsg = "Can't refactor because the source isn't parsed." + +-- --------------------------------------------------------------------- + +-- toWorkspaceEdit :: t -> Maybe J.ApplyWorkspaceEditParams +-- toWorkspaceEdit _ = Nothing + +-- --------------------------------------------------------------------- + +{- -- | Analyze the file and send any diagnostics to the client in a +-- "textDocument/publishDiagnostics" notification +sendDiagnostics :: J.Uri -> Maybe Int -> R () +sendDiagnostics fileUri mversion = do + let + diags = [J.Diagnostic + (J.Range (J.Position 0 1) (J.Position 0 5)) + (Just J.DsWarning) -- severity + Nothing -- code + (Just "descript-server") -- source + "Example diagnostic message" + (Just (J.List [])) + ] + -- reactorSend $ J.NotificationMessage "2.0" "textDocument/publishDiagnostics" (Just r) + publishDiagnostics 100 fileUri mversion (partitionBySource diags) -} + +-- --------------------------------------------------------------------- + +syncOptions :: J.TextDocumentSyncOptions +syncOptions = J.TextDocumentSyncOptions + { J._openClose = Just True + , J._change = Just J.TdSyncIncremental + , J._willSave = Just False + , J._willSaveWaitUntil = Just False + , J._save = Just $ J.SaveOptions $ Just False + } + +lspOptions :: Core.Options +lspOptions = def { Core.textDocumentSync = Just syncOptions + , Core.completionProvider = Just (J.CompletionOptions (Just True) (Just ["<", ">"])) + , Core.executeCommandProvider = Just (J.ExecuteCommandOptions (J.List ["rename"])) + } + +lspHandlers :: TChan ReactorInput -> Core.Handlers +lspHandlers rin + = def { Core.initializedHandler = Just $ passHandler rin Core.NotInitialized + , Core.renameHandler = Just $ passHandler rin Core.ReqRename + , Core.hoverHandler = Just $ passHandler rin Core.ReqHover + , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidOpenTextDocument + , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidSaveTextDocument + , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidChangeTextDocument + , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin Core.NotDidCloseTextDocument + , Core.cancelNotificationHandler = Just $ passHandler rin Core.NotCancelRequest + , Core.responseHandler = Just $ responseHandlerCb rin + , Core.codeActionHandler = Just $ passHandler rin Core.ReqCodeAction + , Core.executeCommandHandler = Just $ passHandler rin Core.ReqExecuteCommand + , Core.completionHandler = Just $ passHandler rin Core.ReqCompletion + , Core.completionResolveHandler = Just $ passHandler rin Core.ReqCompletionItemResolve + , Core.documentHighlightHandler = Just $ passHandler rin Core.ReqDocumentHighlights + , Core.documentFormattingHandler = Just $ passHandler rin Core.ReqDocumentFormatting + , Core.documentRangeFormattingHandler = Just $ passHandler rin Core.ReqDocumentRangeFormatting + , Core.documentSymbolHandler = Just $ passHandler rin Core.ReqDocumentSymbols + } + +-- --------------------------------------------------------------------- + +passHandler :: TChan ReactorInput -> (a -> Core.OutMessage) -> Core.Handler a +passHandler rin c notification = do + atomically $ writeTChan rin (HandlerRequest (c notification)) + +-- --------------------------------------------------------------------- + +responseHandlerCb :: TChan ReactorInput -> Core.Handler J.BareResponseMessage +responseHandlerCb _rin resp = do + + U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp + +-- --------------------------------------------------------------------- diff --git a/dep-licenses/haskell-ide-engine b/dep-licenses/haskell-ide-engine new file mode 100644 --- /dev/null +++ b/dep-licenses/haskell-ide-engine @@ -0,0 +1,31 @@ +Copyright (c) 2015-2016, TBD + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alan Zimmerman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/dep-licenses/haskell-lsp b/dep-licenses/haskell-lsp new file mode 100644 --- /dev/null +++ b/dep-licenses/haskell-lsp @@ -0,0 +1,20 @@ +Copyright (c) 2016 Alan Zimmerman + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/descript-lang.cabal b/descript-lang.cabal new file mode 100644 --- /dev/null +++ b/descript-lang.cabal @@ -0,0 +1,348 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 30323c1db2fda7dccd15d52874bec02728507fd63735220b33cf2364d779f1c2 + +name: descript-lang +version: 0.2.0.0 +synopsis: Library, interpreter, and CLI for Descript programming language. +description: Please see the README at +category: Language +homepage: https://bitbucket.org/jakobeha/descript-lang/src/master/README.md +bug-reports: https://jakobeha@bitbucket.org/jakobeha/descript-lang.git/issues +author: Jakob Hain +maintainer: jakobeha2@gmail.com +copyright: 2018 Jakob Hain +license: GPL-3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.18 +extra-source-files: + ChangeLog.md + dep-licenses/haskell-ide-engine + dep-licenses/haskell-lsp + README.md + test-resources/examples/A.dscr + test-resources/examples/A.out.yaml + test-resources/examples/Basic.dscr + test-resources/examples/Basic.out.yaml + test-resources/examples/Compiled.dscr + test-resources/examples/Compiled.out.yaml + test-resources/examples/Import.Cycle.dscr + test-resources/examples/Import.Cycle.out.yaml + test-resources/examples/Import.dscr + test-resources/examples/Import.ModFunc.dscr + test-resources/examples/Import.ModFunc.out.yaml + test-resources/examples/Import.ModFunc.Workaround.dscr + test-resources/examples/Import.ModFunc.Workaround.out.yaml + test-resources/examples/Import.out.yaml + test-resources/examples/ImportBuiltin.dscr + test-resources/examples/ImportBuiltin.out.yaml + test-resources/examples/Injected.dscr + test-resources/examples/Injected.out.yaml + test-resources/examples/Invalid.dscr + test-resources/examples/Invalid.out.yaml + test-resources/examples/Macros.dscr + test-resources/examples/Macros.out.yaml + test-resources/examples/PrimBuiltin.Bad.dscr + test-resources/examples/PrimBuiltin.Bad.out.yaml + test-resources/examples/PrimBuiltin.dscr + test-resources/examples/PrimBuiltin.out.yaml + test-resources/examples/Rep.dscr + test-resources/examples/Rep.out.yaml + test-resources/examples/Types.Exp.dscr + test-resources/examples/Types.Exp.out.yaml + test-resources/examples/Types.Fun.dscr + test-resources/examples/Types.Fun.out.yaml + test-resources/examples/Types.Imp.dscr + test-resources/examples/Types.Imp.out.yaml + test-resources/examples/Types.New+.dscr + test-resources/examples/Types.New+.out.yaml + test-resources/examples/Types.New.Adv.dscr + test-resources/examples/Types.New.Adv.out.yaml + test-resources/examples/Types.New.dscr + test-resources/examples/Types.New.out.yaml + test-resources/Import/Basic/List.dscr + test-resources/Import/Basic/Num.dscr + test-resources/Import/Cycle/Blue.dscr + test-resources/Import/Cycle/Color.dscr + test-resources/Import/Cycle/Green.dscr + test-resources/Import/Cycle/Red.dscr + test-resources/Import/Math/Square.dscr + test-resources/Import/Math/Vector.dscr + test-resources/refactors/Basic.rename-add.dscr + test-resources/refactors/Basic.rename-succ.dscr + test-resources/refactors/Import.rename-record.dscr + test-resources/refactors/Macros.free-bind-complex-new.dscr + test-resources/refactors/Macros.free-bind.dscr + test-resources/refactors/Macros.singleton-record-new.dscr + test-resources/refactors/Macros.singleton-record.dscr + test-resources/refactors/Types.New.rename-property.dscr +extra-doc-files: + docs/Spec.md +data-files: + resources/modules/Base.dscr + +source-repository head + type: git + location: https://jakobeha@bitbucket.org/jakobeha/descript-lang.git + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + array + , autoexporter + , base >=4.10.1 && <5 + , bifunctors + , bytestring + , containers + , filepath + , hashtables + , megaparsec + , stm + , text + , transformers + exposed-modules: + Descript + Descript.Build + Descript.Build.Cache + Descript.Fast + Descript.BasicInj + Descript.BasicInj.Write + Descript.BasicInj.Process + Descript.BasicInj.Read + Descript.BasicInj.Traverse + Descript.BasicInj.Traverse.Term + Descript.BasicInj.Data + Descript.BasicInj.Data.Type + Descript.BasicInj.Data.Value.Reg + Descript.BasicInj.Data.Value.In + Descript.BasicInj.Data.Value.Out + Descript.Sugar + Descript.Sugar.Data + Descript.Sugar.Data.Type + Descript.Sugar.Data.Value.Reg + Descript.Sugar.Data.Value.In + Descript.Sugar.Data.Value.Out + Descript.Free + Descript.Free.Data + Descript.Lex + Descript.Lex.Data + Descript.Misc + Descript.Misc.Build + Descript.Misc.Build.Write + Descript.Misc.Build.Process + Descript.Misc.Build.Read + other-modules: + Core.Control.Applicative + Core.Control.Monad.ST + Core.Control.Monad.Trans + Core.Data.Functor + Core.Data.Group + Core.Data.List + Core.Data.List.Assoc + Core.Data.List.NonEmpty + Core.Data.Map.Strict + Core.Data.Monoid + Core.Data.Proxy + Core.Data.Semigroup + Core.Data.Set + Core.Data.String + Core.Data.Text + Core.Data.Tuple + Core.DontForce + Core.Numeric + Core.System.FilePath + Core.Text.Megaparsec + Core.Text.Megaparsec.Error + Core.Text.ParserCombinators.Read + Descript.BasicInj.Data.Atom + Descript.BasicInj.Data.Atom.Inject + Descript.BasicInj.Data.Atom.PropPath + Descript.BasicInj.Data.Atom.Scope + Descript.BasicInj.Data.Import + Descript.BasicInj.Data.Import.Import + Descript.BasicInj.Data.Import.Module + Descript.BasicInj.Data.InjFunc + Descript.BasicInj.Data.Reducer + Descript.BasicInj.Data.Source + Descript.BasicInj.Data.Value + Descript.BasicInj.Data.Value.Gen + Descript.BasicInj.Process.Inspect + Descript.BasicInj.Process.Inspect.SymbolAt + Descript.BasicInj.Process.Reduce + Descript.BasicInj.Process.Reduce.Match + Descript.BasicInj.Process.Reduce.NoAnn + Descript.BasicInj.Process.Reduce.PropTrans + Descript.BasicInj.Process.Reduce.SrcAnn + Descript.BasicInj.Process.Refactor + Descript.BasicInj.Process.Refactor.GenRenameSymbol + Descript.BasicInj.Process.Refactor.RefactorReduce + Descript.BasicInj.Process.Refactor.RenameModuleElem + Descript.BasicInj.Process.Refactor.RenameProp + Descript.BasicInj.Process.Refactor.RenameRecord + Descript.BasicInj.Process.Refactor.RenameSymbol + Descript.BasicInj.Process.Validate + Descript.BasicInj.Read.Resolve + Descript.BasicInj.Read.Resolve.Subst + Descript.BasicInj.Read.Resolve.Subst.Global + Descript.BasicInj.Read.Resolve.Subst.Local + Descript.BasicInj.Read.Resolve.Subst.Subst + Descript.BasicInj.Traverse.Termed + Descript.BasicInj.Write.Compile + Descript.BasicInj.Write.Diagnose + Descript.Build.Build + Descript.Build.Cache.Error + Descript.Build.Cache.FileCache + Descript.Build.Cache.GlobalCache + Descript.Build.Cache.PhaseCache + Descript.Build.Error + Descript.Build.Read + Descript.Build.Read.File + Descript.Build.Read.Parse + Descript.Build.Read.Read + Descript.Build.Refactor + Descript.Fast.Reduce + Descript.Free.Data.Atom + Descript.Free.Data.Atom.PropPath + Descript.Free.Data.Import + Descript.Free.Data.Import.Import + Descript.Free.Data.Import.Module + Descript.Free.Error + Descript.Free.Parse + Descript.Lex.Data.Atom + Descript.Lex.Parse + Descript.Misc.Ann + Descript.Misc.Build.Process.Diagnose + Descript.Misc.Build.Process.Refactor + Descript.Misc.Build.Process.Validate + Descript.Misc.Build.Process.Validate.Problem + Descript.Misc.Build.Process.Validate.Term + Descript.Misc.Build.Read.File + Descript.Misc.Build.Read.File.Depd + Descript.Misc.Build.Read.File.DepError + Descript.Misc.Build.Read.File.DepResolve + Descript.Misc.Build.Read.File.DFile + Descript.Misc.Build.Read.File.Scope + Descript.Misc.Build.Read.File.SFile + Descript.Misc.Build.Read.Parse + Descript.Misc.Build.Read.Parse.Action + Descript.Misc.Build.Read.Parse.Error + Descript.Misc.Build.Read.Parse.Loc + Descript.Misc.Build.Read.Parse.SrcAnn + Descript.Misc.Build.Write.Compile + Descript.Misc.Build.Write.Compile.Code + Descript.Misc.Build.Write.Compile.Package + Descript.Misc.Build.Write.Compile.Result + Descript.Misc.Build.Write.Print + Descript.Misc.Build.Write.Print.APrint + Descript.Misc.Build.Write.Print.Patch + Descript.Misc.Build.Write.Print.PrimPrintable + Descript.Misc.Build.Write.Print.Printable + Descript.Misc.Build.Write.Print.PrintPatch + Descript.Misc.Build.Write.Print.PrintReduce + Descript.Misc.Build.Write.Print.PrintString + Descript.Misc.Build.Write.Print.PrintText + Descript.Misc.Error + Descript.Misc.Error.Dirty + Descript.Misc.Error.Result + Descript.Misc.Error.Result.Base + Descript.Misc.Error.Result.Trans + Descript.Misc.Loc + Descript.Misc.Summary + Descript.Sugar.Data.Atom + Descript.Sugar.Data.Atom.Inject + Descript.Sugar.Data.Atom.Scope + Descript.Sugar.Data.Import + Descript.Sugar.Data.InjFunc + Descript.Sugar.Data.Reducer + Descript.Sugar.Data.Source + Descript.Sugar.Data.Value + Descript.Sugar.Data.Value.Gen + Descript.Sugar.Parse + Descript.Sugar.Parse.Refine + Descript.Sugar.Refine + Descript.Sugar.Resolve + Paths_descript_lang + default-language: Haskell2010 + +executable descript-cli + main-is: Main.hs + hs-source-dirs: + app + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , array + , autoexporter + , base >=4.10.1 && <5 + , bifunctors + , bytestring + , containers + , data-default + , descript-lang + , exceptions + , filepath + , fsnotify + , hashtables + , haskell-lsp + , hslogger + , lens + , megaparsec + , mtl + , network-uri + , optparse-applicative + , rainbow + , stm + , text + , transformers + , unordered-containers + , vector + , yi-rope + other-modules: + Action + Parse + Run + Server.Decode + Server.Encode + Server.Run + Paths_descript_lang + default-language: Haskell2010 + +test-suite descript-lang-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit + , QuickCheck + , array + , autoexporter + , base >=4.10.1 && <5 + , bifunctors + , bytestring + , containers + , descript-lang + , directory + , filepath + , hashtables + , hspec + , megaparsec + , stm + , text + , transformers + , yaml + other-modules: + BuildSpec + Core.Test + Core.Test.Descript + Core.Test.Descript.Spec + Core.Test.Descript.TestFile + Core.Test.HUnit + Paths_descript_lang + default-language: Haskell2010 diff --git a/docs/Spec.md b/docs/Spec.md new file mode 100644 --- /dev/null +++ b/docs/Spec.md @@ -0,0 +1,145 @@ +# Descript v0.2 + +## Specification + +> *This specification is slightly outdated. It was mostly written* +> *before the implementation, and it hasn't been fully updated since.* +> *In particular, injections (primitive types and injected applications) +> *aren't included in the specification (although technically they could +> *be considered input/output records.)* + +```descript +A[a: E] | B[b: F] : C + +A | B | D => C | D + +``` + +Programs consist of values and reducers. + +A value is a union (set) of parts. + +A value can't have 2 primitives which are equal, or 2 records which +share the same head. + +> Because of the above, a typical implementation represents a value as a +> map of "heads" to "properties", where a primitives is its own head and +> has no properties. This representation is efficient and easy to use, +> because primitives and record heads are treated similarly. + +A part is a primitive or a record. + +A primitive is a string, number, image, etc.. + +A record has a (head) symbol and a map of symbols to values (properties - +each entry is a property). + +A symbol is an identifier used for reference - symbols can be checked +for equality. + +If 2 records have the same head symbol, they belong to the same type, +and they must have the same property keys. + +> An implementation can allow any datum to be a symbol. A typical +> implementation restricts a symbol in a record to a literal (is a +> special type of string). Typically some special record, such as +> vectors, can have maps with number keys. + +> Usually the symbols in the head of a value are `TitleCamelCase` +> literals, while the symbols in the maps are `lowerCamelCase` literals. + +A reducer has an input value and an output value. + +An input value is a union of input parts. + +An input part is a primitive or input record. + +An input record is a symbol (head) and a map of symbols to *optional* +input values (properties). + +An input record's head must equal an already-defined record's head. + +> Alternatively, an implementation of input records can simply be a +> symbol and a map of symbols to (not optional) input values. Then, +> instead of requiring input records with equal heads to have the same +> property keys, an input record needs to have a subset of the property +> keys of a regular record with the same head. + +> An implementation can prevent input values in top-level input records +> from themselves containing input records, and force top-level input +> records to contain non-optional properties. + +An output value is a union (set) of output parts. + +An output part is a property path, primitive, or output record. + +A property path is list of path elements. + +A path element is a symbol corresponding to a record's head (head +reference) and another symbol corresponding to a property key in that +record (key reference). + +An output record is a symbol (head) and a map of symbols to output +values (properties). + +A reducer affects a value if its input value matches the value. + +An input value matches a regular value if its parts match the regular +value's parts. + +An input primitive matches an equal regular primitive. + +An input record matches a regular record if it has the same head (and +thus, the property keys should be equal) and its property values match +the regular value's property values. + +A value reduces if there's reducer defined which will affect it. The +value reduces into the reducer's output value applied to the value. + +An output value applied to another value is its parts applied to the +other value. + +A primitive applied to any value is the primitive itself. + +A record applied to a value has the same head and property keys, and the +property values are also applied to that value. + +A property path `ab It could be a record or atom, depending on implementation. diff --git a/resources/modules/Base.dscr b/resources/modules/Base.dscr new file mode 100644 --- /dev/null +++ b/resources/modules/Base.dscr @@ -0,0 +1,17 @@ +//The "standard library" of Descript. +//Contains some data-structures embedded into the language, but those +//could be moved later if necessary. + +Code[lang, content]. +Add[left, right]. +Subtract[left, right]. +Multiply[left, right]. +Exp2[a]. +App3[left, center, right]. + +Add[left: #Number[], right: #Number[]]: #Add[left, right] +Subtract[left: #Number[], right: #Number[]]: #Subtract[left, right] +Multiply[left: #Number[], right: #Number[]]: #Multiply[left, right] +Exp2[a: #Number[]]: Multiply[a, a] +App3[left: #String[], center: #String[], right: #String[]]: + #App3[left, center, right] diff --git a/src/Core/Control/Applicative.hs b/src/Core/Control/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Core/Control/Applicative.hs @@ -0,0 +1,23 @@ +module Core.Control.Applicative + ( pure2 + , pure3 + , (<<*>>) + , (<<<*>>>) ) where + +-- | Lifts 'pure' to 2 applicatives. +pure2 :: (Applicative wa, Applicative wb) => a -> wa (wb a) +pure2 = pure . pure + +-- | Lifts 'pure' to 3 applicatives. +pure3 :: (Applicative wa, Applicative wb, Applicative wc) => a -> wa (wb (wc a)) +pure3 = pure2 . pure + +-- | Lifts '<*>' to 2 applicatives. +infixr 3 <<*>> +(<<*>>) :: (Applicative wa, Applicative wb) => wa (wb (a -> b)) -> wa (wb a) -> wa (wb b) +f <<*>> x = (<*>) <$> f <*> x + +-- | Lifts '<*>' to 3 applicatives. +infixr 3 <<<*>>> +(<<<*>>>) :: (Applicative wa, Applicative wb, Applicative wc) => wa (wb (wc (a -> b))) -> wa (wb (wc a)) -> wa (wb (wc b)) +f <<<*>>> x = (<<*>>) <$> f <*> x diff --git a/src/Core/Control/Monad/ST.hs b/src/Core/Control/Monad/ST.hs new file mode 100644 --- /dev/null +++ b/src/Core/Control/Monad/ST.hs @@ -0,0 +1,10 @@ +module Core.Control.Monad.ST + ( stToMio + ) where + +import Control.Monad.ST +import Control.Monad.IO.Class + +-- | Converts an ST monad to a MonadIO instance. +stToMio :: (MonadIO m) => ST RealWorld a -> m a +stToMio = liftIO . stToIO diff --git a/src/Core/Control/Monad/Trans.hs b/src/Core/Control/Monad/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Core/Control/Monad/Trans.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleInstances #-} + +module Core.Control.Monad.Trans + ( MonadHoist (..) + , MonadTransBridge (..) + , lift2 + , rehoist + , mixinEffect + ) where + +import Data.Functor.Identity +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer.Strict + +-- | Can transform the stacked version by transforming the unstacked +-- version, without knowing the unstacked version's type. +class (MonadTrans t) => MonadHoist t where + mapInner :: (forall b. w1 b -> w2 b) -> t w1 a -> t w2 a + +-- | Bridges a monad and its transformer variant. +class (Monad u, MonadHoist t) => MonadTransBridge u t where + hoist :: (Monad w) => u a -> t w a + bindStackOuter :: (Monad w) => (u a -> t w b) -> t w a -> t w b + +instance (Monoid r) => MonadHoist (WriterT r) where + mapInner = mapWriterT + +instance (Monoid r) => MonadTransBridge (WriterT r Identity) (WriterT r) where + hoist = mapWriterT $ pure . runIdentity + bindStackOuter f = mapWriterT $ (runWriterT . f . writer =<<) + +-- | Wraps an effect in 2 transformers. +lift2 :: (MonadTrans t1, MonadTrans t2, Monad u, Monad (t2 u)) + => u a + -> t1 (t2 u) a +lift2 = lift . lift + +-- | Hoists the hoisted monad. +rehoist :: (MonadHoist t, MonadTransBridge wu wt, Monad ww) + => t wu a + -> t (wt ww) a +rehoist = mapInner hoist + +-- | Apply the effect, then return the original value. +mixinEffect :: (MonadTransBridge w wt, Monad we, Monad (wt we)) + => (w a -> we ()) + -> w a + -> wt we a +mixinEffect eff x = lift (eff x) >> hoist x diff --git a/src/Core/Data/Functor.hs b/src/Core/Data/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Functor.hs @@ -0,0 +1,27 @@ +module Core.Data.Functor + ( fmap2 + , fmap3 + , (<<$>>) + , (<<<$>>>) ) where + +-- | @fmap . fmap@. +fmap2 :: (Functor wo, Functor wi) + => (a -> b) -> wo (wi a) -> wo (wi b) +fmap2 = fmap . fmap + +-- | @fmap . fmap . fmap@. +fmap3 :: (Functor w1, Functor w2, Functor w3) + => (a -> b) -> w1 (w2 (w3 a)) -> w1 (w2 (w3 b)) +fmap3 = fmap . fmap . fmap + +-- | @fmap . fmap@. +infixl 4 <<$>> +(<<$>>) :: (Functor wo, Functor wi) + => (a -> b) -> wo (wi a) -> wo (wi b) +(<<$>>) = fmap2 + +-- | @fmap . fmap . fmap@. +infixl 4 <<<$>>> +(<<<$>>>) :: (Functor w1, Functor w2, Functor w3) + => (a -> b) -> w1 (w2 (w3 a)) -> w1 (w2 (w3 b)) +(<<<$>>>) = fmap3 diff --git a/src/Core/Data/Group.hs b/src/Core/Data/Group.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Group.hs @@ -0,0 +1,17 @@ +module Core.Data.Group + ( Subtract (..) + , Group (..) + ) where + +-- | Can be combined and subtracted. +-- Not an algebraic group, since there's no @invert@ - you can only +-- subtract values. +class (Monoid a) => Subtract a where + -- | Subtract the second value from the first. + (\\) :: a -> a -> a + +-- | A 'Monoid' with a "negative" value. Adding a value is like +-- subtracting its negative, and vice versa. The negative of empty is empty. +class (Subtract a) => Group a where + -- | The "negative" of this value. + invert :: a -> a diff --git a/src/Core/Data/List.hs b/src/Core/Data/List.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/List.hs @@ -0,0 +1,161 @@ +module Core.Data.List + ( deleteBy' + , deleteFirstsBy' + , (!?) + , (?:) + , (|>) + , maybeHead + , maybeLast + , overHead + , overLast + , dropEnd + , strip + , removeOddIdxs + , mapEvenOddIdxs + , zipPadS + , zipPadM + , zipPadLeftS + , zipPadLeftM + , zipPadWith + , splitPrefixBy + , isPermBy + , overlapsBy + ) where + +import Data.Bifunctor +import Data.Semigroup as S +import Data.Monoid as M +import Data.List + +-- | 'deleteBy' from 'Data.List', but with a more generic type. +deleteBy' :: (a -> b -> Bool) -> a -> [b] -> [b] +deleteBy' _ _ [] = [] +deleteBy' (=?=) x (y : ys) + | x =?= y = ys + | otherwise = y : deleteBy' (=?=) x ys + +-- | 'deleteFirstsBy' from 'Data.List', but with a more generic type, +-- strict left-fold, and different argument ordering. +deleteFirstsBy' :: (a -> b -> Bool) -> [a] -> [b] -> [b] +deleteFirstsBy' (=?=) = flip $ foldl' $ flip $ deleteBy' (=?=) + +-- | Gets the element at the index, or 'Nothing' if the list isn't large +-- enough. Fails if the index is negative. +(!?) :: [a] -> Int -> Maybe a +xs !? idx + | idx < length xs = Just $ xs !! idx + | otherwise = Nothing + +-- | Conses if 'Just'. +(?:) :: Maybe a -> [a] -> [a] +Nothing ?: xs = xs +Just x ?: xs = x : xs + +-- | Append an element. +(|>) :: [a] -> a -> [a] +[] |> y = [y] +(x : xs) |> y = x : (xs |> y) + +-- | The head, if nonempty, otherwise nothing. +maybeHead :: [a] -> Maybe a +maybeHead [] = Nothing +maybeHead (x : _) = Just x + +-- | The last item, if nonempty, otherwise nothing. +maybeLast :: [a] -> Maybe a +maybeLast [] = Nothing +maybeLast [x] = Just x +maybeLast (_ : x2 : xs) = maybeLast $ x2 : xs + +-- | Transforms the first item in the list. +-- If the list is empty, does nothing. +overHead :: (a -> a) -> [a] -> [a] +overHead _ [] = [] +overHead f (x : xs) = f x : xs + +-- | Transforms the last item in the list. +-- If the list is empty, does nothing. +overLast :: (a -> a) -> [a] -> [a] +overLast _ [] = [] +overLast f [x] = [f x] +overLast f (x : x2 : xs) = x : overLast f (x2 : xs) + +-- | Removes @n@ elements from the end of the list. +dropEnd :: Int -> [a] -> [a] +dropEnd n = reverse . drop n . reverse + +-- | Removes items at the start and end of the list which satisfy the +-- predicate. +strip :: (a -> Bool) -> [a] -> [a] +strip f = dropWhileEnd f . dropWhile f + +-- | Transforms the items at index 0, 2, 4, etc. +-- with the first transformer, and those at 1, 3, 5, etc. +-- with the second. +mapEvenOddIdxs :: (a -> b) -> (a -> b) + -> [a] -> [b] +mapEvenOddIdxs _ _ [] = [] +mapEvenOddIdxs fe _ [x] = [fe x] +mapEvenOddIdxs fe fo (xe : xo : xs) + = fe xe : fo xo : mapEvenOddIdxs fe fo xs + +-- | Removes the items at index 1, 3, 5, etc. +-- Technically removes the second, fourth, etc. +-- but "odd" because indices are 0-based. +removeOddIdxs :: [a] -> [a] +removeOddIdxs [] = [] +removeOddIdxs [x] = [x] +removeOddIdxs (xe : _ : xs) = xe : removeOddIdxs xs + +-- | Zips the lists by appending elements. Won't discard elements at the +-- end of the longer list (so the result is as long as the longer list). +zipPadS :: (Semigroup a) => [a] -> [a] -> [a] +[] `zipPadS` [] = [] +xs `zipPadS` [] = xs +[] `zipPadS` ys = ys +(x : xs) `zipPadS` (y : ys) = (x S.<> y) : (xs `zipPadS` ys) + +-- | Zips the lists by appending elements. Won't discard elements at the +-- end of the longer list (so the result is as long as the longer list). +zipPadM :: (Monoid a) => [a] -> [a] -> [a] +[] `zipPadM` [] = [] +xs `zipPadM` [] = xs +[] `zipPadM` ys = ys +(x : xs) `zipPadM` (y : ys) = (x M.<> y) : (xs `zipPadM` ys) + +-- | Zips the lists by \prepending\ elements. The result is as long as +-- the longer list. +zipPadLeftS :: (Semigroup a) => [a] -> [a] -> [a] +xs `zipPadLeftS` ys = reverse $ reverse xs `zipPadS` reverse ys + +-- | Zips the lists by \prepending\ elements. The result is as long as +-- the longer list. +zipPadLeftM :: (Monoid a) => [a] -> [a] -> [a] +xs `zipPadLeftM` ys = reverse $ reverse xs `zipPadM` reverse ys + +-- | Zips the lists, appending 'mempty's to the shorter list instead of +-- discarding elements from the longer list (so the result is as long as +-- the longer list). +zipPadWith :: (Monoid a, Monoid b) => (a -> b -> c) -> [a] -> [b] -> [c] +zipPadWith _ [] [] = [] +zipPadWith f (x : xs) [] = f x mempty : zipPadWith f xs [] +zipPadWith f [] (y : ys) = f mempty y : zipPadWith f [] ys +zipPadWith f (x : xs) (y : ys) = f x y : zipPadWith f xs ys + +-- | If every element in the first list matches the second according to +-- the given predicate, returns the matched items in the second and the +-- rest of the second. Otherwise returns 'Nothing'. +splitPrefixBy :: (a -> b -> Bool) -> [a] -> [b] -> Maybe ([b], [b]) +splitPrefixBy _ [] x = Just ([], x) +splitPrefixBy _ (_ : _) [] = Nothing +splitPrefixBy f (pre : pres) (x : xs) + | not $ f pre x = Nothing + | otherwise = (first (x :)) <$> splitPrefixBy f pres xs + +-- | Whether the lists share all elements, using the equality test. +isPermBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool +isPermBy (=?=) xs ys = all ((`all` ys) . (=?=)) xs + +-- | Whether the lists share any elements, using the equality test. +overlapsBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool +overlapsBy (=?=) xs ys = any ((`any` ys) . (=?=)) xs diff --git a/src/Core/Data/List/Assoc.hs b/src/Core/Data/List/Assoc.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/List/Assoc.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Functions on general association (key/value) lists. +module Core.Data.List.Assoc + ( AssocPair (..) + , SemAssocPair (..) + , assocKeys + , glookup + , glookupForce + , assocMember + , assocUnion + , assocUnionBy + , assocInsert + , assocInsertBy + , aappend + ) where + +import Data.Semigroup +import Data.List + +-- | A generalized key/value pair - can contain more than just the key +-- and value. +class (Eq (Key a)) => AssocPair a where + type Key a :: * + type Value a :: * + + -- | The key in the pair. + getKey :: a -> Key a + + -- | The value in the pair. + getValue :: a -> Value a + +-- | A generalized key/value pair, where 2 pairs with the same key can +-- be appended. +class (AssocPair a) => SemAssocPair a where + -- | Assumes both values have the same key. Combines them, combining + -- values with the given function. + aappend1 :: (Value a -> Value a -> Value a) -> a -> a -> a + +-- | All the keys in the association list. +assocKeys :: (AssocPair a) => [a] -> [Key a] +assocKeys = map getKey + +-- | Looks up a value in an association list. +glookup :: (AssocPair a) => Key a -> [a] -> Maybe (Value a) +glookup key = fmap getValue . find (hasKey key) + +-- | Looks up a value in an association list. +-- Raises an error if the value can't be found. +glookupForce :: (AssocPair a) => Key a -> [a] -> Value a +glookupForce key xs + = case glookup key xs of + Nothing -> error "Key not in association list" + Just val -> val + +-- | Is the key in the association list? +assocMember :: (AssocPair a) => Key a -> [a] -> Bool +assocMember = any . hasKey + +hasKey :: (AssocPair a) => Key a -> a -> Bool +hasKey key pair = key == getKey pair + +-- | Contains all keys from both lists. If 2 values share a key, they're appended. +-- Assumes no pairs share a key in either of the lists before they're combined. +assocUnion :: (SemAssocPair a, Semigroup (Value a)) => [a] -> [a] -> [a] +assocUnion = assocUnionBy (<>) + +-- | Contains all keys from both lists. If 2 values share a key, they're appended. +-- Assumes no pairs share a key in either of the lists before they're combined. +assocUnionBy :: (SemAssocPair a) + => (Value a -> Value a -> Value a) + -> [a] + -> [a] + -> [a] +assocUnionBy = foldr . assocInsertBy + +-- | Adds the pair to the list. If the original list already contains +-- its key, the value is appended to the original corresponding value. +assocInsert :: (SemAssocPair a, Monoid (Value a)) => a -> [a] -> [a] +assocInsert = assocInsertBy mappend + +-- | Adds the pair to the list. If the original list already contains +-- its key, the value is appended to the original corresponding value. +assocInsertBy :: (SemAssocPair a) + => (Value a -> Value a -> Value a) + -> a + -> [a] + -> [a] +assocInsertBy _ new [] = [new] +assocInsertBy vapp new (x : xs) + | getKey new == getKey x = (aappend1 vapp new x) : xs + | otherwise = x : (assocInsertBy vapp new xs) + +-- | Assumes both values have the same key. Combines them. +aappend :: (SemAssocPair a, Monoid (Value a)) => a -> a -> a +aappend = aappend1 mappend diff --git a/src/Core/Data/List/NonEmpty.hs b/src/Core/Data/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/List/NonEmpty.hs @@ -0,0 +1,89 @@ +module Core.Data.List.NonEmpty + ( replicate + , (|>) + , (|+) + , (+|) + , dropEnd + , stripPrefix + , zipPadS + , zipPadM + , zipPadLeftS + , zipPadLeftM + , zipPadWith + ) where + +import Data.Semigroup as S +import Data.Monoid as M +import qualified Data.List as List (replicate, stripPrefix) +import qualified Core.Data.List as List ( + (|>) + , zipPadS + , zipPadM + , zipPadLeftS + , zipPadLeftM + , zipPadWith + ) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Prelude hiding (replicate) + +-- | Creates a list of length @n@, where every element is @x@. +replicate :: Int -> a -> NonEmpty a +replicate n x + | n < 0 = error "replicate: tried to make NonEmpty with negative elements" + | n == 0 = error "replicate: tried to make NonEmpty with 0 elements" + | otherwise = NonEmpty.fromList $ List.replicate n x + +-- | Appends an element to the list. +(|>) :: NonEmpty a -> a -> NonEmpty a +(x :| xs) |> y = x :| (xs List.|> y) + +-- | Appends a regular list and a non-empty list. +(|+) :: [a] -> NonEmpty a -> NonEmpty a +[] |+ ys = ys +(x : xs) |+ ys = x :| (xs ++ NonEmpty.toList ys) + +-- | Appends a non-empty list and a regular list. +(+|) :: NonEmpty a -> [a] -> NonEmpty a +(x :| xs) +| ys = x :| (xs ++ ys) + +-- | Removes @n@ elements from the end of the list. +dropEnd :: Int -> NonEmpty a -> [a] +dropEnd n = reverse . NonEmpty.drop n . NonEmpty.reverse + +-- | If the second list starts with the first, returns the part after. +-- Otherwise returns 'Nothing'. +stripPrefix :: (Eq a) => NonEmpty a -> NonEmpty a -> Maybe [a] +(x :| xs) `stripPrefix` (y :| ys) + | x /= y = Nothing + | otherwise = xs `List.stripPrefix` ys + +-- | Zips the lists by appending elements. Won't discard elements at the +-- end of the longer list (so the result is as long as the longer list). +zipPadS :: (Semigroup a) => NonEmpty a -> NonEmpty a -> NonEmpty a +(x :| xs) `zipPadS` (y :| ys) = (x S.<> y) :| (xs `List.zipPadS` ys) + +-- | Zips the lists by appending elements. Won't discard elements at the +-- end of the longer list (so the result is as long as the longer list). +zipPadM :: (Monoid a) => NonEmpty a -> NonEmpty a -> NonEmpty a +(x :| xs) `zipPadM` (y :| ys) = (x M.<> y) :| (xs `List.zipPadM` ys) + +-- | Zips the lists by \prepending\ elements. The result is as long as +-- the longer list. +zipPadLeftS :: (Semigroup a) => NonEmpty a -> NonEmpty a -> NonEmpty a +(x :| xs) `zipPadLeftS` (y :| ys) = (x S.<> y) :| (xs `List.zipPadLeftS` ys) + +-- | Zips the lists by \prepending\ elements. The result is as long as +-- the longer list. +zipPadLeftM :: (Monoid a) => NonEmpty a -> NonEmpty a -> NonEmpty a +(x :| xs) `zipPadLeftM` (y :| ys) = (x M.<> y) :| (xs `List.zipPadLeftM` ys) + +-- | Zips the lists, appending 'mempty's to the shorter list instead of +-- discarding elements from the longer list (so the result is as long as +-- the longer list). +zipPadWith :: (Monoid a, Monoid b) + => (a -> b -> c) + -> NonEmpty a + -> NonEmpty b + -> NonEmpty c +zipPadWith f (x :| xs) (y :| ys) = f x y :| List.zipPadWith f xs ys diff --git a/src/Core/Data/Map/Strict.hs b/src/Core/Data/Map/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Map/Strict.hs @@ -0,0 +1,44 @@ +module Core.Data.Map.Strict + ( lookupMon + , insertMon + , unionMon + , intersectionMon + , filterKeys + , adjustF + ) where + +import Data.Monoid +import Data.Foldable +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +-- | Looks up a value, returns @mempty@ if it isn't found. +lookupMon :: (Ord k, Monoid a) => k -> Map k a -> a +lookupMon key = fold . Map.lookup key + +-- | Inserts a value at the given key. +-- If an old value is already present at the key, +-- appends it to the old value. +insertMon :: (Ord k, Monoid a) => k -> a -> Map k a -> Map k a +insertMon = Map.insertWith (<>) + +-- | Combines the two maps, appending values which share keys. +unionMon :: (Ord k, Monoid a) => Map k a -> Map k a -> Map k a +unionMon = Map.unionWith (<>) + +-- | Intersects the two maps by combining values. +-- Returns a map with all keys both maps share, +-- and the values of each key is the value of the left map +-- appended to the value of the second. +intersectionMon :: (Ord k, Monoid a) => Map k a -> Map k a -> Map k a +intersectionMon = Map.intersectionWith (<>) + +-- | Filters a map by its keys -- +-- removes key-value pairs whose keys +-- don't satisfy the predicate. +filterKeys :: (k -> Bool) -> Map k a -> Map k a +filterKeys f = Map.filterWithKey $ const . f + +-- | Transforms the value with the key if it exists, otherwise does nothing. +adjustF :: (Ord k, Applicative w) => (v -> w v) -> k -> Map k v -> w (Map k v) +adjustF f = Map.alterF $ traverse f diff --git a/src/Core/Data/Monoid.hs b/src/Core/Data/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Monoid.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DefaultSignatures #-} + +module Core.Data.Monoid + ( Monoid1 (..) + ) where + +import Data.Semigroup + +-- | Is a 'Monoid' if its type variable is a 'Monoid', +class Monoid1 a where + mempty1 :: (Semigroup b, Monoid b) => a b + default mempty1 :: (Semigroup b, Monoid b, Monoid (a b)) => a b + mempty1 = mempty + mappend1 :: (Semigroup b, Monoid b) => a b -> a b -> a b + default mappend1 :: (Semigroup b, Monoid b, Monoid (a b)) => a b -> a b -> a b + mappend1 = mappend diff --git a/src/Core/Data/Proxy.hs b/src/Core/Data/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Proxy.hs @@ -0,0 +1,9 @@ +module Core.Data.Proxy + ( proxyOf + ) where + +import Data.Proxy + +-- | A proxy for the type of the value. +proxyOf :: a -> Proxy a +proxyOf _ = Proxy diff --git a/src/Core/Data/Semigroup.hs b/src/Core/Data/Semigroup.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Semigroup.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DefaultSignatures #-} + +module Core.Data.Semigroup + ( Semigroup1 (..) + ) where + +import Data.Semigroup + +-- | Is a 'Semigroup' if its type variable is a 'Semigroup', +class Semigroup1 a where + sappend1 :: (Semigroup b) => a b -> a b -> a b + default sappend1 :: (Semigroup b, Semigroup (a b)) => a b -> a b -> a b + sappend1 = (<>) diff --git a/src/Core/Data/Set.hs b/src/Core/Data/Set.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Set.hs @@ -0,0 +1,21 @@ +module Core.Data.Set + ( concatMap + , mapMaybe + , traverse + ) where + +import qualified Data.Maybe as List (mapMaybe) +import qualified Data.List as List (concatMap) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Prelude as List (traverse) +import Prelude hiding (concatMap, traverse) + +concatMap :: (Ord b) => (a -> [b]) -> Set a -> Set b +concatMap f = Set.fromList . List.concatMap f . Set.toList + +mapMaybe :: (Ord b) => (a -> Maybe b) -> Set a -> Set b +mapMaybe f = Set.fromList . List.mapMaybe f . Set.toList + +traverse :: (Ord b, Applicative w) => (a -> w b) -> Set a -> w (Set b) +traverse f = fmap Set.fromList . List.traverse f . Set.toList diff --git a/src/Core/Data/String.hs b/src/Core/Data/String.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/String.hs @@ -0,0 +1,96 @@ +module Core.Data.String + ( trim + , lines' + , unlines' + , endPos + , quote + , unquote + , unescape + , escape + , indentBullet + , indentBlockQuote + ) where + +import Data.List +import Core.Data.List +import Data.Char + +-- | Removes leading and trailing whitespace. +trim :: String -> String +trim = strip isSpace + +-- | Separates the text by newlines. +-- Unlike (regular) @lines@, +-- if there's a trailing newline in the text, +-- this will include an empty string at the end. +lines' :: String -> [String] +lines' "" = [""] +lines' ('\n' : xs) = "" : lines' xs +lines' (x : xs) = overHead (x :) $ lines' xs + +-- | Joins the texts with a newline. +-- Unlike (regular) @unlines@, +-- this doesn't add a trailing newline at the end. +unlines' :: [String] -> String +unlines' = intercalate "\n" + +-- | The line and column length of the text. +endPos :: String -> (Int, Int) +endPos text = (endLine, endCol) + where endCol = length lastLine + lastLine = last lines'' + endLine = length lines'' - 1 + lines'' + = case lines' text of + [] -> [""] + someLines -> someLines + +-- | Unescapes the string and surrounds it in quotes. +quote :: String -> String +quote str = "\"" ++ unescape str ++ "\"" + +-- | Escapes the string and removes surrounding quotes. +-- Expects the string to have surrounding quotes and be escaped. +unquote :: String -> String +unquote = escape . tail . init + +-- | Encodes the given string in source code. +unescape :: String -> String +unescape [] = [] +unescape ('"' : xs) = '\\' : '"' : unescape xs +unescape ('\b' : xs) = '\\' : 'b' : unescape xs +unescape ('\r' : xs) = '\\' : 'r' : unescape xs +unescape ('\t' : xs) = '\\' : 't' : unescape xs +unescape ('\n' : xs) = '\\' : 'n' : unescape xs +unescape ('\\' : xs) = '\\' : '\\' : unescape xs +unescape (x : xs) = x : unescape xs + +-- | Decodes the given string from source code, +escape :: String -> String +escape [] = [] +escape ('\\' : '"' : xs) = '"' : escape xs +escape ('\\' : 'b' : xs) = '\b' : escape xs +escape ('\\' : 'r' : xs) = '\r' : escape xs +escape ('\\' : 't' : xs) = '\t' : escape xs +escape ('\\' : 'n' : xs) = '\n' : escape xs +escape ('\\' : '\\' : xs) = '\\' : escape xs +escape ('\\' : '\n' : xs) = escape xs +escape (x : xs) = x : escape xs + +-- | Formats into a Markdown-style bulleted list item. +indentBullet :: String -> String +indentBullet subPr = "- " ++ indent subPr + +-- | Formats into a Markdown-style block quote. +indentBlockQuote :: String -> String +indentBlockQuote contentPr = "> " ++ indentBlockQuoteRest contentPr + +indent :: String -> String +indent [] = [] +indent ('\n' : xs) = "\n " ++ indent xs +indent (x : xs) = x : indent xs + +indentBlockQuoteRest :: String -> String +indentBlockQuoteRest [] = [] +indentBlockQuoteRest ('\n' : xs) = "\n> " ++ indent xs +indentBlockQuoteRest (x : xs) = x : indent xs diff --git a/src/Core/Data/Text.hs b/src/Core/Data/Text.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Text.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Core.Data.Text + ( lines' + , unlines' + , endPos + , indentBullet + , indentBlockQuote + ) where + +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as Text + +-- | Separates the text by newlines. +-- Unlike (regular) @lines@, +-- if there's a trailing newline in the text, +-- this will include an empty string at the end. +lines' :: Text -> [Text] +lines' = Text.splitOn "\n" + +-- | Joins the texts with a newline. +-- Unlike (regular) @unlines@, +-- this doesn't add a trailing newline at the end. +unlines' :: [Text] -> Text +unlines' = Text.intercalate "\n" + +-- | The line and column length of the text. +endPos :: Text -> (Int, Int) +endPos text = (endLine, endCol) + where endCol = Text.length lastLine + lastLine = last lines'' + endLine = length lines'' - 1 + lines'' + = case lines' text of + [] -> [Text.empty] + someLines -> someLines + +-- | Formats into a Markdown-style bulleted list item. +indentBullet :: Text -> Text +indentBullet subPr = "- " <> indent subPr + +-- | Formats into a Markdown-style block quote. +indentBlockQuote :: Text -> Text +indentBlockQuote contentPr = "> " <> indentBlockQuoteRest contentPr + +indent :: Text -> Text +indent = Text.replace "\n" "\n " + +indentBlockQuoteRest :: Text -> Text +indentBlockQuoteRest = Text.replace "\n" "\n> " diff --git a/src/Core/Data/Tuple.hs b/src/Core/Data/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Core/Data/Tuple.hs @@ -0,0 +1,7 @@ +module Core.Data.Tuple + ( mapAll + ) where + +-- | Transforms both items in a 2-tuple. +mapAll :: (a -> b) -> (a, a) -> (b, b) +mapAll f (x, y) = (f x, f y) diff --git a/src/Core/DontForce.hs b/src/Core/DontForce.hs new file mode 100644 --- /dev/null +++ b/src/Core/DontForce.hs @@ -0,0 +1,7 @@ +module Core.DontForce + ( dontForce + ) where + + -- | An expression which shouldn't be forced (evaluated) - an error. + dontForce :: a + dontForce = error "oops, this shouldn't be forced" diff --git a/src/Core/Numeric.hs b/src/Core/Numeric.hs new file mode 100644 --- /dev/null +++ b/src/Core/Numeric.hs @@ -0,0 +1,24 @@ +module Core.Numeric + ( readBinary + , readFrac + ) where + +import Numeric +import Data.Ratio + +-- | Reads a binary number (1s and 0s). +readBinary :: (Num a) => ReadS a +readBinary = readInt 2 (`elem` "01") readBit + +readBit :: Char -> Int +readBit '0' = 0 +readBit '1' = 1 +readBit x = error $ "Expected a bit, got " ++ show x + +-- | Reads a fraction - @a/b@, where @a@ and @b@ are integers. +readFrac :: ReadS Rational +readFrac str = do + (numer, inter) <- read str + '/' : inter' <- [dropWhile (' ' ==) inter] + (denom, rest) <- read inter' + pure (numer % denom, rest) diff --git a/src/Core/System/FilePath.hs b/src/Core/System/FilePath.hs new file mode 100644 --- /dev/null +++ b/src/Core/System/FilePath.hs @@ -0,0 +1,11 @@ +module Core.System.FilePath + ( takeDirectoryN + ) where + +import Core.Data.List +import System.FilePath + +-- | Removes @n@ end elements from the path. Equivalent to calling +-- 'takeDirectory' @n@ times, but more efficient. +takeDirectoryN :: Int -> FilePath -> FilePath +takeDirectoryN n = joinPath . dropEnd n . splitPath diff --git a/src/Core/Text/Megaparsec.hs b/src/Core/Text/Megaparsec.hs new file mode 100644 --- /dev/null +++ b/src/Core/Text/Megaparsec.hs @@ -0,0 +1,59 @@ +module Core.Text.Megaparsec + ( runParserF + , any + , exactly + , satisfy + , mapExactly + , mapSatisfy + , someSepBy + , manySepBy + ) where + +import Prelude hiding (any) +import Text.Megaparsec.Char +import Text.Megaparsec +import qualified Data.Set as Set +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty + +-- | Runs the parser, expecting it to consume all the input. +runParserF :: (Ord e, Stream s) + => Parsec e s o + -> String + -> s + -> Either (ParseError (Token s) e) o +runParserF parser = runParser $ parser <* eof + +any :: MonadParsec e s m => m (Token s) +any = anyChar + +exactly :: MonadParsec e s m => Token s -> m () +exactly x = () <$ char x + +-- | Applies the function to the input, then expects it to be the +-- function applied to the given value. +mapExactly :: (Eq a) => MonadParsec e s m => (Token s -> a) -> Token s -> m () +mapExactly f expected = () <$ mapSatisfyRepr (expect . f) (Just expected) + where expect x + | x == f expected = Just x + | otherwise = Nothing + +-- | Applies the function to the input. If it succeeds, returns the output. +-- If it fails, returns an error indicating that the input was unexpected. +mapSatisfy :: MonadParsec e s m => (Token s -> Maybe a) -> m a +mapSatisfy f = mapSatisfyRepr f Nothing + +mapSatisfyRepr :: MonadParsec e s m => (Token s -> Maybe a) -> Maybe (Token s) -> m a +mapSatisfyRepr f repr = token testSatisfy repr + where testSatisfy input + = case f input of + Nothing -> Left (pure (Tokens (input :| [])), Set.empty) + Just res -> Right res + +someSepBy :: MonadParsec e s m => m a -> m b -> m (NonEmpty a) +x `someSepBy` sep = (:|) <$> x <*> many (sep *> x) + +manySepBy :: MonadParsec e s m => m a -> m b -> m [a] +x `manySepBy` sep + = NonEmpty.toList <$> (x `someSepBy` sep) + <|> pure [] diff --git a/src/Core/Text/Megaparsec/Error.hs b/src/Core/Text/Megaparsec/Error.hs new file mode 100644 --- /dev/null +++ b/src/Core/Text/Megaparsec/Error.hs @@ -0,0 +1,48 @@ +module Core.Text.Megaparsec.Error + ( traverseErrorSource + , mapErrorSourceStream + , mapErrorSource + ) where + +import Text.Megaparsec.Error +import qualified Data.Set as Set +import qualified Core.Data.Set as Set +import Data.Maybe +import Core.Data.List +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty + +-- | By converting each individual source token into a collection of +-- source tokens, converts each individual "unexpected token" error into +-- a collection of "unexpected" token errors. +-- Mainly used to convert errors parsing larger groups of items errors +-- parsing smaller groups of items. +traverseErrorSource :: (Ord t2) => (t1 -> [t2]) -> ParseError t1 e -> ParseError t2 e +traverseErrorSource f (TrivialError poss actual expecteds) + = TrivialError poss actual' expecteds' + where actual' = maybeHead =<< traverseErrorItemSource f <$> actual + expecteds' = Set.concatMap (traverseErrorItemSource f) expecteds +traverseErrorSource _ (FancyError poss fancy) = FancyError poss fancy + +mapErrorSourceStream :: (Ord t2) => (NonEmpty t1 -> NonEmpty t2) -> ParseError t1 e -> ParseError t2 e +mapErrorSourceStream f (TrivialError poss actual expecteds) + = TrivialError poss actual' expecteds' + where actual' = mapErrorItemSourceStream f <$> actual + expecteds' = Set.map (mapErrorItemSourceStream f) expecteds +mapErrorSourceStream _ (FancyError poss fancy) = FancyError poss fancy + +mapErrorSource :: (Ord t2) => (t1 -> t2) -> ParseError t1 e -> ParseError t2 e +mapErrorSource f (TrivialError poss actual expecteds) + = TrivialError poss (fmap f <$> actual) (Set.map (fmap f) expecteds) +mapErrorSource _ (FancyError poss fancy) = FancyError poss fancy + +traverseErrorItemSource :: (Ord t2) => (t1 -> [t2]) -> ErrorItem t1 -> [ErrorItem t2] +traverseErrorItemSource f (Tokens tokens) + = Tokens <$> mapMaybe (NonEmpty.nonEmpty . f) (NonEmpty.toList tokens) +traverseErrorItemSource _ (Label label) = [Label label] +traverseErrorItemSource _ EndOfInput = [EndOfInput] + +mapErrorItemSourceStream :: (Ord t2) => (NonEmpty t1 -> NonEmpty t2) -> ErrorItem t1 -> ErrorItem t2 +mapErrorItemSourceStream f (Tokens tokens) = Tokens $ f tokens +mapErrorItemSourceStream _ (Label label) = Label label +mapErrorItemSourceStream _ EndOfInput = EndOfInput diff --git a/src/Core/Text/ParserCombinators/Read.hs b/src/Core/Text/ParserCombinators/Read.hs new file mode 100644 --- /dev/null +++ b/src/Core/Text/ParserCombinators/Read.hs @@ -0,0 +1,11 @@ +module Core.Text.ParserCombinators.Read + ( forceRead + ) where + +-- | Evaluates the reader on the input, expects exactly 1 result which +-- consumes all input, rna returns that result. +forceRead :: ReadS a -> String -> a +forceRead read' input + = case read' input of + [(out, "")] -> out + _ -> error $ "Expected to read exactly 1 value from " ++ input diff --git a/src/Descript.hs b/src/Descript.hs new file mode 100644 --- /dev/null +++ b/src/Descript.hs @@ -0,0 +1,8 @@ +-- | Provides tools for interpreting and inspecting Descript programs. +module Descript + ( module Descript.Build + , module Descript.Misc + ) where + +import Descript.Build +import Descript.Misc diff --git a/src/Descript/BasicInj.hs b/src/Descript/BasicInj.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj.hs @@ -0,0 +1,5 @@ +-- | Basic implementation with injections - simple but inefficient, unchecked. +-- Allows for operations on primitives. For example, you can define a +-- function which takes 2 primitives encoding numbers, and returns a new +-- primitive encoding their sum. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/BasicInj/Data.hs b/src/Descript/BasicInj/Data.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data.hs @@ -0,0 +1,17 @@ +module Descript.BasicInj.Data + ( module Descript.BasicInj.Data.Source + , module Descript.BasicInj.Data.Reducer + , module Descript.BasicInj.Data.Value + , module Descript.BasicInj.Data.Type + , module Descript.BasicInj.Data.Import + , module Descript.BasicInj.Data.InjFunc + , module Descript.BasicInj.Data.Atom + ) where + +import Descript.BasicInj.Data.Source +import Descript.BasicInj.Data.Reducer +import Descript.BasicInj.Data.Value hiding (head, properties) +import Descript.BasicInj.Data.Type hiding (head, properties) +import Descript.BasicInj.Data.Import +import Descript.BasicInj.Data.InjFunc +import Descript.BasicInj.Data.Atom diff --git a/src/Descript/BasicInj/Data/Atom.hs b/src/Descript/BasicInj/Data/Atom.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Atom.hs @@ -0,0 +1,11 @@ +module Descript.BasicInj.Data.Atom + ( module Descript.BasicInj.Data.Atom.Inject + , module Descript.BasicInj.Data.Atom.Scope + , module Descript.BasicInj.Data.Atom.PropPath + , module Descript.Lex.Data.Atom + ) where + +import Descript.BasicInj.Data.Atom.Inject +import Descript.BasicInj.Data.Atom.Scope +import Descript.BasicInj.Data.Atom.PropPath +import Descript.Lex.Data.Atom diff --git a/src/Descript/BasicInj/Data/Atom/Inject.hs b/src/Descript/BasicInj/Data/Atom/Inject.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Atom/Inject.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.BasicInj.Data.Atom.Inject + ( PrimType (..) + , InjSymbol (..) + , isInjSymbol + , forceToInjSymbol + , isPrimInstance + ) where + +import Descript.Lex.Data.Atom +import Descript.Misc +import Data.Semigroup + +-- | A type of built-in primitive. +data PrimType an + = PrimTypeNumber an + | PrimTypeString an + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An identifier for a built-in primitive or injected function. +data InjSymbol an + = InjSymbol an String + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Ann PrimType where + getAnn (PrimTypeNumber ann) = ann + getAnn (PrimTypeString ann) = ann + +instance Ann InjSymbol where + getAnn (InjSymbol ann _) = ann + +instance EAnn InjSymbol where + InjSymbol xKeyAnn xKeyStr `eappend` InjSymbol yKeyAnn yKeyStr + | xKeyStr /= yKeyStr = error "Injected symbols have different content" + | otherwise = InjSymbol (xKeyAnn <> yKeyAnn) xKeyStr + +instance Printable PrimType where + aprint (PrimTypeNumber _) = plex "#Number[]" + aprint (PrimTypeString _) = plex "#String[]" + +instance Printable InjSymbol where + aprint (InjSymbol _ str) = plex $ '#' : str + +instance (Show an) => Summary (PrimType an) where + summary = pprintSummary + +instance (Show an) => Summary (InjSymbol an) where + summary = pprintSummary + +-- | Whether the symbol refers to something injected - a primtive type +-- or an injected function. +isInjSymbol :: Symbol an -> Bool +isInjSymbol (Symbol _ ('#' : _)) = True +isInjSymbol (Symbol _ _) = False + +-- | Assuming the symbol refers to something injected, converts it to an +-- injected symbol, making this reference explicit. +-- Raises an error otherwise. +forceToInjSymbol :: Symbol an -> InjSymbol an +forceToInjSymbol (Symbol ann ('#' : xs)) = InjSymbol ann xs +forceToInjSymbol (Symbol _ _) = error "Symbol doesn't refer to injected function." + +-- | Whether the primitive is an instance of the type. +isPrimInstance :: Prim an1 -> PrimType an2 -> Bool +isPrimInstance (PrimNumber _ _) (PrimTypeNumber _) = True +isPrimInstance (PrimText _ _) (PrimTypeString _) = True +isPrimInstance _ _ = False diff --git a/src/Descript/BasicInj/Data/Atom/PropPath.hs b/src/Descript/BasicInj/Data/Atom/PropPath.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Atom/PropPath.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.BasicInj.Data.Atom.PropPath + ( PropPath (..) + , SubPropPath + , PathElem (..) + , immPath + , subPath + , appendSubpath + , stripPrefixPath + ) where + +import Descript.BasicInj.Data.Atom.Scope +import Descript.Lex.Data.Atom +import Descript.Misc +import Data.Monoid +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Core.Data.List.NonEmpty as NonEmpty + +-- | A property path. Refers to a top-level value's property, or +-- property of a property, or property of a property of a property, etc. +data PropPath an + = PropPath an (NonEmpty (PathElem an)) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A part of a property path. It can refer to a top-level value, or +-- a property, or a property of a property, etc. +type SubPropPath an = [PathElem an] + +-- | A property path element. Refers to a property key in a type of +-- record. For example, `a" $ map sub $ NonEmpty.toList elems + +instance Printable PathElem where + aprintRec sub (PathElem _ key head') = sub key <> pimp ("<" <> sub head') + +instance (Show an) => Summary (PropPath an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (PathElem an) where + summaryRec = pprintSummaryRec + +-- | A 'PropPath' with 1 element. +immPath :: PathElem () -> PropPath () +immPath x = PropPath () $ x :| [] + +-- | Prepends the element to the path. +subPath :: PathElem () -> PropPath () -> PropPath () +subPath x (PropPath () xs) = PropPath () $ x NonEmpty.<| xs + +-- | Adds the elements in the subpath to the end of the path. +appendSubpath :: PropPath () -> SubPropPath () -> PropPath () +appendSubpath (PropPath () (x :| xs)) suf = PropPath () $ x :| xs ++ suf + +-- | If the second path starts with the first, returns the part after. +-- Otherwise returns 'Nothing'. +stripPrefixPath :: PropPath () -> PropPath () -> Maybe (SubPropPath ()) +PropPath _ xs `stripPrefixPath` PropPath _ ys + = xs `NonEmpty.stripPrefix` ys diff --git a/src/Descript/BasicInj/Data/Atom/Scope.hs b/src/Descript/BasicInj/Data/Atom/Scope.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Atom/Scope.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +module Descript.BasicInj.Data.Atom.Scope + ( FSymbol (..) + , codeFSym + , undefinedFSym + ) where + +import Descript.Lex.Data.Atom +import Descript.Misc + +-- | A symbol with a file scope. +data FSymbol an + = FSymbol + { fsymbolScope :: AbsScope + , fsymbol :: Symbol an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Ann FSymbol where + getAnn = getAnn . fsymbol + +instance EAnn FSymbol where + FSymbol xScope xSym `eappend` FSymbol yScope ySym + | xScope /= yScope = error "symbols' scopes not equal" + | otherwise = FSymbol xScope $ xSym `eappend` ySym + +instance Printable FSymbol where + aprint = aprint . fsymbol + +instance (Show an) => Summary (FSymbol an) where + summary = pprintSummary + +-- | The record head for code blocks. +codeFSym :: FSymbol () +codeFSym + = FSymbol + { fsymbolScope = baseScope + , fsymbol = codeSym + } + +-- | A symbol for an undefined value - e.g. an unresolved implicit +-- property. +undefinedFSym :: FSymbol () +undefinedFSym + = FSymbol + { fsymbolScope = undefinedScope + , fsymbol = undefinedSym + } diff --git a/src/Descript/BasicInj/Data/Import.hs b/src/Descript/BasicInj/Data/Import.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Import.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/BasicInj/Data/Import/Import.hs b/src/Descript/BasicInj/Data/Import/Import.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Import/Import.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.BasicInj.Data.Import.Import + ( ImportRecord (..) + , ImportDecl (..) + , ImportCtx (..) + , mkImportRecord + ) where + +import Descript.BasicInj.Data.Import.Module +import Descript.BasicInj.Data.Atom +import Descript.Misc +import Data.Monoid + +-- | Imports a single record. +data ImportRecord an + = ImportRecord + { importRecordAnn :: an + , importRecordFrom :: FSymbol an + , importRecordTo :: FSymbol an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An import declaration. +data ImportDecl an + = ImportDecl + { importDeclAnn :: an + , importDeclPath :: ModulePath an + -- | Moves records in the dependency into this module. + , importDeclSrcImports :: [ImportRecord an] + -- | Moves records in this module into the dependency. + , importDeclDstImports :: [ImportRecord an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Contains all a source's imports. +data ImportCtx an + = ImportCtx + { importCtxAnn :: an + , moduleDecl :: ModuleDecl an + , importDecls :: [ImportDecl an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Ann ImportCtx where + getAnn = importCtxAnn + +instance Ann ImportDecl where + getAnn = importDeclAnn + +instance Ann ImportRecord where + getAnn = importRecordAnn + +instance Printable ImportCtx where + aprintRec sub (ImportCtx _ mdecl idecls) + = pintercal "\n" $ filter (/= mempty) $ sub mdecl : map sub idecls + +instance Printable ImportDecl where + aprintRec sub (ImportDecl _ path isrcs idsts) + = "import " + <> sub path + <> pimp1 ("[" <> pintercal ", " (map sub isrcs) <> "]") + <> pimp2 ("{" <> pintercal ", " (map sub idsts) <> "}") + where pimp1 = pimpIf $ null isrcs + pimp2 = pimpIf $ null idsts + +instance Printable ImportRecord where + aprintRec sub (ImportRecord _ from to) + = pimp' (sub from <> " => ") <> sub to + where pimp' = pimpIf $ fsymbol from =@= fsymbol to + + needsFullReprint _pxy = True + +instance (Show an) => Summary (ImportCtx an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (ImportDecl an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (ImportRecord an) where + summaryRec = pprintSummaryRec + +-- | If the second param is 'Nothing', makes a record which implicitly +-- imports the symbol as itself. +mkImportRecord :: an -> FSymbol an -> Maybe (FSymbol an) -> ImportRecord an +mkImportRecord _ ft Nothing = ImportRecord (getAnn ft) ft ft +mkImportRecord ann from (Just to) = ImportRecord ann from to diff --git a/src/Descript/BasicInj/Data/Import/Module.hs b/src/Descript/BasicInj/Data/Import/Module.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Import/Module.hs @@ -0,0 +1,5 @@ +module Descript.BasicInj.Data.Import.Module + ( module Descript.Free.Data.Import.Module + ) where + +import Descript.Free.Data.Import.Module diff --git a/src/Descript/BasicInj/Data/InjFunc.hs b/src/Descript/BasicInj/Data/InjFunc.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/InjFunc.hs @@ -0,0 +1,70 @@ +module Descript.BasicInj.Data.InjFunc + ( InjFunc + , lookupFunc + , forceLookupFunc + ) where + +import Descript.BasicInj.Data.Atom +import Data.Monoid +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Prelude hiding (subtract, compare) +import qualified Prelude (compare) + +-- | A function which operates on primtives, which can be accessed in +-- Descript. Returns 'Nothing' when given the wrong type of primitives. +type InjFunc = [Prim ()] -> Maybe (Prim ()) + +-- | All injected functions, with their corresponding identifiers. +-- (Identifiers not in 'InjSymbol' for convenience). +allFuncs :: Map String InjFunc +allFuncs = Map.fromList + [ ("Add", add) + , ("Subtract", subtract) + , ("Multiply", multiply) + , ("Compare", compare) + , ("Append", append) + , ("App3", app3) + ] + +-- | Gets the injected function corresponding to the given identifer. +-- Returns `Nothing` if the function doesn't exist. +lookupFunc :: InjSymbol an -> Maybe InjFunc +lookupFunc (InjSymbol _ funcId) = allFuncs Map.!? funcId + +-- | Gets the injected function corresponding to the given identifer. +-- Fails if the function doesn't exist. +forceLookupFunc :: InjSymbol an -> InjFunc +forceLookupFunc (InjSymbol _ funcId) = allFuncs Map.! funcId + +add :: InjFunc +add [PrimNumber () x, PrimNumber () y] = Just $ PrimNumber () $ x + y +add _ = Nothing + +subtract :: InjFunc +subtract [PrimNumber () x, PrimNumber () y] = Just $ PrimNumber () $ x - y +subtract _ = Nothing + +multiply :: InjFunc +multiply [PrimNumber () x, PrimNumber () y] = Just $ PrimNumber () $ x * y +multiply _ = Nothing + +compare :: InjFunc +compare [PrimNumber () x, PrimNumber () y] = Just $ PrimNumber () $ x `compareNum` y +compare _ = Nothing + +append :: InjFunc +append [PrimText () x, PrimText () y] = Just $ PrimText () $ x <> y +append _ = Nothing + +app3 :: InjFunc +app3 [PrimText () x, PrimText () y, PrimText () z] + = Just $ PrimText () $ x <> y <> z +app3 _ = Nothing + +compareNum :: Rational -> Rational -> Rational +x `compareNum` y + = case x `Prelude.compare` y of + LT -> -1 + GT -> 1 + EQ -> 0 diff --git a/src/Descript/BasicInj/Data/Reducer.hs b/src/Descript/BasicInj/Data/Reducer.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Reducer.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.BasicInj.Data.Reducer + ( Reducer (..) + , PhaseCtx (..) + , ReduceCtx (..) + ) where + +import qualified Descript.BasicInj.Data.Value.In as In +import qualified Descript.BasicInj.Data.Value.Out as Out +import Descript.Misc +import Data.Semigroup as S +import Data.Monoid as M +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Core.Data.List.NonEmpty as NonEmpty + +-- | A reducer. It takes a value and converts it into a new value. +-- Programs are interpreted/compiled by taking values and reducing them - +-- the program starts with a value representing a question or source +-- code, and reducers convert this value into the answer or compiled code. +-- This is like a function, or even better, an implicit conversion. +data Reducer an + = Reducer + { reducerAnn :: an + , input :: In.Value an + , output :: Out.Value an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Completely reduces a value in a particular phase. +data PhaseCtx an + = PhaseCtx + { phaseCtxAnn :: an + , phaseCtxReducers :: [Reducer an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Completely reduces a value. In the process, also reduces its own +-- reducers when there are reducers in higher phases. +-- Typically contains all of the reducers in a source file. +data ReduceCtx an + = ReduceCtx + { reduceCtxAnn :: an + , reduceCtxTopPhase :: PhaseCtx an -- ^ Applied to the other phases. + , reduceCtxLowPhases :: NonEmpty (PhaseCtx an) -- ^ "Regular" phases. + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance (Semigroup an) => Semigroup (ReduceCtx an) where + ReduceCtx xAnn xTop xLows <> ReduceCtx yAnn yTop yLows + = ReduceCtx + { reduceCtxAnn = xAnn S.<> yAnn + , reduceCtxTopPhase = xTop S.<> yTop + , reduceCtxLowPhases = xLows `NonEmpty.zipPadS` yLows + } + +instance (Monoid an) => Monoid (ReduceCtx an) where + mempty + = ReduceCtx + { reduceCtxAnn = mempty + , reduceCtxTopPhase = mempty + , reduceCtxLowPhases = mempty :| [] + } + ReduceCtx xAnn xTop xLows `mappend` ReduceCtx yAnn yTop yLows + = ReduceCtx + { reduceCtxAnn = xAnn M.<> yAnn + , reduceCtxTopPhase = xTop M.<> yTop + , reduceCtxLowPhases = xLows `NonEmpty.zipPadM` yLows + } + +instance (Semigroup an) => Semigroup (PhaseCtx an) where + PhaseCtx xAnn xrs <> PhaseCtx yAnn yrs + = PhaseCtx (xAnn S.<> yAnn) (xrs ++ yrs) + +instance (Monoid an) => Monoid (PhaseCtx an) where + mempty = PhaseCtx mempty [] + PhaseCtx xAnn xrs `mappend` PhaseCtx yAnn yrs + = PhaseCtx (xAnn M.<> yAnn) (xrs ++ yrs) + +instance Ann ReduceCtx where + getAnn = reduceCtxAnn + +instance Ann PhaseCtx where + getAnn = phaseCtxAnn + +instance Ann Reducer where + getAnn = reducerAnn + +instance Printable ReduceCtx where + aprintRec sub (ReduceCtx _ top lows) + -- Top phase technically isn't parsable, but this is how it would be parsed + = pimp' (sub top M.<> "\n===\n") + M.<> pintercal "\n---\n" (map sub $ NonEmpty.toList lows) + where pimp' = pimpIf $ top_ == mempty + top_ = remAnns top + +instance Printable PhaseCtx where + aprintRec sub (PhaseCtx _ reducers) = pintercal "\n" $ map sub reducers + +instance Printable Reducer where + aprintRec sub reducer = sub (input reducer) M.<> ": " M.<> sub (output reducer) + +instance (Show an) => Summary (ReduceCtx an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (PhaseCtx an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Reducer an) where + summaryRec = pprintSummaryRec diff --git a/src/Descript/BasicInj/Data/Source.hs b/src/Descript/BasicInj/Data/Source.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Source.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.BasicInj.Data.Source + ( Query (..) + , AModule (..) + , BModule (..) + , Program (..) + , Source (..) + , Dep + , DepResult + , DepResultT + , DirtyDep + , DirtyDepT + , Depd + , DirtyDepd + , DepResolver + , DFile + , sourceToProgram + , sourceBModule + , sourceBModule_ + , sourceAModule + , sourceAModule_ + , sourceScope + , moduleScope + , dsourceAModule + , dmodule + , dquery + ) where + +import Descript.BasicInj.Data.Reducer +import qualified Descript.BasicInj.Data.Value.Reg as Reg +import Descript.BasicInj.Data.Type +import Descript.BasicInj.Data.Import +import Descript.Misc +import Data.Semigroup as S +import Data.Monoid as M +import Data.List +import Prelude hiding (mod) + +-- | The "main" value in a program. A program is interpreted by reducing +-- its query - this reduced is the output of a program. +data Query an + = Query + { queryAnn :: an + , queryVal :: Reg.Value an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Anonymous module - no scope. Defines how a program is interpreted. +-- When a module imports another, the other's 'AModule' is appended. +data AModule an + = AModule + { amoduleAnn :: an + , recordCtx :: RecordCtx an + , reduceCtx :: ReduceCtx an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A module with a scope and imports, which allows it to import other +-- modules. +data BModule an + = BModule + { bmoduleAnn :: an + , importCtx :: ImportCtx an + , amodule :: AModule an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Parsed from a source file and interpreted. To interpret, the query +-- is reduced using the module. +data Program an + = Program + { programAnn :: an + , module' :: BModule an + , query :: Query an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Every source file gets parsed into one of these. +data Source an + = SourceModule (BModule an) + | SourceProgram (Program an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +type Dep = AModule () +type DepResult = GenDepResult Dep +type DepResultT u = GenDepResultT u Dep +type DirtyDep an = GenDirtyDep an Dep +type DirtyDepT an u = GenDirtyDepT an u Dep +type Depd a an = GenDepd Dep (a an) +type DirtyDepd a an = GenDepd (DirtyDep an) (a an) +type DepResolver u = GenDepResolver u (AModule ()) +type DFile u = GenDFile u (AModule ()) + +instance (Semigroup an) => Semigroup (AModule an) where + x <> y + = AModule + { amoduleAnn = amoduleAnn x S.<> amoduleAnn y + , recordCtx = recordCtx x S.<> recordCtx y + , reduceCtx = reduceCtx x S.<> reduceCtx y + } + +instance (Monoid an) => Monoid (AModule an) where + mempty + = AModule + { amoduleAnn = mempty + , recordCtx = mempty + , reduceCtx = mempty + } + + x `mappend` y + = AModule + { amoduleAnn = amoduleAnn x M.<> amoduleAnn y + , recordCtx = recordCtx x M.<> recordCtx y + , reduceCtx = reduceCtx x M.<> reduceCtx y + } + +instance Ann Source where + getAnn (SourceModule mod) = getAnn mod + getAnn (SourceProgram prog) = getAnn prog + +instance Ann Program where + getAnn = programAnn + +instance Ann BModule where + getAnn = bmoduleAnn + +instance Ann AModule where + getAnn = amoduleAnn + +instance Ann Query where + getAnn = queryAnn + +instance Printable Source where + aprintRec sub (SourceModule mod) = sub mod + aprintRec sub (SourceProgram prog) = sub prog + +instance Printable Program where + aprintRec sub prog = pintercal "\n\n" $ filter (/= mempty) + [ sub $ module' prog + , sub $ query prog + ] + +instance Printable BModule where + aprintRec sub mod = pintercal "\n\n" $ filter (/= mempty) + [ sub $ importCtx mod + , sub $ amodule mod + ] + +instance Printable AModule where + aprintRec sub mod = pintercal "\n\n" $ filter (/= mempty) + [ sub $ recordCtx mod + , sub $ reduceCtx mod + ] + +instance Printable Query where + aprintRec sub (Query _ val) = sub val M.<> "?" + +instance (Show an) => Summary (Source an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Program an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (BModule an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (AModule an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Query an) where + summaryRec = pprintSummaryRec + +-- | If the source is a program, returns it. +-- If it's a module, returns 'Nothing'. +sourceToProgram :: Source an -> Maybe (Program an) +sourceToProgram (SourceModule _) = Nothing +sourceToProgram (SourceProgram prog) = Just prog + +-- | The source's bound module. +sourceBModule :: Source an -> BModule an +sourceBModule (SourceModule mod) = mod +sourceBModule (SourceProgram prog) = module' prog + +-- | The source's bound module without annotations. +sourceBModule_ :: Source an -> BModule () +sourceBModule_ = remAnns . sourceBModule + +-- | Contains the source's anonymous module. +sourceAModule :: Source an -> AModule an +sourceAModule = amodule . sourceBModule + +-- | Contains the source's anonymous module, without annotations. +sourceAModule_ :: Source an -> AModule () +sourceAModule_ = remAnns . sourceAModule + +-- | The source's scope - the scope of the source's module, which is +-- also used by the query if the source is a program. +sourceScope :: Source an -> AbsScope +sourceScope = moduleScope . sourceBModule + +-- | The scope of the module. +moduleScope :: BModule an -> AbsScope +moduleScope = moduleDeclScope . moduleDecl . importCtx + +-- | The full module of a source, including its dependencies. +dsourceAModule :: Depd Source an -> AModule () +dsourceAModule (Depd extra src) = sourceAModule_ src M.<> extra + +-- | The full module of a program, including its dependencies. +dmodule :: Depd Program an -> AModule () +dmodule (Depd extra prog) = remAnns (amodule $ module' prog) M.<> extra + +-- | The query of a program with dependencies. +dquery :: Depd Program an -> Query an +dquery = query . depdVal diff --git a/src/Descript/BasicInj/Data/Type.hs b/src/Descript/BasicInj/Data/Type.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Type.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.BasicInj.Data.Type + ( Symbol (..) + , RecordType (..) + , RecordDecl (..) + , RecordCtx (..) + , recordCtxTypes + , lookupRecordType + , recTypeHasHead + ) where + +import Descript.BasicInj.Data.Atom +import Descript.Misc +import Data.Semigroup as S +import Data.Monoid as M +import Data.List hiding (head) +import Prelude hiding (head) + +-- | A record type. +data RecordType an + = RecordType + { recordTypeAnn :: an + , head :: FSymbol an -- ^ Identifies and distinguishes the type. + , properties :: [Symbol an] -- ^ All instances should have properties with these keys. + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A record declaration. +data RecordDecl an + = RecordDecl + { recordDeclAnn :: an + , recordDeclType :: RecordType an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Contains a source file's data definitions. +-- These record types encode the types of records which can be used +-- throughout the rest of the source. +-- Each of them should have a different head. +data RecordCtx an + = RecordCtx + { recordCtxAnn :: an + , recordCtxDecls :: [RecordDecl an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance (Semigroup an) => Semigroup (RecordCtx an) where + RecordCtx xAnn xds <> RecordCtx yAnn yds + = RecordCtx (xAnn S.<> yAnn) (xds ++ yds) + +instance (Monoid an) => Monoid (RecordCtx an) where + mempty = RecordCtx mempty [] + RecordCtx xAnn xds `mappend` RecordCtx yAnn yds + = RecordCtx (xAnn M.<> yAnn) (xds ++ yds) + +instance Ann RecordCtx where + getAnn = recordCtxAnn + +instance Ann RecordDecl where + getAnn = recordDeclAnn + +instance Ann RecordType where + getAnn = recordTypeAnn + +instance Printable RecordCtx where + aprintRec sub (RecordCtx _ recordDecls) = pintercal "\n" $ map sub recordDecls + +instance Printable RecordDecl where + aprintRec sub (RecordDecl _ recordType) = sub recordType M.<> "." + +instance Printable RecordType where + aprintRec sub recordType = sub (head recordType) M.<> propsPrinted + where propsPrinted = "[" M.<> pintercal ", " propPrinteds M.<> "]" + propPrinteds = map sub $ properties recordType + +instance (Show an) => Summary (RecordCtx an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (RecordDecl an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (RecordType an) where + summaryRec = pprintSummaryRec + +-- | The record types declared in the context. +recordCtxTypes :: RecordCtx an -> [RecordType an] +recordCtxTypes = map recordDeclType . recordCtxDecls + +-- | Finds the record type with the given head in the context. +lookupRecordType :: FSymbol an -> RecordCtx an -> Maybe (RecordType an) +lookupRecordType head' = find (recTypeHasHead head') . recordCtxTypes + +-- | Does the record type have the given head? +recTypeHasHead :: FSymbol an1 -> RecordType an2 -> Bool +recTypeHasHead head' record = head' =@= head record diff --git a/src/Descript/BasicInj/Data/Value.hs b/src/Descript/BasicInj/Data/Value.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Value.hs @@ -0,0 +1,5 @@ +module Descript.BasicInj.Data.Value + ( module Descript.BasicInj.Data.Value.Gen + ) where + +import Descript.BasicInj.Data.Value.Gen diff --git a/src/Descript/BasicInj/Data/Value/Gen.hs b/src/Descript/BasicInj/Data/Value/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Value/Gen.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.BasicInj.Data.Value.Gen + ( GenProperty (..) + , GenRecord (..) + , GenValue (..) + , PartProperty + , PartRecord + , GenPropVal (..) + , GenPart (..) + , singletonValue + , isEmpty + , primParts + , mapParts + , foldMapParts + , traverseParts + , recWithHead + , forceRecWithHead + , deleteRecWithHead + , mergeAddRecord + , partHasHead + , recHasHead + , recHasProp + , lookupProp + , forceLookupProp + , mapPropVals + , foldMapPropVals + , traversePropVals + , reconValue + , reValue + , reRecord + , reProperty + ) where + +import Prelude hiding (head) +import Descript.BasicInj.Data.Atom +import Descript.Misc +import Data.Monoid as M +import Core.Data.Monoid +import Data.Semigroup as S +import Core.Data.Semigroup +import Data.Proxy +import Data.Maybe +import Data.List hiding (head) +import Core.Data.List.Assoc +import qualified Data.List.NonEmpty as NonEmpty + +-- | A property whose values are of type @v@. +data GenProperty v an + = Property + { propertyAnn :: an + , propertyKey :: Symbol an + , propertyValue :: v an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A record whose property values are of type @v@ - a record in a +-- value of type @v@. +-- +-- Records are the main data of Descript. A record with no properties +-- encodes a singleton value or leaf. A record with properties encodes a +-- structure, or a tree where the properties are branches. Records are +-- similar to products, but their fields are named and they can be +-- differentiated by thier heads. +data GenRecord v an + = Record + { recordAnn :: an + , head :: FSymbol an + , properties :: [GenProperty v an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A value whose parts are of type 'p'. +data GenValue p an + = Value + { valueAnn :: an + , valueParts :: [p an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A property for a particular part. +type PartProperty p an = GenProperty (PartPropVal p) an + +-- | A record for a particular part. +type PartRecord p an = GenRecord (PartPropVal p) an + +class (Semigroup1 v, Monoid1 v) => GenPropVal v where + -- | Whether this prints in a property definition. + -- If true, it would print @key: ...@. If false, it would print @key@. + doesPrint :: v an -> Bool + +-- | A part of a value. +class (Ann p, GenPropVal (PartPropVal p), Eq (p ())) => GenPart p where + type PartPropVal p :: * -> * + + partToPrim :: p an -> Maybe (Prim an) + partToRec :: p an -> Maybe (PartRecord p an) + primToPart :: Proxy p -> Prim an -> p an + recToPart :: Proxy p -> PartRecord p an -> p an + mergeAddPart :: (Semigroup an) => p an -> [p an] -> [p an] + +instance (GenPart p, Semigroup an, Monoid an) => Monoid (GenValue p an) where + mempty = Value mempty [] + mappend = (S.<>) + mconcat vals + = Value + { valueAnn = mconcat $ map valueAnn vals + , valueParts = cmergeParts $ map valueParts vals + } + +instance (GenPart p, Semigroup an) => Semigroup (GenValue p an) where + Value xAnn xParts <> Value yAnn yParts + = Value (xAnn S.<> yAnn) $ mergeParts xParts yParts + sconcat vals + = Value + { valueAnn = sconcat $ NonEmpty.map valueAnn vals + , valueParts = cmergeParts $ map valueParts $ NonEmpty.toList vals + } + +instance (GenPart p) => GenPropVal (GenValue p) where + doesPrint _ = True + +instance (GenPart p) => Monoid1 (GenValue p) +instance (GenPart p) => Semigroup1 (GenValue p) + +instance AssocPair (GenProperty v an) where + type Key (GenProperty v an) = Symbol () -- Don't want annotations to distinguish keys. + type Value (GenProperty v an) = v an + + getKey = remAnns . propertyKey + getValue = propertyValue + +instance (Semigroup an) => SemAssocPair (GenProperty v an) where + aappend1 vapp (Property xAnn xKey xVal) (Property yAnn yKey yVal) + = Property (xAnn S.<> yAnn) (xKey `eappend` yKey) (xVal `vapp` yVal) + +instance (Functor p, Foldable p, Traversable p) => SAnn (GenValue p) where + mapSAnn f (Value ann parts) = Value (f ann) parts + +instance (Functor p, Foldable p, Traversable p) => Ann (GenValue p) where + getAnn = valueAnn + +instance (Functor v, Foldable v, Traversable v) => Ann (GenRecord v) where + getAnn = recordAnn + +instance (Functor v, Foldable v, Traversable v) => Ann (GenProperty v) where + getAnn = propertyAnn + +instance (Printable p) => Printable (GenValue p) where + aprintRec sub (Value _ parts) = pintercal " | " $ map sub parts + +instance (Printable p) => FwdPrintable (GenValue p) where + afprintRec = id + +instance (FwdPrintable v, GenPropVal v) => Printable (GenRecord v) where + aprintRec sub record = sub (head record) M.<> propsPrinted + where propsPrinted = "[" M.<> pintercal ", " propPrinteds M.<> "]" + propPrinteds = map sub $ properties record + +instance (FwdPrintable v, GenPropVal v) => Printable (GenProperty v) where + aprintRec sub (Property _ key val) + | doesPrint val = pimp (keyPrinted M.<> ": ") M.<> valPrinted + | otherwise = keyPrinted + where keyPrinted = sub key + valPrinted = afprintRec sub val + +instance (Show an, Printable p, Show (p an)) => Summary (GenValue p an) where + summaryRec = pprintSummaryRec + +instance (Show an, FwdPrintable v, GenPropVal v, Show (v an)) => Summary (GenRecord v an) where + summaryRec = pprintSummaryRec + +instance (Show an, FwdPrintable v, GenPropVal v, Show (v an)) => Summary (GenProperty v an) where + summaryRec = pprintSummaryRec + +-- | Creates a value with just the given part. +singletonValue :: (Ann p) => p an -> GenValue p an +singletonValue part = Value (getAnn part) [part] + +-- | Whether the value has any parts. +isEmpty :: GenValue p an -> Bool +isEmpty (Value _ parts) = null parts + +-- | All primitives in the value. +primParts :: (GenPart p) => GenValue p an -> [Prim an] +primParts = mapMaybe partToPrim . valueParts + +-- | Maps the parts. +mapParts :: (p1 an -> p2 an) -> GenValue p1 an -> GenValue p2 an +mapParts f (Value ann parts) = Value ann $ map f parts + +-- | Maps then folds the parts. +foldMapParts :: (Monoid r) => (p an -> r) -> GenValue p an -> r +foldMapParts f (Value _ parts) = foldMap f parts + +-- | Traverses the parts. +traverseParts :: (Applicative w) + => (p1 an -> w (p2 an)) + -> GenValue p1 an + -> w (GenValue p2 an) +traverseParts f (Value ann parts) = Value ann <$> traverse f parts + +-- | Gets the record in the value with the given head. +recWithHead :: (GenPart p) + => FSymbol an1 + -> GenValue p an2 + -> Maybe (PartRecord p an2) +recWithHead head' (Value _ parts) + = find (recHasHead head') $ mapMaybe partToRec parts + +-- | Gets the record in the value with the given head. +-- Returns an error if the value isn't present +forceRecWithHead :: (GenPart p) + => FSymbol an1 + -> GenValue p an2 + -> PartRecord p an2 +forceRecWithHead head' value + = case recWithHead head' value of + Nothing + -> error + $ "Value doesn't contain record with head: " + ++ show (remAnns head') + Just record -> record + +-- | Removes the record in the value with the given head. +-- If this record doesn't exist, does nothing. +deleteRecWithHead :: (GenPart p) + => FSymbol an + -> GenValue p an + -> GenValue p an +deleteRecWithHead head' (Value ann parts) + = Value ann $ filter (partHasHead head') parts + +cmergeParts :: (GenPart p, Semigroup an) + => [[p an]] + -> [p an] +cmergeParts = foldr mergeParts [] + +mergeParts :: (GenPart p, Semigroup an) + => [p an] + -> [p an] + -> [p an] +mergeParts = foldr mergeAddPart + +mergeAddRecord :: (GenPart p, Semigroup an) + => PartRecord p an + -> [p an] + -> [p an] +mergeAddRecord record [] = [recToPart Proxy record] +mergeAddRecord record (x : xs) + = case tryMergeRecordWithPart record x of + Failure () -> x : mergeAddRecord record xs + Success newRecord -> recToPart Proxy newRecord : xs + +tryMergeRecordWithPart :: (GenPart p, Semigroup an) + => PartRecord p an + -> p an + -> UResult (PartRecord p an) +tryMergeRecordWithPart xRecord y + = case partToRec y of + Nothing -> Failure () + Just yRecord -> tryMergeRecords xRecord yRecord + +tryMergeRecords :: (Semigroup1 v, Semigroup an) + => GenRecord v an + -> GenRecord v an + -> UResult (GenRecord v an) +tryMergeRecords (Record xAnn xHead xProps) (Record yAnn yHead yProps) + | xHead /@= yHead = Failure () + | otherwise = Success Record + { recordAnn = xAnn S.<> yAnn + , head = xHead `eappend` yHead + , properties = assocUnionBy sappend1 xProps yProps + } + +-- | Whether the part's a record with the given head. +partHasHead :: (GenPart p) => FSymbol an -> p an -> Bool +partHasHead head' part + = case partToRec part of + Just record -> recHasHead head' record + Nothing -> False + +-- | Does the record have the given head? +recHasHead :: FSymbol an1 -> GenRecord v an2 -> Bool +recHasHead head' record = head' =@= head record + +-- | Does the record have the given property key? +recHasProp :: Symbol an1 -> GenRecord v an2 -> Bool +recHasProp key = assocMember (remAnns key) . properties + +-- | Gets the property with the given key. +-- Returns 'Nothing' if the property doesn't exist. +lookupProp :: Symbol an1 -> GenRecord v an2 -> Maybe (v an2) +lookupProp key = glookup (remAnns key) . properties + +-- | Gets the property with the given key. +-- Raises an error if the property doesn't exist. +forceLookupProp :: Symbol an1 -> GenRecord v an2 -> v an2 +forceLookupProp key record + = case lookupProp key record of + Nothing + -> error + $ "No property with the given key: " + ++ show (remAnns key) + Just x -> x + +-- | Maps the record's property values. +mapPropVals :: (v an -> v2 an) -> GenRecord v an -> GenRecord v2 an +mapPropVals f record + = Record + { recordAnn = recordAnn record + , head = head record + , properties = map (mapPropVal f) $ properties record + } + +-- | Maps then folds the record's property values. +foldMapPropVals :: (Monoid r) => (v an -> r) -> GenRecord v an -> r +foldMapPropVals f = foldMap (f . propertyValue) . properties + +-- | Traverses the record's property values. +traversePropVals :: (Applicative w) => (v an -> w (v2 an)) -> GenRecord v an -> w (GenRecord v2 an) +traversePropVals f record + = Record (recordAnn record) (head record) + <$> traverse (traversePropVal f) (properties record) + +mapPropVal :: (v an -> v2 an) -> GenProperty v an -> GenProperty v2 an +mapPropVal f (Property ann key val) = Property ann key $ f val + +traversePropVal :: (Applicative w) => (v an -> w (v2 an)) -> GenProperty v an -> w (GenProperty v2 an) +traversePropVal f (Property ann key val) = Property ann key <$> f val + +-- | Uses the old parts to taint the value's annotation if necessary -- +-- specifically, the value is tainted if the number of parts changes. +reconValue :: (GenPart p, TaintAnn an) + => an + -> [p an] + -> [GenValue p an] + -> GenValue p an +reconValue ann oldParts = reValue ann oldParts . cmergeParts . map valueParts + +-- | Uses the old parts to taint the value's annotation if necessary -- +-- specifically, the value is tainted if the number of parts changes. +reValue :: (TaintAnn an) => an -> [p an] -> [p an] -> GenValue p an +reValue ann oldParts newParts = Value ann' newParts + where ann' + | length oldParts /= length newParts = taint ann + | otherwise = ann + +-- | Uses the old properties to taint the record's annotation if +-- necessary -- specifically, the value is tainted if the number of +-- properties changes. +reRecord :: (TaintAnn an) + => an + -> FSymbol an + -> [GenProperty v an] + -> [GenProperty v an] + -> GenRecord v an +reRecord ann head' oldProps newProps = Record ann' head' newProps + where ann' + | length oldProps /= length newProps = taint ann + | otherwise = ann + +-- | Uses the old property value to taint the property's annotation if +-- necessary -- specifically, the property is tainted if the old value +-- has a print and the new one doesn't, or vice versa. +reProperty :: (GenPropVal v, TaintAnn an) + => an + -> Symbol an + -> v an + -> v an + -> GenProperty v an +reProperty ann key old new = Property ann' key new + where ann' + | doesPrint old /= doesPrint new = taint ann + | otherwise = ann diff --git a/src/Descript/BasicInj/Data/Value/In.hs b/src/Descript/BasicInj/Data/Value/In.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Value/In.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.BasicInj.Data.Value.In + ( Property + , Record + , Part (..) + , Value + , OptValue (..) + , optValToMaybeVal + , maybeValToOptVal + , mapOptVal + , traverseOptVal + , fullConsumeProp + ) where + +import Descript.BasicInj.Data.Value.Gen +import Descript.BasicInj.Data.Atom +import Descript.Misc +import Data.Semigroup as S +import Data.Monoid as M +import Core.Data.Monoid +import Core.Data.Semigroup + +-- | An input property. +type Property an = GenProperty OptValue an + +-- | An input record. +type Record an = GenRecord OptValue an + +-- | An input part. +data Part an + = PartPrim (Prim an) + | PartPrimType (PrimType an) + | PartRecord (Record an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An input value. +type Value an = GenValue Part an + +-- | Either nothing or a value. Composition of 'Maybe' and 'Value'. +data OptValue an + = NothingValue + | JustValue (Value an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance (Semigroup an, Monoid an) => Monoid (OptValue an) where + mempty = JustValue mempty + NothingValue `mappend` _ = NothingValue + JustValue _ `mappend` NothingValue = NothingValue + JustValue x `mappend` JustValue y = JustValue $ x M.<> y + +instance (Semigroup an) => Semigroup (OptValue an) where + NothingValue <> _ = NothingValue + JustValue _ <> NothingValue = NothingValue + JustValue x <> JustValue y = JustValue $ x S.<> y + +instance GenPropVal OptValue where + doesPrint NothingValue = False + doesPrint (JustValue _) = True + +instance Monoid1 OptValue + +instance Semigroup1 OptValue + +instance GenPart Part where + type PartPropVal Part = OptValue + + partToPrim (PartPrim prim) = Just prim + partToPrim _ = Nothing + + partToRec (PartRecord record) = Just record + partToRec _ = Nothing + + primToPart _ = PartPrim + recToPart _ = PartRecord + + mergeAddPart (PartPrim prim) parts = PartPrim prim : parts + mergeAddPart (PartPrimType typ) parts = PartPrimType typ : parts + mergeAddPart (PartRecord record) parts = mergeAddRecord record parts + +instance Ann Part where + getAnn (PartPrim x) = getAnn x + getAnn (PartPrimType x) = getAnn x + getAnn (PartRecord x) = getAnn x + +instance FwdPrintable OptValue where + afprintRec _ NothingValue = mempty + afprintRec sub (JustValue x) = sub x + +instance Printable Part where + aprintRec sub (PartPrim prim) = sub prim + aprintRec sub (PartPrimType primType) = sub primType + aprintRec sub (PartRecord record) = aprintRec sub record + +instance (Show an) => Summary (OptValue an) where + summaryRec sub = pprintSummaryRecF sub + +instance (Show an) => Summary (Part an) where + summaryRec sub = pprintSummaryRec sub + +-- | Converts the 'OptValue' to an equivalent maybe value. +optValToMaybeVal :: OptValue an -> Maybe (Value an) +optValToMaybeVal NothingValue = Nothing +optValToMaybeVal (JustValue val) = Just val + +-- | Converts the maybe value to an equivalent 'OptValue'. +maybeValToOptVal :: Maybe (Value an) -> OptValue an +maybeValToOptVal Nothing = NothingValue +maybeValToOptVal (Just val) = JustValue val + +-- | Transform the value. +mapOptVal :: (Value an1 -> Value an2) -> OptValue an1 -> OptValue an2 +mapOptVal _ NothingValue = NothingValue +mapOptVal f (JustValue x) = JustValue $ f x + +-- | Transform the value with side effects if it exists. +traverseOptVal :: (Applicative w) + => (Value an1 -> w (Value an2)) + -> OptValue an1 + -> w (OptValue an2) +traverseOptVal _ NothingValue = pure NothingValue +traverseOptVal f (JustValue x) = JustValue <$> f x + +-- | A property with the given key and 'NothingValue' (consumes all +-- input) as its value. +fullConsumeProp :: Symbol an -> Property an +fullConsumeProp key = Property ann key NothingValue + where ann = getAnn key diff --git a/src/Descript/BasicInj/Data/Value/Out.hs b/src/Descript/BasicInj/Data/Value/Out.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Value/Out.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.BasicInj.Data.Value.Out + ( Property + , Record + , InjParam (..) + , InjApp (..) + , Part (..) + , Value + , immPathVal + , mapInjAppParams + , mapInjParamVal + , traverseInjParamVal + , idxPropKeys + , fullProduceProp + ) where + +import Descript.BasicInj.Data.Value.Gen +import Descript.BasicInj.Data.Atom +import Descript.Misc +import Data.Semigroup as S +import Data.Monoid as M +import Data.String + +-- | An output property. +type Property an = GenProperty (GenValue Part) an + +-- | An output record. +type Record an = GenRecord (GenValue Part) an + +-- | A parameter of an injected function. +data InjParam an + = InjParam + { injParamAnn :: an + , injParamVal :: Value an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An application of an injected function. +data InjApp an + = InjApp + { injAppAnn :: an + , funcId :: InjSymbol an + , params :: [InjParam an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An output part. +data Part an + = PartPrim (Prim an) + | PartRecord (Record an) + | PartPropPath (PropPath an) + | PartInjApp (InjApp an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An output value. +type Value an = GenValue Part an + +instance (Semigroup an, Monoid an) => Monoid (InjParam an) where + mempty + = InjParam + { injParamAnn = mempty + , injParamVal = mempty + } + + InjParam xAnn xVal `mappend` InjParam yAnn yVal + = InjParam + { injParamAnn = xAnn M.<> yAnn + , injParamVal = xVal M.<> yVal + } + +instance (Semigroup an) => Semigroup (InjParam an) where + InjParam xAnn xVal <> InjParam yAnn yVal + = InjParam + { injParamAnn = xAnn S.<> yAnn + , injParamVal = xVal S.<> yVal + } + +instance GenPart Part where + type PartPropVal Part = GenValue Part + + partToPrim (PartPrim prim) = Just prim + partToPrim _ = Nothing + + partToRec (PartRecord record) = Just record + partToRec _ = Nothing + + primToPart _ = PartPrim + recToPart _ = PartRecord + + mergeAddPart (PartPrim prim) parts = PartPrim prim : parts + mergeAddPart (PartRecord record) parts = mergeAddRecord record parts + mergeAddPart (PartPropPath path) parts = PartPropPath path : parts + mergeAddPart (PartInjApp app) parts = mergeAddInjApp app parts + +instance Ann Part where + getAnn (PartPrim x) = getAnn x + getAnn (PartRecord x) = getAnn x + getAnn (PartPropPath x) = getAnn x + getAnn (PartInjApp x) = getAnn x + +instance Ann InjApp where + getAnn = injAppAnn + +instance Ann InjParam where + getAnn (InjParam ann _) = ann + +instance Printable Part where + aprintRec sub (PartPrim prim) = sub prim + aprintRec sub (PartRecord record) = sub record + aprintRec sub (PartPropPath path) = sub path + aprintRec sub (PartInjApp app) = sub app + +instance Printable InjApp where + aprintRec sub app = sub (funcId app) M.<> paramsPrinted + where paramsPrinted = "[" M.<> pintercal ", " paramPrinteds M.<> "]" + paramPrinteds = zipWith (paramPrint sub) idxPropKeys $ params app + +instance (Show an) => Summary (Part an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (InjApp an) where + summaryRec = pprintSummaryRec + +-- | Refers to the immediate property corresponding to the path element. +immPathVal :: PathElem () -> Value () +immPathVal = singletonValue . PartPropPath . immPath + +mapInjAppParams :: (InjParam an -> InjParam an) -> InjApp an -> InjApp an +mapInjAppParams f (InjApp ann funcId' params') + = InjApp ann funcId' $ map f params' + +-- | Transforms the value in the injected parameter. +mapInjParamVal :: (Value an -> Value an) -> InjParam an -> InjParam an +mapInjParamVal f (InjParam ann x) = InjParam ann $ f x + +-- | Transforms the value in the injected parameter with side effects. +traverseInjParamVal :: (Functor w) + => (Value an -> w (Value an)) + -> InjParam an + -> w (InjParam an) +traverseInjParamVal f (InjParam ann x) = InjParam ann <$> f x + +mergeAddInjApp :: (Semigroup an) => InjApp an -> [Part an] -> [Part an] +mergeAddInjApp app [] = [PartInjApp app] +mergeAddInjApp app (x : xs) + = case tryMergeInjAppWithPart app x of + Failure () -> x : mergeAddInjApp app xs + Success newApp -> PartInjApp newApp : xs + +tryMergeInjAppWithPart :: (Semigroup an) + => InjApp an + -> Part an + -> UResult (InjApp an) +tryMergeInjAppWithPart xApp (PartInjApp yApp) = tryMergeInjApps xApp yApp +tryMergeInjAppWithPart _ _ = Failure () + +tryMergeInjApps :: (Semigroup an) + => InjApp an + -> InjApp an + -> UResult (InjApp an) +tryMergeInjApps (InjApp xAnn xFuncId xParams) (InjApp yAnn yFuncId yParams) + | xFuncId /@= yFuncId = Failure () + | otherwise = Success InjApp + { injAppAnn = xAnn S.<> yAnn + , funcId = xFuncId `eappend` yFuncId + , params = zipWith (S.<>) xParams yParams + } + +-- | Each of these keys in an injected function application corresponds +-- to a parameter at its position. +idxPropKeys :: [Symbol ()] +idxPropKeys = map (Symbol () . pure) ['a'..'z'] + +-- | A property with the given key and a path to itself (with the given +-- record head) as its value. +fullProduceProp :: FSymbol () -> Symbol () -> Property () +fullProduceProp head' key = Property () key val + where val = immPathVal $ PathElem () key head' + + +paramPrint :: (Monoid r, IsString r) + => (Value an -> r) + -> Symbol () + -> InjParam an + -> r +paramPrint sub label (InjParam _ val) + = fromString (pprintStr label) + M.<> ": " + M.<> sub val diff --git a/src/Descript/BasicInj/Data/Value/Reg.hs b/src/Descript/BasicInj/Data/Value/Reg.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Data/Value/Reg.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.BasicInj.Data.Value.Reg + ( Property + , Record + , Part (..) + , Value + ) where + +import Descript.BasicInj.Data.Value.Gen +import Descript.BasicInj.Data.Atom +import Descript.Misc +import Prelude hiding (head) + +-- | A regular property. +type Property an = GenProperty (GenValue Part) an + +-- | A regular record. +type Record an = GenRecord (GenValue Part) an + +-- | A regular part. +data Part an + = PartPrim (Prim an) + | PartRecord (Record an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A regular value. +type Value an = GenValue Part an + +instance GenPart Part where + type PartPropVal Part = GenValue Part + + partToPrim (PartPrim prim) = Just prim + partToPrim _ = Nothing + + partToRec (PartRecord record) = Just record + partToRec _ = Nothing + + primToPart _ = PartPrim + recToPart _ = PartRecord + + mergeAddPart (PartPrim prim) parts = PartPrim prim : parts + mergeAddPart (PartRecord record) parts = mergeAddRecord record parts + +instance Ann Part where + getAnn (PartPrim x) = getAnn x + getAnn (PartRecord x) = getAnn x + +instance Printable Part where + aprintRec sub (PartPrim prim) = sub prim + aprintRec sub (PartRecord record) = sub record + +instance (Show an) => Summary (Part an) where + summaryRec = pprintSummaryRec diff --git a/src/Descript/BasicInj/Process.hs b/src/Descript/BasicInj/Process.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process.hs @@ -0,0 +1,2 @@ +-- | Process the AST (interpret, inspect, refactor, etc.). +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/BasicInj/Process/Inspect.hs b/src/Descript/BasicInj/Process/Inspect.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Inspect.hs @@ -0,0 +1,2 @@ +-- | Get information about 'BasicInj' ASTs. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/BasicInj/Process/Inspect/SymbolAt.hs b/src/Descript/BasicInj/Process/Inspect/SymbolAt.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Inspect/SymbolAt.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeFamilies #-} + +module Descript.BasicInj.Process.Inspect.SymbolAt + ( symbolAt + , symbolAt' + ) where + +import qualified Descript.BasicInj.Traverse.Term as T +import Descript.BasicInj.Traverse +import Descript.BasicInj.Data +import Descript.Misc +import Data.Monoid as M +import Data.Foldable +import Data.List +import qualified Data.List.NonEmpty as NonEmpty + +data SymbolAt = SymbolAt Loc + +instance Fold SymbolAt where + type Res SymbolAt = First (SymbolEnv SrcAnn) + type FAnn SymbolAt = SrcAnn + + fonTerm T.ModulePath (SymbolAt loc) (ModulePath _ xs) + = fold $ zipWith (tryModulePathElemAt loc) (inits xs') xs' + where xs' = NonEmpty.toList xs + fonTerm T.RecordHead (SymbolAt loc) x = tryRecordHeadAt loc x + fonTerm T.RecordType (SymbolAt loc) (RecordType _ head' props) + = foldMap (tryPropertyKeyAt loc head') props + fonTerm T.GenRecord (SymbolAt loc) (Record _ head' props) + = foldMap (tryPropertyKeyAt loc head' . propertyKey) props + fonTerm T.PathElem (SymbolAt loc) (PathElem _ propKey' headKey') + = tryPropertyKeyAt loc headKey' propKey' + fonTerm _ _ _ = First Nothing -- mempty + +-- | Finds the symbol at the given location, if it exists. +symbolAt :: Loc -> Source SrcAnn -> Maybe (SymbolEnv SrcAnn) +symbolAt = symbolAt' T.Source + +-- | Finds the symbol at the given location, if it exists. +symbolAt' :: TTerm t -> Loc -> t SrcAnn -> Maybe (SymbolEnv SrcAnn) +symbolAt' term loc = getFirst . foldTerm term (SymbolAt loc) + +tryModulePathElemAt :: Loc + -> [Symbol SrcAnn] + -> Symbol SrcAnn + -> First (SymbolEnv SrcAnn) +tryModulePathElemAt loc xs = fmap (EnvModulePathElem xs) . trySymbolAt loc + +tryRecordHeadAt :: Loc + -> FSymbol SrcAnn + -> First (SymbolEnv SrcAnn) +tryRecordHeadAt loc (FSymbol scope sym) + = EnvRecordHead . FSymbol scope <$> trySymbolAt loc sym + +tryPropertyKeyAt :: Loc + -> FSymbol SrcAnn + -> Symbol SrcAnn + -> First (SymbolEnv SrcAnn) +tryPropertyKeyAt loc head' = fmap (EnvPropertyKey head') . trySymbolAt loc + +trySymbolAt :: Loc -> Symbol SrcAnn -> First (Symbol SrcAnn) +trySymbolAt loc sym + | loc `isInRange` srcRange (getAnn sym) = First $ Just sym + | otherwise = First Nothing diff --git a/src/Descript/BasicInj/Process/Reduce.hs b/src/Descript/BasicInj/Process/Reduce.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Reduce.hs @@ -0,0 +1,13 @@ +-- | Reduction algorithm. +module Descript.BasicInj.Process.Reduce + ( interpret_ + ) where + +import qualified Descript.BasicInj.Process.Reduce.NoAnn as NoAnn +import qualified Descript.BasicInj.Data.Value.Reg as Reg +import Descript.BasicInj.Data.Source +import Descript.Misc + +-- | Removes all annotations, then interprets the program. +interpret_ :: Depd Program an -> Reg.Value () +interpret_ = NoAnn.interpret . fmap remAnns diff --git a/src/Descript/BasicInj/Process/Reduce/Match.hs b/src/Descript/BasicInj/Process/Reduce/Match.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Reduce/Match.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ApplicativeDo #-} + +module Descript.BasicInj.Process.Reduce.Match + ( Match (..) + , MatchT (..) + , emptyMatch + , matchAgain + , matchAgainF + , mapLeftover + , bimapMatch + ) where + +import Data.Semigroup + +-- | The result of successfully matching an input value (or other +-- expression - whatever @a@ is) on a regular value. +data Match a + = Match + { matched :: a -- ^ Part of the value the input matched/consumed. + , leftover :: a -- ^ Part of the value the input didn't match/consume. + } deriving (Functor) + +-- | Turns 'Match' (and 'MatchA') into a transformer. +newtype MatchT u a = MatchT{ runMatchT :: u (Match a) } deriving (Functor) + +instance Applicative Match where + pure x + = Match + { matched = x + , leftover = x + } + f <*> x + = Match + { matched = matched f $ matched x + , leftover = leftover f $ leftover x + } + +instance (Applicative u) => Applicative (MatchT u) where + pure = MatchT . pure . pure + MatchT f <*> MatchT x = MatchT $ (<*>) <$> f <*> x + +-- | A 'Match' with no 'matched' and the given value as 'leftover'. +-- A match with an empty input. +emptyMatch :: (Monoid a) => a -> Match a +emptyMatch x + = Match + { matched = mempty + , leftover = x + } + +-- | Applies the matching function on the old 'leftover', returns a +-- 'Match' with the old and new 'matched' combined and the new 'leftover'. +matchAgain :: (Semigroup a) => (a -> Match a) -> Match a -> Match a +matchAgain f old + = Match + { matched = matched old <> matched new + , leftover = leftover new + } + where new = f $ leftover old + +-- | 'matchAgain' with a side effect. +matchAgainF :: (Semigroup a, Functor w) => (a -> w (Match a)) -> Match a -> w (Match a) +matchAgainF f old = do + new <- f $ leftover old + pure Match + { matched = matched old <> matched new + , leftover = leftover new + } + +-- | Transforms the 'leftover'. +mapLeftover :: (a -> a) -> Match a -> Match a +mapLeftover f x + = Match + { matched = matched x + , leftover = f $ leftover x + } + +-- | Transforms 'matched' with the first function and 'leftover' with +-- the second. +bimapMatch :: (a -> b) -> (a -> b) -> Match a -> Match b +bimapMatch fMatched fLeftover x + = Match + { matched = fMatched $ matched x + , leftover = fLeftover $ leftover x + } diff --git a/src/Descript/BasicInj/Process/Reduce/NoAnn.hs b/src/Descript/BasicInj/Process/Reduce/NoAnn.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Reduce/NoAnn.hs @@ -0,0 +1,720 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Reduction algorithm. +-- +-- Doesn't use or preserve annotations. +module Descript.BasicInj.Process.Reduce.NoAnn + ( interpret + , reducePhase + , reduceReg + ) where + +import Descript.BasicInj.Process.Reduce.PropTrans +import Descript.BasicInj.Process.Reduce.Match +import qualified Descript.BasicInj.Data.Value.Reg as Reg +import qualified Descript.BasicInj.Data.Value.In as In +import qualified Descript.BasicInj.Data.Value.Out as Out +import Descript.BasicInj.Data +import Descript.Misc +import Data.Monoid +import Core.Data.Functor +import Data.Foldable +import Data.Proxy +import Data.Maybe +import Data.List +import Core.Data.List +import Core.Data.List.Assoc hiding (Value) +import qualified Data.List.NonEmpty as NonEmpty +import Control.Monad +import Core.Control.Monad.Trans +import Control.Monad.Trans.Writer +import Prelude hiding (mod) + +class (GenPart p, Eq (p ()), (PartPropVal p ~ GenValue p)) => NormReducePart p where + reducePartProps :: PhaseCtx () -> p () -> p () + +instance NormReducePart Reg.Part where + reducePartProps _ (Reg.PartPrim prim) = Reg.PartPrim prim + reducePartProps ctx (Reg.PartRecord record) + = Reg.PartRecord $ reduceRecordProps ctx record + +reduceInPartProps :: PhaseCtx () + -> In.Part () + -> WriterT PropTranses [] (In.Part ()) +reduceInPartProps _ (In.PartPrim prim) = pure $ In.PartPrim prim +reduceInPartProps _ (In.PartPrimType ptype) = pure $ In.PartPrimType ptype +reduceInPartProps ctx (In.PartRecord record) + = In.PartRecord <$> reduceInRecordProps ctx record + +instance NormReducePart Out.Part where + reducePartProps _ (Out.PartPrim prim) = Out.PartPrim prim + reducePartProps ctx (Out.PartRecord record) + = Out.PartRecord $ reduceOutRecordProps ctx record + reducePartProps _ (Out.PartPropPath path) = Out.PartPropPath path + reducePartProps ctx (Out.PartInjApp app) + = Out.PartInjApp $ reduceInjAppProps ctx app + +reduceRecordProps :: PhaseCtx () -> Reg.Record () -> Reg.Record () +reduceRecordProps = mapPropVals . reduceReg + +reduceInRecordProps :: PhaseCtx () + -> In.Record () + -> WriterT PropTranses [] (In.Record ()) +reduceInRecordProps ctx (Record () head' props) + = Record () head' <$> traverse (reduceInRecordProp ctx head') props + +reduceInRecordProp :: PhaseCtx () + -> FSymbol () + -> In.Property () + -> WriterT PropTranses [] (In.Property ()) +reduceInRecordProp ctx head' (Property () key val) + = Property () key <$> val' + where val' + = censor (subPropTranses pelem) + $ In.traverseOptVal (reduceInput ctx) val + pelem = PathElem () key head' + +reduceOutRecordProps :: PhaseCtx () -> Out.Record () -> Out.Record () +reduceOutRecordProps = mapPropVals . reduceOutput + +reduceInjAppProps :: PhaseCtx () -> Out.InjApp () -> Out.InjApp () +reduceInjAppProps = Out.mapInjAppParams . Out.mapInjParamVal . reduceOutput + +-- | Interprets the program - reduces its query using its reducers. +interpret :: Depd Program () -> Reg.Value () +interpret dprog = reduceReg phase0 qval + where phase0 = reduceAppPhases $ reduceCtx $ dmodule dprog + qval = queryVal $ dquery dprog + +-- | Macro-reduces each of the phases using reducers from the above +-- phase, adding reducers from the above phase along the way, then +-- returns the last phase (which will reduce the query). +reduceAppPhases :: ReduceCtx () -> PhaseCtx () +reduceAppPhases (ReduceCtx () t xs) = foldl' reduceAppPhase t $ NonEmpty.toList xs + +-- | Macro-reduces the second phase using reducers from the first. +-- Then combines the phases. +reduceAppPhase :: PhaseCtx () -> PhaseCtx () -> PhaseCtx () +reduceAppPhase mctx x = mctx <> reducePhase mctx x + +-- | Macro-reduces the second phase using reducers from the first. +reducePhase :: PhaseCtx () -> PhaseCtx () -> PhaseCtx () +reducePhase mctx (PhaseCtx () xs) + = PhaseCtx () $ concatMap (reduceReducer mctx) xs + +-- | Macro-reduces the input and output (ctx is macros). +reduceReducer :: PhaseCtx () -> Reducer () -> [Reducer ()] +reduceReducer ctx (Reducer () input' output') + = reduceReducerOut ctx output' <$> reduceInput' ctx input' + +-- | Continues reducing the output using effects from the reduced input, +-- then creates the reduced reducer. +reduceReducerOut :: PhaseCtx () + -> Out.Value () + -> (In.Value (), PropTranses) + -> Reducer () +reduceReducerOut ctx output' (newIn, outTranses) + = Reducer () newIn newOut + where newOut = reduceOutput ctx $ apPropTranses newIn outTranses output' + +-- | Applies the context's reducers to the value, until they can't +-- be applied anymore. +reduceReg :: PhaseCtx () -> Reg.Value () -> Reg.Value () +reduceReg = reduceNorm + +-- | Applies the context's reducers to the output value, until they +-- can't be applied anymore. +reduceOutput :: PhaseCtx () -> Out.Value () -> Out.Value () +reduceOutput = reduceNorm + +-- | Applies the context's reducers to the value, until they can't be +-- applied anymore. +reduceNorm :: (NormReducePart p) + => PhaseCtx () + -> GenValue p () + -> GenValue p () +reduceNorm ctx = reduceRest reduceNorm ctx . reduceProps ctx + +-- | Applies the context's reducers to the input value, until they can't +-- be applied anymore. +-- +-- This also returns transformers which should be applied to the output. +-- Every time a record in the input matches, the corresponding property +-- in the output is transformed to a union of all the locations of that +-- property in the reducer's output. +reduceInput' :: PhaseCtx () + -> In.Value () + -> [(In.Value (), PropTranses)] +reduceInput' ctx = runWriterT . reduceInput ctx + +reduceInput :: PhaseCtx () + -> In.Value () + -> WriterT PropTranses [] (In.Value ()) +reduceInput ctx = reduceInRest reduceInput ctx <=< reduceInProps ctx + +-- | Applies the context's reducers to the value's properties, +-- until they can't be applied anymore. +reduceProps :: (NormReducePart p) => PhaseCtx () -> GenValue p () -> GenValue p () +reduceProps ctx (Value () parts) + = Value () $ map (reducePartProps ctx) parts + +reduceInProps :: PhaseCtx () + -> In.Value () + -> WriterT PropTranses [] (In.Value ()) +reduceInProps ctx (Value () parts) + = Value () <$> traverse (reduceInPartProps ctx) parts + +-- | Applies the context's reducers to the value's head. +-- If the value reduced, applies the given reducer to reduce it more. +-- Otherwise just returns it as-is. +reduceRest :: (NormReducePart p) + => (PhaseCtx () -> GenValue p () -> GenValue p ()) + -> PhaseCtx () -> GenValue p () -> GenValue p () +reduceRest reduceMore ctx value + = case reduceOnce ctx value of + Failure () -> value + Success next -> reduceMore ctx next + +reduceInRest :: (PhaseCtx () -> In.Value () -> WriterT PropTranses [] (In.Value ())) + -> PhaseCtx () -> In.Value () -> WriterT PropTranses [] (In.Value ()) +reduceInRest reduceInMore ctx value + = mapWriterT continue $ reduceInOnce ctx value + where continue = concatMap (runWriterT . continue') . runResultT + continue' (Failure ()) = pure value + continue' (Success (next, effTrs)) = do + tell effTrs + reduceInMore ctx next + +-- | Applies the context's reducers to the value once, returning a new +-- value if it reduced, or a failure if it couldn't be reduced at all. +reduceOnce :: (NormReducePart p) + => PhaseCtx () + -> GenValue p () + -> UResult (GenValue p ()) +reduceOnce ctx value + | next == value = Failure () + | otherwise = Success next + where next = tryReduceOnce ctx value + +reduceInOnce :: PhaseCtx () + -> In.Value () + -> WriterT PropTranses (ResultT () []) (In.Value ()) +reduceInOnce ctx value + = mapWriterT continue $ tryReduceInOnce ctx value + where continue = ResultT . map continue' + continue' (next, effTrs) + | next == value = Failure () + | otherwise = Success (next, effTrs) + +-- | Applies the context's reducers to the value once. If none of them +-- could be applied (the value didn't reduce), just returns the same value. +tryReduceOnce :: (NormReducePart p) + => PhaseCtx () + -> GenValue p () + -> GenValue p () +tryReduceOnce (PhaseCtx () reducers) value + = foldl' (flip tryReduceIndiv) value reducers + +tryReduceInOnce :: PhaseCtx () + -> In.Value () + -> WriterT PropTranses [] (In.Value ()) +tryReduceInOnce (PhaseCtx () reducers) value + = foldM (flip tryReduceInIndiv) value reducers + +-- | Applies the individual reducer to the value if it can be applied. +-- Otherwise just returns the value. +tryReduceIndiv :: (NormReducePart p) + => Reducer () + -> GenValue p () + -> GenValue p () +tryReduceIndiv reducer value + = case reduceIndiv reducer value of + Failure () -> value + Success next -> next + +tryReduceInIndiv :: Reducer () + -> In.Value () + -> WriterT PropTranses [] (In.Value ()) +tryReduceInIndiv reducer value + = mapWriterT continue $ reduceInIndiv reducer value + where continue = map continue' . runResultT + continue' (Failure ()) = (value, []) + continue' (Success (next, effTrs)) = (next, effTrs) + +-- | Applies the individual reducer to the value if it can be applied. +-- Otherwise returns a failure. +reduceIndiv :: (NormReducePart p) + => Reducer () + -> GenValue p () + -> UResult (GenValue p ()) +reduceIndiv reducer + = fmap (produce $ output reducer) + . consume (input reducer) + +reduceInIndiv :: Reducer () + -> In.Value () + -> WriterT PropTranses (ResultT () []) (In.Value ()) +reduceInIndiv reducer + = WriterT + . fmap (produceIn $ output reducer) + . consumeIn (input reducer) + +-- | Tries to match the input value to the given value. +consume :: (NormReducePart p) + => In.Value () + -> GenValue p () + -> UResult (Match (GenValue p ())) +consume (Value () inParts) value + = foldM (flip consumePartInMatch) (emptyMatch value) inParts + +consumeIn :: In.Value () + -> In.Value () + -> UResultT [] (Match (In.Value ())) +consumeIn (Value () inParts) value + = foldM (flip consumeInPartInMatch) (emptyMatch value) inParts + +consumePartInMatch :: (NormReducePart p) + => In.Part () + -> Match (GenValue p ()) + -> UResult (Match (GenValue p ())) +consumePartInMatch = matchAgainF . consumePartInValue + +consumeInPartInMatch :: In.Part () + -> Match (In.Value ()) + -> UResultT [] (Match (In.Value ())) +consumeInPartInMatch = matchAgainF . consumeInPartInValue + +consumePartInValue :: (NormReducePart p) + => In.Part () + -> GenValue p () + -> UResult (Match (GenValue p ())) +consumePartInValue (In.PartPrim inPrim) (Value () parts) + | inPart `notElem` parts = Failure () + | otherwise + = Success Match + { matched = Value () [inPart] + , leftover = Value () $ inPart `delete` parts + } + where inPart = primToPart Proxy inPrim +consumePartInValue (In.PartPrimType inType) (Value () parts) + = Value () <<$>> consumePrimTypeInParts inType parts +consumePartInValue (In.PartRecord inRec) (Value () parts) + = Value () <<$>> consumeRecordInParts inRec parts + +consumeInPartInValue :: In.Part () + -> In.Value () + -> UResultT [] (Match (In.Value ())) +consumeInPartInValue inPart@(In.PartPrim _) (Value () parts) + | inPart `notElem` parts = mkUFailureT + | otherwise + = mkSuccessT Match + { matched = Value () [inPart] + , leftover = Value () $ inPart `delete` parts + } +consumeInPartInValue (In.PartPrimType inType) (Value () parts) + = hoist $ Value () <<$>> consumePrimTypeInParts inType parts +consumeInPartInValue (In.PartRecord inRec) (Value () parts) + = Value () <<$>> consumeInRecordInParts inRec parts + +consumePrimTypeInParts :: (GenPart p) + => PrimType () + -> [p ()] + -> UResult (Match [p ()]) +consumePrimTypeInParts _ [] = Failure () +consumePrimTypeInParts inType (part : parts) + = case consumePrimTypeInPart inType part of + Failure () + -> mapLeftover (part :) + <$> consumePrimTypeInParts inType parts + Success () + -> Success Match + { matched = [part] + , leftover = parts + } + +consumePrimTypeInPart :: (GenPart p) + => PrimType () + -> p () + -> UResult () +consumePrimTypeInPart inType part + = case partToPrim part of + Nothing -> Failure () + Just prim + | prim `isPrimInstance` inType -> Success () + | otherwise -> Failure () + +consumeRecordInParts :: (NormReducePart p) + => In.Record () + -> [p ()] + -> UResult (Match [p ()]) +consumeRecordInParts _ [] = Failure () +consumeRecordInParts inRec (part : parts) + = case consumeRecordInPart inRec part of + Failure () + -> mapLeftover (part :) + <$> consumeRecordInParts inRec parts + Success (Match partMatch partLeftover) + -> Success Match + { matched = maybeToList partMatch + , leftover = partLeftover ?: parts + } + +consumeInRecordInParts :: In.Record () + -> [In.Part ()] + -> UResultT [] (Match [In.Part ()]) +consumeInRecordInParts _ [] = mkUFailureT +consumeInRecordInParts inRec (part : parts) + = bindStackOuter continue $ consumeInRecordInPart inRec part + where continue (Failure ()) + = mapLeftover (part :) + <$> consumeInRecordInParts inRec parts + continue (Success (Match partMatch partLeftover)) + = mkSuccessT Match + { matched = maybeToList partMatch + , leftover = partLeftover ?: parts + } + +consumeRecordInPart :: (NormReducePart p) + => In.Record () + -> p () + -> UResult (Match (Maybe (p ()))) +consumeRecordInPart inRec part + = case partToRec part of + Nothing -> Failure () + Just record -> recToPart Proxy <<<$>>> consumeRecord inRec record + +consumeInRecordInPart :: In.Record () + -> In.Part () + -> UResultT [] (Match (Maybe (In.Part ()))) +consumeInRecordInPart _ (In.PartPrim _) = mkUFailureT +consumeInRecordInPart _ (In.PartPrimType _) = mkUFailureT +consumeInRecordInPart inRec (In.PartRecord record) + = In.PartRecord <<<$>>> consumeInRecord inRec record + +consumeRecord :: (NormReducePart p) + => In.Record () + -> PartRecord p () + -> UResult (Match (Maybe (PartRecord p ()))) +consumeRecord (Record () inRecHead inRecProps) (Record () recHead recProps) + | inRecHead /= recHead = Failure () + | otherwise + = Record () recHead + <<<$>>> bimapMatch Just justIfNonEmptyList + <$> consumeProperties inRecProps recProps + +consumeInRecord :: In.Record () + -> In.Record () + -> UResultT [] (Match (Maybe (In.Record ()))) +consumeInRecord (Record () inRecHead inRecProps) (Record () recHead recProps) + | inRecHead /= recHead = mkUFailureT + | otherwise + = Record () recHead + <<<$>>> bimapMatch Just justIfNonEmptyList + <$> consumeInProperties inRecProps recProps + +consumeProperties :: (NormReducePart p) + => [In.Property ()] + -> [PartProperty p ()] + -> UResult (Match [PartProperty p ()]) +consumeProperties _ [] = Success $ pure [] +consumeProperties inProps (prop : props) + = case consumePropertiesInProperty inProps prop of + Failure () -> Failure () + Success match + -> addPropValMatch prop match + <$> consumeProperties inProps props + +consumeInProperties :: [In.Property ()] + -> [In.Property ()] + -> UResultT [] (Match [In.Property ()]) +consumeInProperties _ [] = mkSuccessT $ pure [] +consumeInProperties inProps (prop : props) + = bindStackOuter continue $ consumeInPropertiesInProperty inProps prop + where continue (Failure ()) = mkUFailureT + continue (Success match) + = addPropValMatch prop match + <$> consumeInProperties inProps props + +consumePropertiesInProperty :: (NormReducePart p) + => [In.Property ()] + -> PartProperty p () + -> UResult (Match (Maybe (GenValue p ()))) +consumePropertiesInProperty inProps (Property () propKey propVal) + = case glookupForce propKey inProps of + In.NothingValue + -> Success Match + { matched = Just propVal + , leftover = Nothing + } + In.JustValue inPropVal + -> bimapMatch Just justIfNonEmptyVal + <$> consume inPropVal propVal + +consumeInPropertiesInProperty :: [In.Property ()] + -> In.Property () + -> UResultT [] (Match (Maybe (In.OptValue ()))) +consumeInPropertiesInProperty inProps (Property () propKey propVal) + = case glookupForce propKey inProps of + In.NothingValue + -> mkSuccessT Match + { matched = Just propVal + , leftover = Nothing + } + In.JustValue inPropVal + -> bimapMatch Just justIfNonEmptyOptVal + <$> consumeInOpt inPropVal propVal + +consumeInOpt :: In.Value () + -> In.OptValue () + -> UResultT [] (Match (In.OptValue ())) +consumeInOpt _ In.NothingValue = ResultT [Failure ()] +{- Should the case be this instead? + [ -- consumeIn input input + Success Match + { matched = In.JustValue input' + , leftover = mempty -- JustValue $ Value () [] + } + , Failure () + ] +-} +consumeInOpt input' (In.JustValue x) + = In.JustValue <<$>> consumeIn input' x + +addPropValMatch :: GenProperty v () + -> Match (Maybe (v ())) + -> Match [GenProperty v ()] + -> Match [GenProperty v ()] +addPropValMatch (Property () propKey _) propVal props + = (?:) <$> prop <*> props + where prop = Property () propKey <<$>> propVal + +justIfNonEmptyOptVal :: In.OptValue () -> Maybe (In.OptValue ()) +justIfNonEmptyOptVal In.NothingValue = Just In.NothingValue +justIfNonEmptyOptVal (In.JustValue x) = In.JustValue <$> justIfNonEmptyVal x + +justIfNonEmptyVal :: GenValue v () -> Maybe (GenValue v ()) +justIfNonEmptyVal x + | isEmpty x = Nothing + | otherwise = Just x + +justIfNonEmptyList :: [a] -> Maybe [a] +justIfNonEmptyList x + | null x = Nothing + | otherwise = Just x + +-- | Resolves the property paths in the output value using the given +-- value, and combines the result with the given value. +produce :: (NormReducePart p) + => Out.Value () + -> Match (GenValue p ()) + -> GenValue p () +produce output' match + = leftover match <> resolve output' (matched match) + +produceIn :: Out.Value () + -> Match (In.Value ()) + -> (In.Value (), PropTranses) +produceIn output' match + = (produceInMain output' match, transProps output' $ matched match) + +-- | Resolves the property paths in the output value using the given +-- value, and combines the result with the given value. +produceInMain :: Out.Value () -> Match (In.Value ()) -> In.Value () +produceInMain output' match + = leftover match <> resolveIn' output' (matched match) + +-- | Resolves all property paths in the output value using the given value. +-- Replaces all paths with the corresponding properties in the given +-- value. +resolve :: (NormReducePart p) + => Out.Value () + -> GenValue p () + -> GenValue p () +resolve (Value () outParts) value + = mconcat $ map resolvePart outParts + where resolvePart (Out.PartPrim prim) + = singletonValue $ primToPart Proxy prim + resolvePart (Out.PartRecord record) + = singletonValue + $ recToPart Proxy + $ mapPropVals (`resolve` value) + record + resolvePart (Out.PartPropPath path) = resolvePropPath path value + resolvePart (Out.PartInjApp app) = resolveInjApp app value + +resolveIn' :: Out.Value () -> In.Value () -> In.Value () +resolveIn' output' value + = case resolveIn output' $ In.JustValue value of + In.NothingValue -> error "Bad macro - reduces input to free bind" + In.JustValue x -> x + +resolveIn :: Out.Value () + -> In.OptValue () + -> In.OptValue () +resolveIn (Value () outParts) value + = mconcat $ map resolvePart outParts + where resolvePart (Out.PartPrim prim) + = In.JustValue $ singletonValue $ primToPart Proxy prim + resolvePart (Out.PartRecord record) + = In.JustValue + $ singletonValue + $ recToPart Proxy + $ mapPropVals (`resolveIn` value) + record + resolvePart (Out.PartPropPath path) = resolveInPropPath path value + resolvePart (Out.PartInjApp app) = In.JustValue $ resolveInInjApp app value + +-- | Resolves the property path using the given value. +-- Replaces it with the corresponding property in the given value. +resolvePropPath :: (NormReducePart p) + => PropPath () + -> GenValue p () + -> GenValue p () +resolvePropPath (PropPath () xs) = resolveSubpath $ NonEmpty.toList xs + +resolveInPropPath :: PropPath () + -> In.OptValue () + -> In.OptValue () +resolveInPropPath (PropPath () xs) = resolveInSubpath $ NonEmpty.toList xs + +resolveSubpath :: (NormReducePart p) + => [PathElem ()] + -> GenValue p () + -> GenValue p () +resolveSubpath [] = id +resolveSubpath (x : xs) = resolveSubpath xs . resolveElem x + +resolveInSubpath :: [PathElem ()] + -> In.OptValue () + -> In.OptValue () +resolveInSubpath [] = id +resolveInSubpath (x : xs) = resolveInSubpath xs . resolveInElem x + +resolveElem :: (NormReducePart p) + => PathElem () + -> GenValue p () + -> GenValue p () +resolveElem (PathElem () keyRef' headRef') + = forceLookupProp keyRef' . forceRecWithHead headRef' + +resolveInElem :: PathElem () + -> In.OptValue () + -> In.OptValue () +resolveInElem _ In.NothingValue + = error "Bad macro - references property of free bind" +resolveInElem (PathElem () keyRef' headRef') (In.JustValue val) + = forceLookupProp keyRef' $ forceRecWithHead headRef' val + +-- | Finds the injected function, resolves the arguments, then applies +-- the function with every possible primitive combination until it +-- returns a result. +resolveInjApp :: (NormReducePart p) + => Out.InjApp () + -> GenValue p () + -> GenValue p () +resolveInjApp app x = applyInj func params + where func = forceLookupFunc $ Out.funcId app + params = map ((`resolve` x) . Out.injParamVal) $ Out.params app + +resolveInInjApp :: Out.InjApp () + -> In.OptValue () + -> In.Value () +resolveInInjApp app x = applyInj func params + where func = forceLookupFunc $ Out.funcId app + params + = mapMaybe (In.optValToMaybeVal . (`resolveIn` x) . Out.injParamVal) + $ Out.params app + +-- Applies the function with every possible primitive combination given +-- the arguments until it returns a result. Fails if no combinations work. +applyInj :: (GenPart p) => InjFunc -> [GenValue p ()] -> GenValue p () +applyInj func params + = case tryApplyInj func params of + Failure () -> error "Injected function couldn't be applied to parameters" + Success out -> out + +-- Applies the function with every possible primitive combination given +-- the arguments until it returns a result. +tryApplyInj :: (GenPart p) + => InjFunc + -> [GenValue p ()] + -> UResult (GenValue p ()) +tryApplyInj = applyInjUsing [] + +applyInjUsing :: (GenPart p) + => [Prim ()] + -> InjFunc + -> [GenValue p ()] + -> UResult (GenValue p ()) +applyInjUsing revSelParams func [] + = case func selParams of + Nothing -> Failure () + Just out -> Success $ singletonValue $ primToPart Proxy out + where selParams = reverse revSelParams +applyInjUsing revSelParams func (nextParam : restParams) + = asum $ map applyInjUsingNext $ primParts nextParam + where applyInjUsingNext nextSelParam = applyInjUsing (nextSelParam : revSelParams) func restParams + +transProps :: Out.Value () -> In.Value () -> PropTranses +transProps output' = map (`transPath` output') . pathsInVal + +pathsInVal :: In.Value () -> [PropPath ()] +pathsInVal (Value () parts) = concatMap pathsInPart parts + +pathsInPart :: In.Part () -> [PropPath ()] +pathsInPart (In.PartPrim _) = [] +pathsInPart (In.PartPrimType _) = [] +pathsInPart (In.PartRecord record) = pathsInRecord record + +pathsInRecord :: In.Record () -> [PropPath ()] +pathsInRecord (Record () head' props) = concatMap (pathsInProp head') props + +pathsInProp :: FSymbol () + -> In.Property () + -> [PropPath ()] +pathsInProp head' (Property () key val) + = immPath elem' : map (subPath elem') (pathsInOptVal val) + where elem' = PathElem () key head' + +pathsInOptVal :: In.OptValue () -> [PropPath ()] +pathsInOptVal In.NothingValue = [] +pathsInOptVal (In.JustValue x) = pathsInVal x + +transPath :: PropPath () -> Out.Value () -> PropTrans +transPath inPath = PropTrans inPath . transOutsInVal inPath + +transOutsInVal :: PropPath () -> Out.Value () -> [SubPropPath ()] +transOutsInVal inPath (Value () parts) = concatMap (transOutsInPart inPath) parts + +transOutsInPart :: PropPath () -> Out.Part () -> [SubPropPath ()] +transOutsInPart _ (Out.PartPrim _) = [] +transOutsInPart inPath (Out.PartRecord record) + = transOutsInRecord inPath record +transOutsInPart inPath (Out.PartPropPath path) + = transOutsInPath inPath path +transOutsInPart inPath (Out.PartInjApp app) + = transOutsInInjApp inPath app + +transOutsInRecord :: PropPath () -> Out.Record () -> [SubPropPath ()] +transOutsInRecord inPath (Record () head' props) + = concatMap (transOutsInProp inPath head') props + +transOutsInProp :: PropPath () -> FSymbol () -> Out.Property () -> [SubPropPath ()] +transOutsInProp inPath head' (Property () key val) + = map (elem' :) $ transOutsInVal inPath val + where elem' = PathElem () key head' + +-- | Name is misleading out of context - the old property path will +-- transform into the location of this property path if both paths are +-- equal. +transOutsInPath :: PropPath () -> PropPath () -> [SubPropPath ()] +transOutsInPath inPath path + | inPath == path = [[]] + | otherwise = [] + +transOutsInInjApp :: PropPath () -> Out.InjApp () -> [SubPropPath ()] +transOutsInInjApp _ _ + = error "Macros deconstructing injected applications is unsupported. \ + \Wrap the injected application in a regular record, then \ + \deconstruct that record instead." diff --git a/src/Descript/BasicInj/Process/Reduce/PropTrans.hs b/src/Descript/BasicInj/Process/Reduce/PropTrans.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Reduce/PropTrans.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} + +module Descript.BasicInj.Process.Reduce.PropTrans + ( PropTranses + , PropTrans (..) + , apPropTranses + , subPropTranses + ) where + +import qualified Descript.BasicInj.Data.Value.In as In +import qualified Descript.BasicInj.Data.Value.Out as Out +import Descript.BasicInj.Data +import Descript.Misc +import Data.Maybe +import Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import Control.Applicative + +-- | Replaces properties within a value. +type PropTranses = [PropTrans] + +-- | Replaces every occurrence of a property path with a union of the +-- new subpaths. If a subpath is empty, it's replaced by the entire +-- input value with immediate properties. +data PropTrans + = PropTrans + { propTransOld :: PropPath () + , propTransNews :: [SubPropPath ()] + } deriving (Show) + +-- | Merges the transformations, then applies them all. +apPropTranses :: (TaintAnn an) + => In.Value () + -> PropTranses + -> Out.Value an + -> Out.Value an +apPropTranses in' transes x + = foldl' (flip $ apPropTrans in') x $ mergeTranses transes + +-- | Adds outputs from more general transes to more specific ones. +-- For example: +-- +-- >>> mergeTranses ['a>c>d -> ', 'a -> z', 'a>b -> y'] +-- ['a>c>d -> z>c>d', 'a -> z', 'a>b -> y | z>b'] +mergeTranses :: PropTranses -> PropTranses +mergeTranses = foldl' (flip mergeAddTrans) [] + +-- | Adds outputs from more general transes to the new trans, and adds +-- outputs from the new trans to more specific ones. +mergeAddTrans :: PropTrans -> PropTranses -> PropTranses +mergeAddTrans x [] = [x] +mergeAddTrans x (y : ys) = y' : mergeAddTrans x' ys + where (x', y') = tryMergeTrans x y + +-- | If one of the transes is a prefix of the other, returns both so +-- the longer one has the smaller one's outputs. Otherwise returns both +-- unaffected. +tryMergeTrans :: PropTrans -> PropTrans -> (PropTrans, PropTrans) +tryMergeTrans x y = (x, y) `fromMaybe` mergeTrans x y + +-- | If one of the transes is a prefix of the other, returns both so +-- the longer one has the smaller one's outputs. +mergeTrans :: PropTrans -> PropTrans -> Maybe (PropTrans, PropTrans) +mergeTrans x y + = (x, ) <$> mergeTrans1Way x y + <|> (, y) <$> mergeTrans1Way y x + +-- | If the first transes is a prefix of the second, returns the second +-- so it includes the first. Otherwise returns 'Nothing'. +mergeTrans1Way :: PropTrans -> PropTrans -> Maybe PropTrans +mergeTrans1Way (PropTrans xOld xNews) (PropTrans yOld yNews) + = case xOld `stripPrefixPath` yOld of + Nothing -> Nothing + Just yRest -> Just $ PropTrans yOld $ yNews ++ xNews' + where xNews' = map (++ yRest) xNews + +{- + = case old `stripPrefixPath` path_ of + Nothing -> singletonValue $ Out.PartPropPath path + Just suf_ -> ann' <$ mconcat (map (subPathVal in' . (++ suf_)) news) + where path_ = remAnns path + ann' = taint $ getAnn path +-} + +-- | Assumes there is a transformation for every reasonable path, and +-- the transformations were all merged (more general transformation +-- outputs, specified, were added to more specific outputs). +apPropTrans :: (TaintAnn an) + => In.Value () + -> PropTrans + -> Out.Value an + -> Out.Value an +apPropTrans in' trans (Value ann parts) + = reconValue ann parts $ map (apPropTransToPart in' trans) parts + +apPropTransToPart :: (TaintAnn an) + => In.Value () + -> PropTrans + -> Out.Part an + -> Out.Value an +apPropTransToPart _ _ (Out.PartPrim prim) = singletonValue $ Out.PartPrim prim +apPropTransToPart in' trans (Out.PartRecord record) + = singletonValue $ Out.PartRecord $ apPropTransToRecord in' trans record +apPropTransToPart in' trans (Out.PartPropPath path) + = apPropTransToPath in' trans path +apPropTransToPart in' trans (Out.PartInjApp app) + = singletonValue $ Out.PartInjApp $ apPropTransToInjApp in' trans app + +apPropTransToRecord :: (TaintAnn an) + => In.Value () + -> PropTrans + -> Out.Record an + -> Out.Record an +apPropTransToRecord in' trans (Record ann head' props) + -- No need for reRecord because prop counts, and thus annotation, will + -- always stay the same. + = Record ann head' $ map (apPropTransToProp in' trans) props + +apPropTransToProp :: (TaintAnn an) + => In.Value () + -> PropTrans + -> Out.Property an + -> Out.Property an +apPropTransToProp in' trans (Property ann key val) + -- No need for reProperty because value printability, and thus + -- annotation, will always stay the same. + = Property ann key $ apPropTrans in' trans val + +apPropTransToInjApp :: (TaintAnn an) + => In.Value () + -> PropTrans + -> Out.InjApp an + -> Out.InjApp an +apPropTransToInjApp in' trans (Out.InjApp ann funcId' params') + = Out.InjApp ann funcId' $ map (apPropTransToInjParam in' trans) params' + +apPropTransToInjParam :: (TaintAnn an) + => In.Value () + -> PropTrans + -> Out.InjParam an + -> Out.InjParam an +apPropTransToInjParam in' trans (Out.InjParam ann val) + = Out.InjParam ann $ apPropTrans in' trans val + +apPropTransToPath :: (TaintAnn an) + => In.Value () + -> PropTrans + -> PropPath an + -> Out.Value an +apPropTransToPath in' (PropTrans old news) path +-- Assumes there is a transformation for every reasonable path, and the +-- transformations were all merged. Otherwise would need to check prefix +-- instead of full path. + | path /@= old = singletonValue $ Out.PartPropPath path + | otherwise = ann' <$ mconcat (map (subPathVal in') news) + where ann' = taint $ getAnn path + +-- | An output value which refers to the given sub-path, given the +-- corresponding input. If the sub-path is empty, the value will refer +-- to the entire input (via 'fullOut'). Otherwise it will just contain a +-- single property path. +subPathVal :: In.Value () -> SubPropPath () -> Out.Value () +subPathVal in' [] = fullOut in' +subPathVal _ (x : xs) = singletonValue $ Out.PartPropPath $ PropPath () $ x :| xs + +-- | This output will re-produce everything which was consumed by the +-- input. It's semantically equivalent to an empty property path, but +-- those don't exist. Note that a top-level primitive type has no full +-- output (you can't re-produce it), so that will raise an error. +fullOut :: In.Value () -> Out.Value () +fullOut (Value () parts) = Value () $ map fullOutPart parts + +fullOutPart :: In.Part () -> Out.Part () +fullOutPart (In.PartPrim prim) = Out.PartPrim prim +fullOutPart (In.PartPrimType _) + = error "Top-level primitive type has no full output - you can't \ + \reproduce it in an output value, because it's not a single \ + \value and it doesn't correspond to a property path." +fullOutPart (In.PartRecord record) = Out.PartRecord $ fullOutRecord record + +fullOutRecord :: In.Record () -> Out.Record () +fullOutRecord (Record () head' props) + = Record () head' $ map (fullOutProp head') props + +fullOutProp :: FSymbol () -> In.Property () -> Out.Property () +fullOutProp head' (Property () key _) = Property () key $ Out.immPathVal elem' + where elem' = PathElem () key head' + +-- | Prepends the element to all property paths in all transformations. +subPropTranses :: PathElem () -> PropTranses -> PropTranses +subPropTranses = map . subPropTrans + +-- | Prepends the element to the input and all output paths. +subPropTrans :: PathElem () -> PropTrans -> PropTrans +subPropTrans x (PropTrans old news) + = PropTrans + { propTransOld = subPath x old + , propTransNews = map (x :) news + } diff --git a/src/Descript/BasicInj/Process/Reduce/SrcAnn.hs b/src/Descript/BasicInj/Process/Reduce/SrcAnn.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Reduce/SrcAnn.hs @@ -0,0 +1,709 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Reduction algorithm. +-- +-- Preserves ranges and taints affected values. +module Descript.BasicInj.Process.Reduce.SrcAnn + ( interpret + , reducePhase + , reduceReg + ) where + +import Descript.BasicInj.Process.Reduce.PropTrans +import Descript.BasicInj.Process.Reduce.Match +import qualified Descript.BasicInj.Data.Value.Reg as Reg +import qualified Descript.BasicInj.Data.Value.In as In +import qualified Descript.BasicInj.Data.Value.Out as Out +import Descript.BasicInj.Data +import Descript.Misc +import Data.Monoid +import Core.Data.Functor +import Data.Functor.Identity +import Data.Foldable +import Data.Proxy +import Data.Maybe +import Core.Data.List +import Core.Data.List.Assoc hiding (Value) +import qualified Data.List.NonEmpty as NonEmpty +import Control.Monad +import Control.Monad.Trans.Writer + +-- | Interprets the program - reduces its query using its reducers. +interpret :: (TaintAnn an) => Depd Program an -> Reg.Value an +interpret dprog = reduceReg phase0 qval + where phase0 = reduceAppPhases $ reduceCtx $ dmodule dprog + qval = queryVal $ dquery dprog + +-- | Macro-reduces each of the phases using reducers from the above +-- phase, adding reducers from the above phase along the way, then +-- returns the last phase (which will reduce the query). +reduceAppPhases :: ReduceCtx () -> PhaseCtx () +reduceAppPhases (ReduceCtx () t xs) = foldl' reduceAppPhase t $ NonEmpty.toList xs + +-- | Macro-reduces the second phase using reducers from the first. +-- Then combines the phases. +reduceAppPhase :: PhaseCtx () -> PhaseCtx () -> PhaseCtx () +reduceAppPhase mctx x = mctx <> reducePhase mctx x + +-- | Macro-reduces the second phase using reducers from the first. +reducePhase :: (TaintAnn an) => PhaseCtx () -> PhaseCtx an -> PhaseCtx an +reducePhase mctx (PhaseCtx ann xs) + = PhaseCtx ann $ map (reduceReducer mctx) xs + +-- | Macro-reduces the input and output (ctx is macros). +reduceReducer :: (TaintAnn an) => PhaseCtx () -> Reducer an -> Reducer an +reduceReducer ctx (Reducer ann input' output') + = reduceReducerOut ctx ann (reduceInput' ctx input') output' + +-- | Continues reducing the output using effects from the reduced input, +-- then creates the reduced reducer. +reduceReducerOut :: (TaintAnn an) + => PhaseCtx () + -> an + -> (In.Value an, PropTranses) + -> Out.Value an + -> Reducer an +reduceReducerOut ctx ann (newIn, outTranses) output' + = Reducer ann newIn newOut + where newOut = reduceOutput ctx $ apPropTranses newIn_ outTranses output' + newIn_ = remAnns newIn + +-- | Applies the context's reducers to the value, until they can't +-- be applied anymore. +reduceReg :: (TaintAnn an) + => PhaseCtx () + -> Reg.Value an + -> Reg.Value an +reduceReg = reduceNorm + +-- | Applies the context's reducers to the output value, until they +-- can't be applied anymore. +reduceOutput :: (TaintAnn an) + => PhaseCtx () + -> Out.Value an + -> Out.Value an +reduceOutput = reduceNorm + +-- | Applies the context's reducers to the value, until they can't be +-- applied anymore. +reduceNorm :: (NormReducePart p, TaintAnn an) + => PhaseCtx () + -> GenValue p an + -> GenValue p an +reduceNorm ctx = reduceRest reduceNorm ctx . reduceProps ctx + +-- | Applies the context's reducers to the input value, until they can't +-- be applied anymore. +-- +-- This also returns transformers which should be applied to the output. +-- Every time a record in the input matches, the corresponding property +-- in the output is transformed to a union of all the locations of that +-- property in the reducer's output. +reduceInput' :: (TaintAnn an) + => PhaseCtx () + -> In.Value an + -> (In.Value an, PropTranses) +reduceInput' ctx = runWriter . reduceInput ctx + +reduceInput :: (TaintAnn an) + => PhaseCtx () + -> In.Value an + -> Writer PropTranses (In.Value an) +reduceInput ctx = reduceInRest reduceInput ctx <=< reduceInProps ctx + +-- | Applies the context's reducers to the value's properties, +-- until they can't be applied anymore. +reduceProps :: (NormReducePart p, TaintAnn an) + => PhaseCtx () + -> GenValue p an + -> GenValue p an +reduceProps ctx (Value ann parts) + = Value ann $ map (reducePartProps ctx) parts + +reduceInProps :: (TaintAnn an) + => PhaseCtx () + -> In.Value an + -> Writer PropTranses (In.Value an) +reduceInProps ctx (Value ann parts) + = Value ann <$> traverse (reduceInPartProps ctx) parts + +class (ReducePart p, (PartPropVal p ~ GenValue p)) => NormReducePart p where + reducePartProps :: (TaintAnn an) => PhaseCtx () -> p an -> p an + +instance NormReducePart Reg.Part where + reducePartProps _ (Reg.PartPrim prim) = Reg.PartPrim prim + reducePartProps ctx (Reg.PartRecord record) + = Reg.PartRecord $ reduceRecordProps ctx record + +reduceInPartProps :: (TaintAnn an) + => PhaseCtx () + -> In.Part an + -> Writer PropTranses (In.Part an) +reduceInPartProps _ (In.PartPrim prim) = pure $ In.PartPrim prim +reduceInPartProps _ (In.PartPrimType ptype) = pure $ In.PartPrimType ptype +reduceInPartProps ctx (In.PartRecord record) + = In.PartRecord <$> reduceInRecordProps ctx record + +instance NormReducePart Out.Part where + reducePartProps _ (Out.PartPrim prim) = Out.PartPrim prim + reducePartProps ctx (Out.PartRecord record) + = Out.PartRecord $ reduceOutRecordProps ctx record + reducePartProps _ (Out.PartPropPath path) = Out.PartPropPath path + reducePartProps ctx (Out.PartInjApp app) + = Out.PartInjApp $ reduceInjAppProps ctx app + +reduceRecordProps :: (TaintAnn an) + => PhaseCtx () + -> Reg.Record an + -> Reg.Record an +reduceRecordProps = mapPropVals . reduceReg + +reduceInRecordProps :: (TaintAnn an) + => PhaseCtx () + -> In.Record an + -> Writer PropTranses (In.Record an) +reduceInRecordProps ctx (Record ann head' props) + = Record ann head' <$> traverse (reduceInRecordProp ctx head_) props + where head_ = remAnns head' + +reduceInRecordProp :: (TaintAnn an) + => PhaseCtx () + -> FSymbol () + -> In.Property an + -> Writer PropTranses (In.Property an) +reduceInRecordProp ctx head_ (Property ann key val) + = Property ann key <$> val' + where val' + = censor (subPropTranses pelem) + $ In.traverseOptVal (reduceInput ctx) val + pelem = PathElem () key_ head_ + key_ = remAnns key + +reduceOutRecordProps :: (TaintAnn an) + => PhaseCtx () + -> Out.Record an + -> Out.Record an +reduceOutRecordProps = mapPropVals . reduceOutput + +reduceInjAppProps :: (TaintAnn an) + => PhaseCtx () + -> Out.InjApp an + -> Out.InjApp an +reduceInjAppProps = Out.mapInjAppParams . Out.mapInjParamVal . reduceOutput + +-- | Applies the context's reducers to the value's head. +-- If the value reduced, applies the given reducer to reduce it more. +-- Otherwise just returns it as-is. +reduceRest :: (NormReducePart p, TaintAnn an) + => (PhaseCtx () -> GenValue p an -> GenValue p an) + -> PhaseCtx () -> GenValue p an -> GenValue p an +reduceRest reduceMore ctx value + = case reduceOnce ctx value of + Failure () -> value + Success next -> reduceMore ctx next + +reduceInRest :: (TaintAnn an) + => (PhaseCtx () -> In.Value an -> Writer PropTranses (In.Value an)) + -> PhaseCtx () -> In.Value an -> Writer PropTranses (In.Value an) +reduceInRest reduceInMore ctx value + = mapWriterT continue $ reduceInOnce ctx value + where continue = runWriterT . continue' + continue' (Failure ()) = pure value + continue' (Success (next, effTrs)) = do + tell effTrs + reduceInMore ctx next + +-- | Applies the context's reducers to the value once, returning a new +-- value if it reduced, or a failure if it couldn't be reduced at all. +reduceOnce :: (NormReducePart p, TaintAnn an) + => PhaseCtx () + -> GenValue p an + -> UResult (GenValue p an) +reduceOnce ctx value + | next =@= value = Failure () + | otherwise = Success next + where next = tryReduceOnce ctx value + +reduceInOnce :: (TaintAnn an) + => PhaseCtx () + -> In.Value an + -> WriterT PropTranses (Result ()) (In.Value an) +reduceInOnce ctx value + = mapWriterT continue $ tryReduceInOnce ctx value + where continue = continue' . runIdentity + continue' (next, effTrs) + | next =@= value = Failure () + | otherwise = Success (next, effTrs) + +-- | Applies the context's reducers to the value once. If none of them +-- could be applied (the value didn't reduce), just returns the same value. +tryReduceOnce :: (NormReducePart p, TaintAnn an) + => PhaseCtx () + -> GenValue p an + -> GenValue p an +tryReduceOnce (PhaseCtx () reducers) value + = foldl' (flip tryReduceIndiv) value reducers + +tryReduceInOnce :: (TaintAnn an) + => PhaseCtx () + -> In.Value an + -> Writer PropTranses (In.Value an) +tryReduceInOnce (PhaseCtx () reducers) value + = foldM (flip tryReduceInIndiv) value reducers + +-- | Applies the individual reducer to the value if it can be applied. +-- Otherwise just returns the value. +tryReduceIndiv :: (NormReducePart p, TaintAnn an) + => Reducer () + -> GenValue p an + -> GenValue p an +tryReduceIndiv reducer value + = case reduceIndiv reducer value of + Failure () -> value + Success next -> next + +tryReduceInIndiv :: (TaintAnn an) + => Reducer () + -> In.Value an + -> Writer PropTranses (In.Value an) +tryReduceInIndiv reducer value + = mapWriterT continue $ reduceInIndiv reducer value + where continue = Identity . continue' + continue' (Failure ()) = (value, []) + continue' (Success (next, effTrs)) = (next, effTrs) + +-- | Applies the individual reducer to the value if it can be applied. +-- Otherwise returns a failure. +reduceIndiv :: (NormReducePart p, TaintAnn an) + => Reducer () + -> GenValue p an + -> UResult (GenValue p an) +reduceIndiv reducer + = fmap (produce $ output reducer) + . consume (input reducer) + +reduceInIndiv :: (TaintAnn an) + => Reducer () + -> In.Value an + -> WriterT PropTranses (Result ()) (In.Value an) +reduceInIndiv reducer + = WriterT + . fmap (produceIn $ output reducer) + . consume (input reducer) + +-- | Tries to match the input value to the given value. +consume :: (ReducePart p, TaintAnn an) + => In.Value () + -> GenValue p an + -> UResult (Match (GenValue p an)) +consume (Value () inParts) value + = foldM (flip consumePartInMatch) (emptyValMatch value) inParts + +emptyValMatch :: (Ann v, TaintAnn an) + => GenValue v an + -> Match (GenValue v an) +emptyValMatch x + = Match + { matched = Value (taint $ postInsertAnn $ getAnn x) [] + , leftover = x + } + +consumePartInMatch :: (ReducePart p, TaintAnn an) + => In.Part () + -> Match (GenValue p an) + -> UResult (Match (GenValue p an)) +consumePartInMatch = matchAgainF . consumePartInValue + +consumePartInValue :: (ReducePart p, TaintAnn an) + => In.Part () + -> GenValue p an + -> UResult (Match (GenValue p an)) +consumePartInValue (In.PartPrim inPrim) (Value ann parts) + = reValue ann parts <<$>> consumePrimInParts inPrim parts +consumePartInValue (In.PartPrimType inType) (Value ann parts) + = reValue ann parts <<$>> consumePrimTypeInParts inType parts +consumePartInValue (In.PartRecord inRec) (Value ann parts) + = reValue ann parts <<$>> consumeRecordInParts inRec parts + +consumePrimInParts :: (ReducePart p, TaintAnn an) + => Prim () + -> [p an] + -> UResult (Match [p an]) +consumePrimInParts _ [] = Failure () +consumePrimInParts inPrim (part : parts) + | inPart /@= part + = mapLeftover (part :) <$> consumePrimInParts inPrim parts + | otherwise + = Success Match + { matched = [part] + , leftover = parts + } + where inPart = primToPart Proxy inPrim + +consumePrimTypeInParts :: (ReducePart p, TaintAnn an) + => PrimType () + -> [p an] + -> UResult (Match [p an]) +consumePrimTypeInParts _ [] = Failure () +consumePrimTypeInParts inType (part : parts) + = case consumePrimTypeInPart inType part of + Failure () + -> mapLeftover (part :) + <$> consumePrimTypeInParts inType parts + Success () + -> Success Match + { matched = [part] + , leftover = parts + } + +consumePrimTypeInPart :: (ReducePart p, TaintAnn an) + => PrimType () + -> p an + -> UResult () +consumePrimTypeInPart inType part + = case partToPrim part of + Nothing -> Failure () + Just prim + | prim `isPrimInstance` inType -> Success () + | otherwise -> Failure () + +consumeRecordInParts :: (ReducePart p, TaintAnn an) + => In.Record () + -> [p an] + -> UResult (Match [p an]) +consumeRecordInParts _ [] = Failure () +consumeRecordInParts inRec (part : parts) + = case consumeRecordInPart inRec part of + Failure () + -> mapLeftover (part :) + <$> consumeRecordInParts inRec parts + Success (Match partMatch partLeftover) + -> Success Match + { matched = maybeToList partMatch + , leftover = partLeftover ?: parts + } + +consumeRecordInPart :: (ReducePart p, TaintAnn an) + => In.Record () + -> p an + -> UResult (Match (Maybe (p an))) +consumeRecordInPart inRec part + = case partToRec part of + Nothing -> Failure () + Just record -> recToPart Proxy <<<$>>> consumeRecord inRec record + +class (GenPart p, ReducePropVal (PartPropVal p)) => ReducePart p where + +instance ReducePart Reg.Part +instance ReducePart In.Part +instance ReducePart Out.Part + +consumeRecord :: (ReducePropVal v, TaintAnn an) + => In.Record () + -> GenRecord v an + -> UResult (Match (Maybe (GenRecord v an))) +consumeRecord (Record () inRecHead inRecProps) (Record ann recHead recProps) + | inRecHead /@= recHead = Failure () + | otherwise + = reRecord ann recHead recProps + <<<$>>> bimapMatch Just justIfNonEmptyList + <$> consumeProperties inRecProps recProps + +consumeProperties :: (ReducePropVal v, TaintAnn an) + => [In.Property ()] + -> [GenProperty v an] + -> UResult (Match [GenProperty v an]) +consumeProperties _ [] = Success $ pure [] +consumeProperties inProps (prop : props) + = case consumePropertiesInProperty inProps prop of + Failure () -> Failure () + Success match + -> addPropValMatch prop match + <$> consumeProperties inProps props + +consumePropertiesInProperty :: (ReducePropVal v, TaintAnn an) + => [In.Property ()] + -> GenProperty v an + -> UResult (Match (Maybe (v an))) +consumePropertiesInProperty inProps (Property _ propKey propVal) + = case glookupForce propKey_ inProps of + In.NothingValue + -> Success Match + { matched = Just propVal + , leftover = Nothing + } + In.JustValue inPropVal + -> bimapMatch Just justIfNonEmptyPropVal + <$> consumePropVal inPropVal propVal + where propKey_ = remAnns propKey + +addPropValMatch :: (GenPropVal v, TaintAnn an) + => GenProperty v an + -> Match (Maybe (v an)) + -> Match [GenProperty v an] + -> Match [GenProperty v an] +addPropValMatch (Property ann propKey oldPropVal) newPropVal props + = (?:) <$> prop <*> props + where prop = reProperty ann propKey oldPropVal <<$>> newPropVal + +class (GenPropVal v) => ReducePropVal v where + consumePropVal :: (TaintAnn an) + => In.Value () + -> v an + -> UResult (Match (v an)) + justIfNonEmptyPropVal :: v an -> Maybe (v an) + +instance (ReducePart p) => ReducePropVal (GenValue p) where + consumePropVal = consume + justIfNonEmptyPropVal = justIfNonEmptyVal + +instance ReducePropVal In.OptValue where + consumePropVal = consumeOptVal + justIfNonEmptyPropVal = justIfNonEmptyOptVal + +consumeOptVal :: (TaintAnn an) + => In.Value () + -> In.OptValue an + -> UResult (Match (In.OptValue an)) +consumeOptVal _ In.NothingValue = Failure () +consumeOptVal input' (In.JustValue x) + = In.JustValue <<$>> consume input' x + +justIfNonEmptyOptVal :: In.OptValue an -> Maybe (In.OptValue an) +justIfNonEmptyOptVal In.NothingValue = Just In.NothingValue +justIfNonEmptyOptVal (In.JustValue x) = In.JustValue <$> justIfNonEmptyVal x + +justIfNonEmptyVal :: GenValue v an -> Maybe (GenValue v an) +justIfNonEmptyVal x + | isEmpty x = Nothing + | otherwise = Just x + +justIfNonEmptyList :: [a] -> Maybe [a] +justIfNonEmptyList x + | null x = Nothing + | otherwise = Just x + +-- | Resolves the property paths in the output value using the given +-- value, and combines the result with the given value. +produce :: (TaintAnn an) + => (NormReducePart p) + => Out.Value () + -> Match (GenValue p an) + -> GenValue p an +produce output' (Match matched' leftover') + = leftover' `appGend` resolve output' matched_ + where matched_ = remAnns matched' + +produceIn :: (TaintAnn an) + => Out.Value () + -> Match (In.Value an) + -> (In.Value an, PropTranses) +produceIn output' match + = (produceInMain output' match, transProps output' matched_) + where matched_ = remAnns $ matched match + +-- | Resolves the property paths in the output value using the given +-- value, and combines the result with the given value. +produceInMain :: (TaintAnn an) + => Out.Value () + -> Match (In.Value an) + -> In.Value an +produceInMain output' (Match matched' leftover') + = leftover' `appGend` resolveIn' output' matched_ + where matched_ = remAnns matched' + +-- | Resolves all property paths in the output value using the given value. +-- Replaces all paths with the corresponding properties in the given +-- value. +resolve :: (NormReducePart p) + => Out.Value () + -> GenValue p () + -> GenValue p () +resolve (Value () outParts) value + = mconcat $ map resolvePart outParts + where resolvePart (Out.PartPrim prim) + = singletonValue $ primToPart Proxy prim + resolvePart (Out.PartRecord record) + = singletonValue + $ recToPart Proxy + $ mapPropVals (`resolve` value) + record + resolvePart (Out.PartPropPath path) = resolvePropPath path value + resolvePart (Out.PartInjApp app) = resolveInjApp app value + +resolveIn' :: Out.Value () -> In.Value () -> In.Value () +resolveIn' output' value + = case resolveIn output' $ In.JustValue value of + In.NothingValue -> error "Bad macro - reduces input to free bind" + In.JustValue x -> x + +resolveIn :: Out.Value () + -> In.OptValue () + -> In.OptValue () +resolveIn (Value () outParts) value + = mconcat $ map resolvePart outParts + where resolvePart (Out.PartPrim prim) + = In.JustValue $ singletonValue $ primToPart Proxy prim + resolvePart (Out.PartRecord record) + = In.JustValue + $ singletonValue + $ recToPart Proxy + $ mapPropVals (`resolveIn` value) + record + resolvePart (Out.PartPropPath path) = resolveInPropPath path value + resolvePart (Out.PartInjApp app) = In.JustValue $ resolveInInjApp app value + +-- | Resolves the property path using the given value. +-- Replaces it with the corresponding property in the given value. +resolvePropPath :: (NormReducePart p) + => PropPath () + -> GenValue p () + -> GenValue p () +resolvePropPath (PropPath () xs) = resolveSubpath $ NonEmpty.toList xs + +resolveInPropPath :: PropPath () + -> In.OptValue () + -> In.OptValue () +resolveInPropPath (PropPath () xs) = resolveInSubpath $ NonEmpty.toList xs + +resolveSubpath :: (NormReducePart p) + => [PathElem ()] + -> GenValue p () + -> GenValue p () +resolveSubpath [] = id +resolveSubpath (x : xs) = resolveSubpath xs . resolveElem x + +resolveInSubpath :: [PathElem ()] + -> In.OptValue () + -> In.OptValue () +resolveInSubpath [] = id +resolveInSubpath (x : xs) = resolveInSubpath xs . resolveInElem x + +resolveElem :: (NormReducePart p) + => PathElem () + -> GenValue p () + -> GenValue p () +resolveElem (PathElem () keyRef' headRef') + = forceLookupProp keyRef' . forceRecWithHead headRef' + +resolveInElem :: PathElem () + -> In.OptValue () + -> In.OptValue () +resolveInElem _ In.NothingValue + = error "Bad macro - references property of free bind" +resolveInElem (PathElem () keyRef' headRef') (In.JustValue val) + = forceLookupProp keyRef' $ forceRecWithHead headRef' val + +-- | Finds the injected function, resolves the arguments, then applies +-- the function with every possible primitive combination until it +-- returns a result. +resolveInjApp :: (NormReducePart p) + => Out.InjApp () + -> GenValue p () + -> GenValue p () +resolveInjApp app x = applyInj func params + where func = forceLookupFunc $ Out.funcId app + params = map ((`resolve` x) . Out.injParamVal) $ Out.params app + +resolveInInjApp :: Out.InjApp () + -> In.OptValue () + -> In.Value () +resolveInInjApp app x = applyInj func params + where func = forceLookupFunc $ Out.funcId app + params + = mapMaybe (In.optValToMaybeVal . (`resolveIn` x) . Out.injParamVal) + $ Out.params app + +-- Applies the function with every possible primitive combination given +-- the arguments until it returns a result. Fails if no combinations work. +applyInj :: (GenPart p) => InjFunc -> [GenValue p ()] -> GenValue p () +applyInj func params + = case tryApplyInj func params of + Failure () -> error "Injected function couldn't be applied to parameters" + Success out -> out + +-- Applies the function with every possible primitive combination given +-- the arguments until it returns a result. +tryApplyInj :: (GenPart p) + => InjFunc + -> [GenValue p ()] + -> UResult (GenValue p ()) +tryApplyInj = applyInjUsing [] + +applyInjUsing :: (GenPart p) + => [Prim ()] + -> InjFunc + -> [GenValue p ()] + -> UResult (GenValue p ()) +applyInjUsing revSelParams func [] + = case func selParams of + Nothing -> Failure () + Just out -> Success $ singletonValue $ primToPart Proxy out + where selParams = reverse revSelParams +applyInjUsing revSelParams func (nextParam : restParams) + = asum $ map applyInjUsingNext $ primParts nextParam + where applyInjUsingNext nextSelParam = applyInjUsing (nextSelParam : revSelParams) func restParams + +transProps :: Out.Value () -> In.Value () -> PropTranses +transProps output' = map (`transPath` output') . pathsInVal + +pathsInVal :: In.Value () -> [PropPath ()] +pathsInVal (Value () parts) = concatMap pathsInPart parts + +pathsInPart :: In.Part () -> [PropPath ()] +pathsInPart (In.PartPrim _) = [] +pathsInPart (In.PartPrimType _) = [] +pathsInPart (In.PartRecord record) = pathsInRecord record + +pathsInRecord :: In.Record () -> [PropPath ()] +pathsInRecord (Record () head' props) = concatMap (pathsInProp head') props + +pathsInProp :: FSymbol () + -> In.Property () + -> [PropPath ()] +pathsInProp head' (Property () key val) + = immPath elem' : map (subPath elem') (pathsInOptVal val) + where elem' = PathElem () key head' + +pathsInOptVal :: In.OptValue () -> [PropPath ()] +pathsInOptVal In.NothingValue = [] +pathsInOptVal (In.JustValue x) = pathsInVal x + +transPath :: PropPath () -> Out.Value () -> PropTrans +transPath inPath = PropTrans inPath . transOutsInVal inPath + +transOutsInVal :: PropPath () -> Out.Value () -> [SubPropPath ()] +transOutsInVal inPath (Value () parts) = concatMap (transOutsInPart inPath) parts + +transOutsInPart :: PropPath () -> Out.Part () -> [SubPropPath ()] +transOutsInPart _ (Out.PartPrim _) = [] +transOutsInPart inPath (Out.PartRecord record) + = transOutsInRecord inPath record +transOutsInPart inPath (Out.PartPropPath path) + = transOutsInPath inPath path +transOutsInPart inPath (Out.PartInjApp app) + = transOutsInInjApp inPath app + +transOutsInRecord :: PropPath () -> Out.Record () -> [SubPropPath ()] +transOutsInRecord inPath (Record () head' props) + = concatMap (transOutsInProp inPath head') props + +transOutsInProp :: PropPath () -> FSymbol () -> Out.Property () -> [SubPropPath ()] +transOutsInProp inPath head' (Property () key val) + = map (elem' :) $ transOutsInVal inPath val + where elem' = PathElem () key head' + +-- | Name is misleading out of context - the old property path will +-- transform into the location of this property path if both paths are +-- equal. +transOutsInPath :: PropPath () -> PropPath () -> [SubPropPath ()] +transOutsInPath inPath path + | inPath == path = [[]] + | otherwise = [] + +transOutsInInjApp :: PropPath () -> Out.InjApp () -> [SubPropPath ()] +transOutsInInjApp _ _ + = error "Macros deconstructing injected applications is unsupported. \ + \Wrap the injected application in a regular record, then \ + \deconstruct that record instead." diff --git a/src/Descript/BasicInj/Process/Refactor.hs b/src/Descript/BasicInj/Process/Refactor.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Refactor.hs @@ -0,0 +1,2 @@ +-- | Perform changes on 'BasicInj' ASTs. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/BasicInj/Process/Refactor/GenRenameSymbol.hs b/src/Descript/BasicInj/Process/Refactor/GenRenameSymbol.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Refactor/GenRenameSymbol.hs @@ -0,0 +1,18 @@ +module Descript.BasicInj.Process.Refactor.GenRenameSymbol + ( GenRenameSymbol (..) + , renameSymbol + ) where + +import Descript.Misc +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer.Strict + +data GenRenameSymbol a = GenRenameSymbol (a ()) (a ()) + +renameSymbol :: (Printable a, Eq (a ())) => GenRenameSymbol a -> RefactorFunc a +renameSymbol (GenRenameSymbol old new) sym + | sym =@= old = pure $ ann' <$ new + | sym =@= new = sym <$ lift (tell [SymConflict ann $ pprintStr new]) + | otherwise = pure sym + where ann' = taint ann + ann = getAnn sym diff --git a/src/Descript/BasicInj/Process/Refactor/RefactorReduce.hs b/src/Descript/BasicInj/Process/Refactor/RefactorReduce.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Refactor/RefactorReduce.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TypeFamilies #-} + +module Descript.BasicInj.Process.Refactor.RefactorReduce + ( refactorReduce + ) where + +import Descript.BasicInj.Process.Reduce.SrcAnn +import qualified Descript.BasicInj.Traverse.Term as T +import Descript.BasicInj.Process.Validate +import Descript.BasicInj.Traverse +import qualified Descript.BasicInj.Data.Value.In as In +import qualified Descript.BasicInj.Data.Value.Out as Out +import Descript.BasicInj.Data +import Descript.Misc +import Data.Semigroup as S +import Data.Monoid as M +import Data.Functor.Identity +import Core.Control.Monad.Trans +import Control.Monad.Trans.Writer.Strict + +data RefactorReduce = RefactorReduce (PhaseCtx ()) + +instance Traversal RefactorReduce where + type Eff RefactorReduce = ResultT RefactorError (WriterT [RefactorWarning] Identity) + type TAnn RefactorReduce = SrcAnn + + tonTerm T.PhaseCtx (RefactorReduce phase) = pure . reducePhase phase + tonTerm T.RegValue (RefactorReduce phase) = pure . reduceReg phase + tonTerm _ _ = pure + +-- | Replaces the left (input) value with the right (output) within +-- every value in the source, including reducers. +refactorReduce :: DirtyDep SrcAnn + -> In.Value SrcAnn + -> Out.Value SrcAnn + -> RefactorFunc Source +refactorReduce dextra old new x = do + validateForRefactor $ Depd dextra x -- Handles dependency errors + -- Ignores dependency errors, already handled + validateForRefactorIn T.Reducer fullMod reducer + rehoist $ refactorReduce' T.Source (PhaseCtx () [reducer_]) x + where reducer = Reducer (getAnn old S.<> getAnn new) old new + reducer_ = remAnns reducer + fullMod = sourceAModule_ x M.<> dirtyVal dextra + +-- | Applies the reducer to every value in the node, including other +-- reducers (it's a macro reducer). +refactorReduce' :: TTerm t -> PhaseCtx () -> RefactorFunc t +refactorReduce' term phase = travTerm term $ RefactorReduce phase diff --git a/src/Descript/BasicInj/Process/Refactor/RenameModuleElem.hs b/src/Descript/BasicInj/Process/Refactor/RenameModuleElem.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Refactor/RenameModuleElem.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ApplicativeDo #-} + +module Descript.BasicInj.Process.Refactor.RenameModuleElem + ( renameModuleElem + , renameModuleElem' + ) where + +import Descript.BasicInj.Process.Refactor.GenRenameSymbol +import qualified Descript.BasicInj.Traverse.Term as T +import Descript.BasicInj.Traverse +import Descript.BasicInj.Data +import Descript.Misc +import Data.Functor.Identity +import Core.Data.List +import qualified Data.List.NonEmpty as NonEmpty +import Control.Monad.Trans.Writer.Strict + +data RenameModuleElem = RenameModuleElem [Symbol ()] (GenRenameSymbol Symbol) + +instance Traversal RenameModuleElem where + type Eff RenameModuleElem = ResultT RefactorError (WriterT [RefactorWarning] Identity) + type TAnn RenameModuleElem = SrcAnn + + tonTerm T.ModulePath (RenameModuleElem prevs rsym) x@(ModulePath ann es) + = case splitPrefixBy (=@=) prevs $ NonEmpty.toList es of + Nothing -> pure x + Just (_, []) -> pure x + Just (fes, (targ : res)) -> do + targ' <- renameSymbol rsym targ + pure $ ModulePath ann $ NonEmpty.fromList $ fes ++ targ' : res + tonTerm _ _ x = pure x + +-- | Replaces every occurrence of the first import element immediately +-- after the previous elements with the second. +renameModuleElem :: [String] -> String -> String -> RefactorFunc Source +renameModuleElem prevs old new + = renameModuleElem' T.Source (map (Symbol ()) prevs) (Symbol () old) (Symbol () new) + +-- | Replaces every occurrence of the first import element immediately +-- after the previous elements with the second. +renameModuleElem' :: TTerm t + -> [Symbol ()] + -> Symbol () + -> Symbol () + -> RefactorFunc t +renameModuleElem' term prevs old new + = travTerm term $ RenameModuleElem prevs $ GenRenameSymbol old new diff --git a/src/Descript/BasicInj/Process/Refactor/RenameProp.hs b/src/Descript/BasicInj/Process/Refactor/RenameProp.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Refactor/RenameProp.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeFamilies #-} + +module Descript.BasicInj.Process.Refactor.RenameProp + ( renameProp + , renameProp' + ) where + +import Descript.BasicInj.Process.Refactor.GenRenameSymbol +import qualified Descript.BasicInj.Traverse.Term as T +import Descript.BasicInj.Traverse +import Descript.BasicInj.Data +import Descript.Misc +import Data.Functor.Identity +import Control.Monad.Trans.Writer.Strict + +data RenameProp = RenameProp (FSymbol ()) (GenRenameSymbol Symbol) + +instance Traversal RenameProp where + type Eff RenameProp = ResultT RefactorError (WriterT [RefactorWarning] Identity) + type TAnn RenameProp = SrcAnn + + tonTerm T.RecordType (RenameProp target rsym) x@(RecordType ann head' props) + | head' /@= target = pure x + | otherwise + = RecordType ann head' + <$> traverse (renameSymbol rsym) props + tonTerm T.GenRecord (RenameProp target rsym) x@(Record ann head' props) + | head' /@= target = pure x + | otherwise + = Record ann head' + <$> traverse (renameLocalProp rsym) props + tonTerm T.PathElem (RenameProp target rsym) x@(PathElem ann propKey' headKey') + | headKey' /@= target = pure x + | otherwise + = PathElem ann + <$> renameSymbol rsym propKey' + <*> pure headKey' + tonTerm _ _ x = pure x + +-- | Replaces every occurrence of the first property with the second, +-- in the record with the given head. +renameProp :: String -> String -> String -> RefactorFunc Source +renameProp head' old new src + = renameProp' T.Source (mkFSymbol head') (Symbol () old) (Symbol () new) src + where mkFSymbol = FSymbol (sourceScope src) . Symbol () + +-- | Replaces every occurrence of the first property with the second, +-- in the record with the given head. +renameProp' :: TTerm t -> FSymbol () -> Symbol () -> Symbol () -> RefactorFunc t +renameProp' term head' old new = travTerm term $ RenameProp head' $ GenRenameSymbol old new + +renameLocalProp :: GenRenameSymbol Symbol -> RefactorFunc (GenProperty v) +renameLocalProp rsym (Property ann key val) + = Property ann <$> renameSymbol rsym key <*> pure val diff --git a/src/Descript/BasicInj/Process/Refactor/RenameRecord.hs b/src/Descript/BasicInj/Process/Refactor/RenameRecord.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Refactor/RenameRecord.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TypeFamilies #-} + +module Descript.BasicInj.Process.Refactor.RenameRecord + ( renameRecord + , renameRecord' + ) where + +import Descript.BasicInj.Process.Refactor.GenRenameSymbol +import qualified Descript.BasicInj.Traverse.Term as T +import Descript.BasicInj.Traverse +import Descript.BasicInj.Data +import Descript.Misc +import Data.Functor.Identity +import Control.Monad.Trans.Writer.Strict + +newtype RenameRecord = RenameRecord (GenRenameSymbol FSymbol) + +instance Traversal RenameRecord where + type Eff RenameRecord = ResultT RefactorError (WriterT [RefactorWarning] Identity) + type TAnn RenameRecord = SrcAnn + + tonTerm T.RecordHead (RenameRecord rsym) sym = renameSymbol rsym sym + tonTerm _ _ x = pure x + +-- | Replaces every occurrence of the first record head with the second. +renameRecord :: String -> String -> RefactorFunc Source +renameRecord old new src = renameRecord' T.Source (mkFSymbol old) (mkFSymbol new) src + where mkFSymbol = FSymbol (sourceScope src) . Symbol () + +-- | Replaces every occurrence of the first record head with the second. +renameRecord' :: TTerm t -> FSymbol () -> FSymbol () -> RefactorFunc t +renameRecord' term old new = travTerm term $ RenameRecord $ GenRenameSymbol old new diff --git a/src/Descript/BasicInj/Process/Refactor/RenameSymbol.hs b/src/Descript/BasicInj/Process/Refactor/RenameSymbol.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Refactor/RenameSymbol.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TypeFamilies #-} + +module Descript.BasicInj.Process.Refactor.RenameSymbol + ( renameSymbolAt + ) where + +import Descript.BasicInj.Process.Refactor.RenameModuleElem +import Descript.BasicInj.Process.Refactor.RenameRecord +import Descript.BasicInj.Process.Refactor.RenameProp +import Descript.BasicInj.Process.Inspect +import qualified Descript.BasicInj.Traverse.Term as T +import Descript.BasicInj.Traverse +import Descript.BasicInj.Data +import Descript.Misc + +-- | Replaces every occurrence of the symbol at the given location. +-- Fails if there's no symbol at the location. +renameSymbolAt :: Loc -> String -> RefactorFunc Source +renameSymbolAt oldLoc new = renameSymbolAt' T.Source oldLoc $ Symbol () new + +-- | Replaces every occurrence of the symbol at the given location. +-- Fails if there's no symbol at the location. +renameSymbolAt' :: TTerm t -> Loc -> Symbol () -> RefactorFunc t +renameSymbolAt' term oldLoc new src + = case symbolAt' term oldLoc src of + Nothing -> mkFailureT RefactorNoSymbolAtLoc + Just oldEnv -> renameSymbolInEnv' term oldEnv_ new src + where oldEnv_ = remAnns oldEnv + +-- | Replaces every occurrence of the first symbol in the same +-- environment with the second. +renameSymbolInEnv' :: TTerm t -> SymbolEnv () -> Symbol () -> RefactorFunc t +renameSymbolInEnv' term (EnvModulePathElem prevs old) new + = renameModuleElem' term prevs old new +renameSymbolInEnv' term (EnvRecordHead oldf) new + = renameRecord' term oldf newf + where newf = FSymbol (fsymbolScope oldf) new +renameSymbolInEnv' term (EnvPropertyKey head' old) new + = renameProp' term head' old new diff --git a/src/Descript/BasicInj/Process/Validate.hs b/src/Descript/BasicInj/Process/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Process/Validate.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Checks that Descript source is well-formed before it's interpreted. +-- If the source isn't well-formed, generates user-friendly problems. +module Descript.BasicInj.Process.Validate + ( validateForRefactor + , validate + , validate_ + , validate' + , validateForRefactorIn + , validateIn + , validateIn_ + , validateIn' + ) where + +import qualified Descript.BasicInj.Traverse.Term as T +import Descript.BasicInj.Traverse +import qualified Descript.BasicInj.Data.Value.In as In +import qualified Descript.BasicInj.Data.Value.Out as Out +import qualified Descript.BasicInj.Data.Type as RecordType (head) +import Descript.BasicInj.Data +import qualified Descript.Misc.Build.Process.Validate.Term as Term +import Descript.Misc +import Data.Semigroup as S +import Data.Monoid as M +import Data.List +import Core.Data.List +import Core.Data.List.Assoc +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Core.Control.Monad.Trans +import Prelude hiding (head, mod) + +newtype ValidateAll an = ValidateAll (AModule ()) +newtype ValidateRecords an = ValidateRecords (RecordCtx ()) +newtype ValidatePropPaths an = ValidatePropPaths (In.Value ()) + +instance (Semigroup an) => Fold (ValidateAll an) where + type Res (ValidateAll an) = [Problem an] + type FAnn (ValidateAll an) = an + + fonTerm T.Program (ValidateAll extra) prog + = foldTerm T.Query (ValidateRecords recordCtx') (query prog) + where recordCtx' = recordCtx_ M.<> recordCtx extra + recordCtx_ = remAnns $ recordCtx $ amodule $ module' prog + fonTerm T.AModule (ValidateAll extra) mod + = foldTerm T.ReduceCtx (ValidateRecords recordCtx') (reduceCtx mod) + where recordCtx' = recordCtx_ M.<> recordCtx extra + recordCtx_ = remAnns $ recordCtx mod + fonTerm T.ImportCtx (ValidateAll _) (ImportCtx _ _ idecls) + = validateImportDeclsNoDups idecls + fonTerm T.RecordCtx (ValidateAll extra) (RecordCtx _ decls) + = validateRecordDeclsNoDups extraDecls decls + where extraDecls = recordCtxDecls $ recordCtx extra + fonTerm T.Reducer (ValidateAll _) (Reducer _ input' output') + = foldTerm T.Output (ValidatePropPaths input_) output' + where input_ = remAnns input' + fonTerm T.GenRecord (ValidateAll _) (Record _ _ props) + = validatePropsNoDups props + fonTerm T.InjApp (ValidateAll _) injApp = validateInjAppExists injApp + fonTerm _ _ _ = mempty + +instance (Semigroup an) => Fold (ValidateRecords an) where + type Res (ValidateRecords an) = [Problem an] + type FAnn (ValidateRecords an) = an + + fonTerm T.GenRecord (ValidateRecords recordCtx') record + = validateRecordConforms recordCtx' record + fonTerm _ _ _ = mempty + +instance (Semigroup an) => Fold (ValidatePropPaths an) where + type Res (ValidatePropPaths an) = [Problem an] + type FAnn (ValidatePropPaths an) = an + + fonTerm T.PropPath (ValidatePropPaths input') path + = validatePathExists input' path + fonTerm _ _ _ = mempty + +-- | If the node is valid, returns an empty success. +-- Otherwise returns a refactor failure. +validateForRefactor :: (Monad u) + => DirtyDepd Source SrcAnn + -> RefactorResultT u () +validateForRefactor = hoist . mapError RefactorValidateError . validate_ + +-- | If the source is valid, returns a success containing it. +-- Otherwise returns a failure containing all the problems. +validate :: (Ord an, Semigroup an) + => DirtyDepd Source an + -> Result [Problem an] (Depd Source an) +validate dx + | null problems = Success $ mapDep dirtyVal dx + | otherwise = Failure problems + where problems = validate' dx + +-- | If the source is valid, returns an empty success. +-- Otherwise returns a failure containing all the problems. +-- Useful in do notation. +validate_ :: (Ord an, Semigroup an) + => DirtyDepd Source an + -> Result [Problem an] () +validate_ dx + | null problems = Success () + | otherwise = Failure problems + where problems = validate' dx + +-- | Finds all problems within the source. If the source has no +-- problems, it's well formed and can be interpreted. +validate' :: (Ord an, Semigroup an) + => DirtyDepd Source an + -> [Problem an] +validate' (Depd (Dirty derrs extra) x) = dprobs ++ rprobs + where dprobs = map ProblemDepFail derrs + rprobs = validateIn' T.Source extra x + +-- | If the node is valid, returns an empty success. +-- Otherwise returns a refactor failure. +validateForRefactorIn :: (Monad u) + => TTerm t + -> AModule () + -> t SrcAnn + -> RefactorResultT u () +validateForRefactorIn term extra + = hoist . mapError RefactorValidateError . validateIn_ term extra + +-- | If the node is valid, returns a success containing it. +-- Otherwise returns a failure containing all the problems. +-- Uses context (e.g. declared records) from the module. +validateIn :: (Ord an, Semigroup an) + => TTerm t + -> AModule () + -> t an + -> Result [Problem an] (t an) +validateIn term extra x + | null problems = Success x + | otherwise = Failure problems + where problems = validateIn' term extra x + +-- | If the node is valid, returns an empty success. +-- Otherwise returns a failure containing all the problems. +-- Useful in do notation. +-- Uses context (e.g. declared records) from the module. +validateIn_ :: (Ord an, Semigroup an) + => TTerm t + -> AModule () + -> t an + -> Result [Problem an] () +validateIn_ term extra x + | null problems = Success () + | otherwise = Failure problems + where problems = validateIn' term extra x + +-- | Finds all problems within the node. If the node has no +-- problems, it's well formed and can be interpreted. +-- Uses context (e.g. declared records) from the module. +validateIn' :: (Ord an, Semigroup an) => TTerm t -> AModule () -> t an -> [Problem an] +validateIn' term extra = sortOn getAnn . foldTerm term (ValidateAll extra) + +validateImportDeclsNoDups :: (Semigroup an) => [ImportDecl an] -> [Problem an] +validateImportDeclsNoDups decls + = concat $ zipWith validateImportDeclNoConflict otherDeclss decls + where otherDeclss = inits $ map remAnns decls + +validateRecordDeclsNoDups :: (Semigroup an) => [RecordDecl ()] -> [RecordDecl an] -> [Problem an] +validateRecordDeclsNoDups extraDecls decls + = concat $ zipWith validateRecordDeclNoDup otherDeclss decls + where otherDeclss = map (extraDecls ++) $ inits $ map remAnns decls + +validatePropsNoDups :: (Semigroup an, FwdPrintable v, GenPropVal v) + => [GenProperty v an] + -> [Problem an] +validatePropsNoDups props + = concat $ zipWith validatePropNoDup otherPropss props + where otherPropss = inits $ map remAnns props + +validateImportDeclNoConflict :: (Semigroup an) => [ImportDecl ()] -> ImportDecl an -> [Problem an] +validateImportDeclNoConflict prevDecls decl + | any (`importsConflict` decl) prevDecls + = [Conflict (getAnn decl) Term.Import $ pprintStr decl] + | otherwise = [] + +validateRecordDeclNoDup :: (Semigroup an) => [RecordDecl ()] -> RecordDecl an -> [Problem an] +validateRecordDeclNoDup prevDecls decl + | any (`declsConflict` decl) prevDecls + = [Duplicate (getAnn decl) Term.RecordDecl $ pprintStr decl] + | otherwise = [] + +validatePropNoDup :: (Semigroup an, FwdPrintable v, GenPropVal v) + => [GenProperty v ()] + -> GenProperty v an + -> [Problem an] +validatePropNoDup prevProps prop + | any (`propsConflict` prop) prevProps = [Duplicate (getAnn prop) Term.Property $ pprintStr prop] + | otherwise = [] + +-- | Whether both imports are redundant and/or could break each other. +importsConflict :: ImportDecl an1 -> ImportDecl an2 -> Bool +ImportDecl _ xPath xISrcs xIDsts `importsConflict` ImportDecl _ yPath yISrcs yIDsts + = xPath =@= yPath + && (isPermBy (=@=) xISrcs yISrcs || overlapsBy (=@=) xIDsts yIDsts) + +-- | Whether both declarations' types conflict. +declsConflict :: RecordDecl an1 -> RecordDecl an2 -> Bool +RecordDecl _ x `declsConflict` RecordDecl _ y = x `typesConflict` y + +-- | Whether both types have the same head - whether both types can't +-- exist in the same context. +typesConflict :: RecordType an1 -> RecordType an2 -> Bool +x `typesConflict` y = xHead =@= yHead && xHead /@= undefinedFSym + where xHead = RecordType.head x + yHead = RecordType.head y + +-- | Whether both properties conflict - whether they can't be in the +-- same record. +propsConflict :: GenProperty v1 an1 -> GenProperty v2 an2 -> Bool +x `propsConflict` y = xKey =@= yKey && xKey /@= undefinedSym + where xKey = propertyKey x + yKey = propertyKey y + +-- | Validates that the record's type was defined, and it conforms. +validateRecordConforms :: (Semigroup an) => RecordCtx () -> GenRecord v an -> [Problem an] +validateRecordConforms ctx (Record ann head' properties') + = case recordTypeFor ctx head_ of + Nothing -> [UndeclaredRecord (getAnn head') $ pprintStr head'] + Just (RecordType _ _ typeProps) + -> validatePropsComplete typeProps ann properties' + ++ validatePropsFit typeProps properties' + where head_ = remAnns head' + +validatePropsComplete :: (Semigroup an) => [Symbol ()] -> an -> [GenProperty v an] -> [Problem an] +validatePropsComplete typeProps ann properties' + = case filter (not . (`assocMember` properties')) typeProps_ of + [] -> [] + missingProps -> [IncompleteRecord ann $ map pprintStr missingProps] + where typeProps_ = map remAnns typeProps + +validatePropsFit :: (Semigroup an) => [Symbol ()] -> [GenProperty v an] -> [Problem an] +validatePropsFit declProps properties' + = case deleteFirstsBy' (=@=) declProps propKeys of + [] -> [] + extraKeys@(x : xs) -> [OvercompleteRecord extraKeysAnn $ extraKeyPrs] + where extraKeyPrs = map pprintStr extraKeys + extraKeysAnn = sconcat $ NonEmpty.map getAnn extraKeys' + extraKeys' = x :| xs + where propKeys = map propertyKey properties' + +validatePathExists :: (Semigroup an) => In.Value () -> PropPath an -> [Problem an] +validatePathExists input' (PropPath _ elems) + = validateSubpathExists (Just input') $ NonEmpty.toList elems + +validateSubpathExists :: (Semigroup an) => Maybe (In.Value ()) -> [PathElem an] -> [Problem an] +validateSubpathExists _ [] = [] +validateSubpathExists input' ((PathElem _ keyRef' headRef') : elems) + = case recWithHead headRef_ =<< input' of + Nothing -> [UndeclaredPathElemHead (getAnn headRef') $ pprintStr headRef'] + Just inRec + -> case lookupProp keyRef_ inRec of + Nothing -> [UndeclaredPathElemKey (getAnn keyRef') $ pprintStr keyRef'] + Just subInput -> validateSubpathExists subInput' elems + where subInput' = In.optValToMaybeVal subInput + where headRef_ = remAnns headRef' + keyRef_ = remAnns keyRef' + +validateInjAppExists :: (Semigroup an) => Out.InjApp an -> [Problem an] +validateInjAppExists (Out.InjApp _ funcId' _) + = case lookupFunc funcId' of + Nothing -> [UndefinedInjFunc (getAnn funcId') $ pprintStr funcId'] + Just _ -> [] -- TODO Check params. Requires refactor move into `ValidatePropPaths` + +recordTypeFor :: (Semigroup an) => RecordCtx an -> FSymbol an -> Maybe (RecordType an) +recordTypeFor (RecordCtx _ decls) head' + = find (recordTypeMatches head') $ map recordDeclType decls + +recordTypeMatches :: (Semigroup an) => FSymbol an -> RecordType an -> Bool +recordTypeMatches head' decl = head' =@= RecordType.head decl diff --git a/src/Descript/BasicInj/Read.hs b/src/Descript/BasicInj/Read.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Read.hs @@ -0,0 +1,2 @@ +-- | Read the AST (including dependencies). +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/BasicInj/Read/Resolve.hs b/src/Descript/BasicInj/Read/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Read/Resolve.hs @@ -0,0 +1,45 @@ +-- | Resolves dependencies +module Descript.BasicInj.Read.Resolve + ( extraModule + ) where + +import Descript.BasicInj.Read.Resolve.Subst +import Descript.BasicInj.Data +import Descript.Misc + +-- | Contains imported data used by the module. +extraModule :: (Monad u) + => DepResolver u + -> ImportCtx an + -> DirtyDepT an u +extraModule rsvr (ImportCtx _ mdecl idecls) + = mconcat <$> traverse (resolveImportDep rsvr mascope) idecls + where mascope = modulePathScope $ moduleDeclPath mdecl + +-- | Resolves the dependency for the module with the given scope +-- specified by the given import declaration. +resolveImportDep :: (Monad u) + => DepResolver u + -> AbsScope + -> ImportDecl an + -> DirtyDepT an u +resolveImportDep rsvr mascope (ImportDecl _ ipath isrcs idsts) + = substDstImports idsts_ . substSrcImports isrcs_ + <$> resolveImportDep' rsvr mascope ipath + where isrcs_ = map remAnns $ isrcs + idsts_ = map remAnns $ idsts + +-- | Resolves the dependency for the module with the given scope +-- specified by the given import path - doesn't apply substitutions. +resolveImportDep' :: (Monad u) + => DepResolver u + -> AbsScope + -> ModulePath an + -> DirtyDepT an u +resolveImportDep' rsvr mascope ipath + = resToDirtyMonT + $ mapErrorT (TagdDepError iann mascope) + $ resolveDep rsvr iscope + where iscope = iascope `scopeRelToSib` mascope + iascope = modulePathScope ipath + iann = getAnn ipath diff --git a/src/Descript/BasicInj/Read/Resolve/Subst.hs b/src/Descript/BasicInj/Read/Resolve/Subst.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Read/Resolve/Subst.hs @@ -0,0 +1,36 @@ +module Descript.BasicInj.Read.Resolve.Subst + ( substSrcImports + , substDstImports + ) where + +import Descript.BasicInj.Read.Resolve.Subst.Global +import Descript.BasicInj.Read.Resolve.Subst.Local +import Descript.BasicInj.Read.Resolve.Subst.Subst +import Descript.BasicInj.Data +import Descript.Misc + +-- | Locally substitues each imported @from@ record head with its +-- @to@ counterpart. Does this by directly substituting occurrences in +-- the module, instead of adding reducers to the top phase. +substSrcImports :: (TaintAnn an) + => [ImportRecord ()] + -> AModule an + -> AModule an +substSrcImports = localSubstMany . map isrcToSubst + +-- | Globally substitues each imported @to@ record head with its +-- @from@ counterpart. Does this by adding reducers to the top phase +-- which apply each substitution, and also substituting in the record +-- declarations. +substDstImports :: (TaintAnn an) + => [ImportRecord ()] + -> AModule an + -> AModule an +substDstImports = globalSubstMany . map idstToSubst + +isrcToSubst :: ImportRecord () -> Subst +isrcToSubst (ImportRecord () from to) = Subst SubstFrom from to + +idstToSubst :: ImportRecord () -> Subst +-- Weird and confusing - maybe should have better naming. +idstToSubst (ImportRecord () from to) = Subst SubstTo to from diff --git a/src/Descript/BasicInj/Read/Resolve/Subst/Global.hs b/src/Descript/BasicInj/Read/Resolve/Subst/Global.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Read/Resolve/Subst/Global.hs @@ -0,0 +1,89 @@ +module Descript.BasicInj.Read.Resolve.Subst.Global + ( globalSubstMany + ) where + +import Descript.BasicInj.Read.Resolve.Subst.Subst +import qualified Descript.BasicInj.Data.Value.In as In +import qualified Descript.BasicInj.Data.Value.Out as Out +import qualified Descript.BasicInj.Data.Type as RecordType +import Descript.BasicInj.Data +import Descript.Misc +import Data.Semigroup +import Core.Data.List +import Core.Data.List.Assoc + +-- | Globally applies each substitution by modifying the top phase +-- and record declarations. +globalSubstMany :: (TaintAnn an) + => [Subst] + -> AModule an + -> AModule an +globalSubstMany substs (AModule ann recCtx redCtx) + = AModule + { amoduleAnn = ann + , recordCtx = globalSubstManyRecordCtx substs recCtx + , reduceCtx = globalSubstManyReduceCtx recCtx_ substs redCtx + } + where recCtx_ = remAnns recCtx + +globalSubstManyRecordCtx :: (TaintAnn an) + => [Subst] + -> RecordCtx an + -> RecordCtx an +globalSubstManyRecordCtx substs (RecordCtx ann decls) + = RecordCtx ann $ concatMap (globalSubstManyRecordDecl substs) decls + +globalSubstManyRecordDecl :: (TaintAnn an) + => [Subst] + -> RecordDecl an + -> [RecordDecl an] +globalSubstManyRecordDecl substs (RecordDecl ann typ) + = RecordDecl ann <$> globalSubstManyRecordType substs typ + +globalSubstManyRecordType :: (TaintAnn an) + => [Subst] + -> RecordType an + -> [RecordType an] +globalSubstManyRecordType substs (RecordType ann head' props) + = RecordType ann <$> globalSubstManyFSymbol substs head' <*> pure props + +globalSubstManyFSymbol :: (TaintAnn an) + => [Subst] + -> FSymbol an + -> [FSymbol an] +globalSubstManyFSymbol substs x = y ?: [x] + where y = (ann' <$) <$> y_ + y_ = glookup x_ substs + x_ = remAnns x + ann' = getAnn x + +globalSubstManyReduceCtx :: (TaintAnn an) + => RecordCtx () + -> [Subst] + -> ReduceCtx an + -> ReduceCtx an +globalSubstManyReduceCtx recCtx substs (ReduceCtx ann top lows) + = ReduceCtx ann top' lows + where top' = top <> extraTop + extraTop = substAnn <$ substManyPhase recCtx substs + substAnn = preInsertAnn ann + +substManyPhase :: RecordCtx () -> [Subst] -> PhaseCtx () +substManyPhase recCtx = PhaseCtx () . map (substToReducer recCtx) + +substToReducer :: RecordCtx () -> Subst -> Reducer () +substToReducer recCtx subst@(Subst _ from to) = Reducer () from' to' + where from' + = singletonValue + $ In.PartRecord + $ Record () from + $ map In.fullConsumeProp propKeys + to' + = singletonValue + $ Out.PartRecord + $ Record () to + $ map (Out.fullProduceProp from) propKeys + propKeys + = case lookupRecordType (substDeclHead subst) recCtx of + Nothing -> [undefinedSym] + Just rtype -> RecordType.properties rtype diff --git a/src/Descript/BasicInj/Read/Resolve/Subst/Local.hs b/src/Descript/BasicInj/Read/Resolve/Subst/Local.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Read/Resolve/Subst/Local.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TypeFamilies #-} + +module Descript.BasicInj.Read.Resolve.Subst.Local + ( localSubstMany + ) where + +import Descript.BasicInj.Read.Resolve.Subst.Subst +import qualified Descript.BasicInj.Traverse.Term as T +import Descript.BasicInj.Traverse +import Descript.BasicInj.Data +import Descript.Misc +import Core.Data.List.Assoc + +newtype LocalSubstMany an = LocalSubstMany [Subst] + +instance (TaintAnn an) => Mapping (LocalSubstMany an) where + type MAnn (LocalSubstMany an) = an + + monTerm T.RecordHead (LocalSubstMany substs) x + = localSubstManyIndiv substs x + monTerm _ _ x = x + +-- | Locally applies each substitution by directly substituting +-- occurrences of the symbol. +localSubstMany :: (TaintAnn an) + => [Subst] + -> AModule an + -> AModule an +localSubstMany = mapTerm T.AModule . LocalSubstMany + +localSubstManyIndiv :: (TaintAnn an) + => [Subst] + -> FSymbol an + -> FSymbol an +localSubstManyIndiv substs x + = case glookup x_ substs of + Nothing -> x + Just y_ -> y + where y = ann' <$ y_ + where x_ = remAnns x + ann' = getAnn x diff --git a/src/Descript/BasicInj/Read/Resolve/Subst/Subst.hs b/src/Descript/BasicInj/Read/Resolve/Subst/Subst.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Read/Resolve/Subst/Subst.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeFamilies #-} + +module Descript.BasicInj.Read.Resolve.Subst.Subst + ( SubstPart (..) + , Subst (..) + , substDeclHead + ) where + +import Descript.BasicInj.Data +import Core.Data.List.Assoc + +data SubstPart + = SubstFrom + | SubstTo + +data Subst = Subst SubstPart (FSymbol ()) (FSymbol ()) + +instance AssocPair Subst where + type Key Subst = FSymbol () + type Value Subst = FSymbol () + + getKey (Subst SubstFrom from _) = from + getKey (Subst SubstTo _ to) = to + getValue (Subst SubstFrom _ to) = to + getValue (Subst SubstTo from _) = from + +substDeclHead :: Subst -> FSymbol () +substDeclHead = getKey diff --git a/src/Descript/BasicInj/Traverse.hs b/src/Descript/BasicInj/Traverse.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Traverse.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Abstracts traversals over source ASTs. +module Descript.BasicInj.Traverse + ( module Descript.BasicInj.Traverse.Termed + , TTerm + , Traversal (..) + , Fold (..) + , Mapping (..) + , travTerm + , foldTerm + , mapTerm + ) where + +import Descript.BasicInj.Traverse.Termed +import Descript.BasicInj.Traverse.Term (TTerm) +import qualified Descript.BasicInj.Traverse.Term as T +import qualified Descript.BasicInj.Data.Value.Reg as Reg +import qualified Descript.BasicInj.Data.Value.In as In +import qualified Descript.BasicInj.Data.Value.Out as Out +import Descript.BasicInj.Data +import Data.Functor.Identity +import Control.Monad ((<=<)) +import Control.Monad.Trans.Writer.Strict +import Prelude hiding (mod) + +newtype FoldTrav a = FoldTrav a +newtype MappingTrav a = MappingTrav a + +class (Monad (Eff f)) => Traversal f where + type Eff f :: * -> * + type TAnn f :: * + + tonTerm :: TTerm t -> f -> t (TAnn f) -> Eff f (t (TAnn f)) + tonTerm _ _ = pure + +class (Monoid (Res f)) => Fold f where + type Res f :: * + type FAnn f :: * + + fonTerm :: TTerm t -> f -> t (FAnn f) -> Res f + fonTerm _ _ = mempty + +class Mapping f where + type MAnn f :: * + + monTerm :: TTerm t -> f -> t (MAnn f) -> t (MAnn f) + monTerm _ _ = id + +instance (Fold f) => Traversal (FoldTrav f) where + type Eff (FoldTrav f) = Writer (Res f) + type TAnn (FoldTrav f) = FAnn f + + tonTerm term (FoldTrav t) x = x <$ tell (fonTerm term t x) + +instance (Mapping f) => Traversal (MappingTrav f) where + type Eff (MappingTrav f) = Identity + type TAnn (MappingTrav f) = MAnn f + + tonTerm term (MappingTrav t) = Identity . monTerm term t + +travTerm :: (Traversal f) => TTerm t -> f -> t (TAnn f) -> Eff f (t (TAnn f)) +travTerm term t = travSubTerm term t <=< tonTerm term t + +foldTerm :: (Fold f) => TTerm t -> f -> t (FAnn f) -> Res f +foldTerm term t = execWriter . travTerm term (FoldTrav t) + +mapTerm :: (Mapping f) => TTerm t -> f -> t (MAnn f) -> t (MAnn f) +mapTerm term t = runIdentity . travTerm term (MappingTrav t) + +travSubTerm :: (Traversal f) => TTerm t -> f -> t (TAnn f) -> Eff f (t (TAnn f)) +travSubTerm T.Source t (SourceModule mod) + = SourceModule <$> travTerm T.BModule t mod +travSubTerm T.Source t (SourceProgram prog) + = SourceProgram <$> travTerm T.Program t prog +travSubTerm T.Program t (Program ann mod query') + = Program ann <$> travTerm T.BModule t mod <*> travTerm T.Query t query' +travSubTerm T.BModule t (BModule ann ictx amod) + = BModule ann <$> travTerm T.ImportCtx t ictx <*> travTerm T.AModule t amod +travSubTerm T.AModule t (AModule ann recordCtx' reduceCtx') + = AModule ann + <$> travTerm T.RecordCtx t recordCtx' + <*> travTerm T.ReduceCtx t reduceCtx' +travSubTerm T.ImportCtx t (ImportCtx ann mdecl idecls) + = ImportCtx ann + <$> travTerm T.ModuleDecl t mdecl + <*> traverse (travTerm T.ImportDecl t) idecls +travSubTerm T.RecordCtx t (RecordCtx ann records) + = RecordCtx ann <$> traverse (travTerm T.RecordDecl t) records +travSubTerm T.ReduceCtx t (ReduceCtx ann topCtx lowCtxs) + = ReduceCtx ann + <$> travTerm T.PhaseCtx t topCtx + <*> traverse (travTerm T.PhaseCtx t) lowCtxs +travSubTerm T.PhaseCtx t (PhaseCtx ann reducers) + = PhaseCtx ann <$> traverse (travTerm T.Reducer t) reducers +travSubTerm T.Query t (Query ann val) = Query ann <$> travTerm T.RegValue t val +travSubTerm T.ModuleDecl t (ModuleDecl ann path) + = ModuleDecl ann <$> travTerm T.ModulePath t path +travSubTerm T.ImportDecl t (ImportDecl ann path isrcs idsts) + = ImportDecl ann + <$> travTerm T.ModulePath t path + <*> traverse (travTerm T.ImportRecord t) isrcs + <*> traverse (travTerm T.ImportRecord t) idsts +travSubTerm T.RecordDecl t (RecordDecl ann recordType) + = RecordDecl ann <$> travTerm T.RecordType t recordType +travSubTerm T.Reducer t (Reducer ann input' output') + = Reducer ann <$> travTerm T.Input t input' <*> travTerm T.Output t output' +travSubTerm T.ModulePath t (ModulePath ann xs) + = ModulePath ann <$> traverse (travTerm T.ModulePathElem t) xs +travSubTerm T.ImportRecord t (ImportRecord ann from to) + = ImportRecord ann + <$> travTerm T.RecordHead t from + <*> travTerm T.RecordHead t to +travSubTerm T.RecordType t (RecordType ann head' properties') + = RecordType ann + <$> travTerm T.RecordHead t head' + <*> traverse (travTerm T.PropertyKey t) properties' +travSubTerm T.RegValue t (Value ann parts) + = travTerm T.GenValue t + =<< Value ann <$> traverse (travTerm T.RegPart t) parts +travSubTerm T.Input t (Value ann parts) + = travTerm T.GenValue t + =<< Value ann <$> traverse (travTerm T.InPart t) parts +travSubTerm T.Output t (Value ann parts) + = travTerm T.GenValue t + =<< Value ann <$> traverse (travTerm T.OutPart t) parts +travSubTerm T.GenValue _ x = pure x +travSubTerm T.RegPart t (Reg.PartPrim prim) + = Reg.PartPrim <$> travTerm T.Prim t prim +travSubTerm T.RegPart t (Reg.PartRecord record) + = Reg.PartRecord <$> travTerm T.RegRecord t record +travSubTerm T.InPart t (In.PartPrim prim) + = In.PartPrim <$> travTerm T.Prim t prim +travSubTerm T.InPart t (In.PartPrimType primType) + = In.PartPrimType <$> travTerm T.PrimType t primType +travSubTerm T.InPart t (In.PartRecord record) + = In.PartRecord <$> travTerm T.InRecord t record +travSubTerm T.OutPart t (Out.PartPrim prim) + = Out.PartPrim <$> travTerm T.Prim t prim +travSubTerm T.OutPart t (Out.PartRecord record) + = Out.PartRecord <$> travTerm T.OutRecord t record +travSubTerm T.OutPart t (Out.PartPropPath path) + = Out.PartPropPath <$> travTerm T.PropPath t path +travSubTerm T.OutPart t (Out.PartInjApp app) + = Out.PartInjApp <$> travTerm T.InjApp t app +travSubTerm T.Prim _ x = pure x +travSubTerm T.PrimType _ x = pure x +travSubTerm T.RegRecord t (Record ann head' properties') + = travTerm T.GenRecord t + =<< Record ann head' <$> traverse (travTerm T.RegProperty t) properties' +travSubTerm T.InRecord t (Record ann head' properties') + = travTerm T.GenRecord t + =<< Record ann head' <$> traverse (travTerm T.InProperty t) properties' +travSubTerm T.OutRecord t (Record ann head' properties') + = travTerm T.GenRecord t + =<< Record ann head' <$> traverse (travTerm T.OutProperty t) properties' +travSubTerm T.GenRecord t (Record ann head' properties') + = Record ann <$> travTerm T.RecordHead t head' <*> pure properties' +travSubTerm T.RegProperty t (Property ann key val) + = Property ann + <$> travTerm T.PropertyKey t key + <*> travTerm T.RegValue t val +travSubTerm T.InProperty t (Property ann key val) + = Property ann + <$> travTerm T.PropertyKey t key + <*> In.traverseOptVal (travTerm T.Input t) val +travSubTerm T.OutProperty t (Property ann key val) + = Property ann + <$> travTerm T.PropertyKey t key + <*> travTerm T.Output t val +travSubTerm T.GenProperty _ x = pure x +travSubTerm T.PropPath t (PropPath ann elems) + = PropPath ann <$> traverse (travTerm T.PathElem t) elems +travSubTerm T.PathElem t (PathElem ann propKey' headKey') + = PathElem ann + <$> travTerm T.PropertyKey t propKey' + <*> travTerm T.RecordHead t headKey' +travSubTerm T.InjApp t (Out.InjApp ann funcId' params') + = Out.InjApp ann funcId' + <$> traverse (Out.traverseInjParamVal $ travTerm T.Output t) params' +travSubTerm T.ModulePathElem _ x = pure x +travSubTerm T.RecordHead _ x = pure x +travSubTerm T.PropertyKey _ x = pure x diff --git a/src/Descript/BasicInj/Traverse/Term.hs b/src/Descript/BasicInj/Traverse/Term.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Traverse/Term.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE Rank2Types #-} + +-- | Unifies traversing all of the AST nodes. +-- +-- > import qualified ...Term as T +module Descript.BasicInj.Traverse.Term + ( TTerm (..) + ) where + +import qualified Descript.BasicInj.Data.Value.Reg as Reg +import qualified Descript.BasicInj.Data.Value.In as In +import qualified Descript.BasicInj.Data.Value.Out as Out +import Descript.BasicInj.Data +import Descript.Misc + +-- | A type of AST node. Usually corresponds to a Haskell type but not +-- necessarily. +data TTerm (a :: * -> *) where + Source :: TTerm Source + Program :: TTerm Program + BModule :: TTerm BModule + AModule :: TTerm AModule + ModuleDecl :: TTerm ModuleDecl + ImportCtx :: TTerm ImportCtx + RecordCtx :: TTerm RecordCtx + ReduceCtx :: TTerm ReduceCtx + PhaseCtx :: TTerm PhaseCtx + Query :: TTerm Query + ImportDecl :: TTerm ImportDecl + RecordDecl :: TTerm RecordDecl + Reducer :: TTerm Reducer + ModulePath :: TTerm ModulePath + ImportRecord :: TTerm ImportRecord + RecordType :: TTerm RecordType + RegValue :: TTerm (GenValue Reg.Part) + Input :: TTerm (GenValue In.Part) + Output :: TTerm (GenValue Out.Part) + GenValue :: forall p. (GenPart p) => TTerm (GenValue p) + RegPart :: TTerm Reg.Part + InPart :: TTerm In.Part + OutPart :: TTerm Out.Part + Prim :: TTerm Prim + PrimType :: TTerm PrimType + RegRecord :: TTerm (GenRecord (GenValue Reg.Part)) + InRecord :: TTerm (GenRecord In.OptValue) + OutRecord :: TTerm (GenRecord (GenValue Out.Part)) + GenRecord :: forall v. (FwdPrintable v, GenPropVal v) => TTerm (GenRecord v) + RegProperty :: TTerm (GenProperty (GenValue Reg.Part)) + InProperty :: TTerm (GenProperty In.OptValue) + OutProperty :: TTerm (GenProperty (GenValue Out.Part)) + GenProperty :: forall v. (FwdPrintable v, GenPropVal v) => TTerm (GenProperty v) + PropPath :: TTerm PropPath + PathElem :: TTerm PathElem + InjApp :: TTerm Out.InjApp + ModulePathElem :: TTerm Symbol + RecordHead :: TTerm FSymbol + PropertyKey :: TTerm Symbol diff --git a/src/Descript/BasicInj/Traverse/Termed.hs b/src/Descript/BasicInj/Traverse/Termed.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Traverse/Termed.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +-- | Allows abstraction over larger groups of termed nodes, by +-- associating those nodes with their terms and other specific info. +module Descript.BasicInj.Traverse.Termed + ( Termed (..) + , SymbolEnv (..) + ) where + +import Descript.BasicInj.Traverse.Term (TTerm) +import Descript.BasicInj.Data + +-- | A node associated with a term. +data Termed a an + = Termed + { termedTerm :: TTerm a + , termedValue :: a an + } + +-- | A symbol node associated with its term, and context which would +-- distinguish it from other symbols with the same term and label. +data SymbolEnv an + = EnvModulePathElem [Symbol an] (Symbol an) + | EnvRecordHead (FSymbol an) + | EnvPropertyKey (FSymbol an) (Symbol an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) diff --git a/src/Descript/BasicInj/Write.hs b/src/Descript/BasicInj/Write.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Write.hs @@ -0,0 +1,2 @@ +-- | Write the AST (reprint or compile). +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/BasicInj/Write/Compile.hs b/src/Descript/BasicInj/Write/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Write/Compile.hs @@ -0,0 +1,76 @@ +module Descript.BasicInj.Write.Compile + ( compile + , isFinal + ) where + +import Descript.BasicInj.Data.Value.Reg +import Descript.BasicInj.Data.Value.Gen +import Descript.BasicInj.Data.Atom +import Descript.Misc +import Core.DontForce +import Core.Data.List.Assoc hiding (Value) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import System.FilePath +import Prelude hiding (head) + +-- | Converts a final (reduced) value with the given name into a +-- compiled package. +compile :: String -> Value () -> CompileResult +compile name' x + = case compile' name' x of + Failure () -> Failure $ NotFinal $ pprintStr x + Success out -> Success out + +-- | Whether a value is final. If so, it can be compiled. +-- Otherwise, if it can't be reduced anymore, it can't be compiled. +isFinal :: Value () -> Bool +isFinal = isSuccess . compile' dontForce + +-- | Converts a final (reduced) value with the given name into a +-- compiled package. +compile' :: String -> Value () -> UResult Package +compile' name' (Value () [part]) = compilePart name' part +compile' _ (Value () _) = Failure () + +compilePart :: String -> Part () -> UResult Package +compilePart name' (PartPrim prim) = Success $ compilePrim name' prim +compilePart name' (PartRecord record) = compileRecord name' record + +compilePrim :: String -> Prim () -> Package +compilePrim name' prim + = Package + { packageName = name' -<.> primExt prim + , packageContents = PackageFile $ encodePrim prim + } + +compileRecord :: String -> Record () -> UResult Package +compileRecord name' (Record () head' properties') + | head' == codeFSym = compileCode name' properties' + | otherwise = Failure () + +compileCode :: String -> [Property ()] -> UResult Package +compileCode name' props + = compileCode' name' + <$> (valToText =<< maybeToUResult (glookup codeLangSym props)) + <*> (valToText =<< maybeToUResult (glookup codeContentSym props)) + +compileCode' :: String -> Text -> Text -> Package +compileCode' name' lang content + = Package + { packageName = name' -<.> languageExt (Text.unpack lang) + , packageContents = PackageFile $ Text.encodeUtf8 content + } + +valToText :: Value () -> UResult Text +valToText (Value () [part]) = partToText part +valToText (Value () _) = Failure () + +partToText :: Part () -> UResult Text +partToText (PartPrim prim) = primToText prim +partToText (PartRecord _) = Failure () + +primToText :: Prim () -> UResult Text +primToText (PrimText () text) = Success text +primToText _ = Failure () diff --git a/src/Descript/BasicInj/Write/Diagnose.hs b/src/Descript/BasicInj/Write/Diagnose.hs new file mode 100644 --- /dev/null +++ b/src/Descript/BasicInj/Write/Diagnose.hs @@ -0,0 +1,30 @@ +-- | Generates diagnostics (errors, warnings, and useful information) +-- for Descript code. +module Descript.BasicInj.Write.Diagnose + ( diagnose + ) where + +import Descript.BasicInj.Process.Reduce +import Descript.BasicInj.Process.Validate +import Descript.BasicInj.Data +import Descript.Misc +import Data.Semigroup + +-- | Generates diagnostics for source. +diagnose :: (Ord an, Semigroup an) + => DirtyDepd Source an + -> [Diagnostic an] +diagnose ddsrc + = case validate ddsrc of + Failure probs -> map DiagProblem probs + Success dsrc -> diagnoseValid dsrc + +diagnoseValid :: Depd Source an -> [Diagnostic an] +diagnoseValid (Depd extra src) + = case src of + SourceModule _ -> [] + SourceProgram prog -> [interpretDiag $ Depd extra prog] + +interpretDiag :: Depd Program an -> Diagnostic an +interpretDiag dprog + = DiagEval (getAnn $ dquery dprog) (pprint $ interpret_ dprog) diff --git a/src/Descript/Build.hs b/src/Descript/Build.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build.hs @@ -0,0 +1,2 @@ +-- | Organizes all the build phases. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Build/Build.hs b/src/Descript/Build/Build.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Build.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MonoLocalBinds #-} + +-- | Organizes all the phases. +-- Allows builting and interpreting a program, without exposing any +-- particular phase information -- should maybe be 'Descript.Build.Interface'. +module Descript.Build.Build + ( compile + , eval + , interpret + ) where + +import Descript.Build.Error +import Descript.Build.Read +import qualified Descript.BasicInj.Data.Value.Reg as BasicInj +import qualified Descript.BasicInj as BasicInj +import Descript.Misc +import Data.Text (Text) +import Control.Monad +import Core.Control.Monad.Trans + +-- TODO In future versions, refine "output": +-- look at the reduced value. If it's a datum, output it. If it's a +-- compiled program, output it (maybe in a 'Compiled' structure). +-- Maybe if it's some other "datum"-y record types, output it. +-- + +-- | Parses, interprets, and compiles a source file. +compile :: (Monad u) => DFile u -> BuildResultT u Package +compile file = compileB file =<< interpret file + +compileB :: (Monad u) => DFile u -> BasicInj.Value () -> BuildResultT u Package +compileB file + = hoist . mapError BuildCompileError . BasicInj.compile (fileName file) + +-- | Parses, interprets, and prints a source file. +eval :: (Monad u) => DFile u -> BuildResultT u Text +eval = fmap pprint . interpret + +-- | Parses and interprets a source file. +interpret :: (Monad u) => DFile u -> BuildResultT u (BasicInj.Value ()) +interpret = interpretB . sourceToProgramB <=< validateB <=< readB + where interpretB = fmap BasicInj.interpret_ + sourceToProgramB = maybeToResultT BuildExpectedProgramError . traverse BasicInj.sourceToProgram + validateB = mapErrorT BuildValidateError . hoist . BasicInj.validate + readB = mapErrorT BuildParseError . readSrc diff --git a/src/Descript/Build/Cache.hs b/src/Descript/Build/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Cache.hs @@ -0,0 +1,5 @@ +-- | Keeps track of intermediate ASTs and applies updates. Unlike simple +-- actions, cached actions can be faster and use previous state to +-- understand "bad" ASTs. +-- Useful for complicated, changing processes like language servers. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Build/Cache/Error.hs b/src/Descript/Build/Cache/Error.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Cache/Error.hs @@ -0,0 +1,28 @@ +module Descript.Build.Cache.Error + ( CacheError (..) + , CacheWarning (..) + ) where + +import Descript.Build.Cache.FileCache +import Descript.Misc + +-- | An error obtained updating a cache. Prevents parts of the cache +-- from being updated. +-- +-- Note: 'CacheFileNotFound', 'CachePatchBeforeText', and +-- 'CachePatchBeforeText' are internal errors caused by a bad request. +-- The others are user errors which could appear even when the IDE is +-- working properly. +data CacheError + = CacheFileNotFound + | CachePatchBeforeText + | CacheRefactorBeforeParse + | CacheParseError FileCache (ParseError Char) + | CacheRefactorError FileCache RefactorError + deriving (Eq, Read, Show) + +-- | A warning obtained updating a cache. Allows the delegate to cancel +-- the update, but also allows it to continue. +data CacheWarning + = CacheRefactorWarning FileCache [RefactorWarning] + deriving (Eq, Ord, Read, Show) diff --git a/src/Descript/Build/Cache/FileCache.hs b/src/Descript/Build/Cache/FileCache.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Cache/FileCache.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE Rank2Types #-} + +module Descript.Build.Cache.FileCache + ( FileVersion + , FileCache (..) + , FileUpdate (..) + , newFileCache + , dateFileCache + , updateFileCache + , prepareFileCache + ) where + +import Descript.Build.Cache.PhaseCache +import qualified Descript.Sugar as Sugar +import qualified Descript.BasicInj as BasicInj +import qualified Descript.Free as Free +import qualified Descript.Lex as Lex +import Descript.Misc +import Core.Data.Functor +import Data.Text (Text) + +{- -- | Annotation for a cached node. +data CacheAnn + = CacheAnn + { cacheAnnUpdated :: Bool + , cacheAnnSrc :: SrcAnn + } -} + +type FileVersion = Int + +-- | Contains cached ASTs for a single file. +-- +-- These ASTs are annotated with ranges, not full source info, because +-- they're in sync, so by definition they can't be tainted (maybe in the +-- future, when they need to be updated, the parts which need to be +-- updated will be "tainted", but might just make 'CacheAnn' instead). +data FileCache + = FileCache + { fileVersion :: FileVersion + , srcText :: PhaseCache Text + , srcLex :: PhaseCache [Lex.Lex Range] + , srcFree :: PhaseCache [Free.TopLevel Range] + , srcSugar :: PhaseCache (Sugar.Source Range) + , srcBasicInj :: PhaseCache (BasicInj.DirtyDepd BasicInj.Source Range) + } deriving (Eq, Ord, Read, Show) + +data FileUpdate + = UpdateText Text (Maybe Patch) + | UpdateLex [Lex.Lex SrcAnn] + | UpdateFree [Free.TopLevel SrcAnn] + | UpdateSugar (Sugar.Source SrcAnn) + | UpdateBasicInj (BasicInj.DirtyDepd BasicInj.Source SrcAnn) + deriving (Eq, Ord, Read, Show) + +-- | Creates a cache with no data, which needs to be updated. +newFileCache :: FileVersion -> FileCache +newFileCache ver + = FileCache + { fileVersion = ver + , srcText = newPhaseCache + , srcLex = newPhaseCache + , srcFree = newPhaseCache + , srcSugar = newPhaseCache + , srcBasicInj = newPhaseCache + } + +-- | Signals that every part of the cache needs to be updated, and gives +-- it the new version. +dateFileCache :: FileVersion -> FileCache -> FileCache +dateFileCache nver x + = FileCache + { fileVersion = nver + , srcText = datePhaseCache $ srcText x + , srcLex = datePhaseCache $ srcLex x + , srcFree = datePhaseCache $ srcFree x + , srcSugar = datePhaseCache $ srcSugar x + , srcBasicInj = datePhaseCache $ srcBasicInj x + } + +-- | Updates the phase in the cache specified by the update. +updateFileCache :: FileUpdate -> FileCache -> FileCache +updateFileCache (UpdateText new _) x + = x{ srcText = updatePhaseCache new } +updateFileCache (UpdateLex new) x + = x{ srcLex = updatePhaseCache $ srcRange <<$>> new } +updateFileCache (UpdateFree new) x + = x{ srcFree = updatePhaseCache $ srcRange <<$>> new } +updateFileCache (UpdateSugar new) x + = x{ srcSugar = updatePhaseCache $ srcRange <$> new } +updateFileCache (UpdateBasicInj new) x + = x{ srcBasicInj = updatePhaseCache $ mapDirtyDepdAnn srcRange new } + +-- | Modifies phases after the cache to adjust for the given update, +-- without fully updating them. +prepareFileCache :: FileUpdate -> FileCache -> FileCache +prepareFileCache (UpdateText _ patchOpt) + = case patchOpt of + Nothing -> invalidateCacheASTs + Just patch -> alignCacheASTs patch +prepareFileCache _ = id + +invalidateCacheASTs :: FileCache -> FileCache +invalidateCacheASTs cache + = FileCache + { fileVersion = fileVersion cache + , srcText = srcText cache + , srcLex = newPhaseCache + , srcFree = newPhaseCache + , srcSugar = newPhaseCache + , srcBasicInj = newPhaseCache + } + +alignCacheASTs :: Patch -> FileCache -> FileCache +alignCacheASTs patch cache + = FileCache + { fileVersion = fileVersion cache + , srcText = srcText cache + , srcLex = alignRange patch <<<$>>> srcLex cache + , srcFree = alignRange patch <<<$>>> srcFree cache + , srcSugar = alignRange patch <<$>> srcSugar cache + , srcBasicInj = mapDirtyDepdAnn (alignRange patch) <$> srcBasicInj cache + } diff --git a/src/Descript/Build/Cache/GlobalCache.hs b/src/Descript/Build/Cache/GlobalCache.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Cache/GlobalCache.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE ApplicativeDo #-} + +module Descript.Build.Cache.GlobalCache + ( GlobalCache + , CacheDelegate (..) + , newGlobalCache + , addFile + , delFile + , changeFile + , refactorFile + ) where + +import Descript.Build.Cache.FileCache +import Descript.Build.Cache.PhaseCache +import Descript.Build.Cache.Error +import Descript.Build.Read +import qualified Descript.BasicInj as BasicInj +import qualified Descript.Sugar as Sugar +import qualified Descript.Free as Free +import qualified Descript.Lex as Lex +import Descript.Misc +import Core.Data.Functor +import Data.Text (Text) +import qualified Data.HashTable.IO as HashTable +import Control.Monad +import Control.Monad.IO.Class +import System.FilePath + +type HashTable k v = HashTable.BasicHashTable k v + +-- | Contains cached ASTs, which are keyed by file paths or URIs +-- (presumably to the file on disk where thhey're located). +-- This caches multiple ASTs, and it can handle as many as needed - a +-- directory, a workspace, or even multiple workspaces. +newtype GlobalCache = GlobalCache (HashTable FilePath FileCache) + +-- | Gets called whenever a cache is updated. +data CacheDelegate io + = CacheDelegate + { onUpdateFile :: FileUpdate -> FileCache -> io () + , onWarning :: CacheWarning -> io () -> io () + , onError :: CacheError -> io () + } + +newGlobalCache :: (MonadIO io) => io GlobalCache +newGlobalCache = liftIO $ GlobalCache <$> HashTable.new + +-- | Note: if a file already existed at the path, replaces it, +-- invalidating its cached AST. +addFile :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileVersion + -> Text + -> GlobalCache + -> io () +addFile delegate path nver text (GlobalCache files) = do + let update = UpdateText text Nothing + file <- updateFileCascade delegate path update $ newFileCache nver + liftIO $ HashTable.insert files path file + +delFile :: (MonadIO io) => FilePath -> GlobalCache -> io () +delFile path (GlobalCache files) = liftIO $ HashTable.delete files path + +-- | Applies the update, then applies cascading updates. +-- Notifies the delegate of every update, including this one. +updateFile :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileVersion + -> FileUpdate + -> GlobalCache + -> io () +updateFile delegate path nver update (GlobalCache files) = do + oldOpt <- liftIO $ HashTable.lookup files path + case oldOpt of + Nothing -> onError delegate CacheFileNotFound + Just old -> do + new <- updateFileCascade delegate path update $ dateFileCache nver old + liftIO $ HashTable.insert files path new + +-- | Applies the given update, then applies cascading updates. +-- Notifies the delegate of every update, including this one. +updateFileCascade :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileUpdate + -> FileCache + -> io FileCache +updateFileCascade delegate path update old = do + let new = updateFileCache update old + onUpdateFile delegate update new + cascadeUpdateFile delegate path update new + +-- | Updates other parts of the file to match the part which was +-- updated. For example, if the text was updated, will update ASTs. +-- If an AST was updated, will update the text and other ASTs. +-- The delegate will be notified of each update. +cascadeUpdateFile :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileUpdate + -> FileCache + -> io FileCache +cascadeUpdateFile delegate path update + = cascadeUpdateFileFwd delegate path update + <=< cascadeUpdateFileBwd delegate path update + +-- | Updates more complex ASTs (text -> lex -> free -> ...). +-- Assumes simpler ASTs are updated, so they can be re-used. +cascadeUpdateFileFwd :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileUpdate + -> FileCache + -> io FileCache +cascadeUpdateFileFwd delegate path update + = cascadeUpdateFileFwdFull delegate path update + . prepareFileCache update + +cascadeUpdateFileFwdFull :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileUpdate + -> FileCache + -> io FileCache +cascadeUpdateFileFwdFull delegate path (UpdateText new _) x + | phaseCacheUpdated $ srcLex x = pure x + | otherwise + = case Lex.parse file of + Failure err -> x <$ onError delegate (CacheParseError x err) + Success next -> updateFileCascadeFwd delegate path update x + where update = UpdateLex $ parsedSrcAnn <<$>> next + where file = mkSFile path new +cascadeUpdateFileFwdFull delegate path (UpdateLex _) x + | phaseCacheUpdated $ srcFree x = pure x + | otherwise + = case Free.parse file new of + Failure err -> x <$ onError delegate (CacheParseError x err) + Success next -> updateFileCascadeFwd delegate path update x + where update = UpdateFree $ parsedSrcAnn <<$>> next + where file = mkSFile path $ forceGetPhaseCache $ srcText x + new = forceGetPhaseCache $ srcLex x -- Doesn't use 'SrcAnn' +cascadeUpdateFileFwdFull delegate path (UpdateFree _) x + | phaseCacheUpdated $ srcSugar x = pure x + | otherwise + = case Sugar.parse file new of + Failure err -> x <$ onError delegate (CacheParseError x err) + Success next -> updateFileCascadeFwd delegate path update x + where update = UpdateSugar $ parsedSrcAnn <$> next + where file = mkSFile path $ forceGetPhaseCache $ srcText x + new = forceGetPhaseCache $ srcFree x -- Doesn't use 'SrcAnn' +cascadeUpdateFileFwdFull delegate path (UpdateSugar _) x + | phaseCacheUpdated $ srcBasicInj x = pure x + | otherwise = do + let new = forceGetPhaseCache $ srcSugar x -- Doesn't use 'SrcAnn' + new' = parsedSrcAnn <$> new + rsvr = defaultResolver $ takeDirectory path + ddep <- liftIO $ runDirtyT $ BasicInj.extraModule rsvr $ Sugar.sourceImportCtx new' + let dep = dirtyVal ddep + nextSrc = Sugar.refine dep new' + next = Depd ddep nextSrc + update = UpdateBasicInj next + updateFileCascadeFwd delegate path update x +cascadeUpdateFileFwdFull _ _ (UpdateBasicInj _) x = pure x + +-- | Updates simpler ASTs (... -> free -> lex -> text). +-- Doesn't assume more complex ASTs are updated. +cascadeUpdateFileBwd :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileUpdate + -> FileCache + -> io FileCache +cascadeUpdateFileBwd _ _ (UpdateText _ _) x = pure x +cascadeUpdateFileBwd delegate path (UpdateLex new) x + = updateFileCascadeFwd delegate path (UpdateText prev $ Just patch) x + where prev + = case phaseCached $ srcText x of + Nothing -> pprintF new + Just cachedPrev -> patch `apPatch` cachedPrev + patch = ppatchF new +cascadeUpdateFileBwd delegate path (UpdateFree new) x + = updateFileCascadeFwd delegate path (UpdateText prev $ Just patch) x + where prev + = case phaseCached $ srcText x of + Nothing -> pprintF new + Just cachedPrev -> patch `apPatch` cachedPrev + patch = ppatchF new +cascadeUpdateFileBwd delegate path (UpdateSugar new) x + = updateFileCascadeFwd delegate path (UpdateText prev $ Just patch) x + where prev + = case phaseCached $ srcText x of + Nothing -> pprint new + Just cachedPrev -> patch `apPatch` cachedPrev + patch = ppatch new +cascadeUpdateFileBwd delegate path (UpdateBasicInj new) x + = updateFileCascadeFwd delegate path (UpdateText prev $ Just patch) x + where prev + = case phaseCached $ srcText x of + Nothing -> pprint newSrc + Just cachedPrev -> patch `apPatch` cachedPrev + patch = ppatch newSrc + newSrc = depdVal new + +-- | Applies the given update, then applies forward cascading updates. +-- Notifies the delegate of all updates before they're applied. +updateFileCascadeFwd :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileUpdate + -> FileCache + -> io FileCache +updateFileCascadeFwd delegate path update old = do + let new = updateFileCache update old + onUpdateFile delegate update new + cascadeUpdateFileFwd delegate path update new + +-- | Updates other parts of the file based on an individual change. +-- If the change is a patch, Assumes the cached file already has +-- previously updated text (otherwise it couldn't be patched). +changeFile :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileVersion + -> Change + -> GlobalCache + -> io () +changeFile delegate path nver (Left newText) + = replaceFile delegate path nver newText +changeFile delegate path nver (Right patch) + = patchFile delegate path nver patch + +replaceFile :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileVersion + -> Text + -> GlobalCache + -> io () +replaceFile delegate path nver new + = updateFile delegate path nver $ UpdateText new Nothing + +-- | Updates other parts of the file based on the given part being +-- updated. Assumes the cached file already has previously updated text. +patchFile :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> FileVersion + -> Patch + -> GlobalCache + -> io () +patchFile delegate path nver patch (GlobalCache files) = do + oldOpt <- liftIO $ HashTable.lookup files path + case oldOpt of + Nothing -> onError delegate CacheFileNotFound + Just old + | not $ phaseCacheUpdated $ srcText old -> + onError delegate CachePatchBeforeText + | otherwise -> do + let oldText = forceGetPhaseCache $ srcText old + newText = patch `apPatch` oldText + update = UpdateText newText $ Just patch + new <- updateFileCascade delegate path update $ dateFileCache nver old + liftIO $ HashTable.insert files path new + +-- | Applies the refactor, then updates other ASTs. +refactorFile :: (MonadIO io) + => CacheDelegate io + -> FilePath + -> RefactorFunc BasicInj.Source + -> GlobalCache + -> io () +refactorFile delegate path refactor (GlobalCache files) = do + oldOpt <- liftIO $ HashTable.lookup files path + case oldOpt of + Nothing -> onError delegate CacheFileNotFound + Just old + | not $ phaseCacheUpdated $ srcBasicInj old -> + onError delegate CacheRefactorBeforeParse + | otherwise -> do + let Depd ddep oldBasicInjSrc + = mapDirtyDepdAnn parsedSrcAnn + $ forceGetPhaseCache + $ srcBasicInj old + Dirty warns res = runDirtyRes $ refactor oldBasicInjSrc + case res of + Failure err -> onError delegate $ CacheRefactorError old err + Success newBasicInjSrc + | not $ null warns -> onWarning delegate warning continue + | otherwise -> continue + where continue = do + onUpdateFile delegate update old' + new <- updateFileCascade delegate path update old' + liftIO $ HashTable.insert files path new + update = UpdateBasicInj newBasicInj + warning = CacheRefactorWarning old warns + newBasicInj = Depd ddep newBasicInjSrc + old' = dateFileCache (fileVersion old) old diff --git a/src/Descript/Build/Cache/PhaseCache.hs b/src/Descript/Build/Cache/PhaseCache.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Cache/PhaseCache.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +module Descript.Build.Cache.PhaseCache + ( PhaseCache (..) + , newPhaseCache + , datePhaseCache + , updatePhaseCache + , forceGetPhaseCache + ) where + +-- | A cached AST or text for a single phase. +data PhaseCache a + = PhaseCache + { phaseCacheUpdated :: Bool -- ^ Whether 'phaseCached' is updated. + , phaseCached :: Maybe a -- ^ The last-updated version. + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Creates a cache with no data, which needs to be updated. +newPhaseCache :: PhaseCache a +newPhaseCache = PhaseCache False Nothing + +-- | Notifies that the cache needs to be updated. +datePhaseCache :: PhaseCache a -> PhaseCache a +datePhaseCache (PhaseCache _ x) = PhaseCache False x + +-- | Creates an updated cache for the given (updated) phase. +updatePhaseCache :: a -> PhaseCache a +updatePhaseCache x = PhaseCache True $ Just x + +-- | Asserts the cache is updated, and gets its phase. +forceGetPhaseCache :: PhaseCache a -> a +forceGetPhaseCache (PhaseCache updated cached) + | not updated = error "forceGetPhaseCache: cache not updated" + | otherwise + = case cached of + Nothing -> error "forceGetPhaseCache: bad state - updated but no phase" + Just x -> x diff --git a/src/Descript/Build/Error.hs b/src/Descript/Build/Error.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Error.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Organizes build results. +module Descript.Build.Error + ( BuildError (..) + , BuildResult + , BuildResultT + ) where + +import Descript.Misc +import Data.Semigroup + +-- | Any type of build error. +data BuildError + = BuildParseError (ParseError Char) + | BuildExpectedProgramError + | BuildValidateError [Problem SrcAnn] + | BuildCompileError CompileError + deriving (Eq, Read, Show) + +-- | A final result from building (parsing, interpreting, and +-- outputting) a source. If the build succeeded, contains the output. +-- If the build failed, contains the error. +type BuildResult a = Result BuildError a + +-- | A stacked 'BuildResult'. +type BuildResultT u a = ResultT BuildError u a + +-- | When combined, takes the earlier error. +instance Semigroup BuildError where + BuildParseError x <> BuildParseError y = BuildParseError $ x <> y + BuildParseError x <> _ = BuildParseError x + BuildExpectedProgramError <> _ = BuildExpectedProgramError + BuildValidateError xs <> BuildValidateError ys = BuildValidateError $ xs <> ys + BuildValidateError xs <> _ = BuildValidateError xs + BuildCompileError x <> _ = BuildCompileError x + +instance FileSummary BuildError where + summaryF file (BuildParseError err) = parseErrorSummary file err + summaryF _ BuildExpectedProgramError = "expected a program, given a module" + summaryF _ (BuildValidateError probs) = validateErrorSummary probs + summaryF _ (BuildCompileError err) = "compile error: " ++ summary err diff --git a/src/Descript/Build/Read.hs b/src/Descript/Build/Read.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Read.hs @@ -0,0 +1,3 @@ +-- | Generate a source AST which can be processed. Used by other build +-- functions. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Build/Read/File.hs b/src/Descript/Build/Read/File.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Read/File.hs @@ -0,0 +1,60 @@ +module Descript.Build.Read.File + ( mkFile + , loadFile + , defaultResolver + ) where + +import Descript.Build.Read.Read +import qualified Descript.BasicInj as BasicInj +import Descript.Misc +import Data.Text (Text) +import qualified Data.Text.IO as Text +import Core.Control.Monad.Trans +import System.FilePath + +-- | Creates a file with the given path and contents, which uses the +-- default resolver. +mkFile :: FilePath -> Text -> DFile IO +mkFile = mkDepFile [] + +-- | Creates a file with the given path and contents, which uses the +-- default resolver, provided that this is a dependency of the given +-- modules. +mkDepFile :: [RelScope] -> FilePath -> Text -> DFile IO +mkDepFile dpds path contents + = DFile + { depResolver = defaultDepResolver dpds $ takeDirectory path + , sfile = mkSFile path contents + } + +-- | Reads the file with the given path. +loadFile :: FilePath -> IO (DFile IO) +loadFile path = mkFile path <$> Text.readFile path + +defaultResolver :: FilePath -> DepResolver IO +defaultResolver = defaultDepResolver [] + +-- | The default resolver for a dependency of the given modules. +defaultDepResolver :: [RelScope] -> FilePath -> DepResolver IO +defaultDepResolver dpds path + = readDepResolver dpds path =<< defaultTextResolver path + +readDepResolver :: [RelScope] -> FilePath -> Text -> DepResolver IO +readDepResolver dpds basePath contents + = DepResolver + { showDepResolver = "readDepResolver " ++ show basePath ++ show contents + , resolveDep = resolve + } + where resolve relScope = do + guardCycleT relScope dpds + readDep (relScope : dpds) (scopeFilepath basePath relScope) contents + +readDep :: [RelScope] -> FilePath -> Text -> DepResultT IO +readDep dpds path contents + = fmap BasicInj.dsourceAModule . validateR =<< readSrcR file + where readSrcR = gresToDres (summaryF $ sfile file) . readSrc + validateR ddsrc = do + guardPromoteCycleT $ dirtyWarnings $ depdDep ddsrc + gresToDres validateErrorSummary $ hoist $ BasicInj.validate ddsrc + gresToDres summary' = mapErrorT $ DepNotBuild . summary' + file = mkDepFile dpds path contents diff --git a/src/Descript/Build/Read/Parse.hs b/src/Descript/Build/Read/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Read/Parse.hs @@ -0,0 +1,58 @@ +-- | Organizes and combines all the parse phases. +module Descript.Build.Read.Parse + ( parse + , parseTest + , parseInputVal + , parseOutputVal + ) where + +import qualified Descript.Sugar.Data.Value.In as Sugar.In +import qualified Descript.Sugar.Data.Value.Out as Sugar.Out +import qualified Descript.Sugar as Sugar +import qualified Descript.Free as Free +import qualified Descript.Lex as Lex +import Descript.Misc +import Control.Arrow + +-- | Parses a source file. +parse :: SFile -> ParseResult (Sugar.Source SrcAnn) +parse file + = fmap fixAnn + . Sugar.parse file + =<< Free.parse file + =<< Lex.parse file + +-- | Parses a source file, inspecting each phase and discarding the +-- inspection result. The first string is the literal name of the phase, +-- the second contains its reduce print and summary. Useful for testing +-- phases. +parseTest :: (Monad w) + => SFile + -> (String -> ParseResult (String, String) -> w ()) + -> ParseResultT w (Sugar.Source SrcAnn) +parseTest file test + = fmap fixAnn + . phase "Sugar" Sugar.parse reducePrint + =<< phase "Free" Free.parse reducePrintF + =<< phase "Lex" Lex.parse_ reducePrintF () + where phase name' parse' reducePrint' prev = ResultT $ do + let next = parse' file prev + test name' $ mapSuccess (reducePrint' &&& summary) next + pure next + +parseInputVal :: SFile -> ParseResult (Sugar.In.Value SrcAnn) +parseInputVal file + = fmap fixAnn + . Sugar.parseInputVal file + =<< Free.parseValue file + =<< Lex.parse file + +parseOutputVal :: SFile -> ParseResult (Sugar.Out.Value SrcAnn) +parseOutputVal file + = fmap fixAnn + . Sugar.parseOutputVal file + =<< Free.parseValue file + =<< Lex.parse file + +fixAnn :: (Ann wr) => wr Range -> wr SrcAnn +fixAnn = fmap parsedSrcAnn diff --git a/src/Descript/Build/Read/Read.hs b/src/Descript/Build/Read/Read.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Read/Read.hs @@ -0,0 +1,67 @@ +module Descript.Build.Read.Read + ( Dep + , DepResult + , DepResultT + , DirtyDep + , DirtyDepT + , Depd + , DirtyDepd + , DepResolver + , DFile + , readSrc + , readInputValIn + , readOutputValIn + ) where + +import Descript.Build.Read.Parse +import qualified Descript.BasicInj.Data.Value.In as BasicInj.In +import qualified Descript.BasicInj.Data.Value.Out as BasicInj.Out +import qualified Descript.BasicInj as BasicInj +import qualified Descript.Sugar as Sugar +import Descript.Misc +import Core.Control.Monad.Trans +import Control.Monad.Trans.Class + +-- Note: If there are multiple dependency requiring values, replace with +-- custom @Gen...@ instances which contain all those values as +-- dependencies. Create a wrapper for 'BasicInj.validate' which takes +-- all the dependencies dirty, passes the 'BasicInj' dependencies to +-- 'BasicInj.validate', and returns the (ok) result with all of the +-- dependencies but removes the dirty wrapper (probably reimplement +-- 'BasicInj.validate's control structure and call 'BasicInj.validate'' +-- directly). + +type Dep = BasicInj.Dep +type DepResult = BasicInj.DepResult +type DepResultT u = BasicInj.DepResultT u +type DirtyDep an = BasicInj.DirtyDep an +type DirtyDepT an u = BasicInj.DirtyDepT an u +type Depd a an = BasicInj.Depd a an +type DirtyDepd a an = BasicInj.DirtyDepd a an +type DepResolver u = BasicInj.DepResolver u +type DFile u = BasicInj.DFile u + +-- | Parses source, resolves its dependencies, and refines it. +readSrc :: (Monad u) + => DFile u + -> ParseResultT u (DirtyDepd BasicInj.Source SrcAnn) +readSrc (DFile rsvr sfile') + = refineR =<< resolveR rsvr =<< parseR sfile' + where refineR = pure . Sugar.refineDDepd + resolveR rsvr' = lift . Sugar.resolve rsvr' + parseR = hoist . parse + +readInputValIn :: AbsScope + -> BasicInj.RecordCtx () + -> SFile + -> ParseResult (BasicInj.In.Value SrcAnn) +readInputValIn scope ctx + = fmap (Sugar.refineInputValIn scope ctx) . parseInputVal + +readOutputValIn :: AbsScope + -> BasicInj.RecordCtx () + -> BasicInj.In.Value () + -> SFile + -> ParseResult (BasicInj.Out.Value SrcAnn) +readOutputValIn scope ctx in' + = fmap (Sugar.refineOutputValIn scope ctx in') . parseOutputVal diff --git a/src/Descript/Build/Refactor.hs b/src/Descript/Build/Refactor.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Build/Refactor.hs @@ -0,0 +1,91 @@ +module Descript.Build.Refactor + ( RefactorAction (..) + , parseRefactor + , parseRefactorAction + , refactor + ) where + +import Descript.Build.Read +import qualified Descript.BasicInj as BasicInj +import Descript.Misc +import qualified Data.Text as Text +import Control.Monad +import Core.Control.Monad.Trans +import Control.Monad.Trans.Class + +data RefactorAction + = RenameRecord String String + | RenameProp String String String + | RefactorReduce String String + deriving (Eq, Ord, Read, Show) + +-- | Parses a refactor action from command-line arguments, +-- then runs the action. +parseRefactor :: (Monad u) + => String + -> [String] + -> DFile u + -> RefactorResultT u Patch +parseRefactor label args file + = (`refactor` file) + =<< hoist (parseRefactorAction label args) + +-- | Parses a refactor action from command-line arguments. +-- The string is the action label, the list contains the args. +parseRefactorAction :: String -> [String] -> Result RefactorError RefactorAction +parseRefactorAction "rename-record" [old, new] + = Success $ RenameRecord old new +parseRefactorAction "rename-record" args + = Failure $ BadRefactorArgs "rename-record" 2 args +parseRefactorAction "rename-property" [head', old, new] + = Success $ RenameProp head' old new +parseRefactorAction "rename-property" args + = Failure $ BadRefactorArgs "rename-property" 3 args +parseRefactorAction "reduce" [old, new] + = Success $ RefactorReduce old new +parseRefactorAction "reduce" args + = Failure $ BadRefactorArgs "reduce" 2 args +parseRefactorAction label args + = Failure $ UnsupportedRefactorAction label args + +-- | Parses a source file, refactors it, and returns a patch to update +-- the original file. +refactor :: (Monad u) => RefactorAction -> DFile u -> RefactorResultT u Patch +refactor (RenameRecord old new) file + = refactorViaBasic (BasicInj.renameRecord old new) file +refactor (RenameProp head' old new) file + = refactorViaBasic (BasicInj.renameProp head' old new) file +refactor (RefactorReduce old new) file = do + Depd ddep src <- presToRRes Nothing $ readSrc file + let dep = dirtyVal ddep + dsrc = Depd dep src + scope = BasicInj.sourceScope src + ctx = BasicInj.recordCtx $ BasicInj.dsourceAModule dsrc + old' <- refIRead (readInputValIn scope ctx) $ ifile $ Text.pack old + let old_ = remAnns old' + new' <- refIRead (readOutputValIn scope ctx old_) $ ifile $ Text.pack new + refactorViaBasic (BasicInj.refactorReduce ddep old' new') file + +refactorViaBasic :: (Monad u) + => RefactorFunc BasicInj.Source + -> DFile u + -> RefactorResultT u Patch +refactorViaBasic f = refactorViaBasicT $ rehoist . f + +refactorViaBasicT :: (Monad u) + => RefactorFuncT u BasicInj.Source + -> DFile u + -> RefactorResultT u Patch +refactorViaBasicT f = fmap ppatch . f . depdVal <=< refRead + +refRead :: (Monad u) => DFile u -> RefactorResultT u (DirtyDepd BasicInj.Source SrcAnn) +refRead = presToRRes Nothing . readSrc + +refIRead :: (Monad u) + => (SFile -> ParseResult a) + -> SFile + -> RefactorResultT u a +refIRead readSrc' isrc = presToRRes (Just isrc) $ hoist $ readSrc' isrc + +presToRRes :: (Monad u) => Maybe SFile -> ParseResultT u a -> RefactorResultT u a +presToRRes isrc = mapInner lift . mapErrorT (RefactorParseError isrc) diff --git a/src/Descript/Fast.hs b/src/Descript/Fast.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Fast.hs @@ -0,0 +1,3 @@ +-- | Fast implementation - efficient but complicated and unchecked (or +-- maybe partially checked...). +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Fast/Reduce.hs b/src/Descript/Fast/Reduce.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Fast/Reduce.hs @@ -0,0 +1,35 @@ +-- | Reudction algorithm. +module Descript.Fast.Reduce + ( reduce + , reduceOnce ) where + +import Descript.BasicInj.Data.Reducer +import Descript.BasicInj.Data.Value.Reg +import Descript.Misc.Error + +-- | A context's reducers organized so they can quickly be found when needed. +data FastReduceCtx + +-- | Organizes the reducers to they can be found quicker when reducing a value. +optimizeReduceCtx :: ReduceCtx () -> FastReduceCtx +optimizeReduceCtx = undefined + +----- + +-- | Applies the context's reducers to the value, until they can't +-- be applied anymore. +reduce :: ReduceCtx () -> Value () -> Value () +reduce ctx value = reduce' (optimizeReduceCtx ctx) value + +-- | Applies the context's reducers to the value, until they can't +-- be applied anymore. +reduce' :: FastReduceCtx -> Value () -> Value () +reduce' ctx value + = case reduceOnce ctx value of + Success next -> reduce' ctx next + Failure () -> value + +-- | Applies the context's reducers to the value once, returning a new +-- value if it reduced, or a failure if it couldn't be reduced at all. +reduceOnce :: FastReduceCtx -> Value () -> UResult (Value ()) +reduceOnce = undefined diff --git a/src/Descript/Free.hs b/src/Descript/Free.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Free.hs @@ -0,0 +1,5 @@ +-- | Free grammar - can represent a lot of expressions, including +-- badly-formed ones. Expressions are "free" because they're later +-- refined to more restrictive types - for example, "free" values can be +-- refined to input values, output values, regular values, or record types. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Free/Data.hs b/src/Descript/Free/Data.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Free/Data.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Defines "free" versions of datatypes, which are very general, and +-- can be refined to more constrained, specific datatypes. +module Descript.Free.Data + ( module Descript.Free.Data.Import + , module Descript.Free.Data.Atom + , Property (..) + , Record (..) + , Part (..) + , Value (..) + , ValueRefinement (..) + , RecordDecl (..) + , Reducer (..) + , Query (..) + , TopLevel (..) + , mkTopLevel + , topLevelToModuleDecl + , topLevelToImportDecl + , topLevelToRecordDecl + , topLevelToReducer + , topLevelIsPhaseSep + , topLevelToQuery + , valueToPropKey + ) where + +import Prelude hiding (head) +import Descript.Free.Data.Import +import Descript.Free.Data.Atom +import Descript.Misc +import Data.Monoid +import Data.List.NonEmpty (NonEmpty (..)) + +-- | A free property. Can be refined into a property declaration for a +-- record type (as just a key), or an actual property (as a define). +data Property an + = PropertySingle (Value an) + | PropertyDef an (Symbol an) (Value an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A free record. Can be refined into a regular record, or a record type. +data Record an + = Record + { recordAnn :: an + , head :: Symbol an + , properties :: [Property an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A free part. Can be refined into a regular part, input part, or +-- output part. +data Part an + = PartPrim (Prim an) + | PartRecord (Record an) + | PartPropPath (PropPath an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A free value. Can be refined into a regular value, input value, or +-- output value. +data Value an + = Value an [Part an] + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Converts a value into a top-level declaration. +-- Useful for parsing - parse a value, then a refinement. +data ValueRefinement an + = ToRecordDecl -- ^ Refine into a record type declaration. + -- | Refine into a reducer with the given output, + -- where the value being converted is the input. + | ToReducer (Value an) + | ToQuery -- ^ Refine into a query. + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Declares a record type to be used in values. +data RecordDecl an + = RecordDecl an (Value an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A reducer. It takes a value and converts it into a new value. +-- Programs are interpreted/compiled by taking values and reducing them - +-- the program starts with a value representing a question or source +-- code, and reducers convert this value into the answer or compiled code. +-- This is like a function, or even better, an implicit conversion. +data Reducer an + = Reducer + { reducerAnn :: an + , input :: Value an + , output :: Value an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Declares a program's query. +data Query an + = Query an (Value an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A top-level declaration in source. +data TopLevel an + = TopLevelModuleDecl (ModuleDecl an) + | TopLevelImportDecl (ImportDecl an) + | TopLevelRecordDecl (RecordDecl an) + | TopLevelReducer (Reducer an) + | TopLevelPhaseSep an + | TopLevelQuery (Query an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Ann TopLevel where + getAnn (TopLevelModuleDecl x) = getAnn x + getAnn (TopLevelImportDecl x) = getAnn x + getAnn (TopLevelRecordDecl x) = getAnn x + getAnn (TopLevelReducer x) = getAnn x + getAnn (TopLevelPhaseSep ann) = ann + getAnn (TopLevelQuery x) = getAnn x + +instance Ann RecordDecl where + getAnn (RecordDecl ann _) = ann + +instance Ann Reducer where + getAnn = reducerAnn + +instance Ann Query where + getAnn (Query ann _) = ann + +instance Ann Value where + getAnn (Value ann _) = ann + +instance Ann Part where + getAnn (PartPrim x) = getAnn x + getAnn (PartRecord x) = getAnn x + getAnn (PartPropPath x) = getAnn x + +instance Ann Record where + getAnn = recordAnn + +instance Ann Property where + getAnn (PropertySingle x) = getAnn x + getAnn (PropertyDef ann _ _) = ann + +instance Printable TopLevel where + aprintRec sub (TopLevelModuleDecl decl) = sub decl + aprintRec sub (TopLevelImportDecl decl) = sub decl + aprintRec sub (TopLevelRecordDecl decl) = sub decl + aprintRec sub (TopLevelReducer reducer) = sub reducer + aprintRec _ (TopLevelPhaseSep _) = "---" + aprintRec sub (TopLevelQuery query) = sub query + +instance Printable RecordDecl where + aprintRec sub (RecordDecl _ recordType) = sub recordType <> "." + +instance Printable Reducer where + aprintRec sub reducer = sub (input reducer) <> ": " <> sub (output reducer) + +instance Printable Query where + aprintRec sub (Query _ value) = sub value <> "?" + +instance Printable Value where + aprintRec sub (Value _ parts) = pintercal " | " $ map sub parts + +instance Printable Part where + aprintRec sub (PartPrim prim) = sub prim + aprintRec sub (PartRecord record) = sub record + aprintRec sub (PartPropPath path) = sub path + +instance Printable Record where + aprintRec sub record = sub (head record) <> propsPrinted + where propsPrinted = "[" <> pintercal ", " propPrinteds <> "]" + propPrinteds = map sub $ properties record + +instance Printable Property where + aprintRec sub (PropertySingle x) = sub x + aprintRec sub (PropertyDef _ key val) = sub key <> ": " <> sub val + +instance (Show an) => Summary (TopLevel an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (RecordDecl an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Reducer an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Query an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Value an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Part an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Record an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Property an) where + summaryRec = pprintSummaryRec + +-- | Creates a top-level declaration, which starts with the given value +-- and then has the given refinement. +mkTopLevel :: an -> Value an -> ValueRefinement an -> TopLevel an +mkTopLevel ann val ToRecordDecl = TopLevelRecordDecl $ RecordDecl ann val +mkTopLevel ann val (ToReducer out) = TopLevelReducer $ Reducer ann val out +mkTopLevel ann val ToQuery = TopLevelQuery $ Query ann val + +topLevelToModuleDecl :: TopLevel an -> Maybe (ModuleDecl an) +topLevelToModuleDecl (TopLevelModuleDecl decl) = Just decl +topLevelToModuleDecl _ = Nothing + +topLevelToImportDecl :: TopLevel an -> Maybe (ImportDecl an) +topLevelToImportDecl (TopLevelImportDecl decl) = Just decl +topLevelToImportDecl _ = Nothing + +topLevelToRecordDecl :: TopLevel an -> Maybe (RecordDecl an) +topLevelToRecordDecl (TopLevelRecordDecl decl) = Just decl +topLevelToRecordDecl _ = Nothing + +topLevelToReducer :: TopLevel an -> Maybe (Reducer an) +topLevelToReducer (TopLevelReducer reducer) = Just reducer +topLevelToReducer _ = Nothing + +topLevelIsPhaseSep :: TopLevel an -> Bool +topLevelIsPhaseSep (TopLevelPhaseSep _) = True +topLevelIsPhaseSep _ = False + +topLevelToQuery :: TopLevel an -> Maybe (Query an) +topLevelToQuery (TopLevelQuery query') = Just query' +topLevelToQuery _ = Nothing + +valueToPropKey :: Value an -> Maybe (Symbol an) +valueToPropKey (Value _ [PartPropPath (PropPath _ (PathElemImp sym :| []))]) + = Just sym +valueToPropKey _ = Nothing diff --git a/src/Descript/Free/Data/Atom.hs b/src/Descript/Free/Data/Atom.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Free/Data/Atom.hs @@ -0,0 +1,7 @@ +module Descript.Free.Data.Atom + ( module Descript.Free.Data.Atom.PropPath + , module Descript.Lex.Data.Atom + ) where + +import Descript.Free.Data.Atom.PropPath +import Descript.Lex.Data.Atom diff --git a/src/Descript/Free/Data/Atom/PropPath.hs b/src/Descript/Free/Data/Atom/PropPath.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Free/Data/Atom/PropPath.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Free.Data.Atom.PropPath + ( PropPath (..) + , SubPropPath + , PathElem (..) + , immPath + , subPath + , mkPathElem + ) where + +import Descript.Lex.Data.Atom +import Descript.Misc +import Data.Monoid +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty + +-- | A property path. Refers to a top-level value's property, or +-- property of a property, or property of a property of a property, etc. +data PropPath an + = PropPath an (NonEmpty (PathElem an)) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A part of a property path. It can refer to a top-level value, or +-- a property, or a property of a property, etc. +type SubPropPath an = [PathElem an] + +-- | A property path element. Refers to a property key in a type of +-- record. For example, `a" $ map sub $ NonEmpty.toList elems + +instance Printable PathElem where + aprintRec sub (PathElemImp key) = sub key + aprintRec sub (PathElemExp _ key head') = sub key <> "<" <> sub head' + +instance (Show an) => Summary (PropPath an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (PathElem an) where + summaryRec = pprintSummaryRec + +-- | A 'PropPath' with 1 element. +immPath :: PathElem () -> PropPath () +immPath x = PropPath () $ x :| [] + +-- | Prepends the element to the path. +subPath :: PathElem () -> PropPath () -> PropPath () +subPath x (PropPath () xs) = PropPath () $ x NonEmpty.<| xs + +-- | Creates an implicit element if the head reference is 'Nothing', or +-- an explicit one if it's something. +mkPathElem :: an -> Symbol an -> Maybe (Symbol an) -> PathElem an +mkPathElem _ key Nothing = PathElemImp key +mkPathElem ann key (Just head') = PathElemExp ann key head' diff --git a/src/Descript/Free/Data/Import.hs b/src/Descript/Free/Data/Import.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Free/Data/Import.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Free/Data/Import/Import.hs b/src/Descript/Free/Data/Import/Import.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Free/Data/Import/Import.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Free.Data.Import.Import + ( ImportRecord (..) + , ImportDecl (..) + , mkImportDecl + , mkImportRecord + ) where + +import Descript.Free.Data.Import.Module +import Descript.Free.Data.Atom +import Descript.Misc +import Data.Monoid +import Data.Maybe + +-- | Imports a single record. +data ImportRecord an + = ImportRecord + { importRecordAnn :: an + , importRecordFrom :: Symbol an + , importRecordTo :: Symbol an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An import declaration. +data ImportDecl an + = ImportDecl + { importDeclAnn :: an + , importDeclPath :: ModulePath an + -- | Moves records in the dependency into this module. + , importDeclSrcImports :: [ImportRecord an] + -- | Moves records in this module into the dependency. + , importDeclDstImports :: [ImportRecord an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Ann ImportDecl where + getAnn = importDeclAnn + +instance Ann ImportRecord where + getAnn = importRecordAnn + +instance Printable ImportDecl where + aprintRec sub (ImportDecl _ path isrcs idsts) + = "import " + <> sub path + <> pimp1 ("[" <> pintercal ", " (map sub isrcs) <> "]") + <> pimp2 ("{" <> pintercal ", " (map sub idsts) <> "}") + where pimp1 = pimpIf $ null isrcs + pimp2 = pimpIf $ null idsts + +instance Printable ImportRecord where + aprintRec sub (ImportRecord _ from to) + = pimp' (sub from <> " => ") <> sub to + where pimp' = pimpIf $ from =@= to + + needsFullReprint _pxy = True + +instance (Show an) => Summary (ImportDecl an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (ImportRecord an) where + summaryRec = pprintSummaryRec + +-- | If 'Nothing' is given as parameters/imports, creates a declaration +-- without any parameters/imports. +mkImportDecl :: an + -> ModulePath an + -> Maybe [ImportRecord an] + -> Maybe [ImportRecord an] + -> ImportDecl an +mkImportDecl ann path misrcs midsts = ImportDecl ann path isrcs idsts + where isrcs = [] `fromMaybe` misrcs + idsts = [] `fromMaybe` midsts + +-- | If the second param is 'Nothing', makes a record which implicitly +-- imports (or passes, if a parameter) the symbol as itself. +mkImportRecord :: (TaintAnn an) + => an + -> Symbol an + -> Maybe (Symbol an) + -> ImportRecord an +mkImportRecord _ ft Nothing = ImportRecord ann ft ft + where ann = getAnn ft +mkImportRecord ann from (Just to) = ImportRecord ann from to diff --git a/src/Descript/Free/Data/Import/Module.hs b/src/Descript/Free/Data/Import/Module.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Free/Data/Import/Module.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Free.Data.Import.Module + ( ModulePath (..) + , ModuleDecl (..) + , defModuleDecl + , moduleDeclScope + , modulePathScope + ) where + +import Descript.Free.Data.Atom +import Descript.Misc +import Data.Monoid +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty + +-- | A path to a module. +data ModulePath an + = ModulePath + { modulePathAnn :: an + , modulePathElems :: NonEmpty (Symbol an) + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An module declaration. +data ModuleDecl an + = ModuleDecl + { moduleDeclAnn :: an + , moduleDeclPath :: ModulePath an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Ann ModuleDecl where + getAnn = moduleDeclAnn + +instance Ann ModulePath where + getAnn = modulePathAnn + +instance Printable ModuleDecl where + aprintRec sub (ModuleDecl _ path) = pimp' $ "module " <> sub path + where pimp' = pimpIf $ NonEmpty.length (modulePathElems path) == 1 + +instance Printable ModulePath where + aprintRec sub (ModulePath _ syms) + = pintercal ">" $ map sub $ NonEmpty.toList syms + +instance (Show an) => Summary (ModuleDecl an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (ModulePath an) where + summaryRec = pprintSummaryRec + +-- | If a module declaration isn't provided in a source file, this one +-- is implicitly used. Contains one path element - the file's name. +defModuleDecl :: SFile -> ModuleDecl () +defModuleDecl = ModuleDecl () . scopeModulePath . defaultFileScope + +scopeModulePath :: AbsScope -> ModulePath () +scopeModulePath = ModulePath () . NonEmpty.map (Symbol ()) . absScopePath + +-- | The scope of a module with this declaration. +moduleDeclScope :: ModuleDecl an -> AbsScope +moduleDeclScope (ModuleDecl _ path) = modulePathScope path + +modulePathScope :: ModulePath an -> AbsScope +modulePathScope (ModulePath _ xs) = AbsScope $ NonEmpty.map symbolLiteral xs diff --git a/src/Descript/Free/Error.hs b/src/Descript/Free/Error.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Free/Error.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Descript.Free.Error + ( RefineResult + , RefineDiff (..) + , IndivRefineDiff (..) + , LocalRefineDiff (..) + , entireRefineDiff + , actualSummary + , diffErrorDesc + ) where + +import Descript.Misc + +-- | The result of trying to refine a free value. +type RefineResult a = Result RefineDiff a + +-- | When a term can't be refined because it has the wrong shape, +-- describes which parts of the term have the wrong shape, and for each +-- part, what shape was expected and given. +newtype RefineDiff = RefineDiff [IndivRefineDiff] deriving (Eq, Ord, Read, Show, Monoid) + +-- | When a term can't be refined because a sub-term has the wrong shape, +-- describes the range of the sub-term with the wrong shape, and what shape +-- was expected and given. +data IndivRefineDiff + = IndivRefineDiff + { range :: Range + , localDiff :: LocalRefineDiff + } deriving (Eq, Ord, Read, Show) + +-- | When a term can't be refined because the entire term has the wrong +-- shape, describes what shape was expected and what shape this term has. +data LocalRefineDiff + = LocalRefineDiff + { expected :: String + , actual :: String + , actualPr :: String + } deriving (Eq, Ord, Read, Show) + +instance Summary RefineDiff where + summary = msgToStr . diffErrorDesc + +instance Summary IndivRefineDiff where + summary = indivDiffErrorDesc + +instance Summary LocalRefineDiff where + summary = localDiffErrorDesc + +-- | States that an entire term's shape is wrong. +entireRefineDiff :: Range -> LocalRefineDiff -> RefineDiff +entireRefineDiff range' x + = RefineDiff + [ IndivRefineDiff{range = range', localDiff = x} + ] + +-- | Gets a description of the refine difference. +diffErrorDesc :: RefineDiff -> ErrorMsg +diffErrorDesc (RefineDiff xs) = ErrorMsg $ map indivDiffErrorDesc xs + +indivDiffErrorDesc :: IndivRefineDiff -> String +indivDiffErrorDesc indiv + = summary (range indiv) + ++ ": " + ++ localDiffErrorDesc (localDiff indiv) + +localDiffErrorDesc :: LocalRefineDiff -> String +localDiffErrorDesc diff + = actualPr diff + ++ ": expected " + ++ expected diff + ++ ", got " + ++ actual diff + +-- | Combines the actual print and term label to form a summary of the +-- actual item in a refine diff. +actualSummary :: LocalRefineDiff -> String +actualSummary diff = actual diff ++ " \"" ++ actualPr diff ++ "\"" diff --git a/src/Descript/Free/Parse.hs b/src/Descript/Free/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Free/Parse.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Free.Parse + ( parse + , parseValue + ) where + +import Descript.Free.Data +import Descript.Lex hiding (parse) +import Descript.Misc +import Text.Megaparsec hiding (parse) +import Core.Text.Megaparsec +import qualified Data.List.NonEmpty as NonEmpty +import Prelude hiding (any) + +type Parser a = Parsec RangedError (RangeStream Lex) a +type RParser a = Parser (a Range) + +-- | Parses a source from the given file and contents. +parse :: ParseAction (RangeStream Lex) (RangeStream TopLevel) +parse = runLaterParser topLevels + +-- | Parses an individual value from the given file and contents. +parseValue :: ParseAction (RangeStream Lex) (Value Range) +parseValue = runLaterParser value + +topLevels :: Parser (RangeStream TopLevel) +topLevels = topLevel `manySepBy` sep + +topLevel :: RParser TopLevel +topLevel + = label "top-level declaration" + $ TopLevelModuleDecl <$> moduleDecl + <|> TopLevelImportDecl <$> importDecl + <|> ranged (TopLevelPhaseSep <$ phaseSep) + <|> ranged (mkTopLevel <$@> value <*@> valueRefinement) + +moduleDecl :: RParser ModuleDecl +moduleDecl + = ranged $ label "module declaration" + $ ModuleDecl <$@> (punc DeclModule *> modulePath) + +importDecl :: RParser ImportDecl +importDecl + = ranged $ label "import" + $ mkImportDecl + <$@> (punc DeclImport *> modulePath) + <*@> optional srcImports + <*@> optional dstImports + +srcImports :: Parser [ImportRecord Range] +srcImports + = label "\"[\" (followed by import records)" + $ punc OpenBracket *> importRecord `manySepBy` sep <* punc CloseBracket + +dstImports :: Parser [ImportRecord Range] +dstImports + = label "\"{\" (followed by import records)" + $ punc OpenBrace *> importRecord `manySepBy` sep <* punc CloseBrace + +importRecord :: RParser ImportRecord +importRecord + = ranged $ label "import record" + $ mkImportRecord <$@> symbol <*@> optional (punc ArrowEqFwd *> symbol) + +modulePath :: RParser ModulePath +modulePath + = ranged $ label "module path" + $ ModulePath <$@> symbol `someSepBy` punc PathFwd + +phaseSep :: Parser () +phaseSep = label "phase separator" $ punc PhaseSep + +valueRefinement :: RParser ValueRefinement +valueRefinement + = ToRecordDecl <$ punc Period + <|> ToReducer <$> (punc Colon *> value) + <|> ToQuery <$ punc Question + +value :: RParser Value +value + = ranged $ label "value" + $ Value <$@> NonEmpty.toList <$> part `someSepBy` punc Union + +part :: RParser Part +part + = label "part" + $ PartPrim <$> prim + <|> PartRecord <$> record + <|> PartPropPath <$> propPath + +record :: RParser Record +record + = ranged $ label "record" + $ Record + <$@> try (symbol <* punc OpenBracket) + <*@> property `manySepBy` sep <* punc CloseBracket + +property :: RParser Property +property + = label "property" + $ ranged (PropertyDef <$@> try (symbol <* punc Colon) <*@> value) + <|> PropertySingle <$> value + +propPath :: RParser PropPath +propPath + = ranged $ label "property path" + $ PropPath <$@> pathElem `someSepBy` punc PathFwd + +pathElem :: RParser PathElem +pathElem + = ranged $ label "path element" + $ mkPathElem <$@> symbol <*@> optional (punc PathBwd *> symbol) + +sep :: Parser () +sep = punc Sep + +punc :: (() -> Punc ()) -> Parser () +punc = exactlyR . LexPunc . ($ ()) + +symbol :: RParser Symbol +symbol = mapSatisfy lexToSymbol + +prim :: RParser Prim +prim = mapSatisfy lexToPrim diff --git a/src/Descript/Lex.hs b/src/Descript/Lex.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Lex.hs @@ -0,0 +1,3 @@ +-- | Lexemes - the simplest representation besides raw text, doesn't +-- even have recursive elements. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Lex/Data.hs b/src/Descript/Lex/Data.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Lex/Data.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Lex.Data + ( module Descript.Lex.Data.Atom + , Punc (..) + , Lex (..) + , lexToSymbol + , lexToPrim + ) where + +import Descript.Lex.Data.Atom +import Descript.Misc +import Text.Megaparsec.Error +import Core.Data.String + +-- | Symbolic characters and simple keywords, mainly used to group data. +data Punc an + = Sep an + | PhaseSep an + | Period an + | Colon an + | Question an + | Union an + | PathFwd an + | PathBwd an + | ArrowEqFwd an + | OpenBracket an + | CloseBracket an + | OpenBrace an + | CloseBrace an + | DeclModule an + | DeclImport an + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A single lexeme token. Easy and fast to parse from source text, but +-- not nested and might be syntactically invalid when further parsed. +data Lex an + = LexPunc (Punc an) + | LexSymbol (Symbol an) + | LexPrim (Prim an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Ann Lex where + getAnn (LexPunc punc) = getAnn punc + getAnn (LexSymbol sym) = getAnn sym + getAnn (LexPrim prim) = getAnn prim + +instance Ann Punc where + getAnn (Sep ann) = ann + getAnn (PhaseSep ann) = ann + getAnn (Period ann) = ann + getAnn (Colon ann) = ann + getAnn (Question ann) = ann + getAnn (Union ann) = ann + getAnn (PathFwd ann) = ann + getAnn (PathBwd ann) = ann + getAnn (ArrowEqFwd ann) = ann + getAnn (OpenBracket ann) = ann + getAnn (CloseBracket ann) = ann + getAnn (OpenBrace ann) = ann + getAnn (CloseBrace ann) = ann + getAnn (DeclModule ann) = ann + getAnn (DeclImport ann) = ann + +instance Printable Lex where + aprintRec sub (LexPunc punc) = sub punc + aprintRec sub (LexSymbol symbol) = sub symbol + aprintRec sub (LexPrim prim) = sub prim + +instance Printable Punc where + aprint (Sep _) = ", " + aprint (PhaseSep _) = "---" + aprint (Period _) = "." + aprint (Colon _) = ": " + aprint (Question _) = "?" + aprint (Union _) = " | " + aprint (PathFwd _) = ">" + aprint (PathBwd _) = "<" + aprint (ArrowEqFwd _) = "=>" + aprint (OpenBracket _) = "[" + aprint (CloseBracket _) = "]" + aprint (OpenBrace _) = "{" + aprint (CloseBrace _) = "}" + aprint (DeclModule _) = "module " + aprint (DeclImport _) = "import " + +instance (Show an) => ShowToken (Lex an) where + showTokens = summary + +instance (Show an) => Summary (Lex an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Punc an) where + summary punc = "'" ++ trim (pprintStr punc) ++ "'" + +-- | If the lexeme is a symbol, unwraps it. +lexToSymbol :: Lex an -> Maybe (Symbol an) +lexToSymbol (LexPunc _) = Nothing +lexToSymbol (LexSymbol sym) = Just sym +lexToSymbol (LexPrim _) = Nothing + +-- | If the lexeme is a primitive, unwraps it. +lexToPrim :: Lex an -> Maybe (Prim an) +lexToPrim (LexPunc _) = Nothing +lexToPrim (LexSymbol _) = Nothing +lexToPrim (LexPrim prim) = Just prim diff --git a/src/Descript/Lex/Data/Atom.hs b/src/Descript/Lex/Data/Atom.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Lex/Data/Atom.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Lex.Data.Atom + ( Symbol (..) + , Prim (..) + , codeSym + , codeLangSym + , codeContentSym + , undefinedSym + , primExt + , encodePrim + ) where + +import Descript.Misc +import Data.Semigroup +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as ByteString + +-- | An identifier. Used to distinguish records and record properties. +data Symbol an + = Symbol + { symbolAnn :: an + , symbolLiteral :: String + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A built-in primitive. A piece of data in code not represented by a record. +-- +-- In Descript, most values are typically represented by records. While +-- /theoretically/ every value /could/ be a record, converting some +-- values like strings and numbers is verbose and inefficient. +-- +-- Currently, the only primitives are numbers and strings. In the +-- future, images and other arbitrary data could be added. +data Prim an + = PrimNumber an Rational + | PrimText an Text + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Ann Symbol where + getAnn = symbolAnn + +instance EAnn Symbol where + Symbol xKeyAnn xKeyStr `eappend` Symbol yKeyAnn yKeyStr + | xKeyStr /= yKeyStr = error "Symbols have different content" + | otherwise = Symbol (xKeyAnn <> yKeyAnn) xKeyStr + +instance Ann Prim where + getAnn (PrimNumber ann _) = ann + getAnn (PrimText ann _) = ann + +instance Printable Symbol where + aprint (Symbol _ str) = plex str + +instance Printable Prim where + aprint (PrimNumber _ num) = pprim num + aprint (PrimText _ str) = pprim str + +instance (Show an) => Summary (Symbol an) where + summary = pprintSummary + +instance (Show an) => Summary (Prim an) where + summary = pprintSummary + +-- | The record head for code blocks. +codeSym :: Symbol () +codeSym = Symbol () "Code" + +-- | The property key for a code block's language +codeLangSym :: Symbol () +codeLangSym = Symbol () "lang" + +-- | The property key for a code block's content. +codeContentSym :: Symbol () +codeContentSym = Symbol () "content" + +-- | A symbol for an undefined value - e.g. an unresolved implicit +-- property. +undefinedSym :: Symbol () +undefinedSym = Symbol () "{undefined}" + +-- | The extension of a file with the given primitive. +primExt :: Prim () -> String +primExt _ = "txt" -- So far everything is just text. + +-- | Write a primitive into a 'ByteString'. Just encodes the underlying +-- number or string. +encodePrim :: Prim () -> ByteString +encodePrim (PrimNumber () x) = ByteString.pack $ show x +encodePrim (PrimText () x) = Text.encodeUtf8 x diff --git a/src/Descript/Lex/Parse.hs b/src/Descript/Lex/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Lex/Parse.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Descript.Lex.Parse + ( parse_ + , parse + ) where + +import Prelude hiding (lex) +import Descript.Lex.Data +import Descript.Misc +import Text.Megaparsec hiding (parse) +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import Data.Ratio +import Core.Data.List +import Data.Text (Text) +import qualified Data.Text as Text + +type Parser a = Parsec RangedError Text a +type RParser a = Parser (a Range) + +parse_ :: ParseAction () (RangeStream Lex) +parse_ file () = parse file + +parse :: SFile -> ParseResult (RangeStream Lex) +parse = runFirstParser lexemes + +lexemes :: Parser (RangeStream Lex) +lexemes = stripSeps <$> (white *> many lexeme) + +lexeme :: RParser Lex +lexeme + = LexPunc <$> punc + <|> LexSymbol <$> symbol + <|> LexPrim <$> prim + "lexeme" + +punc :: RParser Punc +punc + = ranged puncFullRange + <|> DeclModule <$> rword "module" + <|> DeclImport <$> rword "import" + "punctuation" + +puncFullRange :: Parser (an -> Punc an) +puncFullRange + = PhaseSep <$ genPuncSep "---" + <|> Period <$ genPuncSuffix "." + <|> Colon <$ genPuncInfix ":" + <|> Question <$ genPuncSuffix "?" + <|> Union <$ genPuncInfix "|" + <|> PathFwd <$ genPuncInfix ">" + <|> PathBwd <$ genPuncInfix "<" + <|> ArrowEqFwd <$ genPuncInfix "=>" + <|> OpenBracket <$ genPuncPrefix "[" + <|> CloseBracket <$ genPuncSuffix "]" + <|> OpenBrace <$ genPuncPrefix "{" + <|> CloseBrace <$ genPuncSuffix "}" + <|> Sep <$ sep + +symbol :: RParser Symbol +symbol = genLexeme symbol' + +prim :: RParser Prim +prim = genLexeme prim' + +symbol' :: Parser (an -> Symbol an) +symbol' = Symbol <$@> symbolStr "symbol" + +prim' :: Parser (an -> Prim an) +prim' + = PrimNumber <$@> number + <|> PrimText <$@> primText + "primitive" + +symbolStr :: Parser String +symbolStr = (:) <$> symStartChar <*> many symNextChar + +symStartChar :: Parser Char +symStartChar = letterChar <|> char '_' <|> char '#' + +symNextChar :: Parser Char +symNextChar = alphaNumChar <|> char '_' + +primText :: Parser Text +primText = Text.pack <$> (char '"' *> manyTill L.charLiteral (char '"')) "string" + +unsignedNumber :: Parser Rational +unsignedNumber + = try (toRational @Double <$> L.float) + <|> try (string "0x") *> (toRational @Integer <$> L.hexadecimal) + <|> try (string "0o") *> (toRational @Integer <$> L.octal) + <|> (%) <$> L.decimal <*> (char '/' *> L.decimal <|> pure 1) + "unsigned number" + +number :: Parser Rational +number + = char '-' *> (negate <$> unsignedNumber) + <|> unsignedNumber + "number" + +sep :: Parser () +sep = genPuncPrefix "," + <|> genPuncPrefix "\n" + "separator" + +rword :: Text -> Parser Range +rword word + = expRanged_ (Text.length word) $ genPuncPrefix (word `Text.snoc` ' ') + +genPuncInfix :: Text -> Parser () +genPuncInfix lit = () <$ L.symbol white lit + +genPuncPrefix :: Text -> Parser () +genPuncPrefix = genPuncInfix + +genPuncSuffix :: Text -> Parser () +genPuncSuffix lit = () <$ try (white *> L.symbol whiteNoSep lit) + +genPuncSep :: Text -> Parser () +genPuncSep lit = () <$ L.symbol whiteNoSep lit + +genLexeme :: Parser (Range -> a) -> Parser a +genLexeme = L.lexeme whiteNoSep . ranged + +spaceNoSep :: Parser () +spaceNoSep = () <$ oneOf [' ', '\t'] + +whiteNoSep :: Parser () +whiteNoSep = L.space spaceNoSep lineComment blockComment + +white :: Parser () +white = L.space space1 lineComment blockComment + +lineComment :: Parser () +lineComment = L.skipLineComment "//" + +blockComment :: Parser () +blockComment = L.skipBlockComment "/*" "*/" + +stripSeps :: RangeStream Lex -> RangeStream Lex +stripSeps = strip $ (== LexPunc (Sep ())) . remAnns diff --git a/src/Descript/Misc.hs b/src/Descript/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc.hs @@ -0,0 +1,3 @@ +-- | Miscellaneous, general-purpose structures and functions which are +-- needed to use this library, but could probably be in a base library. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Ann.hs b/src/Descript/Misc/Ann.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Ann.hs @@ -0,0 +1,97 @@ +-- | Annotations - allow custom, extra data in AST nodes. +module Descript.Misc.Ann + ( Ann (..) + , SAnn (..) + , EAnn (..) + , AnnSummary (..) + , SummaryWithAnn (..) + , remAnns + , (=@=) + , (/@=) + , (<$@>) + , (<*@>) + , summaryWithAnn + ) where + +import Data.Semigroup + +-- | An AST node which can be annotated. +class (Functor a, Foldable a, Traversable a) => Ann a where + -- | Gets the annotation. + getAnn :: a an -> an + +-- | An AST node whose surface annotation can be transformed. +-- Technically every 'Ann' is an 'SAnn', but this functionality rarely +-- seems necessary so for most values it isn't implemented. +class (Ann a) => SAnn a where + -- | Transforms the surface annotation. Different than 'fmap', which + -- also transforms child nodes' annotations. + mapSAnn :: (an -> an) -> a an -> a an + +-- | An AST node which can be combined with a semantically equivalent +-- node (equal via '=@='), combining annotations. Technically every +-- 'Ann' is an 'EAnn', but not all have implementations. +class (Ann a) => EAnn a where + -- | Combine 2 nodes with equivalent semantic content, but different + -- annotations. Assumes the nodes are semantically equal (via '=@='). + eappend :: (Semigroup an) => a an -> a an -> a an + +-- | An annotation which affects a summary. +class (Show a) => AnnSummary a where + -- | A prefix added to a summary by the annotation + annSummaryPre :: a -> String + +-- | Gets its summary by adding its annotation to a base summary. +-- +-- > instance (SummaryWithAnn a) => Summary a where +-- > summary = summaryWithAnn +class (Ann a) => SummaryWithAnn a where + -- | The part of the summary without the annotation. + baseSummary :: a an -> String + +instance AnnSummary () where + annSummaryPre () = "" + +-- | Removes the annotations from the value and sub-values. +remAnns :: (Functor w) => w a -> w () +remAnns x = () <$ x + +-- | Whether the expressions are equal without annotations. +(=@=) :: (Functor w, Eq (w ())) => w a1 -> w a2 -> Bool +x =@= y = remAnns x == remAnns y + +-- | Whether the expressions aren't equal without annotations. +(/@=) :: (Functor w, Eq (w ())) => w a1 -> w a2 -> Bool +x /@= y = remAnns x /= remAnns y + +-- | Like '<$>', but delays applying an initial argument (the annotation). +-- +-- Useful for creating parsers or other functors on annotated values, +-- which get ranges later. For example: +-- +-- > ranged $ Add <$@> numParser <*@> numParser +-- +-- is equivalent to +-- +-- > ranged $ \range -> Add range <$> numParser <*> numParser +infixl 4 <$@> +(<$@>) :: (Functor w) => (ann -> a -> b) -> w a -> w (ann -> b) +f <$@> x = flip f <$> x + +-- | Like '<*>', but delays applying an initial argument (the annotation). +-- +-- Useful for creating parsers or other functors on annotated values, +-- which get ranges later. For example: +-- +-- > ranged $ Add <$@> numParser <*@> numParser +-- +-- is equivalent to +-- +-- > ranged $ \range -> Add range <$> numParser <*> numParser +infixl 4 <*@> +(<*@>) :: (Applicative w) => w (ann -> a -> b) -> w a -> w (ann -> b) +f <*@> x = fmap flip f <*> x + +-- | Gets the summary of a value, including its annotation. +summaryWithAnn :: (SummaryWithAnn a, AnnSummary an) => a an -> String +summaryWithAnn x = annSummaryPre (getAnn x) ++ baseSummary x diff --git a/src/Descript/Misc/Build.hs b/src/Descript/Misc/Build.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build.hs @@ -0,0 +1,2 @@ +-- | General stuff for any build phase. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Build/Process.hs b/src/Descript/Misc/Build/Process.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Process.hs @@ -0,0 +1,2 @@ +-- | Process the AST (interpret, inspect, refactor, etc.). +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Build/Process/Diagnose.hs b/src/Descript/Misc/Build/Process/Diagnose.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Process/Diagnose.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +-- | Diagnostics - errors, warnings, and the result of interpreting a +-- program. +module Descript.Misc.Build.Process.Diagnose + ( DiagType (..) + , Diagnostic (..) + , getDiagType + ) where + +import Descript.Misc.Build.Process.Validate +import Descript.Misc.Ann +import Descript.Misc.Summary +import Data.Text (Text) +import qualified Data.Text as Text + +-- | What type of diagnostic this is. +data DiagType + = DiagProblemType + | DiagEvalType + deriving (Eq, Ord, Read, Show) + +-- | Describes a piece of source - whether it's valid, what it +-- evaluates into, etc.. +data Diagnostic an + = DiagProblem (Problem an) + | DiagEval an Text + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Ann Diagnostic where + getAnn (DiagProblem prob) = getAnn prob + getAnn (DiagEval ann _) = ann + +instance SummaryWithAnn Diagnostic where + baseSummary (DiagProblem prob) = baseSummary prob + baseSummary (DiagEval _ x) = Text.unpack x + +instance (AnnSummary an) => Summary (Diagnostic an) where + summary = summaryWithAnn + +-- | Gets the diagnostic's type. +getDiagType :: Diagnostic an -> DiagType +getDiagType (DiagProblem _) = DiagProblemType +getDiagType (DiagEval _ _) = DiagEvalType diff --git a/src/Descript/Misc/Build/Process/Refactor.hs b/src/Descript/Misc/Build/Process/Refactor.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Process/Refactor.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +module Descript.Misc.Build.Process.Refactor + ( RefactorError (..) + , GenRefactorWarning (..) + , RefactorWarning + , RefactorResult + , RefactorResultT + , RefactorFunc + , RefactorFuncT + ) where + +import Descript.Misc.Build.Process.Validate +import Descript.Misc.Build.Read.Parse +import Descript.Misc.Build.Read.File +import Descript.Misc.Ann +import Descript.Misc.Error +import Descript.Misc.Summary +import Data.Maybe +import Data.List + +-- | Prevents a value from being refactored. Currently none of these, +-- just a stub. +data RefactorError + = UnsupportedRefactorAction String [String] + | BadRefactorArgs String Int [String] + | RefactorNoSymbolAtLoc + | RefactorParseError (Maybe SFile) (ParseError Char) + | RefactorValidateError [Problem SrcAnn] + deriving (Eq, Read, Show) + +-- | Allows a value to be refactored, but might cause conflicts in the +-- source code later (specifically, it can't be verified that the +-- refactor will produce the same code). +data GenRefactorWarning an + = SymConflict an String + | RefactorDepFail (TagdDepError an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Allows a value to be refactored, but might cause conflicts in the +-- source code later (specifically, it can't be verified that the +-- refactor will produce the same code). +type RefactorWarning = GenRefactorWarning SrcAnn + +-- | The result of trying to refactor an expression. Can completely +-- fail ('Failure'), give a result but it could mess up the source code +-- (nonempty 'dirtyWarnings'), or completely succeed. +type RefactorResult a = DirtyRes RefactorError RefactorWarning a + +-- | The result of trying to refactor an expression, with side effects +-- from @u@. +type RefactorResultT u a = DirtyResT RefactorError RefactorWarning u a + +-- | Refactors the expression of type @a@. +type RefactorFunc a = a SrcAnn -> RefactorResult (a SrcAnn) + +-- | Refactors the expression of type @a@, performing side effects from +-- @u@. +type RefactorFuncT u a = a SrcAnn -> RefactorResultT u (a SrcAnn) + +instance Ann GenRefactorWarning where + getAnn (SymConflict ann _) = ann + getAnn (RefactorDepFail derr) = getAnn derr + +instance FileSummary RefactorError where + summaryF _ (UnsupportedRefactorAction label args) + = "unsupported refactor action: " + ++ label + ++ "; args: " + ++ intercalate ", " args + summaryF _ (BadRefactorArgs label expectedArgLen args) + = "expected " + ++ show expectedArgLen + ++ ", got " + ++ show actualArgLen + ++ " for refactor action: " + ++ label + ++ "; args: " + ++ intercalate ", " args + where actualArgLen = length args + summaryF _ RefactorNoSymbolAtLoc = "no symbol at this location" + summaryF file (RefactorParseError isrc err) + = parseErrorSummary file' err + where file' = file `fromMaybe` isrc + summaryF _ (RefactorValidateError probs) = validateErrorSummary probs + +instance SummaryWithAnn GenRefactorWarning where + baseSummary (SymConflict _ symPr) + = "old symbol conflicts with new symbols: " ++ symPr + baseSummary (RefactorDepFail derr) + = "failed to load dependency:\n" ++ baseSummary derr + +instance (AnnSummary an) => Summary (GenRefactorWarning an) where + summary = summaryWithAnn diff --git a/src/Descript/Misc/Build/Process/Validate.hs b/src/Descript/Misc/Build/Process/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Process/Validate.hs @@ -0,0 +1,9 @@ +-- | Checks that Descript source is well-formed before it's interpreted. +-- If the source isn't well-formed, generates user-friendly problems. +module Descript.Misc.Build.Process.Validate + ( module Descript.Misc.Build.Process.Validate.Problem + , Term + ) where + +import Descript.Misc.Build.Process.Validate.Problem +import Descript.Misc.Build.Process.Validate.Term (Term) diff --git a/src/Descript/Misc/Build/Process/Validate/Problem.hs b/src/Descript/Misc/Build/Process/Validate/Problem.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Process/Validate/Problem.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +module Descript.Misc.Build.Process.Validate.Problem + ( Problem (..) + , validateErrorSummary + ) where + +import Descript.Misc.Build.Process.Validate.Term (Term) +import Descript.Misc.Build.Read.File +import Descript.Misc.Ann +import Descript.Misc.Summary +import Data.List +import Core.Data.String + +-- | A reason why code isn't valid / well-formed. +-- Not called "error" because errors typically occur during an operation +-- (e.g. parsing), preventing the operation, but in 'Validate', finding +-- problems /is/ the operation (validation errors /will/ prevent +-- interpretation, so there's a 'ValidateError' for building). +data Problem an + = ProblemDepFail (TagdDepError an) + | Conflict an Term String + | Duplicate an Term String + | UndeclaredRecord an String + | IncompleteRecord an [String] + | OvercompleteRecord an [String] + | UndeclaredPathElemHead an String + | UndeclaredPathElemKey an String + | UndefinedInjFunc an String + | WrongInjFuncParamsLen an Int Int + | WrongInjFuncParamType an String String + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance Ann Problem where + getAnn (ProblemDepFail derr) = getAnn derr + getAnn (Conflict ann _ _) = ann + getAnn (Duplicate ann _ _) = ann + getAnn (UndeclaredRecord ann _) = ann + getAnn (IncompleteRecord ann _) = ann + getAnn (OvercompleteRecord ann _) = ann + getAnn (UndeclaredPathElemHead ann _) = ann + getAnn (UndeclaredPathElemKey ann _) = ann + getAnn (UndefinedInjFunc ann _) = ann + getAnn (WrongInjFuncParamsLen ann _ _) = ann + getAnn (WrongInjFuncParamType ann _ _) = ann + +instance SummaryWithAnn Problem where + baseSummary (ProblemDepFail derr) + = "failed to load dependency:\n" ++ baseSummary derr + baseSummary (Conflict _ term valPr) + = termSum ++ " conflicts with an earlier " ++ termSum ++ ": " ++ valPr + where termSum = summary term + baseSummary (Duplicate _ term valPr) + = "duplicate " ++ summary term ++ ": " ++ valPr + baseSummary (UndeclaredRecord _ symPr) + = "undeclared record type: " ++ symPr + baseSummary (IncompleteRecord _ missingKeyPrs) + = "incomplete record: missing " ++ intercalate ", " missingKeyPrs + baseSummary (OvercompleteRecord _ extraKeyPrs) + = "record has extra, undeclared properties: " ++ intercalate ", " extraKeyPrs + baseSummary (UndeclaredPathElemHead _ headPr) + = "nonexistent path: head not in input: " ++ headPr + baseSummary (UndeclaredPathElemKey _ keyPr) + = "nonexistent path: key not in record: " ++ keyPr + baseSummary (UndefinedInjFunc _ funcPr) + = "undefined injected function: " ++ funcPr + baseSummary (WrongInjFuncParamsLen _ expected actual) + = "wrong number of parameters given to injected function: expected " + ++ show expected ++ ", given " ++ show actual + baseSummary (WrongInjFuncParamType _ expectedPr actualPr) + = "wrong type of parameter given to injected function: expected " + ++ expectedPr ++ ", given " ++ actualPr + +instance (AnnSummary an) => Summary (Problem an) where + summary = summaryWithAnn + +-- | Summarizes a validation error in a larger context (e.g. build +-- error). +validateErrorSummary :: (AnnSummary an) => [Problem an] -> String +validateErrorSummary probs = "invalid:" ++ probsSummary + where probsSummary = concatMap probSummary probs + +probSummary :: (Summary a) => a -> String +probSummary sub = '\n' : indentBullet (summary sub) diff --git a/src/Descript/Misc/Build/Process/Validate/Term.hs b/src/Descript/Misc/Build/Process/Validate/Term.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Process/Validate/Term.hs @@ -0,0 +1,24 @@ +-- | Contains terms for nodes in all phases. +-- +-- > import qualified ...Term as Term +module Descript.Misc.Build.Process.Validate.Term + ( Term (..) + ) where + +import Descript.Misc.Summary +import Core.Data.List +import Data.Char + +-- | A type of expression. This enum covers a broad range of different expressions. +data Term + = Import + | RecordDecl + | Input + | Output + | Property + | Query + deriving (Eq, Ord, Read, Show) + +instance Summary Term where + summary RecordDecl = "record declaration" + summary x = overHead toLower $ show x -- Covers most cases diff --git a/src/Descript/Misc/Build/Read.hs b/src/Descript/Misc/Build/Read.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read.hs @@ -0,0 +1,2 @@ +-- | Read the AST (including dependencies). +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Build/Read/File.hs b/src/Descript/Misc/Build/Read/File.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/File.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Build/Read/File/DFile.hs b/src/Descript/Misc/Build/Read/File/DFile.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/File/DFile.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveFunctor #-} + +module Descript.Misc.Build.Read.File.DFile + ( GenDFile (..) + , mkTextFile + , loadTextFile + , fileName + , fileContents + ) where + +import Descript.Misc.Build.Read.File.DepResolve +import Descript.Misc.Build.Read.File.SFile +import Data.Text +import qualified Data.Text.IO as Text +import System.FilePath + +-- | A (dependent) source file. It can be an actual file on disk, or a +-- virtual representation. It just needs a name, contents, and a +-- resolver to other files. Dependencies are obtained through the monad +-- 'u', and they're of type 'a'. +data GenDFile u d + = DFile + { depResolver :: GenDepResolver u d + , sfile :: SFile + } deriving (Show, Functor) + +-- | Creates a file with the given path and contents, which uses the +-- default resolver. +mkTextFile :: FilePath -> Text -> GenDFile IO Text +mkTextFile path contents + = DFile + { depResolver = defaultTextResolver $ takeDirectory path + , sfile = mkSFile path contents + } + +-- | Reads the file with the given path. +loadTextFile :: FilePath -> IO (GenDFile IO Text) +loadTextFile path = mkTextFile path <$> Text.readFile path + +-- | The name of the file. +fileName :: GenDFile u d -> String +fileName = sfileName . sfile + +-- | The textual representation of the file. +fileContents :: GenDFile u d -> Text +fileContents = sfileContents . sfile diff --git a/src/Descript/Misc/Build/Read/File/DepError.hs b/src/Descript/Misc/Build/Read/File/DepError.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/File/DepError.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +module Descript.Misc.Build.Read.File.DepError + ( AnonDepError (..) + , TagdDepError (..) + , GenDepResult + , GenDepResultT + , GenDirtyDep + , GenDirtyDepT + , mapDirtyDepdAnn + , guardCycle + , guardCycleT + , guardPromoteCycle + , guardPromoteCycleT + ) where + +import Descript.Misc.Build.Read.File.Depd +import Descript.Misc.Build.Read.File.Scope +import Descript.Misc.Error +import Descript.Misc.Ann +import Descript.Misc.Summary +import Core.Data.String +import Core.Control.Monad.Trans + +-- | An error encountered trying to load a dependency. Doesn't specify +-- the dependency's scope (must be inferred). +data AnonDepError + = DepNotExist [String] + | DepNotReadable + | DepNotBuild String + | DepCycles [RelScope] + deriving (Eq, Ord, Read, Show) + +-- | An error encountered trying to load a dependency. Specifies the +-- dependency's scope. +data TagdDepError an + = TagdDepError + { tagdDepErrorAnn :: an + , tagdDepErrorScope :: AbsScope + , tagdDepError :: AnonDepError + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | The result of trying to load a dependency with no fallback. +type GenDepResult a = Result AnonDepError a + +-- | The result of trying to load a dependency with no fallback (stacked). +type GenDepResultT u a = ResultT AnonDepError u a + +-- | The result of trying to load dependencies with fallback. +type GenDirtyDep an a = Dirty (TagdDepError an) a + +-- | The result of trying to load dependencies with fallback (stacked). +type GenDirtyDepT an u a = DirtyT (TagdDepError an) u a + +instance Ann TagdDepError where + getAnn = tagdDepErrorAnn + +instance SummaryWithAnn TagdDepError where + baseSummary (TagdDepError _ scope err) + = anonDepErrorSummary suffix (Just scope) err + where suffix = " - " ++ summary scope + +instance (AnnSummary an) => Summary (TagdDepError an) where + summary = summaryWithAnn + +instance Summary AnonDepError where + summary = anonDepErrorSummary "" Nothing + +-- | Transforms the annotations within the @DirtyDepd@. Annotations are +-- in the value and errors associated with the dependency, but \not\ the +-- dependency itself. +mapDirtyDepdAnn :: (Functor a) + => (an1 -> an2) + -> GenDepd (GenDirtyDep an1 d) (a an1) + -> GenDepd (GenDirtyDep an2 d) (a an2) +mapDirtyDepdAnn f (Depd ddep x) + = Depd (mapWarnings (fmap f) ddep) (f <$> x) + +anonDepErrorSummary :: String + -> Maybe AbsScope + -> AnonDepError + -> String +anonDepErrorSummary sufx _ (DepNotExist paths) + = unlines + ( ("couldn't find module" ++ sufx ++ ", tried:") + : map indentBullet paths ) +anonDepErrorSummary sufx _ DepNotReadable = "couldn't read module" ++ sufx +anonDepErrorSummary sufx _ (DepNotBuild msg) + = "couldn't build module" ++ sufx ++ ":\n" ++ msg +anonDepErrorSummary _ optScope (DepCycles relInters) + = unlines + ( "module depends on this module, forming a cycle:" + : map indentBullet interSums ) + where interSums + = reverse + $ case optScope of + Nothing -> map summary relInters + Just scope -> map summary $ scanr (flip anchorScopeSib) scope relInters + +-- | Fails with 'DepCycles' if adding the given dependency to the given +-- chain of dependencies creates a cycle (if the chain contains the +-- dependency). +guardCycle :: RelScope -> [RelScope] -> GenDepResult () +guardCycle new dpds + | new `elem` dpds = Failure $ DepCycles $ new : dpds + | otherwise = Success () + +-- | Hoisted 'guardCycle' for convenience. +guardCycleT :: (Monad u) => RelScope -> [RelScope] -> GenDepResultT u () +guardCycleT new = hoist . guardCycle new + +-- | Fails if one of the dependency "errors" is a 'DepCycles'. Typically +-- because data with other dependency errors is still interpreted for +-- more errors, but 'DepCycles' errors generate redundant messages +-- later, so when they're encountered, resolution immediately fails. +guardPromoteCycle :: [TagdDepError an] -> GenDepResult () +guardPromoteCycle [] = Success () +guardPromoteCycle (x : xs) = guardPromoteCycle1 x >> guardPromoteCycle xs + +guardPromoteCycle1 :: TagdDepError an -> GenDepResult () +guardPromoteCycle1 terr + = case tagdDepError terr of + DepCycles inters -> Failure $ DepCycles inters + _ -> Success () + +-- | Hoisted 'guardPromoteCycle' for convenience. +guardPromoteCycleT :: (Monad u) => [TagdDepError an] -> GenDepResultT u () +guardPromoteCycleT = hoist . guardPromoteCycle diff --git a/src/Descript/Misc/Build/Read/File/DepResolve.hs b/src/Descript/Misc/Build/Read/File/DepResolve.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/File/DepResolve.hs @@ -0,0 +1,135 @@ +module Descript.Misc.Build.Read.File.DepResolve + ( GenDepResolver (..) + , defaultTextResolver + ) where + +import Descript.Misc.Build.Read.File.DepError +import Descript.Misc.Build.Read.File.Scope +import Descript.Misc.Error +import Core.Data.Functor +import Data.Text (Text) +import qualified Data.Text.IO as Text +import Control.Applicative +import Core.Control.Applicative +import Control.Exception +import System.IO.Error +import Paths_descript_lang + +-- | Finds the dependency at the given relative module. +data GenDepResolver u a + = DepResolver + { showDepResolver :: String -- ^ Used for 'Show'. + , resolveDep :: RelScope -> GenDepResultT u a + } + +instance Show (GenDepResolver u a) where + show = showDepResolver + +instance (Functor u) => Functor (GenDepResolver u) where + fmap f x + = DepResolver + { showDepResolver = "f <$> " ++ showDepResolver x + , resolveDep = f <<$>> resolveDep x + } + +instance (Applicative u) => Applicative (GenDepResolver u) where + pure x + = DepResolver + { showDepResolver = "pure x" + , resolveDep = pure2 x + } + f <*> x + = DepResolver + { showDepResolver = showDepResolver f ++ " <*> " ++ showDepResolver x + , resolveDep = resolveDep f <<*>> resolveDep x + } + +instance (Monad u) => Monad (GenDepResolver u) where + return = pure + fx >>= f + = DepResolver + { showDepResolver = showDepResolver fx ++ " >>= f" + , resolveDep = resolve + } + where resolve scope = do + ix <- resolveDep fx scope + resolveDep (f ix) scope + +-- | Will use the second resolver if the first resolver can't find the +-- module. If the first resolver gets another resolver or succeeds, +-- will return its result. +instance (Monad u) => Alternative (GenDepResolver u) where + empty + = DepResolver + { showDepResolver = "empty" + , resolveDep = resolve + } + where resolve _ = mkFailureT $ DepNotExist [] + fx <|> fy + = DepResolver + { showDepResolver = showDepResolver fx ++ " <|> " ++ showDepResolver fy + , resolveDep = resolve + } + where resolve scope = ResultT $ do + xres <- runResultT $ resolveDep fx scope + case xres of + Failure (DepNotExist xPaths) -> do + yres <- runResultT $ resolveDep fy scope + case yres of + Failure (DepNotExist yPaths) + -> pure $ Failure $ DepNotExist paths + where paths = xPaths ++ yPaths + _ -> pure yres + _ -> pure xres + +-- | Resolves dependencies in the filesystem within the given folder, +-- or within the user's dependency folder. +defaultTextResolver :: FilePath -> GenDepResolver IO Text +defaultTextResolver path = localTextResolver path <|> sharedGenDepTextResolver + +-- | Resolves dependencies in the filesystem within the given folder. +localTextResolver :: FilePath -> GenDepResolver IO Text +localTextResolver path + = DepResolver + { showDepResolver = "localResolver " ++ show path + , resolveDep = resolveLocalT path + } + +-- | Resolves shared dependencies -- installed dependencies which are +-- accessible to all modules with the same path, like @Base@. +sharedGenDepTextResolver :: GenDepResolver IO Text +sharedGenDepTextResolver + = DepResolver + { showDepResolver = "sharedGenDepResolver" + , resolveDep = resolveLocalT' getSharedDepPath . globalizeRelScope + } + +resolveLocalT :: FilePath -> RelScope -> GenDepResultT IO Text +resolveLocalT path = ResultT . resolveLocal path + +resolveLocalT' :: IO FilePath -> RelScope -> GenDepResultT IO Text +resolveLocalT' getPath = ResultT . resolveLocal' getPath + +resolveLocal :: FilePath -> RelScope -> IO (GenDepResult Text) +resolveLocal path scope + = handle (failResolveLocal fullPath) $ forceResolveLocal fullPath + where fullPath = scopeFilepath path scope + +resolveLocal' :: IO FilePath -> RelScope -> IO (GenDepResult Text) +resolveLocal' getPath scope = (`resolveLocal` scope) =<< getPath + +forceResolveLocal :: FilePath -> IO (GenDepResult Text) +forceResolveLocal = fmap Success . Text.readFile + +failResolveLocal :: FilePath -> IOError -> IO (GenDepResult Text) +failResolveLocal path = pure . Failure . ioErrorToDepError path + +ioErrorToDepError :: FilePath -> IOError -> AnonDepError +ioErrorToDepError path err + | isDoesNotExistError err = DepNotExist [path] + | otherwise = DepNotReadable + +-- | This directory contains modules which can be used by a Descript +-- file anywhere. +getSharedDepPath :: IO FilePath +getSharedDepPath = getDataFileName "resources/modules" diff --git a/src/Descript/Misc/Build/Read/File/Depd.hs b/src/Descript/Misc/Build/Read/File/Depd.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/File/Depd.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +module Descript.Misc.Build.Read.File.Depd + ( GenDepd (..) + , mapDep + ) where + +-- | An AST and its dependencies. +data GenDepd d a + = Depd + { depdDep :: d + , depdVal :: a + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Transforms the dependency. +mapDep :: (d1 -> d2) -> GenDepd d1 a -> GenDepd d2 a +mapDep f (Depd dep x) = Depd (f dep) x diff --git a/src/Descript/Misc/Build/Read/File/SFile.hs b/src/Descript/Misc/Build/Read/File/SFile.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/File/SFile.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TypeFamilies #-} + +module Descript.Misc.Build.Read.File.SFile + ( SFile (..) + , FileSummary (..) + , mkSFile + , loadSFile + , ifile + , defaultFileScope + ) where + +import Descript.Misc.Build.Read.File.Scope +import Descript.Misc.Error +import Descript.Misc.Summary +import qualified Text.Megaparsec.Error as Parsec +import Text.Megaparsec.Error hiding (ParseError) +import Data.Text (Text) +import qualified Data.Text.IO as Text +import System.FilePath + +-- | A self-contained source file. +data SFile + = SFile + { sfileName :: String + , sfileContents :: Text + } deriving (Eq, Ord, Read, Show) + +-- | Can get a summary of an instance given the file it came from. +class FileSummary a where + -- A summary of the value, given the file it came from. + summaryF :: SFile -> a -> String + +instance (FileSummary e, Summary a) => FileSummary (Result e a) where + summaryF file (Failure err) = "Failure: " ++ summaryF file err + summaryF _ (Success val) = summary val + +instance (ShowErrorComponent e, t ~ Char) => FileSummary (Parsec.ParseError t e) where + summaryF file err = parseErrorPretty' (sfileContents file) err + +-- | Creates a file at the given path. +mkSFile :: FilePath -> Text -> SFile +mkSFile path contents + = SFile + { sfileName = takeBaseName path + , sfileContents = contents + } + +-- | Reads the file with the given path. +loadSFile :: FilePath -> IO SFile +loadSFile path = mkSFile path <$> Text.readFile path + +-- | Creates a file for text in "interactive mode" (e.g. from a +-- console). +ifile :: Text -> SFile +ifile contents + = SFile + { sfileName = ifileName + , sfileContents = contents + } + +-- | The scope of the module in the file, if the module doesn't have an +-- explicit scope. +defaultFileScope :: SFile -> AbsScope +defaultFileScope = AbsScope . pure . sfileName + +ifileName :: String +ifileName = "" diff --git a/src/Descript/Misc/Build/Read/File/Scope.hs b/src/Descript/Misc/Build/Read/File/Scope.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/File/Scope.hs @@ -0,0 +1,171 @@ +module Descript.Misc.Build.Read.File.Scope + ( AbsScope (..) + , RelScope (..) + , baseScope + , undefinedScope + , anchorScopeSib + , anchorScopeParent + , scopeRelToSib + , scopeRelToParent + , globalizeRelScope + , scopeFilepath + ) where + +import Descript.Misc.Summary +import Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Core.Data.List.NonEmpty as NonEmpty +import System.FilePath +import Core.System.FilePath + +-- | The name of the module\/file where an identifier is located. +-- If the identifier is imported from another module, the imported +-- reducers should automatically alter between the old and new module +-- scopes. +newtype AbsScope + = AbsScope + { absScopePath :: NonEmpty String -- ^ The path - \outermost element first\. + } deriving (Eq, Ord, Read, Show) + +-- | The scope of a module\/file relative to another module\/file. +data RelScope + = RelScope + { relScopePath :: NonEmpty String -- ^ Path elements prepended to the anchor path. + , relScopeUps :: Int -- ^ Path elements removed from the head of the anchor path. + } deriving (Eq, Ord, Read, Show) + +instance Summary AbsScope where + summary (AbsScope path) = pathSummary path + +instance Summary RelScope where + summary (RelScope path ups) = upsSummary ups ++ pathSummary path + +-- | The scope containing the most primitive imports, such as code +-- blocks. +baseScope :: AbsScope +baseScope = AbsScope $ "Base" :| [] + +-- | The scope for unresolved symbols. +undefinedScope :: AbsScope +undefinedScope = AbsScope $ "{undefined}" :| [] + +-- | The given relative scope made absolute "relative to" the given +-- sibling. -- The semantics are a bit confusing, also see +-- 'anchorScopeParent', here are some examples: +-- +-- >>> "Foo>Bar>Baz" `anchorScopeSib` "Qux" +-- "Foo>Bar>Qux" +-- >>> "Foo>Bar>Baz" `anchorScopeSib` "Qux" +-- >>> "Foo>Bar" `anchorScopeSib` "Baz>Qux" +-- "Foo>Baz>Qux" +anchorScopeSib :: AbsScope -> RelScope -> AbsScope +anchorScopeSib (AbsScope basePath) (RelScope relPath relUps) + = AbsScope + { absScopePath = NonEmpty.dropEnd (relUps + 1) basePath NonEmpty.|+ relPath + } + +-- | The given relative scope made absolute "relative to" the given +-- parent. -- The semantics are a bit confusing, also see +-- 'anchorScopeSib', here are some examples: +-- +-- >>> "Foo>Bar>Baz" `anchorScopeParent` "Qux" +-- "Foo>Bar>Baz>Qux" +-- >>> "Foo>Bar>Baz" `anchorScopeParent` "Bar>Qux" +-- >>> "Foo>Bar" `anchorScopeParent` "Baz>Qux" +-- "Foo>Bar>Baz>Qux" +anchorScopeParent :: AbsScope -> RelScope -> AbsScope +anchorScopeParent (AbsScope basePath) (RelScope relPath relUps) + = AbsScope + { absScopePath = NonEmpty.dropEnd relUps basePath NonEmpty.|+ relPath + } + +-- | The first absolute scope made "relative to" the second scope +-- (anchor), so that it's an immediate scope if the anchor is its +-- sibling (e.g. in the same directory). +-- The semantics are a bit confusing, also see 'scopeRelToParent', +-- here are some examples: +-- +-- >>> "Foo>Bar>Baz" `scopeRelToSib` "Foo>Bar>Qux" +-- "Baz" +-- >>> "Foo>Bar>Baz" `scopeRelToSib` "Foo>Qux" +-- "Bar>Baz" +-- >>> "Foo>Bar" `scopeRelToSib` "Foo>Baz>Qux" +-- ">> "Foo>Bar>Baz" `scopeRelToSib` "Foo>Qux>Abc" +-- "Baz" +-- >>> "Foo>Bar>Baz" `scopeRelToSib` "Foo>Bar>Baz" +-- "Baz" +-- >>> "Foo>Bar>Baz" `scopeRelToSib` "Foo>Bar" +-- "Bar>Baz" +-- >>> "Foo>Bar>Baz" `scopeRelToSib` "Foo>Bar>Baz>Qux" +-- "" +scopeRelToSib :: AbsScope -> AbsScope -> RelScope +AbsScope tpath `scopeRelToSib` AbsScope apath + = tpath `subpathRelTo` NonEmpty.init apath + +-- | The first absolute scope made "relative to" the second scope +-- (anchor), so that it's an immediate scope if the anchor is its +-- parent (e.g. in the parent directory, with the same name as the +-- child directory). +-- The semantics are a bit confusing, also see 'scopeRelToSib', here are +-- some examples: +-- +-- >>> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Bar>Qux" +-- ">> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Qux" +-- "Baz" +-- >>> "Foo>Bar" `scopeRelToParent` "Foo>Baz>Qux" +-- "<>> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Qux>Abc" +-- "<Baz" +-- >>> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Bar>Baz" +-- ">> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Bar" +-- "Baz" +-- >>> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Bar>Baz>Qux" +-- "< AbsScope -> RelScope +AbsScope tpath `scopeRelToParent` AbsScope apath + = tpath `subpathRelTo` NonEmpty.toList apath + +-- | The first path relative to the second path as a parent. +subpathRelTo :: NonEmpty String -> [String] -> RelScope +xs `subpathRelTo` [] + = RelScope + { relScopePath = xs + , relScopeUps = 0 + } +(x :| xs) `subpathRelTo` (y : ys) + | x /= y || xs == [] + = RelScope + { relScopePath = x :| xs + , relScopeUps = length $ y : ys + } + | otherwise + = NonEmpty.fromList xs `subpathRelTo` ys + +-- | Gets rid of 'relScopeUps'. +globalizeRelScope :: RelScope -> RelScope +globalizeRelScope (RelScope path _) = RelScope path 0 + +-- | The path to get to the file/module at the scope, given the path to +-- the base scope, used by the local dependency resolver. +-- +-- >>> scopeFilepath "foo/Bar" "Baz" +-- foo/Bar/Baz.dscr +-- >>> scopeFilepath "foo/Bar" "Qux" +-- foo/Baz/Qux.dscr +scopeFilepath :: FilePath -> RelScope -> FilePath +scopeFilepath basePath (RelScope relPath relUps) + = takeDirectoryN relUps basePath + intercalate [pathSeparator] (NonEmpty.toList relPath) + <.> "dscr" + +upsSummary :: Int -> String +upsSummary ups = replicate ups '<' + +pathSummary :: NonEmpty String -> String +pathSummary = intercalate ">" . NonEmpty.toList diff --git a/src/Descript/Misc/Build/Read/Parse.hs b/src/Descript/Misc/Build/Read/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/Parse.hs @@ -0,0 +1,2 @@ +-- | General stuff for any parse phase. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Build/Read/Parse/Action.hs b/src/Descript/Misc/Build/Read/Parse/Action.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/Parse/Action.hs @@ -0,0 +1,37 @@ +module Descript.Misc.Build.Read.Parse.Action + ( ParseAction + , runLaterParser + , runFirstParser + ) where + +import Descript.Misc.Build.Read.Parse.Loc +import Descript.Misc.Build.Read.Parse.Error +import Descript.Misc.Build.Read.File +import Descript.Misc.Loc +import Descript.Misc.Ann +import Descript.Misc.Error +import Text.Megaparsec +import Core.Text.Megaparsec +import Data.Text (Text) + +-- | Intermedaite parse action. Parses an @o@, given the previously +-- built item (@i@) and the original file. Encodes failures in a +-- 'ParseError'. +type ParseAction i o = SFile -> i -> ParseResult o + +-- | Parses a series of smaller tokens into a series of bigger tokens. +-- If the parser fails, converts the failure information back into +-- text using the given source so it can be displayed to the user. +-- Stores errors in a 'ParseResult'. Expects the parser to consume all +-- input. +runLaterParser :: (Ann i, Ord (i Range)) + => Parsec RangedError (RangeStream i) o + -> ParseAction (RangeStream i) o +runLaterParser parser (SFile name contents) source + = eitherToResult $ runParserFR parser name contents source + +-- | Parses text into a series of tokens. Stores errors in a +-- 'ParseResult'. Expects the parser to consume all input. +runFirstParser :: Parsec RangedError Text o -> SFile -> ParseResult o +runFirstParser parser (SFile name contents) + = eitherToResult $ runParserF parser name contents diff --git a/src/Descript/Misc/Build/Read/Parse/Error.hs b/src/Descript/Misc/Build/Read/Parse/Error.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/Parse/Error.hs @@ -0,0 +1,102 @@ +module Descript.Misc.Build.Read.Parse.Error + ( RangedErrorMsg (..) + , RangedError (..) + , ParseError + , ParseResult + , ParseResultT + , splitParseError + , parseErrorSummary + ) where + +import Descript.Misc.Build.Read.Parse.Loc +import Descript.Misc.Build.Read.File +import Descript.Misc.Loc +import Descript.Misc.Error +import Descript.Misc.Summary +import qualified Text.Megaparsec.Error as Parsec +import qualified Text.Megaparsec.Pos as Parsec +import Data.Maybe +import Core.Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Set as Set + +data RangedErrorMsg + = RangedErrorMsg + { itemRange :: Range + , itemMsg :: String + } deriving (Eq, Ord, Read, Show) + +data RangedError + = RangedError + { errorRange :: Range + , rangedErrorExpected :: String + , rangedErrorActual :: String + } deriving (Eq, Ord, Read, Show) + +type ParseError t = Parsec.ParseError t RangedError + +type ParseResult a = Result (ParseError Char) a + +type ParseResultT u a = ResultT (ParseError Char) u a + +instance Parsec.ShowErrorComponent RangedError where + showErrorComponent (RangedError _ expected actual) + = "expected " ++ expected ++ ", got " ++ actual + +instance Summary RangedError where + summary x = summary (errorRange x) ++ ": " ++ Parsec.showErrorComponent x + +-- | Takes components with ranges ('RangedError's) and describes them +-- with their ranges, takes all other components and describes them +-- together with the range starting and ending at the general error's +-- position. +splitParseError :: (Ord a, Parsec.ShowToken a) + => ParseError a + -> [RangedErrorMsg] +splitParseError err@(Parsec.TrivialError (gpos :| _) _ _) = + [ RangedErrorMsg + { itemRange = singletonRange $ posToLoc gpos + , itemMsg = Parsec.parseErrorTextPretty err + } + ] +splitParseError (Parsec.FancyError (gpos :| _) items) + = errItemsGenMsg gpos items' ?: errItemRangedMsgs items' + where items' = Set.toList items + +errItemsGenMsg :: Parsec.SourcePos + -> [Parsec.ErrorFancy RangedError] + -> Maybe RangedErrorMsg +errItemsGenMsg gpos + = fmap (mkGenRangedMsg gpos . msgToStr) + . foldMap (fmap strToMsg . errItemGenMsg) + +errItemGenMsg :: Parsec.ErrorFancy RangedError + -> Maybe String +errItemGenMsg (Parsec.ErrorCustom _) = Nothing +errItemGenMsg err = Just $ Parsec.showErrorComponent err + +errItemRangedMsgs :: [Parsec.ErrorFancy RangedError] -> [RangedErrorMsg] +errItemRangedMsgs = mapMaybe errItemRangedMsg + +errItemRangedMsg :: Parsec.ErrorFancy RangedError -> Maybe RangedErrorMsg +errItemRangedMsg (Parsec.ErrorCustom rangedErr) + = Just $ rangedErrMsg rangedErr +errItemRangedMsg _ = Nothing + +rangedErrMsg :: RangedError -> RangedErrorMsg +rangedErrMsg err + = RangedErrorMsg + { itemRange = errorRange err + , itemMsg = Parsec.showErrorComponent err + } + +mkGenRangedMsg :: Parsec.SourcePos -> String -> RangedErrorMsg +mkGenRangedMsg gpos desc + = RangedErrorMsg + { itemRange = singletonRange $ posToLoc gpos + , itemMsg = desc + } + +-- | Summarizes a parse error in a larger context (e.g. build error). +parseErrorSummary :: SFile -> ParseError Char -> String +parseErrorSummary file err = "parse error: " ++ summaryF file err diff --git a/src/Descript/Misc/Build/Read/Parse/Loc.hs b/src/Descript/Misc/Build/Read/Parse/Loc.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/Parse/Loc.hs @@ -0,0 +1,143 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Descript.Misc.Build.Read.Parse.Loc + ( RangeStream + , runParserFR + , ranged + , expRanged + , expRanged_ + , exactlyR + , mapSatisfyR + , rangeToPosStack + , getLoc + , posToLoc + , locToPos + ) where + +import Descript.Misc.Loc +import Descript.Misc.Ann +import Text.Megaparsec hiding (parse) +import Core.Text.Megaparsec +import Core.Text.Megaparsec.Error +import Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import qualified Data.Text as Text + +type RangeStream a = [a Range] + +instance (Ann a, Ord (a Range)) => Stream (RangeStream a) where + type Token (RangeStream a) = a Range + type Tokens (RangeStream a) = [a Range] + + tokenToChunk _pxy x = [x] + tokensToChunk _pxy = id + chunkToTokens _pxy = id + chunkLength _pxy = length + chunkEmpty _pxy = null + positionAt1 _pxy pos = rePos pos . start . getRange + positionAtN _pxy pos [] = pos + positionAtN _pxy pos (x : _) = rePos pos $ start $ getRange x + advance1 _pxy _ pos = rePos pos . end . getRange + advanceN _pxy _ pos [] = pos + advanceN _pxy _ pos xs = rePos pos $ start $ getRange $ last xs + take1_ = uncons + takeN_ 0 [] = Just ([], []) + takeN_ _ [] = Nothing + takeN_ n xs = Just $ splitAt n xs + takeWhile_ = span + +-- | If the parser fails, converts the failure information back into +-- text using the given source so it can be displayed to the user. +runParserFR :: (Ord e, Ann i, Ord (i Range)) + => Parsec e (RangeStream i) o + -> String + -> Text + -> RangeStream i + -> Either (ParseError Char e) o +runParserFR parser filename source input + = case runParserF parser filename input of + Left err -> Left $ traverseErrorSource fixErrorSource err + Right output -> Right output + where fixErrorSource = Text.unpack . (`inText` source) . getRange + +-- | All text consumed by the parser will be in the range. +ranged :: (MonadParsec e s m) => m (Range -> a) -> m a +ranged parse = do + start' <- getLoc + f <- parse + end' <- getLoc + let range + = Range + { start = start' + , end = end' + } + pure $ f range + +-- | The range will start where the parser starts, and have the given +-- length in columns and no length in lines. +expRanged :: (MonadParsec e s m) + => Int -> m (Range -> a) -> m a +expRanged len parse = do + start' <- getLoc + f <- parse + let range + = Range + { start = start' + , end = start' `addCols` len + } + pure $ f range + +-- | The range will start where the parser starts, and have the given +-- length in columns and no length in lines. +expRanged_ :: (MonadParsec e s m) + => Int -> m () -> m Range +expRanged_ len = expRanged len . (id <$) + +-- | Expects the input without the range to be the given value. +exactlyR :: (MonadParsec e s m, Functor a, Token s ~ a Range, Eq (a ())) + => a () -> m () +exactlyR = mapExactly remAnns . (singletonRange loc1 <$) + +-- | Applies the function to the input without the range. If it +-- succeeds, returns the output. If it fails, returns an error +-- indicating that the input was unexpected. +mapSatisfyR :: (MonadParsec e s m, Functor a, Token s ~ a Range) + => (a () -> Maybe b) -> m b +mapSatisfyR f = mapSatisfy $ f . remAnns + +getLoc :: MonadParsec e s m => m Loc +getLoc = posToLoc <$> getPosition + +-- | Converts a range to a stack of positions for a 'ParseError'. +-- The stack will have one item - the start of the range. +-- Uses the string for the filename. +rangeToPosStack :: String -> Range -> NonEmpty SourcePos +rangeToPosStack filename range = locToPos filename (start range) :| [] + +posToLoc :: SourcePos -> Loc +posToLoc pos + = Loc + { line = sourceLine pos + , column = sourceColumn pos + } + +rePos :: SourcePos -> Loc -> SourcePos +rePos = locToPos . sourceName + +locToPos :: String -> Loc -> SourcePos +locToPos filename loc + = SourcePos + { sourceName = filename + , sourceLine = line loc + , sourceColumn = column loc + } + +-- | Alias for 'getAnn' when dealing with a ranged value. +getRange :: (Ann a) => a Range -> Range +getRange = getAnn diff --git a/src/Descript/Misc/Build/Read/Parse/SrcAnn.hs b/src/Descript/Misc/Build/Read/Parse/SrcAnn.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Read/Parse/SrcAnn.hs @@ -0,0 +1,120 @@ +module Descript.Misc.Build.Read.Parse.SrcAnn + ( SrcAnn (..) + , TaintAnn (..) + , parsedSrcAnn + , gendSrcAnn + , isTainted + , appGend + ) where + +import Descript.Misc.Loc +import Descript.Misc.Summary +import Descript.Misc.Ann +import Data.Semigroup + +-- | The relation between this AST node and the source it came from. +-- Organizes range and tainted status. +data SrcAnn + = SrcAnn + { -- | Where in the file the node came from. + srcRange :: Range + -- | Whether the node was completely generated or modified. A node + -- is tainted if it's fully tainted, or one of its children are tainted. + , isFullyTainted :: Bool + } deriving (Eq, Ord, Read, Show) + +-- | An annotation which explicitly specifies or doesn't specify that a +-- node is tainted. +class (Semigroup an) => TaintAnn an where + -- | Specifies the node is fully tainted, if the annotation does so. + -- Otherwise does nothing. + taint :: an -> an + + -- | An annotation for a node inserted before the given node. + preInsertAnn :: an -> an + + -- | An annotation for a node inserted after the given node + postInsertAnn :: an -> an + +instance TaintAnn SrcAnn where + taint ann + = SrcAnn + { srcRange = taint $ srcRange ann + , isFullyTainted = True + } + + preInsertAnn ann + = SrcAnn + { srcRange = preInsertAnn $ srcRange ann + , isFullyTainted = isFullyTainted ann + } + + postInsertAnn ann + = SrcAnn + { srcRange = postInsertAnn $ srcRange ann + , isFullyTainted = isFullyTainted ann + } + +instance TaintAnn Range where + taint = id + + preInsertAnn = singletonRange . start + + postInsertAnn = singletonRange . end + +instance TaintAnn () where + taint () = () + preInsertAnn () = () + postInsertAnn () = () + +instance Semigroup SrcAnn where + SrcAnn xSrcRange _ <> SrcAnn ySrcRange _ + = SrcAnn + { srcRange = xSrcRange <> ySrcRange + , isFullyTainted = True + } + +instance AnnSummary SrcAnn where + annSummaryPre = annSummaryPre . srcRange + +instance Summary SrcAnn where + summary (SrcAnn srcRange' isFullyTainted') + = "{" + ++ summary srcRange' + ++ ", " + ++ taintSummary isFullyTainted' + ++ "}" + +-- | The annotation for a parsed value with the given range (the range +-- is typically the parsed value's annotation). Not tainted. +parsedSrcAnn :: Range -> SrcAnn +parsedSrcAnn srcRange' + = SrcAnn + { srcRange = srcRange' + , isFullyTainted = False + } + +-- | The annotation for a generated (not parsed) value at the given range. +gendSrcAnn :: Range -> SrcAnn +gendSrcAnn srcRange' + = SrcAnn + { srcRange = srcRange' + , isFullyTainted = True + } + +-- | Whether the node wasn't just parsed from a file, it was also +-- modified or completely generated. +-- +-- If a node isn't tainted, it can just be "printed" by just taking the +-- text at its range. Otherwise its text needs to be regenerated. +isTainted :: (Ann a) => a SrcAnn -> Bool +isTainted = any isFullyTainted + +-- | Appends a generated node to a parsed (and possibly modified) node. +appGend :: (Ann a, TaintAnn an, Semigroup (a an)) => a an -> a () -> a an +x `appGend` y = x <> (ann' <$ y) + where ann' = taint $ postInsertAnn $ getAnn x + +taintSummary :: Bool -> String +taintSummary True = "tainted" +taintSummary False = "untainted" diff --git a/src/Descript/Misc/Build/Write.hs b/src/Descript/Misc/Build/Write.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write.hs @@ -0,0 +1,2 @@ +-- | Write the AST (reprint or compile). +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Build/Write/Compile.hs b/src/Descript/Misc/Build/Write/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Compile.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Build/Write/Compile/Code.hs b/src/Descript/Misc/Build/Write/Compile/Code.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Compile/Code.hs @@ -0,0 +1,14 @@ +module Descript.Misc.Build.Write.Compile.Code + ( languageExt + ) where + +import Data.Char + +-- TODO Get language extension (and other future information like +-- command for running program) from a database. Want current +-- implementation (return the language itself as an extension) to be +-- backup. + +-- | Gets the file extension for the given language. +languageExt :: String -> String +languageExt = map toLower diff --git a/src/Descript/Misc/Build/Write/Compile/Package.hs b/src/Descript/Misc/Build/Write/Compile/Package.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Compile/Package.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Misc.Build.Write.Compile.Package + ( PackageContents (..) + , Package (..) + , savePackage + , pprintPackage + ) where + +import Descript.Misc.Summary +import Data.Monoid +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import System.FilePath +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Core.Data.Text as Text +import qualified Data.Text.Encoding as Text + +data PackageContents + = PackageFile ByteString + | PackageDirectory [Package] + deriving (Eq, Ord, Read, Show) + +-- | The final output of a compile. Can be a single file or a directory +-- of sub-packages. +data Package + = Package + { packageName :: String -- ^ Name of file (with extension) or directory. + , packageContents :: PackageContents + } deriving (Eq, Ord, Read, Show) + +instance Summary Package where + summary = Text.unpack . pprintPackage + +-- | Writes the package to the given path. +savePackage :: FilePath -> Package -> IO () +savePackage dir (Package name contents) + = savePackageContents (dir name) contents + +savePackageContents :: FilePath -> PackageContents -> IO () +savePackageContents path (PackageFile content) = ByteString.writeFile path content +savePackageContents path (PackageDirectory subs) = mapM_ (savePackage path) subs + +-- | Pretty-prints the package. Files which aren't text (e.g. images) +-- won't print well, however. +pprintPackage :: Package -> Text +pprintPackage (Package name contents) + = Text.pack name <> "\n" <> pprintPackageContents contents + +pprintPackageContents :: PackageContents -> Text +pprintPackageContents (PackageFile content) = indentContent $ Text.decodeUtf8 content +pprintPackageContents (PackageDirectory subs) + = Text.unlines $ map (indentSubPackage . pprintPackage) subs + +indentSubPackage :: Text -> Text +indentSubPackage = Text.indentBullet + +indentContent :: Text -> Text +indentContent = Text.indentBlockQuote diff --git a/src/Descript/Misc/Build/Write/Compile/Result.hs b/src/Descript/Misc/Build/Write/Compile/Result.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Compile/Result.hs @@ -0,0 +1,17 @@ +module Descript.Misc.Build.Write.Compile.Result + ( CompileError (..) + , CompileResult + ) where + +import Descript.Misc.Build.Write.Compile.Package +import Descript.Misc.Error +import Descript.Misc.Summary + +-- | An error created during compilation +newtype CompileError = NotFinal String + deriving (Eq, Ord, Read, Show) + +type CompileResult = Result CompileError Package + +instance Summary CompileError where + summary (NotFinal valPr) = "not final (bad type): " ++ valPr diff --git a/src/Descript/Misc/Build/Write/Print.hs b/src/Descript/Misc/Build/Write/Print.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Print.hs @@ -0,0 +1,3 @@ +-- | Converts an AST node back into source text - the opposite of +-- parsing. +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Build/Write/Print/APrint.hs b/src/Descript/Misc/Build/Write/Print/APrint.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Print/APrint.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE Rank2Types #-} + +module Descript.Misc.Build.Write.Print.APrint + ( APrint (..) + , ppunc + , pimpIf + ) where + +import Data.List +import Data.String + +-- | An abstract print - a stream of printed tokens. +-- This abstracts over printing, allowing a single method to implement +-- pretty prints, patches, reduced prints, and (in the future) prints +-- with different style guidelines. +class (Eq a, Monoid a, IsString a) => APrint a where + -- | An "significant" block of text: a block of text which will be + -- different for different occurrences of this node, like a symbol's + -- string. + -- + -- This is different than 'ppunc' ('fromString'), which is an + -- "insignificant" block of text: a block of text which will be the + -- same for every occurrence of the node, like "?" at the end of a + -- query or ", " between record properties (delimiters). + plex :: String -> a + + -- | A piece of text which can sometimes be omitted, like a property + -- key (could be implicit and resolved by index). The content doesn't + -- /always/ have to be optional (if the property key is in the wrong + -- position it can't be implicit). This is used to omit patches which + -- are "parsed" from empty ranges of text (since the implicit content + -- was obviously implicit). + pimp :: a -> a + + -- | 'intercalate'. + pintercal :: a -> [a] -> a + pintercal sep = mconcat . intersperse sep + +-- An "insignificant" block of text: a block of text which will be the +-- same for every occurrence of the node, like "?" at the end of a +-- query or ", " between record properties (delimiters). This is an +-- alias for 'fromString', but clearer. +-- +-- This is different than 'plex', a "significant" block of text: a block +-- of text which will be different for different occurrences of this +-- node, like a symbol's string. +-- +-- With 'OverloadedStrings' turned on, any string literal will be +-- wrapped with 'ppunc' - +-- +-- > ppunc = fromString +ppunc :: (APrint a) => String -> a +ppunc = fromString + +-- | Marks the text implicit (can be omitted) if the given condition is +-- true, otherwise returns the text as-is. +pimpIf :: (APrint a) => Bool -> a -> a +pimpIf True = pimp +pimpIf False = id diff --git a/src/Descript/Misc/Build/Write/Print/Patch.hs b/src/Descript/Misc/Build/Write/Print/Patch.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Print/Patch.hs @@ -0,0 +1,149 @@ +module Descript.Misc.Build.Write.Print.Patch + ( Change + , CChange + , Patch (..) + , CPatch (..) + , replacePatch + , mkCPatch + , liftCPatch + , apPatch + , alignRange + , isInsertPatch + ) where + +import Descript.Misc.Loc +import Data.Monoid +import Core.Data.Group +import Data.List hiding ((\\)) +import Data.Text (Text) +import qualified Data.Text as Text + +-- | Completely replaces or patches text. +type Change = Either Text Patch + +-- | Completely replaces or patches text. +type CChange = Either Text CPatch + +-- | Replaces parts of text inside a bigger block. +data Patch + = Patch + { cpatches :: [CPatch] -- ^ Continuous blocks which are replaced. Assumed to be in order. + , patchOffset :: LocDiff -- ^ The change in size after the patch is applied. + } deriving (Eq, Ord, Read, Show) + +-- | Replaces a continuous block of text inside a bigger block. +data CPatch + = CPatch + { cpatchRange :: Range + , cpatchText :: Text + } deriving (Eq, Ord, Read, Show) + +-- | Assumes when 2 patches are appended, the later patch's range is +-- after the earlier patch's range. +instance Monoid Patch where + mempty + = Patch + { cpatches = [] + , patchOffset = mempty + } + + -- | Assumes the later patch's range is after the earlier patch's range. + Patch xCPatches xPatchOffset `mappend` Patch yCPatches yPatchOffset + = Patch + { cpatches = xCPatches ++ yCPatches' + , patchOffset = xPatchOffset <> yPatchOffset + } + where yCPatches' = map (offsetCPatch xPatchOffset) yCPatches + +-- | Creates a patch which replaces the first text with the second. +replacePatch :: Text -> Text -> Patch +replacePatch = mkCPatch . textRange + +-- | Creates a continuous 'Patch', spanning the given range with the +-- given text. +mkCPatch :: Range -> Text -> Patch +mkCPatch range = liftCPatch . CPatch range + +liftCPatch :: CPatch -> Patch +liftCPatch cpatch + | isCPatchEmpty cpatch = mempty + | otherwise + = Patch + { cpatches = [cpatch] + , patchOffset = cpatchOffset cpatch + } + +isCPatchEmpty :: CPatch -> Bool +isCPatchEmpty (CPatch range text) = isSingletonRange range && Text.null text + +cpatchOffset :: CPatch -> LocDiff +cpatchOffset (CPatch range text) + = textDiff (line $ start range) text \\ rangeDiff range + +offsetCPatch :: LocDiff -> CPatch -> CPatch +offsetCPatch diff (CPatch range text) + = CPatch (offsetRange diff range) text + +-- | Applies the patch to the text - replaces all patched ranges. +apPatch :: Patch -> Text -> Text +apPatch patch text = foldl' (flip apCPatch) text $ cpatches patch + +apCPatch :: CPatch -> Text -> Text +apCPatch (CPatch range patch) orig + = start range `beforeInText` orig + <> patch + <> end range `afterInText` orig + +-- | Adjusts the range in text before the patch so it contains the same +-- content (except if deleted) in text after the patch. +alignRange :: Patch -> Range -> Range +alignRange = alignRangeCs . cpatches + +alignRangeCs :: [CPatch] -> Range -> Range +alignRangeCs = flip $ foldl' $ flip alignRangeC + +-- | Adjusts the range in text before the patch so it contains the same +-- content (except if deleted) in text after the patch. +alignRangeC :: CPatch -> Range -> Range +alignRangeC (CPatch (Range pStart pEnd) content) (Range xStart xEnd) + | pEnd <= xStart + = Range + { start = xStart `addDiff` coff + , end = xEnd `addDiff` coff + } + | pStart >= xEnd + = Range + { start = xStart + , end = xEnd + } + | pStart <= xStart && pEnd < xEnd + = Range + { start = pEnd `addDiff` coff + , end = xEnd `addDiff` coff + } + | pStart <= xStart && pEnd >= xEnd -- Patch completely replaces range + = Range -- Both could be `pStart or `offsetRange coff pEnd`, must be same + { start = pStart + , end = pStart + } + | pStart > xStart && pEnd < xEnd + = Range + { start = xStart + , end = xEnd `addDiff` coff + } + | pStart > xStart && pEnd >= xEnd + = Range + { start = xStart + , end = pEnd `addDiff` coff + } + | otherwise + = error "unexpected \"impossible\" location comparison" + where coff = textDiff (line pStart) content + +-- | Whether the patch only inserts text, doesn't remove any. +isInsertPatch :: Patch -> Bool +isInsertPatch = all isInsertCPatch . cpatches + +-- | Whether the patch only inserts text, doesn't remove any. +isInsertCPatch :: CPatch -> Bool +isInsertCPatch (CPatch range _) = isSingletonRange range diff --git a/src/Descript/Misc/Build/Write/Print/PrimPrintable.hs b/src/Descript/Misc/Build/Write/Print/PrimPrintable.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Print/PrimPrintable.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Descript.Misc.Build.Write.Print.PrimPrintable + ( PrimPrintable (..) + ) where + +import Descript.Misc.Build.Write.Print.APrint +import Descript.Misc.Summary +import Data.Ratio +import Data.Monoid +import Data.Text (Text) + +-- | A primitive value inside of an AST leaf which can be printed back +-- into source text. Instances would implement 'Printable', but they +-- don't have annotations, so they implement this instead. +class (Summary a) => PrimPrintable a where + -- | Prints the primitive value. + pprim :: (APrint r) => a -> r + +instance PrimPrintable Char where + pprim = plex . show + +instance PrimPrintable Int where + pprim = plex . show + +instance PrimPrintable Integer where + pprim = plex . show + +instance PrimPrintable Float where + pprim = plex . show + +instance PrimPrintable Double where + pprim = plex . show + +instance (a ~ Char) => PrimPrintable [a] where + pprim = plex . show + +instance PrimPrintable Text where + pprim = plex . show + +instance (PrimPrintable a) => PrimPrintable (Ratio a) where + pprim x + | denomPrint == "1" = numPrint + | otherwise = numPrint <> "/" <> denomPrint -- Or just 'plex' everything? + where numPrint = pprim $ numerator x + denomPrint = pprim $ denominator x diff --git a/src/Descript/Misc/Build/Write/Print/PrintPatch.hs b/src/Descript/Misc/Build/Write/Print/PrintPatch.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Print/PrintPatch.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Descript.Misc.Build.Write.Print.PrintPatch + ( ppatch + , ppatchThorough + , ppatchRec + , ppatchF + ) where + +import Descript.Misc.Build.Write.Print.PrintText +import Descript.Misc.Build.Write.Print.Printable +import Descript.Misc.Build.Write.Print.APrint +import Descript.Misc.Build.Write.Print.Patch +import Descript.Misc.Build.Read.Parse +import Descript.Misc.Ann +import Core.Data.Proxy +import Data.Maybe +import Data.List +import Data.String + +-- | A "printed" patch - a patch generated using printing. Punctuation +-- (such as delimiters) are ignored, so only 'plex' patches are actually +-- applied. +newtype PrintPatch + = PrintPatch{ runPrintPatch :: Patch } + deriving (Eq, Monoid) + +newtype PrintPatchThorough + = PrintPatchThorough{ runPrintPatchThorough :: Maybe Patch } + deriving (Eq, Monoid) + +instance APrint PrintPatch where + plex = plexPatchErr + + pimp = id + + pintercal sep = mconcat . intersperse sep + +instance APrint PrintPatchThorough where + plex _ = PrintPatchThorough Nothing + + pimp _ = PrintPatchThorough $ Just mempty + + pintercal sep = mconcat . intersperse sep + +instance IsString PrintPatch where + fromString _ = mempty + +instance IsString PrintPatchThorough where + fromString _ = PrintPatchThorough $ Just mempty + +-- | "Pretty patch". Converts the node into a patch which can be applied +-- to the source text, so when it's parsed again, it yields the new node. +-- This patch will affect as little as possible - e.g. if the node +-- wasn't tainted (came right from text), the patch will do absolutely +-- nothing. +ppatch :: (Printable a) => a SrcAnn -> Patch +ppatch x + | isFullyTainted ann || (isTainted' && needsFullReprint (proxyOf x)) + = mkCPatch (srcRange ann) $ pprint x + | isTainted' = ppatchRec ppatch x + | otherwise = mempty + where isTainted' = isTainted x + ann = getAnn x + +-- | Pretty patch this node, recursively patching partially tainted +-- nodes. The resulting patch should be identical to 'ppatch' but more +-- complicated. Useful only for testing. +ppatchThorough :: (Printable a) => a SrcAnn -> Patch +ppatchThorough x + | isFullyTainted ann = fullPatch + | otherwise = fullPatch `fromMaybe` ppatchThoroughRec ppatchThorough x + where fullPatch = mkCPatch (srcRange ann) $ pprint x + ann = getAnn x + +-- | Converts this node into a patch which can be applied to the source +-- by converting its children into patches. +ppatchRec :: (Printable a) + => (forall b. (Printable b) => b an -> Patch) + -> a an + -> Patch +ppatchRec sub = runPrintPatch . aprintRec (PrintPatch . sub) + +-- | Converts this node into a patch which can be applied to the source +-- by converting its children into patches. The resulting patch should +-- be identical to 'ppatch' but more complicated. Useful only for testing. +ppatchThoroughRec :: (Printable a) + => (forall b. (Printable b) => b an -> Patch) + -> a an + -> Maybe Patch +ppatchThoroughRec sub + = runPrintPatchThorough + . aprintRec (PrintPatchThorough . Just . sub) + +-- | Convert the nodes into a patch which can be applied to the source +-- text, so when it's parsed again, it yields the new node. Used for +-- lexemes. +ppatchF :: (Foldable w, Printable a) => w (a SrcAnn) -> Patch +ppatchF = foldMap ppatch + +-- | An error generated when 'plex' is used to create a patch. +plexPatchErr :: a +plexPatchErr + = error $ concat + [ "'plex' can't be used when generating patches.\n" + , "This was raised because an partially tainted node (not fully " + , "tainted but with tainted children) used 'plex'. A node should " + , "never use 'plex' unless it's a leaf (has no children), and then " + , "it should never be partially tainted, either fully tainted or " + , "fully untainted." + ] diff --git a/src/Descript/Misc/Build/Write/Print/PrintReduce.hs b/src/Descript/Misc/Build/Write/Print/PrintReduce.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Print/PrintReduce.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Descript.Misc.Build.Write.Print.PrintReduce + ( reducePrint + , reducePrintF + ) where + +import Descript.Misc.Build.Write.Print.Printable +import Descript.Misc.Build.Write.Print.APrint +import Data.List +import Data.String + +newtype ReducePrint + = ReducePrint{ runReducePrint :: String } + deriving (Eq, Ord, Read, Show, Monoid) + +instance IsString ReducePrint where + fromString ", " = ReducePrint "" + fromString x = ReducePrint x + +instance APrint ReducePrint where + plex = ReducePrint + + pimp _ = ReducePrint "" + + pintercal (ReducePrint sep) = ReducePrint . intercalate sep . map runReducePrint + +-- | Prints this node so that, for a limited ("well-styled") grammar, +-- it's guarenteed to be a subsequence of the text it was parsed from. +-- If @str@ is of this grammar, and @parse@ parses @str@, then: +-- +-- > reducePrint (parse str) `isSubsequenceOf` str +-- +-- Unprintable text or data which could be parsed multiple ways will +-- be completely excluded. This is used to test parsing. +reducePrint :: (Printable a) => a an -> String +reducePrint = runReducePrint . aprint + +-- | Prints the nodes so that, for a limited ("well-styled") grammar, +-- the output is guarenteed to be subsequence of the text the nodes were +-- parsed from. +-- The grammar is even weaker than 'reducePrint', since 'reducePrint' +-- excludes values which have no location. +reducePrintF :: (Foldable w, Printable a) => w (a an) -> String +reducePrintF = foldMap reducePrint diff --git a/src/Descript/Misc/Build/Write/Print/PrintString.hs b/src/Descript/Misc/Build/Write/Print/PrintString.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Print/PrintString.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} + +module Descript.Misc.Build.Write.Print.PrintString + ( pprintStr + , pprintSummary + , pprintSummaryRec + , pprintSummaryRecF + ) where + +import Descript.Misc.Build.Write.Print.Printable +import Descript.Misc.Build.Write.Print.APrint +import Descript.Misc.Ann +import Descript.Misc.Summary +import Data.String +import Data.List + +-- | A plain printed string. +newtype PrintString + = PrintString{ runPrintString :: String } + deriving (Eq, Monoid, IsString) + +instance APrint PrintString where + plex = PrintString -- Same as 'ppunc' + + pimp = id + + pintercal (PrintString sep) + = PrintString . intercalate sep . map runPrintString + +-- | Pretty-prints the node into a string. +pprintStr :: (Printable a) => a an -> String +pprintStr = runPrintString . aprint + +-- | Pretty-prints the node into a string, using the given function to +-- print children. +pprintStrRec :: (Printable a) + => (forall b. (Printable b) => b an -> String) + -> a an + -> String +pprintStrRec sub = runPrintString . aprintRec (PrintString . sub) + +-- | Pretty-prints the node into a string, using the given function to +-- print children. +pprintStrRecF :: (FwdPrintable a) + => (forall b. (Printable b) => b an -> String) + -> a an + -> String +pprintStrRecF sub = runPrintString . afprintRec (PrintString . sub) + +-- | Gets a summary of the value by printing it. Useful when +-- implementing 'Summary' on leafs ('pprintSummaryRec' for branches): +-- +-- > summary = pprintSummary +pprintSummary :: (Printable a) => a an -> String +pprintSummary = pprintStr . remAnns + +-- | Gets a summary of the value by printing it. Useful when +-- implementing 'Summary' (on branches or leafs): +-- +-- > summaryRec = pprintSummaryRec +pprintSummaryRec :: (Printable a) + => (forall b. (Summary b) => b -> String) + -> a an + -> String +pprintSummaryRec sub = pprintStrRec sub . remAnns + +-- | Gets a summary of the value by printing it. Useful when +-- implementing 'Summary' (on branches or leafs): +-- +-- > summaryRec = pprintSummaryRec +pprintSummaryRecF :: (FwdPrintable a) + => (forall b. (Summary b) => b -> String) + -> a an + -> String +pprintSummaryRecF sub = pprintStrRecF sub . remAnns diff --git a/src/Descript/Misc/Build/Write/Print/PrintText.hs b/src/Descript/Misc/Build/Write/Print/PrintText.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Print/PrintText.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} + +module Descript.Misc.Build.Write.Print.PrintText + ( pprint + , reprint + , pprintF + ) where + +import Descript.Misc.Build.Write.Print.Printable +import Descript.Misc.Build.Write.Print.APrint +import Descript.Misc.Build.Read.Parse +import Descript.Misc.Loc +import Descript.Misc.Ann +import Data.String +import Data.Text (Text) +import qualified Data.Text as Text + +-- | Plain printed text. +newtype PrintText + = PrintText{ runPrintText :: Text } + deriving (Eq, Monoid, IsString) + +instance APrint PrintText where + plex = PrintText . Text.pack -- Same as 'ppunc' + + pimp = id + + pintercal (PrintText sep) + = PrintText . Text.intercalate sep . map runPrintText + +-- | Pretty-prints the node. +pprint :: (Printable a) => a an -> Text +pprint = runPrintText . aprint + +-- | Pretty-prints the node, using the given function to print children. +pprintRec :: (Printable a) + => (forall b. (Printable b) => b an -> Text) + -> a an + -> Text +pprintRec sub = runPrintText . aprintRec (PrintText . sub) + +-- | Converts the node back into source text. +-- Will reuse the text the AST was derived from if it isn't tainted. +-- Otherwise will print from scratch (like 'pprint'). +reprint :: (Printable a) => Text -> a SrcAnn -> Text +reprint src x + | isTainted x = pprintRec (reprint src) x + | otherwise = srcRange (getAnn x) `inText` src + +-- | Pretty-prints the nodes and concats them to form source text. Used +-- for lexemes. +pprintF :: (Foldable w, Printable a) => w (a an) -> Text +pprintF = foldMap pprint diff --git a/src/Descript/Misc/Build/Write/Print/Printable.hs b/src/Descript/Misc/Build/Write/Print/Printable.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Build/Write/Print/Printable.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} + +module Descript.Misc.Build.Write.Print.Printable + ( Printable (..) + , FwdPrintable (..) + ) where + +import Descript.Misc.Build.Write.Print.APrint +import Descript.Misc.Ann +import Descript.Misc.Summary +import Data.Proxy + +-- | An AST node which can be printed back into source text. +-- +-- Note: The 'Summary' dependency is for convenience, because most (if +-- not all) prints make good summaries. With it, you can implement +-- 'Summary' using: +-- +-- > summaryRec = pprintSummaryRec +class (Ann a, Summary (a ())) => Printable a where + {-# MINIMAL aprint | aprintRec #-} + + -- | Pretty-prints this node into an abstract form. + aprint :: (APrint r) => a an -> r + aprint = aprintRec aprint + + -- | Pretty-prints this node into an abstract form, + -- printing children using the given function. + aprintRec :: (APrint r) + => (forall b. (Printable b) => b an -> r) + -> a an + -> r + aprintRec _ = aprint + + -- | Whether this node needs to be completely reprinted or patched if + -- tainted (a child changes). Defaults to 'False' for convenience. + needsFullReprint :: Proxy (a an) -> Bool + needsFullReprint _ = False + +-- | An "rough" AST node which can be printed back into source text. The +-- difference between this and 'Print' is that this doesn't need 'Ann', +-- which allows for (probably only use) 'Maybe' values to be printed. +-- +-- If an instance is also 'Printable', the implementation should always be: +-- +-- > afprintRec = id +-- +-- (calls @sub@ on itself). +-- +-- When printing a child instance, "forward" @sub@, e.g.: +-- +-- > aprintRec sub (Add aPrintableChild aFwdPrintableChild) +-- > = sub aPrintableChild <> " + " <> afprintRec sub aFwdPrintableChild +class (Functor a, Foldable a, Traversable a, Summary (a ())) => FwdPrintable a where + -- | Pretty-prints this node into an abstract form, + -- printing children using the given function. + afprintRec :: (APrint r) + => (forall b. (Printable b) => b an -> r) + -> a an + -> r diff --git a/src/Descript/Misc/Error.hs b/src/Descript/Misc/Error.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Error.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Error/Dirty.hs b/src/Descript/Misc/Error/Dirty.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Error/Dirty.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +module Descript.Misc.Error.Dirty + ( Dirty (..) + , DirtyM + , DirtyT + , DirtyRes + , DirtyResT + , mapWarnings + , mapWarningsT + , resToDirtyMon + , resToDirtyMonT + , mkDirtyM + , mkDirtyT + , runDirtyM + , runDirtyT + , runDirtyRes + , runDirtyResT + ) where + +import Descript.Misc.Error.Result +import Descript.Misc.Summary +import Data.Bifunctor +import Data.Tuple +import Control.Monad.Trans.Writer.Strict +import Data.Functor.Identity + +-- | The result of performing an operation which can be used, but has +-- some warnings of type @w@. This is isomorphic to 'Writer', but +-- clearer and doesn't need 'runWriter', although it's not a 'Monad'. +data Dirty w a + = Dirty + { dirtyWarnings :: [w] + , dirtyVal :: a + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | 'Dirty' as a monad. +type DirtyM w a = Writer [w] a + +-- | 'Dirty' monad transformer. +type DirtyT w u a = WriterT [w] u a + +-- | Stacked 'Result' and 'Dirty' (uses 'DirtyM'). Can completely fail +-- with an error (and possibly some warnings), partially succeed with +-- warnings, or completely succeed. +type DirtyRes e w a = ResultT e (WriterT [w] Identity) a + +-- | Further stacked 'DirtyRes'. +type DirtyResT e w u a = ResultT e (WriterT [w] u) a + +instance (Summary w, Summary a) => Summary (Dirty w a) where + summary (Dirty warnings x) = unlines + $ summary x + : "Warnings:" + : map summary warnings + +-- | Transforms the warnings in the 'Dirty'. +mapWarnings :: (w1 -> w2) -> Dirty w1 a -> Dirty w2 a +mapWarnings f (Dirty warns x) = Dirty (map f warns) x + +-- | Transforms the warnings in the 'DirtyT'. +mapWarningsT :: (Monad u) => (w1 -> w2) -> DirtyT w1 u a -> DirtyT w2 u a +mapWarningsT = mapWriterT . fmap . second . map + +-- | If the result succeeded, returns the value and no warnings. +-- If it failed, returns 'mempty' and the error as a single warning. +resToDirtyMon :: (Monoid a) => Result ew a -> Dirty ew a +resToDirtyMon (Success x) = Dirty [] x +resToDirtyMon (Failure err) = Dirty [err] mempty + +-- | If the result succeeded, returns the value and no warnings. +-- If it failed, returns 'mempty' and the error as a single warning. +resToDirtyMonT :: (Monad u, Monoid a) => ResultT ew u a -> DirtyT ew u a +resToDirtyMonT = mkDirtyT . fmap resToDirtyMon . runResultT + +-- | Converts a 'Dirty' into a 'DirtyM'. +mkDirtyM :: Dirty w a -> DirtyM w a +mkDirtyM = writer . dirtyToTuple + +-- | Converts a wrapped 'Dirty' into a 'DirtyT'. +mkDirtyT :: (Monad u) => u (Dirty w a) -> DirtyT w u a +mkDirtyT = WriterT . fmap dirtyToTuple + +-- | Converts a 'Dirty' into a 2-tuple for 'Writer's. +dirtyToTuple :: Dirty w a -> (a, [w]) +dirtyToTuple (Dirty warns x) = (x, warns) + +-- | Converts a 'DirtyM' into a 'Dirty'. +runDirtyM :: DirtyM w a -> Dirty w a +runDirtyM = uncurry Dirty . swap . runWriter + +-- | Converts a 'DirtyT' into a wrapped 'Dirty'. +runDirtyT :: (Monad u) => DirtyT w u a -> u (Dirty w a) +runDirtyT = fmap (uncurry Dirty . swap) . runWriterT + +-- | Unstacks the 'DirtyRes'. +runDirtyRes :: DirtyRes e w a -> Dirty w (Result e a) +runDirtyRes = runDirtyM . runResultT + +-- | Unstacks the 'DirtyResT'. +runDirtyResT :: (Monad u) => DirtyResT e w u a -> u (Dirty w (Result e a)) +runDirtyResT = runDirtyT . runResultT diff --git a/src/Descript/Misc/Error/Result.hs b/src/Descript/Misc/Error/Result.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Error/Result.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Misc/Error/Result/Base.hs b/src/Descript/Misc/Error/Result/Base.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Error/Result/Base.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} + +-- | Datatypes which encode errors. +module Descript.Misc.Error.Result.Base + ( ErrorMsg (..) + , Result (..) + , UResult + , strToMsg + , msgToStr + , maybeToResult + , maybeToUResult + , eitherToResult + , isFailure + , isSuccess + , mapSuccess + , mapError + ) where + +import Descript.Misc.Summary +import Data.Monoid +import Data.Bifunctor +import Data.List +import Control.Applicative +import Control.Monad + +-- | An error message. Like an enhanced string - when combined, +-- automatically adds "and". +newtype ErrorMsg = ErrorMsg [String] deriving (Eq, Ord, Read, Show, Monoid) + +-- | Either produces a value or fails. This is isomorphic to 'Either', +-- but has an 'Alternative' and 'MonadPlus' implementation (for 'Monoid' +-- errors), and constructors are more descriptive ('Failure' and +-- 'Success' vs. 'Left' and 'Right'). +data Result e a + = Failure e + | Success a + deriving (Eq, Ord, Read, Show, Functor) + +-- | Doesn't have any failure info. +type UResult a = Result () a + +instance Bifunctor Result where + bimap fe _ (Failure e) = Failure $ fe e + bimap _ fx (Success x) = Success $ fx x + +instance Applicative (Result e) where + pure = Success + Failure err <*> _ = Failure err + Success _ <*> Failure err = Failure err + Success f <*> Success x = Success $ f x + +instance Monad (Result e) where + return = pure + Failure err >>= _ = Failure err + Success x >>= f = f x + +instance (Monoid e) => Alternative (Result e) where + empty = Failure mempty + Failure ex <|> Failure ey = Failure $ ex <> ey + Failure _ <|> Success x = Success x + Success x <|> _ = Success x + +instance (Monoid e) => MonadPlus (Result e) where + mzero = Failure mempty + Failure ex `mplus` Failure ey = Failure $ ex <> ey + Failure _ `mplus` Success x = Success x + Success x `mplus` _ = Success x + +instance Summary ErrorMsg where + summary = msgToStr + +instance (Summary e, Summary a) => Summary (Result e a) where + summaryRec subSummary (Failure err) = "Failure: " ++ subSummary err + summaryRec subSummary (Success x) = subSummary x + +-- | Converts a user-freindly error message from 'String' to 'ErrorMsg'. +strToMsg :: String -> ErrorMsg +strToMsg x = ErrorMsg [x] + +-- | Converts a user-freindly error message from 'ErrorMsg' to 'String'. +msgToStr :: ErrorMsg -> String +msgToStr (ErrorMsg xs) = intercalate ", and " xs + +-- | If 'Just', a success. If 'Nothing', a failure with the given error. +maybeToResult :: e -> Maybe a -> Result e a +maybeToResult err Nothing = Failure err +maybeToResult _ (Just val) = Success val + +-- | If 'Just', a success. If 'Nothing', a failure. +maybeToUResult :: Maybe a -> UResult a +maybeToUResult = maybeToResult () + +-- | Converts an 'Either', where 'Left' encodes a failure reason and +-- 'Right' encodes a result, into a 'Result'. +eitherToResult :: Either e a -> Result e a +eitherToResult (Left err) = Failure err +eitherToResult (Right val) = Success val + +-- | Is the result a failure? +isFailure :: Result e a -> Bool +isFailure (Failure _) = True +isFailure (Success _) = False + +-- | Is the result a success? +isSuccess :: Result e a -> Bool +isSuccess (Failure _) = False +isSuccess (Success _) = True + +-- | If the result is a success, transforms it's value. +mapSuccess :: (a -> b) -> Result e a -> Result e b +mapSuccess = fmap + +-- | If the result is a failure, transforms it's error. +mapError :: (e1 -> e2) -> Result e1 a -> Result e2 a +mapError f (Failure err) = Failure $ f err +mapError _ (Success x) = Success x diff --git a/src/Descript/Misc/Error/Result/Trans.hs b/src/Descript/Misc/Error/Result/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Error/Result/Trans.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Descript.Misc.Error.Result.Trans + ( ResultT (..) + , UResultT + , mkSuccessT + , mkFailureT + , mkUFailureT + , maybeToResultT + , mapErrorT + ) where + +import Descript.Misc.Error.Result.Base +import Control.Monad.Trans.Class +import Core.Control.Monad.Trans +import Control.Monad + +-- | Either produces a value and fails, and performs some side effect +-- while doing /either/. +newtype ResultT e u a = ResultT{ runResultT :: u (Result e a) } deriving (Functor) + +type UResultT u a = ResultT () u a + +instance (Applicative u) => Applicative (ResultT e u) where + pure = ResultT . pure . Success + ResultT f <*> ResultT x = ResultT $ (<*>) <$> f <*> x + +instance (Monad u) => Monad (ResultT e u) where + return = ResultT . return . Success + ResultT x >>= f = ResultT $ x >>= f' + where f' (Failure err) = pure $ Failure err + f' (Success val) = runResultT $ f val + +instance MonadTrans (ResultT e) where + lift = ResultT . fmap pure + +instance MonadHoist (ResultT e) where + mapInner f (ResultT x) = ResultT $ f x + +instance (e1 ~ e2) => MonadTransBridge (Result e1) (ResultT e2) where + hoist = ResultT . pure + bindStackOuter f = ResultT . join . fmap (runResultT . f) . runResultT + +-- | A lifted success with the given value. +mkSuccessT :: (Monad u) => a -> ResultT e u a +mkSuccessT = hoist . Success + +-- | A lifted failure with the given error. +mkFailureT :: (Monad u) => e -> ResultT e u a +mkFailureT = hoist . Failure + +-- | A lifted failure with no error details. +mkUFailureT :: (Monad u) => UResultT u a +mkUFailureT = mkFailureT () + +-- | If 'Just', a lifted success. If 'Nothing', a lifted failure with +-- the given error. +maybeToResultT :: (Monad u) => e -> Maybe a -> ResultT e u a +maybeToResultT err = hoist . maybeToResult err + +-- | If the result is a 'Failure', transforms the error. +mapErrorT :: (Functor u) => (e1 -> e2) -> ResultT e1 u a -> ResultT e2 u a +mapErrorT = mapResultT . mapError + +mapResultT :: (Functor u) + => (Result e1 a -> Result e2 b) + -> ResultT e1 u a + -> ResultT e2 u b +mapResultT f = ResultT . fmap f . runResultT diff --git a/src/Descript/Misc/Loc.hs b/src/Descript/Misc/Loc.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Loc.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Descript.Misc.Loc + ( Loc (..) + , LocDiff (..) + , Range (..) + , singletonRange + , textRange + , inText' + , inText + , beforeInText + , afterInText + , isSingletonRange + , isInRange + , subRange + , textDiff + , rangeDiff + , offsetRange + , addDiff + , addCols + , posIdx + , loc1 + -- * Reexported from 'Text.Megaparsec.Pos' + , mkPos + , unPos + ) where + +import Descript.Misc.Ann +import Descript.Misc.Summary +import Text.Megaparsec.Pos +import qualified Data.Monoid as Monoid ((<>)) +import Data.Semigroup hiding (diff) +import Core.Data.Group +import Core.Data.List +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Core.Data.Text as Text +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Prelude hiding (lines) + +data Loc + = Loc + { line :: !Pos + , column :: !Pos + } deriving (Eq, Ord, Read, Show) + +data LocDiff + = LocDiff + { lineDiff :: Int + , colDiffs :: IntMap Int -- ^ Column diffs are values, matter only on line pos keys. + } deriving (Eq, Ord, Read, Show) + +data Range + = Range + { start :: Loc + , end :: Loc + } deriving (Eq, Ord, Read, Show) + +instance Monoid LocDiff where + mempty + = LocDiff + { lineDiff = 0 + , colDiffs = IntMap.empty + } + + LocDiff xLineDiff xColDiffs `mappend` LocDiff yLineDiff yColDiffs + = LocDiff + { lineDiff = xLineDiff + yLineDiff + , colDiffs = optColDiffs $ IntMap.unionWith (+) xColDiffs yColDiffs + } + +instance Subtract LocDiff where + x \\ y = x Monoid.<> invert y + +instance Group LocDiff where + invert (LocDiff lineDiff' colDiffs') + = LocDiff + { lineDiff = negate lineDiff' + , colDiffs + = optColDiffs + $ IntMap.fromDistinctAscList + $ map affectColDiff + $ IntMap.toDescList + colDiffs' + } + where affectColDiff (targetLine, colDiff) + = (targetLine + lineDiff', negate colDiff) + +instance Semigroup Range where + Range xStart xEnd <> Range yStart yEnd + = Range + { start = min xStart yStart + , end = max xEnd yEnd + } + +instance AnnSummary Range where + annSummaryPre range = summary range ++ ": " + +instance Summary Range where + summaryRec sub (Range start' end') + | start' == end' + = sub start' + | line start' == line end' + = "line " + ++ sub (line start') + ++ ", columns " + ++ sub (column start') + ++ " to " + ++ sub (column end') + | otherwise + = summary start' ++ " to " ++ summary end' + +instance Summary Loc where + summaryRec sub loc = "line " ++ sub (line loc) ++ ", column " ++ sub (column loc) + +-- | A range which starts and ends at the given location. +singletonRange :: Loc -> Range +singletonRange loc + = Range + { start = loc + , end = loc + } + +-- | The range from the start to the end of the text. +textRange :: Text -> Range +textRange text + = Range + { start = loc1 + , end = textEndLoc text + } + +-- | The location at the end of the text +textEndLoc :: Text -> Loc +textEndLoc text + = Loc + { line = mkPos $ 1 + length lines + , column = mkPos $ 1 + Text.length lastLine + } + where lastLine = last lines + lines = Text.lines' text + +-- | Gets the text at the given range. Assumes the range is in the text. +-- If no range is given, returns an empty text. +inText' :: Maybe Range -> Text -> Text +Nothing `inText'` _ = Text.empty +Just range' `inText'` text = range' `inText` text + +-- | Gets the text at the given range. Assumes the range is in the text. +inText :: Range -> Text -> Text +inText range' + = Text.unlines' + . overHead (Text.drop $ posIdx $ column $ start range') + . overLast (Text.take $ posIdx $ column $ end range') + . drop (posIdx $ line $ start range') + . take (succ $ posIdx $ line $ end range') + . Text.lines' + +-- | Gets the text before the given location. Assumes the location is in the text. +beforeInText :: Loc -> Text -> Text +beforeInText end' + = Text.unlines' + . overLast (Text.take $ posIdx $ column $ end') + . take (succ $ posIdx $ line $ end') + . Text.lines' + +-- | Gets the text after the given location. Assumes the location is in the text. +afterInText :: Loc -> Text -> Text +afterInText start' + = Text.unlines' + . overHead (Text.drop $ posIdx $ column $ start') + . drop (posIdx $ line $ start') + . Text.lines' + +-- | Does the range cover no text (ends at the same position it starts)? +isSingletonRange :: Range -> Bool +isSingletonRange range = start range == end range + +-- | Is the location in the range? Counts locations at the start or end +-- of the range. +isInRange :: Loc -> Range -> Bool +isInRange loc (Range start' end') = start' <= loc && end' >= loc + +-- | Removes locations in the second range from the first. +subRange :: Range -> Range -> [Range] +Range xStart xEnd `subRange` Range yStart yEnd + | xEnd <= yStart || yStart >= yEnd + = [Range xStart xEnd] + | xStart < yStart && xEnd > yEnd + = [Range xStart yStart, Range yEnd xEnd] + | xStart < yStart && xEnd <= yEnd + = [Range xStart yStart] + | xStart >= yStart && xEnd > yEnd + = [Range yEnd xEnd] + | xStart >= yStart && xEnd <= yEnd + = [] + | otherwise + = error "unexpected \"impossible\" location comparison" + +-- | The amount of lines (down cursor movements) and columns +-- (right cursor movements) which cover the text starting at the line. +textDiff :: Pos -> Text -> LocDiff +textDiff line' text + = LocDiff + { lineDiff = length lines - 1 + , colDiffs = optColDiffs colDiffs' + } + where colDiffs' = IntMap.singleton (unPos line') $ Text.length lastLine + lastLine = last lines + lines = Text.lines' text + +-- | The amount of lines (down cursor movements) and columns +-- (right cursor movements) which cover the range. +rangeDiff :: Range -> LocDiff +rangeDiff (Range start' end') + = LocDiff + { lineDiff = unPos (line end') - unPos (line start') + , colDiffs = optColDiffs $ IntMap.singleton (unPos $ line start') $ unPos (column end') - unPos (column start') + } + +-- | Adds the given difference to the start and end of the range. +offsetRange :: LocDiff -> Range -> Range +offsetRange diff (Range start' end') + = Range + { start = start' `addDiff` diff + , end = end' `addDiff` diff + } + +-- | Adds the given difference to the location. +addDiff :: Loc -> LocDiff -> Loc +Loc line' column' `addDiff` LocDiff lineDiff' colDiffs' + = Loc + { line = mkPos $ unPos line' + lineDiff' + , column = mkPos $ unPos column' + colDiff + } + where colDiff = IntMap.findWithDefault 0 (unPos line') colDiffs' + +-- | Adds columns to the location. +addCols :: Loc -> Int -> Loc +Loc line' column' `addCols` len + = Loc + { line = line' + , column = mkPos $ unPos column' + len + } + +-- | Converts 1-based 'Pos' to 0-based index. +posIdx :: Pos -> Int +posIdx = pred . unPos + +-- | Removes 0-column differences. +optColDiffs :: IntMap Int -> IntMap Int +optColDiffs = IntMap.filter (/= 0) + +-- | Line 1, column 1 +loc1 :: Loc +loc1 = Loc{ line = pos1, column = pos1 } diff --git a/src/Descript/Misc/Summary.hs b/src/Descript/Misc/Summary.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Misc/Summary.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE Rank2Types #-} + +module Descript.Misc.Summary + ( Summary (..) + ) where + +import Data.Ratio +import Data.List +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Text (Text) +import Text.Megaparsec.Pos + +-- | Can generate a debug description. Summaries explicitly /don't/ need +-- to provide all information about an object - this makes them +-- different than 'Show'. +class (Show a) => Summary a where + {-# MINIMAL summary | summaryRec #-} + + -- | A debug description. Summaries explicitly /don't/ need to provide + -- all information about an object - this makes them different than 'Show'. + -- If the implementation calls the summary of sub-expressions, use + -- 'summaryRec' instead. + summary :: a -> String + summary = summaryRec summary + + -- | A debug description. Summaries explicitly /don't/ need to provide + -- all information about an object - this makes them different than 'Show'. + -- Can modify the summaries of sub-expressions using the given function. + summaryRec :: (forall b. (Summary b) => b -> String) -> a -> String + summaryRec _ = summary + + -- | A summary of a list of these items, given a function which gets a + -- summary of each item. Overridden by 'Char', like 'showsList', for strings. + summaryList :: (a -> String) -> [a] -> String + summaryList subSummary xs = "[" ++ intercalate ", " childSummaries ++ "]" + where childSummaries = map subSummary xs + +instance Summary Char where + summary = show + summaryList _ = show + +instance Summary Int where + summary = show + +instance Summary Integer where + summary = show + +instance Summary Float where + summary = show + +instance Summary Double where + summary = show + +instance Summary Pos where + summary = summary . unPos + +instance Summary Text where + summary = show + +instance (Summary a) => Summary (Ratio a) where + summaryRec subSummary x + | denomSummary == "1" = numSummary + | otherwise = numSummary ++ "/" ++ denomSummary + where numSummary = subSummary $ numerator x + denomSummary = subSummary $ denominator x + +instance (Summary a) => Summary (Maybe a) where + summaryRec _ Nothing = "(nothing)" + summaryRec sub (Just x) = sub x + +instance (Summary a) => Summary [a] where + summaryRec = summaryList + +instance (Summary a) => Summary (NonEmpty a) where + summaryRec subSummary = summaryRec subSummary . NonEmpty.toList + +instance (Summary a, Summary b) => Summary (a, b) where + summaryRec subSummary (x, y) = "(" ++ subSummary x ++ ", " ++ subSummary y ++ ")" diff --git a/src/Descript/Sugar.hs b/src/Descript/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar.hs @@ -0,0 +1,4 @@ +-- | Encodes syntax sugar. Currently: +-- - Implicit record properties (resolved by index) +-- - Implicit path key heads (resolved by input) +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/src/Descript/Sugar/Data.hs b/src/Descript/Sugar/Data.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data.hs @@ -0,0 +1,17 @@ +module Descript.Sugar.Data + ( module Descript.Sugar.Data.Source + , module Descript.Sugar.Data.Reducer + , module Descript.Sugar.Data.Value + , module Descript.Sugar.Data.Type + , module Descript.Sugar.Data.Import + , module Descript.Sugar.Data.InjFunc + , module Descript.Sugar.Data.Atom + ) where + +import Descript.Sugar.Data.Source +import Descript.Sugar.Data.Reducer +import Descript.Sugar.Data.Value hiding (head, properties) +import Descript.Sugar.Data.Type hiding (head, properties) +import Descript.Sugar.Data.Import +import Descript.Sugar.Data.InjFunc +import Descript.Sugar.Data.Atom diff --git a/src/Descript/Sugar/Data/Atom.hs b/src/Descript/Sugar/Data/Atom.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Atom.hs @@ -0,0 +1,9 @@ +module Descript.Sugar.Data.Atom + ( module Descript.Sugar.Data.Atom.Inject + , module Descript.Sugar.Data.Atom.Scope + , module Descript.Free.Data.Atom + ) where + +import Descript.Sugar.Data.Atom.Inject +import Descript.Sugar.Data.Atom.Scope +import Descript.Free.Data.Atom diff --git a/src/Descript/Sugar/Data/Atom/Inject.hs b/src/Descript/Sugar/Data/Atom/Inject.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Atom/Inject.hs @@ -0,0 +1,5 @@ +module Descript.Sugar.Data.Atom.Inject + ( module Descript.BasicInj.Data.Atom.Inject + ) where + +import Descript.BasicInj.Data.Atom.Inject diff --git a/src/Descript/Sugar/Data/Atom/Scope.hs b/src/Descript/Sugar/Data/Atom/Scope.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Atom/Scope.hs @@ -0,0 +1,5 @@ +module Descript.Sugar.Data.Atom.Scope + ( module Descript.BasicInj.Data.Atom.Scope + ) where + +import Descript.BasicInj.Data.Atom.Scope diff --git a/src/Descript/Sugar/Data/Import.hs b/src/Descript/Sugar/Data/Import.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Import.hs @@ -0,0 +1,22 @@ +module Descript.Sugar.Data.Import + ( module Descript.BasicInj.Data.Import + , mkImportCtx + ) where + +import Descript.BasicInj.Data.Import +import Descript.Misc + +-- | If a module declaration isn't given, uses the default (file's) +-- module scope. +mkImportCtx :: (TaintAnn an) + => SFile + -> an + -> Maybe (ModuleDecl an) + -> [AbsScope -> ImportDecl an] + -> ImportCtx an +-- TODO Find better solution - @AbsScope -> ImportDecl an@ is ugly. +mkImportCtx file' ann Nothing sfreeIDecls = ImportCtx ann mdecl idecls + where idecls = map ($ moduleDeclScope mdecl) sfreeIDecls + mdecl = preInsertAnn ann <$ defModuleDecl file' +mkImportCtx _ ann (Just mdecl) sfreeIDecls = ImportCtx ann mdecl idecls + where idecls = map ($ moduleDeclScope mdecl) sfreeIDecls diff --git a/src/Descript/Sugar/Data/InjFunc.hs b/src/Descript/Sugar/Data/InjFunc.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/InjFunc.hs @@ -0,0 +1,70 @@ +module Descript.Sugar.Data.InjFunc + ( InjFunc + , lookupFunc + , forceLookupFunc + ) where + +import Descript.Sugar.Data.Atom +import Data.Monoid +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Prelude hiding (subtract, compare) +import qualified Prelude (compare) + +-- | A function which operates on primtives, which can be accessed in +-- Descript. Returns 'Nothing' when given the wrong type of primitives. +type InjFunc = [Prim ()] -> Maybe (Prim ()) + +-- | All injected functions, with their corresponding identifiers. +-- (Identifiers not in 'InjSymbol' for convenience). +allFuncs :: Map String InjFunc +allFuncs = Map.fromList + [ ("Add", add) + , ("Subtract", subtract) + , ("Multiply", multiply) + , ("Compare", compare) + , ("Append", append) + , ("App3", app3) + ] + +-- | Gets the injected function corresponding to the given identifer. +-- Returns `Nothing` if the function doesn't exist. +lookupFunc :: InjSymbol an -> Maybe InjFunc +lookupFunc (InjSymbol _ funcId) = allFuncs Map.!? funcId + +-- | Gets the injected function corresponding to the given identifer. +-- Fails if the function doesn't exist. +forceLookupFunc :: InjSymbol an -> InjFunc +forceLookupFunc (InjSymbol _ funcId) = allFuncs Map.! funcId + +add :: InjFunc +add [PrimNumber () x, PrimNumber () y] = Just $ PrimNumber () $ x + y +add _ = Nothing + +subtract :: InjFunc +subtract [PrimNumber () x, PrimNumber () y] = Just $ PrimNumber () $ x - y +subtract _ = Nothing + +multiply :: InjFunc +multiply [PrimNumber () x, PrimNumber () y] = Just $ PrimNumber () $ x * y +multiply _ = Nothing + +compare :: InjFunc +compare [PrimNumber () x, PrimNumber () y] = Just $ PrimNumber () $ x `compareNum` y +compare _ = Nothing + +append :: InjFunc +append [PrimText () x, PrimText () y] = Just $ PrimText () $ x <> y +append _ = Nothing + +app3 :: InjFunc +app3 [PrimText () x, PrimText () y, PrimText () z] + = Just $ PrimText () $ x <> y <> z +app3 _ = Nothing + +compareNum :: Rational -> Rational -> Rational +x `compareNum` y + = case x `Prelude.compare` y of + LT -> -1 + GT -> 1 + EQ -> 0 diff --git a/src/Descript/Sugar/Data/Reducer.hs b/src/Descript/Sugar/Data/Reducer.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Reducer.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Sugar.Data.Reducer + ( Reducer (..) + , PhaseCtx (..) + , ReduceCtx (..) + ) where + +import qualified Descript.Sugar.Data.Value.In as In +import qualified Descript.Sugar.Data.Value.Out as Out +import Descript.Misc +import Data.Monoid +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Core.Data.List.NonEmpty as NonEmpty + +-- | A reducer. It takes a value and converts it into a new value. +-- Programs are interpreted/compiled by taking values and reducing them - +-- the program starts with a value representing a question or source +-- code, and reducers convert this value into the answer or compiled code. +-- This is like a function, or even better, an implicit conversion. +data Reducer an + = Reducer + { reducerAnn :: an + , input :: In.Value an + , output :: Out.Value an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Completely reduces a value in a particular phase. +data PhaseCtx an + = PhaseCtx an [Reducer an] + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Completely reduces a value. In the process, also reduces its own +-- reducers when there are reducers in higher phases. +-- Typically contains all of the reducers in a source file. +data ReduceCtx an + = ReduceCtx an (NonEmpty (PhaseCtx an)) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance (Monoid an) => Monoid (ReduceCtx an) where + mempty = ReduceCtx mempty $ mempty :| [] + ReduceCtx xAnn xPhases `mappend` ReduceCtx yAnn yPhases + = ReduceCtx (xAnn <> yAnn) (xPhases `NonEmpty.zipPadLeftM` yPhases) + +instance (Monoid an) => Monoid (PhaseCtx an) where + mempty = PhaseCtx mempty [] + PhaseCtx xAnn xrs `mappend` PhaseCtx yAnn yrs + = PhaseCtx (xAnn <> yAnn) (xrs ++ yrs) + +instance Ann ReduceCtx where + getAnn (ReduceCtx ann _) = ann + +instance Ann PhaseCtx where + getAnn (PhaseCtx ann _) = ann + +instance Ann Reducer where + getAnn = reducerAnn + +instance Printable ReduceCtx where + aprintRec sub (ReduceCtx _ phases) + = pintercal "\n---\n" $ map sub $ NonEmpty.toList phases + +instance Printable PhaseCtx where + aprintRec sub (PhaseCtx _ reducers) = pintercal "\n" $ map sub reducers + +instance Printable Reducer where + aprintRec sub reducer = sub (input reducer) <> ": " <> sub (output reducer) + +instance (Show an) => Summary (ReduceCtx an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (PhaseCtx an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Reducer an) where + summaryRec = pprintSummaryRec diff --git a/src/Descript/Sugar/Data/Source.hs b/src/Descript/Sugar/Data/Source.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Source.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Sugar.Data.Source + ( Query (..) + , AModule (..) + , BModule (..) + , Program (..) + , Source (..) + , mkSource + , sourceToProgram + , sourceBModule + , sourceImportCtx + ) where + +import Descript.Sugar.Data.Reducer +import qualified Descript.Sugar.Data.Value.Reg as Reg +import Descript.Sugar.Data.Type +import Descript.Sugar.Data.Import +import Descript.Misc +import Data.Monoid +import Data.List +import Prelude hiding (mod) + +-- | The "main" value in a program. A program is interpreted by reducing +-- its query - this reduced is the output of a program. +data Query an + = Query + { queryAnn :: an + , queryVal :: Reg.Value an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Anonymous module - no scope. Defines how a program is interpreted. +-- When a module imports another, the other's 'AModule' is appended. +data AModule an + = AModule + { amoduleAnn :: an + , recordCtx :: RecordCtx an + , reduceCtx :: ReduceCtx an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A module with a scope and imports, which allows it to import other +-- modules. +data BModule an + = BModule + { bmoduleAnn :: an + , importCtx :: ImportCtx an + , amodule :: AModule an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Parsed from a source file and interpreted. To interpret, the query +-- is reduced using the module. +data Program an + = Program + { programAnn :: an + , module' :: BModule an + , query :: Query an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Every source file gets parsed into one of these. +data Source an + = SourceModule (BModule an) + | SourceProgram (Program an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance (Monoid an) => Monoid (AModule an) where + mempty + = AModule + { amoduleAnn = mempty + , recordCtx = mempty + , reduceCtx = mempty + } + + x `mappend` y + = AModule + { amoduleAnn = amoduleAnn x <> amoduleAnn y + , recordCtx = recordCtx x <> recordCtx y + , reduceCtx = reduceCtx x <> reduceCtx y + } + +instance Ann Source where + getAnn (SourceModule mod) = getAnn mod + getAnn (SourceProgram prog) = getAnn prog + +instance Ann Program where + getAnn = programAnn + +instance Ann BModule where + getAnn = bmoduleAnn + +instance Ann AModule where + getAnn = amoduleAnn + +instance Ann Query where + getAnn = queryAnn + +instance Printable Source where + aprintRec sub (SourceModule mod) = sub mod + aprintRec sub (SourceProgram prog) = sub prog + +instance Printable Program where + aprintRec sub prog = pintercal "\n\n" $ filter (/= mempty) + [ sub $ module' prog + , sub $ query prog + ] + +instance Printable BModule where + aprintRec sub mod = pintercal "\n\n" $ filter (/= mempty) + [ sub $ importCtx mod + , sub $ amodule mod + ] + +instance Printable AModule where + aprintRec sub mod = pintercal "\n\n" $ filter (/= mempty) + [ sub $ recordCtx mod + , sub $ reduceCtx mod + ] + +instance Printable Query where + aprintRec sub (Query _ val) = sub val <> "?" + +instance (Show an) => Summary (Source an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Program an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (BModule an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (AModule an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (Query an) where + summaryRec = pprintSummaryRec + +-- | Creates a source program if the query exists, or a source module if it doesn't. +mkSource :: an -> BModule an -> Maybe (Query an) -> Source an +mkSource _ mod Nothing = SourceModule mod +mkSource ann mod (Just qry) = SourceProgram $ Program ann mod qry + +-- | If the source is a program, returns it. +-- If it's a module, returns 'Nothing'. +sourceToProgram :: Source an -> Maybe (Program an) +sourceToProgram (SourceModule _) = Nothing +sourceToProgram (SourceProgram prog) = Just prog + +-- | The source's bound module. +sourceBModule :: Source an -> BModule an +sourceBModule (SourceModule mod) = mod +sourceBModule (SourceProgram prog) = module' prog + +-- | Contains the source's module declaration and imports. +sourceImportCtx :: Source an -> ImportCtx an +sourceImportCtx = importCtx . sourceBModule diff --git a/src/Descript/Sugar/Data/Type.hs b/src/Descript/Sugar/Data/Type.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Type.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Sugar.Data.Type + ( Symbol (..) + , RecordType (..) + , RecordDecl (..) + , RecordCtx (..) + , recordCtxTypes + , lookupRecordType + , recTypeHasHead + ) where + +import Descript.Sugar.Data.Atom +import Descript.Misc +import Data.Monoid +import Data.List hiding (head) +import Prelude hiding (head) + +-- | A record type. +data RecordType an + = RecordType + { recordTypeAnn :: an + , head :: Symbol an -- ^ Identifies and distinguishes the type. + , properties :: [Symbol an] -- ^ All instances should have properties with these keys. + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A record declaration. +data RecordDecl an + = RecordDecl + { recordDeclAnn :: an + , recordDeclType :: RecordType an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | Contains a source file's data definitions. +-- These record types encode the types of records which can be used +-- throughout the rest of the source. +-- Each of them should have a different head. +data RecordCtx an + = RecordCtx + { recordCtxAnn :: an + , recordCtxDecls :: [RecordDecl an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance (Monoid an) => Monoid (RecordCtx an) where + mempty = RecordCtx mempty [] + RecordCtx xAnn xds `mappend` RecordCtx yAnn yds + = RecordCtx (xAnn <> yAnn) (xds ++ yds) + +instance Ann RecordCtx where + getAnn = recordCtxAnn + +instance Ann RecordDecl where + getAnn = recordDeclAnn + +instance Ann RecordType where + getAnn = recordTypeAnn + +instance Printable RecordCtx where + aprintRec sub (RecordCtx _ recordDecls) = pintercal "\n" $ map sub recordDecls + +instance Printable RecordDecl where + aprintRec sub (RecordDecl _ recordType) = sub recordType <> "." + +instance Printable RecordType where + aprintRec sub recordType = sub (head recordType) <> propsPrinted + where propsPrinted = "[" <> pintercal ", " propPrinteds <> "]" + propPrinteds = map sub $ properties recordType + +instance (Show an) => Summary (RecordCtx an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (RecordDecl an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (RecordType an) where + summaryRec = pprintSummaryRec + +-- | The record types declared in the context. +recordCtxTypes :: RecordCtx an -> [RecordType an] +recordCtxTypes = map recordDeclType . recordCtxDecls + +-- | Finds the record type with the given head in the context. +lookupRecordType :: Symbol an -> RecordCtx an -> Maybe (RecordType an) +lookupRecordType head' = find (recTypeHasHead head') . recordCtxTypes + +-- | Does the record type have the given head? +recTypeHasHead :: Symbol an1 -> RecordType an2 -> Bool +recTypeHasHead head' record = head' =@= head record diff --git a/src/Descript/Sugar/Data/Value.hs b/src/Descript/Sugar/Data/Value.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Value.hs @@ -0,0 +1,5 @@ +module Descript.Sugar.Data.Value + ( module Descript.Sugar.Data.Value.Gen + ) where + +import Descript.Sugar.Data.Value.Gen diff --git a/src/Descript/Sugar/Data/Value/Gen.hs b/src/Descript/Sugar/Data/Value/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Value/Gen.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Sugar.Data.Value.Gen + ( GenProperty (..) + , GenRecord (..) + , GenValue (..) + , PartProperty + , PartRecord + , GenPropVal (..) + , GenPart (..) + , singletonValue + , isEmpty + , primParts + , mapParts + , foldMapParts + , traverseParts + , recWithHead + , forceRecWithHead + , deleteRecWithHead + , partHasHead + , recHasHead + , mapPropVals + , foldMapPropVals + , traversePropVals + ) where + +import Prelude hiding (head) +import Descript.Sugar.Data.Atom +import Descript.Misc +import Data.Monoid +import Data.Proxy +import Data.Maybe +import Data.List hiding (head) + +-- | A property whose values are of type @v@. +data GenProperty v an + = Property + { propertyAnn :: an + , propertyKey :: Maybe (Symbol an) + , propertyValue :: v an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A record whose property values are of type @v@ - a record in a +-- value of type @v@. +-- +-- Records are the main data of Descript. A record with no properties +-- encodes a singleton value or leaf. A record with properties encodes a +-- structure, or a tree where the properties are branches. Records are +-- similar to products, but their fields are named and they can be +-- differentiated by thier heads. +data GenRecord v an + = Record + { recordAnn :: an + , head :: Symbol an + , properties :: [GenProperty v an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A value whose parts are of type 'p'. +data GenValue p an + = Value + { valueAnn :: an + , valueParts :: [p an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A property for a particular part. +type PartProperty p an = GenProperty (PartPropVal p) an + +-- | A record for a particular part. +type PartRecord p an = GenRecord (PartPropVal p) an + +class GenPropVal v where + -- | Whether this prints in a property definition. + -- If true, it would print @key: ...@. If false, it would print @key@. + doesPrint :: v an -> Bool + +-- | A part of a value. +class (Ann p, GenPropVal (PartPropVal p), Eq (p ())) => GenPart p where + type PartPropVal p :: * -> * + + partToPrim :: p an -> Maybe (Prim an) + partToRec :: p an -> Maybe (PartRecord p an) + primToPart :: Proxy p -> Prim an -> p an + recToPart :: Proxy p -> PartRecord p an -> p an + +instance (GenPart p) => GenPropVal (GenValue p) where + doesPrint _ = True + +instance (Functor p, Foldable p, Traversable p) => SAnn (GenValue p) where + mapSAnn f (Value ann parts) = Value (f ann) parts + +instance (Functor p, Foldable p, Traversable p) => Ann (GenValue p) where + getAnn = valueAnn + +instance (Functor v, Foldable v, Traversable v) => Ann (GenRecord v) where + getAnn = recordAnn + +instance (Functor v, Foldable v, Traversable v) => Ann (GenProperty v) where + getAnn = propertyAnn + +instance (Printable p) => Printable (GenValue p) where + aprintRec sub (Value _ parts) = pintercal " | " $ map sub parts + +instance (Printable p) => FwdPrintable (GenValue p) where + afprintRec = id + +instance (FwdPrintable v, GenPropVal v) => Printable (GenRecord v) where + aprintRec sub record = sub (head record) <> propsPrinted + where propsPrinted = "[" <> pintercal ", " propPrinteds <> "]" + propPrinteds = map sub $ properties record + +instance (FwdPrintable v, GenPropVal v) => Printable (GenProperty v) where + aprintRec sub (Property _ key val) + = case key of + Nothing -> valPrinted + Just key' + | doesPrint val -> keyPrinted <> ": " <> valPrinted + | otherwise -> keyPrinted + where keyPrinted = sub key' + where valPrinted = afprintRec sub val + +instance (Show an, Printable p, Show (p an)) => Summary (GenValue p an) where + summaryRec = pprintSummaryRec + +instance (Show an, FwdPrintable v, GenPropVal v, Show (v an)) => Summary (GenRecord v an) where + summaryRec = pprintSummaryRec + +instance (Show an, FwdPrintable v, GenPropVal v, Show (v an)) => Summary (GenProperty v an) where + summaryRec = pprintSummaryRec + +-- | Creates a value with just the given part. +singletonValue :: (Ann p) => p an -> GenValue p an +singletonValue part = Value (getAnn part) [part] + +-- | Whether the value has any parts. +isEmpty :: GenValue p an -> Bool +isEmpty (Value _ parts) = null parts + +-- | All primitives in the value. +primParts :: (GenPart p) => GenValue p an -> [Prim an] +primParts = mapMaybe partToPrim . valueParts + +-- | Maps the parts. +mapParts :: (p1 an -> p2 an) -> GenValue p1 an -> GenValue p2 an +mapParts f (Value ann parts) = Value ann $ map f parts + +-- | Maps then folds the parts. +foldMapParts :: (Monoid r) => (p an -> r) -> GenValue p an -> r +foldMapParts f (Value _ parts) = foldMap f parts + +-- | Traverses the parts. +traverseParts :: (Applicative w) + => (p1 an -> w (p2 an)) + -> GenValue p1 an + -> w (GenValue p2 an) +traverseParts f (Value ann parts) = Value ann <$> traverse f parts + +-- | Gets the record in the value with the given head. +recWithHead :: (GenPart p) + => Symbol an1 + -> GenValue p an2 + -> Maybe (PartRecord p an2) +recWithHead head' (Value _ parts) + = find (recHasHead head') $ mapMaybe partToRec parts + +-- | Gets the record in the value with the given head. +-- Returns an error if the value isn't present +forceRecWithHead :: (GenPart p) + => Symbol an1 + -> GenValue p an2 + -> PartRecord p an2 +forceRecWithHead head' value + = case recWithHead head' value of + Nothing -> error "Value doesn't contain record with head" + Just record -> record + +-- | Removes the record in the value with the given head. +-- If this record doesn't exist, does nothing. +deleteRecWithHead :: (GenPart p) + => Symbol an + -> GenValue p an + -> GenValue p an +deleteRecWithHead head' (Value ann parts) + = Value ann $ filter (partHasHead head') parts + +-- | Whether the part's a record with the given head. +partHasHead :: (GenPart p) => Symbol an -> p an -> Bool +partHasHead head' part + = case partToRec part of + Just record -> recHasHead head' record + Nothing -> False + +-- | Does the record have the given head? +recHasHead :: Symbol an1 -> GenRecord v an2 -> Bool +recHasHead head' record = remAnns head' == remAnns (head record) + +-- | Maps the record's property values. +mapPropVals :: (v an -> v2 an) -> GenRecord v an -> GenRecord v2 an +mapPropVals f record + = Record + { recordAnn = recordAnn record + , head = head record + , properties = map (mapPropVal f) $ properties record + } + +-- | Maps then folds the record's property values. +foldMapPropVals :: (Monoid r) => (v an -> r) -> GenRecord v an -> r +foldMapPropVals f = foldMap (f . propertyValue) . properties + +-- | Traverses the record's property values. +traversePropVals :: (Applicative w) => (v an -> w (v2 an)) -> GenRecord v an -> w (GenRecord v2 an) +traversePropVals f record + = Record (recordAnn record) (head record) + <$> traverse (traversePropVal f) (properties record) + +mapPropVal :: (v an -> v2 an) -> GenProperty v an -> GenProperty v2 an +mapPropVal f (Property ann key val) = Property ann key $ f val + +traversePropVal :: (Applicative w) => (v an -> w (v2 an)) -> GenProperty v an -> w (GenProperty v2 an) +traversePropVal f (Property ann key val) = Property ann key <$> f val diff --git a/src/Descript/Sugar/Data/Value/In.hs b/src/Descript/Sugar/Data/Value/In.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Value/In.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Sugar.Data.Value.In + ( Property + , Record + , Part (..) + , Value + , OptValue (..) + , optValToMaybeVal + , maybeValToOptVal + , mapOptVal + , traverseOptVal + ) where + +import Descript.Sugar.Data.Value.Gen +import Descript.Sugar.Data.Atom +import Descript.Misc + +-- | An input property. +type Property an = GenProperty OptValue an + +-- | An input record. +type Record an = GenRecord OptValue an + +-- | An input part. +data Part an + = PartPrim (Prim an) + | PartPrimType (PrimType an) + | PartRecord (Record an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An input value. +type Value an = GenValue Part an + +-- | Either nothing or a value. Composition of 'Maybe' and 'Value'. +data OptValue an + = NothingValue + | JustValue (Value an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +instance GenPropVal OptValue where + doesPrint NothingValue = False + doesPrint (JustValue _) = True + +instance GenPart Part where + type PartPropVal Part = OptValue + + partToPrim (PartPrim prim) = Just prim + partToPrim _ = Nothing + + partToRec (PartRecord record) = Just record + partToRec _ = Nothing + + primToPart _ = PartPrim + recToPart _ = PartRecord + +instance Ann Part where + getAnn (PartPrim x) = getAnn x + getAnn (PartPrimType x) = getAnn x + getAnn (PartRecord x) = getAnn x + +instance FwdPrintable OptValue where + afprintRec _ NothingValue = mempty + afprintRec sub (JustValue x) = sub x + +instance Printable Part where + aprintRec sub (PartPrim prim) = sub prim + aprintRec sub (PartPrimType primType) = sub primType + aprintRec sub (PartRecord record) = aprintRec sub record + +instance (Show an) => Summary (OptValue an) where + summaryRec sub = pprintSummaryRecF sub + +instance (Show an) => Summary (Part an) where + summaryRec sub = pprintSummaryRec sub + +-- | Converts the 'OptValue' to an equivalent maybe value. +optValToMaybeVal :: OptValue an -> Maybe (Value an) +optValToMaybeVal NothingValue = Nothing +optValToMaybeVal (JustValue val) = Just val + +-- | Converts the maybe value to an equivalent 'OptValue'. +maybeValToOptVal :: Maybe (Value an) -> OptValue an +maybeValToOptVal Nothing = NothingValue +maybeValToOptVal (Just val) = JustValue val + +-- | Transform the value. +mapOptVal :: (Value an1 -> Value an2) -> OptValue an1 -> OptValue an2 +mapOptVal _ NothingValue = NothingValue +mapOptVal f (JustValue x) = JustValue $ f x + +-- | Transform the value with side effects if it exists. +traverseOptVal :: (Applicative w) + => (Value an1 -> w (Value an2)) + -> OptValue an1 + -> w (OptValue an2) +traverseOptVal _ NothingValue = pure NothingValue +traverseOptVal f (JustValue x) = JustValue <$> f x diff --git a/src/Descript/Sugar/Data/Value/Out.hs b/src/Descript/Sugar/Data/Value/Out.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Value/Out.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Sugar.Data.Value.Out + ( Property + , Record + , InjParam (..) + , InjApp (..) + , Part (..) + , Value + , immPathVal + , mapInjAppParams + , mapInjParamVal + , traverseInjParamVal + , idxPropKeys + ) where + +import Descript.Sugar.Data.Value.Gen +import Descript.Sugar.Data.Atom +import Descript.Misc +import Data.Monoid + +-- | An output property. +type Property an = GenProperty (GenValue Part) an + +-- | An output record. +type Record an = GenRecord (GenValue Part) an + +-- | A parameter of an injected function. +data InjParam an + = InjParam + { injParamAnn :: an + , injParamVal :: Value an + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An application of an injected function. +data InjApp an + = InjApp + { injAppAnn :: an + , funcId :: InjSymbol an + , params :: [InjParam an] + } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An output part. +data Part an + = PartPrim (Prim an) + | PartRecord (Record an) + | PartPropPath (PropPath an) + | PartInjApp (InjApp an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | An output value. +type Value an = GenValue Part an + +instance GenPart Part where + type PartPropVal Part = GenValue Part + + partToPrim (PartPrim prim) = Just prim + partToPrim _ = Nothing + + partToRec (PartRecord record) = Just record + partToRec _ = Nothing + + primToPart _ = PartPrim + recToPart _ = PartRecord + +instance Ann Part where + getAnn (PartPrim x) = getAnn x + getAnn (PartRecord x) = getAnn x + getAnn (PartPropPath x) = getAnn x + getAnn (PartInjApp x) = getAnn x + +instance Ann InjApp where + getAnn = injAppAnn + +instance Ann InjParam where + getAnn (InjParam ann _) = ann + +instance Printable Part where + aprintRec sub (PartPrim prim) = sub prim + aprintRec sub (PartRecord record) = sub record + aprintRec sub (PartPropPath path) = sub path + aprintRec sub (PartInjApp app) = sub app + +instance Printable InjApp where + aprintRec sub app = sub (funcId app) <> paramsPrinted + where paramsPrinted = "[" <> pintercal ", " paramPrinteds <> "]" + paramPrinteds = map sub $ params app + +instance Printable InjParam where + aprintRec sub (InjParam _ val) = sub val + +instance (Show an) => Summary (Part an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (InjApp an) where + summaryRec = pprintSummaryRec + +instance (Show an) => Summary (InjParam an) where + summaryRec = pprintSummaryRec + +-- | Refers to the immediate property corresponding to the path element. +immPathVal :: PathElem () -> Value () +immPathVal = singletonValue . PartPropPath . immPath + +mapInjAppParams :: (InjParam an -> InjParam an) -> InjApp an -> InjApp an +mapInjAppParams f (InjApp ann funcId' params') + = InjApp ann funcId' $ map f params' + +-- | Transforms the value in the injected parameter. +mapInjParamVal :: (Value an -> Value an) -> InjParam an -> InjParam an +mapInjParamVal f (InjParam ann x) = InjParam ann $ f x + +-- | Transforms the value in the injected parameter with side effects. +traverseInjParamVal :: (Functor w) + => (Value an -> w (Value an)) + -> InjParam an + -> w (InjParam an) +traverseInjParamVal f (InjParam ann x) = InjParam ann <$> f x + +-- | Each of these keys in an injected function application corresponds +-- to a parameter at its position. +idxPropKeys :: [Symbol ()] +idxPropKeys = map (Symbol () . pure) ['a'..'z'] diff --git a/src/Descript/Sugar/Data/Value/Reg.hs b/src/Descript/Sugar/Data/Value/Reg.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Data/Value/Reg.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Sugar.Data.Value.Reg + ( Property + , Record + , Part (..) + , Value + ) where + +import Descript.Sugar.Data.Value.Gen +import Descript.Sugar.Data.Atom +import Descript.Misc +import Prelude hiding (head) + +-- | A regular property. +type Property an = GenProperty (GenValue Part) an + +-- | A regular record. +type Record an = GenRecord (GenValue Part) an + +-- | A regular part. +data Part an + = PartPrim (Prim an) + | PartRecord (Record an) + deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable) + +-- | A regular value. +type Value an = GenValue Part an + +instance GenPart Part where + type PartPropVal Part = GenValue Part + + partToPrim (PartPrim prim) = Just prim + partToPrim _ = Nothing + + partToRec (PartRecord record) = Just record + partToRec _ = Nothing + + primToPart _ = PartPrim + recToPart _ = PartRecord + +instance Ann Part where + getAnn (PartPrim x) = getAnn x + getAnn (PartRecord x) = getAnn x + +instance Printable Part where + aprintRec sub (PartPrim prim) = sub prim + aprintRec sub (PartRecord record) = sub record + +instance (Show an) => Summary (Part an) where + summaryRec = pprintSummaryRec diff --git a/src/Descript/Sugar/Parse.hs b/src/Descript/Sugar/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Parse.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Descript.Sugar.Parse + ( parse + , parseInputVal + , parseOutputVal + ) where + +import Descript.Sugar.Parse.Refine +import Descript.Sugar.Data.Source hiding (query, amodule, importCtx, recordCtx, reduceCtx) +import Descript.Sugar.Data.Reducer hiding (input, output) +import qualified Descript.Sugar.Data.Value.In as In +import qualified Descript.Sugar.Data.Value.Out as Out +import Descript.Sugar.Data.Type +import Descript.Sugar.Data.Import hiding (moduleDecl) +import Descript.Free.Error +import qualified Descript.Free.Data as Free +import Descript.Misc +import Text.Megaparsec hiding (ParseError, parse) +import Core.Text.Megaparsec +import Data.Foldable +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Set as Set +import Prelude hiding (any) + +type Parser a = Parsec RangedError (RangeStream Free.TopLevel) a +type RParser a = Parser (a Range) + +-- | Parses a source file from the given file and contents. +parse :: ParseAction (RangeStream Free.TopLevel) (Source Range) +parse file = runLaterParser (source file) file + +-- | Parses an individual input value from the given file and contents. +parseInputVal :: ParseAction (Free.Value Range) (In.Value Range) +parseInputVal file = refineResToParseRes file . freeToInput + +-- | Parses an individual output value from the given file and contents. +parseOutputVal :: ParseAction (Free.Value Range) (Out.Value Range) +parseOutputVal file = refineResToParseRes file . freeToOutput + +source :: SFile -> RParser Source +source file + = ranged $ label "source" + $ mkSource <$@> bmodule file <*@> optional query + +bmodule :: SFile -> RParser BModule +bmodule file + = ranged $ label "module" + $ BModule <$@> importCtx file <*@> amodule + +amodule :: RParser AModule +amodule + = ranged + $ AModule <$@> recordCtx <*@> reduceCtx + +importCtx :: SFile -> RParser ImportCtx +importCtx file + = ranged $ label "all imports" + $ mkImportCtx file <$@> optional moduleDecl <*@> many importDecl + +recordCtx :: RParser RecordCtx +recordCtx + = ranged $ label "all record type declarations" + $ RecordCtx <$@> many recordDecl + +reduceCtx :: RParser ReduceCtx +reduceCtx + = ranged $ label "all reducers" + $ ReduceCtx <$@> phaseCtx `someSepBy` satisfy Free.topLevelIsPhaseSep + +phaseCtx :: RParser PhaseCtx +phaseCtx + = ranged $ label "all reducers in a particular phase" + $ PhaseCtx <$@> many reducer + +moduleDecl :: RParser ModuleDecl +moduleDecl + = label "module declaration" + $ mapSatisfy Free.topLevelToModuleDecl + +importDecl :: Parser (AbsScope -> ImportDecl Range) +importDecl + = label "import declaration" + $ flip freeToImportDeclIn <$> mapSatisfy Free.topLevelToImportDecl + +recordDecl :: RParser RecordDecl +recordDecl + = absorbError $ label "record type eclaration" + $ freeToRecordDecl <$> mapSatisfy Free.topLevelToRecordDecl + +reducer :: RParser Reducer +reducer + = absorbError $ label "reducer" + $ freeToReducer <$> mapSatisfy Free.topLevelToReducer + +query :: RParser Query +query + = absorbError $ label "query" + $ freeToQuery <$> mapSatisfy Free.topLevelToQuery + +absorbError :: Parser (RefineResult (a Range)) -> RParser a +absorbError x = x >>= refineResToParser + +refineResToParser :: RefineResult (a Range) -> RParser a +refineResToParser (Failure err) = refineDiffToParser err +refineResToParser (Success x) = pure x + +refineResToParseRes :: SFile -> RefineResult a -> ParseResult a +refineResToParseRes = mapError . refineDiffToParseErr + +refineDiffToParser :: RefineDiff -> Parser a +refineDiffToParser (RefineDiff diffs) = do + filename <- sourceName <$> getPosition + setPosition $ locToPos filename $ indivDiffsErrLoc diffs + fancyFailure $ Set.fromList $ map indivDiffToFancyErr diffs + +refineDiffToParseErr :: (Ord t) => SFile -> RefineDiff -> (ParseError t) +refineDiffToParseErr file (RefineDiff diffs) + = FancyError posStack $ Set.fromList $ map indivDiffToFancyErr diffs + where posStack = locToPos (sfileName file) (indivDiffsErrLoc diffs) :| [] + +indivDiffToFancyErr :: IndivRefineDiff -> ErrorFancy RangedError +indivDiffToFancyErr = ErrorCustom . indivDiffToRangedErr + +indivDiffToRangedErr :: IndivRefineDiff -> RangedError +indivDiffToRangedErr (IndivRefineDiff range' local) + = RangedError + { errorRange = range' + , rangedErrorExpected = expected local + -- Don't want full summary - print handled by range + , rangedErrorActual = actual local + } + +indivDiffsErrLoc :: [IndivRefineDiff] -> Loc +indivDiffsErrLoc = minimum . map (start . range) diff --git a/src/Descript/Sugar/Parse/Refine.hs b/src/Descript/Sugar/Parse/Refine.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Parse/Refine.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE TupleSections #-} + +module Descript.Sugar.Parse.Refine + ( freeToImportDeclIn + , freeToRecordDecl + , freeToReducer + , freeToQuery + , freeToRegValue + , freeToInput + , freeToOutput + , freeToRecordType + ) where + +import Descript.Sugar.Data.Source +import Descript.Sugar.Data.Import +import Descript.Sugar.Data.Reducer +import qualified Descript.Sugar.Data.Value.In as In +import qualified Descript.Sugar.Data.Value.Out as Out +import qualified Descript.Sugar.Data.Value.Reg as Reg +import Descript.Sugar.Data.Value.Gen +import Descript.Sugar.Data.Type +import Descript.Sugar.Data.Atom +import qualified Descript.Free.Data as Free +import Descript.Free.Error +import Descript.Misc + +freeToImportDeclIn :: (TaintAnn an) + => AbsScope + -> Free.ImportDecl an + -> ImportDecl an +freeToImportDeclIn scope (Free.ImportDecl ann path isrcs idsts) + = ImportDecl + { importDeclAnn = ann + , importDeclPath = path + , importDeclSrcImports = map (freeToImportRecordIn scope pscope) isrcs + , importDeclDstImports = map (freeToImportRecordIn scope pscope) idsts + } + where pscope = modulePathScope path + +freeToImportRecordIn :: (TaintAnn an) + => AbsScope + -> AbsScope + -> Free.ImportRecord an + -> ImportRecord an +freeToImportRecordIn scope pscope (Free.ImportRecord ann from to) + = ImportRecord ann (FSymbol pscope from) (FSymbol scope to) + +-- | Refines to a record declaration. +freeToRecordDecl :: Free.RecordDecl Range -> RefineResult (RecordDecl Range) +freeToRecordDecl (Free.RecordDecl r recordType) = RecordDecl r <$> freeToRecordType recordType + +-- | Refines to a reducer. +freeToReducer :: Free.Reducer Range -> RefineResult (Reducer Range) +freeToReducer (Free.Reducer r input' output') + = Reducer r <$> freeToInput input' <*> freeToOutput output' + +-- | Refines to a query. +freeToQuery :: Free.Query Range -> RefineResult (Query Range) +freeToQuery (Free.Query r val) = Query r <$> freeToRegValue val + +-- | Refines to a regular value. +freeToRegValue :: Free.Value Range -> RefineResult (Reg.Value Range) +freeToRegValue (Free.Value r parts) = Value r <$> freeToParts parts + +-- | Refines to regular parts. +freeToParts :: [Free.Part Range] -> RefineResult [Reg.Part Range] +freeToParts = traverse freeToPart + +-- | Refines to a regular part. +freeToPart :: Free.Part Range -> RefineResult (Reg.Part Range) +freeToPart (Free.PartPrim prim) = Success $ Reg.PartPrim prim +freeToPart (Free.PartRecord record) = Reg.PartRecord <$> freeToRecord record +freeToPart x@(Free.PartPropPath (PropPath r _)) + = Failure $ entireRefineDiff r LocalRefineDiff + { expected = "primitive or record" + , actual = "property path" + , actualPr = pprintStr x + } + +-- | Refines to a regular record. +freeToRecord :: Free.Record Range -> RefineResult (Reg.Record Range) +freeToRecord record + = Record (Free.recordAnn record) (Free.head record) + <$> freeToProperties (Free.properties record) + +-- | Refines to regular properties. +freeToProperties :: [Free.Property Range] -> RefineResult [Reg.Property Range] +freeToProperties = traverse freeToProperty + +-- | Refines to a regular property. +freeToProperty :: Free.Property Range -> RefineResult (Reg.Property Range) +freeToProperty (Free.PropertySingle val) + = Property r Nothing <$> freeToRegValue val + where r = getAnn val +freeToProperty (Free.PropertyDef r key val) + = Property r (Just key) <$> freeToRegValue val + +-- | Refines to Range input value. +freeToInput :: Free.Value Range -> RefineResult (In.Value Range) +freeToInput (Free.Value r parts) = Value r <$> freeToInParts parts + +-- | Refines to input parts. +freeToInParts :: [Free.Part Range] -> RefineResult [In.Part Range] +freeToInParts = traverse freeToInPart + +-- | Refines to Range input part. +freeToInPart :: Free.Part Range -> RefineResult (In.Part Range) +freeToInPart (Free.PartPrim prim) = Success $ In.PartPrim prim +freeToInPart (Free.PartRecord record) + | isFreePrimType record = In.PartPrimType <$> freeToPrimType record + | otherwise = In.PartRecord <$> freeToInRecord record +freeToInPart x@(Free.PartPropPath (PropPath r _)) + = Failure $ entireRefineDiff r LocalRefineDiff + { expected = "primitive, primitive type, or record" + , actual = "property path" + , actualPr = pprintStr x + } + +isFreePrimType :: Free.Record Range -> Bool +isFreePrimType = isInjSymbol . Free.head + +freeToPrimType :: Free.Record Range -> RefineResult (PrimType Range) +freeToPrimType record + | null $ Free.properties record = freeSymbolToPrimType (Free.recordAnn record) $ Free.head record + | otherwise = Failure $ entireRefineDiff (Free.recordAnn record) LocalRefineDiff + { expected = "primitive type" + , actual = "injected function application" + , actualPr = pprintStr record + } + +freeSymbolToPrimType :: Range -> Symbol Range -> RefineResult (PrimType Range) +freeSymbolToPrimType r (Symbol _ label) = freeSymbolStrToPrimType r label + +freeSymbolStrToPrimType :: Range -> String -> RefineResult (PrimType Range) +freeSymbolStrToPrimType r "#Number" = Success $ PrimTypeNumber r +freeSymbolStrToPrimType r "#String" = Success $ PrimTypeString r +freeSymbolStrToPrimType r x + = Failure $ entireRefineDiff r LocalRefineDiff + { expected = "#Number or #String" + , actual = "non-existent primitive type" + , actualPr = x + } + +-- | Refines to Range input record. +freeToInRecord :: Free.Record Range -> RefineResult (In.Record Range) +freeToInRecord record + = Record (Free.recordAnn record) (Free.head record) + <$> freeToInProperties (Free.properties record) + +-- | Refines to input properties. +freeToInProperties :: [Free.Property Range] -> RefineResult [In.Property Range] +freeToInProperties = traverse freeToInProperty + +-- | Refines to Range input property. +freeToInProperty :: Free.Property Range -> RefineResult (In.Property Range) +freeToInProperty (Free.PropertySingle x) + = case Free.valueToPropKey x of + Nothing -> Property r Nothing . In.JustValue <$> freeToInput x + Just key -> Success $ Property r (Just key) In.NothingValue + where r = getAnn x +freeToInProperty (Free.PropertyDef r key val) + = Property r (Just key) . In.JustValue <$> freeToInput val + +-- | Refines to Range output value. +freeToOutput :: Free.Value Range -> RefineResult (Out.Value Range) +freeToOutput (Free.Value r parts) = Value r <$> freeToOutParts parts + +-- | Refines to output parts. +freeToOutParts :: [Free.Part Range] -> RefineResult [Out.Part Range] +freeToOutParts = traverse freeToOutPart + +-- | Refines to Range output part. +freeToOutPart :: Free.Part Range -> RefineResult (Out.Part Range) +freeToOutPart (Free.PartPrim prim) = Success $ Out.PartPrim prim +freeToOutPart (Free.PartRecord record) + | isFreeInjApp record = Out.PartInjApp <$> freeToInjApp record + | otherwise = Out.PartRecord <$> freeToOutRecord record +freeToOutPart (Free.PartPropPath path) = Success $ Out.PartPropPath path + +isFreeInjApp :: Free.Record Range -> Bool +isFreeInjApp = isInjSymbol . Free.head + +freeToInjApp :: Free.Record Range -> RefineResult (Out.InjApp Range) +freeToInjApp record + = Out.InjApp (Free.recordAnn record) (forceToInjSymbol $ Free.head record) + <$> freeToInjParams (Free.properties record) + +freeToInjParams :: [Free.Property Range] -> RefineResult [Out.InjParam Range] +freeToInjParams = freeToInjParamsFromIdx 0 + +freeToInjParamsFromIdx :: Int -> [Free.Property Range] -> RefineResult [Out.InjParam Range] +freeToInjParamsFromIdx _ [] = Success [] +freeToInjParamsFromIdx n (x : xs) + = (:) <$> freeToInjParamAtIdx n x <*> freeToInjParamsFromIdx (n + 1) xs + +freeToInjParamAtIdx :: Int -> Free.Property Range -> RefineResult (Out.InjParam Range) +freeToInjParamAtIdx _ (Free.PropertySingle val) + = Out.InjParam r <$> freeToOutput val + where r = getAnn val +freeToInjParamAtIdx n (Free.PropertyDef r key val) + | key /@= propKey + = Failure $ entireRefineDiff r LocalRefineDiff + { expected = "\"" ++ summary propKey ++ "\"" + , actual = "\"" ++ summary key ++ "\"" + , actualPr = pprintStr key + } + | otherwise = Out.InjParam r <$> freeToOutput val + where propKey = Out.idxPropKeys !! n + +-- | Refines to Range output record. +freeToOutRecord :: Free.Record Range -> RefineResult (Out.Record Range) +freeToOutRecord record + = Record (Free.recordAnn record) (Free.head record) + <$> freeToOutProperties (Free.properties record) + +-- | Refines to output properties. +freeToOutProperties :: [Free.Property Range] -> RefineResult [Out.Property Range] +freeToOutProperties = traverse freeToOutProperty + +-- | Refines to Range output property. +freeToOutProperty :: Free.Property Range -> RefineResult (Out.Property Range) +freeToOutProperty (Free.PropertySingle val) + = Property r Nothing <$> freeToOutput val + where r = getAnn val +freeToOutProperty (Free.PropertyDef r key val) + = Property r (Just key) <$> freeToOutput val + +-- | Refines to a record type. +freeToRecordType :: Free.Value Range -> RefineResult (RecordType Range) +freeToRecordType (Free.Value _ [Free.PartRecord record]) = freeRecordToRecordType record +freeToRecordType x@(Free.Value r _) + = Failure $ entireRefineDiff r LocalRefineDiff + { expected = "record" + , actual = describeValueAsPart x + , actualPr = pprintStr x + } + +-- | Refines a record to a record type. +freeRecordToRecordType :: Free.Record Range -> RefineResult (RecordType Range) +freeRecordToRecordType record + = RecordType (Free.recordAnn record) (Free.head record) + <$> freeToRecordTypeProperties (Free.properties record) + +-- | Refines to record type "properties" (property declarations). +freeToRecordTypeProperties :: [Free.Property Range] -> RefineResult [Symbol Range] +freeToRecordTypeProperties = traverse freeToRecordTypeProperty + +-- | Refines to a record type "property" (property declaration). +freeToRecordTypeProperty :: Free.Property Range -> RefineResult (Symbol Range) +freeToRecordTypeProperty (Free.PropertySingle x) + = case Free.valueToPropKey x of + Nothing + -> Failure $ entireRefineDiff r LocalRefineDiff + { expected = "property declaration" + , actual = "value" + , actualPr = pprintStr x + } + Just key -> Success key + where r = getAnn x +freeToRecordTypeProperty x@(Free.PropertyDef r _ _) + = Failure $ entireRefineDiff r LocalRefineDiff + { expected = "property declaration" + , actual = "property definition" + , actualPr = pprintStr x + } + +describeValueAsPart :: Free.Value Range -> String +describeValueAsPart (Free.Value _ [Free.PartPrim _]) = "primitive" +describeValueAsPart (Free.Value _ [Free.PartRecord _]) = "record" +describeValueAsPart (Free.Value _ [Free.PartPropPath _]) = "path" +describeValueAsPart (Free.Value _ []) = "empty" +describeValueAsPart (Free.Value _ _) = "union" diff --git a/src/Descript/Sugar/Refine.hs b/src/Descript/Sugar/Refine.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Refine.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE ApplicativeDo #-} + +module Descript.Sugar.Refine + ( refineDDepd + , refine + , refineInputValIn + , refineOutputValIn + ) where + +import qualified Descript.Sugar.Data.Value.Reg as Reg +import qualified Descript.Sugar.Data.Value.In as In +import qualified Descript.Sugar.Data.Value.Out as Out +import Descript.Sugar.Data +import qualified Descript.BasicInj.Data.Value.Reg as BasicInj.Reg +import qualified Descript.BasicInj.Data.Value.In as BasicInj.In +import qualified Descript.BasicInj.Data.Value.Out as BasicInj.Out +import qualified Descript.BasicInj.Data.Value.Gen as BasicInj.Record +import qualified Descript.BasicInj.Data.Type as BasicInj.RecordType +import qualified Descript.BasicInj.Data as BasicInj +import Descript.Misc +import Data.Monoid +import Data.Foldable +import Data.Maybe +import Core.Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Control.Monad +import Prelude hiding (mod) + +-- | Expands syntactic sugar in the source using the dependency. +-- Passes dependency failures along. +refineDDepd :: (TaintAnn an) + => BasicInj.DirtyDepd Source an + -> BasicInj.DirtyDepd BasicInj.Source an +refineDDepd (Depd dextra x) = Depd dextra $ refine (dirtyVal dextra) x + +-- | Expands syntactic sugar in the source. +refine :: (TaintAnn an) + => BasicInj.Dep + -> Source an + -> BasicInj.Source an +refine extra (SourceModule mod) + = BasicInj.SourceModule $ refineBModule extra mod +refine extra (SourceProgram prog) + = BasicInj.SourceProgram $ refineProgram extra prog + +refineProgram :: (TaintAnn an) + => BasicInj.Dep + -> Program an + -> BasicInj.Program an +refineProgram extra (Program ann mod query') + = BasicInj.Program ann mod' $ refineQueryIn scope ctx query' + where scope = BasicInj.moduleScope mod' + ctx = recordCtx_ <> extraCtx + extraCtx = BasicInj.recordCtx extra + recordCtx_ = remAnns $ BasicInj.recordCtx $ BasicInj.amodule mod' + mod' = refineBModule extra mod + +refineQueryIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> Query an + -> BasicInj.Query an +refineQueryIn scope ctx (Query ann val) + = BasicInj.Query ann $ refineRegValueIn scope ctx val + +refineBModule :: (TaintAnn an) + => BasicInj.Dep + -> BModule an + -> BasicInj.BModule an +refineBModule extra (BModule ann ictx amod) + = BasicInj.BModule ann ictx $ refineAModuleIn scope ctx amod + where scope = moduleDeclScope $ moduleDecl ictx + ctx = BasicInj.recordCtx extra + +refineAModuleIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> AModule an + -> BasicInj.AModule an +refineAModuleIn scope extraCtx (AModule ann recordCtx' reduceCtx') + = BasicInj.AModule ann recordCtx'' reduceCtx'' + where recordCtx'' = refineRecordCtxIn scope recordCtx' + reduceCtx'' = refineReduceCtxIn scope ctx reduceCtx' + ctx = recordCtx_ <> extraCtx + recordCtx_ = remAnns recordCtx'' + +refineRecordCtxIn :: (TaintAnn an) + => AbsScope + -> RecordCtx an + -> BasicInj.RecordCtx an +refineRecordCtxIn scope (RecordCtx ann decls) + = BasicInj.RecordCtx ann $ map (refineRecordDeclIn scope) decls + +refineRecordDeclIn :: (TaintAnn an) + => AbsScope + -> RecordDecl an + -> BasicInj.RecordDecl an +refineRecordDeclIn scope (RecordDecl ann rtype) + = BasicInj.RecordDecl ann $ refineRecordTypeIn scope rtype + +refineRecordTypeIn :: (TaintAnn an) + => AbsScope + -> RecordType an + -> BasicInj.RecordType an +refineRecordTypeIn scope (RecordType ann head' props) + = BasicInj.RecordType ann (FSymbol scope head') props + +refineReduceCtxIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> ReduceCtx an + -> BasicInj.ReduceCtx an +refineReduceCtxIn scope ctx (ReduceCtx ann (p :| ps)) + = BasicInj.ReduceCtx ann topPhase + $ NonEmpty.map (refinePhaseCtxIn scope ctx) $ p :| ps + where topPhase = BasicInj.PhaseCtx (preInsertAnn $ getAnn p) [] + +refinePhaseCtxIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> PhaseCtx an + -> BasicInj.PhaseCtx an +refinePhaseCtxIn scope ctx (PhaseCtx ann reducers) + = BasicInj.PhaseCtx ann $ map (refineReducerIn scope ctx) reducers + +refineReducerIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> Reducer an + -> BasicInj.Reducer an +refineReducerIn scope ctx (Reducer ann input' output') + = BasicInj.Reducer ann input'' (refineOutputValIn scope ctx input_ output') + where input_ = remAnns input'' + input'' = refineInputValIn scope ctx input' + +refineRegValueIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> Reg.Value an + -> BasicInj.Reg.Value an +refineRegValueIn scope ctx (Value ann parts) + = BasicInj.Value ann $ map (refineRegPartIn scope ctx) parts + +refineInputValIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> In.Value an + -> BasicInj.In.Value an +refineInputValIn scope ctx (Value ann parts) + = BasicInj.Value ann $ map (refineInPartIn scope ctx) parts + +refineOutputValIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> BasicInj.In.Value () + -> Out.Value an + -> BasicInj.Out.Value an +refineOutputValIn scope ctx in' (Value ann parts) + = BasicInj.Value ann $ map (refineOutPartIn scope ctx in') parts + +refineRegPartIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> Reg.Part an + -> BasicInj.Reg.Part an +refineRegPartIn _ _ (Reg.PartPrim prim) = BasicInj.Reg.PartPrim prim +refineRegPartIn scope ctx (Reg.PartRecord record) + = BasicInj.Reg.PartRecord $ refineRegRecordIn scope ctx record + +refineInPartIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> In.Part an + -> BasicInj.In.Part an +refineInPartIn _ _ (In.PartPrim prim) = BasicInj.In.PartPrim prim +refineInPartIn _ _ (In.PartPrimType primType) = BasicInj.In.PartPrimType primType +refineInPartIn scope ctx (In.PartRecord record) + = BasicInj.In.PartRecord $ refineInRecordIn scope ctx record + +refineOutPartIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> BasicInj.In.Value () + -> Out.Part an + -> BasicInj.Out.Part an +refineOutPartIn _ _ _ (Out.PartPrim prim) = BasicInj.Out.PartPrim prim +refineOutPartIn scope ctx in' (Out.PartRecord record) + = BasicInj.Out.PartRecord $ refineOutRecordIn scope ctx in' record +refineOutPartIn scope _ in' (Out.PartPropPath path) + = BasicInj.Out.PartPropPath $ refinePropPathIn scope in' path +refineOutPartIn scope ctx in' (Out.PartInjApp app) + = BasicInj.Out.PartInjApp $ refineInjAppIn scope ctx in' app + +refineRegRecordIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> Reg.Record an + -> BasicInj.Reg.Record an +refineRegRecordIn scope ctx (Record ann head' props) + = BasicInj.Record ann head'' + $ zipWith (refineRegPropIn scope ctx head_) [0..] props + where head_ = remAnns head'' + head'' = FSymbol scope head' + +refineInRecordIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> In.Record an + -> BasicInj.In.Record an +refineInRecordIn scope ctx (Record ann head' props) + = BasicInj.Record ann head'' + $ zipWith (refineInPropIn scope ctx head_) [0..] props + where head_ = remAnns head'' + head'' = FSymbol scope head' + +refineOutRecordIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> BasicInj.In.Value () + -> Out.Record an + -> BasicInj.Out.Record an +refineOutRecordIn scope ctx in' (Record ann head' props) + = BasicInj.Record ann head'' + $ zipWith (refineOutPropIn scope ctx in' head_) [0..] props + where head_ = remAnns head'' + head'' = FSymbol scope head' + +refineRegPropIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> BasicInj.FSymbol () + -> Int + -> Reg.Property an + -> BasicInj.Reg.Property an +refineRegPropIn scope ctx head' idx (Property ann key val) + = BasicInj.Property ann key' $ refineRegValueIn scope ctx val + where key' = resolvePropKey ctx head' idx keyAnn `fromMaybe` key + keyAnn = preInsertAnn ann + +refineInPropIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> BasicInj.FSymbol () + -> Int + -> In.Property an + -> BasicInj.In.Property an +refineInPropIn scope ctx head' idx (Property ann key val) + = BasicInj.Property ann key' $ refineInOptValueIn scope ctx val + where key' = resolvePropKey ctx head' idx keyAnn `fromMaybe` key + keyAnn = preInsertAnn ann + +refineOutPropIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> BasicInj.In.Value () + -> BasicInj.FSymbol () + -> Int + -> Out.Property an + -> BasicInj.Out.Property an +refineOutPropIn scope ctx in' head' idx (Property ann key val) + = BasicInj.Property ann key' $ refineOutputValIn scope ctx in' val + where key' = resolvePropKey ctx head' idx keyAnn `fromMaybe` key + keyAnn = preInsertAnn ann + +refineInOptValueIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> In.OptValue an + -> BasicInj.In.OptValue an +refineInOptValueIn _ _ In.NothingValue = BasicInj.In.NothingValue +refineInOptValueIn scope ctx (In.JustValue val) + = BasicInj.In.JustValue $ refineInputValIn scope ctx val + +refinePropPathIn :: (TaintAnn an) + => AbsScope + -> BasicInj.In.Value () + -> PropPath an + -> BasicInj.PropPath an +refinePropPathIn scope in' (PropPath ann (x :| xs)) + = BasicInj.PropPath ann $ x' :| refineSubPathIn scope inSub xs + where inSub = inputInElem x_ in' + x_ = remAnns x' + x' = refinePathElemIn scope in' x + +refineSubPathIn :: (TaintAnn an) + => AbsScope + -> BasicInj.In.Value () + -> SubPropPath an + -> BasicInj.SubPropPath an +refineSubPathIn _ _ [] = [] +refineSubPathIn scope in' (x : xs) + = x' : refineSubPathIn scope inSub xs + where inSub = inputInElem x_ in' + x_ = remAnns x' + x' = refinePathElemIn scope in' x + +refinePathElemIn :: (TaintAnn an) + => AbsScope + -> BasicInj.In.Value () + -> PathElem an + -> BasicInj.PathElem an +refinePathElemIn _ in' (PathElemImp key) = BasicInj.PathElem ann key head' + where head' = resolvePathHead in' key + ann = getAnn key +refinePathElemIn scope _ (PathElemExp ann key head') + = BasicInj.PathElem ann key $ FSymbol scope head' + +refineInjAppIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> BasicInj.In.Value () + -> Out.InjApp an + -> BasicInj.Out.InjApp an +refineInjAppIn scope ctx in' (Out.InjApp ann funcId' params') + = BasicInj.Out.InjApp ann funcId' + $ map (refineOutParamIn scope ctx in') params' + +refineOutParamIn :: (TaintAnn an) + => AbsScope + -> BasicInj.RecordCtx () + -> BasicInj.In.Value () + -> Out.InjParam an + -> BasicInj.Out.InjParam an +refineOutParamIn scope ctx in' (Out.InjParam ann val) + = BasicInj.Out.InjParam ann $ refineOutputValIn scope ctx in' val + +inputInElem :: BasicInj.PathElem () + -> BasicInj.In.Value () + -> BasicInj.In.Value () +inputInElem (BasicInj.PathElem () key head') + = fold + . ( BasicInj.In.optValToMaybeVal + <=< BasicInj.lookupProp key + <=< BasicInj.recWithHead head' ) + +resolvePropKey :: (TaintAnn an) + => BasicInj.RecordCtx () + -> BasicInj.FSymbol () + -> Int + -> an + -> BasicInj.Symbol an +resolvePropKey ctx head' idx ann + = ann <$ (undefinedSym `fromMaybe` resolvePropKey_ ctx head' idx) + +resolvePropKey_ :: BasicInj.RecordCtx () + -> BasicInj.FSymbol () + -> Int + -> Maybe (BasicInj.Symbol ()) +resolvePropKey_ ctx head' idx + = (!? idx) . BasicInj.RecordType.properties + =<< BasicInj.lookupRecordType head' ctx + +resolvePathHead :: (TaintAnn an) + => BasicInj.In.Value () + -> Symbol an + -> FSymbol an +resolvePathHead in' key + = ann' <$ (BasicInj.undefinedFSym `fromMaybe` resolvePathHead_ in' key_) + where key_ = remAnns key + ann' = postInsertAnn $ getAnn key + +resolvePathHead_ :: BasicInj.In.Value () + -> Symbol () + -> Maybe (FSymbol ()) +resolvePathHead_ (BasicInj.Value () parts) key + = case filter (BasicInj.recHasProp key) $ mapMaybe BasicInj.partToRec parts of + [record] -> Just $ BasicInj.Record.head record + _ -> Nothing diff --git a/src/Descript/Sugar/Resolve.hs b/src/Descript/Sugar/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Descript/Sugar/Resolve.hs @@ -0,0 +1,15 @@ +module Descript.Sugar.Resolve + ( resolve + ) where + +import Descript.Sugar.Data +import qualified Descript.BasicInj as BasicInj +import Descript.Misc + +-- | Resolves dependencies using the given resolver. +resolve :: (Monad u) + => BasicInj.DepResolver u + -> Source an + -> u (BasicInj.DirtyDepd Source an) +resolve rsvr src = (`Depd` src) <$> extra + where extra = runDirtyT $ BasicInj.extraModule rsvr $ sourceImportCtx src diff --git a/test-resources/Import/Basic/List.dscr b/test-resources/Import/Basic/List.dscr new file mode 100644 --- /dev/null +++ b/test-resources/Import/Basic/List.dscr @@ -0,0 +1,19 @@ +module Import>Basic>List + +Nil[]. +Cons[first, rest]. +Map[f, xs]. +Apply[f, x]. +//Should be shadowed +Sub1[]. +Add3[]. +Res[value]. + +Map[f, xs: Nil[]]: Nil[] +Map[f, xs: Cons[first, rest]]: Cons[Apply[f, xs>first], Map[f, xs>rest]] +//Should be shadowed +Apply[f: Sub1[], x: #Number[]]: #Subtract[x, 1] +Apply[f: Add3[], x]: "Unexpected" + +//Should be unnecessary (doesn't even need to compile, but OK if does) +Res[value: Map[Sub1[], Cons[3, Cons[4, Cons[-5, Nil[]]]]]]? diff --git a/test-resources/Import/Basic/Num.dscr b/test-resources/Import/Basic/Num.dscr new file mode 100644 --- /dev/null +++ b/test-resources/Import/Basic/Num.dscr @@ -0,0 +1,12 @@ +module Import>Basic>Num +import Import>Basic>List{Apply} + +Add[left, right]. +Add3[]. +Add3_[]. +//Should be shadowed. +Res[foo]. + +Add3[]: Add3_[] +Apply[f: Add3_[], x: #Number[]]: Add[left: x, right: 3] +Add[left: #Number[], right: #Number[]]: #Add[left, right] diff --git a/test-resources/Import/Cycle/Blue.dscr b/test-resources/Import/Cycle/Blue.dscr new file mode 100644 --- /dev/null +++ b/test-resources/Import/Cycle/Blue.dscr @@ -0,0 +1,7 @@ +module Import>Cycle>Blue +import Import>Cycle>Red{Red} +import Import>Cycle>Color{Next} + +Blue[]. + +Next[color: Blue[]]: Red[] diff --git a/test-resources/Import/Cycle/Color.dscr b/test-resources/Import/Cycle/Color.dscr new file mode 100644 --- /dev/null +++ b/test-resources/Import/Cycle/Color.dscr @@ -0,0 +1,3 @@ +module Import>Cycle>Color + +Next[color]. diff --git a/test-resources/Import/Cycle/Green.dscr b/test-resources/Import/Cycle/Green.dscr new file mode 100644 --- /dev/null +++ b/test-resources/Import/Cycle/Green.dscr @@ -0,0 +1,7 @@ +module Import>Cycle>Green +import Import>Cycle>Color{Next} +import Import>Cycle>Blue{Blue} + +Green[]. + +Next[color: Green[]]: Blue[] diff --git a/test-resources/Import/Cycle/Red.dscr b/test-resources/Import/Cycle/Red.dscr new file mode 100644 --- /dev/null +++ b/test-resources/Import/Cycle/Red.dscr @@ -0,0 +1,7 @@ +module Import>Cycle>Red +import Import>Cycle>Green{Green} +import Import>Cycle>Color{Next} + +Red[]. + +Next[color: Red[]]: Green[] diff --git a/test-resources/Import/Math/Square.dscr b/test-resources/Import/Math/Square.dscr new file mode 100644 --- /dev/null +++ b/test-resources/Import/Math/Square.dscr @@ -0,0 +1,7 @@ +module Import>Math>Square + +Square[a]. +//A module parameter - should be substituted when imported. +Mult[left, right]. + +Square[a]: Mult[left: a, right: a] diff --git a/test-resources/Import/Math/Vector.dscr b/test-resources/Import/Math/Vector.dscr new file mode 100644 --- /dev/null +++ b/test-resources/Import/Math/Vector.dscr @@ -0,0 +1,19 @@ +module Import>Math>Vector + +Vec3[x, y, z]. +Dot[left, right]. +Cross[left, right]. + +Dot[left: Vec3[x, y, z], right: Vec3[x, y, z]]: #Add[ + #Multiply[left>x, right>x] + #Add[ + #Multiply[left>y, right>y] + #Multiply[left>z, right>z] + ] +] + +Cross[left: Vec3[x, y, z], right: Vec3[x, y, z]]: Vec3[ + x: #Subtract[#Multiply[left>y, right>z], #Multiply[left>z, right>y]] + y: #Subtract[#Multiply[left>z, right>x], #Multiply[left>x, right>z]] + z: #Subtract[#Multiply[left>x, right>y], #Multiply[left>y, right>x]] +] diff --git a/test-resources/examples/A.dscr b/test-resources/examples/A.dscr new file mode 100644 --- /dev/null +++ b/test-resources/examples/A.dscr @@ -0,0 +1,1 @@ +80? diff --git a/test-resources/examples/A.out.yaml b/test-resources/examples/A.out.yaml new file mode 100644 --- /dev/null +++ b/test-resources/examples/A.out.yaml @@ -0,0 +1,1 @@ +eval: "80" diff --git a/test-resources/examples/Basic.dscr b/test-resources/examples/Basic.dscr new file mode 100644 --- /dev/null +++ b/test-resources/examples/Basic.dscr @@ -0,0 +1,16 @@ +//Records. These are data structures and function signatures. +//These records define natural numbers and addition. +Zero[]. //0 - in other languages this would be an ADT or singleton. +Succ[prev]. //1 + prev - in other languages this would be an ADT, structure, or object. +Add[a, b]. //a + b - in other languages this would be a function. + +//Reducers. Reducers are like function implementations. These reducers "implement" Add. +Add[a: Zero[], b]: bprevcontent int main(string[] args) { + > println("Hello world"); + > } diff --git a/test-resources/examples/Import.Cycle.dscr b/test-resources/examples/Import.Cycle.dscr new file mode 100644 --- /dev/null +++ b/test-resources/examples/Import.Cycle.dscr @@ -0,0 +1,6 @@ +module Examples>Import +import Import>Cycle>Red + +What[]. + +What[]? diff --git a/test-resources/examples/Import.Cycle.out.yaml b/test-resources/examples/Import.Cycle.out.yaml new file mode 100644 --- /dev/null +++ b/test-resources/examples/Import.Cycle.out.yaml @@ -0,0 +1,11 @@ +valid?: false +problems: +- | + line 2, columns 7 to 24: failed to load dependency: + module depends on this module, forming a cycle: + - Examples>Import + - Import>Cycle>Red + - Import>Cycle>Green + - Import>Cycle>Blue + - Import>Cycle>Red + - Import>Cycle>Green diff --git a/test-resources/examples/Import.ModFunc.Workaround.dscr b/test-resources/examples/Import.ModFunc.Workaround.dscr new file mode 100644 --- /dev/null +++ b/test-resources/examples/Import.ModFunc.Workaround.dscr @@ -0,0 +1,33 @@ +//Uses the same exact function (`Square`) with 2 different definitions +//of an inner function (`Mult`), without using import parameters. +module Examples>Import +import Import>Math>Square{Mult, Square} +import Import>Math>Vector{Vec3, Dot, Cross} + +SqDot[a]. +SqCross[a]. +MultWrap[val, func]. +MultDot[]. +MultCross[]. + +Res[dotProduct, crossProduct]. +VecA[]. + +SqDot[a]: Square[MultWrap[a, func: MultDot[]]] +SqCross[a]: Square[MultWrap[a, func: MultCross[]]] + +Mult[ + left: MultWrap[val, func: MultDot[]] + right: MultWrap[val, func: MultDot[]] +]: Dot[left>val, right>val] +Mult[ + left: MultWrap[val, func: MultCross[]] + right: MultWrap[val, func: MultCross[]] +]: Cross[left>val, right>val] + +VecA[]: Vec3[x: 5, y: 4, z: 10] + +Res[ + dotProduct: SqDot[VecA[]] + crossProduct: SqCross[VecA[]] +]? diff --git a/test-resources/examples/Import.ModFunc.Workaround.out.yaml b/test-resources/examples/Import.ModFunc.Workaround.out.yaml new file mode 100644 --- /dev/null +++ b/test-resources/examples/Import.ModFunc.Workaround.out.yaml @@ -0,0 +1,2 @@ +final?: false +eval: 'Res[dotProduct: 141, crossProduct: Vec3[x: 0, y: 0, z: 0]]' diff --git a/test-resources/examples/Import.ModFunc.dscr b/test-resources/examples/Import.ModFunc.dscr new file mode 100644 --- /dev/null +++ b/test-resources/examples/Import.ModFunc.dscr @@ -0,0 +1,16 @@ +//Uses the same exact function (`Square`) with 2 different definitions +//of an inner function (`Mult`), by using import parameters. +module Examples>Import +import Import>Math>Square[Square => SqDot, Mult => Dot] +import Import>Math>Square[Square => SqCross, Mult => Cross] +import Import>Math>Vector{Vec3, Dot, Cross} + +Res[dotProduct, crossProduct]. +VecA[]. + +VecA[]: Vec3[x: 5, y: 4, z: 10] + +Res[ + dotProduct: SqDot[VecA[]] + crossProduct: SqCross[a: VecA[]] +]? diff --git a/test-resources/examples/Import.ModFunc.out.yaml b/test-resources/examples/Import.ModFunc.out.yaml new file mode 100644 --- /dev/null +++ b/test-resources/examples/Import.ModFunc.out.yaml @@ -0,0 +1,2 @@ +final?: false +eval: 'Res[dotProduct: 141, crossProduct: Vec3[x: 0, y: 0, z: 0]]' diff --git a/test-resources/examples/Import.dscr b/test-resources/examples/Import.dscr new file mode 100644 --- /dev/null +++ b/test-resources/examples/Import.dscr @@ -0,0 +1,10 @@ +module Examples>Import +import Import>Basic>List{Nil => Null, Cons, Map} +import Import>Basic>Num{Add3} + +Res[sym, calc]. + +Res[ + sym: Add3[] + calc: Map[f: Add3[], xs: Cons[9/4, Cons[1, Cons[15/2, Null[]]]]] +]? diff --git a/test-resources/examples/Import.out.yaml b/test-resources/examples/Import.out.yaml new file mode 100644 --- /dev/null +++ b/test-resources/examples/Import.out.yaml @@ -0,0 +1,4 @@ +final?: false +eval: "Res[sym: Add3_[], calc: Cons[first: 21/4, rest: Cons[first: 4, rest: Cons[first: 21/2, rest: Nil[]]]]]" +refactor: +- action: rename-record Add3 Add3_ diff --git a/test-resources/examples/ImportBuiltin.dscr b/test-resources/examples/ImportBuiltin.dscr new file mode 100644 --- /dev/null +++ b/test-resources/examples/ImportBuiltin.dscr @@ -0,0 +1,3 @@ +import Base{Add} + +Add[left: 3, right: 2]? diff --git a/test-resources/examples/ImportBuiltin.out.yaml b/test-resources/examples/ImportBuiltin.out.yaml new file mode 100644 --- /dev/null +++ b/test-resources/examples/ImportBuiltin.out.yaml @@ -0,0 +1,5 @@ +# TODO fix and uncomment +# eval: "5" + +# TODO fix and remove +valid?: false diff --git a/test-resources/examples/Injected.dscr b/test-resources/examples/Injected.dscr new file mode 100644 --- /dev/null +++ b/test-resources/examples/Injected.dscr @@ -0,0 +1,14 @@ +Add[left, right]. +App3[right, left, center]. +Result[add, app, weirdRep]. + +Add[left: #Number[], right: #Number[]]: #Add[a: leftprevaababaprevaaba:1:8: + | + 1 | Add[a: #Add[a, b]] + | ^ + expected primitive type, got injected function application +- label: validation-error + action: | + reduce + Add[a, b] + Add[b: aababa Pack[ + foos: Foo[contents: Bar[contents: Air[]]] | Air[] + bars: Bar[contents: Foo[contents: Air[]]] | Air[] +]*/ + +Organize[ + a: + Foo[contents: Bar[contents: Air[]]] | + Bar[contents: Foo[contents: Air[]]] +]? diff --git a/test-resources/examples/Rep.out.yaml b/test-resources/examples/Rep.out.yaml new file mode 100644 --- /dev/null +++ b/test-resources/examples/Rep.out.yaml @@ -0,0 +1,2 @@ +final?: false +eval: "Pack[foos: Foo[contents: Bar[contents: Air[]]] | Air[], bars: Air[] | Bar[contents: Foo[contents: Air[]]]]" diff --git a/test-resources/examples/Types.Exp.dscr b/test-resources/examples/Types.Exp.dscr new file mode 100644 --- /dev/null +++ b/test-resources/examples/Types.Exp.dscr @@ -0,0 +1,26 @@ +//Explicit type by alternate representation. + +//Records. These are data structures and function signatures. +//These records define natural numbers and addition. +Nat[]. //A natural number - in other languages this would be a type. +Untyped[]. //Denotes that a value needs to be typed. +Zero[]. //0 - in other languages this would be an ADT or singleton. +Succ[prev]. //1 + prev - in other languages this would be an ADT, structure, or object. +Add[a, b]. //a + b - in other languages this would be a function. + +//Reducers. Reducers are like function implementations. These reducers "implement" Add. +Add[a: Nat[], b: Nat[]] | Untyped[]: Nat[] //Adding naturals produces a natural. +Add[a: Zero[], b]: bprevprevprevpreva] +Add[Value[Succ[prev]], Value[a]]: Add[ + Value[a>a>prev] + Value[Succ[prev: baa>prev]] + Fib[Value[a>a>prev>prev]] +] +Fib3[Value[a]]: Fib[Fib[Fib[Value[a>a]]]] + +//Alternate number representation +Add[Value[#Number[]], Value[#Number[]]]: Value[#Add[a>a, b>a]] +Fib[Value[0]]: Value[1] +Fib[Value[1]]: Value[1] +Fib[Value[#Number[]]]: Add[ + Fib[Value[#Add[a>a, -1]]] + Fib[Value[#Add[a>a, -2]]] +] + +//Query +Res[ + rec: Fib3[Type[Nat[]] | Value[Succ[Succ[Succ[Succ[Zero[]]]]]]] + prim: Fib3[Type[Nat[]] | Value[4]] +]? diff --git a/test-resources/examples/Types.New+.out.yaml b/test-resources/examples/Types.New+.out.yaml new file mode 100644 --- /dev/null +++ b/test-resources/examples/Types.New+.out.yaml @@ -0,0 +1,2 @@ +final?: false +eval: 'Res[rec: Type[a: Nat[]] | Value[a: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]], prim: Type[a: Nat[]] | Value[a: 34]]' diff --git a/test-resources/examples/Types.New.Adv.dscr b/test-resources/examples/Types.New.Adv.dscr new file mode 100644 --- /dev/null +++ b/test-resources/examples/Types.New.Adv.dscr @@ -0,0 +1,81 @@ +//Separates values into 'Value[a] | Type[a]'. + +Res[rec, prim]. + +//The type system +Value[a]. //An untyped value. +Type[a]. //A value's type. + +//Values +None[]. +Some[a]. +Zero[]. +Succ[prev]. + +//Functions +One[a]. // Interesting - returns '1' in the encoding of 'a'. +Add[a, b]. +Sub1[a]. +Sub2[a]. +Sub_[a, sub, cmp]. +Fib[a]. +Fib_[a, sub1, sub2]. +Fib3[a]. + +//Types +Maybe[a]. +Nat[]. + +//Type signatures +One[a: Type[a: Nat[]]]: Type[a: Nat[]] +Add[a: Type[a: Nat[]], b: Type[a: Nat[]]]: Type[a: Nat[]] +Sub1[a: Type[a: Nat[]]]: Type[a: Maybe[a: Nat[]]] +Sub2[a: Type[a: Nat[]]]: Type[a: Maybe[a: Nat[]]] +Fib[a: Type[a: Nat[]]]: Type[a: Nat[]] +Fib_[ + a: Type[a: Nat[]] + sub1: Type[a: Maybe[a: Nat[]]] + sub2: Type[a: Maybe[a: Nat[]]] +]: Type[a: Nat[]] +Fib3[a: Type[a: Nat[]]]: Type[a: Nat[]] + +//Untyped functions +One[a: Value[a: Zero[]]]: Value[a: Succ[prev: Zero[]]] +One[a: Value[a: Succ[prev]]]: Value[a: Succ[prev: Zero[]]] +Add[a: Value[a: Zero[]], b: Value[a]]: baprevaaprevaprevprevaaaaaaaaaaaaprevaaprevaprevprevaaaaaprevprevImport +import Import>Basic>List{Nil => Null, Cons, Map} +import Import>Basic>Num{Add3 => Add3_} + +Res[sym, calc]. + +Res[ + sym: Add3_[] + calc: Map[f: Add3_[], xs: Cons[9/4, Cons[1, Cons[15/2, Null[]]]]] +]? diff --git a/test-resources/refactors/Macros.free-bind-complex-new.dscr b/test-resources/refactors/Macros.free-bind-complex-new.dscr new file mode 100644 --- /dev/null +++ b/test-resources/refactors/Macros.free-bind-complex-new.dscr @@ -0,0 +1,35 @@ +//Macros + +UZero[]. +USucc[prev]. +Sub[a, b]. +Neg[a]. + +Nat[]. +Untyped[]. +Zero[]. +Succ[prev]. +Add[a, b]. + +//Macros +UZero[]: Zero[] | Untyped[] +USucc[prev]: Succ[prev: prevaaaprevprevaababaprevaababaprevaaprevaaprevaprevprevaaaaa String -> IO Text +getRefactorText action = Text.readFile . getRefactorPath action + +getRefactorPath :: String -> String -> String +getRefactorPath label' srcName + = refactorsDir srcName <.> label' <.> "dscr" + +mkVarMap :: (Ord k) => [k] -> IO (VarMap k v) +mkVarMap = fmap Map.fromList . mapM (sequence . (, newMVar Nothing)) + +insertVarMap :: (Ord k) => VarMap k v -> k -> v -> IO () +insertVarMap vars key x = do + Nothing <- swapMVar (vars Map.! key) $ Just x + pure () + +spec :: Spec +spec = do + exampleFiles <- runIO getExampleFiles + exampleParsedVars <- runIO $ mkVarMap exampleFiles + exampleResolvedVars <- runIO $ mkVarMap exampleFiles + exampleRefinedVars <- runIO $ mkVarMap exampleFiles + exampleInterpretedVars <- runIO $ mkVarMap exampleFiles + let forExampleFile :: (TestFile -> IO ()) -> IO () + forExampleFile f = + forM_ exampleFiles $ \file -> + denoteFailIn ("file " ++ sfileName (srcFile file)) $ f file + forPhaseIn :: TestFile -> (String -> ParseResult (String, String) -> IO ()) -> IO () + forPhaseIn file@(TestFile srcFile' _) f = do + result <- runResultT $ parseTest srcFile' $ \phaseName phaseRes -> + denoteFailIn ("phase " ++ phaseName) $ f phaseName phaseRes + case result of + Failure _ -> pure () + Success val -> insertVarMap exampleParsedVars file val + forExampleIntermediateIn :: Map TestFile (MVar (Maybe a)) -> (TestFile -> a -> IO ()) -> IO () + forExampleIntermediateIn xVars f = + forM_ (Map.toAscList xVars) $ \(file, xVar) -> + denoteFailIn ("file " ++ sfileName (srcFile file)) $ withMVar xVar $ \case + Nothing -> pure () + Just val -> f file val + forExampleParsed :: (TestFile -> Sugar.Source SrcAnn -> IO ()) -> IO () + forExampleParsed = forExampleIntermediateIn exampleParsedVars + forExampleResolved :: (TestFile -> BasicInj.DirtyDepd Sugar.Source SrcAnn -> IO ()) -> IO () + forExampleResolved = forExampleIntermediateIn exampleResolvedVars + forExampleRefinedSrc :: (TestFile -> BasicInj.DirtyDepd BasicInj.Source SrcAnn -> IO ()) -> IO () + forExampleRefinedSrc = forExampleIntermediateIn exampleRefinedVars + forExampleRefinedProg :: (TestFile -> BasicInj.DirtyDepd BasicInj.Program SrcAnn -> IO ()) -> IO () + forExampleRefinedProg f = forExampleRefinedSrc $ \file -> \case + Depd _ (BasicInj.SourceModule _) -> pure () + Depd ddep (BasicInj.SourceProgram prgm) -> f file $ Depd ddep prgm + forExampleInterpreted :: (TestFile -> BasicInj.Reg.Value () -> IO ()) -> IO () + forExampleInterpreted = forExampleIntermediateIn exampleInterpretedVars + + describe "Read" $ do + it "Parses" $ + forExampleFile $ \file@(TestFile srcFile' testInfo') -> do + let shouldFailTo = shouldFailToSummaryIn srcFile' + fileStr = Text.unpack $ sfileContents srcFile' + if isParseable testInfo' then do + forPhaseIn file $ \phaseName phaseRes -> do + when (phaseName `elem` printParsedPhases testInfo') $ do + putStrLn $ sfileName srcFile' ++ " - " ++ phaseName ++ ":" + putStrLn $ summaryF srcFile' phaseRes + case phaseRes of + Failure phaseErr -> assertFailure $ summaryF srcFile' phaseErr + Success (phaseRp, _) -> phaseRp `shouldBeReducePrintOf` fileStr + else + unless (null $ errorMsg testInfo') $ do + parse srcFile' `shouldFailTo` errorMsg testInfo' + it "Resolves" $ + -- Dependency failures are handled by the validation tests. + forExampleParsed $ \file@(TestFile srcFile' testInfo') psrc -> do + rsddsrc <- Sugar.resolve testDepResolver psrc + when (printDependency testInfo') $ do + let dep = dirtyVal $ depdDep rsddsrc + putStrLn $ sfileName srcFile' ++ ":" + Text.putStrLn $ pprint dep + insertVarMap exampleResolvedVars file rsddsrc + it "Refines" $ + -- This test is only useful to check hanging and exceptions. + -- Not sure if it even does that because the source isn't forced. + forExampleResolved $ \file rsddsrc -> do + let !rfddsrc = Sugar.refineDDepd rsddsrc + insertVarMap exampleRefinedVars file rfddsrc + describe "Process" $ do + it "Validates" $ + forExampleRefinedSrc $ \(TestFile _ testInfo') ddsrc -> do + let pmsgs = map summary $ BasicInj.validate' ddsrc + if isValid testInfo' then + pmsgs `shouldSatisfy` null + else + unless (null $ problemMsgs testInfo') $ do + pmsgs `shouldBe` problemMsgs testInfo' + it "Interprets" $ + forExampleRefinedProg $ \file@(TestFile _ testInfo') ddprog -> + when (isValid testInfo' && isTerminating testInfo') $ do + let dprog = mapDep dirtyVal ddprog + !interpreted = BasicInj.interpret_ dprog + insertVarMap exampleInterpretedVars file interpreted + it "Refactors" $ + forExampleFile $ \(TestFile srcFile' testInfo') -> do + let srcDFile = DFile testDepResolver srcFile' + srcText' = sfileContents srcFile' + forM_ (refactorCmds testInfo') $ \(RefactorInfo action args ewarnMsgs eerrMsg label') -> do + let shouldSucceed = null eerrMsg + Dirty awarnings res <- runDirtyResT $ parseRefactor action args srcDFile + let awarnMsgs = map summary awarnings + case res of + Failure err -> do + let aerrMsg = summaryF srcFile' err + if shouldSucceed then + assertFailure aerrMsg + else + aerrMsg `shouldBe` eerrMsg + Success patch -> do + let anewSrcText = apPatch patch srcText' + if shouldSucceed then do + enewSrcText <- getRefactorText label' $ sfileName srcFile' + anewSrcText `shouldBe` enewSrcText + else + assertFailure $ "Unexpected success\n" ++ Text.unpack anewSrcText + awarnMsgs `shouldBe` ewarnMsgs + describe "Write" $ do + it "Compiles" $ + forExampleInterpreted $ \(TestFile srcFile' testInfo') interpreted -> + when (isFinal testInfo') $ + case BasicInj.compile (sfileName srcFile') interpreted of + Failure err -> assertFailure $ summary err + Success package -> do + when (printCompiled testInfo') $ do + putStrLn $ sfileName srcFile' ++ ":" + Text.putStrLn $ pprintPackage package + unless (Text.null $ packagePr testInfo') $ + pprintPackage package `shouldBe` packagePr testInfo' + it "Evaluates" $ + forExampleInterpreted $ \(TestFile srcFile' testInfo') interpreted -> do + when (printEvaluated testInfo') $ do + putStr $ sfileName srcFile' ++ ": " + Text.putStrLn $ pprint interpreted + unless (Text.null $ evalPr testInfo') $ + pprint interpreted `shouldBe` evalPr testInfo' + it "Reprints" $ + forExampleRefinedSrc $ \(TestFile srcFile' testInfo') dsrc -> do + let source = depdVal dsrc + srcText' = sfileContents srcFile' + patch = ppatchThorough source + when (printReprinted testInfo') $ do + putStrLn $ sfileName srcFile' ++ ": " + Text.putStrLn $ reprint (sfileContents srcFile') source + reprint srcText' source `shouldSatisfy` (`Text.isInfixOf` srcText') + apPatch patch srcText' `shouldBe` srcText' + patchOffset patch `shouldBe` mempty diff --git a/test/Core/Test.hs b/test/Core/Test.hs new file mode 100644 --- /dev/null +++ b/test/Core/Test.hs @@ -0,0 +1,13 @@ +module Core.Test + ( module Core.Test.Descript + , module Core.Test.HUnit + , module Test.Hspec + , module Test.QuickCheck + , module Test.HUnit + ) where + +import Core.Test.Descript +import Core.Test.HUnit +import Test.Hspec +import Test.QuickCheck hiding (Result, Success, Failure, Testable) +import Test.HUnit hiding (Testable) diff --git a/test/Core/Test/Descript.hs b/test/Core/Test/Descript.hs new file mode 100644 --- /dev/null +++ b/test/Core/Test/Descript.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/test/Core/Test/Descript/Spec.hs b/test/Core/Test/Descript/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Core/Test/Descript/Spec.hs @@ -0,0 +1,41 @@ +module Core.Test.Descript.Spec + ( shouldFailTo_ + , shouldFailToSummaryIn + , shouldFailToSummaries + , shouldBeReducePrintOf + ) where + +import Test.Hspec +import Test.HUnit +import Descript.Misc +import Data.List +import Control.Monad + +-- | Asserts the result should be a failure, and the error should be the +-- given value. +shouldFailTo_ :: (HasCallStack, Eq e, Show e, Summary a) => Result e a -> e -> Expectation +shouldFailTo_ = shouldFailToGen id + +-- | Asserts the result should be a failure, and the error's summary +-- should be the given value. +shouldFailToSummaryIn :: (HasCallStack, FileSummary e, Summary a) => SFile -> Result e a -> String -> Expectation +shouldFailToSummaryIn = shouldFailToGen . summaryF + +-- | Asserts the result should be a failure, and the errors' summaries +-- should be the given values. +shouldFailToSummaries :: (HasCallStack, Summary e, Summary a) => Result [e] a -> [String] -> Expectation +shouldFailToSummaries = shouldFailToGen $ map summary + +shouldFailToGen :: (HasCallStack, Eq ee, Show ee, Summary a) => (ae -> ee) -> Result ae a -> ee -> Expectation +shouldFailToGen f (Failure aerr) eerr = f aerr `shouldBe` eerr +shouldFailToGen _ (Success val) _ = assertFailure $ "Unexpected success: " ++ summary val + +-- | Specifies that the left string should be a subsequence of the right. +shouldBeReducePrintOf :: (HasCallStack) => String -> String -> Expectation +rp `shouldBeReducePrintOf` full + = unless (rp `isSubsequenceOf` full) $ assertFailure failMsg + where failMsg + = "not a reduce print:\n" + ++ rp + ++ "\n----- isn't a reduce print of -----\n" + ++ full diff --git a/test/Core/Test/Descript/TestFile.hs b/test/Core/Test/Descript/TestFile.hs new file mode 100644 --- /dev/null +++ b/test/Core/Test/Descript/TestFile.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Core.Test.Descript.TestFile + ( TestFile (..) + , TestInfo (..) + , RefactorInfo (..) + , loadFilesInDir + ) where + +import Descript.Misc +import System.Directory +import System.FilePath +import Data.Maybe +import Data.List +import Data.Text (Text) +import Data.Yaml +import Control.Applicative + +data TestFile + = TestFile + { srcFile :: SFile + , testInfo :: TestInfo + } deriving (Eq, Ord, Read, Show) + +data TestInfo + = TestInfo + { printParsedPhases :: [String] + , printDependency :: Bool + , printEvaluated :: Bool + , printCompiled :: Bool + , printReprinted :: Bool + , isParseable :: Bool + , isValid :: Bool + , isTerminating :: Bool + , isFinal :: Bool + , evalPr :: Text + , packagePr :: Text + , refactorCmds :: [RefactorInfo] + , errorMsg :: String + , problemMsgs :: [String] + } deriving (Eq, Ord, Read, Show) + +data RefactorInfo + = RefactorInfo + { refactorCmdAction :: String + , refactorCmdArgs :: [String] + , refactorWarningMsgs :: [String] + , refactorErrorMsg :: String + , refactorLabel :: String + } deriving (Eq, Ord, Read, Show) + +instance FromJSON TestInfo where + parseJSON = withObject "TestInfo" $ \x -> TestInfo + <$> x .:? "printParsedPhases" .!= [] + <*> x .:? "printDependency?" .!= False + <*> x .:? "printEval?" .!= False + <*> x .:? "printCompile?" .!= False + <*> x .:? "printReprint?" .!= False + <*> x .:? "parses?" .!= True + <*> x .:? "valid?" .!= True + <*> x .:? "terminates?" .!= True + <*> x .:? "final?" .!= True + <*> x .:? "eval" .!= "" + <*> x .:? "compile" .!= "" + <*> x .:? "refactor" .!= [] + <*> x .:? "error" .!= "" + <*> x .:? "problems" .!= [] + +instance FromJSON RefactorInfo where + parseJSON val = parseStr val <|> parseObject val + where parseStr = fmap mkBasicRefactorInfo . parseJSON + parseObject = withObject "RefactorInfo" $ \x -> mkRefactorInfo + <$> x .: "action" + <*> x .:? "warnings" .!= [] + <*> x .:? "error" .!= "" + <*> x .:? "label" + +-- | Gets the all test files in the directory, assuming the directory doesn't +-- contain any sub-directories. +loadFilesInDir :: FilePath -> IO [TestFile] +loadFilesInDir dir + = traverse (loadTestFileInDir dir) + . mapMaybe (stripSuffix ".dscr") + =<< listDirectory dir + +-- | Reads the test file in the given directory with the given name. +loadTestFileInDir :: FilePath -> String -> IO TestFile +loadTestFileInDir dir name' + = TestFile <$> loadSrcFileInDir dir name' <*> loadTestInfoInDir dir name' + +-- | Reads the source file in the given directory with the given name. +loadSrcFileInDir :: FilePath -> String -> IO SFile +loadSrcFileInDir dir name' = loadSFile $ dir name' <.> "dscr" + +-- | Reads the source file in the given directory with the given name. +loadTestInfoInDir :: FilePath -> String -> IO TestInfo +loadTestInfoInDir dir name' = do + let path = dir name' <.> "out.yaml" + result <- decodeFileEither path + case result of + Left err + -> fail + $ "Error while decoding test info for " + ++ name' + ++ ": " + ++ prettyPrintParseException err + Right x -> pure x + +mkBasicRefactorInfo :: String -> RefactorInfo +mkBasicRefactorInfo cmd = mkRefactorInfo cmd [] "" Nothing + +mkRefactorInfo :: String -> [String] -> String -> Maybe String -> RefactorInfo +mkRefactorInfo cmd warnMsgs errMsg optLabel + = case parseCmd cmd of + [] -> error "refactor command can't be empty, needs action specified" + action : args -> RefactorInfo action args warnMsgs errMsg label + where label = action `fromMaybe` optLabel + +parseCmd :: String -> [String] +parseCmd cmd + = case lines cmd of + [] -> [""] + [cmd1] -> words cmd1 + parts -> parts + +stripSuffix :: (Eq a) => [a] -> [a] -> Maybe [a] +stripSuffix suf = fmap reverse . stripPrefix (reverse suf) . reverse diff --git a/test/Core/Test/HUnit.hs b/test/Core/Test/HUnit.hs new file mode 100644 --- /dev/null +++ b/test/Core/Test/HUnit.hs @@ -0,0 +1,45 @@ +module Core.Test.HUnit + ( tryTest + , denoteFailIn + , denoteFail + ) where + +import Test.HUnit.Lang +import Data.Maybe +import Control.Exception + +-- | Will return 'Nothing' if an exception was raised. +tryTest :: IO a -> IO (Maybe a) +tryTest action = do + res <- try action + case res of + Left HUnitFailure{} -> pure Nothing + Right val -> pure $ Just val + +-- | If a failure occurs, denotes that it occurred for "in" the given label. +denoteFailIn :: String -> IO a -> IO a +denoteFailIn label = denoteFail $ "in " ++ label ++ ": " + +-- | If a failure occurs, prepends the given string to the error +-- message. +denoteFail :: String -> IO a -> IO a +denoteFail pre test = test `catch` rethrowWithPrefix pre + +-- | Prepends the given string to the error message. +rethrowWithPrefix :: String -> HUnitFailure -> IO a +rethrowWithPrefix pre = throw . addPrefixToFailure pre + +addPrefixToFailure :: String -> HUnitFailure -> HUnitFailure +addPrefixToFailure pre (HUnitFailure srcLoc reason) + = HUnitFailure srcLoc $ addPrefixToReason pre reason + +addPrefixToReason :: String -> FailureReason -> FailureReason +addPrefixToReason pre (Reason msg) = Reason $ addPrefixToMsg pre msg +addPrefixToReason pre (ExpectedButGot extraMsg expected got) + = ExpectedButGot (addPrefixToExtraMsg pre extraMsg) expected got + +addPrefixToExtraMsg :: String -> Maybe String -> Maybe String +addPrefixToExtraMsg pre = Just . addPrefixToMsg pre . fromMaybe "" + +addPrefixToMsg :: String -> String -> String +addPrefixToMsg pre msg = pre ++ msg diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}