packages feed

descript-lang (empty) → 0.2.0.0

raw patch · 238 files changed

+15846/−0 lines, 238 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed

Dependencies added: HUnit, QuickCheck, aeson, array, autoexporter, base, bifunctors, bytestring, containers, data-default, descript-lang, directory, exceptions, filepath, fsnotify, hashtables, haskell-lsp, hslogger, hspec, lens, megaparsec, mtl, network-uri, optparse-applicative, rainbow, stm, text, transformers, unordered-containers, vector, yaml, yi-rope

Files

+ ChangeLog.md view
@@ -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.
+ LICENSE view
@@ -0,0 +1,674 @@+              GNU GENERAL PUBLIC LICENSE+                Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                     Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++              END OF TERMS AND CONDITIONS++     How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ README.md view
@@ -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 <filename>`.+//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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Action.hs view
@@ -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+  }
+ app/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Run+import Parse++main :: IO ()+main = run =<< prompt
+ app/Parse.hs view
@@ -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"
+ app/Run.hs view
@@ -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
+ app/Server/Decode.hs view
@@ -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
+ app/Server/Encode.hs view
@@ -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 = ""+  }
+ app/Server/Run.hs view
@@ -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++-- ---------------------------------------------------------------------
+ dep-licenses/haskell-ide-engine view
@@ -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.
+ dep-licenses/haskell-lsp view
@@ -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.
+ descript-lang.cabal view
@@ -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 <https://bitbucket.org/jakobeha/descript-lang/src/master/README.md>+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
+ docs/Spec.md view
@@ -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 `a<A>b<B` applied to a value is created by this+algorithm.++1. Take the value's parts.+2. Then take from the parts all records with the head `A`.+3. Then look up the entry in their maps with the key `a`.+4. Then take the parts from those values.+5. Then take from those parts all records with the head `B`.+6. Then look up the entry in their maps with the key `b`.+7. Repeat from (2) until the end of the property's path is reached. You+   should have a union of parts.++The result of this is the value with those parts.++There can only be one reducer defined for a particular value.++**Implicit Transitive Reducer:** If `ai` reduces to `ao`, then `ai | b`+reduces to `ao | b`, unless another reducer for `ai | b` is defined.++A part can be marked as final.++A value is final if all its parts are final.++Final values can't reduce. If a reducer is defined, an error is raised.++- A value containing a final part *isn't* final, so it has to reduce.+  Furthermore, an explicit reducer *can* be defined for it.++All other expressions have to reduce. If no reducer is defined, an error+is raised.++The output of a program is a final value.++A code block contains source code (data) and a language.++Code blocks are usually special - typically a program outputs a code+block which is its compiled form.++> It could be a record or atom, depending on implementation.
+ resources/modules/Base.dscr view
@@ -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]
+ src/Core/Control/Applicative.hs view
@@ -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
+ src/Core/Control/Monad/ST.hs view
@@ -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
+ src/Core/Control/Monad/Trans.hs view
@@ -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
+ src/Core/Data/Functor.hs view
@@ -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
+ src/Core/Data/Group.hs view
@@ -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
+ src/Core/Data/List.hs view
@@ -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
+ src/Core/Data/List/Assoc.hs view
@@ -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
+ src/Core/Data/List/NonEmpty.hs view
@@ -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
+ src/Core/Data/Map/Strict.hs view
@@ -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
+ src/Core/Data/Monoid.hs view
@@ -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
+ src/Core/Data/Proxy.hs view
@@ -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
+ src/Core/Data/Semigroup.hs view
@@ -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 = (<>)
+ src/Core/Data/Set.hs view
@@ -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
+ src/Core/Data/String.hs view
@@ -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
+ src/Core/Data/Text.hs view
@@ -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> "
+ src/Core/Data/Tuple.hs view
@@ -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)
+ src/Core/DontForce.hs view
@@ -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"
+ src/Core/Numeric.hs view
@@ -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)
+ src/Core/System/FilePath.hs view
@@ -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
+ src/Core/Text/Megaparsec.hs view
@@ -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 []
+ src/Core/Text/Megaparsec/Error.hs view
@@ -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
+ src/Core/Text/ParserCombinators/Read.hs view
@@ -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
+ src/Descript.hs view
@@ -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
+ src/Descript/BasicInj.hs view
@@ -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 #-}
+ src/Descript/BasicInj/Data.hs view
@@ -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
+ src/Descript/BasicInj/Data/Atom.hs view
@@ -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
+ src/Descript/BasicInj/Data/Atom/Inject.hs view
@@ -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
+ src/Descript/BasicInj/Data/Atom/PropPath.hs view
@@ -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<Foo` would refer to `5` in `Foo[a: 5]`.+data PathElem an+  = PathElem+  { pathElemAnn :: an+  , keyRef :: Symbol an -- ^ Refers to the property key (e.g. `a`).+  , headRef :: FSymbol an -- ^ Refers to the type of record (e.g. `Foo`).+  } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)++instance Ann PropPath where+  getAnn (PropPath ann _) = ann++instance Ann PathElem where+  getAnn = pathElemAnn++instance Printable PropPath where+  aprintRec sub (PropPath _ elems) = pintercal ">" $ 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
+ src/Descript/BasicInj/Data/Atom/Scope.hs view
@@ -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+  }
+ src/Descript/BasicInj/Data/Import.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/BasicInj/Data/Import/Import.hs view
@@ -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
+ src/Descript/BasicInj/Data/Import/Module.hs view
@@ -0,0 +1,5 @@+module Descript.BasicInj.Data.Import.Module+  ( module Descript.Free.Data.Import.Module+  ) where++import Descript.Free.Data.Import.Module
+ src/Descript/BasicInj/Data/InjFunc.hs view
@@ -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
+ src/Descript/BasicInj/Data/Reducer.hs view
@@ -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
+ src/Descript/BasicInj/Data/Source.hs view
@@ -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
+ src/Descript/BasicInj/Data/Type.hs view
@@ -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
+ src/Descript/BasicInj/Data/Value.hs view
@@ -0,0 +1,5 @@+module Descript.BasicInj.Data.Value+  ( module Descript.BasicInj.Data.Value.Gen+  ) where++import Descript.BasicInj.Data.Value.Gen
+ src/Descript/BasicInj/Data/Value/Gen.hs view
@@ -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
+ src/Descript/BasicInj/Data/Value/In.hs view
@@ -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
+ src/Descript/BasicInj/Data/Value/Out.hs view
@@ -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
+ src/Descript/BasicInj/Data/Value/Reg.hs view
@@ -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
+ src/Descript/BasicInj/Process.hs view
@@ -0,0 +1,2 @@+-- | Process the AST (interpret, inspect, refactor, etc.).+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/BasicInj/Process/Inspect.hs view
@@ -0,0 +1,2 @@+-- | Get information about 'BasicInj' ASTs.+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/BasicInj/Process/Inspect/SymbolAt.hs view
@@ -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
+ src/Descript/BasicInj/Process/Reduce.hs view
@@ -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
+ src/Descript/BasicInj/Process/Reduce/Match.hs view
@@ -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+  }
+ src/Descript/BasicInj/Process/Reduce/NoAnn.hs view
@@ -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."
+ src/Descript/BasicInj/Process/Reduce/PropTrans.hs view
@@ -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+  }
+ src/Descript/BasicInj/Process/Reduce/SrcAnn.hs view
@@ -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."
+ src/Descript/BasicInj/Process/Refactor.hs view
@@ -0,0 +1,2 @@+-- | Perform changes on 'BasicInj' ASTs.+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/BasicInj/Process/Refactor/GenRenameSymbol.hs view
@@ -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
+ src/Descript/BasicInj/Process/Refactor/RefactorReduce.hs view
@@ -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
+ src/Descript/BasicInj/Process/Refactor/RenameModuleElem.hs view
@@ -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
+ src/Descript/BasicInj/Process/Refactor/RenameProp.hs view
@@ -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
+ src/Descript/BasicInj/Process/Refactor/RenameRecord.hs view
@@ -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
+ src/Descript/BasicInj/Process/Refactor/RenameSymbol.hs view
@@ -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
+ src/Descript/BasicInj/Process/Validate.hs view
@@ -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
+ src/Descript/BasicInj/Read.hs view
@@ -0,0 +1,2 @@+-- | Read the AST (including dependencies).+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/BasicInj/Read/Resolve.hs view
@@ -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
+ src/Descript/BasicInj/Read/Resolve/Subst.hs view
@@ -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
+ src/Descript/BasicInj/Read/Resolve/Subst/Global.hs view
@@ -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
+ src/Descript/BasicInj/Read/Resolve/Subst/Local.hs view
@@ -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
+ src/Descript/BasicInj/Read/Resolve/Subst/Subst.hs view
@@ -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
+ src/Descript/BasicInj/Traverse.hs view
@@ -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
+ src/Descript/BasicInj/Traverse/Term.hs view
@@ -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
+ src/Descript/BasicInj/Traverse/Termed.hs view
@@ -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)
+ src/Descript/BasicInj/Write.hs view
@@ -0,0 +1,2 @@+-- | Write the AST (reprint or compile).+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/BasicInj/Write/Compile.hs view
@@ -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 ()
+ src/Descript/BasicInj/Write/Diagnose.hs view
@@ -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)
+ src/Descript/Build.hs view
@@ -0,0 +1,2 @@+-- | Organizes all the build phases.+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Build/Build.hs view
@@ -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
+ src/Descript/Build/Cache.hs view
@@ -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 #-}
+ src/Descript/Build/Cache/Error.hs view
@@ -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)
+ src/Descript/Build/Cache/FileCache.hs view
@@ -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+  }
+ src/Descript/Build/Cache/GlobalCache.hs view
@@ -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
+ src/Descript/Build/Cache/PhaseCache.hs view
@@ -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
+ src/Descript/Build/Error.hs view
@@ -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
+ src/Descript/Build/Read.hs view
@@ -0,0 +1,3 @@+-- | Generate a source AST which can be processed. Used by other build+-- functions.+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Build/Read/File.hs view
@@ -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
+ src/Descript/Build/Read/Parse.hs view
@@ -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
+ src/Descript/Build/Read/Read.hs view
@@ -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
+ src/Descript/Build/Refactor.hs view
@@ -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)
+ src/Descript/Fast.hs view
@@ -0,0 +1,3 @@+-- | Fast implementation - efficient but complicated and unchecked (or+-- maybe partially checked...).+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Fast/Reduce.hs view
@@ -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
+ src/Descript/Free.hs view
@@ -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 #-}
+ src/Descript/Free/Data.hs view
@@ -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
+ src/Descript/Free/Data/Atom.hs view
@@ -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
+ src/Descript/Free/Data/Atom/PropPath.hs view
@@ -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<Foo` would refer to `5` in `Foo[a: 5]`.+data PathElem an+  = PathElemImp (Symbol an)+  | PathElemExp an (Symbol an) (Symbol an)+  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)++instance Ann PropPath where+  getAnn (PropPath ann _) = ann++instance Ann PathElem where+  getAnn (PathElemImp x) = getAnn x+  getAnn (PathElemExp ann _ _) = ann++instance Printable PropPath where+  aprintRec sub (PropPath _ elems) = pintercal ">" $ 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'
+ src/Descript/Free/Data/Import.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Free/Data/Import/Import.hs view
@@ -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
+ src/Descript/Free/Data/Import/Module.hs view
@@ -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
+ src/Descript/Free/Error.hs view
@@ -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 ++ "\""
+ src/Descript/Free/Parse.hs view
@@ -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
+ src/Descript/Lex.hs view
@@ -0,0 +1,3 @@+-- | Lexemes - the simplest representation besides raw text, doesn't+-- even have recursive elements.+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Lex/Data.hs view
@@ -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
+ src/Descript/Lex/Data/Atom.hs view
@@ -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
+ src/Descript/Lex/Parse.hs view
@@ -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
+ src/Descript/Misc.hs view
@@ -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 #-}
+ src/Descript/Misc/Ann.hs view
@@ -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
+ src/Descript/Misc/Build.hs view
@@ -0,0 +1,2 @@+-- | General stuff for any build phase.+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Misc/Build/Process.hs view
@@ -0,0 +1,2 @@+-- | Process the AST (interpret, inspect, refactor, etc.).+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Misc/Build/Process/Diagnose.hs view
@@ -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
+ src/Descript/Misc/Build/Process/Refactor.hs view
@@ -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
+ src/Descript/Misc/Build/Process/Validate.hs view
@@ -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)
+ src/Descript/Misc/Build/Process/Validate/Problem.hs view
@@ -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)
+ src/Descript/Misc/Build/Process/Validate/Term.hs view
@@ -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
+ src/Descript/Misc/Build/Read.hs view
@@ -0,0 +1,2 @@+-- | Read the AST (including dependencies).+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Misc/Build/Read/File.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Misc/Build/Read/File/DFile.hs view
@@ -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
+ src/Descript/Misc/Build/Read/File/DepError.hs view
@@ -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
+ src/Descript/Misc/Build/Read/File/DepResolve.hs view
@@ -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"
+ src/Descript/Misc/Build/Read/File/Depd.hs view
@@ -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
+ src/Descript/Misc/Build/Read/File/SFile.hs view
@@ -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 = "<interactive>"
+ src/Descript/Misc/Build/Read/File/Scope.hs view
@@ -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>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` "<Qux"+-- "Foo>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"+-- "<Bar"+-- >>> "Foo>Bar>Baz" `scopeRelToSib` "Foo>Qux>Abc"+-- "<Bar>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"+-- "<Baz"+-- >>> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Qux"+-- "<Bar>Baz"+-- >>> "Foo>Bar" `scopeRelToParent` "Foo>Baz>Qux"+-- "<<Bar"+-- >>> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Qux>Abc"+-- "<<Bar>Baz"+-- >>> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Bar>Baz"+-- "<Baz" -- Special case - scope needs to be 'NonEmpty'+-- >>> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Bar"+-- "Baz"+-- >>> "Foo>Bar>Baz" `scopeRelToParent` "Foo>Bar>Baz>Qux"+-- "<<Bar" -- Special case - scope needs to be 'NonEmpty'+scopeRelToParent :: AbsScope -> 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" "<Baz>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
+ src/Descript/Misc/Build/Read/Parse.hs view
@@ -0,0 +1,2 @@+-- | General stuff for any parse phase.+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Misc/Build/Read/Parse/Action.hs view
@@ -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
+ src/Descript/Misc/Build/Read/Parse/Error.hs view
@@ -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
+ src/Descript/Misc/Build/Read/Parse/Loc.hs view
@@ -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
+ src/Descript/Misc/Build/Read/Parse/SrcAnn.hs view
@@ -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"
+ src/Descript/Misc/Build/Write.hs view
@@ -0,0 +1,2 @@+-- | Write the AST (reprint or compile).+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Misc/Build/Write/Compile.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Misc/Build/Write/Compile/Code.hs view
@@ -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
+ src/Descript/Misc/Build/Write/Compile/Package.hs view
@@ -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
+ src/Descript/Misc/Build/Write/Compile/Result.hs view
@@ -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
+ src/Descript/Misc/Build/Write/Print.hs view
@@ -0,0 +1,3 @@+-- | Converts an AST node back into source text - the opposite of+-- parsing.+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Misc/Build/Write/Print/APrint.hs view
@@ -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
+ src/Descript/Misc/Build/Write/Print/Patch.hs view
@@ -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
+ src/Descript/Misc/Build/Write/Print/PrimPrintable.hs view
@@ -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
+ src/Descript/Misc/Build/Write/Print/PrintPatch.hs view
@@ -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."+  ]
+ src/Descript/Misc/Build/Write/Print/PrintReduce.hs view
@@ -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
+ src/Descript/Misc/Build/Write/Print/PrintString.hs view
@@ -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
+ src/Descript/Misc/Build/Write/Print/PrintText.hs view
@@ -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
+ src/Descript/Misc/Build/Write/Print/Printable.hs view
@@ -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
+ src/Descript/Misc/Error.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Misc/Error/Dirty.hs view
@@ -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
+ src/Descript/Misc/Error/Result.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Descript/Misc/Error/Result/Base.hs view
@@ -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
+ src/Descript/Misc/Error/Result/Trans.hs view
@@ -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
+ src/Descript/Misc/Loc.hs view
@@ -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 }
+ src/Descript/Misc/Summary.hs view
@@ -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 ++ ")"
+ src/Descript/Sugar.hs view
@@ -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 #-}
+ src/Descript/Sugar/Data.hs view
@@ -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
+ src/Descript/Sugar/Data/Atom.hs view
@@ -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
+ src/Descript/Sugar/Data/Atom/Inject.hs view
@@ -0,0 +1,5 @@+module Descript.Sugar.Data.Atom.Inject+  ( module Descript.BasicInj.Data.Atom.Inject+  ) where++import Descript.BasicInj.Data.Atom.Inject
+ src/Descript/Sugar/Data/Atom/Scope.hs view
@@ -0,0 +1,5 @@+module Descript.Sugar.Data.Atom.Scope+  ( module Descript.BasicInj.Data.Atom.Scope+  ) where++import Descript.BasicInj.Data.Atom.Scope
+ src/Descript/Sugar/Data/Import.hs view
@@ -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
+ src/Descript/Sugar/Data/InjFunc.hs view
@@ -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
+ src/Descript/Sugar/Data/Reducer.hs view
@@ -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
+ src/Descript/Sugar/Data/Source.hs view
@@ -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
+ src/Descript/Sugar/Data/Type.hs view
@@ -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
+ src/Descript/Sugar/Data/Value.hs view
@@ -0,0 +1,5 @@+module Descript.Sugar.Data.Value+  ( module Descript.Sugar.Data.Value.Gen+  ) where++import Descript.Sugar.Data.Value.Gen
+ src/Descript/Sugar/Data/Value/Gen.hs view
@@ -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
+ src/Descript/Sugar/Data/Value/In.hs view
@@ -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
+ src/Descript/Sugar/Data/Value/Out.hs view
@@ -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']
+ src/Descript/Sugar/Data/Value/Reg.hs view
@@ -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
+ src/Descript/Sugar/Parse.hs view
@@ -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)
+ src/Descript/Sugar/Parse/Refine.hs view
@@ -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"
+ src/Descript/Sugar/Refine.hs view
@@ -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
+ src/Descript/Sugar/Resolve.hs view
@@ -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
+ test-resources/Import/Basic/List.dscr view
@@ -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[]]]]]]?
+ test-resources/Import/Basic/Num.dscr view
@@ -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]
+ test-resources/Import/Cycle/Blue.dscr view
@@ -0,0 +1,7 @@+module Import>Cycle>Blue+import Import>Cycle>Red{Red}+import Import>Cycle>Color{Next}++Blue[].++Next[color: Blue[]]: Red[]
+ test-resources/Import/Cycle/Color.dscr view
@@ -0,0 +1,3 @@+module Import>Cycle>Color++Next[color].
+ test-resources/Import/Cycle/Green.dscr view
@@ -0,0 +1,7 @@+module Import>Cycle>Green+import Import>Cycle>Color{Next}+import Import>Cycle>Blue{Blue}++Green[].++Next[color: Green[]]: Blue[]
+ test-resources/Import/Cycle/Red.dscr view
@@ -0,0 +1,7 @@+module Import>Cycle>Red+import Import>Cycle>Green{Green}+import Import>Cycle>Color{Next}++Red[].++Next[color: Red[]]: Green[]
+ test-resources/Import/Math/Square.dscr view
@@ -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]
+ test-resources/Import/Math/Vector.dscr view
@@ -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]]+]
+ test-resources/examples/A.dscr view
@@ -0,0 +1,1 @@+80?
+ test-resources/examples/A.out.yaml view
@@ -0,0 +1,1 @@+eval: "80"
+ test-resources/examples/Basic.dscr view
@@ -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]: b<Add //Adding 0 to anything produces 0.+Add[a: Succ[prev], b]: Add[a: a<Add>prev<Succ, b: Succ[prev: b<Add]] //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[+  a: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]+  b: Succ[prev: Succ[prev: Zero[]]]+]? //This encodes (2 + 3). What does it reduce to?
+ test-resources/examples/Basic.out.yaml view
@@ -0,0 +1,18 @@+final?: false+eval: "Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]]]"+refactor:+- label: rename-succ+  action: rename-record Succ Next+- label: rename-add+  action: rename-record Add Zero+  warnings:+  - "line 3, columns 1 to 5: old symbol conflicts with new symbols: Zero"+  - "line 8, columns 8 to 12: old symbol conflicts with new symbols: Zero"+  - "line 14, columns 39 to 43: old symbol conflicts with new symbols: Zero"+  - "line 15, columns 28 to 32: old symbol conflicts with new symbols: Zero"+- label: bad-rename-wrong-args+  action: rename-record Succ Zero Nat+  error: 'expected 2, got 3 for refactor action: rename-record; args: Succ, Zero, Nat'+- label: bad-action+  action: renameq-recordq Succq Nextq+  error: 'unsupported refactor action: renameq-recordq; args: Succq, Nextq'
+ test-resources/examples/Compiled.dscr view
@@ -0,0 +1,26 @@+import Base{Code}++// From Base+App3[left, center, right].++Prgm[statement].+Print[text].++// From Base+App3[left: #String[], center: #String[], right: #String[]]:+  #App3[a: left<App3, b: center<App3, c: right<App3]++Prgm[statement: Code[lang: "C", content: #String[]]]: Code[+  lang: "C"+  content: App3[+    left: "int main(string[] args) {\n  "+    center: statement<Prgm>content<Code+    right: "\n}"+  ]+]+Print[text: #String[]]: Code[+  lang: "C"+  content: App3[left: "println(\"", center: text<Print, right: "\");"]+]++Prgm[statement: Print[text: "Hello world"]]?
+ test-resources/examples/Compiled.out.yaml view
@@ -0,0 +1,6 @@+eval: 'Code[lang: "C", content: "int main(string[] args) {\n  println(\"Hello world\");\n}"]'+compile: |-+  Compiled.c+  > int main(string[] args) {+  >   println("Hello world");+  > }
+ test-resources/examples/Import.Cycle.dscr view
@@ -0,0 +1,6 @@+module Examples>Import+import Import>Cycle>Red++What[].++What[]?
+ test-resources/examples/Import.Cycle.out.yaml view
@@ -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
+ test-resources/examples/Import.ModFunc.Workaround.dscr view
@@ -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[]]+]?
+ test-resources/examples/Import.ModFunc.Workaround.out.yaml view
@@ -0,0 +1,2 @@+final?: false+eval: 'Res[dotProduct: 141, crossProduct: Vec3[x: 0, y: 0, z: 0]]'
+ test-resources/examples/Import.ModFunc.dscr view
@@ -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[]]+]?
+ test-resources/examples/Import.ModFunc.out.yaml view
@@ -0,0 +1,2 @@+final?: false+eval: 'Res[dotProduct: 141, crossProduct: Vec3[x: 0, y: 0, z: 0]]'
+ test-resources/examples/Import.dscr view
@@ -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[]]]]]+]?
+ test-resources/examples/Import.out.yaml view
@@ -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_
+ test-resources/examples/ImportBuiltin.dscr view
@@ -0,0 +1,3 @@+import Base{Add}++Add[left: 3, right: 2]?
+ test-resources/examples/ImportBuiltin.out.yaml view
@@ -0,0 +1,5 @@+# TODO fix and uncomment+# eval: "5"++# TODO fix and remove+valid?: false
+ test-resources/examples/Injected.dscr view
@@ -0,0 +1,14 @@+Add[left, right].+App3[right, left, center].+Result[add, app, weirdRep].++Add[left: #Number[], right: #Number[]]: #Add[a: left<Add, b: right<Add]+App3[center: #String[], left: #String[], right: #String[]]:+  #Append[a: left<App3, b: #Append[a: center<App3, b: right<App3]]++Result[+  add: Add[left: 2, right: 2]+  app: App3[left: "abc", center: "def", right: "ghi"]+  //Does `4 | 7`, but technically `5 | 6` (or `6 | 5` or `7 | 4`) are OK too.+  weirdRep: Add[left: 2 | 3, right: 2 | 4]+]?
+ test-resources/examples/Injected.out.yaml view
@@ -0,0 +1,2 @@+final?: false+eval: 'Result[add: 4, app: "abcdefghi", weirdRep: 7 | 4]'
+ test-resources/examples/Invalid.dscr view
@@ -0,0 +1,17 @@+Zero[].+Succ[prev].+Succ[prev]. //Duplicate record+Add[a, b].+Add[a, c]. //Duplicate record++Add[a, b: Zero[], b]: b<Add //Duplicate property+Add[b: Zeroo[], c]: a<Add //Missing property, extra property, undeclared record+Add[b, b]: c<Add //Duplicate property, undeclared property+Add[]: App[] //Missing property, undeclared record+Add[a, b]: Add[a: b<Add] //Missing property+Add[a: Succ[prev], c]: Add[a: a<Succ>prev<Add, b: Succ[prev: b<Add]] //Undeclared property (switched heads)++Add[+  a: Zero[prev: Zero[prev: Zero[prev: Succ[]]]] //Missing/extra properties (swapped)+  b: Zero[prev: Zero[prev: Succ[]]] //Missing/extra properties (swapped)+]?
+ test-resources/examples/Invalid.out.yaml view
@@ -0,0 +1,28 @@+valid?: false+problems:+- 'line 3, columns 1 to 31: duplicate record declaration: Succ[prev].'+- 'line 5, columns 1 to 30: duplicate record declaration: Add[a, c].'+- 'line 7, columns 19 to 20: record has extra, undeclared properties: b'+- 'line 7, columns 19 to 20: duplicate property: b'+- 'line 8, columns 1 to 19: incomplete record: missing a'+- 'line 8, columns 8 to 13: undeclared record type: Zeroo'+- 'line 8, columns 17 to 18: record has extra, undeclared properties: c'+- 'line 8, columns 21 to 22: nonexistent path: key not in record: a'+- 'line 9, columns 1 to 10: incomplete record: missing a'+- 'line 9, columns 8 to 9: record has extra, undeclared properties: b'+- 'line 9, columns 8 to 9: duplicate property: b'+- 'line 9, columns 12 to 13: nonexistent path: key not in record: c'+- 'line 10, columns 1 to 6: incomplete record: missing a, b'+- 'line 10, columns 8 to 11: undeclared record type: App'+- 'line 11, columns 12 to 44: incomplete record: missing b'+- 'line 12, columns 1 to 22: incomplete record: missing b'+- 'line 12, columns 20 to 21: record has extra, undeclared properties: c'+- 'line 12, columns 33 to 37: nonexistent path: head not in input: Succ'+- 'line 12, columns 62 to 63: nonexistent path: key not in record: b'+- 'line 15, columns 11 to 15: record has extra, undeclared properties: prev'+- 'line 15, columns 22 to 26: record has extra, undeclared properties: prev'+- 'line 15, columns 33 to 37: record has extra, undeclared properties: prev'+- 'line 15, columns 39 to 45: incomplete record: missing prev'+- 'line 16, columns 11 to 15: record has extra, undeclared properties: prev'+- 'line 16, columns 22 to 26: record has extra, undeclared properties: prev'+- 'line 16, columns 28 to 34: incomplete record: missing prev'
+ test-resources/examples/Macros.dscr view
@@ -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: prev<USucc] | Untyped[]++Neg[a: Sub[a: Neg[a], b: Neg[a]]]: Add[+  a: a<Neg>a<Sub>a<Neg+  b: a<Neg>b<Sub>a<Neg+]++---++Add[a: Nat[], b: Nat[]] | Untyped[]: Nat[]+Neg[a: Sub[a: Neg[a: Zero[]], b: Neg[a]]]: a<Neg>b<Sub>a<Neg+Add[a: Succ[prev], b]: Add[a: a<Add>prev<Succ, b: Succ[prev: b<Add]]++UZero[]: Zero[] | Nat[]+USucc[prev: Nat[]]: Nat[]++Add[+  a: Succ[prev: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]] | Untyped[]+  b: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]+] | Untyped[]?
+ test-resources/examples/Macros.out.yaml view
@@ -0,0 +1,50 @@+final?: false+eval: 'Nat[] | Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]]]'+refactor:+- label: singleton-record+  action: |+    reduce+    UZero[]+    Zero[] | Untyped[]+- label: singleton-record-new+  action: |+    reduce+    UZero[]+    UZeroq[]+- label: free-bind+  action: |+    reduce+    Neg[a: Sub[a: Neg[a], b: Neg[a]]]+    Add[a: a<Neg>a<Sub>a<Neg, b: a<Neg>b<Sub>a<Neg]+- label: parse-error+  action: |+    reduce+    Add[a: #Add[a, b]]+    Add[]+  error: |+    parse error: <interactive>: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: a<Add, b: b<Add]+  error: |-+    invalid:+    - line 1, columns 15 to 23: duplicate property: b: b<Add+- label: validation-error-ctx+  action: |+    reduce+    Add[a, b]+    Add[a: a<Add, b: b<Addq]+  error: |-+    invalid:+    - line 1, columns 20 to 24: nonexistent path: head not in input: Addq+- label: free-bind-complex-new+  action: |+    reduce+    Neg[a: Sub[a: Neg[a], b: Neg[a]]]+    Add3[a: a<Neg>a<Sub, b: a<Neg>b<Sub>a<Neg, c: Ignore[a: a<Neg>b<Sub>a<Neg]]
+ test-resources/examples/PrimBuiltin.Bad.dscr view
@@ -0,0 +1,9 @@+import Base{}++// From Base+Add[left, right].++// From Base+Add[left: #Number[], right: #Number[]]: #BAdd[a: left<Add, b: right<Add]++Add[left: 3, right: 2]?
+ test-resources/examples/PrimBuiltin.Bad.out.yaml view
@@ -0,0 +1,3 @@+valid?: false+problems:+- 'line 7, columns 41 to 46: undefined injected function: #BAdd'
+ test-resources/examples/PrimBuiltin.dscr view
@@ -0,0 +1,9 @@+import Base{}++// From Base+Add[left, right].++// From Base+Add[left: #Number[], right: #Number[]]: #Add[a: left<Add, b: right<Add]++Add[left: 3, right: 2]?
+ test-resources/examples/PrimBuiltin.out.yaml view
@@ -0,0 +1,1 @@+eval: "5"
+ test-resources/examples/Rep.dscr view
@@ -0,0 +1,23 @@+Air[].+Foo[contents].+Bar[contents].+Pack[foos, bars].+Organize[a].++Organize[a: Foo[contents]]: Pack[foos: a<Organize, bars: Air[]]+Organize[a: Bar[contents]]: Pack[foos: Air[], bars: a<Organize]++/*Organize[+  a:+    Foo[contents: Bar[contents: Air[]]] |+    Bar[contents: Foo[contents: Air[]]]+] => 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[]]]+]?
+ test-resources/examples/Rep.out.yaml view
@@ -0,0 +1,2 @@+final?: false+eval: "Pack[foos: Foo[contents: Bar[contents: Air[]]] | Air[], bars: Air[] | Bar[contents: Foo[contents: Air[]]]]"
+ test-resources/examples/Types.Exp.dscr view
@@ -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]: b<Add //Adding 0 to anything produces 0.+Add[a: Succ[prev], b]: Add[a: a<Add>prev<Succ, b: Succ[prev: b<Add]] //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?
+ test-resources/examples/Types.Exp.out.yaml view
@@ -0,0 +1,2 @@+final?: false+eval: "Nat[] | Succ[prev: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]]]"
+ test-resources/examples/Types.Fun.dscr view
@@ -0,0 +1,24 @@+//Types by functions. Not "hacky".++//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.+Nat[]. //A natural number - in other languages this would be a type.+Type[a]. //Get the type of a value.+TypeSucc[a].++//Reducers. Reducers are like function implementations. These reducers "implement" Add.+Add[a: Zero[], b]: b<Add //Adding 0 to anything produces 0.+Add[a: Succ[prev], b]: Add[a: a<Add>prev<Succ, b: Succ[prev: b<Add]] //Adding 1 + n to anything produces n + (1 + anything).+Type[a: Zero[]]: Nat[]+Type[a: Succ[prev]]: TypeSucc[a: Type[a: a<Type>prev<Succ]]+TypeSucc[a: Nat[]]: Nat[]++//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.+Type[a: Add[+  a: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]+  b: Succ[prev: Succ[prev: Zero[]]]+]]? //What does this reduce to?
+ test-resources/examples/Types.Fun.out.yaml view
@@ -0,0 +1,2 @@+final?: false+eval: "Nat[]"
+ test-resources/examples/Types.Imp.dscr view
@@ -0,0 +1,27 @@+//Implicit types by alternate representation. "Hacky" but easy.+//Infinitely recurses using the current interpreter - need a special+//interpreter which handles values which reduce to themselves.++//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.+Nat[]. //A natural number - in other languages this would be a type.++//Reducers. Reducers are like function implementations. These reducers "implement" Add.+Add[a: Zero[], b]: b<Add //Adding 0 to anything produces 0.+Add[a: Succ[prev], b]: Add[a: a<Add>prev<Succ, b: Succ[prev: b<Add]] //Adding 1 + n to anything produces n + (1 + anything).+Add[a: Nat[], b: Nat[]]: Add[a: Nat[], b: Nat[]] | Nat[] //Adding naturals produces a natural.++//More reducers. These reducers aren't really function implementations.+//In other languages, these would assign the types to the instances.+Zero[]: Zero[] | Nat[] //Zero is a natural.+Succ[prev: Nat[]]: Succ[prev: Nat[]] | Nat[] //1 + n is a natural if n is a natural.++//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[]]]]+  b: Succ[prev: Succ[prev: Zero[]]]+]? //What does this reduce to?
+ test-resources/examples/Types.Imp.out.yaml view
@@ -0,0 +1,2 @@+terminates?: false+final?: false
+ test-resources/examples/Types.New+.dscr view
@@ -0,0 +1,53 @@+//'Types.New' with property key syntax sugar.+//Uses ambiguous matches - might change in future.+//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+Zero[].+Succ[prev].+Add[a, b].+Fib[a].+Fib3[a].++//Types+Nat[].++//Type signatures+Add[Type[Nat[]], Type[Nat[]]]: Type[Nat[]]+Fib[Type[Nat[]]]: Type[Nat[]]+Fib3[Type[Nat[]]]: Type[Nat[]]++//Untyped functions+Add[Value[Zero[]], Value[a]]: Value[b>a]+Add[Value[Succ[prev]], Value[a]]: Add[+  Value[a>a>prev]+  Value[Succ[prev: b<Add>a<Value]]+]+Fib[Value[Zero[]]]: Value[Succ[Zero[]]]+Fib[Value[Succ[Zero[]]]]: Value[Succ[Zero[]]]+Fib[Value[Succ[Succ[prev]]]]: Add[+  Fib[Value[a>a>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]]+]?
+ test-resources/examples/Types.New+.out.yaml view
@@ -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]]'
+ test-resources/examples/Types.New.Adv.dscr view
@@ -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]]: b<Add+Add[a: Value[a: Succ[prev]], b: Value[a]]: Add[+  a: Value[a: a<Add>a<Value>prev<Succ]+  b: Value[a: Succ[prev: b<Add>a<Value]]+]+Sub1[a: Value[a: Zero[]]]: Value[a: None[]]+Sub1[a: Value[a: Succ[prev]]]: Value[a: Some[a: a<Sub1>a<Value>prev<Succ]]+Sub2[a: Value[a: Zero[]]]: Value[a: None[]]+Sub2[a: Value[a: Succ[prev: Zero[]]]]: Value[a: None[]]+Sub2[a: Value[a: Succ[prev: Succ[prev]]]]:+  Value[a: Some[a: a<Sub2>a<Value>prev<Succ>prev<Succ]]+Fib[a: Value[a]]: Fib_[a: a<Fib, sub1: Sub1[a: a<Fib], sub2: Sub2[a: a<Fib]]+Fib_[a: Value[a], sub1: Value[a: None[]], sub2]: One[a: a<Fib_]+Fib_[a: Value[a], sub1: Value[a: Some[a]], sub2: Value[a: None[]]]: One[a: a<Fib_]+Fib_[a: Value[a], sub1: Value[a: Some[a]], sub2: Value[a: Some[a]]]: Add[+  a: Fib[a: Value[a: sub1<Fib_>a<Value>a<Some]]+  b: Fib[a: Value[a: sub2<Fib_>a<Value>a<Some]]+]+Fib3[a: Value[a]]: Fib[a: Fib[a: Fib[a: a<Fib3]]]++//Alternate number encoding+One[a: Value[a: #Number[]]]: Value[a: 1]+Add[a: Value[a: #Number[]], b: Value[a: #Number[]]]:+  Value[a: #Add[a: a<Add>a<Value, b: b<Add>a<Value]]+Sub1[a: Value[a: #Number[]]]:+  Sub_[a: a<Sub1, sub: 1, cmp: #Compare[a: a<Sub1>a<Value, b: 1]]+Sub2[a: Value[a: #Number[]]]:+  Sub_[a: a<Sub2, sub: 2, cmp: #Compare[a: a<Sub2>a<Value, b: 2]]+Sub_[a: Value[a], sub, cmp: 1]: Value[a: Some[a: #Subtract[a: a<Sub_>a<Value, b: sub<Sub_]]]+Sub_[a: Value[a], sub, cmp: 0]: Value[a: Some[a: #Subtract[a: a<Sub_>a<Value, b: sub<Sub_]]]+Sub_[a: Value[a], sub, cmp: -1]: Value[a: None[]]++//Query+Res[+  rec: Fib3[a: Type[a: Nat[]] | Value[a: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]]]]+  prim: Fib3[a: Type[a: Nat[]] | Value[a: 4]]+]?
+ test-resources/examples/Types.New.Adv.out.yaml view
@@ -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]]'
+ test-resources/examples/Types.New.dscr view
@@ -0,0 +1,54 @@+//Uses ambiguous matches - might change in future.+//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+Zero[].+Succ[prev].+Add[a, b].+Fib[a].+Fib3[a].++//Types+Nat[].++//Type signatures+Add[a: Type[a: Nat[]], b: Type[a: Nat[]]]: Type[a: Nat[]]+Fib[a: Type[a: Nat[]]]: Type[a: Nat[]]+Fib3[a: Type[a: Nat[]]]: Type[a: Nat[]]++//Untyped functions+Add[a: Value[a: Zero[]], b: Value[a]]:+  Value[a: b<Add>a<Value]+Add[a: Value[a: Succ[prev]], b: Value[a]]: Add[+  a: Value[a: a<Add>a<Value>prev<Succ]+  b: Value[a: Succ[prev: b<Add>a<Value]]+]+Fib[a: Value[a: Zero[]]]: Value[a: Succ[prev: Zero[]]]+Fib[a: Value[a: Succ[prev: Zero[]]]]: Value[a: Succ[prev: Zero[]]]+Fib[a: Value[a: Succ[prev: Succ[prev]]]]: Add[+  a: Fib[a: Value[a: a<Fib>a<Value>prev<Succ]]+  b: Fib[a: Value[a: a<Fib>a<Value>prev<Succ>prev<Succ]]+]+Fib3[a: Value[a]]: Fib[a: Fib[a: Fib[a: Value[a: a<Fib3>a<Value]]]]++//Alternate number representation+Add[a: Value[a: #Number[]], b: Value[a: #Number[]]]:+  Value[a: #Add[a: a<Add>a<Value, b: b<Add>a<Value]]+Fib[a: Value[a: 0]]: Value[a: 1]+Fib[a: Value[a: 1]]: Value[a: 1]+Fib[a: Value[a: #Number[]]]: Add[+  a: Fib[a: Value[a: #Add[a: a<Fib>a<Value, b: -1]]]+  b: Fib[a: Value[a: #Add[a: a<Fib>a<Value, b: -2]]]+]++//Query+Res[+  rec: Fib3[a: Type[a: Nat[]] | Value[a: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]]]]+  prim: Fib3[a: Type[a: Nat[]] | Value[a: 4]]+]?
+ test-resources/examples/Types.New.out.yaml view
@@ -0,0 +1,4 @@+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]]'+refactor:+- rename-property Fib a b
+ test-resources/refactors/Basic.rename-add.dscr view
@@ -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.+Zero[a, b]. //a + b - in other languages this would be a function.++//Reducers. Reducers are like function implementations. These reducers "implement" Add.+Zero[a: Zero[], b]: b<Zero //Adding 0 to anything produces 0.+Zero[a: Succ[prev], b]: Zero[a: a<Zero>prev<Succ, b: Succ[prev: b<Zero]] //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.+Zero[+  a: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]+  b: Succ[prev: Succ[prev: Zero[]]]+]? //This encodes (2 + 3). What does it reduce to?
+ test-resources/refactors/Basic.rename-succ.dscr view
@@ -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.+Next[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<Add //Adding 0 to anything produces 0.+Add[a: Next[prev], b]: Add[a: a<Add>prev<Next, b: Next[prev: b<Add]] //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[+  a: Next[prev: Next[prev: Next[prev: Zero[]]]]+  b: Next[prev: Next[prev: Zero[]]]+]? //This encodes (2 + 3). What does it reduce to?
+ test-resources/refactors/Import.rename-record.dscr view
@@ -0,0 +1,10 @@+module Examples>Import+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[]]]]]+]?
+ test-resources/refactors/Macros.free-bind-complex-new.dscr view
@@ -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: prev<USucc] | Untyped[]++Add3[a: Neg[a], b, c: Ignore[a]]: Add[+  a: a<Add3>a<Neg+  b: c<Add3>a<Ignore | b<Add3+]++---++Add[a: Nat[], b: Nat[]] | Untyped[]: Nat[]+Add3[a: Neg[a: Zero[]], b, c: Ignore[a]]: c<Add3>a<Ignore | b<Add3+Add[a: Succ[prev], b]: Add[a: a<Add>prev<Succ, b: Succ[prev: b<Add]]++UZero[]: Zero[] | Nat[]+USucc[prev: Nat[]]: Nat[]++Add[+  a: Succ[prev: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]] | Untyped[]+  b: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]+] | Untyped[]?
+ test-resources/refactors/Macros.free-bind.dscr view
@@ -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: prev<USucc] | Untyped[]++Add[a, b]: Add[+  a: a<Add+  b: b<Add+]++---++Add[a: Nat[], b: Nat[]] | Untyped[]: Nat[]+Add[a: Zero[], b]: b<Add+Add[a: Succ[prev], b]: Add[a: a<Add>prev<Succ, b: Succ[prev: b<Add]]++UZero[]: Zero[] | Nat[]+USucc[prev: Nat[]]: Nat[]++Add[+  a: Succ[prev: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]] | Untyped[]+  b: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]+] | Untyped[]?
+ test-resources/refactors/Macros.singleton-record-new.dscr view
@@ -0,0 +1,35 @@+//Macros++UZero[].+USucc[prev].+Sub[a, b].+Neg[a].++Nat[].+Untyped[].+Zero[].+Succ[prev].+Add[a, b].++//Macros+UZeroq[]: Zero[] | Untyped[]+USucc[prev]: Succ[prev: prev<USucc] | Untyped[]++Neg[a: Sub[a: Neg[a], b: Neg[a]]]: Add[+  a: a<Neg>a<Sub>a<Neg+  b: a<Neg>b<Sub>a<Neg+]++---++Add[a: Nat[], b: Nat[]] | Untyped[]: Nat[]+Neg[a: Sub[a: Neg[a: Zero[]], b: Neg[a]]]: a<Neg>b<Sub>a<Neg+Add[a: Succ[prev], b]: Add[a: a<Add>prev<Succ, b: Succ[prev: b<Add]]++UZeroq[]: Zero[] | Nat[]+USucc[prev: Nat[]]: Nat[]++Add[+  a: Succ[prev: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]] | Untyped[]+  b: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]+] | Untyped[]?
+ test-resources/refactors/Macros.singleton-record.dscr view
@@ -0,0 +1,35 @@+//Macros++UZero[].+USucc[prev].+Sub[a, b].+Neg[a].++Nat[].+Untyped[].+Zero[].+Succ[prev].+Add[a, b].++//Macros+Untyped[] | Zero[]: Zero[] | Untyped[]+USucc[prev]: Succ[prev: prev<USucc] | Untyped[]++Neg[a: Sub[a: Neg[a], b: Neg[a]]]: Add[+  a: a<Neg>a<Sub>a<Neg+  b: a<Neg>b<Sub>a<Neg+]++---++Add[a: Nat[], b: Nat[]] | Untyped[]: Nat[]+Neg[a: Sub[a: Neg[a: Zero[]], b: Neg[a]]]: a<Neg>b<Sub>a<Neg+Add[a: Succ[prev], b]: Add[a: a<Add>prev<Succ, b: Succ[prev: b<Add]]++Untyped[] | Zero[]: Zero[] | Nat[]+USucc[prev: Nat[]]: Nat[]++Add[+  a: Succ[prev: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]] | Untyped[]+  b: Succ[prev: Succ[prev: Zero[] | Untyped[]] | Untyped[]] | Untyped[]+] | Untyped[]?
+ test-resources/refactors/Types.New.rename-property.dscr view
@@ -0,0 +1,54 @@+//Uses ambiguous matches - might change in future.+//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+Zero[].+Succ[prev].+Add[a, b].+Fib[b].+Fib3[a].++//Types+Nat[].++//Type signatures+Add[a: Type[a: Nat[]], b: Type[a: Nat[]]]: Type[a: Nat[]]+Fib[b: Type[a: Nat[]]]: Type[a: Nat[]]+Fib3[a: Type[a: Nat[]]]: Type[a: Nat[]]++//Untyped functions+Add[a: Value[a: Zero[]], b: Value[a]]:+  Value[a: b<Add>a<Value]+Add[a: Value[a: Succ[prev]], b: Value[a]]: Add[+  a: Value[a: a<Add>a<Value>prev<Succ]+  b: Value[a: Succ[prev: b<Add>a<Value]]+]+Fib[b: Value[a: Zero[]]]: Value[a: Succ[prev: Zero[]]]+Fib[b: Value[a: Succ[prev: Zero[]]]]: Value[a: Succ[prev: Zero[]]]+Fib[b: Value[a: Succ[prev: Succ[prev]]]]: Add[+  a: Fib[b: Value[a: b<Fib>a<Value>prev<Succ]]+  b: Fib[b: Value[a: b<Fib>a<Value>prev<Succ>prev<Succ]]+]+Fib3[a: Value[a]]: Fib[b: Fib[b: Fib[b: Value[a: a<Fib3>a<Value]]]]++//Alternate number representation+Add[a: Value[a: #Number[]], b: Value[a: #Number[]]]:+  Value[a: #Add[a: a<Add>a<Value, b: b<Add>a<Value]]+Fib[b: Value[a: 0]]: Value[a: 1]+Fib[b: Value[a: 1]]: Value[a: 1]+Fib[b: Value[a: #Number[]]]: Add[+  a: Fib[b: Value[a: #Add[a: b<Fib>a<Value, b: -1]]]+  b: Fib[b: Value[a: #Add[a: b<Fib>a<Value, b: -2]]]+]++//Query+Res[+  rec: Fib3[a: Type[a: Nat[]] | Value[a: Succ[prev: Succ[prev: Succ[prev: Succ[prev: Zero[]]]]]]]+  prim: Fib3[a: Type[a: Nat[]] | Value[a: 4]]+]?
+ test/BuildSpec.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-}++-- | Tests all parts of building.+module BuildSpec+       ( spec ) where++import Core.Test+import Descript+import qualified Descript.BasicInj.Data.Value.Reg as BasicInj.Reg+import qualified Descript.BasicInj as BasicInj+import qualified Descript.Sugar as Sugar+import System.FilePath hiding (isValid)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Control.Monad+import Control.Concurrent.MVar++type VarMap k v = Map k (MVar (Maybe v))++examplesDir :: FilePath+examplesDir = "test-resources/examples/"++refactorsDir :: FilePath+refactorsDir = "test-resources/refactors/"++testDepResolver :: DepResolver IO+testDepResolver = defaultResolver examplesDir++getExampleFiles :: IO [TestFile]+getExampleFiles = loadFilesInDir examplesDir++getRefactorText :: String -> 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
+ test/Core/Test.hs view
@@ -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)
+ test/Core/Test/Descript.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ test/Core/Test/Descript/Spec.hs view
@@ -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
+ test/Core/Test/Descript/TestFile.hs view
@@ -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
+ test/Core/Test/HUnit.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}