From 209365c9f345bf7219fcd4daca29dd91598db2df Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 29 Sep 2024 19:20:25 +0300 Subject: [PATCH 001/310] implement first version of AST and corresponding print function Signed-off-by: Ksenia Kotelnikova --- fsharp_active_patterns/.envrc | 3 + fsharp_active_patterns/.gitignore | 6 + fsharp_active_patterns/.ocamlformat | 2 + fsharp_active_patterns/.zanuda | 1 + fsharp_active_patterns/COPYING | 674 ++++++++++++++++++ fsharp_active_patterns/COPYING.CC0 | 121 ++++ fsharp_active_patterns/COPYING.LESSER | 165 +++++ fsharp_active_patterns/bin/dune | 4 + fsharp_active_patterns/bin/exec.ml | 35 + fsharp_active_patterns/dune | 16 + fsharp_active_patterns/dune-project | 35 + .../fsharp_active_patterns.opam | 36 + fsharp_active_patterns/lib/AST.ml | 31 + fsharp_active_patterns/lib/dune | 4 + fsharp_active_patterns/lib/printAST.ml | 62 ++ 15 files changed, 1195 insertions(+) create mode 100644 fsharp_active_patterns/.envrc create mode 100644 fsharp_active_patterns/.gitignore create mode 100644 fsharp_active_patterns/.ocamlformat create mode 100644 fsharp_active_patterns/.zanuda create mode 100644 fsharp_active_patterns/COPYING create mode 100644 fsharp_active_patterns/COPYING.CC0 create mode 100644 fsharp_active_patterns/COPYING.LESSER create mode 100644 fsharp_active_patterns/bin/dune create mode 100644 fsharp_active_patterns/bin/exec.ml create mode 100644 fsharp_active_patterns/dune create mode 100644 fsharp_active_patterns/dune-project create mode 100644 fsharp_active_patterns/fsharp_active_patterns.opam create mode 100644 fsharp_active_patterns/lib/AST.ml create mode 100644 fsharp_active_patterns/lib/dune create mode 100644 fsharp_active_patterns/lib/printAST.ml diff --git a/fsharp_active_patterns/.envrc b/fsharp_active_patterns/.envrc new file mode 100644 index 000000000..e6bd6786d --- /dev/null +++ b/fsharp_active_patterns/.envrc @@ -0,0 +1,3 @@ +export OPAMSWITCH=4.14.2+flambda +eval $(opam env) + diff --git a/fsharp_active_patterns/.gitignore b/fsharp_active_patterns/.gitignore new file mode 100644 index 000000000..7102a822c --- /dev/null +++ b/fsharp_active_patterns/.gitignore @@ -0,0 +1,6 @@ +_build +_coverage +/_esy +/node_modules +/esy.lock +/.melange.eobjs diff --git a/fsharp_active_patterns/.ocamlformat b/fsharp_active_patterns/.ocamlformat new file mode 100644 index 000000000..97f970802 --- /dev/null +++ b/fsharp_active_patterns/.ocamlformat @@ -0,0 +1,2 @@ +profile=janestreet +version=0.26.2 diff --git a/fsharp_active_patterns/.zanuda b/fsharp_active_patterns/.zanuda new file mode 100644 index 000000000..43cfa2792 --- /dev/null +++ b/fsharp_active_patterns/.zanuda @@ -0,0 +1 @@ +forward mutability_check ignore exec.ml diff --git a/fsharp_active_patterns/COPYING b/fsharp_active_patterns/COPYING new file mode 100644 index 000000000..f288702d2 --- /dev/null +++ b/fsharp_active_patterns/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/fsharp_active_patterns/COPYING.CC0 b/fsharp_active_patterns/COPYING.CC0 new file mode 100644 index 000000000..0e259d42c --- /dev/null +++ b/fsharp_active_patterns/COPYING.CC0 @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/fsharp_active_patterns/COPYING.LESSER b/fsharp_active_patterns/COPYING.LESSER new file mode 100644 index 000000000..0a041280b --- /dev/null +++ b/fsharp_active_patterns/COPYING.LESSER @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/fsharp_active_patterns/bin/dune b/fsharp_active_patterns/bin/dune new file mode 100644 index 000000000..53a7b565d --- /dev/null +++ b/fsharp_active_patterns/bin/dune @@ -0,0 +1,4 @@ +(executable + (public_name exec) + (name exec) + (libraries fsharp_active_patterns_lib)) diff --git a/fsharp_active_patterns/bin/exec.ml b/fsharp_active_patterns/bin/exec.ml new file mode 100644 index 000000000..6921c4907 --- /dev/null +++ b/fsharp_active_patterns/bin/exec.ml @@ -0,0 +1,35 @@ +(** Copyright 2021-2024, Ksenia Kotelnikova, Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Fsharp_active_patterns_lib.AST +open Fsharp_active_patterns_lib.PrintAST + +let () = + let factorial = + Function + ( Some "factorial" + , [ Variable (Ident "n") ] + , [ If_then_else + ( Bin_expr + ( Logical_or + , Bin_expr (Binary_equal, Variable (Ident "n"), Const 0.0) + , Bin_expr (Binary_equal, Variable (Ident "n"), Const 1.0) ) + , [ Const 1.0 ] + , [ Bin_expr + ( Binary_multiply + , Variable (Ident "n") + , Function_call + ( "factorial" + , [ Bin_expr (Binary_minus, Variable (Ident "n"), Const 1.0) ] ) ) + ] ) + ] ) + in + let program = + [ Let (Ident "a", Const 10.0) + ; factorial + ; Function_call ("factorial", [ Variable (Ident "a") ]) + ] + in + List.iter (print_expr 0) program +;; diff --git a/fsharp_active_patterns/dune b/fsharp_active_patterns/dune new file mode 100644 index 000000000..0ef8774ec --- /dev/null +++ b/fsharp_active_patterns/dune @@ -0,0 +1,16 @@ +(env + (dev + (flags + (:standard -alert @deprecated -warn-error -A -w -3-9-32-34-58))) + (release + (flags + (:standard -alert @deprecated -warn-error +A -w +A-4-40-42-44-70)))) + +; (executable +; (name REPL) +; (public_name REPL) +; (modules REPL) +; (libraries lambda_lib stdio)) + +; (cram +; (deps ./REPL.exe %{bin:REPL})) diff --git a/fsharp_active_patterns/dune-project b/fsharp_active_patterns/dune-project new file mode 100644 index 000000000..a1484317a --- /dev/null +++ b/fsharp_active_patterns/dune-project @@ -0,0 +1,35 @@ +(lang dune 3.7) + +(generate_opam_files true) + +(cram enable) + +(license LGPL-3.0-or-later) + +(authors "Ksenia Kotelnikova, Gleb Nasretdinov") + +(maintainers "Ksenia Kotelnikova, Gleb Nasretdinov") + +(bug_reports "https://github.com/Ycyken/fp2024") + +(homepage "https://github.com/Ycyken/fp2024") + +(package + (name fsharp_active_patterns) + (synopsis "An interpreter for F# with active patterns") + (description + "FIX LATER. A longer description, for example, which are the most interesing features being supported, etc.") + (documentation "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda") + (version 0.1) + (depends + dune + angstrom + (ppx_inline_test :with-test) + ppx_expect + ppx_deriving + bisect_ppx + (odoc :with-doc) + (ocamlformat :build) + ; base + ; After adding dependencies to 'dune' files and the same dependecies here too + )) \ No newline at end of file diff --git a/fsharp_active_patterns/fsharp_active_patterns.opam b/fsharp_active_patterns/fsharp_active_patterns.opam new file mode 100644 index 000000000..43ba3226a --- /dev/null +++ b/fsharp_active_patterns/fsharp_active_patterns.opam @@ -0,0 +1,36 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "0.1" +synopsis: "An interpreter for F# with active patterns" +description: + "FIX LATER. A longer description, for example, which are the most interesing features being supported, etc." +maintainer: ["Ksenia Kotelnikova, Gleb Nasretdinov"] +authors: ["Ksenia Kotelnikova, Gleb Nasretdinov"] +license: "LGPL-3.0-or-later" +homepage: "https://github.com/Ycyken/fp2024" +doc: "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda" +bug-reports: "https://github.com/Ycyken/fp2024" +depends: [ + "dune" {>= "3.7"} + "angstrom" + "ppx_inline_test" {with-test} + "ppx_expect" + "ppx_deriving" + "bisect_ppx" + "odoc" {with-doc} + "ocamlformat" {build} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] diff --git a/fsharp_active_patterns/lib/AST.ml b/fsharp_active_patterns/lib/AST.ml new file mode 100644 index 000000000..dc77f6289 --- /dev/null +++ b/fsharp_active_patterns/lib/AST.ml @@ -0,0 +1,31 @@ +(** Copyright 2021-2024, Ksenia Kotelnikova, Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +type ident = Ident of string + +type binary_operator = + | Binary_equal + | Binary_unequal + | Binary_less + | Binary_less_or_equal + | Binary_greater + | Binary_greater_or_equal + | Binary_plus + | Binary_minus + | Binary_multiply + | Logical_or + | Logical_and + | Binary_divide + | Binary_or_bitwise + | Binary_xor_bitwise + | Binary_and_bitwise + +type expr = + | Const of float + | Variable of (*name*) ident + | Bin_expr of (*oper*) binary_operator * (*fst*) expr * (*snd*) expr + | If_then_else of (*condition*) expr * (*then body*) expr list * (*else body*) expr list + | Function of (*name*) string option * (*args*) expr list * (*body*) expr list + | Function_call of (*name*) string * (*args*) expr list + | Let of (*name*) ident * (*value*) expr (* * (*body*) expr list *) diff --git a/fsharp_active_patterns/lib/dune b/fsharp_active_patterns/lib/dune new file mode 100644 index 000000000..3bdcfaa3b --- /dev/null +++ b/fsharp_active_patterns/lib/dune @@ -0,0 +1,4 @@ +(library + (name fsharp_active_patterns_lib) + (public_name fsharp_active_patterns.Lib) + (modules AST PrintAST)) diff --git a/fsharp_active_patterns/lib/printAST.ml b/fsharp_active_patterns/lib/printAST.ml new file mode 100644 index 000000000..6f8706649 --- /dev/null +++ b/fsharp_active_patterns/lib/printAST.ml @@ -0,0 +1,62 @@ +(** Copyright 2021-2024, Ksenia Kotelnikova, Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open AST + +let rec print_expr indent = function + | Const f -> Printf.printf "%s| Const(%f)\n" (String.make indent '-') f + | Variable (Ident name) -> + Printf.printf "%s| Variable(%s)\n" (String.make indent '-') name + | Bin_expr (op, left, right) -> + Printf.printf "%s| Binary expr(\n" (String.make indent '-'); + print_bin_op indent op; + print_expr (indent + 2) left; + print_expr (indent + 2) right + | If_then_else (cond, then_body, else_body) -> + Printf.printf "%s| If Then Else(\n" (String.make indent '-'); + Printf.printf "%sCONDITION\n" (String.make indent ' '); + print_expr (indent + 2) cond; + Printf.printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 4)) then_body; + Printf.printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 4)) else_body + | Function (name, args, body) -> + Printf.printf + "%s| Function(%s):\n" + (String.make indent '-') + (match name with + | Some n -> n + | None -> "Anonymous"); + Printf.printf "%sARGS\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 4)) args; + Printf.printf "%sBODY\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 4)) body + | Function_call (name, args) -> + Printf.printf "%s| Function Call(%s):\n" (String.make indent '-') name; + List.iter (print_expr (indent + 2)) args + | Let (Ident name, value) -> + Printf.printf "%s| Let %s =\n" (String.make indent '-') name; + print_expr (indent + 2) value + +and print_bin_op indent = function + | Binary_equal -> Printf.printf "%s| Binary Equal\n" (String.make indent '-') + | Binary_unequal -> Printf.printf "%s| Binary Unequal\n" (String.make indent '-') + | Binary_less -> Printf.printf "%s| Binary Less\n" (String.make indent '-') + | Binary_less_or_equal -> + Printf.printf "%s| Binary Less Or Equal\n" (String.make indent ' ') + | Binary_greater -> Printf.printf "%s| Binary Greater\n" (String.make indent '-') + | Binary_greater_or_equal -> + Printf.printf "%s| Binary Greater Or Equal\n" (String.make indent '-') + | Binary_plus -> Printf.printf "%s| Binary Plus\n" (String.make indent '-') + | Binary_minus -> Printf.printf "%s| Binary Minus\n" (String.make indent '-') + | Binary_multiply -> Printf.printf "%s| Binary Multiply\n" (String.make indent '-') + | Logical_or -> Printf.printf "%s| Logical Or\n" (String.make indent '-') + | Logical_and -> Printf.printf "%s| Logical And\n" (String.make indent '-') + | Binary_divide -> Printf.printf "%s| Binary Divide\n" (String.make indent '-') + | Binary_or_bitwise -> Printf.printf "%s| Binary Or Bitwise\n" (String.make indent '-') + | Binary_xor_bitwise -> + Printf.printf "%s| Binary Xor Bitwise\n" (String.make indent '-') + | Binary_and_bitwise -> + Printf.printf "%s| Binary And Bitwise\n" (String.make indent '-') +;; From d947520a3291277cbe6cc5ad60b97f8fc52a9e90 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 30 Sep 2024 17:49:20 +0300 Subject: [PATCH 002/310] fix: change license date to correct year Signed-off-by: Ksenia Kotelnikova --- fsharp_active_patterns/bin/exec.ml | 2 +- fsharp_active_patterns/lib/AST.ml | 2 +- fsharp_active_patterns/lib/printAST.ml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/fsharp_active_patterns/bin/exec.ml b/fsharp_active_patterns/bin/exec.ml index 6921c4907..cd8733fc4 100644 --- a/fsharp_active_patterns/bin/exec.ml +++ b/fsharp_active_patterns/bin/exec.ml @@ -1,4 +1,4 @@ -(** Copyright 2021-2024, Ksenia Kotelnikova, Gleb Nasretdinov *) +(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/fsharp_active_patterns/lib/AST.ml b/fsharp_active_patterns/lib/AST.ml index dc77f6289..31fadc533 100644 --- a/fsharp_active_patterns/lib/AST.ml +++ b/fsharp_active_patterns/lib/AST.ml @@ -1,4 +1,4 @@ -(** Copyright 2021-2024, Ksenia Kotelnikova, Gleb Nasretdinov *) +(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/fsharp_active_patterns/lib/printAST.ml b/fsharp_active_patterns/lib/printAST.ml index 6f8706649..3c433b98d 100644 --- a/fsharp_active_patterns/lib/printAST.ml +++ b/fsharp_active_patterns/lib/printAST.ml @@ -1,4 +1,4 @@ -(** Copyright 2021-2024, Ksenia Kotelnikova, Gleb Nasretdinov *) +(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) From fac582b11eac33bd1f1d8f0c369d0bd1f142854a Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 30 Sep 2024 17:52:22 +0300 Subject: [PATCH 003/310] fix: delete comments from dune files Signed-off-by: Ksenia Kotelnikova --- fsharp_active_patterns/dune | 8 -------- fsharp_active_patterns/dune-project | 2 -- 2 files changed, 10 deletions(-) diff --git a/fsharp_active_patterns/dune b/fsharp_active_patterns/dune index 0ef8774ec..4189d77b9 100644 --- a/fsharp_active_patterns/dune +++ b/fsharp_active_patterns/dune @@ -6,11 +6,3 @@ (flags (:standard -alert @deprecated -warn-error +A -w +A-4-40-42-44-70)))) -; (executable -; (name REPL) -; (public_name REPL) -; (modules REPL) -; (libraries lambda_lib stdio)) - -; (cram -; (deps ./REPL.exe %{bin:REPL})) diff --git a/fsharp_active_patterns/dune-project b/fsharp_active_patterns/dune-project index a1484317a..93e8bfb86 100644 --- a/fsharp_active_patterns/dune-project +++ b/fsharp_active_patterns/dune-project @@ -30,6 +30,4 @@ bisect_ppx (odoc :with-doc) (ocamlformat :build) - ; base - ; After adding dependencies to 'dune' files and the same dependecies here too )) \ No newline at end of file From 475e47414a7ec1cee3de41558121db7f924261db Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 30 Sep 2024 19:15:16 +0300 Subject: [PATCH 004/310] fix: change directory name to camel case and change public name of lib accordingly Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/.envrc | 3 + FSharpActivePatterns/.gitignore | 6 + FSharpActivePatterns/.ocamlformat | 2 + FSharpActivePatterns/.zanuda | 1 + FSharpActivePatterns/COPYING | 674 ++++++++++++++++++ FSharpActivePatterns/COPYING.CC0 | 121 ++++ FSharpActivePatterns/COPYING.LESSER | 165 +++++ .../FSharpActivePatterns.opam | 36 + FSharpActivePatterns/bin/dune | 4 + FSharpActivePatterns/bin/exec.ml | 35 + FSharpActivePatterns/dune | 8 + FSharpActivePatterns/dune-project | 33 + FSharpActivePatterns/lib/AST.ml | 31 + FSharpActivePatterns/lib/dune | 4 + FSharpActivePatterns/lib/printAST.ml | 62 ++ 15 files changed, 1185 insertions(+) create mode 100644 FSharpActivePatterns/.envrc create mode 100644 FSharpActivePatterns/.gitignore create mode 100644 FSharpActivePatterns/.ocamlformat create mode 100644 FSharpActivePatterns/.zanuda create mode 100644 FSharpActivePatterns/COPYING create mode 100644 FSharpActivePatterns/COPYING.CC0 create mode 100644 FSharpActivePatterns/COPYING.LESSER create mode 100644 FSharpActivePatterns/FSharpActivePatterns.opam create mode 100644 FSharpActivePatterns/bin/dune create mode 100644 FSharpActivePatterns/bin/exec.ml create mode 100644 FSharpActivePatterns/dune create mode 100644 FSharpActivePatterns/dune-project create mode 100644 FSharpActivePatterns/lib/AST.ml create mode 100644 FSharpActivePatterns/lib/dune create mode 100644 FSharpActivePatterns/lib/printAST.ml diff --git a/FSharpActivePatterns/.envrc b/FSharpActivePatterns/.envrc new file mode 100644 index 000000000..e6bd6786d --- /dev/null +++ b/FSharpActivePatterns/.envrc @@ -0,0 +1,3 @@ +export OPAMSWITCH=4.14.2+flambda +eval $(opam env) + diff --git a/FSharpActivePatterns/.gitignore b/FSharpActivePatterns/.gitignore new file mode 100644 index 000000000..7102a822c --- /dev/null +++ b/FSharpActivePatterns/.gitignore @@ -0,0 +1,6 @@ +_build +_coverage +/_esy +/node_modules +/esy.lock +/.melange.eobjs diff --git a/FSharpActivePatterns/.ocamlformat b/FSharpActivePatterns/.ocamlformat new file mode 100644 index 000000000..97f970802 --- /dev/null +++ b/FSharpActivePatterns/.ocamlformat @@ -0,0 +1,2 @@ +profile=janestreet +version=0.26.2 diff --git a/FSharpActivePatterns/.zanuda b/FSharpActivePatterns/.zanuda new file mode 100644 index 000000000..43cfa2792 --- /dev/null +++ b/FSharpActivePatterns/.zanuda @@ -0,0 +1 @@ +forward mutability_check ignore exec.ml diff --git a/FSharpActivePatterns/COPYING b/FSharpActivePatterns/COPYING new file mode 100644 index 000000000..f288702d2 --- /dev/null +++ b/FSharpActivePatterns/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/FSharpActivePatterns/COPYING.CC0 b/FSharpActivePatterns/COPYING.CC0 new file mode 100644 index 000000000..0e259d42c --- /dev/null +++ b/FSharpActivePatterns/COPYING.CC0 @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/FSharpActivePatterns/COPYING.LESSER b/FSharpActivePatterns/COPYING.LESSER new file mode 100644 index 000000000..0a041280b --- /dev/null +++ b/FSharpActivePatterns/COPYING.LESSER @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/FSharpActivePatterns/FSharpActivePatterns.opam b/FSharpActivePatterns/FSharpActivePatterns.opam new file mode 100644 index 000000000..43ba3226a --- /dev/null +++ b/FSharpActivePatterns/FSharpActivePatterns.opam @@ -0,0 +1,36 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "0.1" +synopsis: "An interpreter for F# with active patterns" +description: + "FIX LATER. A longer description, for example, which are the most interesing features being supported, etc." +maintainer: ["Ksenia Kotelnikova, Gleb Nasretdinov"] +authors: ["Ksenia Kotelnikova, Gleb Nasretdinov"] +license: "LGPL-3.0-or-later" +homepage: "https://github.com/Ycyken/fp2024" +doc: "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda" +bug-reports: "https://github.com/Ycyken/fp2024" +depends: [ + "dune" {>= "3.7"} + "angstrom" + "ppx_inline_test" {with-test} + "ppx_expect" + "ppx_deriving" + "bisect_ppx" + "odoc" {with-doc} + "ocamlformat" {build} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] diff --git a/FSharpActivePatterns/bin/dune b/FSharpActivePatterns/bin/dune new file mode 100644 index 000000000..53a7b565d --- /dev/null +++ b/FSharpActivePatterns/bin/dune @@ -0,0 +1,4 @@ +(executable + (public_name exec) + (name exec) + (libraries fsharp_active_patterns_lib)) diff --git a/FSharpActivePatterns/bin/exec.ml b/FSharpActivePatterns/bin/exec.ml new file mode 100644 index 000000000..cd8733fc4 --- /dev/null +++ b/FSharpActivePatterns/bin/exec.ml @@ -0,0 +1,35 @@ +(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Fsharp_active_patterns_lib.AST +open Fsharp_active_patterns_lib.PrintAST + +let () = + let factorial = + Function + ( Some "factorial" + , [ Variable (Ident "n") ] + , [ If_then_else + ( Bin_expr + ( Logical_or + , Bin_expr (Binary_equal, Variable (Ident "n"), Const 0.0) + , Bin_expr (Binary_equal, Variable (Ident "n"), Const 1.0) ) + , [ Const 1.0 ] + , [ Bin_expr + ( Binary_multiply + , Variable (Ident "n") + , Function_call + ( "factorial" + , [ Bin_expr (Binary_minus, Variable (Ident "n"), Const 1.0) ] ) ) + ] ) + ] ) + in + let program = + [ Let (Ident "a", Const 10.0) + ; factorial + ; Function_call ("factorial", [ Variable (Ident "a") ]) + ] + in + List.iter (print_expr 0) program +;; diff --git a/FSharpActivePatterns/dune b/FSharpActivePatterns/dune new file mode 100644 index 000000000..4189d77b9 --- /dev/null +++ b/FSharpActivePatterns/dune @@ -0,0 +1,8 @@ +(env + (dev + (flags + (:standard -alert @deprecated -warn-error -A -w -3-9-32-34-58))) + (release + (flags + (:standard -alert @deprecated -warn-error +A -w +A-4-40-42-44-70)))) + diff --git a/FSharpActivePatterns/dune-project b/FSharpActivePatterns/dune-project new file mode 100644 index 000000000..e5d11e5bb --- /dev/null +++ b/FSharpActivePatterns/dune-project @@ -0,0 +1,33 @@ +(lang dune 3.7) + +(generate_opam_files true) + +(cram enable) + +(license LGPL-3.0-or-later) + +(authors "Ksenia Kotelnikova, Gleb Nasretdinov") + +(maintainers "Ksenia Kotelnikova, Gleb Nasretdinov") + +(bug_reports "https://github.com/Ycyken/fp2024") + +(homepage "https://github.com/Ycyken/fp2024") + +(package + (name FSharpActivePatterns) + (synopsis "An interpreter for F# with active patterns") + (description + "FIX LATER. A longer description, for example, which are the most interesing features being supported, etc.") + (documentation "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda") + (version 0.1) + (depends + dune + angstrom + (ppx_inline_test :with-test) + ppx_expect + ppx_deriving + bisect_ppx + (odoc :with-doc) + (ocamlformat :build) + )) \ No newline at end of file diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml new file mode 100644 index 000000000..31fadc533 --- /dev/null +++ b/FSharpActivePatterns/lib/AST.ml @@ -0,0 +1,31 @@ +(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +type ident = Ident of string + +type binary_operator = + | Binary_equal + | Binary_unequal + | Binary_less + | Binary_less_or_equal + | Binary_greater + | Binary_greater_or_equal + | Binary_plus + | Binary_minus + | Binary_multiply + | Logical_or + | Logical_and + | Binary_divide + | Binary_or_bitwise + | Binary_xor_bitwise + | Binary_and_bitwise + +type expr = + | Const of float + | Variable of (*name*) ident + | Bin_expr of (*oper*) binary_operator * (*fst*) expr * (*snd*) expr + | If_then_else of (*condition*) expr * (*then body*) expr list * (*else body*) expr list + | Function of (*name*) string option * (*args*) expr list * (*body*) expr list + | Function_call of (*name*) string * (*args*) expr list + | Let of (*name*) ident * (*value*) expr (* * (*body*) expr list *) diff --git a/FSharpActivePatterns/lib/dune b/FSharpActivePatterns/lib/dune new file mode 100644 index 000000000..4e85ca0b2 --- /dev/null +++ b/FSharpActivePatterns/lib/dune @@ -0,0 +1,4 @@ +(library + (name fsharp_active_patterns_lib) + (public_name FSharpActivePatterns.Lib) + (modules AST PrintAST)) diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml new file mode 100644 index 000000000..3c433b98d --- /dev/null +++ b/FSharpActivePatterns/lib/printAST.ml @@ -0,0 +1,62 @@ +(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open AST + +let rec print_expr indent = function + | Const f -> Printf.printf "%s| Const(%f)\n" (String.make indent '-') f + | Variable (Ident name) -> + Printf.printf "%s| Variable(%s)\n" (String.make indent '-') name + | Bin_expr (op, left, right) -> + Printf.printf "%s| Binary expr(\n" (String.make indent '-'); + print_bin_op indent op; + print_expr (indent + 2) left; + print_expr (indent + 2) right + | If_then_else (cond, then_body, else_body) -> + Printf.printf "%s| If Then Else(\n" (String.make indent '-'); + Printf.printf "%sCONDITION\n" (String.make indent ' '); + print_expr (indent + 2) cond; + Printf.printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 4)) then_body; + Printf.printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 4)) else_body + | Function (name, args, body) -> + Printf.printf + "%s| Function(%s):\n" + (String.make indent '-') + (match name with + | Some n -> n + | None -> "Anonymous"); + Printf.printf "%sARGS\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 4)) args; + Printf.printf "%sBODY\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 4)) body + | Function_call (name, args) -> + Printf.printf "%s| Function Call(%s):\n" (String.make indent '-') name; + List.iter (print_expr (indent + 2)) args + | Let (Ident name, value) -> + Printf.printf "%s| Let %s =\n" (String.make indent '-') name; + print_expr (indent + 2) value + +and print_bin_op indent = function + | Binary_equal -> Printf.printf "%s| Binary Equal\n" (String.make indent '-') + | Binary_unequal -> Printf.printf "%s| Binary Unequal\n" (String.make indent '-') + | Binary_less -> Printf.printf "%s| Binary Less\n" (String.make indent '-') + | Binary_less_or_equal -> + Printf.printf "%s| Binary Less Or Equal\n" (String.make indent ' ') + | Binary_greater -> Printf.printf "%s| Binary Greater\n" (String.make indent '-') + | Binary_greater_or_equal -> + Printf.printf "%s| Binary Greater Or Equal\n" (String.make indent '-') + | Binary_plus -> Printf.printf "%s| Binary Plus\n" (String.make indent '-') + | Binary_minus -> Printf.printf "%s| Binary Minus\n" (String.make indent '-') + | Binary_multiply -> Printf.printf "%s| Binary Multiply\n" (String.make indent '-') + | Logical_or -> Printf.printf "%s| Logical Or\n" (String.make indent '-') + | Logical_and -> Printf.printf "%s| Logical And\n" (String.make indent '-') + | Binary_divide -> Printf.printf "%s| Binary Divide\n" (String.make indent '-') + | Binary_or_bitwise -> Printf.printf "%s| Binary Or Bitwise\n" (String.make indent '-') + | Binary_xor_bitwise -> + Printf.printf "%s| Binary Xor Bitwise\n" (String.make indent '-') + | Binary_and_bitwise -> + Printf.printf "%s| Binary And Bitwise\n" (String.make indent '-') +;; From 1a1c074964cad0d96a79e87d3f5c09d660dffcdf Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 30 Sep 2024 19:32:15 +0300 Subject: [PATCH 005/310] exclude extra dependencies and fix format of dune files Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/dune | 1 - FSharpActivePatterns/dune-project | 1 - 2 files changed, 2 deletions(-) diff --git a/FSharpActivePatterns/dune b/FSharpActivePatterns/dune index 4189d77b9..98e54536a 100644 --- a/FSharpActivePatterns/dune +++ b/FSharpActivePatterns/dune @@ -5,4 +5,3 @@ (release (flags (:standard -alert @deprecated -warn-error +A -w +A-4-40-42-44-70)))) - diff --git a/FSharpActivePatterns/dune-project b/FSharpActivePatterns/dune-project index e5d11e5bb..ee9d9ea89 100644 --- a/FSharpActivePatterns/dune-project +++ b/FSharpActivePatterns/dune-project @@ -23,7 +23,6 @@ (version 0.1) (depends dune - angstrom (ppx_inline_test :with-test) ppx_expect ppx_deriving From 6149765dba653581135d346ffa79cf544d5458c4 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 30 Sep 2024 19:36:10 +0300 Subject: [PATCH 006/310] fix: change names of plus and minus constructors to add and subtract respectively for uniformity Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/exec.ml | 2 +- FSharpActivePatterns/lib/AST.ml | 4 ++-- FSharpActivePatterns/lib/printAST.ml | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/FSharpActivePatterns/bin/exec.ml b/FSharpActivePatterns/bin/exec.ml index cd8733fc4..3e5d208ea 100644 --- a/FSharpActivePatterns/bin/exec.ml +++ b/FSharpActivePatterns/bin/exec.ml @@ -21,7 +21,7 @@ let () = , Variable (Ident "n") , Function_call ( "factorial" - , [ Bin_expr (Binary_minus, Variable (Ident "n"), Const 1.0) ] ) ) + , [ Bin_expr (Binary_subtract, Variable (Ident "n"), Const 1.0) ] ) ) ] ) ] ) in diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index 31fadc533..9e2bbcf9f 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -11,8 +11,8 @@ type binary_operator = | Binary_less_or_equal | Binary_greater | Binary_greater_or_equal - | Binary_plus - | Binary_minus + | Binary_add + | Binary_subtract | Binary_multiply | Logical_or | Logical_and diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index 3c433b98d..286c78c9d 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -48,8 +48,8 @@ and print_bin_op indent = function | Binary_greater -> Printf.printf "%s| Binary Greater\n" (String.make indent '-') | Binary_greater_or_equal -> Printf.printf "%s| Binary Greater Or Equal\n" (String.make indent '-') - | Binary_plus -> Printf.printf "%s| Binary Plus\n" (String.make indent '-') - | Binary_minus -> Printf.printf "%s| Binary Minus\n" (String.make indent '-') + | Binary_add -> Printf.printf "%s| Binary Add\n" (String.make indent '-') + | Binary_subtract -> Printf.printf "%s| Binary Subtract\n" (String.make indent '-') | Binary_multiply -> Printf.printf "%s| Binary Multiply\n" (String.make indent '-') | Logical_or -> Printf.printf "%s| Logical Or\n" (String.make indent '-') | Logical_and -> Printf.printf "%s| Logical And\n" (String.make indent '-') From 459b270c165cf3000cf0a088d21e3b3626635b89 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 30 Sep 2024 19:49:18 +0300 Subject: [PATCH 007/310] fix: change else body from expressions list to expressions list option to allow empty elses Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/exec.ml | 4 ++-- FSharpActivePatterns/lib/AST.ml | 2 +- FSharpActivePatterns/lib/printAST.ml | 4 +++- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/bin/exec.ml b/FSharpActivePatterns/bin/exec.ml index 3e5d208ea..a494b7cf5 100644 --- a/FSharpActivePatterns/bin/exec.ml +++ b/FSharpActivePatterns/bin/exec.ml @@ -16,13 +16,13 @@ let () = , Bin_expr (Binary_equal, Variable (Ident "n"), Const 0.0) , Bin_expr (Binary_equal, Variable (Ident "n"), Const 1.0) ) , [ Const 1.0 ] - , [ Bin_expr + , Some([ Bin_expr ( Binary_multiply , Variable (Ident "n") , Function_call ( "factorial" , [ Bin_expr (Binary_subtract, Variable (Ident "n"), Const 1.0) ] ) ) - ] ) + ]) ) ] ) in let program = diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index 9e2bbcf9f..55a7cbe79 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -25,7 +25,7 @@ type expr = | Const of float | Variable of (*name*) ident | Bin_expr of (*oper*) binary_operator * (*fst*) expr * (*snd*) expr - | If_then_else of (*condition*) expr * (*then body*) expr list * (*else body*) expr list + | If_then_else of (*condition*) expr * (*then body*) expr list * (*else body*) expr list option | Function of (*name*) string option * (*args*) expr list * (*body*) expr list | Function_call of (*name*) string * (*args*) expr list | Let of (*name*) ident * (*value*) expr (* * (*body*) expr list *) diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index 286c78c9d..f67f028a2 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -20,7 +20,9 @@ let rec print_expr indent = function Printf.printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 4)) then_body; Printf.printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4)) else_body + (match else_body with + | Some body -> List.iter (print_expr (indent + 4)) body + | None -> Printf.printf "No else body") | Function (name, args, body) -> Printf.printf "%s| Function(%s):\n" From f645e323de411961be03b79e1d8892ec1e1ef5f2 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 09:54:13 +0300 Subject: [PATCH 008/310] fix: delete old directory Signed-off-by: Ksenia Kotelnikova --- fsharp_active_patterns/.envrc | 3 - fsharp_active_patterns/.gitignore | 6 - fsharp_active_patterns/.ocamlformat | 2 - fsharp_active_patterns/.zanuda | 1 - fsharp_active_patterns/COPYING | 674 ------------------ fsharp_active_patterns/COPYING.CC0 | 121 ---- fsharp_active_patterns/COPYING.LESSER | 165 ----- fsharp_active_patterns/bin/dune | 4 - fsharp_active_patterns/bin/exec.ml | 35 - fsharp_active_patterns/dune | 8 - fsharp_active_patterns/dune-project | 33 - .../fsharp_active_patterns.opam | 36 - fsharp_active_patterns/lib/AST.ml | 31 - fsharp_active_patterns/lib/dune | 4 - fsharp_active_patterns/lib/printAST.ml | 62 -- 15 files changed, 1185 deletions(-) delete mode 100644 fsharp_active_patterns/.envrc delete mode 100644 fsharp_active_patterns/.gitignore delete mode 100644 fsharp_active_patterns/.ocamlformat delete mode 100644 fsharp_active_patterns/.zanuda delete mode 100644 fsharp_active_patterns/COPYING delete mode 100644 fsharp_active_patterns/COPYING.CC0 delete mode 100644 fsharp_active_patterns/COPYING.LESSER delete mode 100644 fsharp_active_patterns/bin/dune delete mode 100644 fsharp_active_patterns/bin/exec.ml delete mode 100644 fsharp_active_patterns/dune delete mode 100644 fsharp_active_patterns/dune-project delete mode 100644 fsharp_active_patterns/fsharp_active_patterns.opam delete mode 100644 fsharp_active_patterns/lib/AST.ml delete mode 100644 fsharp_active_patterns/lib/dune delete mode 100644 fsharp_active_patterns/lib/printAST.ml diff --git a/fsharp_active_patterns/.envrc b/fsharp_active_patterns/.envrc deleted file mode 100644 index e6bd6786d..000000000 --- a/fsharp_active_patterns/.envrc +++ /dev/null @@ -1,3 +0,0 @@ -export OPAMSWITCH=4.14.2+flambda -eval $(opam env) - diff --git a/fsharp_active_patterns/.gitignore b/fsharp_active_patterns/.gitignore deleted file mode 100644 index 7102a822c..000000000 --- a/fsharp_active_patterns/.gitignore +++ /dev/null @@ -1,6 +0,0 @@ -_build -_coverage -/_esy -/node_modules -/esy.lock -/.melange.eobjs diff --git a/fsharp_active_patterns/.ocamlformat b/fsharp_active_patterns/.ocamlformat deleted file mode 100644 index 97f970802..000000000 --- a/fsharp_active_patterns/.ocamlformat +++ /dev/null @@ -1,2 +0,0 @@ -profile=janestreet -version=0.26.2 diff --git a/fsharp_active_patterns/.zanuda b/fsharp_active_patterns/.zanuda deleted file mode 100644 index 43cfa2792..000000000 --- a/fsharp_active_patterns/.zanuda +++ /dev/null @@ -1 +0,0 @@ -forward mutability_check ignore exec.ml diff --git a/fsharp_active_patterns/COPYING b/fsharp_active_patterns/COPYING deleted file mode 100644 index f288702d2..000000000 --- a/fsharp_active_patterns/COPYING +++ /dev/null @@ -1,674 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU General Public License is a free, copyleft license for -software and other kinds of works. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -the GNU General Public License is intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. We, the Free Software Foundation, use the -GNU General Public License for most of our software; it applies also to -any other work released this way by its authors. You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - To protect your rights, we need to prevent others from denying you -these rights or asking you to surrender the rights. Therefore, you have -certain responsibilities if you distribute copies of the software, or if -you modify it: responsibilities to respect the freedom of others. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must pass on to the recipients the same -freedoms that you received. You must make sure that they, too, receive -or can get the source code. And you must show them these terms so they -know their rights. - - Developers that use the GNU GPL protect your rights with two steps: -(1) assert copyright on the software, and (2) offer you this License -giving you legal permission to copy, distribute and/or modify it. - - For the developers' and authors' protection, the GPL clearly explains -that there is no warranty for this free software. For both users' and -authors' sake, the GPL requires that modified versions be marked as -changed, so that their problems will not be attributed erroneously to -authors of previous versions. - - Some devices are designed to deny users access to install or run -modified versions of the software inside them, although the manufacturer -can do so. This is fundamentally incompatible with the aim of -protecting users' freedom to change the software. The systematic -pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we -have designed this version of the GPL to prohibit the practice for those -products. If such problems arise substantially in other domains, we -stand ready to extend this provision to those domains in future versions -of the GPL, as needed to protect the freedom of users. - - Finally, every program is threatened constantly by software patents. -States should not allow patents to restrict development and use of -software on general-purpose computers, but in those that do, we wish to -avoid the special danger that patents applied to a free program could -make it effectively proprietary. To prevent this, the GPL assures that -patents cannot be used to render the program non-free. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Use with the GNU Affero General Public License. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU Affero General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the special requirements of the GNU Affero General Public License, -section 13, concerning interaction through a network will apply to the -combination as such. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If the program does terminal interaction, make it output a short -notice like this when it starts in an interactive mode: - - Copyright (C) - This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, your program's commands -might be different; for a GUI interface, you would use an "about box". - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU GPL, see -. - - The GNU General Public License does not permit incorporating your program -into proprietary programs. If your program is a subroutine library, you -may consider it more useful to permit linking proprietary applications with -the library. If this is what you want to do, use the GNU Lesser General -Public License instead of this License. But first, please read -. diff --git a/fsharp_active_patterns/COPYING.CC0 b/fsharp_active_patterns/COPYING.CC0 deleted file mode 100644 index 0e259d42c..000000000 --- a/fsharp_active_patterns/COPYING.CC0 +++ /dev/null @@ -1,121 +0,0 @@ -Creative Commons Legal Code - -CC0 1.0 Universal - - CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE - LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN - ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS - INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES - REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS - PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM - THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED - HEREUNDER. - -Statement of Purpose - -The laws of most jurisdictions throughout the world automatically confer -exclusive Copyright and Related Rights (defined below) upon the creator -and subsequent owner(s) (each and all, an "owner") of an original work of -authorship and/or a database (each, a "Work"). - -Certain owners wish to permanently relinquish those rights to a Work for -the purpose of contributing to a commons of creative, cultural and -scientific works ("Commons") that the public can reliably and without fear -of later claims of infringement build upon, modify, incorporate in other -works, reuse and redistribute as freely as possible in any form whatsoever -and for any purposes, including without limitation commercial purposes. -These owners may contribute to the Commons to promote the ideal of a free -culture and the further production of creative, cultural and scientific -works, or to gain reputation or greater distribution for their Work in -part through the use and efforts of others. - -For these and/or other purposes and motivations, and without any -expectation of additional consideration or compensation, the person -associating CC0 with a Work (the "Affirmer"), to the extent that he or she -is an owner of Copyright and Related Rights in the Work, voluntarily -elects to apply CC0 to the Work and publicly distribute the Work under its -terms, with knowledge of his or her Copyright and Related Rights in the -Work and the meaning and intended legal effect of CC0 on those rights. - -1. Copyright and Related Rights. A Work made available under CC0 may be -protected by copyright and related or neighboring rights ("Copyright and -Related Rights"). Copyright and Related Rights include, but are not -limited to, the following: - - i. the right to reproduce, adapt, distribute, perform, display, - communicate, and translate a Work; - ii. moral rights retained by the original author(s) and/or performer(s); -iii. publicity and privacy rights pertaining to a person's image or - likeness depicted in a Work; - iv. rights protecting against unfair competition in regards to a Work, - subject to the limitations in paragraph 4(a), below; - v. rights protecting the extraction, dissemination, use and reuse of data - in a Work; - vi. database rights (such as those arising under Directive 96/9/EC of the - European Parliament and of the Council of 11 March 1996 on the legal - protection of databases, and under any national implementation - thereof, including any amended or successor version of such - directive); and -vii. other similar, equivalent or corresponding rights throughout the - world based on applicable law or treaty, and any national - implementations thereof. - -2. Waiver. To the greatest extent permitted by, but not in contravention -of, applicable law, Affirmer hereby overtly, fully, permanently, -irrevocably and unconditionally waives, abandons, and surrenders all of -Affirmer's Copyright and Related Rights and associated claims and causes -of action, whether now known or unknown (including existing as well as -future claims and causes of action), in the Work (i) in all territories -worldwide, (ii) for the maximum duration provided by applicable law or -treaty (including future time extensions), (iii) in any current or future -medium and for any number of copies, and (iv) for any purpose whatsoever, -including without limitation commercial, advertising or promotional -purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each -member of the public at large and to the detriment of Affirmer's heirs and -successors, fully intending that such Waiver shall not be subject to -revocation, rescission, cancellation, termination, or any other legal or -equitable action to disrupt the quiet enjoyment of the Work by the public -as contemplated by Affirmer's express Statement of Purpose. - -3. Public License Fallback. Should any part of the Waiver for any reason -be judged legally invalid or ineffective under applicable law, then the -Waiver shall be preserved to the maximum extent permitted taking into -account Affirmer's express Statement of Purpose. In addition, to the -extent the Waiver is so judged Affirmer hereby grants to each affected -person a royalty-free, non transferable, non sublicensable, non exclusive, -irrevocable and unconditional license to exercise Affirmer's Copyright and -Related Rights in the Work (i) in all territories worldwide, (ii) for the -maximum duration provided by applicable law or treaty (including future -time extensions), (iii) in any current or future medium and for any number -of copies, and (iv) for any purpose whatsoever, including without -limitation commercial, advertising or promotional purposes (the -"License"). The License shall be deemed effective as of the date CC0 was -applied by Affirmer to the Work. Should any part of the License for any -reason be judged legally invalid or ineffective under applicable law, such -partial invalidity or ineffectiveness shall not invalidate the remainder -of the License, and in such case Affirmer hereby affirms that he or she -will not (i) exercise any of his or her remaining Copyright and Related -Rights in the Work or (ii) assert any associated claims and causes of -action with respect to the Work, in either case contrary to Affirmer's -express Statement of Purpose. - -4. Limitations and Disclaimers. - - a. No trademark or patent rights held by Affirmer are waived, abandoned, - surrendered, licensed or otherwise affected by this document. - b. Affirmer offers the Work as-is and makes no representations or - warranties of any kind concerning the Work, express, implied, - statutory or otherwise, including without limitation warranties of - title, merchantability, fitness for a particular purpose, non - infringement, or the absence of latent or other defects, accuracy, or - the present or absence of errors, whether or not discoverable, all to - the greatest extent permissible under applicable law. - c. Affirmer disclaims responsibility for clearing rights of other persons - that may apply to the Work or any use thereof, including without - limitation any person's Copyright and Related Rights in the Work. - Further, Affirmer disclaims responsibility for obtaining any necessary - consents, permissions or other rights required for any use of the - Work. - d. Affirmer understands and acknowledges that Creative Commons is not a - party to this document and has no duty or obligation with respect to - this CC0 or use of the Work. diff --git a/fsharp_active_patterns/COPYING.LESSER b/fsharp_active_patterns/COPYING.LESSER deleted file mode 100644 index 0a041280b..000000000 --- a/fsharp_active_patterns/COPYING.LESSER +++ /dev/null @@ -1,165 +0,0 @@ - GNU LESSER GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - - This version of the GNU Lesser General Public License incorporates -the terms and conditions of version 3 of the GNU General Public -License, supplemented by the additional permissions listed below. - - 0. Additional Definitions. - - As used herein, "this License" refers to version 3 of the GNU Lesser -General Public License, and the "GNU GPL" refers to version 3 of the GNU -General Public License. - - "The Library" refers to a covered work governed by this License, -other than an Application or a Combined Work as defined below. - - An "Application" is any work that makes use of an interface provided -by the Library, but which is not otherwise based on the Library. -Defining a subclass of a class defined by the Library is deemed a mode -of using an interface provided by the Library. - - A "Combined Work" is a work produced by combining or linking an -Application with the Library. The particular version of the Library -with which the Combined Work was made is also called the "Linked -Version". - - The "Minimal Corresponding Source" for a Combined Work means the -Corresponding Source for the Combined Work, excluding any source code -for portions of the Combined Work that, considered in isolation, are -based on the Application, and not on the Linked Version. - - The "Corresponding Application Code" for a Combined Work means the -object code and/or source code for the Application, including any data -and utility programs needed for reproducing the Combined Work from the -Application, but excluding the System Libraries of the Combined Work. - - 1. Exception to Section 3 of the GNU GPL. - - You may convey a covered work under sections 3 and 4 of this License -without being bound by section 3 of the GNU GPL. - - 2. Conveying Modified Versions. - - If you modify a copy of the Library, and, in your modifications, a -facility refers to a function or data to be supplied by an Application -that uses the facility (other than as an argument passed when the -facility is invoked), then you may convey a copy of the modified -version: - - a) under this License, provided that you make a good faith effort to - ensure that, in the event an Application does not supply the - function or data, the facility still operates, and performs - whatever part of its purpose remains meaningful, or - - b) under the GNU GPL, with none of the additional permissions of - this License applicable to that copy. - - 3. Object Code Incorporating Material from Library Header Files. - - The object code form of an Application may incorporate material from -a header file that is part of the Library. You may convey such object -code under terms of your choice, provided that, if the incorporated -material is not limited to numerical parameters, data structure -layouts and accessors, or small macros, inline functions and templates -(ten or fewer lines in length), you do both of the following: - - a) Give prominent notice with each copy of the object code that the - Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the object code with a copy of the GNU GPL and this license - document. - - 4. Combined Works. - - You may convey a Combined Work under terms of your choice that, -taken together, effectively do not restrict modification of the -portions of the Library contained in the Combined Work and reverse -engineering for debugging such modifications, if you also do each of -the following: - - a) Give prominent notice with each copy of the Combined Work that - the Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the Combined Work with a copy of the GNU GPL and this license - document. - - c) For a Combined Work that displays copyright notices during - execution, include the copyright notice for the Library among - these notices, as well as a reference directing the user to the - copies of the GNU GPL and this license document. - - d) Do one of the following: - - 0) Convey the Minimal Corresponding Source under the terms of this - License, and the Corresponding Application Code in a form - suitable for, and under terms that permit, the user to - recombine or relink the Application with a modified version of - the Linked Version to produce a modified Combined Work, in the - manner specified by section 6 of the GNU GPL for conveying - Corresponding Source. - - 1) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (a) uses at run time - a copy of the Library already present on the user's computer - system, and (b) will operate properly with a modified version - of the Library that is interface-compatible with the Linked - Version. - - e) Provide Installation Information, but only if you would otherwise - be required to provide such information under section 6 of the - GNU GPL, and only to the extent that such information is - necessary to install and execute a modified version of the - Combined Work produced by recombining or relinking the - Application with a modified version of the Linked Version. (If - you use option 4d0, the Installation Information must accompany - the Minimal Corresponding Source and Corresponding Application - Code. If you use option 4d1, you must provide the Installation - Information in the manner specified by section 6 of the GNU GPL - for conveying Corresponding Source.) - - 5. Combined Libraries. - - You may place library facilities that are a work based on the -Library side by side in a single library together with other library -facilities that are not Applications and are not covered by this -License, and convey such a combined library under terms of your -choice, if you do both of the following: - - a) Accompany the combined library with a copy of the same work based - on the Library, uncombined with any other library facilities, - conveyed under the terms of this License. - - b) Give prominent notice with the combined library that part of it - is a work based on the Library, and explaining where to find the - accompanying uncombined form of the same work. - - 6. Revised Versions of the GNU Lesser General Public License. - - The Free Software Foundation may publish revised and/or new versions -of the GNU Lesser General Public License from time to time. Such new -versions will be similar in spirit to the present version, but may -differ in detail to address new problems or concerns. - - Each version is given a distinguishing version number. If the -Library as you received it specifies that a certain numbered version -of the GNU Lesser General Public License "or any later version" -applies to it, you have the option of following the terms and -conditions either of that published version or of any later version -published by the Free Software Foundation. If the Library as you -received it does not specify a version number of the GNU Lesser -General Public License, you may choose any version of the GNU Lesser -General Public License ever published by the Free Software Foundation. - - If the Library as you received it specifies that a proxy can decide -whether future versions of the GNU Lesser General Public License shall -apply, that proxy's public statement of acceptance of any version is -permanent authorization for you to choose that version for the -Library. diff --git a/fsharp_active_patterns/bin/dune b/fsharp_active_patterns/bin/dune deleted file mode 100644 index 53a7b565d..000000000 --- a/fsharp_active_patterns/bin/dune +++ /dev/null @@ -1,4 +0,0 @@ -(executable - (public_name exec) - (name exec) - (libraries fsharp_active_patterns_lib)) diff --git a/fsharp_active_patterns/bin/exec.ml b/fsharp_active_patterns/bin/exec.ml deleted file mode 100644 index cd8733fc4..000000000 --- a/fsharp_active_patterns/bin/exec.ml +++ /dev/null @@ -1,35 +0,0 @@ -(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - -open Fsharp_active_patterns_lib.AST -open Fsharp_active_patterns_lib.PrintAST - -let () = - let factorial = - Function - ( Some "factorial" - , [ Variable (Ident "n") ] - , [ If_then_else - ( Bin_expr - ( Logical_or - , Bin_expr (Binary_equal, Variable (Ident "n"), Const 0.0) - , Bin_expr (Binary_equal, Variable (Ident "n"), Const 1.0) ) - , [ Const 1.0 ] - , [ Bin_expr - ( Binary_multiply - , Variable (Ident "n") - , Function_call - ( "factorial" - , [ Bin_expr (Binary_minus, Variable (Ident "n"), Const 1.0) ] ) ) - ] ) - ] ) - in - let program = - [ Let (Ident "a", Const 10.0) - ; factorial - ; Function_call ("factorial", [ Variable (Ident "a") ]) - ] - in - List.iter (print_expr 0) program -;; diff --git a/fsharp_active_patterns/dune b/fsharp_active_patterns/dune deleted file mode 100644 index 4189d77b9..000000000 --- a/fsharp_active_patterns/dune +++ /dev/null @@ -1,8 +0,0 @@ -(env - (dev - (flags - (:standard -alert @deprecated -warn-error -A -w -3-9-32-34-58))) - (release - (flags - (:standard -alert @deprecated -warn-error +A -w +A-4-40-42-44-70)))) - diff --git a/fsharp_active_patterns/dune-project b/fsharp_active_patterns/dune-project deleted file mode 100644 index 93e8bfb86..000000000 --- a/fsharp_active_patterns/dune-project +++ /dev/null @@ -1,33 +0,0 @@ -(lang dune 3.7) - -(generate_opam_files true) - -(cram enable) - -(license LGPL-3.0-or-later) - -(authors "Ksenia Kotelnikova, Gleb Nasretdinov") - -(maintainers "Ksenia Kotelnikova, Gleb Nasretdinov") - -(bug_reports "https://github.com/Ycyken/fp2024") - -(homepage "https://github.com/Ycyken/fp2024") - -(package - (name fsharp_active_patterns) - (synopsis "An interpreter for F# with active patterns") - (description - "FIX LATER. A longer description, for example, which are the most interesing features being supported, etc.") - (documentation "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda") - (version 0.1) - (depends - dune - angstrom - (ppx_inline_test :with-test) - ppx_expect - ppx_deriving - bisect_ppx - (odoc :with-doc) - (ocamlformat :build) - )) \ No newline at end of file diff --git a/fsharp_active_patterns/fsharp_active_patterns.opam b/fsharp_active_patterns/fsharp_active_patterns.opam deleted file mode 100644 index 43ba3226a..000000000 --- a/fsharp_active_patterns/fsharp_active_patterns.opam +++ /dev/null @@ -1,36 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -version: "0.1" -synopsis: "An interpreter for F# with active patterns" -description: - "FIX LATER. A longer description, for example, which are the most interesing features being supported, etc." -maintainer: ["Ksenia Kotelnikova, Gleb Nasretdinov"] -authors: ["Ksenia Kotelnikova, Gleb Nasretdinov"] -license: "LGPL-3.0-or-later" -homepage: "https://github.com/Ycyken/fp2024" -doc: "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda" -bug-reports: "https://github.com/Ycyken/fp2024" -depends: [ - "dune" {>= "3.7"} - "angstrom" - "ppx_inline_test" {with-test} - "ppx_expect" - "ppx_deriving" - "bisect_ppx" - "odoc" {with-doc} - "ocamlformat" {build} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] diff --git a/fsharp_active_patterns/lib/AST.ml b/fsharp_active_patterns/lib/AST.ml deleted file mode 100644 index 31fadc533..000000000 --- a/fsharp_active_patterns/lib/AST.ml +++ /dev/null @@ -1,31 +0,0 @@ -(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - -type ident = Ident of string - -type binary_operator = - | Binary_equal - | Binary_unequal - | Binary_less - | Binary_less_or_equal - | Binary_greater - | Binary_greater_or_equal - | Binary_plus - | Binary_minus - | Binary_multiply - | Logical_or - | Logical_and - | Binary_divide - | Binary_or_bitwise - | Binary_xor_bitwise - | Binary_and_bitwise - -type expr = - | Const of float - | Variable of (*name*) ident - | Bin_expr of (*oper*) binary_operator * (*fst*) expr * (*snd*) expr - | If_then_else of (*condition*) expr * (*then body*) expr list * (*else body*) expr list - | Function of (*name*) string option * (*args*) expr list * (*body*) expr list - | Function_call of (*name*) string * (*args*) expr list - | Let of (*name*) ident * (*value*) expr (* * (*body*) expr list *) diff --git a/fsharp_active_patterns/lib/dune b/fsharp_active_patterns/lib/dune deleted file mode 100644 index 3bdcfaa3b..000000000 --- a/fsharp_active_patterns/lib/dune +++ /dev/null @@ -1,4 +0,0 @@ -(library - (name fsharp_active_patterns_lib) - (public_name fsharp_active_patterns.Lib) - (modules AST PrintAST)) diff --git a/fsharp_active_patterns/lib/printAST.ml b/fsharp_active_patterns/lib/printAST.ml deleted file mode 100644 index 3c433b98d..000000000 --- a/fsharp_active_patterns/lib/printAST.ml +++ /dev/null @@ -1,62 +0,0 @@ -(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - -open AST - -let rec print_expr indent = function - | Const f -> Printf.printf "%s| Const(%f)\n" (String.make indent '-') f - | Variable (Ident name) -> - Printf.printf "%s| Variable(%s)\n" (String.make indent '-') name - | Bin_expr (op, left, right) -> - Printf.printf "%s| Binary expr(\n" (String.make indent '-'); - print_bin_op indent op; - print_expr (indent + 2) left; - print_expr (indent + 2) right - | If_then_else (cond, then_body, else_body) -> - Printf.printf "%s| If Then Else(\n" (String.make indent '-'); - Printf.printf "%sCONDITION\n" (String.make indent ' '); - print_expr (indent + 2) cond; - Printf.printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4)) then_body; - Printf.printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4)) else_body - | Function (name, args, body) -> - Printf.printf - "%s| Function(%s):\n" - (String.make indent '-') - (match name with - | Some n -> n - | None -> "Anonymous"); - Printf.printf "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4)) args; - Printf.printf "%sBODY\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4)) body - | Function_call (name, args) -> - Printf.printf "%s| Function Call(%s):\n" (String.make indent '-') name; - List.iter (print_expr (indent + 2)) args - | Let (Ident name, value) -> - Printf.printf "%s| Let %s =\n" (String.make indent '-') name; - print_expr (indent + 2) value - -and print_bin_op indent = function - | Binary_equal -> Printf.printf "%s| Binary Equal\n" (String.make indent '-') - | Binary_unequal -> Printf.printf "%s| Binary Unequal\n" (String.make indent '-') - | Binary_less -> Printf.printf "%s| Binary Less\n" (String.make indent '-') - | Binary_less_or_equal -> - Printf.printf "%s| Binary Less Or Equal\n" (String.make indent ' ') - | Binary_greater -> Printf.printf "%s| Binary Greater\n" (String.make indent '-') - | Binary_greater_or_equal -> - Printf.printf "%s| Binary Greater Or Equal\n" (String.make indent '-') - | Binary_plus -> Printf.printf "%s| Binary Plus\n" (String.make indent '-') - | Binary_minus -> Printf.printf "%s| Binary Minus\n" (String.make indent '-') - | Binary_multiply -> Printf.printf "%s| Binary Multiply\n" (String.make indent '-') - | Logical_or -> Printf.printf "%s| Logical Or\n" (String.make indent '-') - | Logical_and -> Printf.printf "%s| Logical And\n" (String.make indent '-') - | Binary_divide -> Printf.printf "%s| Binary Divide\n" (String.make indent '-') - | Binary_or_bitwise -> Printf.printf "%s| Binary Or Bitwise\n" (String.make indent '-') - | Binary_xor_bitwise -> - Printf.printf "%s| Binary Xor Bitwise\n" (String.make indent '-') - | Binary_and_bitwise -> - Printf.printf "%s| Binary And Bitwise\n" (String.make indent '-') -;; From 5c267994f6c756e05c00e0eab94d5dc5193ee8f6 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 10:04:07 +0300 Subject: [PATCH 009/310] feat: add mails to copyright Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/exec.ml | 2 +- FSharpActivePatterns/lib/AST.ml | 2 +- FSharpActivePatterns/lib/printAST.ml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/FSharpActivePatterns/bin/exec.ml b/FSharpActivePatterns/bin/exec.ml index a494b7cf5..062dea2e1 100644 --- a/FSharpActivePatterns/bin/exec.ml +++ b/FSharpActivePatterns/bin/exec.ml @@ -1,4 +1,4 @@ -(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) +(** Copyright 2024, Ksenia Kotelnikova , Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index 55a7cbe79..be108c9c9 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -1,4 +1,4 @@ -(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) +(** Copyright 2024, Ksenia Kotelnikova , Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index f67f028a2..88a5ab7f5 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -1,4 +1,4 @@ -(** Copyright 2024, Ksenia Kotelnikova, Gleb Nasretdinov *) +(** Copyright 2024, Ksenia Kotelnikova , Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) From 5f3980f43efcfc993270e90bb55b3f8bbd9ec202 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 10:06:39 +0300 Subject: [PATCH 010/310] fix: edit description Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/dune-project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/dune-project b/FSharpActivePatterns/dune-project index ee9d9ea89..9ef997f45 100644 --- a/FSharpActivePatterns/dune-project +++ b/FSharpActivePatterns/dune-project @@ -18,7 +18,7 @@ (name FSharpActivePatterns) (synopsis "An interpreter for F# with active patterns") (description - "FIX LATER. A longer description, for example, which are the most interesing features being supported, etc.") + "An interpreter for F# with supported active patterns feature (mb fix later)") (documentation "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda") (version 0.1) (depends From f2186e5fb28be8af473145889e6faaa8bcf113c6 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 10:13:42 +0300 Subject: [PATCH 011/310] feat: implement function flags, currently only rec flag Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/exec.ml | 3 ++- FSharpActivePatterns/lib/AST.ml | 6 +++++- FSharpActivePatterns/lib/printAST.ml | 7 +++++-- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/bin/exec.ml b/FSharpActivePatterns/bin/exec.ml index 062dea2e1..168205e2a 100644 --- a/FSharpActivePatterns/bin/exec.ml +++ b/FSharpActivePatterns/bin/exec.ml @@ -8,7 +8,8 @@ open Fsharp_active_patterns_lib.PrintAST let () = let factorial = Function - ( Some "factorial" + ( Rec + , Some "factorial" , [ Variable (Ident "n") ] , [ If_then_else ( Bin_expr diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index be108c9c9..697f9ff14 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -21,11 +21,15 @@ type binary_operator = | Binary_xor_bitwise | Binary_and_bitwise +type function_flag = + | None + | Rec + type expr = | Const of float | Variable of (*name*) ident | Bin_expr of (*oper*) binary_operator * (*fst*) expr * (*snd*) expr | If_then_else of (*condition*) expr * (*then body*) expr list * (*else body*) expr list option - | Function of (*name*) string option * (*args*) expr list * (*body*) expr list + | Function of (*rec/no rec*) function_flag * (*name*) string option * (*args*) expr list * (*body*) expr list | Function_call of (*name*) string * (*args*) expr list | Let of (*name*) ident * (*value*) expr (* * (*body*) expr list *) diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index 88a5ab7f5..260493a9a 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -23,10 +23,13 @@ let rec print_expr indent = function (match else_body with | Some body -> List.iter (print_expr (indent + 4)) body | None -> Printf.printf "No else body") - | Function (name, args, body) -> + | Function (flag, name, args, body) -> Printf.printf - "%s| Function(%s):\n" + "%s| %s Function(%s):\n" (String.make indent '-') + (match flag with + | None -> "" + | Rec -> "Rec") (match name with | Some n -> n | None -> "Anonymous"); From 1d500c4703837329ec0383621af0cbe8b16b8d65 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 13:52:39 +0300 Subject: [PATCH 012/310] feat: implement unary operators to AST Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/AST.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index 697f9ff14..efac2048c 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -21,6 +21,11 @@ type binary_operator = | Binary_xor_bitwise | Binary_and_bitwise +type unary_operator = + | Unary_plus + | Unary_minus + | Unary_negative + type function_flag = | None | Rec From 4e3488c3fb8565b1cacfeb2d643e55299f04faf6 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 14:11:22 +0300 Subject: [PATCH 013/310] feat: implement literals as types of constants Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/exec.ml | 12 ++++++------ FSharpActivePatterns/lib/AST.ml | 8 +++++++- FSharpActivePatterns/lib/printAST.ml | 5 ++++- 3 files changed, 17 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/bin/exec.ml b/FSharpActivePatterns/bin/exec.ml index 168205e2a..4da645d90 100644 --- a/FSharpActivePatterns/bin/exec.ml +++ b/FSharpActivePatterns/bin/exec.ml @@ -5,7 +5,7 @@ open Fsharp_active_patterns_lib.AST open Fsharp_active_patterns_lib.PrintAST -let () = +let() = let factorial = Function ( Rec @@ -14,20 +14,20 @@ let () = , [ If_then_else ( Bin_expr ( Logical_or - , Bin_expr (Binary_equal, Variable (Ident "n"), Const 0.0) - , Bin_expr (Binary_equal, Variable (Ident "n"), Const 1.0) ) - , [ Const 1.0 ] + , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 0)) + , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 1)) ) + , [ Const (Int_lt 1) ] , Some([ Bin_expr ( Binary_multiply , Variable (Ident "n") , Function_call ( "factorial" - , [ Bin_expr (Binary_subtract, Variable (Ident "n"), Const 1.0) ] ) ) + , [ Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) ] ) ) ]) ) ] ) in let program = - [ Let (Ident "a", Const 10.0) + [ Let (Ident "a", Const (Int_lt 10)) ; factorial ; Function_call ("factorial", [ Variable (Ident "a") ]) ] diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index efac2048c..f8a19c265 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -4,6 +4,12 @@ type ident = Ident of string +type literal = + | Int_lt of int + | Bool_lt of bool + | String_lt of string + | Unit_lt + type binary_operator = | Binary_equal | Binary_unequal @@ -31,7 +37,7 @@ type function_flag = | Rec type expr = - | Const of float + | Const of literal | Variable of (*name*) ident | Bin_expr of (*oper*) binary_operator * (*fst*) expr * (*snd*) expr | If_then_else of (*condition*) expr * (*then body*) expr list * (*else body*) expr list option diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index 260493a9a..6c510a815 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -5,7 +5,10 @@ open AST let rec print_expr indent = function - | Const f -> Printf.printf "%s| Const(%f)\n" (String.make indent '-') f + | Const (Int_lt i) -> Printf.printf "%s| Const(Int: %d)\n" (String.make indent '-') i + | Const (Bool_lt b) -> Printf.printf "%s| Const(Bool: %b)\n" (String.make indent '-') b + | Const (String_lt s) -> Printf.printf "%s| Const(String: \"%s\")\n" (String.make indent '-') s + | Const Unit_lt -> Printf.printf "%s| Const(Unit)\n" (String.make indent '-') | Variable (Ident name) -> Printf.printf "%s| Variable(%s)\n" (String.make indent '-') name | Bin_expr (op, left, right) -> From f7b17d4e579f379fecba4e2952dfef242c44b483 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 14:15:37 +0300 Subject: [PATCH 014/310] fix: exclude extra lib Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/FSharpActivePatterns.opam | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/FSharpActivePatterns/FSharpActivePatterns.opam b/FSharpActivePatterns/FSharpActivePatterns.opam index 43ba3226a..6041814cd 100644 --- a/FSharpActivePatterns/FSharpActivePatterns.opam +++ b/FSharpActivePatterns/FSharpActivePatterns.opam @@ -3,7 +3,7 @@ opam-version: "2.0" version: "0.1" synopsis: "An interpreter for F# with active patterns" description: - "FIX LATER. A longer description, for example, which are the most interesing features being supported, etc." + "An interpreter for F# with supported active patterns feature (mb fix later)" maintainer: ["Ksenia Kotelnikova, Gleb Nasretdinov"] authors: ["Ksenia Kotelnikova, Gleb Nasretdinov"] license: "LGPL-3.0-or-later" @@ -12,7 +12,6 @@ doc: "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda" bug-reports: "https://github.com/Ycyken/fp2024" depends: [ "dune" {>= "3.7"} - "angstrom" "ppx_inline_test" {with-test} "ppx_expect" "ppx_deriving" From 3ceba231021348d1f15156899c2576ccafb31a20 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 14:18:47 +0300 Subject: [PATCH 015/310] fix: update comments Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/AST.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index f8a19c265..2ed5e1807 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -34,13 +34,13 @@ type unary_operator = type function_flag = | None - | Rec + | Rec (* recursion flag *) type expr = | Const of literal | Variable of (*name*) ident - | Bin_expr of (*oper*) binary_operator * (*fst*) expr * (*snd*) expr + | Bin_expr of (*oper*) binary_operator * (*fst expr*) expr * (*snd expr*) expr | If_then_else of (*condition*) expr * (*then body*) expr list * (*else body*) expr list option - | Function of (*rec/no rec*) function_flag * (*name*) string option * (*args*) expr list * (*body*) expr list + | Function of (*special characteristic*) function_flag * (*name*) string option * (*args*) expr list * (*body*) expr list | Function_call of (*name*) string * (*args*) expr list - | Let of (*name*) ident * (*value*) expr (* * (*body*) expr list *) + | Let of (*name*) ident * (*value*) expr From 73b5059a5f25ed743728ff1604bda957af083a53 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 14:19:59 +0300 Subject: [PATCH 016/310] fix: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/AST.ml | 22 +++++++++++++++------- FSharpActivePatterns/lib/printAST.ml | 13 +++++++------ 2 files changed, 22 insertions(+), 13 deletions(-) diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index 2ed5e1807..a0b2f407a 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -4,8 +4,8 @@ type ident = Ident of string -type literal = - | Int_lt of int +type literal = + | Int_lt of int | Bool_lt of bool | String_lt of string | Unit_lt @@ -28,19 +28,27 @@ type binary_operator = | Binary_and_bitwise type unary_operator = - | Unary_plus + | Unary_plus | Unary_minus | Unary_negative -type function_flag = - | None +type function_flag = + | None | Rec (* recursion flag *) type expr = | Const of literal | Variable of (*name*) ident | Bin_expr of (*oper*) binary_operator * (*fst expr*) expr * (*snd expr*) expr - | If_then_else of (*condition*) expr * (*then body*) expr list * (*else body*) expr list option - | Function of (*special characteristic*) function_flag * (*name*) string option * (*args*) expr list * (*body*) expr list + | If_then_else of + (*condition*) expr * (*then body*) expr list * (*else body*) expr list option + | Function of + (*special characteristic*) function_flag + * (*name*) + string option + * (*args*) + expr list + * (*body*) + expr list | Function_call of (*name*) string * (*args*) expr list | Let of (*name*) ident * (*value*) expr diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index 6c510a815..62657be49 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -7,7 +7,8 @@ open AST let rec print_expr indent = function | Const (Int_lt i) -> Printf.printf "%s| Const(Int: %d)\n" (String.make indent '-') i | Const (Bool_lt b) -> Printf.printf "%s| Const(Bool: %b)\n" (String.make indent '-') b - | Const (String_lt s) -> Printf.printf "%s| Const(String: \"%s\")\n" (String.make indent '-') s + | Const (String_lt s) -> + Printf.printf "%s| Const(String: \"%s\")\n" (String.make indent '-') s | Const Unit_lt -> Printf.printf "%s| Const(Unit)\n" (String.make indent '-') | Variable (Ident name) -> Printf.printf "%s| Variable(%s)\n" (String.make indent '-') name @@ -24,15 +25,15 @@ let rec print_expr indent = function List.iter (print_expr (indent + 4)) then_body; Printf.printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); (match else_body with - | Some body -> List.iter (print_expr (indent + 4)) body - | None -> Printf.printf "No else body") + | Some body -> List.iter (print_expr (indent + 4)) body + | None -> Printf.printf "No else body") | Function (flag, name, args, body) -> Printf.printf "%s| %s Function(%s):\n" (String.make indent '-') - (match flag with - | None -> "" - | Rec -> "Rec") + (match flag with + | None -> "" + | Rec -> "Rec") (match name with | Some n -> n | None -> "Anonymous"); From 935040f23a6bdd2d0e6710c1582a3ba0dbbfa954 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 14:31:54 +0300 Subject: [PATCH 017/310] fix: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/exec.ml | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/bin/exec.ml b/FSharpActivePatterns/bin/exec.ml index 4da645d90..d48940fbe 100644 --- a/FSharpActivePatterns/bin/exec.ml +++ b/FSharpActivePatterns/bin/exec.ml @@ -5,7 +5,7 @@ open Fsharp_active_patterns_lib.AST open Fsharp_active_patterns_lib.PrintAST -let() = +let () = let factorial = Function ( Rec @@ -17,13 +17,16 @@ let() = , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 0)) , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 1)) ) , [ Const (Int_lt 1) ] - , Some([ Bin_expr - ( Binary_multiply - , Variable (Ident "n") - , Function_call - ( "factorial" - , [ Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) ] ) ) - ]) ) + , Some + [ Bin_expr + ( Binary_multiply + , Variable (Ident "n") + , Function_call + ( "factorial" + , [ Bin_expr + (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) + ] ) ) + ] ) ] ) in let program = From 100595a1e6c3bfadd52fef05b6178a5f4be987eb Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 1 Oct 2024 15:48:36 +0300 Subject: [PATCH 018/310] feat: implement tuple type of expression and devide definition/declaration of functions Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/exec.ml | 2 +- FSharpActivePatterns/lib/AST.ml | 5 ++++- FSharpActivePatterns/lib/printAST.ml | 14 +++++++++++++- 3 files changed, 18 insertions(+), 3 deletions(-) diff --git a/FSharpActivePatterns/bin/exec.ml b/FSharpActivePatterns/bin/exec.ml index d48940fbe..658a6ac74 100644 --- a/FSharpActivePatterns/bin/exec.ml +++ b/FSharpActivePatterns/bin/exec.ml @@ -7,7 +7,7 @@ open Fsharp_active_patterns_lib.PrintAST let () = let factorial = - Function + Function_def ( Rec , Some "factorial" , [ Variable (Ident "n") ] diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index a0b2f407a..75808b985 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -38,11 +38,12 @@ type function_flag = type expr = | Const of literal + | Tuple of expr list | Variable of (*name*) ident | Bin_expr of (*oper*) binary_operator * (*fst expr*) expr * (*snd expr*) expr | If_then_else of (*condition*) expr * (*then body*) expr list * (*else body*) expr list option - | Function of + | Function_def of (*special characteristic*) function_flag * (*name*) string option @@ -50,5 +51,7 @@ type expr = expr list * (*body*) expr list + | Function_dec of + (*special characteristic*) function_flag * (*name*) string * (*args*) expr list | Function_call of (*name*) string * (*args*) expr list | Let of (*name*) ident * (*value*) expr diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index 62657be49..d4632479b 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -10,6 +10,7 @@ let rec print_expr indent = function | Const (String_lt s) -> Printf.printf "%s| Const(String: \"%s\")\n" (String.make indent '-') s | Const Unit_lt -> Printf.printf "%s| Const(Unit)\n" (String.make indent '-') + | Tuple list -> List.iter (print_expr indent) list | Variable (Ident name) -> Printf.printf "%s| Variable(%s)\n" (String.make indent '-') name | Bin_expr (op, left, right) -> @@ -27,7 +28,7 @@ let rec print_expr indent = function (match else_body with | Some body -> List.iter (print_expr (indent + 4)) body | None -> Printf.printf "No else body") - | Function (flag, name, args, body) -> + | Function_def (flag, name, args, body) -> Printf.printf "%s| %s Function(%s):\n" (String.make indent '-') @@ -41,8 +42,19 @@ let rec print_expr indent = function List.iter (print_expr (indent + 4)) args; Printf.printf "%sBODY\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 4)) body + | Function_dec (flag, name, args) -> + Printf.printf + "%s| %s Function Declaration(%s):\n" + (String.make indent '-') + (match flag with + | None -> "" + | Rec -> "Rec") + name; + Printf.printf "%sARGS\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 2)) args | Function_call (name, args) -> Printf.printf "%s| Function Call(%s):\n" (String.make indent '-') name; + Printf.printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 2)) args | Let (Ident name, value) -> Printf.printf "%s| Let %s =\n" (String.make indent '-') name; From 4be022b2afa75629275369eeadd748a35453c918 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 1 Oct 2024 17:52:23 +0300 Subject: [PATCH 019/310] test: add print_expr test Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/tests/dune | 3 ++ FSharpActivePatterns/tests/print_expr.t | 38 +++++++++++++++++++++++++ 2 files changed, 41 insertions(+) create mode 100644 FSharpActivePatterns/tests/dune create mode 100644 FSharpActivePatterns/tests/print_expr.t diff --git a/FSharpActivePatterns/tests/dune b/FSharpActivePatterns/tests/dune new file mode 100644 index 000000000..4f32d99ea --- /dev/null +++ b/FSharpActivePatterns/tests/dune @@ -0,0 +1,3 @@ +(cram + (applies_to print_expr) + (deps ../bin/exec.exe)) diff --git a/FSharpActivePatterns/tests/print_expr.t b/FSharpActivePatterns/tests/print_expr.t new file mode 100644 index 000000000..41abea324 --- /dev/null +++ b/FSharpActivePatterns/tests/print_expr.t @@ -0,0 +1,38 @@ +(** Copyright 2021-2024, Ksenia Kotelnikova, Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + + $ ../bin/exec.exe + | Let a = + --| Const(Int: 10) + | Rec Function(factorial): + ARGS + ----| Variable(n) + BODY + ----| If Then Else( + CONDITION + ------| Binary expr( + ------| Logical Or + --------| Binary expr( + --------| Binary Equal + ----------| Variable(n) + ----------| Const(Int: 0) + --------| Binary expr( + --------| Binary Equal + ----------| Variable(n) + ----------| Const(Int: 1) + THEN BRANCH + --------| Const(Int: 1) + ELSE BRANCH + --------| Binary expr( + --------| Binary Multiply + ----------| Variable(n) + ----------| Function Call(factorial): + ARGS + ------------| Binary expr( + ------------| Binary Subtract + --------------| Variable(n) + --------------| Const(Int: 1) + | Function Call(factorial): + ARGS + --| Variable(a) From 668a964581a1a47e545d4630100f0131027d3d35 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 1 Oct 2024 23:57:21 +0300 Subject: [PATCH 020/310] ref: print_expr and print_bin_op --- FSharpActivePatterns/lib/printAST.ml | 81 ++++++++++++++-------------- 1 file changed, 40 insertions(+), 41 deletions(-) diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index d4632479b..8671fafd8 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -4,32 +4,32 @@ open AST -let rec print_expr indent = function - | Const (Int_lt i) -> Printf.printf "%s| Const(Int: %d)\n" (String.make indent '-') i - | Const (Bool_lt b) -> Printf.printf "%s| Const(Bool: %b)\n" (String.make indent '-') b - | Const (String_lt s) -> - Printf.printf "%s| Const(String: \"%s\")\n" (String.make indent '-') s - | Const Unit_lt -> Printf.printf "%s| Const(Unit)\n" (String.make indent '-') +let rec print_expr indent expr = + let open Printf in + match expr with + | Const (Int_lt i) -> printf "%s| Const(Int: %d)\n" (String.make indent '-') i + | Const (Bool_lt b) -> printf "%s| Const(Bool: %b)\n" (String.make indent '-') b + | Const (String_lt s) -> printf "%s| Const(String: \"%s\")\n" (String.make indent '-') s + | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') | Tuple list -> List.iter (print_expr indent) list - | Variable (Ident name) -> - Printf.printf "%s| Variable(%s)\n" (String.make indent '-') name + | Variable (Ident name) -> printf "%s| Variable(%s)\n" (String.make indent '-') name | Bin_expr (op, left, right) -> - Printf.printf "%s| Binary expr(\n" (String.make indent '-'); + printf "%s| Binary expr(\n" (String.make indent '-'); print_bin_op indent op; print_expr (indent + 2) left; print_expr (indent + 2) right | If_then_else (cond, then_body, else_body) -> - Printf.printf "%s| If Then Else(\n" (String.make indent '-'); - Printf.printf "%sCONDITION\n" (String.make indent ' '); + printf "%s| If Then Else(\n" (String.make indent '-'); + printf "%sCONDITION\n" (String.make indent ' '); print_expr (indent + 2) cond; - Printf.printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); + printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 4)) then_body; - Printf.printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); + printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); (match else_body with | Some body -> List.iter (print_expr (indent + 4)) body - | None -> Printf.printf "No else body") + | None -> printf "No else body") | Function_def (flag, name, args, body) -> - Printf.printf + printf "%s| %s Function(%s):\n" (String.make indent '-') (match flag with @@ -38,46 +38,45 @@ let rec print_expr indent = function (match name with | Some n -> n | None -> "Anonymous"); - Printf.printf "%sARGS\n" (String.make (indent + 2) ' '); + printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 4)) args; - Printf.printf "%sBODY\n" (String.make (indent + 2) ' '); + printf "%sBODY\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 4)) body | Function_dec (flag, name, args) -> - Printf.printf + printf "%s| %s Function Declaration(%s):\n" (String.make indent '-') (match flag with | None -> "" | Rec -> "Rec") name; - Printf.printf "%sARGS\n" (String.make (indent + 2) ' '); + printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 2)) args | Function_call (name, args) -> - Printf.printf "%s| Function Call(%s):\n" (String.make indent '-') name; - Printf.printf "%sARGS\n" (String.make (indent + 2) ' '); + printf "%s| Function Call(%s):\n" (String.make indent '-') name; + printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 2)) args | Let (Ident name, value) -> - Printf.printf "%s| Let %s =\n" (String.make indent '-') name; + printf "%s| Let %s =\n" (String.make indent '-') name; print_expr (indent + 2) value -and print_bin_op indent = function - | Binary_equal -> Printf.printf "%s| Binary Equal\n" (String.make indent '-') - | Binary_unequal -> Printf.printf "%s| Binary Unequal\n" (String.make indent '-') - | Binary_less -> Printf.printf "%s| Binary Less\n" (String.make indent '-') - | Binary_less_or_equal -> - Printf.printf "%s| Binary Less Or Equal\n" (String.make indent ' ') - | Binary_greater -> Printf.printf "%s| Binary Greater\n" (String.make indent '-') +and print_bin_op indent bin_op = + let open Printf in + match bin_op with + | Binary_equal -> printf "%s| Binary Equal\n" (String.make indent '-') + | Binary_unequal -> printf "%s| Binary Unequal\n" (String.make indent '-') + | Binary_less -> printf "%s| Binary Less\n" (String.make indent '-') + | Binary_less_or_equal -> printf "%s| Binary Less Or Equal\n" (String.make indent ' ') + | Binary_greater -> printf "%s| Binary Greater\n" (String.make indent '-') | Binary_greater_or_equal -> - Printf.printf "%s| Binary Greater Or Equal\n" (String.make indent '-') - | Binary_add -> Printf.printf "%s| Binary Add\n" (String.make indent '-') - | Binary_subtract -> Printf.printf "%s| Binary Subtract\n" (String.make indent '-') - | Binary_multiply -> Printf.printf "%s| Binary Multiply\n" (String.make indent '-') - | Logical_or -> Printf.printf "%s| Logical Or\n" (String.make indent '-') - | Logical_and -> Printf.printf "%s| Logical And\n" (String.make indent '-') - | Binary_divide -> Printf.printf "%s| Binary Divide\n" (String.make indent '-') - | Binary_or_bitwise -> Printf.printf "%s| Binary Or Bitwise\n" (String.make indent '-') - | Binary_xor_bitwise -> - Printf.printf "%s| Binary Xor Bitwise\n" (String.make indent '-') - | Binary_and_bitwise -> - Printf.printf "%s| Binary And Bitwise\n" (String.make indent '-') + printf "%s| Binary Greater Or Equal\n" (String.make indent '-') + | Binary_add -> printf "%s| Binary Add\n" (String.make indent '-') + | Binary_subtract -> printf "%s| Binary Subtract\n" (String.make indent '-') + | Binary_multiply -> printf "%s| Binary Multiply\n" (String.make indent '-') + | Logical_or -> printf "%s| Logical Or\n" (String.make indent '-') + | Logical_and -> printf "%s| Logical And\n" (String.make indent '-') + | Binary_divide -> printf "%s| Binary Divide\n" (String.make indent '-') + | Binary_or_bitwise -> printf "%s| Binary Or Bitwise\n" (String.make indent '-') + | Binary_xor_bitwise -> printf "%s| Binary Xor Bitwise\n" (String.make indent '-') + | Binary_and_bitwise -> printf "%s| Binary And Bitwise\n" (String.make indent '-') ;; From f311d036db68ce7d02b153d5b15295568d8226d5 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Wed, 2 Oct 2024 19:54:18 +0300 Subject: [PATCH 021/310] fix: printAST indent Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/printAST.ml | 2 +- FSharpActivePatterns/tests/print_expr.t | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index 8671fafd8..24b404aec 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -20,7 +20,7 @@ let rec print_expr indent expr = print_expr (indent + 2) right | If_then_else (cond, then_body, else_body) -> printf "%s| If Then Else(\n" (String.make indent '-'); - printf "%sCONDITION\n" (String.make indent ' '); + printf "%sCONDITION\n" (String.make (indent + 2) ' '); print_expr (indent + 2) cond; printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 4)) then_body; diff --git a/FSharpActivePatterns/tests/print_expr.t b/FSharpActivePatterns/tests/print_expr.t index 41abea324..1e66e3a95 100644 --- a/FSharpActivePatterns/tests/print_expr.t +++ b/FSharpActivePatterns/tests/print_expr.t @@ -10,7 +10,7 @@ ----| Variable(n) BODY ----| If Then Else( - CONDITION + CONDITION ------| Binary expr( ------| Logical Or --------| Binary expr( From d480b6a50354d0eb95ba181be7655b1d8c40cfd8 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Wed, 2 Oct 2024 20:00:54 +0300 Subject: [PATCH 022/310] docs: fix AST doc comments Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/AST.ml | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index 75808b985..3fb2374cc 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -39,19 +39,12 @@ type function_flag = type expr = | Const of literal | Tuple of expr list - | Variable of (*name*) ident - | Bin_expr of (*oper*) binary_operator * (*fst expr*) expr * (*snd expr*) expr - | If_then_else of - (*condition*) expr * (*then body*) expr list * (*else body*) expr list option - | Function_def of - (*special characteristic*) function_flag - * (*name*) - string option - * (*args*) - expr list - * (*body*) - expr list - | Function_dec of - (*special characteristic*) function_flag * (*name*) string * (*args*) expr list - | Function_call of (*name*) string * (*args*) expr list - | Let of (*name*) ident * (*value*) expr + | Variable of ident + | Bin_expr of binary_operator * expr * expr (**operator, first operand, second operand*) + | If_then_else of expr * expr list * expr list option + (**condition, then body, else body*) + | Function_def of function_flag * string option * expr list * expr list + (**rec, name, body*) + | Function_dec of function_flag * string * expr list (**rec, name, args*) + | Function_call of string * expr list (**name, args*) + | Let of ident * expr (**name, expr*) From 80bfe93f89024e7bb265ad5d080e799a5e159688 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Wed, 2 Oct 2024 20:29:34 +0300 Subject: [PATCH 023/310] ref: change constructor name to avoid shadowing Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/AST.ml | 11 +++++------ FSharpActivePatterns/lib/printAST.ml | 4 ++-- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/AST.ml index 3fb2374cc..01f24c7f3 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/AST.ml @@ -32,9 +32,9 @@ type unary_operator = | Unary_minus | Unary_negative -type function_flag = - | None - | Rec (* recursion flag *) +type recursive = + | Nonrec + | Rec (**recursion flag*) type expr = | Const of literal @@ -43,8 +43,7 @@ type expr = | Bin_expr of binary_operator * expr * expr (**operator, first operand, second operand*) | If_then_else of expr * expr list * expr list option (**condition, then body, else body*) - | Function_def of function_flag * string option * expr list * expr list - (**rec, name, body*) - | Function_dec of function_flag * string * expr list (**rec, name, args*) + | Function_def of recursive * string option * expr list * expr list (**rec, name, body*) + | Function_dec of recursive * string * expr list (**rec, name, args*) | Function_call of string * expr list (**name, args*) | Let of ident * expr (**name, expr*) diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index 24b404aec..8c610b42a 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -33,7 +33,7 @@ let rec print_expr indent expr = "%s| %s Function(%s):\n" (String.make indent '-') (match flag with - | None -> "" + | Nonrec -> "" | Rec -> "Rec") (match name with | Some n -> n @@ -47,7 +47,7 @@ let rec print_expr indent expr = "%s| %s Function Declaration(%s):\n" (String.make indent '-') (match flag with - | None -> "" + | Nonrec -> "" | Rec -> "Rec") name; printf "%sARGS\n" (String.make (indent + 2) ' '); From 65fa43e3fce59181b3f91ad97d224684fc6241c8 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Wed, 2 Oct 2024 20:37:36 +0300 Subject: [PATCH 024/310] fix: print string literal with %S instead of %s Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/printAST.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAST.ml index 8c610b42a..16ee1fc63 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAST.ml @@ -9,7 +9,7 @@ let rec print_expr indent expr = match expr with | Const (Int_lt i) -> printf "%s| Const(Int: %d)\n" (String.make indent '-') i | Const (Bool_lt b) -> printf "%s| Const(Bool: %b)\n" (String.make indent '-') b - | Const (String_lt s) -> printf "%s| Const(String: \"%s\")\n" (String.make indent '-') s + | Const (String_lt s) -> printf "%s| Const(String: \"%S\")\n" (String.make indent '-') s | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') | Tuple list -> List.iter (print_expr indent) list | Variable (Ident name) -> printf "%s| Variable(%s)\n" (String.make indent '-') name From e8314374b43847dfee541d3a1df44cda8dd4b01d Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 3 Oct 2024 13:21:05 +0300 Subject: [PATCH 025/310] Add Makefile, fix test coverage, add more printAst tests, fix docs * build: add Makefile Signed-off-by: Gleb Nasretdinov * ref: modules and executable renaming Signed-off-by: Gleb Nasretdinov * build: add instruments and preprocess Signed-off-by: Gleb Nasretdinov * test: add print_bin_op test Signed-off-by: Gleb Nasretdinov * docs: add args to Function_def doc comment Signed-off-by: Gleb Nasretdinov --------- Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/Makefile | 49 +++++++++++++++++ FSharpActivePatterns/bin/dune | 8 +-- FSharpActivePatterns/bin/{exec.ml => main.ml} | 4 +- FSharpActivePatterns/lib/{AST.ml => ast.ml} | 3 +- FSharpActivePatterns/lib/dune | 10 ++-- .../lib/{printAST.ml => printAst.ml} | 2 +- FSharpActivePatterns/tests/dune | 11 +++- FSharpActivePatterns/tests/print_ast.ml | 53 +++++++++++++++++++ .../tests/{print_expr.t => print_ast.t} | 2 +- 9 files changed, 130 insertions(+), 12 deletions(-) create mode 100644 FSharpActivePatterns/Makefile rename FSharpActivePatterns/bin/{exec.ml => main.ml} (93%) rename FSharpActivePatterns/lib/{AST.ml => ast.ml} (97%) rename FSharpActivePatterns/lib/{printAST.ml => printAst.ml} (99%) create mode 100644 FSharpActivePatterns/tests/print_ast.ml rename FSharpActivePatterns/tests/{print_expr.t => print_ast.t} (97%) diff --git a/FSharpActivePatterns/Makefile b/FSharpActivePatterns/Makefile new file mode 100644 index 000000000..79fbb624c --- /dev/null +++ b/FSharpActivePatterns/Makefile @@ -0,0 +1,49 @@ +.PHONY: repl tests test fmt lint celan + +all: + dune build + +repl: + dune build ./REPL.exe && rlwrap _build/default/REPL.exe + +tests: test +test: + dune runtest + +celan: clean +clean: + @$(RM) -r _build _coverage + +fmt: + dune build @fmt --auto-promote + +lint: + dune build @lint --force + +release: + dune build --profile=release + dune runtest --profile=release + +install: + dune b @install --profile=release + dune install + +ODIG_SWITCHES = --odoc-theme=odig.gruvbox.light +ODIG_SWITCHES += --no-tag-index +ODIG_SWITCHES += --no-pkg-deps +odig: + odig odoc $(ODIG_SWITCHES) Lambda + +TEST_COV_D = /tmp/cov +COVERAGE_OPTS = --coverage-path $(TEST_COV_D) --expect lib/ --expect tests/ + +.PHONY: test_coverage coverage +test_coverage: coverage +coverage: + $(RM) -r $(TEST_COV_D) + mkdir -p $(TEST_COV_D) + BISECT_FILE=$(TEST_COV_D)/langauge dune runtest --no-print-directory \ + --instrument-with bisect_ppx --force + bisect-ppx-report html $(COVERAGE_OPTS) + bisect-ppx-report summary $(COVERAGE_OPTS) + @echo "Use 'xdg-open _coverage/index.html' to see coverage report" diff --git a/FSharpActivePatterns/bin/dune b/FSharpActivePatterns/bin/dune index 53a7b565d..f145ccfcc 100644 --- a/FSharpActivePatterns/bin/dune +++ b/FSharpActivePatterns/bin/dune @@ -1,4 +1,6 @@ (executable - (public_name exec) - (name exec) - (libraries fsharp_active_patterns_lib)) + (public_name main) + (name main) + (libraries FSharpActivePatterns) + (instrumentation + (backend bisect_ppx))) diff --git a/FSharpActivePatterns/bin/exec.ml b/FSharpActivePatterns/bin/main.ml similarity index 93% rename from FSharpActivePatterns/bin/exec.ml rename to FSharpActivePatterns/bin/main.ml index 658a6ac74..6d0f70883 100644 --- a/FSharpActivePatterns/bin/exec.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -2,8 +2,8 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open Fsharp_active_patterns_lib.AST -open Fsharp_active_patterns_lib.PrintAST +open FSharpActivePatterns.Ast +open FSharpActivePatterns.PrintAst let () = let factorial = diff --git a/FSharpActivePatterns/lib/AST.ml b/FSharpActivePatterns/lib/ast.ml similarity index 97% rename from FSharpActivePatterns/lib/AST.ml rename to FSharpActivePatterns/lib/ast.ml index 01f24c7f3..d853f0d27 100644 --- a/FSharpActivePatterns/lib/AST.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -43,7 +43,8 @@ type expr = | Bin_expr of binary_operator * expr * expr (**operator, first operand, second operand*) | If_then_else of expr * expr list * expr list option (**condition, then body, else body*) - | Function_def of recursive * string option * expr list * expr list (**rec, name, body*) + | Function_def of recursive * string option * expr list * expr list + (**rec, name, args, body*) | Function_dec of recursive * string * expr list (**rec, name, args*) | Function_call of string * expr list (**name, args*) | Let of ident * expr (**name, expr*) diff --git a/FSharpActivePatterns/lib/dune b/FSharpActivePatterns/lib/dune index 4e85ca0b2..a29a17737 100644 --- a/FSharpActivePatterns/lib/dune +++ b/FSharpActivePatterns/lib/dune @@ -1,4 +1,8 @@ (library - (name fsharp_active_patterns_lib) - (public_name FSharpActivePatterns.Lib) - (modules AST PrintAST)) + (name FSharpActivePatterns) + (public_name FSharpActivePatterns) + (modules Ast PrintAst) + (preprocess + (pps ppx_deriving.show ppx_deriving.eq)) + (instrumentation + (backend bisect_ppx))) diff --git a/FSharpActivePatterns/lib/printAST.ml b/FSharpActivePatterns/lib/printAst.ml similarity index 99% rename from FSharpActivePatterns/lib/printAST.ml rename to FSharpActivePatterns/lib/printAst.ml index 16ee1fc63..1b51aca3f 100644 --- a/FSharpActivePatterns/lib/printAST.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -2,7 +2,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open AST +open Ast let rec print_expr indent expr = let open Printf in diff --git a/FSharpActivePatterns/tests/dune b/FSharpActivePatterns/tests/dune index 4f32d99ea..88fedb127 100644 --- a/FSharpActivePatterns/tests/dune +++ b/FSharpActivePatterns/tests/dune @@ -1,3 +1,12 @@ +(library + (name tests) + (libraries base stdio FSharpActivePatterns) + (inline_tests) + (preprocess + (pps ppx_inline_test ppx_expect)) + (instrumentation + (backend bisect_ppx))) + (cram (applies_to print_expr) - (deps ../bin/exec.exe)) + (deps ../bin/main.exe)) diff --git a/FSharpActivePatterns/tests/print_ast.ml b/FSharpActivePatterns/tests/print_ast.ml new file mode 100644 index 000000000..1b898d98a --- /dev/null +++ b/FSharpActivePatterns/tests/print_ast.ml @@ -0,0 +1,53 @@ +open FSharpActivePatterns.Ast +open FSharpActivePatterns.PrintAst + +let%expect_test "print double func" = + let recursive = Nonrec in + let name = Some "double" in + let var = Variable (Ident "n") in + let args = [ var ] in + let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), var) in + let double = Function_def (recursive, name, args, [ binary_expr ]) in + print_expr 0 double; + [%expect + {| + | Function(double): + ARGS + ----| Variable(n) + BODY + ----| Binary expr( + ----| Binary Multiply + ------| Const(Int: 2) + ------| Variable(n)|}] +;; + +let%expect_test "print tuple of binary operators" = + let binary_operators = + [ Binary_unequal + ; Binary_less + ; Binary_less_or_equal + ; Binary_greater + ; Binary_greater_or_equal + ; Binary_add + ; Logical_and + ; Binary_divide + ; Binary_or_bitwise + ; Binary_xor_bitwise + ; Binary_and_bitwise + ] + in + List.iter (print_bin_op 0) binary_operators; + [%expect + {| + | Binary Unequal + | Binary Less + | Binary Less Or Equal + | Binary Greater + | Binary Greater Or Equal + | Binary Add + | Logical And + | Binary Divide + | Binary Or Bitwise + | Binary Xor Bitwise + | Binary And Bitwise |}] +;; diff --git a/FSharpActivePatterns/tests/print_expr.t b/FSharpActivePatterns/tests/print_ast.t similarity index 97% rename from FSharpActivePatterns/tests/print_expr.t rename to FSharpActivePatterns/tests/print_ast.t index 1e66e3a95..5ed054e6e 100644 --- a/FSharpActivePatterns/tests/print_expr.t +++ b/FSharpActivePatterns/tests/print_ast.t @@ -2,7 +2,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) - $ ../bin/exec.exe + $ ../bin/main.exe | Let a = --| Const(Int: 10) | Rec Function(factorial): From f85a2a91a82fa2a4eaa3b472776ebb32c5e8f6eb Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 3 Oct 2024 15:30:28 +0300 Subject: [PATCH 026/310] test: fix cram deps in tests/dune Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/tests/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/tests/dune b/FSharpActivePatterns/tests/dune index 88fedb127..79e2e6e71 100644 --- a/FSharpActivePatterns/tests/dune +++ b/FSharpActivePatterns/tests/dune @@ -8,5 +8,5 @@ (backend bisect_ppx))) (cram - (applies_to print_expr) + (applies_to print_ast) (deps ../bin/main.exe)) From cf8aa65444e498fb95d188970335abbf1ed13017 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 3 Oct 2024 21:04:08 +0300 Subject: [PATCH 027/310] feat: Ast - add LetIn, change expr list to expr in Let Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 10 +++++----- FSharpActivePatterns/lib/printAst.ml | 16 ++++++---------- 2 files changed, 11 insertions(+), 15 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index d853f0d27..921055f4e 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -32,9 +32,9 @@ type unary_operator = | Unary_minus | Unary_negative -type recursive = +type is_recursive = | Nonrec - | Rec (**recursion flag*) + | Rec type expr = | Const of literal @@ -43,8 +43,8 @@ type expr = | Bin_expr of binary_operator * expr * expr (**operator, first operand, second operand*) | If_then_else of expr * expr list * expr list option (**condition, then body, else body*) - | Function_def of recursive * string option * expr list * expr list + | Function_def of is_recursive * string option * expr list * expr list (**rec, name, args, body*) - | Function_dec of recursive * string * expr list (**rec, name, args*) | Function_call of string * expr list (**name, args*) - | Let of ident * expr (**name, expr*) + | Let of ident * expr (**name, value*) + | LetIn of ident * expr * expr (**name, value, inner value*) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 1b51aca3f..36f92ac9a 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -42,16 +42,6 @@ let rec print_expr indent expr = List.iter (print_expr (indent + 4)) args; printf "%sBODY\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 4)) body - | Function_dec (flag, name, args) -> - printf - "%s| %s Function Declaration(%s):\n" - (String.make indent '-') - (match flag with - | Nonrec -> "" - | Rec -> "Rec") - name; - printf "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 2)) args | Function_call (name, args) -> printf "%s| Function Call(%s):\n" (String.make indent '-') name; printf "%sARGS\n" (String.make (indent + 2) ' '); @@ -59,6 +49,12 @@ let rec print_expr indent expr = | Let (Ident name, value) -> printf "%s| Let %s =\n" (String.make indent '-') name; print_expr (indent + 2) value + | LetIn (Ident name, value, inner_expr) -> + printf "%s | LetIn %s =\n" (String.make indent '-') name; + printf "%sVALUE\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) value; + printf "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) inner_expr and print_bin_op indent bin_op = let open Printf in From 45f337a6cc7d5071be58d5d4b562997df353d017 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 3 Oct 2024 21:59:50 +0300 Subject: [PATCH 028/310] build: disable 66 warning (misfire on unused open) --- FSharpActivePatterns/dune | 2 +- FSharpActivePatterns/tests/print_ast.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/FSharpActivePatterns/dune b/FSharpActivePatterns/dune index 98e54536a..62e01c89e 100644 --- a/FSharpActivePatterns/dune +++ b/FSharpActivePatterns/dune @@ -4,4 +4,4 @@ (:standard -alert @deprecated -warn-error -A -w -3-9-32-34-58))) (release (flags - (:standard -alert @deprecated -warn-error +A -w +A-4-40-42-44-70)))) + (:standard -alert @deprecated -warn-error +A -w +A-4-40-42-44-70-66)))) diff --git a/FSharpActivePatterns/tests/print_ast.ml b/FSharpActivePatterns/tests/print_ast.ml index 1b898d98a..ebc89b4f6 100644 --- a/FSharpActivePatterns/tests/print_ast.ml +++ b/FSharpActivePatterns/tests/print_ast.ml @@ -1,5 +1,5 @@ -open FSharpActivePatterns.Ast -open FSharpActivePatterns.PrintAst +open! FSharpActivePatterns.Ast +open! FSharpActivePatterns.PrintAst let%expect_test "print double func" = let recursive = Nonrec in From 0b3d466f0681b5c3d8128092153cb82498c43482 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 3 Oct 2024 23:27:37 +0300 Subject: [PATCH 029/310] fix: print string literals in print_expr Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/printAst.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 36f92ac9a..5d38bc46b 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -9,7 +9,7 @@ let rec print_expr indent expr = match expr with | Const (Int_lt i) -> printf "%s| Const(Int: %d)\n" (String.make indent '-') i | Const (Bool_lt b) -> printf "%s| Const(Bool: %b)\n" (String.make indent '-') b - | Const (String_lt s) -> printf "%s| Const(String: \"%S\")\n" (String.make indent '-') s + | Const (String_lt s) -> printf "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') | Tuple list -> List.iter (print_expr indent) list | Variable (Ident name) -> printf "%s| Variable(%s)\n" (String.make indent '-') name From e6d3525129d8930bd580f9bb9f4777854f3738c1 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 4 Oct 2024 00:49:36 +0300 Subject: [PATCH 030/310] chore: fix license information Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 2 +- FSharpActivePatterns/lib/ast.ml | 2 +- FSharpActivePatterns/lib/printAst.ml | 2 +- FSharpActivePatterns/tests/print_ast.ml | 4 ++++ FSharpActivePatterns/tests/print_ast.t | 2 +- 5 files changed, 8 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 6d0f70883..3eb08e73b 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -1,4 +1,4 @@ -(** Copyright 2024, Ksenia Kotelnikova , Gleb Nasretdinov *) +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 921055f4e..882a3a29f 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -1,4 +1,4 @@ -(** Copyright 2024, Ksenia Kotelnikova , Gleb Nasretdinov *) +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 5d38bc46b..0ea828a0b 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -1,4 +1,4 @@ -(** Copyright 2024, Ksenia Kotelnikova , Gleb Nasretdinov *) +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/FSharpActivePatterns/tests/print_ast.ml b/FSharpActivePatterns/tests/print_ast.ml index ebc89b4f6..b7e31719b 100644 --- a/FSharpActivePatterns/tests/print_ast.ml +++ b/FSharpActivePatterns/tests/print_ast.ml @@ -1,3 +1,7 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + open! FSharpActivePatterns.Ast open! FSharpActivePatterns.PrintAst diff --git a/FSharpActivePatterns/tests/print_ast.t b/FSharpActivePatterns/tests/print_ast.t index 5ed054e6e..8a7b48b28 100644 --- a/FSharpActivePatterns/tests/print_ast.t +++ b/FSharpActivePatterns/tests/print_ast.t @@ -1,4 +1,4 @@ -(** Copyright 2021-2024, Ksenia Kotelnikova, Gleb Nasretdinov *) +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) From c6d05832b8e60926dd3240e65de6a8302baecd5e Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 4 Oct 2024 02:17:29 +0300 Subject: [PATCH 031/310] test: return warning '66', move unit tests to /lib/tests, created .mli Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/dune | 2 +- FSharpActivePatterns/lib/{ast.ml => ast.mli} | 0 FSharpActivePatterns/lib/dune | 1 + FSharpActivePatterns/lib/printAst.mli | 7 ++ FSharpActivePatterns/lib/tests/dune | 9 ++ FSharpActivePatterns/lib/tests/print_ast.ml | 90 ++++++++++++++++++++ FSharpActivePatterns/tests/dune | 9 -- FSharpActivePatterns/tests/print_ast.ml | 57 ------------- 8 files changed, 108 insertions(+), 67 deletions(-) rename FSharpActivePatterns/lib/{ast.ml => ast.mli} (100%) create mode 100644 FSharpActivePatterns/lib/printAst.mli create mode 100644 FSharpActivePatterns/lib/tests/dune create mode 100644 FSharpActivePatterns/lib/tests/print_ast.ml delete mode 100644 FSharpActivePatterns/tests/print_ast.ml diff --git a/FSharpActivePatterns/dune b/FSharpActivePatterns/dune index 62e01c89e..98e54536a 100644 --- a/FSharpActivePatterns/dune +++ b/FSharpActivePatterns/dune @@ -4,4 +4,4 @@ (:standard -alert @deprecated -warn-error -A -w -3-9-32-34-58))) (release (flags - (:standard -alert @deprecated -warn-error +A -w +A-4-40-42-44-70-66)))) + (:standard -alert @deprecated -warn-error +A -w +A-4-40-42-44-70)))) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.mli similarity index 100% rename from FSharpActivePatterns/lib/ast.ml rename to FSharpActivePatterns/lib/ast.mli diff --git a/FSharpActivePatterns/lib/dune b/FSharpActivePatterns/lib/dune index a29a17737..91a3144a9 100644 --- a/FSharpActivePatterns/lib/dune +++ b/FSharpActivePatterns/lib/dune @@ -2,6 +2,7 @@ (name FSharpActivePatterns) (public_name FSharpActivePatterns) (modules Ast PrintAst) + (modules_without_implementation ast) (preprocess (pps ppx_deriving.show ppx_deriving.eq)) (instrumentation diff --git a/FSharpActivePatterns/lib/printAst.mli b/FSharpActivePatterns/lib/printAst.mli new file mode 100644 index 000000000..d38bdb7e3 --- /dev/null +++ b/FSharpActivePatterns/lib/printAst.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast + +val print_expr : int -> expr -> unit diff --git a/FSharpActivePatterns/lib/tests/dune b/FSharpActivePatterns/lib/tests/dune new file mode 100644 index 000000000..a8c113927 --- /dev/null +++ b/FSharpActivePatterns/lib/tests/dune @@ -0,0 +1,9 @@ +(library + (name tests) + (modules Print_ast) + (libraries FSharpActivePatterns) + (preprocess + (pps ppx_expect ppx_deriving.show)) + (instrumentation + (backend bisect_ppx)) + (inline_tests)) diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml new file mode 100644 index 000000000..b0117d3c3 --- /dev/null +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -0,0 +1,90 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open FSharpActivePatterns.Ast +open FSharpActivePatterns.PrintAst + +let%expect_test "print double func" = + let recursive = Nonrec in + let name = Some "double" in + let var = Variable (Ident "n") in + let args = [ var ] in + let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), var) in + let double = Function_def (recursive, name, args, [ binary_expr ]) in + print_expr 0 double; + [%expect + {| + | Function(double): + ARGS + ----| Variable(n) + BODY + ----| Binary expr( + ----| Binary Multiply + ------| Const(Int: 2) + ------| Variable(n)|}] +;; + +let%expect_test "print tu ple of binary operators" = + let binary_operations = + [ Bin_expr (Binary_unequal, Const (Int_lt 3), Const (Int_lt 10)) + ; Bin_expr (Binary_less, Const (Int_lt 3), Const (Int_lt 10)) + ; Bin_expr (Binary_less_or_equal, Const (Int_lt 10), Const (Int_lt (-45))) + ; Bin_expr (Binary_greater, Const (Int_lt 3), Const (Int_lt 10)) + ; Bin_expr (Binary_greater_or_equal, Const (Int_lt 3), Const (Int_lt 10)) + ; Bin_expr (Binary_add, Const (Int_lt 3), Const (Int_lt 10)) + ; Bin_expr (Logical_and, Const (Int_lt 3), Const (Int_lt 10)) + ; Bin_expr (Binary_divide, Const (Int_lt 3), Const (Int_lt 10)) + ; Bin_expr (Binary_or_bitwise, Const (Int_lt 3), Const (Int_lt 10)) + ; Bin_expr (Binary_xor_bitwise, Const (Int_lt 3), Const (Int_lt 10)) + ; Bin_expr (Binary_and_bitwise, Const (Int_lt 3), Const (Int_lt 10)) + ] + in + List.iter (print_expr 0) binary_operations; + [%expect + {| + | Binary expr( + | Binary Unequal + --| Const(Int: 3) + --| Const(Int: 10) + | Binary expr( + | Binary Less + --| Const(Int: 3) + --| Const(Int: 10) + | Binary expr( + | Binary Less Or Equal + --| Const(Int: 10) + --| Const(Int: -45) + | Binary expr( + | Binary Greater + --| Const(Int: 3) + --| Const(Int: 10) + | Binary expr( + | Binary Greater Or Equal + --| Const(Int: 3) + --| Const(Int: 10) + | Binary expr( + | Binary Add + --| Const(Int: 3) + --| Const(Int: 10) + | Binary expr( + | Logical And + --| Const(Int: 3) + --| Const(Int: 10) + | Binary expr( + | Binary Divide + --| Const(Int: 3) + --| Const(Int: 10) + | Binary expr( + | Binary Or Bitwise + --| Const(Int: 3) + --| Const(Int: 10) + | Binary expr( + | Binary Xor Bitwise + --| Const(Int: 3) + --| Const(Int: 10) + | Binary expr( + | Binary And Bitwise + --| Const(Int: 3) + --| Const(Int: 10) |}] +;; diff --git a/FSharpActivePatterns/tests/dune b/FSharpActivePatterns/tests/dune index 79e2e6e71..7a37b28ce 100644 --- a/FSharpActivePatterns/tests/dune +++ b/FSharpActivePatterns/tests/dune @@ -1,12 +1,3 @@ -(library - (name tests) - (libraries base stdio FSharpActivePatterns) - (inline_tests) - (preprocess - (pps ppx_inline_test ppx_expect)) - (instrumentation - (backend bisect_ppx))) - (cram (applies_to print_ast) (deps ../bin/main.exe)) diff --git a/FSharpActivePatterns/tests/print_ast.ml b/FSharpActivePatterns/tests/print_ast.ml deleted file mode 100644 index b7e31719b..000000000 --- a/FSharpActivePatterns/tests/print_ast.ml +++ /dev/null @@ -1,57 +0,0 @@ -(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - -open! FSharpActivePatterns.Ast -open! FSharpActivePatterns.PrintAst - -let%expect_test "print double func" = - let recursive = Nonrec in - let name = Some "double" in - let var = Variable (Ident "n") in - let args = [ var ] in - let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), var) in - let double = Function_def (recursive, name, args, [ binary_expr ]) in - print_expr 0 double; - [%expect - {| - | Function(double): - ARGS - ----| Variable(n) - BODY - ----| Binary expr( - ----| Binary Multiply - ------| Const(Int: 2) - ------| Variable(n)|}] -;; - -let%expect_test "print tuple of binary operators" = - let binary_operators = - [ Binary_unequal - ; Binary_less - ; Binary_less_or_equal - ; Binary_greater - ; Binary_greater_or_equal - ; Binary_add - ; Logical_and - ; Binary_divide - ; Binary_or_bitwise - ; Binary_xor_bitwise - ; Binary_and_bitwise - ] - in - List.iter (print_bin_op 0) binary_operators; - [%expect - {| - | Binary Unequal - | Binary Less - | Binary Less Or Equal - | Binary Greater - | Binary Greater Or Equal - | Binary Add - | Logical And - | Binary Divide - | Binary Or Bitwise - | Binary Xor Bitwise - | Binary And Bitwise |}] -;; From 1fc1f75850ec1351328b9872f29d9eee03142f88 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 4 Oct 2024 02:27:48 +0300 Subject: [PATCH 032/310] feat: change printAst.mli and print_expr signature Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 2 +- FSharpActivePatterns/lib/printAst.ml | 69 +++++++++++---------- FSharpActivePatterns/lib/printAst.mli | 2 +- FSharpActivePatterns/lib/tests/print_ast.ml | 4 +- 4 files changed, 40 insertions(+), 37 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 3eb08e73b..561bd5880 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -35,5 +35,5 @@ let () = ; Function_call ("factorial", [ Variable (Ident "a") ]) ] in - List.iter (print_expr 0) program + List.iter print_expr program ;; diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 0ea828a0b..0678e357c 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -4,29 +4,50 @@ open Ast -let rec print_expr indent expr = +let print_bin_op indent bin_op = + let open Printf in + match bin_op with + | Binary_equal -> printf "%s| Binary Equal\n" (String.make indent '-') + | Binary_unequal -> printf "%s| Binary Unequal\n" (String.make indent '-') + | Binary_less -> printf "%s| Binary Less\n" (String.make indent '-') + | Binary_less_or_equal -> printf "%s| Binary Less Or Equal\n" (String.make indent ' ') + | Binary_greater -> printf "%s| Binary Greater\n" (String.make indent '-') + | Binary_greater_or_equal -> + printf "%s| Binary Greater Or Equal\n" (String.make indent '-') + | Binary_add -> printf "%s| Binary Add\n" (String.make indent '-') + | Binary_subtract -> printf "%s| Binary Subtract\n" (String.make indent '-') + | Binary_multiply -> printf "%s| Binary Multiply\n" (String.make indent '-') + | Logical_or -> printf "%s| Logical Or\n" (String.make indent '-') + | Logical_and -> printf "%s| Logical And\n" (String.make indent '-') + | Binary_divide -> printf "%s| Binary Divide\n" (String.make indent '-') + | Binary_or_bitwise -> printf "%s| Binary Or Bitwise\n" (String.make indent '-') + | Binary_xor_bitwise -> printf "%s| Binary Xor Bitwise\n" (String.make indent '-') + | Binary_and_bitwise -> printf "%s| Binary And Bitwise\n" (String.make indent '-') +;; + +let rec print_expr_helper indent expr = let open Printf in match expr with | Const (Int_lt i) -> printf "%s| Const(Int: %d)\n" (String.make indent '-') i | Const (Bool_lt b) -> printf "%s| Const(Bool: %b)\n" (String.make indent '-') b | Const (String_lt s) -> printf "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') - | Tuple list -> List.iter (print_expr indent) list + | Tuple list -> List.iter (print_expr_helper indent) list | Variable (Ident name) -> printf "%s| Variable(%s)\n" (String.make indent '-') name | Bin_expr (op, left, right) -> printf "%s| Binary expr(\n" (String.make indent '-'); print_bin_op indent op; - print_expr (indent + 2) left; - print_expr (indent + 2) right + print_expr_helper (indent + 2) left; + print_expr_helper (indent + 2) right | If_then_else (cond, then_body, else_body) -> printf "%s| If Then Else(\n" (String.make indent '-'); printf "%sCONDITION\n" (String.make (indent + 2) ' '); - print_expr (indent + 2) cond; + print_expr_helper (indent + 2) cond; printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4)) then_body; + List.iter (print_expr_helper (indent + 4)) then_body; printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); (match else_body with - | Some body -> List.iter (print_expr (indent + 4)) body + | Some body -> List.iter (print_expr_helper (indent + 4)) body | None -> printf "No else body") | Function_def (flag, name, args, body) -> printf @@ -39,40 +60,22 @@ let rec print_expr indent expr = | Some n -> n | None -> "Anonymous"); printf "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4)) args; + List.iter (print_expr_helper (indent + 4)) args; printf "%sBODY\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4)) body + List.iter (print_expr_helper (indent + 4)) body | Function_call (name, args) -> printf "%s| Function Call(%s):\n" (String.make indent '-') name; printf "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 2)) args + List.iter (print_expr_helper (indent + 2)) args | Let (Ident name, value) -> printf "%s| Let %s =\n" (String.make indent '-') name; - print_expr (indent + 2) value + print_expr_helper (indent + 2) value | LetIn (Ident name, value, inner_expr) -> printf "%s | LetIn %s =\n" (String.make indent '-') name; printf "%sVALUE\n" (String.make (indent + 2) ' '); - print_expr (indent + 2) value; + print_expr_helper (indent + 2) value; printf "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); - print_expr (indent + 2) inner_expr - -and print_bin_op indent bin_op = - let open Printf in - match bin_op with - | Binary_equal -> printf "%s| Binary Equal\n" (String.make indent '-') - | Binary_unequal -> printf "%s| Binary Unequal\n" (String.make indent '-') - | Binary_less -> printf "%s| Binary Less\n" (String.make indent '-') - | Binary_less_or_equal -> printf "%s| Binary Less Or Equal\n" (String.make indent ' ') - | Binary_greater -> printf "%s| Binary Greater\n" (String.make indent '-') - | Binary_greater_or_equal -> - printf "%s| Binary Greater Or Equal\n" (String.make indent '-') - | Binary_add -> printf "%s| Binary Add\n" (String.make indent '-') - | Binary_subtract -> printf "%s| Binary Subtract\n" (String.make indent '-') - | Binary_multiply -> printf "%s| Binary Multiply\n" (String.make indent '-') - | Logical_or -> printf "%s| Logical Or\n" (String.make indent '-') - | Logical_and -> printf "%s| Logical And\n" (String.make indent '-') - | Binary_divide -> printf "%s| Binary Divide\n" (String.make indent '-') - | Binary_or_bitwise -> printf "%s| Binary Or Bitwise\n" (String.make indent '-') - | Binary_xor_bitwise -> printf "%s| Binary Xor Bitwise\n" (String.make indent '-') - | Binary_and_bitwise -> printf "%s| Binary And Bitwise\n" (String.make indent '-') + print_expr_helper (indent + 2) inner_expr ;; + +let print_expr expr = print_expr_helper 0 expr diff --git a/FSharpActivePatterns/lib/printAst.mli b/FSharpActivePatterns/lib/printAst.mli index d38bdb7e3..3a600135b 100644 --- a/FSharpActivePatterns/lib/printAst.mli +++ b/FSharpActivePatterns/lib/printAst.mli @@ -4,4 +4,4 @@ open Ast -val print_expr : int -> expr -> unit +val print_expr : expr -> unit diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index b0117d3c3..ad5bcba80 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -12,7 +12,7 @@ let%expect_test "print double func" = let args = [ var ] in let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), var) in let double = Function_def (recursive, name, args, [ binary_expr ]) in - print_expr 0 double; + print_expr double; [%expect {| | Function(double): @@ -40,7 +40,7 @@ let%expect_test "print tu ple of binary operators" = ; Bin_expr (Binary_and_bitwise, Const (Int_lt 3), Const (Int_lt 10)) ] in - List.iter (print_expr 0) binary_operations; + List.iter print_expr binary_operations; [%expect {| | Binary expr( From 76d15211164896717e4ea0a9f74ea2afce537959 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 4 Oct 2024 05:26:32 +0300 Subject: [PATCH 033/310] feat: add Active Patterns, separated Let from expressions Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 41 ++++++++++----------- FSharpActivePatterns/lib/ast.mli | 34 +++++++++++++++-- FSharpActivePatterns/lib/printAst.ml | 32 +++++++++++----- FSharpActivePatterns/lib/printAst.mli | 2 +- FSharpActivePatterns/lib/tests/print_ast.ml | 39 +++++++++++--------- FSharpActivePatterns/tests/print_ast.t | 8 +++- 6 files changed, 102 insertions(+), 54 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 561bd5880..b9386aeaa 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -11,29 +11,28 @@ let () = ( Rec , Some "factorial" , [ Variable (Ident "n") ] - , [ If_then_else - ( Bin_expr - ( Logical_or - , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 0)) - , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 1)) ) - , [ Const (Int_lt 1) ] - , Some - [ Bin_expr - ( Binary_multiply - , Variable (Ident "n") - , Function_call - ( "factorial" - , [ Bin_expr - (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) - ] ) ) - ] ) - ] ) + , If_then_else + ( Bin_expr + ( Logical_or + , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 0)) + , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 1)) ) + , [ Const (Int_lt 1) ] + , Some + [ Bin_expr + ( Binary_multiply + , Variable (Ident "n") + , Function_call + ( Variable (Ident "factorial") + , [ Bin_expr + (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) + ] ) ) + ] ) ) in let program = - [ Let (Ident "a", Const (Int_lt 10)) - ; factorial - ; Function_call ("factorial", [ Variable (Ident "a") ]) + [ Statement (Let (Ident "a", Const (Int_lt 10))) + ; Expr factorial + ; Expr (Function_call (Variable (Ident "factorial"), [ Variable (Ident "a") ])) ] in - List.iter print_expr program + List.iter print_construction program ;; diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 882a3a29f..1f0474343 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -2,13 +2,15 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -type ident = Ident of string +type ident = Ident of string [@@deriving eq, show { with_path = false }] type literal = | Int_lt of int | Bool_lt of bool | String_lt of string | Unit_lt + | Null_lt +[@@deriving eq, show { with_path = false }] type binary_operator = | Binary_equal @@ -26,25 +28,49 @@ type binary_operator = | Binary_or_bitwise | Binary_xor_bitwise | Binary_and_bitwise +[@@deriving eq, show { with_path = false }] type unary_operator = | Unary_plus | Unary_minus | Unary_negative +[@@deriving eq, show { with_path = false }] + +type pattern = + | Wild (** _ *) + | PCons of pattern * pattern (** hd :: tl*) + | PConst of literal (** | 4 -> *) + | PVar of ident (** ident for other patterns *) + | Variant of ident list (** | Blue, Green, Yellow -> *) +[@@deriving eq, show { with_path = false }] type is_recursive = | Nonrec | Rec +[@@deriving eq, show { with_path = false }] type expr = | Const of literal | Tuple of expr list + | List_expr of expr * expr (** List (1, List (2, Null)) *) | Variable of ident | Bin_expr of binary_operator * expr * expr (**operator, first operand, second operand*) | If_then_else of expr * expr list * expr list option (**condition, then body, else body*) - | Function_def of is_recursive * string option * expr list * expr list + | Function_def of is_recursive * string option * expr list * expr (**rec, name, args, body*) - | Function_call of string * expr list (**name, args*) - | Let of ident * expr (**name, value*) + | Function_call of expr * expr list (** sum 1 2 *) + | Match of expr * (pattern * expr) list (**matching value, pattern-value list *) | LetIn of ident * expr * expr (**name, value, inner value*) +[@@deriving eq, show { with_path = false }] + +type statement = + | Let of ident * expr (**name, value*) + | ActivePattern of ident list * expr + (** let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd *) +[@@deriving eq, show { with_path = false }] + +type construction = + | Expr of expr + | Statement of statement +[@@deriving eq, show { with_path = false }] diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 0678e357c..7f3cb9645 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -3,9 +3,9 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open Ast +open Printf let print_bin_op indent bin_op = - let open Printf in match bin_op with | Binary_equal -> printf "%s| Binary Equal\n" (String.make indent '-') | Binary_unequal -> printf "%s| Binary Unequal\n" (String.make indent '-') @@ -26,13 +26,15 @@ let print_bin_op indent bin_op = ;; let rec print_expr_helper indent expr = - let open Printf in match expr with | Const (Int_lt i) -> printf "%s| Const(Int: %d)\n" (String.make indent '-') i | Const (Bool_lt b) -> printf "%s| Const(Bool: %b)\n" (String.make indent '-') b | Const (String_lt s) -> printf "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') - | Tuple list -> List.iter (print_expr_helper indent) list + | Const Null_lt -> printf "%s| Const(Null)\n" (String.make indent '-') + | List_expr (_, _) -> printf "LIST_EXPR TODO" + | Tuple t -> List.iter (print_expr_helper indent) t + | Match (_, _) -> printf "MATCH TODO" | Variable (Ident name) -> printf "%s| Variable(%s)\n" (String.make indent '-') name | Bin_expr (op, left, right) -> printf "%s| Binary expr(\n" (String.make indent '-'); @@ -62,14 +64,13 @@ let rec print_expr_helper indent expr = printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr_helper (indent + 4)) args; printf "%sBODY\n" (String.make (indent + 2) ' '); - List.iter (print_expr_helper (indent + 4)) body - | Function_call (name, args) -> - printf "%s| Function Call(%s):\n" (String.make indent '-') name; + print_expr_helper (indent + 4) body + | Function_call (func, args) -> + printf "%s| Function Call:\n" (String.make indent '-'); + printf "%sFUNCTION\n" (String.make (indent + 2) ' '); + print_expr_helper (indent + 2) func; printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr_helper (indent + 2)) args - | Let (Ident name, value) -> - printf "%s| Let %s =\n" (String.make indent '-') name; - print_expr_helper (indent + 2) value | LetIn (Ident name, value, inner_expr) -> printf "%s | LetIn %s =\n" (String.make indent '-') name; printf "%sVALUE\n" (String.make (indent + 2) ' '); @@ -79,3 +80,16 @@ let rec print_expr_helper indent expr = ;; let print_expr expr = print_expr_helper 0 expr + +let print_statement indent statement = + match statement with + | Let (Ident name, value) -> + printf "%s| Let %s =\n" (String.make indent '-') name; + print_expr_helper (indent + 2) value + | ActivePattern _ -> printf "ACTIVE PATTERN TODO" +;; + +let print_construction = function + | Expr e -> print_expr e + | Statement s -> print_statement 0 s +;; diff --git a/FSharpActivePatterns/lib/printAst.mli b/FSharpActivePatterns/lib/printAst.mli index 3a600135b..846b45558 100644 --- a/FSharpActivePatterns/lib/printAst.mli +++ b/FSharpActivePatterns/lib/printAst.mli @@ -4,4 +4,4 @@ open Ast -val print_expr : expr -> unit +val print_construction : construction -> unit diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index ad5bcba80..f347924fd 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -11,8 +11,8 @@ let%expect_test "print double func" = let var = Variable (Ident "n") in let args = [ var ] in let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), var) in - let double = Function_def (recursive, name, args, [ binary_expr ]) in - print_expr double; + let double = Function_def (recursive, name, args, binary_expr) in + print_construction @@ Expr double; [%expect {| | Function(double): @@ -25,22 +25,27 @@ let%expect_test "print double func" = ------| Variable(n)|}] ;; -let%expect_test "print tu ple of binary operators" = - let binary_operations = - [ Bin_expr (Binary_unequal, Const (Int_lt 3), Const (Int_lt 10)) - ; Bin_expr (Binary_less, Const (Int_lt 3), Const (Int_lt 10)) - ; Bin_expr (Binary_less_or_equal, Const (Int_lt 10), Const (Int_lt (-45))) - ; Bin_expr (Binary_greater, Const (Int_lt 3), Const (Int_lt 10)) - ; Bin_expr (Binary_greater_or_equal, Const (Int_lt 3), Const (Int_lt 10)) - ; Bin_expr (Binary_add, Const (Int_lt 3), Const (Int_lt 10)) - ; Bin_expr (Logical_and, Const (Int_lt 3), Const (Int_lt 10)) - ; Bin_expr (Binary_divide, Const (Int_lt 3), Const (Int_lt 10)) - ; Bin_expr (Binary_or_bitwise, Const (Int_lt 3), Const (Int_lt 10)) - ; Bin_expr (Binary_xor_bitwise, Const (Int_lt 3), Const (Int_lt 10)) - ; Bin_expr (Binary_and_bitwise, Const (Int_lt 3), Const (Int_lt 10)) +let%expect_test "print tuple of binary operators" = + let first = Const (Int_lt 3) in + let second = Const (Int_lt 10) in + let operators = + [ Binary_unequal + ; Binary_less + ; Binary_less_or_equal + ; Binary_greater + ; Binary_greater_or_equal + ; Binary_add + ; Logical_and + ; Binary_divide + ; Binary_or_bitwise + ; Binary_xor_bitwise + ; Binary_and_bitwise ] in - List.iter print_expr binary_operations; + let print_binary_constr operator = + print_construction @@ Expr (Bin_expr (operator, first, second)) + in + List.iter print_binary_constr operators; [%expect {| | Binary expr( @@ -53,8 +58,8 @@ let%expect_test "print tu ple of binary operators" = --| Const(Int: 10) | Binary expr( | Binary Less Or Equal + --| Const(Int: 3) --| Const(Int: 10) - --| Const(Int: -45) | Binary expr( | Binary Greater --| Const(Int: 3) diff --git a/FSharpActivePatterns/tests/print_ast.t b/FSharpActivePatterns/tests/print_ast.t index 8a7b48b28..9fe0c8212 100644 --- a/FSharpActivePatterns/tests/print_ast.t +++ b/FSharpActivePatterns/tests/print_ast.t @@ -27,12 +27,16 @@ --------| Binary expr( --------| Binary Multiply ----------| Variable(n) - ----------| Function Call(factorial): + ----------| Function Call: + FUNCTION + ------------| Variable(factorial) ARGS ------------| Binary expr( ------------| Binary Subtract --------------| Variable(n) --------------| Const(Int: 1) - | Function Call(factorial): + | Function Call: + FUNCTION + --| Variable(factorial) ARGS --| Variable(a) From a5a12714e29f8325e61100e883d7d0742ca21856 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 4 Oct 2024 18:56:05 +0300 Subject: [PATCH 034/310] docs: add constructor comments in Ast Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.mli | 75 ++++++++++++++++---------------- 1 file changed, 38 insertions(+), 37 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 1f0474343..26ba7c578 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -2,37 +2,38 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -type ident = Ident of string [@@deriving eq, show { with_path = false }] +type ident = Ident of string (** identifier *) +[@@deriving eq, show { with_path = false }] type literal = - | Int_lt of int - | Bool_lt of bool - | String_lt of string - | Unit_lt - | Null_lt + | Int_lt of int (** 0, 1, 30 *) + | Bool_lt of bool (** false, true *) + | String_lt of string (** "Hello world" *) + | Unit_lt (** Unit *) + | Null_lt (** Null *) [@@deriving eq, show { with_path = false }] type binary_operator = - | Binary_equal - | Binary_unequal - | Binary_less - | Binary_less_or_equal - | Binary_greater - | Binary_greater_or_equal - | Binary_add - | Binary_subtract - | Binary_multiply - | Logical_or - | Logical_and - | Binary_divide - | Binary_or_bitwise - | Binary_xor_bitwise - | Binary_and_bitwise + | Binary_equal (** = *) + | Binary_unequal (** <> *) + | Binary_less (** < *) + | Binary_less_or_equal (** <= *) + | Binary_greater (** > *) + | Binary_greater_or_equal (** >= *) + | Binary_add (** + *) + | Binary_subtract (** - *) + | Binary_multiply (** * *) + | Logical_or (** || *) + | Logical_and (** && *) + | Binary_divide (** / *) + | Binary_or_bitwise (** ||| *) + | Binary_xor_bitwise (** ^^^ *) + | Binary_and_bitwise (** &&& *) [@@deriving eq, show { with_path = false }] type unary_operator = - | Unary_plus - | Unary_minus + | Unary_plus (** +5 *) + | Unary_minus (** -10 *) | Unary_negative [@@deriving eq, show { with_path = false }] @@ -40,37 +41,37 @@ type pattern = | Wild (** _ *) | PCons of pattern * pattern (** hd :: tl*) | PConst of literal (** | 4 -> *) - | PVar of ident (** ident for other patterns *) + | PVar of ident (** pattern identifier *) | Variant of ident list (** | Blue, Green, Yellow -> *) [@@deriving eq, show { with_path = false }] type is_recursive = - | Nonrec - | Rec + | Nonrec (** let rec factorial n = ... *) + | Rec (** let factorial n = ... *) [@@deriving eq, show { with_path = false }] type expr = - | Const of literal - | Tuple of expr list - | List_expr of expr * expr (** List (1, List (2, Null)) *) - | Variable of ident - | Bin_expr of binary_operator * expr * expr (**operator, first operand, second operand*) + | Const of literal (** Int, Bool, String, Unit, Null *) + | Tuple of expr list (** (1, "Hello world", true) *) + | List_expr of expr * expr (** [1, 2, 3] *) + | Variable of ident (** x, y *) + | Bin_expr of binary_operator * expr * expr (** 1 + 2, 3 ||| 12 *) | If_then_else of expr * expr list * expr list option - (**condition, then body, else body*) + (** if n % 2 = 0 then "Even" else "Odd" *) | Function_def of is_recursive * string option * expr list * expr (**rec, name, args, body*) | Function_call of expr * expr list (** sum 1 2 *) - | Match of expr * (pattern * expr) list (**matching value, pattern-value list *) - | LetIn of ident * expr * expr (**name, value, inner value*) + | Match of expr * (pattern * expr) list (** matching value, pattern-value list *) + | LetIn of ident * expr * expr (** let x = 5 in x * y *) [@@deriving eq, show { with_path = false }] type statement = - | Let of ident * expr (**name, value*) + | Let of ident * expr (** name, value *) | ActivePattern of ident list * expr (** let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd *) [@@deriving eq, show { with_path = false }] type construction = - | Expr of expr - | Statement of statement + | Expr of expr (** expression *) + | Statement of statement (** statement *) [@@deriving eq, show { with_path = false }] From 467c3b4607a32fbfd519ff59376518c1e77e3f90 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 4 Oct 2024 21:14:43 +0300 Subject: [PATCH 035/310] feat: implement print function for patterns, update printAst Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/printAst.ml | 84 +++++++++++++++++++++------- 1 file changed, 64 insertions(+), 20 deletions(-) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 7f3cb9645..abf6d9469 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -25,31 +25,71 @@ let print_bin_op indent bin_op = | Binary_and_bitwise -> printf "%s| Binary And Bitwise\n" (String.make indent '-') ;; -let rec print_expr_helper indent expr = +let rec print_pattern indent pattern = + match pattern with + | Wild -> + printf "%s| Wild\n" (String.make indent '-') + | PCons (head, tail) -> + printf "%s| PCons:\n" (String.make indent '-'); + printf "%sHead:\n" (String.make (indent + 2) '-'); + print_pattern (indent + 4) head; + printf "%sTail:\n" (String.make (indent + 2) '-'); + print_pattern (indent + 4) tail + | PConst literal -> + printf "%s| PConst:\n" (String.make indent '-'); + (match literal with + | Int_lt i -> printf "%sInt: %d\n" (String.make (indent + 2) '-') i + | Bool_lt b -> printf "%sBool: %b\n" (String.make (indent + 2) '-') b + | String_lt s -> printf "%sString: %S\n" (String.make (indent + 2) '-') s + | Unit_lt -> printf "%sUnit\n" (String.make (indent + 2) '-') + | Null_lt -> printf "%sNull\n" (String.make (indent + 2) '-')) + | PVar (Ident name) -> + printf "%s| PVar(%s)\n" (String.make indent '-') name + | Variant variants -> + printf "%s| Variant:\n" (String.make indent '-'); + List.iter (fun (Ident v) -> + printf "%s- %s\n" (String.make (indent + 2) '-') v + ) variants +;; + + +let rec print_expr indent expr = match expr with | Const (Int_lt i) -> printf "%s| Const(Int: %d)\n" (String.make indent '-') i | Const (Bool_lt b) -> printf "%s| Const(Bool: %b)\n" (String.make indent '-') b | Const (String_lt s) -> printf "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') | Const Null_lt -> printf "%s| Const(Null)\n" (String.make indent '-') - | List_expr (_, _) -> printf "LIST_EXPR TODO" - | Tuple t -> List.iter (print_expr_helper indent) t - | Match (_, _) -> printf "MATCH TODO" + | List_expr (expr1, expr2) -> ( + printf "%s| List expr:\n" (String.make indent '-'); + print_expr (indent + 2) expr1; + print_expr (indent + 2) expr2; + ) + | Tuple t -> List.iter (print_expr indent) t + | Match (value, patterns) -> + printf "%s| Match:\n" (String.make indent '-'); + print_expr (indent + 2) value; + List.iter (fun (pat, expr) -> + printf "%s| Pattern:\n" (String.make (indent + 2) '-'); + print_pattern (indent + 4) pat; + printf "%s| Inner expr:\n" (String.make (indent + 2) '-'); + print_expr (indent + 4) expr + ) patterns | Variable (Ident name) -> printf "%s| Variable(%s)\n" (String.make indent '-') name | Bin_expr (op, left, right) -> printf "%s| Binary expr(\n" (String.make indent '-'); print_bin_op indent op; - print_expr_helper (indent + 2) left; - print_expr_helper (indent + 2) right + print_expr (indent + 2) left; + print_expr(indent + 2) right | If_then_else (cond, then_body, else_body) -> printf "%s| If Then Else(\n" (String.make indent '-'); printf "%sCONDITION\n" (String.make (indent + 2) ' '); - print_expr_helper (indent + 2) cond; + print_expr (indent + 2) cond; printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); - List.iter (print_expr_helper (indent + 4)) then_body; + List.iter (print_expr (indent + 4)) then_body; printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); (match else_body with - | Some body -> List.iter (print_expr_helper (indent + 4)) body + | Some body -> List.iter (print_expr (indent + 4)) body | None -> printf "No else body") | Function_def (flag, name, args, body) -> printf @@ -62,34 +102,38 @@ let rec print_expr_helper indent expr = | Some n -> n | None -> "Anonymous"); printf "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr_helper (indent + 4)) args; + List.iter (print_expr (indent + 4)) args; printf "%sBODY\n" (String.make (indent + 2) ' '); - print_expr_helper (indent + 4) body + print_expr (indent + 4) body | Function_call (func, args) -> printf "%s| Function Call:\n" (String.make indent '-'); printf "%sFUNCTION\n" (String.make (indent + 2) ' '); - print_expr_helper (indent + 2) func; + print_expr (indent + 2) func; printf "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr_helper (indent + 2)) args + List.iter (print_expr (indent + 2)) args | LetIn (Ident name, value, inner_expr) -> printf "%s | LetIn %s =\n" (String.make indent '-') name; printf "%sVALUE\n" (String.make (indent + 2) ' '); - print_expr_helper (indent + 2) value; + print_expr (indent + 2) value; printf "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); - print_expr_helper (indent + 2) inner_expr + print_expr (indent + 2) inner_expr ;; -let print_expr expr = print_expr_helper 0 expr - let print_statement indent statement = match statement with | Let (Ident name, value) -> printf "%s| Let %s =\n" (String.make indent '-') name; - print_expr_helper (indent + 2) value - | ActivePattern _ -> printf "ACTIVE PATTERN TODO" + print_expr (indent + 2) value + | ActivePattern (patterns, expr) -> ( + printf "%s| ActivePattern:\n" (String.make indent '-'); + List.iter (fun (Ident param) -> + printf "%s- %s\n" (String.make (indent + 2) '-') param + ) patterns; + print_expr (indent + 2) expr + ) ;; let print_construction = function - | Expr e -> print_expr e + | Expr e -> print_expr 0 e | Statement s -> print_statement 0 s ;; From 5d197316974f7515026e132749c0a47017e6b082 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 4 Oct 2024 21:20:18 +0300 Subject: [PATCH 036/310] fix: fix formatting and linter reports Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/printAst.ml | 63 +++++++++++++--------------- 1 file changed, 28 insertions(+), 35 deletions(-) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index abf6d9469..8e4a9d64d 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -5,12 +5,11 @@ open Ast open Printf -let print_bin_op indent bin_op = - match bin_op with +let print_bin_op indent = function | Binary_equal -> printf "%s| Binary Equal\n" (String.make indent '-') | Binary_unequal -> printf "%s| Binary Unequal\n" (String.make indent '-') | Binary_less -> printf "%s| Binary Less\n" (String.make indent '-') - | Binary_less_or_equal -> printf "%s| Binary Less Or Equal\n" (String.make indent ' ') + | Binary_less_or_equal -> printf "%s| Binary Less Or Equal\n" (String.make indent '-') | Binary_greater -> printf "%s| Binary Greater\n" (String.make indent '-') | Binary_greater_or_equal -> printf "%s| Binary Greater Or Equal\n" (String.make indent '-') @@ -25,10 +24,8 @@ let print_bin_op indent bin_op = | Binary_and_bitwise -> printf "%s| Binary And Bitwise\n" (String.make indent '-') ;; -let rec print_pattern indent pattern = - match pattern with - | Wild -> - printf "%s| Wild\n" (String.make indent '-') +let rec print_pattern indent = function + | Wild -> printf "%s| Wild\n" (String.make indent '-') | PCons (head, tail) -> printf "%s| PCons:\n" (String.make indent '-'); printf "%sHead:\n" (String.make (indent + 2) '-'); @@ -38,21 +35,19 @@ let rec print_pattern indent pattern = | PConst literal -> printf "%s| PConst:\n" (String.make indent '-'); (match literal with - | Int_lt i -> printf "%sInt: %d\n" (String.make (indent + 2) '-') i - | Bool_lt b -> printf "%sBool: %b\n" (String.make (indent + 2) '-') b - | String_lt s -> printf "%sString: %S\n" (String.make (indent + 2) '-') s - | Unit_lt -> printf "%sUnit\n" (String.make (indent + 2) '-') - | Null_lt -> printf "%sNull\n" (String.make (indent + 2) '-')) - | PVar (Ident name) -> - printf "%s| PVar(%s)\n" (String.make indent '-') name + | Int_lt i -> printf "%sInt: %d\n" (String.make (indent + 2) '-') i + | Bool_lt b -> printf "%sBool: %b\n" (String.make (indent + 2) '-') b + | String_lt s -> printf "%sString: %S\n" (String.make (indent + 2) '-') s + | Unit_lt -> printf "%sUnit\n" (String.make (indent + 2) '-') + | Null_lt -> printf "%sNull\n" (String.make (indent + 2) '-')) + | PVar (Ident name) -> printf "%s| PVar(%s)\n" (String.make indent '-') name | Variant variants -> printf "%s| Variant:\n" (String.make indent '-'); - List.iter (fun (Ident v) -> - printf "%s- %s\n" (String.make (indent + 2) '-') v - ) variants + List.iter + (fun (Ident v) -> printf "%s- %s\n" (String.make (indent + 2) '-') v) + variants ;; - let rec print_expr indent expr = match expr with | Const (Int_lt i) -> printf "%s| Const(Int: %d)\n" (String.make indent '-') i @@ -60,27 +55,27 @@ let rec print_expr indent expr = | Const (String_lt s) -> printf "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') | Const Null_lt -> printf "%s| Const(Null)\n" (String.make indent '-') - | List_expr (expr1, expr2) -> ( + | List_expr (expr1, expr2) -> printf "%s| List expr:\n" (String.make indent '-'); print_expr (indent + 2) expr1; - print_expr (indent + 2) expr2; - ) + print_expr (indent + 2) expr2 | Tuple t -> List.iter (print_expr indent) t | Match (value, patterns) -> printf "%s| Match:\n" (String.make indent '-'); print_expr (indent + 2) value; - List.iter (fun (pat, expr) -> - printf "%s| Pattern:\n" (String.make (indent + 2) '-'); - print_pattern (indent + 4) pat; - printf "%s| Inner expr:\n" (String.make (indent + 2) '-'); - print_expr (indent + 4) expr - ) patterns + List.iter + (fun (pat, expr) -> + printf "%s| Pattern:\n" (String.make (indent + 2) '-'); + print_pattern (indent + 4) pat; + printf "%s| Inner expr:\n" (String.make (indent + 2) '-'); + print_expr (indent + 4) expr) + patterns | Variable (Ident name) -> printf "%s| Variable(%s)\n" (String.make indent '-') name | Bin_expr (op, left, right) -> printf "%s| Binary expr(\n" (String.make indent '-'); print_bin_op indent op; print_expr (indent + 2) left; - print_expr(indent + 2) right + print_expr (indent + 2) right | If_then_else (cond, then_body, else_body) -> printf "%s| If Then Else(\n" (String.make indent '-'); printf "%sCONDITION\n" (String.make (indent + 2) ' '); @@ -119,18 +114,16 @@ let rec print_expr indent expr = print_expr (indent + 2) inner_expr ;; -let print_statement indent statement = - match statement with +let print_statement indent = function | Let (Ident name, value) -> printf "%s| Let %s =\n" (String.make indent '-') name; print_expr (indent + 2) value - | ActivePattern (patterns, expr) -> ( + | ActivePattern (patterns, expr) -> printf "%s| ActivePattern:\n" (String.make indent '-'); - List.iter (fun (Ident param) -> - printf "%s- %s\n" (String.make (indent + 2) '-') param - ) patterns; + List.iter + (fun (Ident param) -> printf "%s- %s\n" (String.make (indent + 2) '-') param) + patterns; print_expr (indent + 2) expr - ) ;; let print_construction = function From 092b40bc46645beedbdeda4aa6d5142821fcd29d Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 4 Oct 2024 21:24:22 +0300 Subject: [PATCH 037/310] fix: delete extra constructor Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 1 - 1 file changed, 1 deletion(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 26ba7c578..78a27326f 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -34,7 +34,6 @@ type binary_operator = type unary_operator = | Unary_plus (** +5 *) | Unary_minus (** -10 *) - | Unary_negative [@@deriving eq, show { with_path = false }] type pattern = From 0428d53b8f6e1557c7fdfb53405e1dd7f61a6a31 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 4 Oct 2024 22:29:48 +0300 Subject: [PATCH 038/310] feat: change expr list to expr in IfThenElse Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 18 ++++++++---------- FSharpActivePatterns/lib/ast.mli | 3 +-- FSharpActivePatterns/lib/printAst.ml | 4 ++-- 3 files changed, 11 insertions(+), 14 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index b9386aeaa..8ba2e59dc 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -16,17 +16,15 @@ let () = ( Logical_or , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 0)) , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 1)) ) - , [ Const (Int_lt 1) ] + , Const (Int_lt 1) , Some - [ Bin_expr - ( Binary_multiply - , Variable (Ident "n") - , Function_call - ( Variable (Ident "factorial") - , [ Bin_expr - (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) - ] ) ) - ] ) ) + (Bin_expr + ( Binary_multiply + , Variable (Ident "n") + , Function_call + ( Variable (Ident "factorial") + , [ Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) + ] ) )) ) ) in let program = [ Statement (Let (Ident "a", Const (Int_lt 10))) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 78a27326f..5d11d1b3c 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -55,8 +55,7 @@ type expr = | List_expr of expr * expr (** [1, 2, 3] *) | Variable of ident (** x, y *) | Bin_expr of binary_operator * expr * expr (** 1 + 2, 3 ||| 12 *) - | If_then_else of expr * expr list * expr list option - (** if n % 2 = 0 then "Even" else "Odd" *) + | If_then_else of expr * expr * expr option (** if n % 2 = 0 then "Even" else "Odd" *) | Function_def of is_recursive * string option * expr list * expr (**rec, name, args, body*) | Function_call of expr * expr list (** sum 1 2 *) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 8e4a9d64d..e414361f7 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -81,10 +81,10 @@ let rec print_expr indent expr = printf "%sCONDITION\n" (String.make (indent + 2) ' '); print_expr (indent + 2) cond; printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4)) then_body; + print_expr (indent + 4) then_body; printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); (match else_body with - | Some body -> List.iter (print_expr (indent + 4)) body + | Some body -> print_expr (indent + 4) body | None -> printf "No else body") | Function_def (flag, name, args, body) -> printf From 6e12743d626cc912bd513c5d0efe729d59a8ee8f Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 4 Oct 2024 22:40:17 +0300 Subject: [PATCH 039/310] feat: add tuple pattern in ast Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.mli | 3 ++- FSharpActivePatterns/lib/printAst.ml | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 5d11d1b3c..b4d9aef57 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -38,7 +38,8 @@ type unary_operator = type pattern = | Wild (** _ *) - | PCons of pattern * pattern (** hd :: tl*) + | PCons of pattern * pattern (** | hd :: tl -> *) + | PTuple of pattern list (** | (a, b) -> *) | PConst of literal (** | 4 -> *) | PVar of ident (** pattern identifier *) | Variant of ident list (** | Blue, Green, Yellow -> *) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index e414361f7..d549c30ff 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -32,6 +32,9 @@ let rec print_pattern indent = function print_pattern (indent + 4) head; printf "%sTail:\n" (String.make (indent + 2) '-'); print_pattern (indent + 4) tail + | PTuple tuple -> + printf "%s| PTuple:\n" (String.make indent '-'); + List.iter (print_pattern (indent + 2)) tuple | PConst literal -> printf "%s| PConst:\n" (String.make indent '-'); (match literal with From b52bd102f2db84844d1657f2136aec12582d0597 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 4 Oct 2024 23:43:00 +0300 Subject: [PATCH 040/310] feat: add unary_expr and change unary operators, change ast docs Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.mli | 84 +++++++++++++++------------- FSharpActivePatterns/lib/printAst.ml | 9 +++ 2 files changed, 53 insertions(+), 40 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index b4d9aef57..ba504510f 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -6,68 +6,72 @@ type ident = Ident of string (** identifier *) [@@deriving eq, show { with_path = false }] type literal = - | Int_lt of int (** 0, 1, 30 *) - | Bool_lt of bool (** false, true *) - | String_lt of string (** "Hello world" *) - | Unit_lt (** Unit *) - | Null_lt (** Null *) + | Int_lt of int (** [0], [1], [30] *) + | Bool_lt of bool (** [false], [true] *) + | String_lt of string (** ["Hello world"] *) + | Unit_lt (** [Unit] *) + | Null_lt (** [Null] *) [@@deriving eq, show { with_path = false }] type binary_operator = - | Binary_equal (** = *) - | Binary_unequal (** <> *) - | Binary_less (** < *) - | Binary_less_or_equal (** <= *) - | Binary_greater (** > *) - | Binary_greater_or_equal (** >= *) - | Binary_add (** + *) - | Binary_subtract (** - *) - | Binary_multiply (** * *) - | Logical_or (** || *) - | Logical_and (** && *) - | Binary_divide (** / *) - | Binary_or_bitwise (** ||| *) - | Binary_xor_bitwise (** ^^^ *) - | Binary_and_bitwise (** &&& *) + | Binary_equal (** [=] *) + | Binary_unequal (** [<>] *) + | Binary_less (** [<] *) + | Binary_less_or_equal (** [<=] *) + | Binary_greater (** [>] *) + | Binary_greater_or_equal (** [>=] *) + | Binary_add (** [+] *) + | Binary_subtract (** [-] *) + | Binary_multiply (** [*] *) + | Logical_or (** [||] *) + | Logical_and (** [&&] *) + | Binary_divide (** [/] *) + | Binary_or_bitwise (** [|||] *) + | Binary_xor_bitwise (** [^^^] *) + | Binary_and_bitwise (** [&&&] *) [@@deriving eq, show { with_path = false }] type unary_operator = - | Unary_plus (** +5 *) - | Unary_minus (** -10 *) + | Unary_minus (** unary [-] *) + | Unary_negative (** unary [not] *) [@@deriving eq, show { with_path = false }] type pattern = - | Wild (** _ *) - | PCons of pattern * pattern (** | hd :: tl -> *) - | PTuple of pattern list (** | (a, b) -> *) - | PConst of literal (** | 4 -> *) + | Wild (** [_] *) + | PCons of pattern * pattern (** | [hd :: tl] -> *) + | PTuple of pattern list (** | [(a, b)] -> *) + | PConst of literal (** | [4] -> *) | PVar of ident (** pattern identifier *) - | Variant of ident list (** | Blue, Green, Yellow -> *) + | Variant of ident list (** | [Blue, Green, Yellow] -> *) [@@deriving eq, show { with_path = false }] type is_recursive = - | Nonrec (** let rec factorial n = ... *) - | Rec (** let factorial n = ... *) + | Nonrec (** let factorial n = ... *) + | Rec (** let rec factorial n = ... *) [@@deriving eq, show { with_path = false }] type expr = - | Const of literal (** Int, Bool, String, Unit, Null *) - | Tuple of expr list (** (1, "Hello world", true) *) - | List_expr of expr * expr (** [1, 2, 3] *) - | Variable of ident (** x, y *) - | Bin_expr of binary_operator * expr * expr (** 1 + 2, 3 ||| 12 *) - | If_then_else of expr * expr * expr option (** if n % 2 = 0 then "Even" else "Odd" *) + | Const of literal (** [Int], [Bool], [String], [Unit], [Null] *) + | Tuple of expr list (** [(1, "Hello world", true)] *) + | List_expr of expr * expr + (** {[ + [ 1, 2, 3 ] + ]} *) + | Variable of ident (** [x], [y] *) + | Unary_expr of unary_operator * expr + | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) + | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) | Function_def of is_recursive * string option * expr list * expr (**rec, name, args, body*) - | Function_call of expr * expr list (** sum 1 2 *) - | Match of expr * (pattern * expr) list (** matching value, pattern-value list *) - | LetIn of ident * expr * expr (** let x = 5 in x * y *) + | Function_call of expr * expr list (** [sum 1 ] *) + | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) + | LetIn of ident * expr * expr (** [let x = 5 in x * y] *) [@@deriving eq, show { with_path = false }] type statement = - | Let of ident * expr (** name, value *) + | Let of ident * expr (** [let name = expr] *) | ActivePattern of ident list * expr - (** let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd *) + (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *) [@@deriving eq, show { with_path = false }] type construction = diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index d549c30ff..ea124e2e0 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -51,6 +51,11 @@ let rec print_pattern indent = function variants ;; +let print_unary_op indent = function + | Unary_minus -> printf "%s| Unary minus\n" (String.make indent '-') + | Unary_negative -> printf "%s| Unary negative\n" (String.make indent '-') +;; + let rec print_expr indent expr = match expr with | Const (Int_lt i) -> printf "%s| Const(Int: %d)\n" (String.make indent '-') i @@ -74,6 +79,10 @@ let rec print_expr indent expr = print_expr (indent + 4) expr) patterns | Variable (Ident name) -> printf "%s| Variable(%s)\n" (String.make indent '-') name + | Unary_expr (op, expr) -> + printf "%s| Unary expr(\n" (String.make indent '-'); + print_unary_op indent op; + print_expr (indent + 2) expr | Bin_expr (op, left, right) -> printf "%s| Binary expr(\n" (String.make indent '-'); print_bin_op indent op; From 7cdd8f0b11cd872e026de6e59a666f5874f4d3d2 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 11 Oct 2024 16:39:15 +0300 Subject: [PATCH 041/310] feat: add first version of arithm expressions parser Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/main.ml | 7 +- FSharpActivePatterns/dune-project | 1 + FSharpActivePatterns/lib/arithmParser.ml | 221 +++++++++++++++++++++++ FSharpActivePatterns/lib/dune | 3 +- 4 files changed, 230 insertions(+), 2 deletions(-) create mode 100644 FSharpActivePatterns/lib/arithmParser.ml diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 8ba2e59dc..7287bcf0d 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -4,6 +4,7 @@ open FSharpActivePatterns.Ast open FSharpActivePatterns.PrintAst +open FSharpActivePatterns.ArithmParser let () = let factorial = @@ -32,5 +33,9 @@ let () = ; Expr (Function_call (Variable (Ident "factorial"), [ Variable (Ident "a") ])) ] in - List.iter print_construction program + List.iter print_construction program; + Printf.printf "\n\n\n"; + let input = " ( 5 + 1 ) + 8 " in + let result = parse input in + print_construction (Expr result) ;; diff --git a/FSharpActivePatterns/dune-project b/FSharpActivePatterns/dune-project index 9ef997f45..8c017dc56 100644 --- a/FSharpActivePatterns/dune-project +++ b/FSharpActivePatterns/dune-project @@ -23,6 +23,7 @@ (version 0.1) (depends dune + angstrom (ppx_inline_test :with-test) ppx_expect ppx_deriving diff --git a/FSharpActivePatterns/lib/arithmParser.ml b/FSharpActivePatterns/lib/arithmParser.ml new file mode 100644 index 000000000..92d6756e9 --- /dev/null +++ b/FSharpActivePatterns/lib/arithmParser.ml @@ -0,0 +1,221 @@ +open Angstrom +open Ast + +let ws = skip_while (function ' ' -> true | _ -> false) +let parens p = ws *> char '(' *> ws *> p <* ws <* char ')' <* ws +let add = ws *> char '+' *> ws *> return Binary_add +let sub = ws *> char '-' *> ws *> return Binary_subtract +let mul = ws *> char '*' *> ws *> return Binary_multiply +let div = ws *> char '/' *> ws *> return Binary_divide +let integer = + take_while1 (function '0' .. '9' -> true | _ -> false) >>| (fun s -> Const (Int_lt (int_of_string s))) + +let chainl1 e op = + let rec go acc = + (lift2 (fun f x -> Bin_expr (f, acc, x)) op e >>= go) <|> return acc in + e >>= fun init -> go init <* ws + +let expr : expr t = + fix (fun expr -> + let factor = (ws *> parens expr) <|> (ws *> integer) in + let term = chainl1 factor (mul <|> div) in + chainl1 term (add <|> sub)) + +let parse (str:string) : expr = + match parse_string ~consume:All expr str with + | Ok v -> v + | Error msg -> failwith msg + +(* +(* saves info about positions explicitly during parsing *) +let parse_with_pos parser pos = + parser >>= fun (result, new_pos) -> + return (result, pos, new_pos) +;; + +(* assumes that something in brackets can be parsed further *) +let parse_parens p pos = + char '(' *> p (pos + 1) >>= fun (expr_inside, new_pos) -> + char ')' *> return (expr_inside, new_pos + 1) +;; +let parse_add pos = + char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_add, left, right), l_start, r_end)) +;; +let parse_sub pos = + char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_subtract, left, right), l_start, r_end)) +;; +let parse_mul pos = + char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_multiply, left, right), l_start, r_end)) +;; +let parse_div pos = + char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_divide, left, right), l_start, r_end)) +;; + +let find_const pos = + take_while1 (function + | '0' .. '9' -> true + | _ -> false) + >>= fun num -> + let num_length = String.length num in + return (Const (Int_lt (int_of_string num)), pos + num_length) +;; + +(* finds a chain of operands with the same priority and left associativity, e.g., a-b+c or a*b/c *) +let find_left_chain e func pos = + let rec go acc pos = + (* *) + lift2 (fun f x -> f acc x) (func pos) (e pos) >>= fun new_acc -> + go new_acc (pos + 1) <|> return acc + in + e pos >>= fun init -> go init pos + +(* parses an arithmetic expression with +-*/() completely *) +let rec find_arithm_expr pos : (expr * int) t = + let parser = (parse_parens find_arithm_expr pos) <|> find_const pos in + parser >>= fun (factor, new_pos) -> + let term = find_left_chain (fun pos -> parse_mul pos <|> parse_div pos) new_pos factor in + find_left_chain term (fun pos -> parse_add pos <|> parse_sub pos) new_pos +;; + + +let parse (str : string) : expr = + (* apply parser to string *) + match parse_string ~consume:All (find_arithm_expr 0) str with + | Ok (v, start_pos) -> v + | Error msg -> + failwith (Printf.sprintf "Error at position: %s" msg) *) + +(* +open Angstrom +open Ast + +(* saves info about positions explicitly during parsing *) +let parse_with_pos parser pos = + parser >>= fun (result, new_pos) -> + return (result, pos, new_pos) +;; + +(* assumes that something in brackets can be parsed further *) +let parse_parens p pos = + char '(' *> parse_with_pos p (pos + 1) <* char ')' +;; +let parse_add pos = + char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_add, left, right), l_start, r_end)) +;; +let parse_sub pos = + char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_subtract, left, right), l_start, r_end)) +;; +let parse_mul pos = + char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_multiply, left, right), l_start, r_end)) +;; +let parse_div pos = + char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_divide, left, right), l_start, r_end)) +;; + +let find_const pos = + take_while1 (function + | '0' .. '9' -> true + | _ -> false) + >>= fun num -> + let length = String.length num in + return (Const (Int_lt (int_of_string num)), pos, pos + length) +;; + +(* finds chain of operands on same priority level and with left associativity, such as a-b+c or a*b/c *) +let find_left_chain e func pos = + let rec go acc pos = + lift2 (fun f x -> f acc x) (func pos) (e pos) >>= fun new_acc -> + go new_acc (pos + 1) <|> return acc + in + e pos >>= fun init -> go init pos +;; + +(* parses arithmetical expression with +-*/() completely *) +let rec find_arithm_expr pos : (expr * int * int) t = + let rec expr_with_pos pos = + let factor = parse_parens (expr_with_pos pos) pos <|> find_const pos in + let term = find_left_chain factor (parse_mul pos <|> parse_div pos) pos in + find_left_chain term (parse_add pos <|> parse_sub pos) pos + in + expr_with_pos pos +;; + +let parse (str : string) : expr = + match parse_string ~consume:All (find_arithm_expr 0) str with + | Ok (v, start_pos, end_pos) -> ( + Printf.printf "start is %d" start_pos; + Printf.printf "end is %d" end_pos; + v + ) + | Error msg -> + failwith (Printf.sprintf "Error at position: %s" msg) *) + + + +(* + +open Angstrom +open Ast + +(* saves info about positions in string before and after parsing *) +let parse_with_pos parser = + pos >>= fun start_pos -> + parser >>= fun result -> + pos >>= fun end_pos -> + return (result, start_pos, end_pos) +;; + +let parse_parens p = char '(' *> parse_with_pos p <* char ')' (* assumes that something in brackets can be parsed further *) +let parse_add = char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_add, left, right), l_start, r_end)) +let parse_sub = char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_subtract, left, right), l_start, r_end)) +let parse_mul = char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_multiply, left, right), l_start, r_end)) +let parse_div = char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_divide, left, right), l_start, r_end)) + +let find_const = + pos >>= fun start_pos -> + take_while1 (function + | '0' .. '9' -> true + | _ -> false) + >>= fun num -> + pos >>= fun end_pos -> + return (Const (Int_lt (int_of_string num)), start_pos, end_pos) +;; + +(* finds chain of operands on same priority level and with left associativity, such as a-b+c or a*b/c *) +let find_left_chain e func = + let rec go acc = lift2 (fun f x -> f acc x) func e >>= go <|> return acc in + e >>= fun init -> go init +;; + +(* parses arithmetical expression with +-*/() completely *) +let rec find_arithm_expr : (expr * int * int) t = + let rec expr_with_pos () = + let factor = parse_parens (expr_with_pos ()) <|> find_const in + let term = find_left_chain factor (parse_mul <|> parse_div) in + find_left_chain term (parse_add <|> parse_sub) + in + expr_with_pos () +;; + + +let parse (str : string) : expr = + match parse_string ~consume:All find_arithm_expr str with + | Ok (v, start_pos, end_pos) -> ( + Printf.printf "start is %d" start_pos; + Printf.printf "end is %d" end_pos; + v + ) + | Error msg -> + failwith (Printf.sprintf "Error at position: %s" msg) *) diff --git a/FSharpActivePatterns/lib/dune b/FSharpActivePatterns/lib/dune index 91a3144a9..ba7a2a1ec 100644 --- a/FSharpActivePatterns/lib/dune +++ b/FSharpActivePatterns/lib/dune @@ -1,8 +1,9 @@ (library (name FSharpActivePatterns) (public_name FSharpActivePatterns) - (modules Ast PrintAst) + (modules Ast PrintAst ArithmParser) (modules_without_implementation ast) + (libraries angstrom) (preprocess (pps ppx_deriving.show ppx_deriving.eq)) (instrumentation From 6e2d43d00874b0c3c4f586b6bb170e50a19e65e3 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 11 Oct 2024 16:46:07 +0300 Subject: [PATCH 042/310] feat: add example Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/main.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 7287bcf0d..e8f4c129d 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -35,7 +35,7 @@ let () = in List.iter print_construction program; Printf.printf "\n\n\n"; - let input = " ( 5 + 1 ) + 8 " in + let input = " ( 5 + 1 ) * 8 " in let result = parse input in print_construction (Expr result) ;; From 9b050caa28335d32dd1d7c9d4f37392a3d29f668 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 11 Oct 2024 16:54:59 +0300 Subject: [PATCH 043/310] fix: change names slightly Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/arithmParser.ml | 29 ++++++++++++------------ 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/FSharpActivePatterns/lib/arithmParser.ml b/FSharpActivePatterns/lib/arithmParser.ml index 92d6756e9..2f80679b8 100644 --- a/FSharpActivePatterns/lib/arithmParser.ml +++ b/FSharpActivePatterns/lib/arithmParser.ml @@ -1,28 +1,29 @@ open Angstrom open Ast -let ws = skip_while (function ' ' -> true | _ -> false) -let parens p = ws *> char '(' *> ws *> p <* ws <* char ')' <* ws -let add = ws *> char '+' *> ws *> return Binary_add -let sub = ws *> char '-' *> ws *> return Binary_subtract -let mul = ws *> char '*' *> ws *> return Binary_multiply -let div = ws *> char '/' *> ws *> return Binary_divide -let integer = +let skip_ws = skip_while (function ' ' -> true | _ -> false) +let parse_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' <* skip_ws +let add = skip_ws *> char '+' *> skip_ws *> return Binary_add +let sub = skip_ws *> char '-' *> skip_ws *> return Binary_subtract +let mul = skip_ws *> char '*' *> skip_ws *> return Binary_multiply +let div = skip_ws *> char '/' *> skip_ws *> return Binary_divide +let find_integer = take_while1 (function '0' .. '9' -> true | _ -> false) >>| (fun s -> Const (Int_lt (int_of_string s))) -let chainl1 e op = +(* find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) +let parse_chainl1 e op = let rec go acc = (lift2 (fun f x -> Bin_expr (f, acc, x)) op e >>= go) <|> return acc in - e >>= fun init -> go init <* ws + e >>= fun init -> go init <* skip_ws -let expr : expr t = +let find_expr : expr t = fix (fun expr -> - let factor = (ws *> parens expr) <|> (ws *> integer) in - let term = chainl1 factor (mul <|> div) in - chainl1 term (add <|> sub)) + let factor = (skip_ws *> parse_parens expr) <|> (skip_ws *> find_integer) in + let term = parse_chainl1 factor (mul <|> div) in + parse_chainl1 term (add <|> sub)) let parse (str:string) : expr = - match parse_string ~consume:All expr str with + match parse_string ~consume:All find_expr str with | Ok v -> v | Error msg -> failwith msg From 4e063907a8768aa693d9bc6b64ca88fffeacf42b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 12 Oct 2024 23:33:00 +0300 Subject: [PATCH 044/310] feat: implemented logical expressions parser Signed-off-by: Gleb Nasretdinov --- .../FSharpActivePatterns.opam | 1 + FSharpActivePatterns/bin/main.ml | 4 +- FSharpActivePatterns/lib/arithmParser.ml | 222 -------------- FSharpActivePatterns/lib/dune | 2 +- FSharpActivePatterns/lib/parser.ml | 270 ++++++++++++++++++ 5 files changed, 274 insertions(+), 225 deletions(-) delete mode 100644 FSharpActivePatterns/lib/arithmParser.ml create mode 100644 FSharpActivePatterns/lib/parser.ml diff --git a/FSharpActivePatterns/FSharpActivePatterns.opam b/FSharpActivePatterns/FSharpActivePatterns.opam index 6041814cd..ff3987134 100644 --- a/FSharpActivePatterns/FSharpActivePatterns.opam +++ b/FSharpActivePatterns/FSharpActivePatterns.opam @@ -12,6 +12,7 @@ doc: "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda" bug-reports: "https://github.com/Ycyken/fp2024" depends: [ "dune" {>= "3.7"} + "angstrom" "ppx_inline_test" {with-test} "ppx_expect" "ppx_deriving" diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index e8f4c129d..2aed2840f 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -4,7 +4,7 @@ open FSharpActivePatterns.Ast open FSharpActivePatterns.PrintAst -open FSharpActivePatterns.ArithmParser +open FSharpActivePatterns.Parser let () = let factorial = @@ -35,7 +35,7 @@ let () = in List.iter print_construction program; Printf.printf "\n\n\n"; - let input = " ( 5 + 1 ) * 8 " in + let input = " 3 + 5 > 8" in let result = parse input in print_construction (Expr result) ;; diff --git a/FSharpActivePatterns/lib/arithmParser.ml b/FSharpActivePatterns/lib/arithmParser.ml deleted file mode 100644 index 2f80679b8..000000000 --- a/FSharpActivePatterns/lib/arithmParser.ml +++ /dev/null @@ -1,222 +0,0 @@ -open Angstrom -open Ast - -let skip_ws = skip_while (function ' ' -> true | _ -> false) -let parse_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' <* skip_ws -let add = skip_ws *> char '+' *> skip_ws *> return Binary_add -let sub = skip_ws *> char '-' *> skip_ws *> return Binary_subtract -let mul = skip_ws *> char '*' *> skip_ws *> return Binary_multiply -let div = skip_ws *> char '/' *> skip_ws *> return Binary_divide -let find_integer = - take_while1 (function '0' .. '9' -> true | _ -> false) >>| (fun s -> Const (Int_lt (int_of_string s))) - -(* find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) -let parse_chainl1 e op = - let rec go acc = - (lift2 (fun f x -> Bin_expr (f, acc, x)) op e >>= go) <|> return acc in - e >>= fun init -> go init <* skip_ws - -let find_expr : expr t = - fix (fun expr -> - let factor = (skip_ws *> parse_parens expr) <|> (skip_ws *> find_integer) in - let term = parse_chainl1 factor (mul <|> div) in - parse_chainl1 term (add <|> sub)) - -let parse (str:string) : expr = - match parse_string ~consume:All find_expr str with - | Ok v -> v - | Error msg -> failwith msg - -(* -(* saves info about positions explicitly during parsing *) -let parse_with_pos parser pos = - parser >>= fun (result, new_pos) -> - return (result, pos, new_pos) -;; - -(* assumes that something in brackets can be parsed further *) -let parse_parens p pos = - char '(' *> p (pos + 1) >>= fun (expr_inside, new_pos) -> - char ')' *> return (expr_inside, new_pos + 1) -;; -let parse_add pos = - char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_add, left, right), l_start, r_end)) -;; -let parse_sub pos = - char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_subtract, left, right), l_start, r_end)) -;; -let parse_mul pos = - char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_multiply, left, right), l_start, r_end)) -;; -let parse_div pos = - char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_divide, left, right), l_start, r_end)) -;; - -let find_const pos = - take_while1 (function - | '0' .. '9' -> true - | _ -> false) - >>= fun num -> - let num_length = String.length num in - return (Const (Int_lt (int_of_string num)), pos + num_length) -;; - -(* finds a chain of operands with the same priority and left associativity, e.g., a-b+c or a*b/c *) -let find_left_chain e func pos = - let rec go acc pos = - (* *) - lift2 (fun f x -> f acc x) (func pos) (e pos) >>= fun new_acc -> - go new_acc (pos + 1) <|> return acc - in - e pos >>= fun init -> go init pos - -(* parses an arithmetic expression with +-*/() completely *) -let rec find_arithm_expr pos : (expr * int) t = - let parser = (parse_parens find_arithm_expr pos) <|> find_const pos in - parser >>= fun (factor, new_pos) -> - let term = find_left_chain (fun pos -> parse_mul pos <|> parse_div pos) new_pos factor in - find_left_chain term (fun pos -> parse_add pos <|> parse_sub pos) new_pos -;; - - -let parse (str : string) : expr = - (* apply parser to string *) - match parse_string ~consume:All (find_arithm_expr 0) str with - | Ok (v, start_pos) -> v - | Error msg -> - failwith (Printf.sprintf "Error at position: %s" msg) *) - -(* -open Angstrom -open Ast - -(* saves info about positions explicitly during parsing *) -let parse_with_pos parser pos = - parser >>= fun (result, new_pos) -> - return (result, pos, new_pos) -;; - -(* assumes that something in brackets can be parsed further *) -let parse_parens p pos = - char '(' *> parse_with_pos p (pos + 1) <* char ')' -;; -let parse_add pos = - char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_add, left, right), l_start, r_end)) -;; -let parse_sub pos = - char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_subtract, left, right), l_start, r_end)) -;; -let parse_mul pos = - char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_multiply, left, right), l_start, r_end)) -;; -let parse_div pos = - char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_divide, left, right), l_start, r_end)) -;; - -let find_const pos = - take_while1 (function - | '0' .. '9' -> true - | _ -> false) - >>= fun num -> - let length = String.length num in - return (Const (Int_lt (int_of_string num)), pos, pos + length) -;; - -(* finds chain of operands on same priority level and with left associativity, such as a-b+c or a*b/c *) -let find_left_chain e func pos = - let rec go acc pos = - lift2 (fun f x -> f acc x) (func pos) (e pos) >>= fun new_acc -> - go new_acc (pos + 1) <|> return acc - in - e pos >>= fun init -> go init pos -;; - -(* parses arithmetical expression with +-*/() completely *) -let rec find_arithm_expr pos : (expr * int * int) t = - let rec expr_with_pos pos = - let factor = parse_parens (expr_with_pos pos) pos <|> find_const pos in - let term = find_left_chain factor (parse_mul pos <|> parse_div pos) pos in - find_left_chain term (parse_add pos <|> parse_sub pos) pos - in - expr_with_pos pos -;; - -let parse (str : string) : expr = - match parse_string ~consume:All (find_arithm_expr 0) str with - | Ok (v, start_pos, end_pos) -> ( - Printf.printf "start is %d" start_pos; - Printf.printf "end is %d" end_pos; - v - ) - | Error msg -> - failwith (Printf.sprintf "Error at position: %s" msg) *) - - - -(* - -open Angstrom -open Ast - -(* saves info about positions in string before and after parsing *) -let parse_with_pos parser = - pos >>= fun start_pos -> - parser >>= fun result -> - pos >>= fun end_pos -> - return (result, start_pos, end_pos) -;; - -let parse_parens p = char '(' *> parse_with_pos p <* char ')' (* assumes that something in brackets can be parsed further *) -let parse_add = char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_add, left, right), l_start, r_end)) -let parse_sub = char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_subtract, left, right), l_start, r_end)) -let parse_mul = char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_multiply, left, right), l_start, r_end)) -let parse_div = char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_divide, left, right), l_start, r_end)) - -let find_const = - pos >>= fun start_pos -> - take_while1 (function - | '0' .. '9' -> true - | _ -> false) - >>= fun num -> - pos >>= fun end_pos -> - return (Const (Int_lt (int_of_string num)), start_pos, end_pos) -;; - -(* finds chain of operands on same priority level and with left associativity, such as a-b+c or a*b/c *) -let find_left_chain e func = - let rec go acc = lift2 (fun f x -> f acc x) func e >>= go <|> return acc in - e >>= fun init -> go init -;; - -(* parses arithmetical expression with +-*/() completely *) -let rec find_arithm_expr : (expr * int * int) t = - let rec expr_with_pos () = - let factor = parse_parens (expr_with_pos ()) <|> find_const in - let term = find_left_chain factor (parse_mul <|> parse_div) in - find_left_chain term (parse_add <|> parse_sub) - in - expr_with_pos () -;; - - -let parse (str : string) : expr = - match parse_string ~consume:All find_arithm_expr str with - | Ok (v, start_pos, end_pos) -> ( - Printf.printf "start is %d" start_pos; - Printf.printf "end is %d" end_pos; - v - ) - | Error msg -> - failwith (Printf.sprintf "Error at position: %s" msg) *) diff --git a/FSharpActivePatterns/lib/dune b/FSharpActivePatterns/lib/dune index ba7a2a1ec..4a4c515ae 100644 --- a/FSharpActivePatterns/lib/dune +++ b/FSharpActivePatterns/lib/dune @@ -1,7 +1,7 @@ (library (name FSharpActivePatterns) (public_name FSharpActivePatterns) - (modules Ast PrintAst ArithmParser) + (modules Ast PrintAst Parser) (modules_without_implementation ast) (libraries angstrom) (preprocess diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml new file mode 100644 index 000000000..3a6a0096c --- /dev/null +++ b/FSharpActivePatterns/lib/parser.ml @@ -0,0 +1,270 @@ +open Angstrom +open Ast + +let skip_ws = + skip_while (function + | ' ' -> true + | _ -> false) +;; + +let parse_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' <* skip_ws +let add = skip_ws *> char '+' *> skip_ws *> return Binary_add +let sub = skip_ws *> char '-' *> skip_ws *> return Binary_subtract +let mul = skip_ws *> char '*' *> skip_ws *> return Binary_multiply +let div = skip_ws *> char '/' *> skip_ws *> return Binary_divide +let equal = skip_ws *> char '=' *> skip_ws *> return Binary_equal +let unequal = skip_ws *> string "<>" *> skip_ws *> return Binary_unequal +let less = skip_ws *> char '<' *> skip_ws *> return Binary_less +let less_or_equal = skip_ws *> string "<=" *> skip_ws *> return Binary_less_or_equal +let greater = skip_ws *> char '>' *> skip_ws *> return Binary_greater +let greater_or_equal = skip_ws *> string ">=" *> skip_ws *> return Binary_greater_or_equal +let log_or = skip_ws *> string "||" *> skip_ws *> return Logical_or +let log_and = skip_ws *> string "&&" *> skip_ws *> return Logical_and +let log_not = skip_ws *> string "not" *> skip_ws *> return Unary_negative + +let integer = + take_while1 (function + | '0' .. '9' -> true + | _ -> false) + >>| fun s -> Const (Int_lt (int_of_string s)) +;; + +(* find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) +let parse_binary_chainl1 e op = + let rec go acc = lift2 (fun f x -> Bin_expr (f, acc, x)) op e >>= go <|> return acc in + e >>= fun init -> go init <* skip_ws +;; + +let parse_binary_single e op = + e + >>= fun e1_expr -> + op >>= fun bin_op -> e >>= fun e2_expr -> return (Bin_expr (bin_op, e1_expr, e2_expr)) +;; + +let parse_unary_chainl1 e op = + let rec go acc = lift (fun f -> Unary_expr (f, acc)) op >>= go <|> return acc in + e >>= fun init -> go init +;; + +let bool = + string "true" <|> string "false" >>| fun s -> Const (Bool_lt (bool_of_string s)) +;; + +let int_expr : expr t = + fix (fun expr -> + let factor = skip_ws *> (parse_parens expr <|> integer) <* skip_ws in + let term = parse_binary_chainl1 factor (mul <|> div) in + parse_binary_chainl1 term (add <|> sub)) +;; + +let comparison_expr : expr t = + parse_binary_single + int_expr + (less <|> less_or_equal <|> greater <|> greater_or_equal <|> equal <|> unequal) + <|> parse_binary_single int_expr (equal <|> unequal) +;; + +let bool_expr : expr t = + fix (fun expr -> + let level1 = skip_ws *> (parse_parens expr <|> bool <|> comparison_expr) <* skip_ws in + let level2 = parse_unary_chainl1 level1 log_not in + let level3 = parse_binary_chainl1 level2 (equal <|> unequal) in + let level4 = parse_binary_chainl1 level3 log_and in + parse_binary_chainl1 level4 log_or) +;; + +let expr = bool_expr <|> int_expr + +let parse (str : string) : expr = + match parse_string ~consume:All expr str with + | Ok v -> v + | Error msg -> failwith msg +;; + +(* + (* saves info about positions explicitly during parsing *) + let parse_with_pos parser pos = + parser >>= fun (result, new_pos) -> + return (result, pos, new_pos) + ;; + + (* assumes that something in brackets can be parsed further *) + let parse_parens p pos = + char '(' *> p (pos + 1) >>= fun (expr_inside, new_pos) -> + char ')' *> return (expr_inside, new_pos + 1) + ;; + let parse_add pos = + char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_add, left, right), l_start, r_end)) + ;; + let parse_sub pos = + char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_subtract, left, right), l_start, r_end)) + ;; + let parse_mul pos = char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_multiply, left, right), l_start, r_end)) + ;; + let parse_div pos = + char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_divide, left, right), l_start, r_end)) + ;; + + let find_const pos = + take_while1 (function + | '0' .. '9' -> true + | _ -> false) + >>= fun num -> + let num_length = String.length num in + return (Const (Int_lt (int_of_string num)), pos + num_length) + ;; + + (* finds a chain of operands with the same priority and left associativity, e.g., a-b+c or a*b/c *) + let find_left_chain e func pos = + let rec go acc pos = + (* *) + lift2 (fun f x -> f acc x) (func pos) (e pos) >>= fun new_acc -> + go new_acc (pos + 1) <|> return acc + in + e pos >>= fun init -> go init pos + + (* parses an arithmetic expression with +-*/() completely *) + let rec find_arithm_expr pos : (expr * int) t = + let parser = (parse_parens find_arithm_expr pos) <|> find_const pos in + parser >>= fun (factor, new_pos) -> + let term = find_left_chain (fun pos -> parse_mul pos <|> parse_div pos) new_pos factor in + find_left_chain term (fun pos -> parse_add pos <|> parse_sub pos) new_pos + ;; + + let parse (str : string) : expr = + (* apply parser to string *) + match parse_string ~consume:All (find_arithm_expr 0) str with + | Ok (v, start_pos) -> v + | Error msg -> + failwith (Printf.sprintf "Error at position: %s" msg) *) + +(* + open Angstrom + open Ast + + (* saves info about positions explicitly during parsing *) + let parse_with_pos parser pos = + parser >>= fun (result, new_pos) -> + return (result, pos, new_pos) + ;; + + (* assumes that something in brackets can be parsed further *) + let parse_parens p pos = + char '(' *> parse_with_pos p (pos + 1) <* char ')' + ;; + let parse_add pos = + char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_add, left, right), l_start, r_end)) + ;; + let parse_sub pos = + char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_subtract, left, right), l_start, r_end)) + ;; + let parse_mul pos = + char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_multiply, left, right), l_start, r_end)) + ;; + let parse_div pos = + char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_divide, left, right), l_start, r_end)) + ;; + + let find_const pos = + take_while1 (function + | '0' .. '9' -> true + | _ -> false) + >>= fun num -> + let length = String.length num in + return (Const (Int_lt (int_of_string num)), pos, pos + length) + ;; + + (* finds chain of operands on same priority level and with left associativity, such as a-b+c or a*b/c *) + let find_left_chain e func pos = + let rec go acc pos = + lift2 (fun f x -> f acc x) (func pos) (e pos) >>= fun new_acc -> + go new_acc (pos + 1) <|> return acc + in + e pos >>= fun init -> go init pos + ;; + + (* parses arithmetical expression with +-*/() completely *) + let rec find_arithm_expr pos : (expr * int * int) t = + let rec expr_with_pos pos = + let factor = parse_parens (expr_with_pos pos) pos <|> find_const pos in + let term = find_left_chain factor (parse_mul pos <|> parse_div pos) pos in + find_left_chain term (parse_add pos <|> parse_sub pos) pos + in + expr_with_pos pos + ;; + + let parse (str : string) : expr = + match parse_string ~consume:All (find_arithm_expr 0) str with + | Ok (v, start_pos, end_pos) -> ( + Printf.printf "start is %d" start_pos; + Printf.printf "end is %d" end_pos; + v + ) + | Error msg -> + failwith (Printf.sprintf "Error at position: %s" msg) *) + +(* + open Angstrom + open Ast + + (* saves info about positions in string before and after parsing *) + let parse_with_pos parser = + pos >>= fun start_pos -> + parser >>= fun result -> + pos >>= fun end_pos -> + return (result, start_pos, end_pos) + ;; + + let parse_parens p = char '(' *> parse_with_pos p <* char ')' (* assumes that something in brackets can be parsed further *) + let parse_add = char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_add, left, right), l_start, r_end)) + let parse_sub = char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_subtract, left, right), l_start, r_end)) + let parse_mul = char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_multiply, left, right), l_start, r_end)) + let parse_div = char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> + (Bin_expr (Binary_divide, left, right), l_start, r_end)) + + let find_const = + pos >>= fun start_pos -> + take_while1 (function + | '0' .. '9' -> true + | _ -> false) + >>= fun num -> + pos >>= fun end_pos -> + return (Const (Int_lt (int_of_string num)), start_pos, end_pos) + ;; + + (* finds chain of operands on same priority level and with left associativity, such as a-b+c or a*b/c *) + let find_left_chain e func = + let rec go acc = lift2 (fun f x -> f acc x) func e >>= go <|> return acc in + e >>= fun init -> go init + ;; + + (* parses arithmetical expression with +-*/() completely *) + let rec find_arithm_expr : (expr * int * int) t = + let rec expr_with_pos () = + let factor = parse_parens (expr_with_pos ()) <|> find_const in + let term = find_left_chain factor (parse_mul <|> parse_div) in + find_left_chain term (parse_add <|> parse_sub) + in + expr_with_pos () + ;; + + let parse (str : string) : expr = + match parse_string ~consume:All find_arithm_expr str with + | Ok (v, start_pos, end_pos) -> ( + Printf.printf "start is %d" start_pos; + Printf.printf "end is %d" end_pos; + v + ) + | Error msg -> + failwith (Printf.sprintf "Error at position: %s" msg) *) From a7432f73a707c9c18397c5dbdf38c3b73954411b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 13 Oct 2024 00:28:35 +0300 Subject: [PATCH 045/310] docs: add parser docs Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 3a6a0096c..10a955216 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -29,26 +29,34 @@ let integer = >>| fun s -> Const (Int_lt (int_of_string s)) ;; -(* find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) let parse_binary_chainl1 e op = let rec go acc = lift2 (fun f x -> Bin_expr (f, acc, x)) op e >>= go <|> return acc in e >>= fun init -> go init <* skip_ws ;; +(** find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) -let parse_binary_single e op = +let parse_binary1 e op = e >>= fun e1_expr -> op >>= fun bin_op -> e >>= fun e2_expr -> return (Bin_expr (bin_op, e1_expr, e2_expr)) ;; +(** parse exactly one infix binary operation and returns Bin_expr (bin_op, e1, e2) *) let parse_unary_chainl1 e op = let rec go acc = lift (fun f -> Unary_expr (f, acc)) op >>= go <|> return acc in e >>= fun init -> go init ;; +(** parse chain of unary left-associated expressions, such as - + - - 3 and returns Unary_expr (f, expr) *) let bool = string "true" <|> string "false" >>| fun s -> Const (Bool_lt (bool_of_string s)) ;; +(** bool [b] accepts boolean_literal [b] and returns Const Bool_lt from it*) + +let string_expr = + skip_ws *> char '"' *> take_while (fun c -> c <> '"') >>| fun s -> Const (String_lt s) +;; +(** parse string literal [s] without escaping symbols and returns Const (String_lt [s]) *) let int_expr : expr t = fix (fun expr -> @@ -56,13 +64,15 @@ let int_expr : expr t = let term = parse_binary_chainl1 factor (mul <|> div) in parse_binary_chainl1 term (add <|> sub)) ;; +(** parse integer expression, such as [(3 + 5) * (12 - 5)] and returns Binary_expr (f, e1, e2) *) let comparison_expr : expr t = - parse_binary_single + parse_binary1 int_expr (less <|> less_or_equal <|> greater <|> greater_or_equal <|> equal <|> unequal) - <|> parse_binary_single int_expr (equal <|> unequal) + <|> parse_binary1 (int_expr <|> bool <|> string_expr) (equal <|> unequal) ;; +(** parse comparison expression with integers, bool literals and strings and return Bin_expr(comp_op, e1, e2) *) let bool_expr : expr t = fix (fun expr -> @@ -72,8 +82,9 @@ let bool_expr : expr t = let level4 = parse_binary_chainl1 level3 log_and in parse_binary_chainl1 level4 log_or) ;; +(** parse bool_expr, such as [3 > 2 || true <> false && 12 > 7] and returns boolean expr*) -let expr = bool_expr <|> int_expr +let expr = bool_expr <|> int_expr <|> string_expr let parse (str : string) : expr = match parse_string ~consume:All expr str with From a4cdfdce411303ba51556b858ddf879165c53893 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 13 Oct 2024 06:54:53 +0300 Subject: [PATCH 046/310] fix: parse_unary_chainl1, comparison operators parsing (<= < <>) Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 10a955216..234ee9cd7 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -1,3 +1,7 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + open Angstrom open Ast @@ -31,25 +35,25 @@ let integer = let parse_binary_chainl1 e op = let rec go acc = lift2 (fun f x -> Bin_expr (f, acc, x)) op e >>= go <|> return acc in - e >>= fun init -> go init <* skip_ws + e >>= fun init -> go init ;; (** find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) let parse_binary1 e op = - e - >>= fun e1_expr -> - op >>= fun bin_op -> e >>= fun e2_expr -> return (Bin_expr (bin_op, e1_expr, e2_expr)) + lift3 (fun e1 bin_op e2 -> Bin_expr (bin_op, e1, e2)) e op e ;; (** parse exactly one infix binary operation and returns Bin_expr (bin_op, e1, e2) *) -let parse_unary_chainl1 e op = - let rec go acc = lift (fun f -> Unary_expr (f, acc)) op >>= go <|> return acc in - e >>= fun init -> go init +let rec parse_unary_chainl1 e op = + (op >>= fun un_op -> parse_unary_chainl1 e op >>= fun expr -> return (Unary_expr (un_op, expr))) <|> e + ;; + (* >>= go <|> return acc in + op >>= fun init -> Unary_expr (init, go op ) *) (** parse chain of unary left-associated expressions, such as - + - - 3 and returns Unary_expr (f, expr) *) let bool = - string "true" <|> string "false" >>| fun s -> Const (Bool_lt (bool_of_string s)) + skip_ws *> string "true" <|> string "false" >>| fun s -> Const (Bool_lt (bool_of_string s)) ;; (** bool [b] accepts boolean_literal [b] and returns Const Bool_lt from it*) @@ -69,7 +73,7 @@ let int_expr : expr t = let comparison_expr : expr t = parse_binary1 int_expr - (less <|> less_or_equal <|> greater <|> greater_or_equal <|> equal <|> unequal) + (less_or_equal <|> greater_or_equal <|> unequal <|> less <|> greater <|> equal) <|> parse_binary1 (int_expr <|> bool <|> string_expr) (equal <|> unequal) ;; (** parse comparison expression with integers, bool literals and strings and return Bin_expr(comp_op, e1, e2) *) From bc2c2152b5de53ab6299bcbdb31996fdfd8a246f Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 13 Oct 2024 06:55:57 +0300 Subject: [PATCH 047/310] tests: add parser tests, change factorial test to .ml Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 30 +------- FSharpActivePatterns/lib/tests/dune | 2 +- FSharpActivePatterns/lib/tests/parser.ml | 80 +++++++++++++++++++++ FSharpActivePatterns/lib/tests/print_ast.ml | 69 ++++++++++++++++++ FSharpActivePatterns/tests/print_ast.t | 42 ----------- 5 files changed, 152 insertions(+), 71 deletions(-) create mode 100644 FSharpActivePatterns/lib/tests/parser.ml delete mode 100644 FSharpActivePatterns/tests/print_ast.t diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 2aed2840f..5f230a398 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -7,35 +7,9 @@ open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser let () = - let factorial = - Function_def - ( Rec - , Some "factorial" - , [ Variable (Ident "n") ] - , If_then_else - ( Bin_expr - ( Logical_or - , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 0)) - , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 1)) ) - , Const (Int_lt 1) - , Some - (Bin_expr - ( Binary_multiply - , Variable (Ident "n") - , Function_call - ( Variable (Ident "factorial") - , [ Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) - ] ) )) ) ) - in - let program = - [ Statement (Let (Ident "a", Const (Int_lt 10))) - ; Expr factorial - ; Expr (Function_call (Variable (Ident "factorial"), [ Variable (Ident "a") ])) - ] - in - List.iter print_construction program; Printf.printf "\n\n\n"; - let input = " 3 + 5 > 8" in + Printf.printf "gleb loh\n"; + let input = " 4 >= 5 " in let result = parse input in print_construction (Expr result) ;; diff --git a/FSharpActivePatterns/lib/tests/dune b/FSharpActivePatterns/lib/tests/dune index a8c113927..734ae264e 100644 --- a/FSharpActivePatterns/lib/tests/dune +++ b/FSharpActivePatterns/lib/tests/dune @@ -1,6 +1,6 @@ (library (name tests) - (modules Print_ast) + (modules Print_ast Parser) (libraries FSharpActivePatterns) (preprocess (pps ppx_expect ppx_deriving.show)) diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml new file mode 100644 index 000000000..1c9d42041 --- /dev/null +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -0,0 +1,80 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open FSharpActivePatterns.Parser +open FSharpActivePatterns.PrintAst +open FSharpActivePatterns.Ast +open Angstrom + +let parse (p : expr t) input = + match parse_string ~consume:All p input with + | Ok v -> Expr v + | Error msg -> failwith msg +;; + +let%expect_test "logical expr parsing" = + let input = {| (3 + 5) >= 8 || true && (5 <> 4) |} in + let result = parse bool_expr input in + print_construction result; + [%expect + {| + | Binary expr( + | Logical Or + --| Binary expr( + --| Binary Greater Or Equal + ----| Binary expr( + ----| Binary Add + ------| Const(Int: 3) + ------| Const(Int: 5) + ----| Const(Int: 8) + --| Binary expr( + --| Logical And + ----| Const(Bool: true) + ----| Binary expr( + ----| Binary Unequal + ------| Const(Int: 5) + ------| Const(Int: 4) |}] +;; + +let%expect_test "int_expr" = + let input = " (3 + 5) - (12 / 7)" in + let result = parse int_expr input in + print_construction result; + [%expect + {| + | Binary expr( + | Binary Subtract + --| Binary expr( + --| Binary Add + ----| Const(Int: 3) + ----| Const(Int: 5) + --| Binary expr( + --| Binary Divide + ----| Const(Int: 12) + ----| Const(Int: 7) |}] +;; + +let%expect_test "parse_unary_chainl1" = + let input = "not not ( not true && false || 3 > 5)" in + let result = parse (parse_unary_chainl1 bool_expr log_not) input in + print_construction result; + [%expect + {| + | Unary expr( + | Unary negative + --| Unary expr( + --| Unary negative + ----| Binary expr( + ----| Logical Or + ------| Binary expr( + ------| Logical And + --------| Unary expr( + --------| Unary negative + ----------| Const(Bool: true) + --------| Const(Bool: false) + ------| Binary expr( + ------| Binary Greater + --------| Const(Int: 3) + --------| Const(Int: 5) |}] +;; diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index f347924fd..c925adb46 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -5,6 +5,75 @@ open FSharpActivePatterns.Ast open FSharpActivePatterns.PrintAst +let%expect_test "print factorial" = + let factorial = + Function_def + ( Rec + , Some "factorial" + , [ Variable (Ident "n") ] + , If_then_else + ( Bin_expr + ( Logical_or + , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 0)) + , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 1)) ) + , Const (Int_lt 1) + , Some + (Bin_expr + ( Binary_multiply + , Variable (Ident "n") + , Function_call + ( Variable (Ident "factorial") + , [ Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) + ] ) )) ) ) + in + let program = + [ Statement (Let (Ident "a", Const (Int_lt 10))) + ; Expr factorial + ; Expr (Function_call (Variable (Ident "factorial"), [ Variable (Ident "a") ])) + ] + in + List.iter print_construction program; + [%expect + {| + | Let a = + --| Const(Int: 10) + | Rec Function(factorial): + ARGS + ----| Variable(n) + BODY + ----| If Then Else( + CONDITION + ------| Binary expr( + ------| Logical Or + --------| Binary expr( + --------| Binary Equal + ----------| Variable(n) + ----------| Const(Int: 0) + --------| Binary expr( + --------| Binary Equal + ----------| Variable(n) + ----------| Const(Int: 1) + THEN BRANCH + --------| Const(Int: 1) + ELSE BRANCH + --------| Binary expr( + --------| Binary Multiply + ----------| Variable(n) + ----------| Function Call: + FUNCTION + ------------| Variable(factorial) + ARGS + ------------| Binary expr( + ------------| Binary Subtract + --------------| Variable(n) + --------------| Const(Int: 1) + | Function Call: + FUNCTION + --| Variable(factorial) + ARGS + --| Variable(a) |}] +;; + let%expect_test "print double func" = let recursive = Nonrec in let name = Some "double" in diff --git a/FSharpActivePatterns/tests/print_ast.t b/FSharpActivePatterns/tests/print_ast.t deleted file mode 100644 index 9fe0c8212..000000000 --- a/FSharpActivePatterns/tests/print_ast.t +++ /dev/null @@ -1,42 +0,0 @@ -(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - - $ ../bin/main.exe - | Let a = - --| Const(Int: 10) - | Rec Function(factorial): - ARGS - ----| Variable(n) - BODY - ----| If Then Else( - CONDITION - ------| Binary expr( - ------| Logical Or - --------| Binary expr( - --------| Binary Equal - ----------| Variable(n) - ----------| Const(Int: 0) - --------| Binary expr( - --------| Binary Equal - ----------| Variable(n) - ----------| Const(Int: 1) - THEN BRANCH - --------| Const(Int: 1) - ELSE BRANCH - --------| Binary expr( - --------| Binary Multiply - ----------| Variable(n) - ----------| Function Call: - FUNCTION - ------------| Variable(factorial) - ARGS - ------------| Binary expr( - ------------| Binary Subtract - --------------| Variable(n) - --------------| Const(Int: 1) - | Function Call: - FUNCTION - --| Variable(factorial) - ARGS - --| Variable(a) From d86e911b736e1f119b0340139600831acaa8f39a Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 13 Oct 2024 07:49:16 +0300 Subject: [PATCH 048/310] feat: add if parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 46 +++++++++++++++--------- FSharpActivePatterns/lib/tests/parser.ml | 28 +++++++++++++-- 2 files changed, 55 insertions(+), 19 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 234ee9cd7..7dfe2e8b6 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -11,6 +11,7 @@ let skip_ws = | _ -> false) ;; +let skip_ws1 = char ' ' *> skip_ws let parse_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' <* skip_ws let add = skip_ws *> char '+' *> skip_ws *> return Binary_add let sub = skip_ws *> char '-' *> skip_ws *> return Binary_subtract @@ -33,63 +34,74 @@ let integer = >>| fun s -> Const (Int_lt (int_of_string s)) ;; +(** find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) let parse_binary_chainl1 e op = let rec go acc = lift2 (fun f x -> Bin_expr (f, acc, x)) op e >>= go <|> return acc in e >>= fun init -> go init ;; -(** find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) -let parse_binary1 e op = - lift3 (fun e1 bin_op e2 -> Bin_expr (bin_op, e1, e2)) e op e -;; (** parse exactly one infix binary operation and returns Bin_expr (bin_op, e1, e2) *) +let parse_binary1 e op = lift3 (fun e1 bin_op e2 -> Bin_expr (bin_op, e1, e2)) e op e -let rec parse_unary_chainl1 e op = - (op >>= fun un_op -> parse_unary_chainl1 e op >>= fun expr -> return (Unary_expr (un_op, expr))) <|> e - -;; - (* >>= go <|> return acc in - op >>= fun init -> Unary_expr (init, go op ) *) (** parse chain of unary left-associated expressions, such as - + - - 3 and returns Unary_expr (f, expr) *) +let rec parse_unary_chain e op = + op + >>= (fun un_op -> + parse_unary_chain e op >>= fun expr -> return (Unary_expr (un_op, expr))) + <|> e +;; +(** bool [b] accepts boolean_literal [b] and returns Const Bool_lt from it*) let bool = - skip_ws *> string "true" <|> string "false" >>| fun s -> Const (Bool_lt (bool_of_string s)) + skip_ws *> string "true" + <|> string "false" + >>| fun s -> Const (Bool_lt (bool_of_string s)) ;; -(** bool [b] accepts boolean_literal [b] and returns Const Bool_lt from it*) +(** parse string literal [s] without escaping symbols and returns Const (String_lt [s]) *) let string_expr = skip_ws *> char '"' *> take_while (fun c -> c <> '"') >>| fun s -> Const (String_lt s) ;; -(** parse string literal [s] without escaping symbols and returns Const (String_lt [s]) *) +(** parse integer expression, such as [(3 + 5) * (12 - 5)] and returns Binary_expr (f, e1, e2) *) let int_expr : expr t = fix (fun expr -> let factor = skip_ws *> (parse_parens expr <|> integer) <* skip_ws in let term = parse_binary_chainl1 factor (mul <|> div) in parse_binary_chainl1 term (add <|> sub)) ;; -(** parse integer expression, such as [(3 + 5) * (12 - 5)] and returns Binary_expr (f, e1, e2) *) +(** parse comparison expression with integers, bool literals and strings and return Bin_expr(comp_op, e1, e2) *) let comparison_expr : expr t = parse_binary1 int_expr (less_or_equal <|> greater_or_equal <|> unequal <|> less <|> greater <|> equal) <|> parse_binary1 (int_expr <|> bool <|> string_expr) (equal <|> unequal) ;; -(** parse comparison expression with integers, bool literals and strings and return Bin_expr(comp_op, e1, e2) *) +(** parse bool_expr, such as [3 > 2 || true <> false && 12 > 7] and returns boolean expr*) let bool_expr : expr t = fix (fun expr -> let level1 = skip_ws *> (parse_parens expr <|> bool <|> comparison_expr) <* skip_ws in - let level2 = parse_unary_chainl1 level1 log_not in + let level2 = parse_unary_chain level1 log_not in let level3 = parse_binary_chainl1 level2 (equal <|> unequal) in let level4 = parse_binary_chainl1 level3 log_and in parse_binary_chainl1 level4 log_or) ;; -(** parse bool_expr, such as [3 > 2 || true <> false && 12 > 7] and returns boolean expr*) let expr = bool_expr <|> int_expr <|> string_expr +let parse_if = + skip_ws + *> string "if" + *> skip_ws1 + *> lift3 + (fun cond th el -> If_then_else (cond, th, el)) + bool_expr + (string "then" *> expr) + (string "else" *> (expr >>= (fun e -> return (Some e)) <|> return None)) +;; + let parse (str : string) : expr = match parse_string ~consume:All expr str with | Ok v -> v diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index 1c9d42041..036ebf4f6 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -55,9 +55,9 @@ let%expect_test "int_expr" = ----| Const(Int: 7) |}] ;; -let%expect_test "parse_unary_chainl1" = +let%expect_test "parse_unary_chain" = let input = "not not ( not true && false || 3 > 5)" in - let result = parse (parse_unary_chainl1 bool_expr log_not) input in + let result = parse (parse_unary_chain bool_expr log_not) input in print_construction result; [%expect {| @@ -78,3 +78,27 @@ let%expect_test "parse_unary_chainl1" = --------| Const(Int: 3) --------| Const(Int: 5) |}] ;; + +let%expect_test "parse_unary_chainl1" = + let input = "if 3 > 2 && false then 5 + 7 else 12" in + let result = parse parse_if input in + print_construction result; + [%expect + {| + | If Then Else( + CONDITION + --| Binary expr( + --| Logical And + ----| Binary expr( + ----| Binary Greater + ------| Const(Int: 3) + ------| Const(Int: 2) + ----| Const(Bool: false) + THEN BRANCH + ----| Binary expr( + ----| Binary Add + ------| Const(Int: 5) + ------| Const(Int: 7) + ELSE BRANCH + ----| Const(Int: 12) |}] +;; From be2651cb32227e2fbe2f48c5d1f23fd5c106afa4 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 13 Oct 2024 20:15:05 +0300 Subject: [PATCH 049/310] fix: delete outdated comments Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 188 ----------------------------- 1 file changed, 188 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 7dfe2e8b6..318cb71de 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -107,191 +107,3 @@ let parse (str : string) : expr = | Ok v -> v | Error msg -> failwith msg ;; - -(* - (* saves info about positions explicitly during parsing *) - let parse_with_pos parser pos = - parser >>= fun (result, new_pos) -> - return (result, pos, new_pos) - ;; - - (* assumes that something in brackets can be parsed further *) - let parse_parens p pos = - char '(' *> p (pos + 1) >>= fun (expr_inside, new_pos) -> - char ')' *> return (expr_inside, new_pos + 1) - ;; - let parse_add pos = - char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_add, left, right), l_start, r_end)) - ;; - let parse_sub pos = - char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_subtract, left, right), l_start, r_end)) - ;; - let parse_mul pos = char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_multiply, left, right), l_start, r_end)) - ;; - let parse_div pos = - char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_divide, left, right), l_start, r_end)) - ;; - - let find_const pos = - take_while1 (function - | '0' .. '9' -> true - | _ -> false) - >>= fun num -> - let num_length = String.length num in - return (Const (Int_lt (int_of_string num)), pos + num_length) - ;; - - (* finds a chain of operands with the same priority and left associativity, e.g., a-b+c or a*b/c *) - let find_left_chain e func pos = - let rec go acc pos = - (* *) - lift2 (fun f x -> f acc x) (func pos) (e pos) >>= fun new_acc -> - go new_acc (pos + 1) <|> return acc - in - e pos >>= fun init -> go init pos - - (* parses an arithmetic expression with +-*/() completely *) - let rec find_arithm_expr pos : (expr * int) t = - let parser = (parse_parens find_arithm_expr pos) <|> find_const pos in - parser >>= fun (factor, new_pos) -> - let term = find_left_chain (fun pos -> parse_mul pos <|> parse_div pos) new_pos factor in - find_left_chain term (fun pos -> parse_add pos <|> parse_sub pos) new_pos - ;; - - let parse (str : string) : expr = - (* apply parser to string *) - match parse_string ~consume:All (find_arithm_expr 0) str with - | Ok (v, start_pos) -> v - | Error msg -> - failwith (Printf.sprintf "Error at position: %s" msg) *) - -(* - open Angstrom - open Ast - - (* saves info about positions explicitly during parsing *) - let parse_with_pos parser pos = - parser >>= fun (result, new_pos) -> - return (result, pos, new_pos) - ;; - - (* assumes that something in brackets can be parsed further *) - let parse_parens p pos = - char '(' *> parse_with_pos p (pos + 1) <* char ')' - ;; - let parse_add pos = - char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_add, left, right), l_start, r_end)) - ;; - let parse_sub pos = - char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_subtract, left, right), l_start, r_end)) - ;; - let parse_mul pos = - char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_multiply, left, right), l_start, r_end)) - ;; - let parse_div pos = - char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_divide, left, right), l_start, r_end)) - ;; - - let find_const pos = - take_while1 (function - | '0' .. '9' -> true - | _ -> false) - >>= fun num -> - let length = String.length num in - return (Const (Int_lt (int_of_string num)), pos, pos + length) - ;; - - (* finds chain of operands on same priority level and with left associativity, such as a-b+c or a*b/c *) - let find_left_chain e func pos = - let rec go acc pos = - lift2 (fun f x -> f acc x) (func pos) (e pos) >>= fun new_acc -> - go new_acc (pos + 1) <|> return acc - in - e pos >>= fun init -> go init pos - ;; - - (* parses arithmetical expression with +-*/() completely *) - let rec find_arithm_expr pos : (expr * int * int) t = - let rec expr_with_pos pos = - let factor = parse_parens (expr_with_pos pos) pos <|> find_const pos in - let term = find_left_chain factor (parse_mul pos <|> parse_div pos) pos in - find_left_chain term (parse_add pos <|> parse_sub pos) pos - in - expr_with_pos pos - ;; - - let parse (str : string) : expr = - match parse_string ~consume:All (find_arithm_expr 0) str with - | Ok (v, start_pos, end_pos) -> ( - Printf.printf "start is %d" start_pos; - Printf.printf "end is %d" end_pos; - v - ) - | Error msg -> - failwith (Printf.sprintf "Error at position: %s" msg) *) - -(* - open Angstrom - open Ast - - (* saves info about positions in string before and after parsing *) - let parse_with_pos parser = - pos >>= fun start_pos -> - parser >>= fun result -> - pos >>= fun end_pos -> - return (result, start_pos, end_pos) - ;; - - let parse_parens p = char '(' *> parse_with_pos p <* char ')' (* assumes that something in brackets can be parsed further *) - let parse_add = char '+' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_add, left, right), l_start, r_end)) - let parse_sub = char '-' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_subtract, left, right), l_start, r_end)) - let parse_mul = char '*' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_multiply, left, right), l_start, r_end)) - let parse_div = char '/' *> return (fun (left, l_start, l_end) (right, r_start, r_end) -> - (Bin_expr (Binary_divide, left, right), l_start, r_end)) - - let find_const = - pos >>= fun start_pos -> - take_while1 (function - | '0' .. '9' -> true - | _ -> false) - >>= fun num -> - pos >>= fun end_pos -> - return (Const (Int_lt (int_of_string num)), start_pos, end_pos) - ;; - - (* finds chain of operands on same priority level and with left associativity, such as a-b+c or a*b/c *) - let find_left_chain e func = - let rec go acc = lift2 (fun f x -> f acc x) func e >>= go <|> return acc in - e >>= fun init -> go init - ;; - - (* parses arithmetical expression with +-*/() completely *) - let rec find_arithm_expr : (expr * int * int) t = - let rec expr_with_pos () = - let factor = parse_parens (expr_with_pos ()) <|> find_const in - let term = find_left_chain factor (parse_mul <|> parse_div) in - find_left_chain term (parse_add <|> parse_sub) - in - expr_with_pos () - ;; - - let parse (str : string) : expr = - match parse_string ~consume:All find_arithm_expr str with - | Ok (v, start_pos, end_pos) -> ( - Printf.printf "start is %d" start_pos; - Printf.printf "end is %d" end_pos; - v - ) - | Error msg -> - failwith (Printf.sprintf "Error at position: %s" msg) *) From 963cd8ded249ec1059d56a58fba3896f7780caaa Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 13 Oct 2024 21:53:15 +0300 Subject: [PATCH 050/310] fix: edit parser logic slighgtly and rename functions to verbs Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 31 +++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 318cb71de..825610106 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -8,6 +8,7 @@ open Ast let skip_ws = skip_while (function | ' ' -> true + | '\n' -> true | _ -> false) ;; @@ -27,13 +28,19 @@ let log_or = skip_ws *> string "||" *> skip_ws *> return Logical_or let log_and = skip_ws *> string "&&" *> skip_ws *> return Logical_and let log_not = skip_ws *> string "not" *> skip_ws *> return Unary_negative -let integer = +let parse_integer = take_while1 (function | '0' .. '9' -> true | _ -> false) >>| fun s -> Const (Int_lt (int_of_string s)) ;; +let parse_word = + take_while1 (function + | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true + | _ -> false) + >>| fun s -> Variable(Ident(s)) + (** find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) let parse_binary_chainl1 e op = let rec go acc = lift2 (fun f x -> Bin_expr (f, acc, x)) op e >>= go <|> return acc in @@ -52,7 +59,7 @@ let rec parse_unary_chain e op = ;; (** bool [b] accepts boolean_literal [b] and returns Const Bool_lt from it*) -let bool = +let parse_bool = skip_ws *> string "true" <|> string "false" >>| fun s -> Const (Bool_lt (bool_of_string s)) @@ -60,13 +67,13 @@ let bool = (** parse string literal [s] without escaping symbols and returns Const (String_lt [s]) *) let string_expr = - skip_ws *> char '"' *> take_while (fun c -> c <> '"') >>| fun s -> Const (String_lt s) + skip_ws *> char '\"' *> take_while (fun c -> c <> '\"') >>| fun s -> Const (String_lt s) ;; (** parse integer expression, such as [(3 + 5) * (12 - 5)] and returns Binary_expr (f, e1, e2) *) let int_expr : expr t = fix (fun expr -> - let factor = skip_ws *> (parse_parens expr <|> integer) <* skip_ws in + let factor = skip_ws *> (parse_parens expr <|> parse_integer <|> parse_word) <* skip_ws in let term = parse_binary_chainl1 factor (mul <|> div) in parse_binary_chainl1 term (add <|> sub)) ;; @@ -76,20 +83,20 @@ let comparison_expr : expr t = parse_binary1 int_expr (less_or_equal <|> greater_or_equal <|> unequal <|> less <|> greater <|> equal) - <|> parse_binary1 (int_expr <|> bool <|> string_expr) (equal <|> unequal) + <|> parse_binary1 (int_expr <|> parse_bool <|> string_expr) (equal <|> unequal) ;; (** parse bool_expr, such as [3 > 2 || true <> false && 12 > 7] and returns boolean expr*) let bool_expr : expr t = fix (fun expr -> - let level1 = skip_ws *> (parse_parens expr <|> bool <|> comparison_expr) <* skip_ws in + let level1 = skip_ws *> (parse_parens expr <|> parse_bool <|> comparison_expr) <* skip_ws in let level2 = parse_unary_chain level1 log_not in let level3 = parse_binary_chainl1 level2 (equal <|> unequal) in let level4 = parse_binary_chainl1 level3 log_and in parse_binary_chainl1 level4 log_or) ;; -let expr = bool_expr <|> int_expr <|> string_expr +let parse_expr = bool_expr <|> int_expr <|> string_expr let parse_if = skip_ws @@ -98,12 +105,14 @@ let parse_if = *> lift3 (fun cond th el -> If_then_else (cond, th, el)) bool_expr - (string "then" *> expr) - (string "else" *> (expr >>= (fun e -> return (Some e)) <|> return None)) -;; + (string "then" *> parse_expr) + (string "else" *> (parse_expr >>= fun e -> return (Some e)) <|> return None) +;; + +let parse_statement = parse_if <|> parse_expr let parse (str : string) : expr = - match parse_string ~consume:All expr str with + match parse_string ~consume:All parse_statement str with | Ok v -> v | Error msg -> failwith msg ;; From cbe3906efc703b7f9c5d5def76b3c519ef3884e2 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 13 Oct 2024 21:53:52 +0300 Subject: [PATCH 051/310] feat: add new example Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/main.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 5f230a398..6eb72f8ae 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -9,7 +9,9 @@ open FSharpActivePatterns.Parser let () = Printf.printf "\n\n\n"; Printf.printf "gleb loh\n"; - let input = " 4 >= 5 " in + let input = "if ((n = 0) || (n = 1)) + then 1 + else n" in let result = parse input in print_construction (Expr result) ;; From 574ffbef8eea92872d5c53309e3270e570e4b88f Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 13 Oct 2024 21:54:23 +0300 Subject: [PATCH 052/310] fix: gleb is not loh anymore Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/main.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 6eb72f8ae..f40a9be98 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -7,8 +7,6 @@ open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser let () = - Printf.printf "\n\n\n"; - Printf.printf "gleb loh\n"; let input = "if ((n = 0) || (n = 1)) then 1 else n" in From 616b847760c2ac0e13a94a84ad7b1a031f5f5c5f Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 13 Oct 2024 23:13:47 +0300 Subject: [PATCH 053/310] fix: change let to describe both functions and single values, function_def now is meant for anonymous functions Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 4 +-- FSharpActivePatterns/lib/printAst.ml | 41 +++++++++++++++++----------- 2 files changed, 27 insertions(+), 18 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index ba504510f..8a42f774a 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -61,11 +61,11 @@ type expr = | Unary_expr of unary_operator * expr | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) - | Function_def of is_recursive * string option * expr list * expr + | Function_def of expr list * expr (**rec, name, args, body*) | Function_call of expr * expr list (** [sum 1 ] *) | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) - | LetIn of ident * expr * expr (** [let x = 5 in x * y] *) + | Let of is_recursive * ident option * expr list option * expr * expr option (** [let x = 5 in x * y] *) [@@deriving eq, show { with_path = false }] type statement = diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index ea124e2e0..5c1b6abf7 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -98,16 +98,8 @@ let rec print_expr indent expr = (match else_body with | Some body -> print_expr (indent + 4) body | None -> printf "No else body") - | Function_def (flag, name, args, body) -> - printf - "%s| %s Function(%s):\n" - (String.make indent '-') - (match flag with - | Nonrec -> "" - | Rec -> "Rec") - (match name with - | Some n -> n - | None -> "Anonymous"); + | Function_def (args, body) -> + printf "%s| Func:\n" (String.make indent '-'); printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 4)) args; printf "%sBODY\n" (String.make (indent + 2) ' '); @@ -118,12 +110,29 @@ let rec print_expr indent expr = print_expr (indent + 2) func; printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 2)) args - | LetIn (Ident name, value, inner_expr) -> - printf "%s | LetIn %s =\n" (String.make indent '-') name; - printf "%sVALUE\n" (String.make (indent + 2) ' '); - print_expr (indent + 2) value; - printf "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); - print_expr (indent + 2) inner_expr + | Let (flag, name, args, body, in_expr) -> + printf "%s | Let %s %s =\n" (String.make indent '-') + (match flag with + | Nonrec -> "" + | Rec -> "Rec") + (match name with + | Some Ident(n) -> n + | None -> "Anonymous"); + printf "%sARGS\n" (String.make (indent + 2) ' '); + match args with + | None -> printf "NO ARGS"; + | Some args -> ( + printf "%sARGS\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 2)) args; + ); + printf "%sBODY\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) body; + match in_expr with + | None -> printf "NO IN EXPR"; + | Some in_expr -> ( + printf "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) in_expr; + ); ;; let print_statement indent = function From 000b76261c7eaa9c115475c1bf5c5558ac8fb972 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 14 Oct 2024 02:02:22 +0300 Subject: [PATCH 054/310] fix: refactor arch of parser Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/main.ml | 5 ++- FSharpActivePatterns/lib/ast.mli | 2 +- FSharpActivePatterns/lib/parser.ml | 55 ++++++++++++++++++++++------ FSharpActivePatterns/lib/printAst.ml | 2 +- 4 files changed, 48 insertions(+), 16 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index f40a9be98..0a033a0cd 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -8,8 +8,9 @@ open FSharpActivePatterns.Parser let () = let input = "if ((n = 0) || (n = 1)) - then 1 - else n" in + then 1 + else (n + 1) + " in let result = parse input in print_construction (Expr result) ;; diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 8a42f774a..6066c0ad4 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -65,7 +65,7 @@ type expr = (**rec, name, args, body*) | Function_call of expr * expr list (** [sum 1 ] *) | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) - | Let of is_recursive * ident option * expr list option * expr * expr option (** [let x = 5 in x * y] *) + | LetIn of is_recursive * ident option * expr list option * expr * expr option (** [let x = 5 in x * y] *) [@@deriving eq, show { with_path = false }] type statement = diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 825610106..64bd99b9d 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -9,6 +9,7 @@ let skip_ws = skip_while (function | ' ' -> true | '\n' -> true + | '\t' -> true | _ -> false) ;; @@ -35,11 +36,13 @@ let parse_integer = >>| fun s -> Const (Int_lt (int_of_string s)) ;; -let parse_word = +let parse_ident = take_while1 (function | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true | _ -> false) - >>| fun s -> Variable(Ident(s)) + >>| fun s -> Ident(s) + +let parse_word = parse_ident >>| (fun ident -> Variable(ident)) (** find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) let parse_binary_chainl1 e op = @@ -96,20 +99,48 @@ let bool_expr : expr t = parse_binary_chainl1 level4 log_or) ;; -let parse_expr = bool_expr <|> int_expr <|> string_expr +let parse_expr parse_statement = + choice + [ + parse_parens parse_statement; + bool_expr; + string_expr; + int_expr; + ] +;; + +let parse_if parse_statement = + fix + (fun parse_if -> + lift3 + (fun cond th el -> If_then_else (cond, th, el)) + (skip_ws *> string "if" *> skip_ws1 *> bool_expr) + (skip_ws *> string "then" *> (parse_if <|> parse_statement)) + (skip_ws *> string "else" *> ((parse_if <|> parse_statement) >>= fun e -> return (Some e)) <|> return None) + ) +;; -let parse_if = +let parse_let parse_statement = skip_ws - *> string "if" + *> string "let" *> skip_ws1 - *> lift3 - (fun cond th el -> If_then_else (cond, th, el)) - bool_expr - (string "then" *> parse_expr) - (string "else" *> (parse_expr >>= fun e -> return (Some e)) <|> return None) -;; + *> lift4 + (fun rec_flag name args body in_expr -> LetIn(rec_flag, name, args, body, in_expr)) + (string "rec" *> return Rec <|> return Nonrec) + (skip_ws *> parse_ident >>= fun ident -> return (Some(ident)) <|> return None) + (skip_ws *> many (parse_expr parse_statement) >>= fun args -> if List.length args > 0 then return (Some(args)) else return None) + (skip_ws *> string "=" *> skip_ws *> parse_statement) <*> + (skip_ws *> string "in" *> (parse_statement >>= fun e -> return (Some e)) <|> return None) +;; -let parse_statement = parse_if <|> parse_expr +let parse_statement = + fix + (fun parse_statement -> + let statement = parse_let parse_statement in + let statement = parse_if statement <|> statement in + let statement = parse_expr statement <|> statement in + statement) +;; let parse (str : string) : expr = match parse_string ~consume:All parse_statement str with diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 5c1b6abf7..c54136097 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -110,7 +110,7 @@ let rec print_expr indent expr = print_expr (indent + 2) func; printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 2)) args - | Let (flag, name, args, body, in_expr) -> + | LetIn (flag, name, args, body, in_expr) -> printf "%s | Let %s %s =\n" (String.make indent '-') (match flag with | Nonrec -> "" From f52642fd73f07349be964a4044768e8f5e81c833 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 14 Oct 2024 02:32:33 +0300 Subject: [PATCH 055/310] feat: add keywords Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 64bd99b9d..e7710b454 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -4,6 +4,9 @@ open Angstrom open Ast +open PrintAst + +let keywords = ["if"; "then"; "else"; "let"; "in"] let skip_ws = skip_while (function @@ -40,9 +43,12 @@ let parse_ident = take_while1 (function | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true | _ -> false) - >>| fun s -> Ident(s) + >>= fun str -> + if List.mem str keywords then fail " no keywords pls " + else return (Ident(str)) -let parse_word = parse_ident >>| (fun ident -> Variable(ident)) +let parse_word = + parse_ident >>| fun ident -> Variable ident (** find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) let parse_binary_chainl1 e op = @@ -133,17 +139,25 @@ let parse_let parse_statement = (skip_ws *> string "in" *> (parse_statement >>= fun e -> return (Some e)) <|> return None) ;; +let debug p = + p >>= fun result -> + print_expr 0 result; + return result +;; + let parse_statement = fix (fun parse_statement -> let statement = parse_let parse_statement in let statement = parse_if statement <|> statement in let statement = parse_expr statement <|> statement in - statement) + debug statement) ;; let parse (str : string) : expr = - match parse_string ~consume:All parse_statement str with + match parse_string ~consume:All (skip_ws *> parse_statement <* skip_ws) str with | Ok v -> v - | Error msg -> failwith msg + | Error msg -> ( + Printf.printf "%s " msg; + failwith msg) ;; From d037c07d223d8a0c61d975488201aa01bba76f43 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 14 Oct 2024 05:09:18 +0300 Subject: [PATCH 056/310] fix: smth Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/main.ml | 8 ++++-- FSharpActivePatterns/lib/parser.ml | 44 ++++++++++++++++++------------ 2 files changed, 32 insertions(+), 20 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 0a033a0cd..22753eb3f 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -7,9 +7,11 @@ open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser let () = - let input = "if ((n = 0) || (n = 1)) - then 1 - else (n + 1) + let input = "let factorial n = + if ((n = 0) || (n = 1)) + then 1 + else (n + 1) + in n * factorial (n-1) " in let result = parse input in print_construction (Expr result) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index e7710b454..8371fba3e 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -79,26 +79,34 @@ let string_expr = skip_ws *> char '\"' *> take_while (fun c -> c <> '\"') >>| fun s -> Const (String_lt s) ;; +let parse_function_call parse_statement : expr t = + parse_ident >>= fun func_name -> + skip_ws *> many (skip_ws *> parse_statement) >>= fun args -> + if List.length args > 0 then + return (Function_call (Variable func_name, args)) + else return (Variable func_name) +;; + (** parse integer expression, such as [(3 + 5) * (12 - 5)] and returns Binary_expr (f, e1, e2) *) -let int_expr : expr t = +let int_expr parse_statement: expr t = fix (fun expr -> - let factor = skip_ws *> (parse_parens expr <|> parse_integer <|> parse_word) <* skip_ws in + let factor = skip_ws *> (parse_function_call parse_statement <|> parse_parens expr <|> parse_integer <|> parse_word) <* skip_ws in let term = parse_binary_chainl1 factor (mul <|> div) in parse_binary_chainl1 term (add <|> sub)) ;; (** parse comparison expression with integers, bool literals and strings and return Bin_expr(comp_op, e1, e2) *) -let comparison_expr : expr t = +let comparison_expr parse_statement : expr t = parse_binary1 - int_expr + (int_expr parse_statement) (less_or_equal <|> greater_or_equal <|> unequal <|> less <|> greater <|> equal) - <|> parse_binary1 (int_expr <|> parse_bool <|> string_expr) (equal <|> unequal) + <|> parse_binary1 (int_expr parse_statement <|> parse_bool <|> string_expr) (equal <|> unequal) ;; (** parse bool_expr, such as [3 > 2 || true <> false && 12 > 7] and returns boolean expr*) -let bool_expr : expr t = +let bool_expr parse_statement : expr t = fix (fun expr -> - let level1 = skip_ws *> (parse_parens expr <|> parse_bool <|> comparison_expr) <* skip_ws in + let level1 = skip_ws *> (parse_parens expr <|> parse_bool <|> comparison_expr parse_statement) <* skip_ws in let level2 = parse_unary_chain level1 log_not in let level3 = parse_binary_chainl1 level2 (equal <|> unequal) in let level4 = parse_binary_chainl1 level3 log_and in @@ -108,10 +116,11 @@ let bool_expr : expr t = let parse_expr parse_statement = choice [ + parse_function_call parse_statement; + int_expr parse_statement; parse_parens parse_statement; - bool_expr; + bool_expr parse_statement; string_expr; - int_expr; ] ;; @@ -120,9 +129,9 @@ let parse_if parse_statement = (fun parse_if -> lift3 (fun cond th el -> If_then_else (cond, th, el)) - (skip_ws *> string "if" *> skip_ws1 *> bool_expr) - (skip_ws *> string "then" *> (parse_if <|> parse_statement)) - (skip_ws *> string "else" *> ((parse_if <|> parse_statement) >>= fun e -> return (Some e)) <|> return None) + (skip_ws *> string "if" *> skip_ws1 *> bool_expr parse_statement) + (skip_ws *> string "then" *> parse_statement) + (skip_ws *> string "else" *> (parse_statement >>= fun e -> return (Some e)) <|> return None) ) ;; @@ -134,7 +143,7 @@ let parse_let parse_statement = (fun rec_flag name args body in_expr -> LetIn(rec_flag, name, args, body, in_expr)) (string "rec" *> return Rec <|> return Nonrec) (skip_ws *> parse_ident >>= fun ident -> return (Some(ident)) <|> return None) - (skip_ws *> many (parse_expr parse_statement) >>= fun args -> if List.length args > 0 then return (Some(args)) else return None) + (skip_ws *> many (skip_ws *> parse_word) >>= fun args -> if List.length args > 0 then return (Some(args)) else return None) (skip_ws *> string "=" *> skip_ws *> parse_statement) <*> (skip_ws *> string "in" *> (parse_statement >>= fun e -> return (Some e)) <|> return None) ;; @@ -146,12 +155,13 @@ let debug p = ;; let parse_statement = + skip_ws *> fix (fun parse_statement -> - let statement = parse_let parse_statement in - let statement = parse_if statement <|> statement in - let statement = parse_expr statement <|> statement in - debug statement) + let statement = parse_if parse_statement in + let statement = parse_expr statement <|> statement in + let statement = parse_let statement <|> statement in + statement) ;; let parse (str : string) : expr = From 03bc1a4fb538da06adfc497abbc0cf7de2ccea05 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 14 Oct 2024 18:07:22 +0300 Subject: [PATCH 057/310] fix: edit parser Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/main.ml | 11 +- FSharpActivePatterns/lib/ast.mli | 2 +- FSharpActivePatterns/lib/parser.ml | 196 ++++++++++----------------- FSharpActivePatterns/lib/printAst.ml | 8 +- 4 files changed, 85 insertions(+), 132 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 22753eb3f..c2d8de987 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -7,12 +7,11 @@ open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser let () = - let input = "let factorial n = - if ((n = 0) || (n = 1)) - then 1 - else (n + 1) - in n * factorial (n-1) - " in + let input = "let factorial n = + if ((n = 0)||(n = 1)) + then 1 + else n * factorial (n - 1) + in factorial (b)" in let result = parse input in print_construction (Expr result) ;; diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 6066c0ad4..1d4125ac3 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -63,7 +63,7 @@ type expr = | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) | Function_def of expr list * expr (**rec, name, args, body*) - | Function_call of expr * expr list (** [sum 1 ] *) + | Function_call of expr * expr (** [sum 1 ] *) | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) | LetIn of is_recursive * ident option * expr list option * expr * expr option (** [let x = 5 in x * y] *) [@@deriving eq, show { with_path = false }] diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 8371fba3e..7636d729e 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -6,8 +6,7 @@ open Angstrom open Ast open PrintAst -let keywords = ["if"; "then"; "else"; "let"; "in"] - +(* TECHNICAL FUNCTIONS *) let skip_ws = skip_while (function | ' ' -> true @@ -15,157 +14,112 @@ let skip_ws = | '\t' -> true | _ -> false) ;; - let skip_ws1 = char ' ' *> skip_ws -let parse_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' <* skip_ws -let add = skip_ws *> char '+' *> skip_ws *> return Binary_add -let sub = skip_ws *> char '-' *> skip_ws *> return Binary_subtract -let mul = skip_ws *> char '*' *> skip_ws *> return Binary_multiply -let div = skip_ws *> char '/' *> skip_ws *> return Binary_divide -let equal = skip_ws *> char '=' *> skip_ws *> return Binary_equal -let unequal = skip_ws *> string "<>" *> skip_ws *> return Binary_unequal -let less = skip_ws *> char '<' *> skip_ws *> return Binary_less -let less_or_equal = skip_ws *> string "<=" *> skip_ws *> return Binary_less_or_equal -let greater = skip_ws *> char '>' *> skip_ws *> return Binary_greater -let greater_or_equal = skip_ws *> string ">=" *> skip_ws *> return Binary_greater_or_equal -let log_or = skip_ws *> string "||" *> skip_ws *> return Logical_or -let log_and = skip_ws *> string "&&" *> skip_ws *> return Logical_and -let log_not = skip_ws *> string "not" *> skip_ws *> return Unary_negative -let parse_integer = +let chainl1 e op = + let rec go acc = lift2 (fun f x -> f acc x) op e >>= go <|> return acc in + e >>= go +;; + +(* SIMPLE PARSERS *) +let p_int = take_while1 (function | '0' .. '9' -> true | _ -> false) >>| fun s -> Const (Int_lt (int_of_string s)) ;; -let parse_ident = +let keywords = ["if"; "then"; "else"; "let"; "in"] + +let p_ident = take_while1 (function | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true | _ -> false) >>= fun str -> if List.mem str keywords then fail " no keywords pls " - else return (Ident(str)) - -let parse_word = - parse_ident >>| fun ident -> Variable ident - -(** find full chain of left-associated expressions on the same level of associativity, such as a-b+cc or a*b/c *) -let parse_binary_chainl1 e op = - let rec go acc = lift2 (fun f x -> Bin_expr (f, acc, x)) op e >>= go <|> return acc in - e >>= fun init -> go init -;; - -(** parse exactly one infix binary operation and returns Bin_expr (bin_op, e1, e2) *) -let parse_binary1 e op = lift3 (fun e1 bin_op e2 -> Bin_expr (bin_op, e1, e2)) e op e + else ( + return (Ident(str))) +;; -(** parse chain of unary left-associated expressions, such as - + - - 3 and returns Unary_expr (f, expr) *) -let rec parse_unary_chain e op = - op - >>= (fun un_op -> - parse_unary_chain e op >>= fun expr -> return (Unary_expr (un_op, expr))) - <|> e +let p_var = + p_ident >>| fun ident -> Variable ident ;; -(** bool [b] accepts boolean_literal [b] and returns Const Bool_lt from it*) -let parse_bool = - skip_ws *> string "true" - <|> string "false" - >>| fun s -> Const (Bool_lt (bool_of_string s)) -;; - -(** parse string literal [s] without escaping symbols and returns Const (String_lt [s]) *) -let string_expr = - skip_ws *> char '\"' *> take_while (fun c -> c <> '\"') >>| fun s -> Const (String_lt s) -;; - -let parse_function_call parse_statement : expr t = - parse_ident >>= fun func_name -> - skip_ws *> many (skip_ws *> parse_statement) >>= fun args -> - if List.length args > 0 then - return (Function_call (Variable func_name, args)) - else return (Variable func_name) -;; - -(** parse integer expression, such as [(3 + 5) * (12 - 5)] and returns Binary_expr (f, e1, e2) *) -let int_expr parse_statement: expr t = - fix (fun expr -> - let factor = skip_ws *> (parse_function_call parse_statement <|> parse_parens expr <|> parse_integer <|> parse_word) <* skip_ws in - let term = parse_binary_chainl1 factor (mul <|> div) in - parse_binary_chainl1 term (add <|> sub)) -;; - -(** parse comparison expression with integers, bool literals and strings and return Bin_expr(comp_op, e1, e2) *) -let comparison_expr parse_statement : expr t = - parse_binary1 - (int_expr parse_statement) - (less_or_equal <|> greater_or_equal <|> unequal <|> less <|> greater <|> equal) - <|> parse_binary1 (int_expr parse_statement <|> parse_bool <|> string_expr) (equal <|> unequal) -;; +(* EXPR PARSERS *) +let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' <* skip_ws + +let make_binexpr op expr1 expr2 = Bin_expr (op, expr1, expr2) +let p_binexpr binop constr = skip_ws *> string binop *> skip_ws *> return (make_binexpr constr) +let apply name arg = Function_call (name, arg) +let add = p_binexpr "+" Binary_add +let sub = p_binexpr "-" Binary_subtract +let mul = p_binexpr "*" Binary_multiply +let div = p_binexpr "/" Binary_divide +let equal = p_binexpr "=" Binary_equal +let unequal = p_binexpr "<>" Binary_unequal +let less = p_binexpr "<" Binary_less +let less_or_equal = p_binexpr "<=" Binary_less_or_equal +let greater = p_binexpr ">" Binary_greater +let greater_or_equal = p_binexpr ">=" Binary_greater_or_equal +let log_or = p_binexpr "||" Logical_or +let log_and = p_binexpr "&&" Logical_and +let log_not = skip_ws *> string "not" *> skip_ws *> return Unary_negative -(** parse bool_expr, such as [3 > 2 || true <> false && 12 > 7] and returns boolean expr*) -let bool_expr parse_statement : expr t = - fix (fun expr -> - let level1 = skip_ws *> (parse_parens expr <|> parse_bool <|> comparison_expr parse_statement) <* skip_ws in - let level2 = parse_unary_chain level1 log_not in - let level3 = parse_binary_chainl1 level2 (equal <|> unequal) in - let level4 = parse_binary_chainl1 level3 log_and in - parse_binary_chainl1 level4 log_or) +let p_if p_expr = + fix (fun p_if -> + lift3 + (fun cond th el -> If_then_else (cond, th, el)) + (skip_ws *> string "if" *> skip_ws1 *> (p_expr <|> p_if)) + (skip_ws *> string "then" *> skip_ws1 *> (p_expr <|> p_if)) + (skip_ws *> string "else" *> skip_ws1 *> ((p_expr <|> p_if) >>= fun e -> return (Some e)) <|> return None)) ;; -let parse_expr parse_statement = - choice - [ - parse_function_call parse_statement; - int_expr parse_statement; - parse_parens parse_statement; - bool_expr parse_statement; - string_expr; - ] +let p_let p_expr = + fix (fun p_let -> + skip_ws + *> string "let" + *> skip_ws1 + *> lift4 + (fun rec_flag name args body in_expr -> LetIn(rec_flag, name, args, body, in_expr)) + (string "rec" *> return Rec <|> return Nonrec) + (skip_ws *> p_ident >>= fun ident -> return (Some(ident)) <|> return None) + (skip_ws *> many (skip_ws *> (p_expr <|> p_let)) >>= fun args -> if List.length args > 0 then return (Some(args)) else return None) + (skip_ws *> string "=" *> skip_ws *> (p_expr <|> p_let)) <*> + ((skip_ws *> string "in" *> skip_ws *> (p_expr <|> p_let) >>= fun e -> return (Some e)) <|> return None)) ;; -let parse_if parse_statement = - fix - (fun parse_if -> - lift3 - (fun cond th el -> If_then_else (cond, th, el)) - (skip_ws *> string "if" *> skip_ws1 *> bool_expr parse_statement) - (skip_ws *> string "then" *> parse_statement) - (skip_ws *> string "else" *> (parse_statement >>= fun e -> return (Some e)) <|> return None) - ) -;; - -let parse_let parse_statement = - skip_ws - *> string "let" - *> skip_ws1 - *> lift4 - (fun rec_flag name args body in_expr -> LetIn(rec_flag, name, args, body, in_expr)) - (string "rec" *> return Rec <|> return Nonrec) - (skip_ws *> parse_ident >>= fun ident -> return (Some(ident)) <|> return None) - (skip_ws *> many (skip_ws *> parse_word) >>= fun args -> if List.length args > 0 then return (Some(args)) else return None) - (skip_ws *> string "=" *> skip_ws *> parse_statement) <*> - (skip_ws *> string "in" *> (parse_statement >>= fun e -> return (Some e)) <|> return None) -;; +let p_apply expr = ( + (*Printf.printf "\n\n\n\n here"; *) + chainl1 expr (return (fun e1 e2 -> Function_call(e1, e2)))) let debug p = p >>= fun result -> + Printf.printf "\n\n\n\n"; print_expr 0 result; return result ;; -let parse_statement = - skip_ws *> +let p_expr = + skip_ws *> fix - (fun parse_statement -> - let statement = parse_if parse_statement in - let statement = parse_expr statement <|> statement in - let statement = parse_let statement <|> statement in - statement) + (fun p_expr -> + let atom = choice [p_var; p_int; p_parens p_expr] in + let app = p_apply atom in + let factor = chainl1 app (mul <|> div) in + let term = chainl1 factor (add <|> sub) in + let comp_eq = chainl1 term (equal <|> unequal) in + let comp_less = chainl1 comp_eq (less_or_equal <|> less) in + let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in + let comp_and = chainl1 comp_gr log_and in + let comp_or = chainl1 comp_and log_or in + let if_expr = p_if comp_or <|> comp_or in + let let_expr = p_let if_expr <|> if_expr in + debug let_expr) ;; +(* MAIN PARSE FUNCTION *) let parse (str : string) : expr = - match parse_string ~consume:All (skip_ws *> parse_statement <* skip_ws) str with + match parse_string ~consume:All (skip_ws *> p_expr <* skip_ws) str with | Ok v -> v | Error msg -> ( Printf.printf "%s " msg; diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index c54136097..472d0fcc1 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -104,12 +104,12 @@ let rec print_expr indent expr = List.iter (print_expr (indent + 4)) args; printf "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 4) body - | Function_call (func, args) -> + | Function_call (func, arg) -> printf "%s| Function Call:\n" (String.make indent '-'); printf "%sFUNCTION\n" (String.make (indent + 2) ' '); print_expr (indent + 2) func; printf "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 2)) args + print_expr (indent + 2) arg | LetIn (flag, name, args, body, in_expr) -> printf "%s | Let %s %s =\n" (String.make indent '-') (match flag with @@ -119,8 +119,8 @@ let rec print_expr indent expr = | Some Ident(n) -> n | None -> "Anonymous"); printf "%sARGS\n" (String.make (indent + 2) ' '); - match args with - | None -> printf "NO ARGS"; + match args with + | None -> printf "NO ARGS\n"; | Some args -> ( printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 2)) args; From 362c1487530efaebec0ad3821ac2b72cef8b6f49 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 14 Oct 2024 22:44:55 +0300 Subject: [PATCH 058/310] fix: separated LetIn and Let Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 9 +- FSharpActivePatterns/lib/ast.mli | 8 +- FSharpActivePatterns/lib/parser.ml | 113 ++++++++++++-------- FSharpActivePatterns/lib/printAst.ml | 44 ++++---- FSharpActivePatterns/lib/tests/parser.ml | 68 +++++------- FSharpActivePatterns/lib/tests/print_ast.ml | 60 ++++++++--- 6 files changed, 174 insertions(+), 128 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index c2d8de987..fcf69fb4c 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -2,16 +2,11 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open FSharpActivePatterns.Ast open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser let () = - let input = "let factorial n = - if ((n = 0)||(n = 1)) - then 1 - else n * factorial (n - 1) - in factorial (b)" in + let input = " f (4) (5)" in let result = parse input in - print_construction (Expr result) + print_construction result ;; diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 1d4125ac3..85a1b4e19 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -61,15 +61,15 @@ type expr = | Unary_expr of unary_operator * expr | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) - | Function_def of expr list * expr - (**rec, name, args, body*) + | Function_def of expr list * expr (**rec, name, args, body*) | Function_call of expr * expr (** [sum 1 ] *) | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) - | LetIn of is_recursive * ident option * expr list option * expr * expr option (** [let x = 5 in x * y] *) + | LetIn of is_recursive * ident option * expr list option * expr * expr + (** [let x = 5 in x * y] *) [@@deriving eq, show { with_path = false }] type statement = - | Let of ident * expr (** [let name = expr] *) + | Let of is_recursive * ident * expr list option * expr (** [let name = expr] *) | ActivePattern of ident list * expr (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *) [@@deriving eq, show { with_path = false }] diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 7636d729e..0834610e5 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -14,6 +14,7 @@ let skip_ws = | '\t' -> true | _ -> false) ;; + let skip_ws1 = char ' ' *> skip_ws let chainl1 e op = @@ -29,27 +30,26 @@ let p_int = >>| fun s -> Const (Int_lt (int_of_string s)) ;; -let keywords = ["if"; "then"; "else"; "let"; "in"] +let keywords = [ "if"; "then"; "else"; "let"; "in" ] -let p_ident = +let p_ident = take_while1 (function | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true | _ -> false) - >>= fun str -> - if List.mem str keywords then fail " no keywords pls " - else ( - return (Ident(str))) -;; - -let p_var = - p_ident >>| fun ident -> Variable ident + >>= fun str -> + if List.mem str keywords then fail " no keywords pls " else return (Ident str) ;; +let p_var = p_ident >>| fun ident -> Variable ident + (* EXPR PARSERS *) let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' <* skip_ws - let make_binexpr op expr1 expr2 = Bin_expr (op, expr1, expr2) -let p_binexpr binop constr = skip_ws *> string binop *> skip_ws *> return (make_binexpr constr) + +let p_binexpr binop constr = + skip_ws *> string binop *> skip_ws *> return (make_binexpr constr) +;; + let apply name arg = Function_call (name, arg) let add = p_binexpr "+" Binary_add let sub = p_binexpr "-" Binary_subtract @@ -67,43 +67,64 @@ let log_not = skip_ws *> string "not" *> skip_ws *> return Unary_negative let p_if p_expr = fix (fun p_if -> - lift3 - (fun cond th el -> If_then_else (cond, th, el)) - (skip_ws *> string "if" *> skip_ws1 *> (p_expr <|> p_if)) - (skip_ws *> string "then" *> skip_ws1 *> (p_expr <|> p_if)) - (skip_ws *> string "else" *> skip_ws1 *> ((p_expr <|> p_if) >>= fun e -> return (Some e)) <|> return None)) + lift3 + (fun cond th el -> If_then_else (cond, th, el)) + (skip_ws *> string "if" *> skip_ws1 *> (p_expr <|> p_if)) + (skip_ws *> string "then" *> skip_ws1 *> (p_expr <|> p_if)) + (skip_ws + *> string "else" + *> skip_ws1 + *> (p_expr <|> p_if >>= fun e -> return (Some e)) + <|> return None)) ;; -let p_let p_expr = - fix (fun p_let -> +let p_letin p_expr = + fix (fun p_letin -> skip_ws *> string "let" *> skip_ws1 - *> lift4 - (fun rec_flag name args body in_expr -> LetIn(rec_flag, name, args, body, in_expr)) - (string "rec" *> return Rec <|> return Nonrec) - (skip_ws *> p_ident >>= fun ident -> return (Some(ident)) <|> return None) - (skip_ws *> many (skip_ws *> (p_expr <|> p_let)) >>= fun args -> if List.length args > 0 then return (Some(args)) else return None) - (skip_ws *> string "=" *> skip_ws *> (p_expr <|> p_let)) <*> - ((skip_ws *> string "in" *> skip_ws *> (p_expr <|> p_let) >>= fun e -> return (Some e)) <|> return None)) + *> lift4 + (fun rec_flag name args body in_expr -> + LetIn (rec_flag, name, args, body, in_expr)) + (string "rec" *> return Rec <|> return Nonrec) + (skip_ws *> p_ident >>= fun ident -> return (Some ident) <|> return None) + (many (skip_ws *> p_var) + >>= fun args -> if List.length args > 0 then return (Some args) else return None + ) + (skip_ws *> string "=" *> skip_ws *> (p_expr <|> p_letin)) + <*> skip_ws *> string "in" *> skip_ws *> (p_expr <|> p_letin)) ;; -let p_apply expr = ( +let p_let p_expr = + skip_ws + *> string "let" + *> skip_ws1 + *> lift4 + (fun rec_flag name args body -> Let (rec_flag, name, args, body)) + (string "rec" *> return Rec <|> return Nonrec) + (skip_ws *> p_ident) + (skip_ws *> many (skip_ws *> p_var) + >>= fun args -> if List.length args > 0 then return (Some args) else return None) + (skip_ws *> string "=" *> skip_ws *> p_expr) +;; + +let p_apply expr = (*Printf.printf "\n\n\n\n here"; *) - chainl1 expr (return (fun e1 e2 -> Function_call(e1, e2)))) + chainl1 expr (return (fun f arg -> Function_call (f, arg))) +;; let debug p = - p >>= fun result -> + p + >>= fun result -> Printf.printf "\n\n\n\n"; - print_expr 0 result; + print_construction result; return result ;; -let p_expr = - skip_ws *> - fix - (fun p_expr -> - let atom = choice [p_var; p_int; p_parens p_expr] in +let p_expr = + skip_ws + *> fix (fun p_expr -> + let atom = choice [ p_var; p_int; p_parens p_expr ] in let app = p_apply atom in let factor = chainl1 app (mul <|> div) in let term = chainl1 factor (add <|> sub) in @@ -112,16 +133,22 @@ let p_expr = let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in let comp_and = chainl1 comp_gr log_and in let comp_or = chainl1 comp_and log_or in - let if_expr = p_if comp_or <|> comp_or in - let let_expr = p_let if_expr <|> if_expr in - debug let_expr) + let if_expr = p_if comp_or <|> comp_or in + let letin_expr = p_letin if_expr <|> if_expr in + letin_expr) +;; + +let p_statement = p_let p_expr + +let p_construction = + p_expr >>= (fun e -> return (Expr e)) <|> (p_statement >>= fun s -> return (Statement s)) ;; (* MAIN PARSE FUNCTION *) -let parse (str : string) : expr = - match parse_string ~consume:All (skip_ws *> p_expr <* skip_ws) str with +let parse (str : string) : construction = + match parse_string ~consume:All (skip_ws *> p_construction <* skip_ws) str with | Ok v -> v - | Error msg -> ( - Printf.printf "%s " msg; - failwith msg) + | Error msg -> + print_endline msg; + failwith msg ;; diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 472d0fcc1..5df2df3a5 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -110,35 +110,41 @@ let rec print_expr indent expr = print_expr (indent + 2) func; printf "%sARGS\n" (String.make (indent + 2) ' '); print_expr (indent + 2) arg - | LetIn (flag, name, args, body, in_expr) -> - printf "%s | Let %s %s =\n" (String.make indent '-') - (match flag with + | LetIn (rec_flag, name, args, body, in_expr) -> + printf + "%s | LetIn %s %s =\n" + (String.make indent '-') + (match rec_flag with | Nonrec -> "" | Rec -> "Rec") (match name with - | Some Ident(n) -> n + | Some (Ident n) -> n | None -> "Anonymous"); printf "%sARGS\n" (String.make (indent + 2) ' '); - match args with - | None -> printf "NO ARGS\n"; - | Some args -> ( - printf "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 2)) args; - ); + (match args with + | None -> printf "%s| No args\n" (String.make (indent + 2) '-') + | Some args -> List.iter (print_expr (indent + 2)) args); printf "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 2) body; - match in_expr with - | None -> printf "NO IN EXPR"; - | Some in_expr -> ( - printf "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); - print_expr (indent + 2) in_expr; - ); + printf "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) in_expr ;; let print_statement indent = function - | Let (Ident name, value) -> - printf "%s| Let %s =\n" (String.make indent '-') name; - print_expr (indent + 2) value + | Let (rec_flag, Ident name, args, body) -> + printf + "%s | Let %s %s =\n" + (String.make indent '-') + (match rec_flag with + | Nonrec -> "" + | Rec -> "Rec") + name; + printf "%sARGS\n" (String.make (indent + 2) ' '); + (match args with + | None -> printf "%s| No args\n" (String.make (indent + 2) '-') + | Some args -> List.iter (print_expr (indent + 2)) args); + printf "%sBODY\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) body | ActivePattern (patterns, expr) -> printf "%s| ActivePattern:\n" (String.make indent '-'); List.iter diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index 036ebf4f6..620c7a682 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -1,21 +1,13 @@ -(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) +(* Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) -(** SPDX-License-Identifier: LGPL-3.0-or-later *) +(* SPDX-License-Identifier: LGPL-3.0-or-later *) open FSharpActivePatterns.Parser open FSharpActivePatterns.PrintAst -open FSharpActivePatterns.Ast -open Angstrom -let parse (p : expr t) input = - match parse_string ~consume:All p input with - | Ok v -> Expr v - | Error msg -> failwith msg -;; - -let%expect_test "logical expr parsing" = +let%expect_test "parse logical expression" = let input = {| (3 + 5) >= 8 || true && (5 <> 4) |} in - let result = parse bool_expr input in + let result = parse input in print_construction result; [%expect {| @@ -30,16 +22,16 @@ let%expect_test "logical expr parsing" = ----| Const(Int: 8) --| Binary expr( --| Logical And - ----| Const(Bool: true) + ----| Variable(true) ----| Binary expr( ----| Binary Unequal ------| Const(Int: 5) ------| Const(Int: 4) |}] ;; -let%expect_test "int_expr" = +let%expect_test "parse integer expression" = let input = " (3 + 5) - (12 / 7)" in - let result = parse int_expr input in + let result = parse input in print_construction result; [%expect {| @@ -55,33 +47,31 @@ let%expect_test "int_expr" = ----| Const(Int: 7) |}] ;; -let%expect_test "parse_unary_chain" = +(* + let%expect_test "parse_unary_chain" = let input = "not not ( not true && false || 3 > 5)" in - let result = parse (parse_unary_chain bool_expr log_not) input in + let result = parse input in print_construction result; - [%expect - {| - | Unary expr( - | Unary negative - --| Unary expr( - --| Unary negative - ----| Binary expr( - ----| Logical Or - ------| Binary expr( - ------| Logical And - --------| Unary expr( - --------| Unary negative - ----------| Const(Bool: true) - --------| Const(Bool: false) - ------| Binary expr( - ------| Binary Greater - --------| Const(Int: 3) - --------| Const(Int: 5) |}] -;; + [%expect.unreachable] +[@@expect.uncaught_exn + {| + (* CR expect_test_collector: This test expectation appears to contain a backtrace. + This is strongly discouraged as backtraces are fragile. + Please change this test to not include a backtrace. *) + + (Failure ": end_of_input") + Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 + Called from Tests__Parser.(fun) in file "lib/tests/parser.ml", line 52, characters 15-26 + Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 + + Trailing output + --------------- + : end_of_input |}] +;; *) -let%expect_test "parse_unary_chainl1" = +let%expect_test "parse if with comparison" = let input = "if 3 > 2 && false then 5 + 7 else 12" in - let result = parse parse_if input in + let result = parse input in print_construction result; [%expect {| @@ -93,7 +83,7 @@ let%expect_test "parse_unary_chainl1" = ----| Binary Greater ------| Const(Int: 3) ------| Const(Int: 2) - ----| Const(Bool: false) + ----| Variable(false) THEN BRANCH ----| Binary expr( ----| Binary Add diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index c925adb46..9bc60f797 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -1,6 +1,6 @@ -(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) +(* Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) -(** SPDX-License-Identifier: LGPL-3.0-or-later *) +(* SPDX-License-Identifier: LGPL-3.0-or-later *) open FSharpActivePatterns.Ast open FSharpActivePatterns.PrintAst @@ -8,9 +8,7 @@ open FSharpActivePatterns.PrintAst let%expect_test "print factorial" = let factorial = Function_def - ( Rec - , Some "factorial" - , [ Variable (Ident "n") ] + ( [ Variable (Ident "n") ] , If_then_else ( Bin_expr ( Logical_or @@ -23,21 +21,24 @@ let%expect_test "print factorial" = , Variable (Ident "n") , Function_call ( Variable (Ident "factorial") - , [ Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) - ] ) )) ) ) + , Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) + ) )) ) ) in let program = - [ Statement (Let (Ident "a", Const (Int_lt 10))) + [ Statement (Let (Nonrec, Ident "a", None, Const (Int_lt 10))) ; Expr factorial - ; Expr (Function_call (Variable (Ident "factorial"), [ Variable (Ident "a") ])) + ; Expr (Function_call (factorial, Variable (Ident "a"))) ] in List.iter print_construction program; [%expect {| - | Let a = + | Let a = + ARGS + --| No args + BODY --| Const(Int: 10) - | Rec Function(factorial): + | Func: ARGS ----| Variable(n) BODY @@ -69,22 +70,49 @@ let%expect_test "print factorial" = --------------| Const(Int: 1) | Function Call: FUNCTION - --| Variable(factorial) + --| Func: + ARGS + ------| Variable(n) + BODY + ------| If Then Else( + CONDITION + --------| Binary expr( + --------| Logical Or + ----------| Binary expr( + ----------| Binary Equal + ------------| Variable(n) + ------------| Const(Int: 0) + ----------| Binary expr( + ----------| Binary Equal + ------------| Variable(n) + ------------| Const(Int: 1) + THEN BRANCH + ----------| Const(Int: 1) + ELSE BRANCH + ----------| Binary expr( + ----------| Binary Multiply + ------------| Variable(n) + ------------| Function Call: + FUNCTION + --------------| Variable(factorial) + ARGS + --------------| Binary expr( + --------------| Binary Subtract + ----------------| Variable(n) + ----------------| Const(Int: 1) ARGS --| Variable(a) |}] ;; let%expect_test "print double func" = - let recursive = Nonrec in - let name = Some "double" in let var = Variable (Ident "n") in let args = [ var ] in let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), var) in - let double = Function_def (recursive, name, args, binary_expr) in + let double = Function_def (args, binary_expr) in print_construction @@ Expr double; [%expect {| - | Function(double): + | Func: ARGS ----| Variable(n) BODY From bcefa9da1a9f2cf9ebd05578b85385a9c0a9973f Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 14 Oct 2024 23:30:56 +0300 Subject: [PATCH 059/310] fix: change logic of parse Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/main.ml | 3 +-- FSharpActivePatterns/lib/parser.ml | 12 +++++------- FSharpActivePatterns/lib/printAst.ml | 5 +++++ FSharpActivePatterns/lib/printAst.mli | 2 ++ FSharpActivePatterns/lib/tests/parser.ml | 9 +++------ 5 files changed, 16 insertions(+), 15 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index fcf69fb4c..d4e125605 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -7,6 +7,5 @@ open FSharpActivePatterns.Parser let () = let input = " f (4) (5)" in - let result = parse input in - print_construction result + print_p_res (parse input) ;; diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 0834610e5..80a684ced 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -89,7 +89,7 @@ let p_letin p_expr = (string "rec" *> return Rec <|> return Nonrec) (skip_ws *> p_ident >>= fun ident -> return (Some ident) <|> return None) (many (skip_ws *> p_var) - >>= fun args -> if List.length args > 0 then return (Some args) else return None + >>= fun args -> if not (List.length args == 0) then return (Some args) else return None ) (skip_ws *> string "=" *> skip_ws *> (p_expr <|> p_letin)) <*> skip_ws *> string "in" *> skip_ws *> (p_expr <|> p_letin)) @@ -104,7 +104,7 @@ let p_let p_expr = (string "rec" *> return Rec <|> return Nonrec) (skip_ws *> p_ident) (skip_ws *> many (skip_ws *> p_var) - >>= fun args -> if List.length args > 0 then return (Some args) else return None) + >>= fun args -> if not (List.length args == 0) then return (Some args) else return None) (skip_ws *> string "=" *> skip_ws *> p_expr) ;; @@ -145,10 +145,8 @@ let p_construction = ;; (* MAIN PARSE FUNCTION *) -let parse (str : string) : construction = +let parse (str : string) : construction option = match parse_string ~consume:All (skip_ws *> p_construction <* skip_ws) str with - | Ok v -> v - | Error msg -> - print_endline msg; - failwith msg + | Ok ast -> Some ast + | Error _ -> None ;; diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 5df2df3a5..9b297650e 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -157,3 +157,8 @@ let print_construction = function | Expr e -> print_expr 0 e | Statement s -> print_statement 0 s ;; + +let print_p_res = function + | Some expr -> print_construction expr + | None -> Printf.printf "Error occured"; +;; diff --git a/FSharpActivePatterns/lib/printAst.mli b/FSharpActivePatterns/lib/printAst.mli index 846b45558..62704e0cb 100644 --- a/FSharpActivePatterns/lib/printAst.mli +++ b/FSharpActivePatterns/lib/printAst.mli @@ -5,3 +5,5 @@ open Ast val print_construction : construction -> unit + +val print_p_res : construction option -> unit diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index 620c7a682..23b55dab5 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -7,8 +7,7 @@ open FSharpActivePatterns.PrintAst let%expect_test "parse logical expression" = let input = {| (3 + 5) >= 8 || true && (5 <> 4) |} in - let result = parse input in - print_construction result; + print_p_res (parse input); [%expect {| | Binary expr( @@ -31,8 +30,7 @@ let%expect_test "parse logical expression" = let%expect_test "parse integer expression" = let input = " (3 + 5) - (12 / 7)" in - let result = parse input in - print_construction result; + print_p_res (parse input); [%expect {| | Binary expr( @@ -71,8 +69,7 @@ let%expect_test "parse integer expression" = let%expect_test "parse if with comparison" = let input = "if 3 > 2 && false then 5 + 7 else 12" in - let result = parse input in - print_construction result; + print_p_res (parse input); [%expect {| | If Then Else( From c0c6b3aba8ae48b7a64e99de8a08abe6af826575 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 14 Oct 2024 23:37:17 +0300 Subject: [PATCH 060/310] feat: add mli file for parser and edit headers in tests Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 2 +- FSharpActivePatterns/lib/parser.mli | 7 +++++++ FSharpActivePatterns/lib/tests/parser.ml | 4 ++-- FSharpActivePatterns/lib/tests/print_ast.ml | 4 ++-- 4 files changed, 12 insertions(+), 5 deletions(-) create mode 100644 FSharpActivePatterns/lib/parser.mli diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 85a1b4e19..6bc9fe0da 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -58,7 +58,7 @@ type expr = [ 1, 2, 3 ] ]} *) | Variable of ident (** [x], [y] *) - | Unary_expr of unary_operator * expr + | Unary_expr of unary_operator * expr (** -x *) | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) | Function_def of expr list * expr (**rec, name, args, body*) diff --git a/FSharpActivePatterns/lib/parser.mli b/FSharpActivePatterns/lib/parser.mli new file mode 100644 index 000000000..1e577eb1f --- /dev/null +++ b/FSharpActivePatterns/lib/parser.mli @@ -0,0 +1,7 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast + +val parse : string -> construction option \ No newline at end of file diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index 23b55dab5..c2a9eff47 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -1,6 +1,6 @@ -(* Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) -(* SPDX-License-Identifier: LGPL-3.0-or-later *) +(** SPDX-License-Identifier: LGPL-3.0-or-later *) open FSharpActivePatterns.Parser open FSharpActivePatterns.PrintAst diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index 9bc60f797..952bd9216 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -1,6 +1,6 @@ -(* Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) -(* SPDX-License-Identifier: LGPL-3.0-or-later *) +(** SPDX-License-Identifier: LGPL-3.0-or-later *) open FSharpActivePatterns.Ast open FSharpActivePatterns.PrintAst From e425c4b64769fbad1e1afcbda98855948356893e Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 14 Oct 2024 23:38:47 +0300 Subject: [PATCH 061/310] fix: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 7 ++++--- FSharpActivePatterns/lib/parser.mli | 2 +- FSharpActivePatterns/lib/printAst.ml | 4 ++-- FSharpActivePatterns/lib/printAst.mli | 1 - 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 80a684ced..99a229ceb 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -89,8 +89,8 @@ let p_letin p_expr = (string "rec" *> return Rec <|> return Nonrec) (skip_ws *> p_ident >>= fun ident -> return (Some ident) <|> return None) (many (skip_ws *> p_var) - >>= fun args -> if not (List.length args == 0) then return (Some args) else return None - ) + >>= fun args -> + if not (List.length args == 0) then return (Some args) else return None) (skip_ws *> string "=" *> skip_ws *> (p_expr <|> p_letin)) <*> skip_ws *> string "in" *> skip_ws *> (p_expr <|> p_letin)) ;; @@ -104,7 +104,8 @@ let p_let p_expr = (string "rec" *> return Rec <|> return Nonrec) (skip_ws *> p_ident) (skip_ws *> many (skip_ws *> p_var) - >>= fun args -> if not (List.length args == 0) then return (Some args) else return None) + >>= fun args -> + if not (List.length args == 0) then return (Some args) else return None) (skip_ws *> string "=" *> skip_ws *> p_expr) ;; diff --git a/FSharpActivePatterns/lib/parser.mli b/FSharpActivePatterns/lib/parser.mli index 1e577eb1f..19a074986 100644 --- a/FSharpActivePatterns/lib/parser.mli +++ b/FSharpActivePatterns/lib/parser.mli @@ -4,4 +4,4 @@ open Ast -val parse : string -> construction option \ No newline at end of file +val parse : string -> construction option diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 9b297650e..b8ab3bf8e 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -158,7 +158,7 @@ let print_construction = function | Statement s -> print_statement 0 s ;; -let print_p_res = function +let print_p_res = function | Some expr -> print_construction expr - | None -> Printf.printf "Error occured"; + | None -> Printf.printf "Error occured" ;; diff --git a/FSharpActivePatterns/lib/printAst.mli b/FSharpActivePatterns/lib/printAst.mli index 62704e0cb..43681ddfb 100644 --- a/FSharpActivePatterns/lib/printAst.mli +++ b/FSharpActivePatterns/lib/printAst.mli @@ -5,5 +5,4 @@ open Ast val print_construction : construction -> unit - val print_p_res : construction option -> unit From eab37644ad40742fc46ccea759349ec6cdc239fd Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 14 Oct 2024 23:45:49 +0300 Subject: [PATCH 062/310] tests: add print ast tests for LetIn and Match Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/print_ast.ml | 73 ++++++++++++++++++++- 1 file changed, 70 insertions(+), 3 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index 952bd9216..db2bc398a 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -5,7 +5,7 @@ open FSharpActivePatterns.Ast open FSharpActivePatterns.PrintAst -let%expect_test "print factorial" = +let%expect_test "print Ast factorial" = let factorial = Function_def ( [ Variable (Ident "n") ] @@ -104,7 +104,7 @@ let%expect_test "print factorial" = --| Variable(a) |}] ;; -let%expect_test "print double func" = +let%expect_test "print Ast double func" = let var = Variable (Ident "n") in let args = [ var ] in let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), var) in @@ -122,7 +122,7 @@ let%expect_test "print double func" = ------| Variable(n)|}] ;; -let%expect_test "print tuple of binary operators" = +let%expect_test "print Ast tuple of binary operators" = let first = Const (Int_lt 3) in let second = Const (Int_lt 10) in let operators = @@ -190,3 +190,70 @@ let%expect_test "print tuple of binary operators" = --| Const(Int: 3) --| Const(Int: 10) |}] ;; + +let%expect_test "print Ast of LetIn" = + let sum = + Expr + (LetIn + ( Nonrec + , Some (Ident "x") + , None + , Const (Int_lt 5) + , Bin_expr (Binary_add, Variable (Ident "x"), Const (Int_lt 5)) )) + in + print_construction sum; + [%expect + {| + | LetIn x = + ARGS + --| No args + BODY + --| Const(Int: 5) + INNER EXPRESSION + --| Binary expr( + --| Binary Add + ----| Variable(x) + ----| Const(Int: 5) |}] +;; + +let%expect_test "print Ast of match_expr" = + let patterns = + [ PConst (Int_lt 5) + ; PConst (String_lt " bar foo") + ; Variant [ Ident "Green"; Ident "Blue"; Ident "Red" ] + ; PCons (Wild, PVar (Ident "xs")) + ] + in + let pattern_values = List.map (fun p -> p, Const (Int_lt 4)) patterns in + let match_expr = Match (Variable (Ident "x"), pattern_values) in + print_construction (Expr match_expr); + [%expect + {| + | Match: + --| Variable(x) + --| Pattern: + ----| PConst: + ------Int: 5 + --| Inner expr: + ----| Const(Int: 4) + --| Pattern: + ----| PConst: + ------String: " bar foo" + --| Inner expr: + ----| Const(Int: 4) + --| Pattern: + ----| Variant: + ------- Green + ------- Blue + ------- Red + --| Inner expr: + ----| Const(Int: 4) + --| Pattern: + ----| PCons: + ------Head: + --------| Wild + ------Tail: + --------| PVar(xs) + --| Inner expr: + ----| Const(Int: 4) |}] +;; From 1855d88c97557940c7059dee5bbae84807a06f5b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 14 Oct 2024 23:52:52 +0300 Subject: [PATCH 063/310] ref: remove unused functions and open Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 99a229ceb..abcd493d8 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -4,7 +4,6 @@ open Angstrom open Ast -open PrintAst (* TECHNICAL FUNCTIONS *) let skip_ws = @@ -50,7 +49,6 @@ let p_binexpr binop constr = skip_ws *> string binop *> skip_ws *> return (make_binexpr constr) ;; -let apply name arg = Function_call (name, arg) let add = p_binexpr "+" Binary_add let sub = p_binexpr "-" Binary_subtract let mul = p_binexpr "*" Binary_multiply @@ -63,7 +61,6 @@ let greater = p_binexpr ">" Binary_greater let greater_or_equal = p_binexpr ">=" Binary_greater_or_equal let log_or = p_binexpr "||" Logical_or let log_and = p_binexpr "&&" Logical_and -let log_not = skip_ws *> string "not" *> skip_ws *> return Unary_negative let p_if p_expr = fix (fun p_if -> @@ -114,14 +111,6 @@ let p_apply expr = chainl1 expr (return (fun f arg -> Function_call (f, arg))) ;; -let debug p = - p - >>= fun result -> - Printf.printf "\n\n\n\n"; - print_construction result; - return result -;; - let p_expr = skip_ws *> fix (fun p_expr -> From 183e4decff38856fb638999bc85efe95571c0149 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 15 Oct 2024 00:04:48 +0300 Subject: [PATCH 064/310] feat: add factorial to main.ml Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index d4e125605..be65efcfc 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -6,6 +6,10 @@ open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser let () = - let input = " f (4) (5)" in + let input = "let factorial n = + if ((n = 0)||(n = 1)) + then 1 + else n * factorial (n - 1) + in factorial (b)" in print_p_res (parse input) ;; From 3455a821dd2256a7aaec20f1344de5283feaf2ee Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 15 Oct 2024 00:17:34 +0300 Subject: [PATCH 065/310] tests: remove old test Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/tests/print_ast.t | 42 -------------------------- 1 file changed, 42 deletions(-) delete mode 100644 FSharpActivePatterns/tests/print_ast.t diff --git a/FSharpActivePatterns/tests/print_ast.t b/FSharpActivePatterns/tests/print_ast.t deleted file mode 100644 index 9fe0c8212..000000000 --- a/FSharpActivePatterns/tests/print_ast.t +++ /dev/null @@ -1,42 +0,0 @@ -(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - - $ ../bin/main.exe - | Let a = - --| Const(Int: 10) - | Rec Function(factorial): - ARGS - ----| Variable(n) - BODY - ----| If Then Else( - CONDITION - ------| Binary expr( - ------| Logical Or - --------| Binary expr( - --------| Binary Equal - ----------| Variable(n) - ----------| Const(Int: 0) - --------| Binary expr( - --------| Binary Equal - ----------| Variable(n) - ----------| Const(Int: 1) - THEN BRANCH - --------| Const(Int: 1) - ELSE BRANCH - --------| Binary expr( - --------| Binary Multiply - ----------| Variable(n) - ----------| Function Call: - FUNCTION - ------------| Variable(factorial) - ARGS - ------------| Binary expr( - ------------| Binary Subtract - --------------| Variable(n) - --------------| Const(Int: 1) - | Function Call: - FUNCTION - --| Variable(factorial) - ARGS - --| Variable(a) From 54a24f15fde9b7ee56009a19aef950c57b05a20b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 15 Oct 2024 00:18:02 +0300 Subject: [PATCH 066/310] ref: fix formatting Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 12 +++++++----- FSharpActivePatterns/lib/tests/print_ast.ml | 2 +- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index be65efcfc..7a6f823f4 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -6,10 +6,12 @@ open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser let () = - let input = "let factorial n = - if ((n = 0)||(n = 1)) - then 1 - else n * factorial (n - 1) - in factorial (b)" in + let input = + "let factorial n =\n\ + \ if ((n = 0)||(n = 1))\n\ + \ then 1\n\ + \ else n * factorial (n - 1)\n\ + \ in factorial (b)" + in print_p_res (parse input) ;; diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index f2307491b..db2bc398a 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -256,4 +256,4 @@ let%expect_test "print Ast of match_expr" = --------| PVar(xs) --| Inner expr: ----| Const(Int: 4) |}] -;; \ No newline at end of file +;; From e867705b89fdeff5f6b682ef29444bfb672774c0 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 15 Oct 2024 18:42:57 +0300 Subject: [PATCH 067/310] feat: add possibility of digits in variable name Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/dune | 2 +- FSharpActivePatterns/lib/parser.ml | 23 +++++++++++++---------- 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/FSharpActivePatterns/lib/dune b/FSharpActivePatterns/lib/dune index 4a4c515ae..44620ab63 100644 --- a/FSharpActivePatterns/lib/dune +++ b/FSharpActivePatterns/lib/dune @@ -3,7 +3,7 @@ (public_name FSharpActivePatterns) (modules Ast PrintAst Parser) (modules_without_implementation ast) - (libraries angstrom) + (libraries angstrom base) (preprocess (pps ppx_deriving.show ppx_deriving.eq)) (instrumentation diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index abcd493d8..1746c5356 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -4,6 +4,7 @@ open Angstrom open Ast +open Base (* TECHNICAL FUNCTIONS *) let skip_ws = @@ -22,28 +23,30 @@ let chainl1 e op = ;; (* SIMPLE PARSERS *) -let p_int = - take_while1 (function - | '0' .. '9' -> true - | _ -> false) - >>| fun s -> Const (Int_lt (int_of_string s)) -;; +let p_int = take_while1 Char.is_digit >>| fun s -> Const (Int_lt (int_of_string s)) -let keywords = [ "if"; "then"; "else"; "let"; "in" ] +let is_keyword = function + | "if" | "then" | "else" | "let" | "in" -> true + | _ -> false +;; let p_ident = take_while1 (function - | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> true | _ -> false) >>= fun str -> - if List.mem str keywords then fail " no keywords pls " else return (Ident str) + if is_keyword str + then fail "keyword in variable name" + else if Char.is_digit (String.get str 0) + then fail "variable name cannot start with a digit" + else return (Ident str) ;; let p_var = p_ident >>| fun ident -> Variable ident (* EXPR PARSERS *) let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' <* skip_ws -let make_binexpr op expr1 expr2 = Bin_expr (op, expr1, expr2) +let make_binexpr op expr1 expr2 = Bin_expr (op, expr1, expr2) [@@inline always] let p_binexpr binop constr = skip_ws *> string binop *> skip_ws *> return (make_binexpr constr) From c7b2fb6c1ca1f6e2a1f92a124f485917e2686e8e Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 15 Oct 2024 20:50:20 +0300 Subject: [PATCH 068/310] fix: add whitespaces skip in integer and variable parsers Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 10 +++++----- FSharpActivePatterns/lib/parser.ml | 11 +++++++---- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 7a6f823f4..69eb828c3 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -7,11 +7,11 @@ open FSharpActivePatterns.Parser let () = let input = - "let factorial n =\n\ - \ if ((n = 0)||(n = 1))\n\ - \ then 1\n\ - \ else n * factorial (n - 1)\n\ - \ in factorial (b)" + {|let rec factorial n = + if n = 0 || n = 1 + then 1 + else n * factorial (n-1) + in factorial b |} in print_p_res (parse input) ;; diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 1746c5356..d55143afe 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -23,7 +23,9 @@ let chainl1 e op = ;; (* SIMPLE PARSERS *) -let p_int = take_while1 Char.is_digit >>| fun s -> Const (Int_lt (int_of_string s)) +let p_int = + skip_ws *> take_while1 Char.is_digit >>| fun s -> Const (Int_lt (int_of_string s)) +;; let is_keyword = function | "if" | "then" | "else" | "let" | "in" -> true @@ -31,7 +33,8 @@ let is_keyword = function ;; let p_ident = - take_while1 (function + skip_ws + *> take_while1 (function | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> true | _ -> false) >>= fun str -> @@ -87,7 +90,7 @@ let p_letin p_expr = (fun rec_flag name args body in_expr -> LetIn (rec_flag, name, args, body, in_expr)) (string "rec" *> return Rec <|> return Nonrec) - (skip_ws *> p_ident >>= fun ident -> return (Some ident) <|> return None) + (p_ident >>= fun ident -> return (Some ident) <|> return None) (many (skip_ws *> p_var) >>= fun args -> if not (List.length args == 0) then return (Some args) else return None) @@ -102,7 +105,7 @@ let p_let p_expr = *> lift4 (fun rec_flag name args body -> Let (rec_flag, name, args, body)) (string "rec" *> return Rec <|> return Nonrec) - (skip_ws *> p_ident) + p_ident (skip_ws *> many (skip_ws *> p_var) >>= fun args -> if not (List.length args == 0) then return (Some args) else return None) From 89de711db84706e25a5d8dfe0924296c3346713c Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Wed, 16 Oct 2024 04:28:36 +0300 Subject: [PATCH 069/310] feat: add parsing of unary operators Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.mli | 2 +- FSharpActivePatterns/lib/parser.ml | 38 ++++++++++++++-- FSharpActivePatterns/lib/printAst.ml | 2 +- FSharpActivePatterns/lib/tests/parser.ml | 58 +++++++++++++----------- 4 files changed, 66 insertions(+), 34 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 6bc9fe0da..2388c5244 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -33,7 +33,7 @@ type binary_operator = type unary_operator = | Unary_minus (** unary [-] *) - | Unary_negative (** unary [not] *) + | Unary_not (** unary [not] *) [@@deriving eq, show { with_path = false }] type pattern = diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index d55143afe..fe2d46a41 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -22,13 +22,33 @@ let chainl1 e op = e >>= go ;; +let rec unary_chain op e = + op >>= (fun unexpr -> unary_chain op e >>= fun expr -> return (unexpr expr)) <|> e +;; + (* SIMPLE PARSERS *) let p_int = skip_ws *> take_while1 Char.is_digit >>| fun s -> Const (Int_lt (int_of_string s)) ;; +let p_bool = + skip_ws *> string "true" + <|> string "false" + >>| fun s -> Const (Bool_lt (bool_of_string s)) +;; + let is_keyword = function - | "if" | "then" | "else" | "let" | "in" -> true + | "if" + | "then" + | "else" + | "let" + | "in" + | "not" + | "true" + | "false" + | "fun" + | "match" + | "with" -> true | _ -> false ;; @@ -50,11 +70,18 @@ let p_var = p_ident >>| fun ident -> Variable ident (* EXPR PARSERS *) let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' <* skip_ws let make_binexpr op expr1 expr2 = Bin_expr (op, expr1, expr2) [@@inline always] +let make_unexpr op expr = Unary_expr (op, expr) [@@inline always] + +let p_binexpr binop_str binop = + skip_ws *> string binop_str *> skip_ws *> return (make_binexpr binop) +;; -let p_binexpr binop constr = - skip_ws *> string binop *> skip_ws *> return (make_binexpr constr) +let p_unexpr unop_str unop = + skip_ws *> string unop_str *> skip_ws *> return (make_unexpr unop) ;; +let p_not = p_unexpr "not" Unary_not +let unminus = p_unexpr "-" Unary_minus let add = p_binexpr "+" Binary_add let sub = p_binexpr "-" Binary_subtract let mul = p_binexpr "*" Binary_multiply @@ -120,8 +147,9 @@ let p_apply expr = let p_expr = skip_ws *> fix (fun p_expr -> - let atom = choice [ p_var; p_int; p_parens p_expr ] in - let app = p_apply atom in + let atom = choice [ p_var; p_int; p_bool; p_parens p_expr ] in + let unary = choice [ unary_chain p_not atom; unary_chain unminus atom ] in + let app = p_apply unary in let factor = chainl1 app (mul <|> div) in let term = chainl1 factor (add <|> sub) in let comp_eq = chainl1 term (equal <|> unequal) in diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index b8ab3bf8e..c8f26ba87 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -53,7 +53,7 @@ let rec print_pattern indent = function let print_unary_op indent = function | Unary_minus -> printf "%s| Unary minus\n" (String.make indent '-') - | Unary_negative -> printf "%s| Unary negative\n" (String.make indent '-') + | Unary_not -> printf "%s| Unary negative\n" (String.make indent '-') ;; let rec print_expr indent expr = diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index c2a9eff47..f3f2dfca0 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -21,7 +21,7 @@ let%expect_test "parse logical expression" = ----| Const(Int: 8) --| Binary expr( --| Logical And - ----| Variable(true) + ----| Const(Bool: true) ----| Binary expr( ----| Binary Unequal ------| Const(Int: 5) @@ -33,39 +33,43 @@ let%expect_test "parse integer expression" = print_p_res (parse input); [%expect {| - | Binary expr( - | Binary Subtract + | Function Call: + FUNCTION --| Binary expr( --| Binary Add ----| Const(Int: 3) ----| Const(Int: 5) - --| Binary expr( - --| Binary Divide - ----| Const(Int: 12) - ----| Const(Int: 7) |}] + ARGS + --| Unary expr( + --| Unary minus + ----| Binary expr( + ----| Binary Divide + ------| Const(Int: 12) + ------| Const(Int: 7) |}] ;; -(* - let%expect_test "parse_unary_chain" = +let%expect_test "parse_unary_chain" = let input = "not not ( not true && false || 3 > 5)" in let result = parse input in - print_construction result; - [%expect.unreachable] -[@@expect.uncaught_exn - {| - (* CR expect_test_collector: This test expectation appears to contain a backtrace. - This is strongly discouraged as backtraces are fragile. - Please change this test to not include a backtrace. *) - - (Failure ": end_of_input") - Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 - Called from Tests__Parser.(fun) in file "lib/tests/parser.ml", line 52, characters 15-26 - Called from Expect_test_collector.Make.Instance_io.exec in file "collector/expect_test_collector.ml", line 234, characters 12-19 - - Trailing output - --------------- - : end_of_input |}] -;; *) + print_p_res result; + [%expect{| + | Unary expr( + | Unary negative + --| Unary expr( + --| Unary negative + ----| Binary expr( + ----| Logical Or + ------| Binary expr( + ------| Logical And + --------| Unary expr( + --------| Unary negative + ----------| Const(Bool: true) + --------| Const(Bool: false) + ------| Binary expr( + ------| Binary Greater + --------| Const(Int: 3) + --------| Const(Int: 5) |}] +;; let%expect_test "parse if with comparison" = let input = "if 3 > 2 && false then 5 + 7 else 12" in @@ -80,7 +84,7 @@ let%expect_test "parse if with comparison" = ----| Binary Greater ------| Const(Int: 3) ------| Const(Int: 2) - ----| Variable(false) + ----| Const(Bool: false) THEN BRANCH ----| Binary expr( ----| Binary Add From c91ec5ea2403d2f059c829c884a12b62a488fb3a Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Wed, 16 Oct 2024 19:59:18 +0300 Subject: [PATCH 070/310] ref: formatting Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 8 +------- FSharpActivePatterns/lib/tests/parser.ml | 3 ++- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index 69eb828c3..ad2d95e4c 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -6,12 +6,6 @@ open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser let () = - let input = - {|let rec factorial n = - if n = 0 || n = 1 - then 1 - else n * factorial (n-1) - in factorial b |} - in + let input = " if (if true then true else false) then 2 else 4 " in print_p_res (parse input) ;; diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index f3f2dfca0..408beaced 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -52,7 +52,8 @@ let%expect_test "parse_unary_chain" = let input = "not not ( not true && false || 3 > 5)" in let result = parse input in print_p_res result; - [%expect{| + [%expect + {| | Unary expr( | Unary negative --| Unary expr( From ee2f80cd62cd9f2881e2a42477b007600f8f9d5e Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Wed, 16 Oct 2024 20:02:27 +0300 Subject: [PATCH 071/310] fix: change deprecated functions Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index fe2d46a41..0ac09088d 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -28,13 +28,13 @@ let rec unary_chain op e = (* SIMPLE PARSERS *) let p_int = - skip_ws *> take_while1 Char.is_digit >>| fun s -> Const (Int_lt (int_of_string s)) + skip_ws *> take_while1 Char.is_digit >>| fun s -> Const (Int_lt (Int.of_string s)) ;; let p_bool = skip_ws *> string "true" <|> string "false" - >>| fun s -> Const (Bool_lt (bool_of_string s)) + >>| fun s -> Const (Bool_lt (Bool.of_string s)) ;; let is_keyword = function @@ -120,7 +120,7 @@ let p_letin p_expr = (p_ident >>= fun ident -> return (Some ident) <|> return None) (many (skip_ws *> p_var) >>= fun args -> - if not (List.length args == 0) then return (Some args) else return None) + if not (List.length args = 0) then return (Some args) else return None) (skip_ws *> string "=" *> skip_ws *> (p_expr <|> p_letin)) <*> skip_ws *> string "in" *> skip_ws *> (p_expr <|> p_letin)) ;; @@ -135,7 +135,7 @@ let p_let p_expr = p_ident (skip_ws *> many (skip_ws *> p_var) >>= fun args -> - if not (List.length args == 0) then return (Some args) else return None) + if not (List.length args = 0) then return (Some args) else return None) (skip_ws *> string "=" *> skip_ws *> p_expr) ;; From e4ec029614e11e0df58148b630417857fc2b3de0 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 18 Oct 2024 03:33:38 +0300 Subject: [PATCH 072/310] fix: add possibility of sum with ite and LetIn Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 2 +- FSharpActivePatterns/lib/parser.ml | 8 ++-- FSharpActivePatterns/lib/tests/parser.ml | 60 ++++++++++++++++++++++++ 3 files changed, 65 insertions(+), 5 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index ad2d95e4c..e5d5b2824 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -6,6 +6,6 @@ open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser let () = - let input = " if (if true then true else false) then 2 else 4 " in + let input = " if (if not true || false then true else false) then 2 else 4 " in print_p_res (parse input) ;; diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 0ac09088d..21d8e3243 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -148,7 +148,9 @@ let p_expr = skip_ws *> fix (fun p_expr -> let atom = choice [ p_var; p_int; p_bool; p_parens p_expr ] in - let unary = choice [ unary_chain p_not atom; unary_chain unminus atom ] in + let if_expr = p_if (p_expr <|> atom) <|> atom in + let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in + let unary = choice [ unary_chain p_not letin_expr; unary_chain unminus letin_expr ] in let app = p_apply unary in let factor = chainl1 app (mul <|> div) in let term = chainl1 factor (add <|> sub) in @@ -157,9 +159,7 @@ let p_expr = let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in let comp_and = chainl1 comp_gr log_and in let comp_or = chainl1 comp_and log_or in - let if_expr = p_if comp_or <|> comp_or in - let letin_expr = p_letin if_expr <|> if_expr in - letin_expr) + comp_or) ;; let p_statement = p_let p_expr diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index 408beaced..b7151be61 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -94,3 +94,63 @@ let%expect_test "parse if with comparison" = ELSE BRANCH ----| Const(Int: 12) |}] ;; + +let%expect_test "sum with if" = + let input = "a + if 3 > 2 then 2 else 1" in + print_p_res (parse input); + [%expect + {| + | Binary expr( + | Binary Add + --| Variable(a) + --| If Then Else( + CONDITION + ----| Binary expr( + ----| Binary Greater + ------| Const(Int: 3) + ------| Const(Int: 2) + THEN BRANCH + ------| Const(Int: 2) + ELSE BRANCH + ------| Const(Int: 1) |}] +;; + +let%expect_test "inner expressions with LetIn and If" = + let input = + "if let x = true in let y = false in x || y then 3 else if 5 > 3 then 2 else 1" + in + print_p_res (parse input); + [%expect + {| + | If Then Else( + CONDITION + -- | LetIn x = + ARGS + ----| No args + BODY + ----| Const(Bool: true) + INNER EXPRESSION + ---- | LetIn y = + ARGS + ------| No args + BODY + ------| Const(Bool: false) + INNER EXPRESSION + ------| Binary expr( + ------| Logical Or + --------| Variable(x) + --------| Variable(y) + THEN BRANCH + ----| Const(Int: 3) + ELSE BRANCH + ----| If Then Else( + CONDITION + ------| Binary expr( + ------| Binary Greater + --------| Const(Int: 5) + --------| Const(Int: 3) + THEN BRANCH + --------| Const(Int: 2) + ELSE BRANCH + --------| Const(Int: 1) |}] +;; From cc6c42fdb066855ad124ebe739268d7fa2af6269 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 18 Oct 2024 03:44:48 +0300 Subject: [PATCH 073/310] docs: fix Ast constructor docs Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.mli | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 2388c5244..be127ca7c 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -55,17 +55,17 @@ type expr = | Tuple of expr list (** [(1, "Hello world", true)] *) | List_expr of expr * expr (** {[ - [ 1, 2, 3 ] + [ 1; 2; 3 ] ]} *) | Variable of ident (** [x], [y] *) | Unary_expr of unary_operator * expr (** -x *) | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) - | Function_def of expr list * expr (**rec, name, args, body*) + | Function_def of expr list * expr (** fun x y -> x + y *) | Function_call of expr * expr (** [sum 1 ] *) | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) | LetIn of is_recursive * ident option * expr list option * expr * expr - (** [let x = 5 in x * y] *) + (** [let f x y = x + y in f 3 4] *) [@@deriving eq, show { with_path = false }] type statement = From b04f53aa639404dea93446d4526547a68c0b9d89 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 19 Oct 2024 15:03:58 +0300 Subject: [PATCH 074/310] fix: change function for identifiers parsing Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 21d8e3243..ed79dec4b 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -53,17 +53,21 @@ let is_keyword = function ;; let p_ident = - skip_ws - *> take_while1 (function + let find_string = + skip_ws *> + lift2 (fun s1 s2 -> s1 ^ s2) + (take_while1 (function + | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true + | _ -> false)) + (take_while (function | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> true - | _ -> false) - >>= fun str -> - if is_keyword str - then fail "keyword in variable name" - else if Char.is_digit (String.get str 0) - then fail "variable name cannot start with a digit" - else return (Ident str) -;; + | _ -> false)) + in + find_string >>= fun str -> + if is_keyword str then fail "keywords are not allowed as variable names" + else if String.equal str "_" then fail "wildcard is not allowed as a variable name" + else return (Ident str) +;; let p_var = p_ident >>| fun ident -> Variable ident @@ -132,7 +136,7 @@ let p_let p_expr = *> lift4 (fun rec_flag name args body -> Let (rec_flag, name, args, body)) (string "rec" *> return Rec <|> return Nonrec) - p_ident + (p_ident >>= fun ident -> return ident) (skip_ws *> many (skip_ws *> p_var) >>= fun args -> if not (List.length args = 0) then return (Some args) else return None) From 2bd0d1bcf910d54bb8bf42858b5eefe141f7b6d7 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 19 Oct 2024 15:16:16 +0300 Subject: [PATCH 075/310] fix: replace unary operators after binary for correct work Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index ed79dec4b..272e5f7d6 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -154,8 +154,7 @@ let p_expr = let atom = choice [ p_var; p_int; p_bool; p_parens p_expr ] in let if_expr = p_if (p_expr <|> atom) <|> atom in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in - let unary = choice [ unary_chain p_not letin_expr; unary_chain unminus letin_expr ] in - let app = p_apply unary in + let app = p_apply letin_expr in let factor = chainl1 app (mul <|> div) in let term = chainl1 factor (add <|> sub) in let comp_eq = chainl1 term (equal <|> unequal) in @@ -163,7 +162,8 @@ let p_expr = let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in let comp_and = chainl1 comp_gr log_and in let comp_or = chainl1 comp_and log_or in - comp_or) + let unary = choice [ unary_chain p_not comp_or; unary_chain unminus comp_or ] in + unary) ;; let p_statement = p_let p_expr From bb987f8861ca888dcc72b44f9e7095406336b3b7 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 19 Oct 2024 15:37:05 +0300 Subject: [PATCH 076/310] fix: delete self-application of if and let Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 272e5f7d6..0305c4296 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -100,20 +100,18 @@ let log_or = p_binexpr "||" Logical_or let log_and = p_binexpr "&&" Logical_and let p_if p_expr = - fix (fun p_if -> - lift3 - (fun cond th el -> If_then_else (cond, th, el)) - (skip_ws *> string "if" *> skip_ws1 *> (p_expr <|> p_if)) - (skip_ws *> string "then" *> skip_ws1 *> (p_expr <|> p_if)) - (skip_ws + lift3 + (fun cond th el -> If_then_else (cond, th, el)) + (skip_ws *> string "if" *> skip_ws1 *> (p_expr)) + (skip_ws *> string "then" *> skip_ws1 *> (p_expr)) + (skip_ws *> string "else" *> skip_ws1 - *> (p_expr <|> p_if >>= fun e -> return (Some e)) - <|> return None)) + *> (p_expr >>= fun e -> return (Some e)) + <|> return None) ;; let p_letin p_expr = - fix (fun p_letin -> skip_ws *> string "let" *> skip_ws1 @@ -125,8 +123,8 @@ let p_letin p_expr = (many (skip_ws *> p_var) >>= fun args -> if not (List.length args = 0) then return (Some args) else return None) - (skip_ws *> string "=" *> skip_ws *> (p_expr <|> p_letin)) - <*> skip_ws *> string "in" *> skip_ws *> (p_expr <|> p_letin)) + (skip_ws *> string "=" *> skip_ws *> p_expr) + <*> skip_ws *> string "in" *> skip_ws *> p_expr ;; let p_let p_expr = From b478f3a085b6bf09af4c7d0096caec1229f49746 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 19 Oct 2024 21:32:35 +0300 Subject: [PATCH 077/310] fix: change logic of p_apply so first function name will always be correct Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 0305c4296..a2f72b229 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -5,6 +5,14 @@ open Angstrom open Ast open Base +(*open PrintAst*) + +(* +let debug p = + p >>= fun result -> + print_expr 0 result; + return result +;;*) (* TECHNICAL FUNCTIONS *) let skip_ws = @@ -141,10 +149,28 @@ let p_let p_expr = (skip_ws *> string "=" *> skip_ws *> p_expr) ;; + +let app_first expr = + skip_ws *> + fix (fun a_exp -> + let expr = choice [p_var; p_if expr; p_parens a_exp] in + expr + ) +;; + +let p_apply expr = + let* name = app_first expr in + let rec parse_args acc = + (skip_ws *> expr >>= fun arg -> + parse_args (Function_call (acc, arg))) <|> return acc + in + parse_args name +;; +(* let p_apply expr = (*Printf.printf "\n\n\n\n here"; *) chainl1 expr (return (fun f arg -> Function_call (f, arg))) -;; +;; *) let p_expr = skip_ws @@ -152,7 +178,7 @@ let p_expr = let atom = choice [ p_var; p_int; p_bool; p_parens p_expr ] in let if_expr = p_if (p_expr <|> atom) <|> atom in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in - let app = p_apply letin_expr in + let app = p_apply letin_expr <|> letin_expr in let factor = chainl1 app (mul <|> div) in let term = chainl1 factor (add <|> sub) in let comp_eq = chainl1 term (equal <|> unequal) in From f69ec9b1360f765e1ceb8f57433375a513be121a Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 20 Oct 2024 04:02:21 +0300 Subject: [PATCH 078/310] fix: order of unary expressions and applying complex expressions Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/main.ml | 2 +- FSharpActivePatterns/lib/parser.ml | 112 ++++++++---------- FSharpActivePatterns/lib/tests/parser.ml | 144 +++++++++++++++++++++-- 3 files changed, 185 insertions(+), 73 deletions(-) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml index e5d5b2824..c7634ce75 100644 --- a/FSharpActivePatterns/bin/main.ml +++ b/FSharpActivePatterns/bin/main.ml @@ -6,6 +6,6 @@ open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser let () = - let input = " if (if not true || false then true else false) then 2 else 4 " in + let input = " f 3 + if true then 12 else h 5 " in print_p_res (parse input) ;; diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index a2f72b229..701be7635 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -5,14 +5,6 @@ open Angstrom open Ast open Base -(*open PrintAst*) - -(* -let debug p = - p >>= fun result -> - print_expr 0 result; - return result -;;*) (* TECHNICAL FUNCTIONS *) let skip_ws = @@ -56,26 +48,29 @@ let is_keyword = function | "false" | "fun" | "match" - | "with" -> true + | "with" + | "_" -> true | _ -> false ;; let p_ident = - let find_string = - skip_ws *> - lift2 (fun s1 s2 -> s1 ^ s2) - (take_while1 (function - | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true - | _ -> false)) - (take_while (function - | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> true - | _ -> false)) - in - find_string >>= fun str -> - if is_keyword str then fail "keywords are not allowed as variable names" - else if String.equal str "_" then fail "wildcard is not allowed as a variable name" - else return (Ident str) -;; + let find_string = + skip_ws + *> lift2 + (fun s1 s2 -> s1 ^ s2) + (take_while1 (function + | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true + | _ -> false)) + (take_while (function + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> true + | _ -> false)) + in + find_string + >>= fun str -> + if is_keyword str + then fail "keywords are not allowed as variable names" + else return (Ident str) +;; let p_var = p_ident >>| fun ident -> Variable ident @@ -110,29 +105,26 @@ let log_and = p_binexpr "&&" Logical_and let p_if p_expr = lift3 (fun cond th el -> If_then_else (cond, th, el)) - (skip_ws *> string "if" *> skip_ws1 *> (p_expr)) - (skip_ws *> string "then" *> skip_ws1 *> (p_expr)) - (skip_ws - *> string "else" - *> skip_ws1 - *> (p_expr >>= fun e -> return (Some e)) - <|> return None) + (skip_ws *> string "if" *> skip_ws1 *> p_expr) + (skip_ws *> string "then" *> skip_ws1 *> p_expr) + (skip_ws *> string "else" *> skip_ws1 *> (p_expr >>= fun e -> return (Some e)) + <|> return None) ;; let p_letin p_expr = - skip_ws - *> string "let" - *> skip_ws1 - *> lift4 - (fun rec_flag name args body in_expr -> - LetIn (rec_flag, name, args, body, in_expr)) - (string "rec" *> return Rec <|> return Nonrec) - (p_ident >>= fun ident -> return (Some ident) <|> return None) - (many (skip_ws *> p_var) - >>= fun args -> - if not (List.length args = 0) then return (Some args) else return None) - (skip_ws *> string "=" *> skip_ws *> p_expr) - <*> skip_ws *> string "in" *> skip_ws *> p_expr + skip_ws + *> string "let" + *> skip_ws1 + *> lift4 + (fun rec_flag name args body in_expr -> + LetIn (rec_flag, name, args, body, in_expr)) + (string "rec" *> return Rec <|> return Nonrec) + (p_ident >>= fun ident -> return (Some ident) <|> return None) + (many (skip_ws *> p_var) + >>= fun args -> + if not (List.length args = 0) then return (Some args) else return None) + (skip_ws *> string "=" *> skip_ws *> p_expr) + <*> skip_ws *> string "in" *> skip_ws *> p_expr ;; let p_let p_expr = @@ -149,28 +141,22 @@ let p_let p_expr = (skip_ws *> string "=" *> skip_ws *> p_expr) ;; - -let app_first expr = - skip_ws *> - fix (fun a_exp -> - let expr = choice [p_var; p_if expr; p_parens a_exp] in - expr - ) +let app_first expr = + skip_ws + *> fix (fun a_exp -> + let expr = choice [ p_var; p_if expr; p_letin expr; p_parens a_exp ] in + expr) ;; let p_apply expr = let* name = app_first expr in let rec parse_args acc = - (skip_ws *> expr >>= fun arg -> - parse_args (Function_call (acc, arg))) <|> return acc + skip_ws *> choice [ p_var; p_bool; p_int; p_if expr; p_letin expr; p_parens expr ] + >>= (fun arg -> parse_args (Function_call (acc, arg))) + <|> return acc in parse_args name -;; -(* -let p_apply expr = - (*Printf.printf "\n\n\n\n here"; *) - chainl1 expr (return (fun f arg -> Function_call (f, arg))) -;; *) +;; let p_expr = skip_ws @@ -178,16 +164,16 @@ let p_expr = let atom = choice [ p_var; p_int; p_bool; p_parens p_expr ] in let if_expr = p_if (p_expr <|> atom) <|> atom in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in - let app = p_apply letin_expr <|> letin_expr in - let factor = chainl1 app (mul <|> div) in + let apply = p_apply (p_expr <|> letin_expr) <|> letin_expr in + let unary = choice [ unary_chain p_not apply; unary_chain unminus apply ] in + let factor = chainl1 unary (mul <|> div) in let term = chainl1 factor (add <|> sub) in let comp_eq = chainl1 term (equal <|> unequal) in let comp_less = chainl1 comp_eq (less_or_equal <|> less) in let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in let comp_and = chainl1 comp_gr log_and in let comp_or = chainl1 comp_and log_or in - let unary = choice [ unary_chain p_not comp_or; unary_chain unminus comp_or ] in - unary) + comp_or) ;; let p_statement = p_let p_expr diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index b7151be61..35d34971d 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -5,6 +5,101 @@ open FSharpActivePatterns.Parser open FSharpActivePatterns.PrintAst +let%expect_test "binary subtract" = + let input = {| a - 3|} in + print_p_res (parse input); + [%expect + {| + | Binary expr( + | Binary Subtract + --| Variable(a) + --| Const(Int: 3) |}] +;; + +let%expect_test "function apply of letIn" = + let input = {| f let x = false in true || x|} in + print_p_res (parse input); + [%expect + {| + | Function Call: + FUNCTION + --| Variable(f) + ARGS + -- | LetIn x = + ARGS + ----| No args + BODY + ----| Const(Bool: false) + INNER EXPRESSION + ----| Binary expr( + ----| Logical Or + ------| Const(Bool: true) + ------| Variable(x) |}] +;; + +let%expect_test "arithmetic with unary operations and variables" = + let input = {| - a - - b + 4|} in + print_p_res (parse input); + [%expect + {| + | Binary expr( + | Binary Add + --| Binary expr( + --| Binary Subtract + ----| Unary expr( + ----| Unary minus + ------| Variable(a) + ----| Unary expr( + ----| Unary minus + ------| Variable(b) + --| Const(Int: 4) |}] +;; + +let%expect_test "sum of function applying" = + let input = {| f 4 + g 3|} in + print_p_res (parse input); + [%expect + {| + | Binary expr( + | Binary Add + --| Function Call: + FUNCTION + ----| Variable(f) + ARGS + ----| Const(Int: 4) + --| Function Call: + FUNCTION + ----| Variable(g) + ARGS + ----| Const(Int: 3) |}] +;; + +let%expect_test "order of logical expressions and function applying" = + let input = {| let x = true in not x || true && f 12|} in + print_p_res (parse input); + [%expect + {| + | LetIn x = + ARGS + --| No args + BODY + --| Const(Bool: true) + INNER EXPRESSION + --| Binary expr( + --| Logical Or + ----| Unary expr( + ----| Unary negative + ------| Variable(x) + ----| Binary expr( + ----| Logical And + ------| Const(Bool: true) + ------| Function Call: + FUNCTION + --------| Variable(f) + ARGS + --------| Const(Int: 12) |}] +;; + let%expect_test "parse logical expression" = let input = {| (3 + 5) >= 8 || true && (5 <> 4) |} in print_p_res (parse input); @@ -33,19 +128,16 @@ let%expect_test "parse integer expression" = print_p_res (parse input); [%expect {| - | Function Call: - FUNCTION + | Binary expr( + | Binary Subtract --| Binary expr( --| Binary Add ----| Const(Int: 3) ----| Const(Int: 5) - ARGS - --| Unary expr( - --| Unary minus - ----| Binary expr( - ----| Binary Divide - ------| Const(Int: 12) - ------| Const(Int: 7) |}] + --| Binary expr( + --| Binary Divide + ----| Const(Int: 12) + ----| Const(Int: 7) |}] ;; let%expect_test "parse_unary_chain" = @@ -154,3 +246,37 @@ let%expect_test "inner expressions with LetIn and If" = ELSE BRANCH --------| Const(Int: 1) |}] ;; + +let%expect_test "factorial" = + let input = "let factorial n = if n = 0 then 1 else factorial (n - 1) in factorial b" in + print_p_res (parse input); + [%expect + {| + | LetIn factorial = + ARGS + --| Variable(n) + BODY + --| If Then Else( + CONDITION + ----| Binary expr( + ----| Binary Equal + ------| Variable(n) + ------| Const(Int: 0) + THEN BRANCH + ------| Const(Int: 1) + ELSE BRANCH + ------| Function Call: + FUNCTION + --------| Variable(factorial) + ARGS + --------| Binary expr( + --------| Binary Subtract + ----------| Variable(n) + ----------| Const(Int: 1) + INNER EXPRESSION + --| Function Call: + FUNCTION + ----| Variable(factorial) + ARGS + ----| Variable(b) |}] +;; From fc9530b63b75a70e4933aeb64ce2c5290bda01ee Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 20 Oct 2024 11:14:14 +0300 Subject: [PATCH 079/310] fix: add tab and line break to skip_ws1 symbols Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 701be7635..ea717ecb6 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -7,15 +7,16 @@ open Ast open Base (* TECHNICAL FUNCTIONS *) -let skip_ws = - skip_while (function - | ' ' -> true - | '\n' -> true - | '\t' -> true - | _ -> false) + +let is_ws = function + | ' ' -> true + | '\n' -> true + | '\t' -> true + | _ -> false ;; -let skip_ws1 = char ' ' *> skip_ws +let skip_ws = skip_while is_ws +let skip_ws1 = satisfy is_ws *> skip_ws let chainl1 e op = let rec go acc = lift2 (fun f x -> f acc x) op e >>= go <|> return acc in From 7d21c5f0acf10342e73db90d3942a396b19d5e00 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 20 Oct 2024 12:59:48 +0300 Subject: [PATCH 080/310] feat: implemented REPL Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 77 ++++++++++++++++++++++++++++++++ FSharpActivePatterns/bin/dune | 6 +-- FSharpActivePatterns/bin/main.ml | 11 ----- 3 files changed, 80 insertions(+), 14 deletions(-) create mode 100644 FSharpActivePatterns/bin/REPL.ml delete mode 100644 FSharpActivePatterns/bin/main.ml diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml new file mode 100644 index 000000000..f6fdab5d9 --- /dev/null +++ b/FSharpActivePatterns/bin/REPL.ml @@ -0,0 +1,77 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open FSharpActivePatterns.PrintAst +open FSharpActivePatterns.Parser +open Stdlib + +let input_upto_sep sep ic = + let sep_len = String.length sep in + let take_line () = In_channel.input_line ic in + let rec fill_buffer b = + let line = take_line () in + match line with + | None -> () + | Some line -> + let len = String.length line in + (match String.ends_with ~suffix:sep (String.trim line) with + | true -> + Buffer.add_substring b line 0 (len - sep_len); + Buffer.add_string b "\n" + | false -> + Buffer.add_string b line; + Buffer.add_string b "\n"; + fill_buffer b) + in + let buffer = Buffer.create 1024 in + let () = fill_buffer buffer in + Buffer.contents buffer +;; + +let run_single ic = + let input = input_upto_sep ";;" ic in + parse input +;; + +let run_repl dump_parsetree input_file = + let ic = + match input_file with + | None -> stdin + | Some n -> open_in n + in + let rec run_repl_helper run = + match run ic with + | None -> Stdlib.Format.eprintf "Error occured\n" + | Some ast -> + if dump_parsetree then print_construction ast; + run_repl_helper run + in + run_repl_helper run_single +;; + +type opts = + { mutable dump_parsetree : bool + ; mutable input_file : string option + } + +let () = + let opts = { dump_parsetree = false; input_file = None } in + let open Stdlib.Arg in + let speclist = + [ ( "-dparsetree" + , Unit (fun _ -> opts.dump_parsetree <- true) + , "Dump parse tree, don't evaluate anything" ) + ; ( "-fromfile" + , String (fun filename -> opts.input_file <- Some filename) + , "Input file name" ) + ] + in + let anon_func _ = + Stdlib.Format.eprintf "Positioned arguments are not supported\n"; + Stdlib.exit 1 + in + let usage_msg = "Read-Eval-Print-Loop for F# with Active Patterns" in + let () = parse speclist anon_func usage_msg in + run_repl opts.dump_parsetree opts.input_file +;; diff --git a/FSharpActivePatterns/bin/dune b/FSharpActivePatterns/bin/dune index f145ccfcc..64ac7d7d3 100644 --- a/FSharpActivePatterns/bin/dune +++ b/FSharpActivePatterns/bin/dune @@ -1,6 +1,6 @@ (executable - (public_name main) - (name main) - (libraries FSharpActivePatterns) + (public_name repl) + (name REPL) + (libraries FSharpActivePatterns stdlib) (instrumentation (backend bisect_ppx))) diff --git a/FSharpActivePatterns/bin/main.ml b/FSharpActivePatterns/bin/main.ml deleted file mode 100644 index c7634ce75..000000000 --- a/FSharpActivePatterns/bin/main.ml +++ /dev/null @@ -1,11 +0,0 @@ -(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) - -(** SPDX-License-Identifier: LGPL-3.0-or-later *) - -open FSharpActivePatterns.PrintAst -open FSharpActivePatterns.Parser - -let () = - let input = " f 3 + if true then 12 else h 5 " in - print_p_res (parse input) -;; From 556b172fc5ac0b2a57266e8351b04580fd40b2a8 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 21 Oct 2024 02:39:04 +0300 Subject: [PATCH 081/310] fix: add flush stdout in REPL Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index f6fdab5d9..135786cc1 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -44,7 +44,10 @@ let run_repl dump_parsetree input_file = match run ic with | None -> Stdlib.Format.eprintf "Error occured\n" | Some ast -> - if dump_parsetree then print_construction ast; + if dump_parsetree + then ( + print_construction ast; + flush stdout); run_repl_helper run in run_repl_helper run_single From 09ea9a040073f4c11c9175bee17a8d362a2a4d8b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 21 Oct 2024 19:32:26 +0300 Subject: [PATCH 082/310] fix: incorrect expr in ITE and parentheses parsing Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 33 +++++++++++++++++------- FSharpActivePatterns/lib/tests/parser.ml | 23 +++++++++++++++++ 2 files changed, 47 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index ea717ecb6..cd8ea95b2 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -16,7 +16,19 @@ let is_ws = function ;; let skip_ws = skip_while is_ws -let skip_ws1 = satisfy is_ws *> skip_ws + +let peek_sep1 = + peek_char + >>= fun c -> + match c with + | None -> return None + | Some c -> + if is_ws c || Char.equal c '(' || Char.equal c ')' + then return (Some c) + else fail "need a delimiter" +;; + +let skip_ws_sep1 = peek_sep1 *> skip_ws let chainl1 e op = let rec go acc = lift2 (fun f x -> f acc x) op e >>= go <|> return acc in @@ -76,7 +88,7 @@ let p_ident = let p_var = p_ident >>| fun ident -> Variable ident (* EXPR PARSERS *) -let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' <* skip_ws +let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' let make_binexpr op expr1 expr2 = Bin_expr (op, expr1, expr2) [@@inline always] let make_unexpr op expr = Unary_expr (op, expr) [@@inline always] @@ -106,16 +118,19 @@ let log_and = p_binexpr "&&" Logical_and let p_if p_expr = lift3 (fun cond th el -> If_then_else (cond, th, el)) - (skip_ws *> string "if" *> skip_ws1 *> p_expr) - (skip_ws *> string "then" *> skip_ws1 *> p_expr) - (skip_ws *> string "else" *> skip_ws1 *> (p_expr >>= fun e -> return (Some e)) + (skip_ws *> string "if" *> skip_ws_sep1 *> p_expr) + (skip_ws *> string "then" *> skip_ws_sep1 *> p_expr) + (skip_ws + *> string "else" + *> skip_ws_sep1 + *> (p_expr <* peek_sep1 >>= fun e -> return (Some e)) <|> return None) ;; let p_letin p_expr = skip_ws *> string "let" - *> skip_ws1 + *> skip_ws_sep1 *> lift4 (fun rec_flag name args body in_expr -> LetIn (rec_flag, name, args, body, in_expr)) @@ -125,13 +140,13 @@ let p_letin p_expr = >>= fun args -> if not (List.length args = 0) then return (Some args) else return None) (skip_ws *> string "=" *> skip_ws *> p_expr) - <*> skip_ws *> string "in" *> skip_ws *> p_expr + <*> skip_ws *> string "in" *> skip_ws_sep1 *> p_expr ;; let p_let p_expr = skip_ws *> string "let" - *> skip_ws1 + *> skip_ws_sep1 *> lift4 (fun rec_flag name args body -> Let (rec_flag, name, args, body)) (string "rec" *> return Rec <|> return Nonrec) @@ -139,7 +154,7 @@ let p_let p_expr = (skip_ws *> many (skip_ws *> p_var) >>= fun args -> if not (List.length args = 0) then return (Some args) else return None) - (skip_ws *> string "=" *> skip_ws *> p_expr) + (skip_ws *> string "=" *> p_expr) ;; let app_first expr = diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index 35d34971d..1588aaef7 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -280,3 +280,26 @@ let%expect_test "factorial" = ARGS ----| Variable(b) |}] ;; + +let%expect_test "fail in ITE with incorrect else expression" = + let input = "if true then 1 else 2c" in + print_p_res (parse input); + [%expect{| Error occured |}] +;; + +let%expect_test "call if with parentheses" = + let input = "(if(false)then(a) else(b))c" in + print_p_res (parse input); + [%expect{| + | Function Call: + FUNCTION + --| If Then Else( + CONDITION + ----| Const(Bool: false) + THEN BRANCH + ------| Variable(a) + ELSE BRANCH + ------| Variable(b) + ARGS + --| Variable(c) |}] +;; From f1129eaba150a0cd3994c94764bf09835ecabd72 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 21 Oct 2024 20:23:29 +0300 Subject: [PATCH 083/310] fix: change REPL logic Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/REPL.ml | 15 ++++++++++++--- FSharpActivePatterns/bin/input.txt | 1 + FSharpActivePatterns/lib/parser.ml | 11 +++++++---- FSharpActivePatterns/lib/parser.mli | 7 ++++++- 4 files changed, 26 insertions(+), 8 deletions(-) create mode 100644 FSharpActivePatterns/bin/input.txt diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 135786cc1..091ca6d57 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -31,9 +31,17 @@ let input_upto_sep sep ic = let run_single ic = let input = input_upto_sep ";;" ic in - parse input + let trimmed_input = String.trim input in + if trimmed_input = "" then + (None, false) + else + match parse trimmed_input with + | Success ast -> (Some ast, true) + | Error -> (None, true) ;; + + let run_repl dump_parsetree input_file = let ic = match input_file with @@ -42,8 +50,9 @@ let run_repl dump_parsetree input_file = in let rec run_repl_helper run = match run ic with - | None -> Stdlib.Format.eprintf "Error occured\n" - | Some ast -> + | (None, true) -> Stdlib.Format.eprintf "Error occured\n" + | (None, false) -> Stdlib.Format.eprintf "\n" + | (Some ast, _) -> if dump_parsetree then ( print_construction ast; diff --git a/FSharpActivePatterns/bin/input.txt b/FSharpActivePatterns/bin/input.txt new file mode 100644 index 000000000..c129fcfc1 --- /dev/null +++ b/FSharpActivePatterns/bin/input.txt @@ -0,0 +1 @@ +if a then b else c \ No newline at end of file diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index cd8ea95b2..bd3d49b84 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -6,6 +6,10 @@ open Angstrom open Ast open Base +type 'a parsing_result = + | Success of 'a + | Error + (* TECHNICAL FUNCTIONS *) let is_ws = function @@ -199,8 +203,7 @@ let p_construction = ;; (* MAIN PARSE FUNCTION *) -let parse (str : string) : construction option = +let parse (str : string) : construction parsing_result = match parse_string ~consume:All (skip_ws *> p_construction <* skip_ws) str with - | Ok ast -> Some ast - | Error _ -> None -;; + | Ok ast -> Success ast + | Error _ -> Error \ No newline at end of file diff --git a/FSharpActivePatterns/lib/parser.mli b/FSharpActivePatterns/lib/parser.mli index 19a074986..ce92970a5 100644 --- a/FSharpActivePatterns/lib/parser.mli +++ b/FSharpActivePatterns/lib/parser.mli @@ -4,4 +4,9 @@ open Ast -val parse : string -> construction option +type 'a parsing_result = + | Success of 'a + | Error + +val parse : string -> construction parsing_result + From 8f00d13450515bd816b874b5f188a9edd769a358 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 21 Oct 2024 21:44:41 +0300 Subject: [PATCH 084/310] ref: add types of run result in REPL Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 45 ++++++++++++++++++----------- FSharpActivePatterns/lib/parser.ml | 11 +++---- FSharpActivePatterns/lib/parser.mli | 7 +---- 3 files changed, 33 insertions(+), 30 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 091ca6d57..70a275bba 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -6,42 +6,52 @@ open FSharpActivePatterns.PrintAst open FSharpActivePatterns.Parser open Stdlib +type input = + | Input of string + | EOF + +type 'a run_result = + | Result of 'a + | Fail + | Empty + | End + let input_upto_sep sep ic = let sep_len = String.length sep in let take_line () = In_channel.input_line ic in let rec fill_buffer b = let line = take_line () in match line with - | None -> () + | None -> EOF | Some line -> let len = String.length line in (match String.ends_with ~suffix:sep (String.trim line) with | true -> Buffer.add_substring b line 0 (len - sep_len); - Buffer.add_string b "\n" + Buffer.add_string b "\n"; + Input (Buffer.contents b) | false -> Buffer.add_string b line; Buffer.add_string b "\n"; fill_buffer b) in let buffer = Buffer.create 1024 in - let () = fill_buffer buffer in - Buffer.contents buffer + fill_buffer buffer ;; let run_single ic = - let input = input_upto_sep ";;" ic in - let trimmed_input = String.trim input in - if trimmed_input = "" then - (None, false) - else - match parse trimmed_input with - | Success ast -> (Some ast, true) - | Error -> (None, true) + match input_upto_sep ";;" ic with + | EOF -> End + | Input input -> + let trimmed_input = String.trim input in + if trimmed_input = "" + then Empty + else ( + match parse trimmed_input with + | Some ast -> Result ast + | None -> Fail) ;; - - let run_repl dump_parsetree input_file = let ic = match input_file with @@ -50,9 +60,10 @@ let run_repl dump_parsetree input_file = in let rec run_repl_helper run = match run ic with - | (None, true) -> Stdlib.Format.eprintf "Error occured\n" - | (None, false) -> Stdlib.Format.eprintf "\n" - | (Some ast, _) -> + | Fail -> Stdlib.Format.eprintf "Error occured\n" + | Empty -> Stdlib.Format.eprintf "\n" + | End -> () + | Result ast -> if dump_parsetree then ( print_construction ast; diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index bd3d49b84..7f871a2a9 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -6,10 +6,6 @@ open Angstrom open Ast open Base -type 'a parsing_result = - | Success of 'a - | Error - (* TECHNICAL FUNCTIONS *) let is_ws = function @@ -203,7 +199,8 @@ let p_construction = ;; (* MAIN PARSE FUNCTION *) -let parse (str : string) : construction parsing_result = +let parse (str : string) = match parse_string ~consume:All (skip_ws *> p_construction <* skip_ws) str with - | Ok ast -> Success ast - | Error _ -> Error \ No newline at end of file + | Ok ast -> Some ast + | Error _ -> None +;; diff --git a/FSharpActivePatterns/lib/parser.mli b/FSharpActivePatterns/lib/parser.mli index ce92970a5..19a074986 100644 --- a/FSharpActivePatterns/lib/parser.mli +++ b/FSharpActivePatterns/lib/parser.mli @@ -4,9 +4,4 @@ open Ast -type 'a parsing_result = - | Success of 'a - | Error - -val parse : string -> construction parsing_result - +val parse : string -> construction option From 1107f0b423b4c0faac38a72b2ec50159747d9080 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 21 Oct 2024 21:45:41 +0300 Subject: [PATCH 085/310] fix: spaces after ;; in REPL Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 70a275bba..9b09345ec 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -24,8 +24,9 @@ let input_upto_sep sep ic = match line with | None -> EOF | Some line -> + let line = String.trim line in let len = String.length line in - (match String.ends_with ~suffix:sep (String.trim line) with + (match String.ends_with ~suffix:sep line with | true -> Buffer.add_substring b line 0 (len - sep_len); Buffer.add_string b "\n"; From 033eb26bc69419eb731c379528875c7d8084948c Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 21 Oct 2024 21:48:37 +0300 Subject: [PATCH 086/310] ref: fix fmt Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/parser.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index 1588aaef7..76f79f06e 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -284,13 +284,14 @@ let%expect_test "factorial" = let%expect_test "fail in ITE with incorrect else expression" = let input = "if true then 1 else 2c" in print_p_res (parse input); - [%expect{| Error occured |}] + [%expect {| Error occured |}] ;; let%expect_test "call if with parentheses" = let input = "(if(false)then(a) else(b))c" in print_p_res (parse input); - [%expect{| + [%expect + {| | Function Call: FUNCTION --| If Then Else( From c39fca02f819756c0ee7353476382876c9428595 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 21 Oct 2024 21:56:24 +0300 Subject: [PATCH 087/310] fix: add REPL run after emtpy input Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 9b09345ec..807a4f36e 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -62,7 +62,10 @@ let run_repl dump_parsetree input_file = let rec run_repl_helper run = match run ic with | Fail -> Stdlib.Format.eprintf "Error occured\n" - | Empty -> Stdlib.Format.eprintf "\n" + | Empty -> + Stdlib.Format.eprintf "\n"; + flush stdout; + run_repl_helper run | End -> () | Result ast -> if dump_parsetree From ce4d2966516f86552de3d9b2eff75a42c3ac8886 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 21 Oct 2024 22:01:19 +0300 Subject: [PATCH 088/310] fix: print empty input to stdout in REPL Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 807a4f36e..dd52bcaa8 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -63,7 +63,7 @@ let run_repl dump_parsetree input_file = match run ic with | Fail -> Stdlib.Format.eprintf "Error occured\n" | Empty -> - Stdlib.Format.eprintf "\n"; + Stdlib.Format.printf "\n"; flush stdout; run_repl_helper run | End -> () From 11cf80287cbec48751ba0d3fe93d77348373ba38 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 21 Oct 2024 22:06:12 +0300 Subject: [PATCH 089/310] fix: empty print in REPL Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/abc.txt | 11 +++++++++++ FSharpActivePatterns/bin/REPL.ml | 2 +- 2 files changed, 12 insertions(+), 1 deletion(-) create mode 100644 FSharpActivePatterns/abc.txt diff --git a/FSharpActivePatterns/abc.txt b/FSharpActivePatterns/abc.txt new file mode 100644 index 000000000..7b28e9a78 --- /dev/null +++ b/FSharpActivePatterns/abc.txt @@ -0,0 +1,11 @@ +;; +;; +;; +;; +1;; +;; +2;; + + + + diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index dd52bcaa8..09e97008f 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -63,7 +63,7 @@ let run_repl dump_parsetree input_file = match run ic with | Fail -> Stdlib.Format.eprintf "Error occured\n" | Empty -> - Stdlib.Format.printf "\n"; + Printf.printf "\n"; flush stdout; run_repl_helper run | End -> () From a1f1221efc02eaeccfd661ad8cc4010b455d52f9 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 21 Oct 2024 22:56:41 +0300 Subject: [PATCH 090/310] fix: exclude extra null literal Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 1 - 1 file changed, 1 deletion(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index be127ca7c..3904b7aee 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -10,7 +10,6 @@ type literal = | Bool_lt of bool (** [false], [true] *) | String_lt of string (** ["Hello world"] *) | Unit_lt (** [Unit] *) - | Null_lt (** [Null] *) [@@deriving eq, show { with_path = false }] type binary_operator = From b73cf647e6722fcdde6dd285333ba3f2a2759fb1 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 21 Oct 2024 23:06:27 +0300 Subject: [PATCH 091/310] fix: change arguments in LetIn from list option to list with empty list as no arguments case Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 2 +- FSharpActivePatterns/lib/parser.ml | 4 +--- FSharpActivePatterns/lib/printAst.ml | 8 ++------ FSharpActivePatterns/lib/tests/parser.ml | 4 ---- FSharpActivePatterns/lib/tests/print_ast.ml | 3 +-- 5 files changed, 5 insertions(+), 16 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 3904b7aee..8a53d5c71 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -63,7 +63,7 @@ type expr = | Function_def of expr list * expr (** fun x y -> x + y *) | Function_call of expr * expr (** [sum 1 ] *) | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) - | LetIn of is_recursive * ident option * expr list option * expr * expr + | LetIn of is_recursive * ident option * expr list * expr * expr (** [let f x y = x + y in f 3 4] *) [@@deriving eq, show { with_path = false }] diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 7f871a2a9..b214c27ab 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -136,9 +136,7 @@ let p_letin p_expr = LetIn (rec_flag, name, args, body, in_expr)) (string "rec" *> return Rec <|> return Nonrec) (p_ident >>= fun ident -> return (Some ident) <|> return None) - (many (skip_ws *> p_var) - >>= fun args -> - if not (List.length args = 0) then return (Some args) else return None) + (many (skip_ws *> p_var) >>= fun args -> return args) (skip_ws *> string "=" *> skip_ws *> p_expr) <*> skip_ws *> string "in" *> skip_ws_sep1 *> p_expr ;; diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index c8f26ba87..f6f5902ee 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -41,8 +41,7 @@ let rec print_pattern indent = function | Int_lt i -> printf "%sInt: %d\n" (String.make (indent + 2) '-') i | Bool_lt b -> printf "%sBool: %b\n" (String.make (indent + 2) '-') b | String_lt s -> printf "%sString: %S\n" (String.make (indent + 2) '-') s - | Unit_lt -> printf "%sUnit\n" (String.make (indent + 2) '-') - | Null_lt -> printf "%sNull\n" (String.make (indent + 2) '-')) + | Unit_lt -> printf "%sUnit\n" (String.make (indent + 2) '-')) | PVar (Ident name) -> printf "%s| PVar(%s)\n" (String.make indent '-') name | Variant variants -> printf "%s| Variant:\n" (String.make indent '-'); @@ -62,7 +61,6 @@ let rec print_expr indent expr = | Const (Bool_lt b) -> printf "%s| Const(Bool: %b)\n" (String.make indent '-') b | Const (String_lt s) -> printf "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') - | Const Null_lt -> printf "%s| Const(Null)\n" (String.make indent '-') | List_expr (expr1, expr2) -> printf "%s| List expr:\n" (String.make indent '-'); print_expr (indent + 2) expr1; @@ -121,9 +119,7 @@ let rec print_expr indent expr = | Some (Ident n) -> n | None -> "Anonymous"); printf "%sARGS\n" (String.make (indent + 2) ' '); - (match args with - | None -> printf "%s| No args\n" (String.make (indent + 2) '-') - | Some args -> List.iter (print_expr (indent + 2)) args); + List.iter (print_expr (indent + 2)) args; printf "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 2) body; printf "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index 76f79f06e..f783ee20e 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -27,7 +27,6 @@ let%expect_test "function apply of letIn" = ARGS -- | LetIn x = ARGS - ----| No args BODY ----| Const(Bool: false) INNER EXPRESSION @@ -81,7 +80,6 @@ let%expect_test "order of logical expressions and function applying" = {| | LetIn x = ARGS - --| No args BODY --| Const(Bool: true) INNER EXPRESSION @@ -218,13 +216,11 @@ let%expect_test "inner expressions with LetIn and If" = CONDITION -- | LetIn x = ARGS - ----| No args BODY ----| Const(Bool: true) INNER EXPRESSION ---- | LetIn y = ARGS - ------| No args BODY ------| Const(Bool: false) INNER EXPRESSION diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index db2bc398a..0fa2f5bc7 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -197,7 +197,7 @@ let%expect_test "print Ast of LetIn" = (LetIn ( Nonrec , Some (Ident "x") - , None + , [] , Const (Int_lt 5) , Bin_expr (Binary_add, Variable (Ident "x"), Const (Int_lt 5)) )) in @@ -206,7 +206,6 @@ let%expect_test "print Ast of LetIn" = {| | LetIn x = ARGS - --| No args BODY --| Const(Int: 5) INNER EXPRESSION From 9c5085ac10b35084c7c528a4390ddd2def87b6e1 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 21 Oct 2024 23:09:35 +0300 Subject: [PATCH 092/310] fix: change arguments in Let from list option to list with empty list as no arguments case Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 2 +- FSharpActivePatterns/lib/parser.ml | 4 +--- FSharpActivePatterns/lib/printAst.ml | 4 +--- FSharpActivePatterns/lib/tests/print_ast.ml | 3 +-- 4 files changed, 4 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 8a53d5c71..826b22d26 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -68,7 +68,7 @@ type expr = [@@deriving eq, show { with_path = false }] type statement = - | Let of is_recursive * ident * expr list option * expr (** [let name = expr] *) + | Let of is_recursive * ident * expr list * expr (** [let name = expr] *) | ActivePattern of ident list * expr (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *) [@@deriving eq, show { with_path = false }] diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index b214c27ab..ddc719189 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -149,9 +149,7 @@ let p_let p_expr = (fun rec_flag name args body -> Let (rec_flag, name, args, body)) (string "rec" *> return Rec <|> return Nonrec) (p_ident >>= fun ident -> return ident) - (skip_ws *> many (skip_ws *> p_var) - >>= fun args -> - if not (List.length args = 0) then return (Some args) else return None) + (skip_ws *> many (skip_ws *> p_var) >>= fun args -> return args) (skip_ws *> string "=" *> p_expr) ;; diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index f6f5902ee..bcee07334 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -136,9 +136,7 @@ let print_statement indent = function | Rec -> "Rec") name; printf "%sARGS\n" (String.make (indent + 2) ' '); - (match args with - | None -> printf "%s| No args\n" (String.make (indent + 2) '-') - | Some args -> List.iter (print_expr (indent + 2)) args); + List.iter (print_expr (indent + 2)) args; printf "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 2) body | ActivePattern (patterns, expr) -> diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index 0fa2f5bc7..f71286299 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -25,7 +25,7 @@ let%expect_test "print Ast factorial" = ) )) ) ) in let program = - [ Statement (Let (Nonrec, Ident "a", None, Const (Int_lt 10))) + [ Statement (Let (Nonrec, Ident "a", [], Const (Int_lt 10))) ; Expr factorial ; Expr (Function_call (factorial, Variable (Ident "a"))) ] @@ -35,7 +35,6 @@ let%expect_test "print Ast factorial" = {| | Let a = ARGS - --| No args BODY --| Const(Int: 10) | Func: From 0994fcc0a914bee14ebddfd3c242d0af1bc732bb Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 21 Oct 2024 23:27:36 +0300 Subject: [PATCH 093/310] ref: eta reduction Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index ddc719189..9cdd2960b 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -70,7 +70,7 @@ let p_ident = let find_string = skip_ws *> lift2 - (fun s1 s2 -> s1 ^ s2) + ( ^ ) (take_while1 (function | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true | _ -> false)) @@ -136,7 +136,7 @@ let p_letin p_expr = LetIn (rec_flag, name, args, body, in_expr)) (string "rec" *> return Rec <|> return Nonrec) (p_ident >>= fun ident -> return (Some ident) <|> return None) - (many (skip_ws *> p_var) >>= fun args -> return args) + (many (skip_ws *> p_var)) (skip_ws *> string "=" *> skip_ws *> p_expr) <*> skip_ws *> string "in" *> skip_ws_sep1 *> p_expr ;; @@ -148,8 +148,8 @@ let p_let p_expr = *> lift4 (fun rec_flag name args body -> Let (rec_flag, name, args, body)) (string "rec" *> return Rec <|> return Nonrec) - (p_ident >>= fun ident -> return ident) - (skip_ws *> many (skip_ws *> p_var) >>= fun args -> return args) + p_ident + (skip_ws *> many (skip_ws *> p_var)) (skip_ws *> string "=" *> p_expr) ;; From 2a53f820979343cf1f072ea27b3702eab08a95d2 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 8 Nov 2024 15:40:13 +0300 Subject: [PATCH 094/310] fix: change printer output so it matches F# syntax, edit example Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/input.txt | 5 +- FSharpActivePatterns/lib/printAst.ml | 85 +++++++++++++--------------- 2 files changed, 43 insertions(+), 47 deletions(-) diff --git a/FSharpActivePatterns/bin/input.txt b/FSharpActivePatterns/bin/input.txt index c129fcfc1..9c77b084a 100644 --- a/FSharpActivePatterns/bin/input.txt +++ b/FSharpActivePatterns/bin/input.txt @@ -1 +1,4 @@ -if a then b else c \ No newline at end of file +let a = 6 in +if a = 5 then b else func a b c +;; +let a b c = if a then b else c;; \ No newline at end of file diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index bcee07334..87caff5f9 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -6,19 +6,18 @@ open Ast open Printf let print_bin_op indent = function - | Binary_equal -> printf "%s| Binary Equal\n" (String.make indent '-') - | Binary_unequal -> printf "%s| Binary Unequal\n" (String.make indent '-') - | Binary_less -> printf "%s| Binary Less\n" (String.make indent '-') - | Binary_less_or_equal -> printf "%s| Binary Less Or Equal\n" (String.make indent '-') - | Binary_greater -> printf "%s| Binary Greater\n" (String.make indent '-') - | Binary_greater_or_equal -> - printf "%s| Binary Greater Or Equal\n" (String.make indent '-') - | Binary_add -> printf "%s| Binary Add\n" (String.make indent '-') - | Binary_subtract -> printf "%s| Binary Subtract\n" (String.make indent '-') - | Binary_multiply -> printf "%s| Binary Multiply\n" (String.make indent '-') - | Logical_or -> printf "%s| Logical Or\n" (String.make indent '-') - | Logical_and -> printf "%s| Logical And\n" (String.make indent '-') - | Binary_divide -> printf "%s| Binary Divide\n" (String.make indent '-') + | Binary_equal -> printf "= " + | Binary_unequal -> printf "<> " + | Binary_less -> printf "< " + | Binary_less_or_equal -> printf "<= " + | Binary_greater -> printf "> " + | Binary_greater_or_equal -> printf ">= " + | Binary_add -> printf "+ " + | Binary_subtract -> printf "- " + | Binary_multiply -> printf "* " + | Logical_or -> printf "|| " + | Logical_and -> printf "&& " + | Binary_divide -> printf "/ " | Binary_or_bitwise -> printf "%s| Binary Or Bitwise\n" (String.make indent '-') | Binary_xor_bitwise -> printf "%s| Binary Xor Bitwise\n" (String.make indent '-') | Binary_and_bitwise -> printf "%s| Binary And Bitwise\n" (String.make indent '-') @@ -50,14 +49,14 @@ let rec print_pattern indent = function variants ;; -let print_unary_op indent = function - | Unary_minus -> printf "%s| Unary minus\n" (String.make indent '-') - | Unary_not -> printf "%s| Unary negative\n" (String.make indent '-') +let print_unary_op = function + | Unary_minus -> printf "-" + | Unary_not -> printf "not " ;; let rec print_expr indent expr = match expr with - | Const (Int_lt i) -> printf "%s| Const(Int: %d)\n" (String.make indent '-') i + | Const (Int_lt i) -> printf "%d " i | Const (Bool_lt b) -> printf "%s| Const(Bool: %b)\n" (String.make indent '-') b | Const (String_lt s) -> printf "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') @@ -76,26 +75,24 @@ let rec print_expr indent expr = printf "%s| Inner expr:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) expr) patterns - | Variable (Ident name) -> printf "%s| Variable(%s)\n" (String.make indent '-') name + | Variable (Ident name) -> printf "%s " name | Unary_expr (op, expr) -> - printf "%s| Unary expr(\n" (String.make indent '-'); - print_unary_op indent op; + print_unary_op op; print_expr (indent + 2) expr | Bin_expr (op, left, right) -> - printf "%s| Binary expr(\n" (String.make indent '-'); - print_bin_op indent op; print_expr (indent + 2) left; + print_bin_op indent op; print_expr (indent + 2) right | If_then_else (cond, then_body, else_body) -> - printf "%s| If Then Else(\n" (String.make indent '-'); - printf "%sCONDITION\n" (String.make (indent + 2) ' '); + printf "if "; print_expr (indent + 2) cond; - printf "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); + printf "then "; print_expr (indent + 4) then_body; - printf "%sELSE BRANCH\n" (String.make (indent + 2) ' '); (match else_body with - | Some body -> print_expr (indent + 4) body - | None -> printf "No else body") + | Some body -> ( + printf "else "; + print_expr (indent + 4) body) + |None -> printf ";\n") | Function_def (args, body) -> printf "%s| Func:\n" (String.make indent '-'); printf "%sARGS\n" (String.make (indent + 2) ' '); @@ -103,41 +100,33 @@ let rec print_expr indent expr = printf "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 4) body | Function_call (func, arg) -> - printf "%s| Function Call:\n" (String.make indent '-'); - printf "%sFUNCTION\n" (String.make (indent + 2) ' '); print_expr (indent + 2) func; - printf "%sARGS\n" (String.make (indent + 2) ' '); print_expr (indent + 2) arg | LetIn (rec_flag, name, args, body, in_expr) -> printf - "%s | LetIn %s %s =\n" - (String.make indent '-') + "let %s %s = " (match rec_flag with | Nonrec -> "" - | Rec -> "Rec") + | Rec -> "rec") (match name with | Some (Ident n) -> n - | None -> "Anonymous"); - printf "%sARGS\n" (String.make (indent + 2) ' '); + | None -> "()"); List.iter (print_expr (indent + 2)) args; - printf "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 2) body; - printf "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); - print_expr (indent + 2) in_expr + printf "in\n"; + print_expr (indent + 2) in_expr; + printf "\n" ;; let print_statement indent = function | Let (rec_flag, Ident name, args, body) -> printf - "%s | Let %s %s =\n" - (String.make indent '-') + "let %s %s = " (match rec_flag with | Nonrec -> "" - | Rec -> "Rec") + | Rec -> "rec") name; - printf "%sARGS\n" (String.make (indent + 2) ' '); List.iter (print_expr (indent + 2)) args; - printf "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 2) body | ActivePattern (patterns, expr) -> printf "%s| ActivePattern:\n" (String.make indent '-'); @@ -148,8 +137,12 @@ let print_statement indent = function ;; let print_construction = function - | Expr e -> print_expr 0 e - | Statement s -> print_statement 0 s + | Expr e -> + (print_expr 0 e; + printf ";;\n") + | Statement s -> + (print_statement 0 s; + printf ";;\n") ;; let print_p_res = function From 40b3ad31f4153bbc2757a394dcedf08e5246707e Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 9 Nov 2024 19:02:43 +0300 Subject: [PATCH 095/310] feat: implement parser for option and tuple, change corresponding print funcs Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 3 ++- FSharpActivePatterns/lib/parser.ml | 22 ++++++++++++++++++++-- FSharpActivePatterns/lib/printAst.ml | 14 +++++++++++++- 3 files changed, 35 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 826b22d26..41052f8fa 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -51,7 +51,7 @@ type is_recursive = type expr = | Const of literal (** [Int], [Bool], [String], [Unit], [Null] *) - | Tuple of expr list (** [(1, "Hello world", true)] *) + | Tuple of expr * expr * expr list (** [(1, "Hello world", true)] *) | List_expr of expr * expr (** {[ [ 1; 2; 3 ] @@ -65,6 +65,7 @@ type expr = | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) | LetIn of is_recursive * ident option * expr list * expr * expr (** [let f x y = x + y in f 3 4] *) + | Option of expr option (** [int option] *) [@@deriving eq, show { with_path = false }] type statement = diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 9cdd2960b..7b7d9c0ce 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -115,6 +115,16 @@ let greater_or_equal = p_binexpr ">=" Binary_greater_or_equal let log_or = p_binexpr "||" Logical_or let log_and = p_binexpr "&&" Logical_and +let p_tuple p_expr = + skip_ws *> + string "(" *> + lift3 + (fun fst snd tail -> Tuple(fst, snd, tail)) + (p_expr) + (skip_ws *> string "," *> skip_ws *> p_expr) + (many (skip_ws *> string "," *> skip_ws *> p_expr)) + <* skip_ws <* string ")" + let p_if p_expr = lift3 (fun cond th el -> If_then_else (cond, th, el)) @@ -170,11 +180,18 @@ let p_apply expr = parse_args name ;; +let p_option p_expr = + skip_ws *> + (string "None" *> return (Option None)) + <|> (skip_ws *> string "Some" *> p_expr >>| fun expr -> Option (Some expr)) +;; + let p_expr = skip_ws *> fix (fun p_expr -> let atom = choice [ p_var; p_int; p_bool; p_parens p_expr ] in - let if_expr = p_if (p_expr <|> atom) <|> atom in + let tuple = p_tuple atom <|> atom in + let if_expr = p_if (p_expr <|> tuple) <|> tuple in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in let apply = p_apply (p_expr <|> letin_expr) <|> letin_expr in let unary = choice [ unary_chain p_not apply; unary_chain unminus apply ] in @@ -185,7 +202,8 @@ let p_expr = let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in let comp_and = chainl1 comp_gr log_and in let comp_or = chainl1 comp_and log_or in - comp_or) + let option = p_option comp_or <|> comp_or in + option) ;; let p_statement = p_let p_expr diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 87caff5f9..e3fe22e28 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -64,7 +64,13 @@ let rec print_expr indent expr = printf "%s| List expr:\n" (String.make indent '-'); print_expr (indent + 2) expr1; print_expr (indent + 2) expr2 - | Tuple t -> List.iter (print_expr indent) t + | Tuple (fst, snd, tail) -> ( + printf "("; + print_expr (indent + 2) fst; + printf ", "; + print_expr (indent + 2) snd; + List.iter (fun e -> printf ", "; print_expr indent e) tail; + printf ") ") | Match (value, patterns) -> printf "%s| Match:\n" (String.make indent '-'); print_expr (indent + 2) value; @@ -116,6 +122,12 @@ let rec print_expr indent expr = printf "in\n"; print_expr (indent + 2) in_expr; printf "\n" + | Option (expr) -> + match expr with + | None -> printf "None " + | Some (expr) -> ( + printf "Some "; + print_expr (indent +2) expr) ;; let print_statement indent = function From ba6538fdfbf0b57dce109b567a657a6f70f14431 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 10 Nov 2024 00:42:02 +0300 Subject: [PATCH 096/310] feat: implemet type cast to identifiers Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 2 +- FSharpActivePatterns/lib/parser.ml | 9 +++- FSharpActivePatterns/lib/printAst.ml | 48 ++++++++++++++------- FSharpActivePatterns/lib/tests/print_ast.ml | 28 ++++++------ 4 files changed, 55 insertions(+), 32 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 41052f8fa..ec9dfb52f 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -2,7 +2,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -type ident = Ident of string (** identifier *) +type ident = Ident of string * string option (** identifier *) [@@deriving eq, show { with_path = false }] type literal = diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 7b7d9c0ce..02d612400 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -66,6 +66,11 @@ let is_keyword = function | _ -> false ;; +let p_type = + skip_ws *> char ':' *> skip_ws *> + (choice [string "int"; string "bool"] >>| fun var_type -> Some var_type) + <|> return None + let p_ident = let find_string = skip_ws @@ -82,7 +87,9 @@ let p_ident = >>= fun str -> if is_keyword str then fail "keywords are not allowed as variable names" - else return (Ident str) + else ( + p_type >>| fun type_opt -> Ident (str, type_opt) + ) ;; let p_var = p_ident >>| fun ident -> Variable ident diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index e3fe22e28..dfa07fce7 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -41,11 +41,16 @@ let rec print_pattern indent = function | Bool_lt b -> printf "%sBool: %b\n" (String.make (indent + 2) '-') b | String_lt s -> printf "%sString: %S\n" (String.make (indent + 2) '-') s | Unit_lt -> printf "%sUnit\n" (String.make (indent + 2) '-')) - | PVar (Ident name) -> printf "%s| PVar(%s)\n" (String.make indent '-') name + | PVar (Ident (name, var_type)) -> ( + printf "%s " name; + match var_type with + | None -> printf "" + | Some str -> printf ": %s " str + ) | Variant variants -> printf "%s| Variant:\n" (String.make indent '-'); List.iter - (fun (Ident v) -> printf "%s- %s\n" (String.make (indent + 2) '-') v) + (fun (Ident (v, _)) -> printf "%s- %s\n" (String.make (indent + 2) '-') v) variants ;; @@ -81,7 +86,11 @@ let rec print_expr indent expr = printf "%s| Inner expr:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) expr) patterns - | Variable (Ident name) -> printf "%s " name + | Variable (Ident (name, var_type)) -> ( + printf "%s " name; + match var_type with + | None -> printf "" + | Some str -> printf ": %s " str) | Unary_expr (op, expr) -> print_unary_op op; print_expr (indent + 2) expr @@ -109,14 +118,19 @@ let rec print_expr indent expr = print_expr (indent + 2) func; print_expr (indent + 2) arg | LetIn (rec_flag, name, args, body, in_expr) -> - printf - "let %s %s = " + printf "let %s " (match rec_flag with | Nonrec -> "" - | Rec -> "rec") - (match name with - | Some (Ident n) -> n - | None -> "()"); + | Rec -> "rec"); + (match name with + | Some (Ident (name, var_type)) -> ( + printf "%s " name; + match var_type with + | None -> () + | Some str -> printf ": %s " str + ) + | None -> printf "()" + ); List.iter (print_expr (indent + 2)) args; print_expr (indent + 2) body; printf "in\n"; @@ -131,19 +145,21 @@ let rec print_expr indent expr = ;; let print_statement indent = function - | Let (rec_flag, Ident name, args, body) -> - printf - "let %s %s = " + | Let (rec_flag, Ident (name, var_type), args, body) -> + printf "let %s " (match rec_flag with | Nonrec -> "" - | Rec -> "rec") - name; + | Rec -> "rec"); + printf "%s " name; + (match var_type with + | None -> () + | Some str -> printf ": %s " str); List.iter (print_expr (indent + 2)) args; - print_expr (indent + 2) body + print_expr (indent + 2) body; | ActivePattern (patterns, expr) -> printf "%s| ActivePattern:\n" (String.make indent '-'); List.iter - (fun (Ident param) -> printf "%s- %s\n" (String.make (indent + 2) '-') param) + (fun (Ident (param, _)) -> printf "%s- %s\n" (String.make (indent + 2) '-') param) patterns; print_expr (indent + 2) expr ;; diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index f71286299..14af5ba89 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -8,26 +8,26 @@ open FSharpActivePatterns.PrintAst let%expect_test "print Ast factorial" = let factorial = Function_def - ( [ Variable (Ident "n") ] + ( [ Variable (Ident ("n", None)) ] , If_then_else ( Bin_expr ( Logical_or - , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 0)) - , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 1)) ) + , Bin_expr (Binary_equal, Variable (Ident ("n", None)), Const (Int_lt 0)) + , Bin_expr (Binary_equal, Variable (Ident ("n", None)), Const (Int_lt 1)) ) , Const (Int_lt 1) , Some (Bin_expr ( Binary_multiply - , Variable (Ident "n") + , Variable (Ident ("n", None)) , Function_call - ( Variable (Ident "factorial") - , Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) + ( Variable (Ident ("factorial", None)) + , Bin_expr (Binary_subtract, Variable (Ident ("n", None)), Const (Int_lt 1)) ) )) ) ) in let program = - [ Statement (Let (Nonrec, Ident "a", [], Const (Int_lt 10))) + [ Statement (Let (Nonrec, Ident ("a", None), [], Const (Int_lt 10))) ; Expr factorial - ; Expr (Function_call (factorial, Variable (Ident "a"))) + ; Expr (Function_call (factorial, Variable (Ident ("a", None)))) ] in List.iter print_construction program; @@ -104,7 +104,7 @@ let%expect_test "print Ast factorial" = ;; let%expect_test "print Ast double func" = - let var = Variable (Ident "n") in + let var = Variable (Ident ("n", None)) in let args = [ var ] in let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), var) in let double = Function_def (args, binary_expr) in @@ -195,10 +195,10 @@ let%expect_test "print Ast of LetIn" = Expr (LetIn ( Nonrec - , Some (Ident "x") + , Some (Ident ("x", None)) , [] , Const (Int_lt 5) - , Bin_expr (Binary_add, Variable (Ident "x"), Const (Int_lt 5)) )) + , Bin_expr (Binary_add, Variable (Ident ("x", None)), Const (Int_lt 5)) )) in print_construction sum; [%expect @@ -218,12 +218,12 @@ let%expect_test "print Ast of match_expr" = let patterns = [ PConst (Int_lt 5) ; PConst (String_lt " bar foo") - ; Variant [ Ident "Green"; Ident "Blue"; Ident "Red" ] - ; PCons (Wild, PVar (Ident "xs")) + ; Variant [ Ident ("Green", None); Ident ("Blue", None); Ident ("Red", None) ] + ; PCons (Wild, PVar (Ident ("xs", None))) ] in let pattern_values = List.map (fun p -> p, Const (Int_lt 4)) patterns in - let match_expr = Match (Variable (Ident "x"), pattern_values) in + let match_expr = Match (Variable (Ident ("x", None)), pattern_values) in print_construction (Expr match_expr); [%expect {| From 59e1677e4b1a4fa9e0776ab6c5473b5d79033ffa Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 10 Nov 2024 00:42:39 +0300 Subject: [PATCH 097/310] feat: update example Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/input.txt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/FSharpActivePatterns/bin/input.txt b/FSharpActivePatterns/bin/input.txt index 9c77b084a..38307ed6a 100644 --- a/FSharpActivePatterns/bin/input.txt +++ b/FSharpActivePatterns/bin/input.txt @@ -1,4 +1,4 @@ -let a = 6 in -if a = 5 then b else func a b c +let a : bool = true in +if a:int = 5 then None else func a b c ;; -let a b c = if a then b else c;; \ No newline at end of file +let a b c = if a then Some (c, b) else ( a , b , c );; \ No newline at end of file From 3ed7159e36027fe3243e0a2854cff72f7e9030f4 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 10 Nov 2024 00:44:43 +0300 Subject: [PATCH 098/310] fix: print of booleans Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/printAst.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index dfa07fce7..fdae7f899 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -62,7 +62,7 @@ let print_unary_op = function let rec print_expr indent expr = match expr with | Const (Int_lt i) -> printf "%d " i - | Const (Bool_lt b) -> printf "%s| Const(Bool: %b)\n" (String.make indent '-') b + | Const (Bool_lt b) -> printf "%b " b | Const (String_lt s) -> printf "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') | List_expr (expr1, expr2) -> From 9a4f645efb442f9435671d30b448f723eff00642 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 10 Nov 2024 00:48:55 +0300 Subject: [PATCH 099/310] fix: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 36 ++++---- FSharpActivePatterns/lib/printAst.ml | 97 +++++++++++---------- FSharpActivePatterns/lib/tests/print_ast.ml | 3 +- 3 files changed, 71 insertions(+), 65 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 02d612400..8769af2a0 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -67,9 +67,12 @@ let is_keyword = function ;; let p_type = - skip_ws *> char ':' *> skip_ws *> - (choice [string "int"; string "bool"] >>| fun var_type -> Some var_type) + skip_ws + *> char ':' + *> skip_ws + *> (choice [ string "int"; string "bool" ] >>| fun var_type -> Some var_type) <|> return None +;; let p_ident = let find_string = @@ -87,9 +90,7 @@ let p_ident = >>= fun str -> if is_keyword str then fail "keywords are not allowed as variable names" - else ( - p_type >>| fun type_opt -> Ident (str, type_opt) - ) + else p_type >>| fun type_opt -> Ident (str, type_opt) ;; let p_var = p_ident >>| fun ident -> Variable ident @@ -122,15 +123,17 @@ let greater_or_equal = p_binexpr ">=" Binary_greater_or_equal let log_or = p_binexpr "||" Logical_or let log_and = p_binexpr "&&" Logical_and -let p_tuple p_expr = - skip_ws *> - string "(" *> - lift3 - (fun fst snd tail -> Tuple(fst, snd, tail)) - (p_expr) - (skip_ws *> string "," *> skip_ws *> p_expr) - (many (skip_ws *> string "," *> skip_ws *> p_expr)) - <* skip_ws <* string ")" +let p_tuple p_expr = + skip_ws + *> string "(" + *> lift3 + (fun fst snd tail -> Tuple (fst, snd, tail)) + p_expr + (skip_ws *> string "," *> skip_ws *> p_expr) + (many (skip_ws *> string "," *> skip_ws *> p_expr)) + <* skip_ws + <* string ")" +;; let p_if p_expr = lift3 @@ -188,9 +191,8 @@ let p_apply expr = ;; let p_option p_expr = - skip_ws *> - (string "None" *> return (Option None)) - <|> (skip_ws *> string "Some" *> p_expr >>| fun expr -> Option (Some expr)) + skip_ws *> (string "None" *> return (Option None)) + <|> (skip_ws *> string "Some" *> p_expr >>| fun expr -> Option (Some expr)) ;; let p_expr = diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index fdae7f899..03e5f2bbc 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -6,17 +6,17 @@ open Ast open Printf let print_bin_op indent = function - | Binary_equal -> printf "= " - | Binary_unequal -> printf "<> " + | Binary_equal -> printf "= " + | Binary_unequal -> printf "<> " | Binary_less -> printf "< " - | Binary_less_or_equal -> printf "<= " - | Binary_greater -> printf "> " - | Binary_greater_or_equal -> printf ">= " + | Binary_less_or_equal -> printf "<= " + | Binary_greater -> printf "> " + | Binary_greater_or_equal -> printf ">= " | Binary_add -> printf "+ " | Binary_subtract -> printf "- " | Binary_multiply -> printf "* " - | Logical_or -> printf "|| " - | Logical_and -> printf "&& " + | Logical_or -> printf "|| " + | Logical_and -> printf "&& " | Binary_divide -> printf "/ " | Binary_or_bitwise -> printf "%s| Binary Or Bitwise\n" (String.make indent '-') | Binary_xor_bitwise -> printf "%s| Binary Xor Bitwise\n" (String.make indent '-') @@ -41,12 +41,11 @@ let rec print_pattern indent = function | Bool_lt b -> printf "%sBool: %b\n" (String.make (indent + 2) '-') b | String_lt s -> printf "%sString: %S\n" (String.make (indent + 2) '-') s | Unit_lt -> printf "%sUnit\n" (String.make (indent + 2) '-')) - | PVar (Ident (name, var_type)) -> ( + | PVar (Ident (name, var_type)) -> printf "%s " name; - match var_type with - | None -> printf "" - | Some str -> printf ": %s " str - ) + (match var_type with + | None -> printf "" + | Some str -> printf ": %s " str) | Variant variants -> printf "%s| Variant:\n" (String.make indent '-'); List.iter @@ -69,13 +68,17 @@ let rec print_expr indent expr = printf "%s| List expr:\n" (String.make indent '-'); print_expr (indent + 2) expr1; print_expr (indent + 2) expr2 - | Tuple (fst, snd, tail) -> ( + | Tuple (fst, snd, tail) -> printf "("; print_expr (indent + 2) fst; printf ", "; print_expr (indent + 2) snd; - List.iter (fun e -> printf ", "; print_expr indent e) tail; - printf ") ") + List.iter + (fun e -> + printf ", "; + print_expr indent e) + tail; + printf ") " | Match (value, patterns) -> printf "%s| Match:\n" (String.make indent '-'); print_expr (indent + 2) value; @@ -86,11 +89,11 @@ let rec print_expr indent expr = printf "%s| Inner expr:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) expr) patterns - | Variable (Ident (name, var_type)) -> ( + | Variable (Ident (name, var_type)) -> printf "%s " name; - match var_type with - | None -> printf "" - | Some str -> printf ": %s " str) + (match var_type with + | None -> printf "" + | Some str -> printf ": %s " str) | Unary_expr (op, expr) -> print_unary_op op; print_expr (indent + 2) expr @@ -104,10 +107,10 @@ let rec print_expr indent expr = printf "then "; print_expr (indent + 4) then_body; (match else_body with - | Some body -> ( - printf "else "; - print_expr (indent + 4) body) - |None -> printf ";\n") + | Some body -> + printf "else "; + print_expr (indent + 4) body + | None -> printf ";\n") | Function_def (args, body) -> printf "%s| Func:\n" (String.make indent '-'); printf "%sARGS\n" (String.make (indent + 2) ' '); @@ -118,44 +121,44 @@ let rec print_expr indent expr = print_expr (indent + 2) func; print_expr (indent + 2) arg | LetIn (rec_flag, name, args, body, in_expr) -> - printf "let %s " + printf + "let %s " (match rec_flag with | Nonrec -> "" | Rec -> "rec"); (match name with - | Some (Ident (name, var_type)) -> ( - printf "%s " name; - match var_type with - | None -> () - | Some str -> printf ": %s " str - ) - | None -> printf "()" - ); + | Some (Ident (name, var_type)) -> + printf "%s " name; + (match var_type with + | None -> () + | Some str -> printf ": %s " str) + | None -> printf "()"); List.iter (print_expr (indent + 2)) args; print_expr (indent + 2) body; printf "in\n"; print_expr (indent + 2) in_expr; printf "\n" - | Option (expr) -> - match expr with - | None -> printf "None " - | Some (expr) -> ( - printf "Some "; - print_expr (indent +2) expr) + | Option expr -> + (match expr with + | None -> printf "None " + | Some expr -> + printf "Some "; + print_expr (indent + 2) expr) ;; let print_statement indent = function | Let (rec_flag, Ident (name, var_type), args, body) -> - printf "let %s " + printf + "let %s " (match rec_flag with | Nonrec -> "" | Rec -> "rec"); - printf "%s " name; + printf "%s " name; (match var_type with | None -> () | Some str -> printf ": %s " str); List.iter (print_expr (indent + 2)) args; - print_expr (indent + 2) body; + print_expr (indent + 2) body | ActivePattern (patterns, expr) -> printf "%s| ActivePattern:\n" (String.make indent '-'); List.iter @@ -165,12 +168,12 @@ let print_statement indent = function ;; let print_construction = function - | Expr e -> - (print_expr 0 e; - printf ";;\n") - | Statement s -> - (print_statement 0 s; - printf ";;\n") + | Expr e -> + print_expr 0 e; + printf ";;\n" + | Statement s -> + print_statement 0 s; + printf ";;\n" ;; let print_p_res = function diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index 14af5ba89..40ebc47f1 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -21,7 +21,8 @@ let%expect_test "print Ast factorial" = , Variable (Ident ("n", None)) , Function_call ( Variable (Ident ("factorial", None)) - , Bin_expr (Binary_subtract, Variable (Ident ("n", None)), Const (Int_lt 1)) + , Bin_expr + (Binary_subtract, Variable (Ident ("n", None)), Const (Int_lt 1)) ) )) ) ) in let program = From 3358f1748dcd634fd8a08c3f56cfd9a2159b673b Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 10 Nov 2024 11:51:24 +0300 Subject: [PATCH 100/310] fix: add equal sign Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/printAst.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 03e5f2bbc..eec76b2e4 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -134,6 +134,7 @@ let rec print_expr indent expr = | Some str -> printf ": %s " str) | None -> printf "()"); List.iter (print_expr (indent + 2)) args; + printf "= "; print_expr (indent + 2) body; printf "in\n"; print_expr (indent + 2) in_expr; @@ -157,6 +158,7 @@ let print_statement indent = function (match var_type with | None -> () | Some str -> printf ": %s " str); + printf "= "; List.iter (print_expr (indent + 2)) args; print_expr (indent + 2) body | ActivePattern (patterns, expr) -> From 466c2837dcf264c55b30b22b29ce2e76f3640d6a Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 10 Nov 2024 13:07:57 +0300 Subject: [PATCH 101/310] feat: implement mutual recursion through and Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 8 ++-- FSharpActivePatterns/lib/parser.ml | 49 +++++++++++++++++++-- FSharpActivePatterns/lib/printAst.ml | 19 ++++++-- FSharpActivePatterns/lib/tests/print_ast.ml | 3 +- 4 files changed, 67 insertions(+), 12 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index ec9dfb52f..37af2b3f3 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -63,13 +63,15 @@ type expr = | Function_def of expr list * expr (** fun x y -> x + y *) | Function_call of expr * expr (** [sum 1 ] *) | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) - | LetIn of is_recursive * ident option * expr list * expr * expr - (** [let f x y = x + y in f 3 4] *) + | LetIn of is_recursive * ident option * expr list * expr * and_bind list * expr + (** [let f x y = x + y in f 3 4 and g = f-x in f (g 10 5) 2] *) | Option of expr option (** [int option] *) [@@deriving eq, show { with_path = false }] +and and_bind = And_bind of ident * expr list * expr (** [and sum n m = n+m] *) + type statement = - | Let of is_recursive * ident * expr list * expr (** [let name = expr] *) + | Let of is_recursive * ident * expr list * expr * and_bind list (** [let name = expr] *) | ActivePattern of ident list * expr (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *) [@@deriving eq, show { with_path = false }] diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 8769af2a0..28a3c02ed 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -62,6 +62,7 @@ let is_keyword = function | "fun" | "match" | "with" + | "and" | "_" -> true | _ -> false ;; @@ -147,32 +148,72 @@ let p_if p_expr = <|> return None) ;; +let p_and p_expr = + skip_ws *> string "and" *> skip_ws_sep1 *> + lift3 + (fun name args body -> And_bind(name, args, body)) + p_ident + (many (skip_ws *> p_var)) + (skip_ws *> string "=" *> skip_ws *> p_expr) +;; +(* let p_letin p_expr = skip_ws *> string "let" *> skip_ws_sep1 *> lift4 - (fun rec_flag name args body in_expr -> - LetIn (rec_flag, name, args, body, in_expr)) + (fun rec_flag name args body and_list in_expr -> + LetIn (rec_flag, name, args, body, and_list, in_expr)) (string "rec" *> return Rec <|> return Nonrec) (p_ident >>= fun ident -> return (Some ident) <|> return None) (many (skip_ws *> p_var)) (skip_ws *> string "=" *> skip_ws *> p_expr) - <*> skip_ws *> string "in" *> skip_ws_sep1 *> p_expr + <*> skip_ws *> many (skip_ws *> p_and p_expr) + <*> skip_ws *> string "in" *> skip_ws_sep1 *> p_expr +;; *) + +let p_letin p_expr = + skip_ws + *> string "let" + *> skip_ws_sep1 + *> (string "rec" *> return Rec <|> return Nonrec) + >>= fun rec_flag -> + (p_ident >>= fun name -> return (Some name)) <|> return None >>= fun name_option -> + (skip_ws *> many (skip_ws *> p_var)) >>= fun args -> + (skip_ws *> string "=" *> skip_ws *> p_expr) >>= fun body -> + (skip_ws *> many (skip_ws *> p_and p_expr)) >>= fun and_list -> + skip_ws *> string "in" *> skip_ws_sep1 *> p_expr >>= fun in_expr -> + return (LetIn (rec_flag, name_option, args, body, and_list, in_expr)) ;; +(* let p_let p_expr = skip_ws *> string "let" *> skip_ws_sep1 *> lift4 - (fun rec_flag name args body -> Let (rec_flag, name, args, body)) + (fun rec_flag name args body and_list -> Let (rec_flag, name, args, body, and_list)) (string "rec" *> return Rec <|> return Nonrec) p_ident (skip_ws *> many (skip_ws *> p_var)) (skip_ws *> string "=" *> p_expr) + <*> skip_ws *> many (skip_ws *> p_and p_expr) +;; *) + +let p_let p_expr = + skip_ws + *> string "let" + *> skip_ws_sep1 + *> (string "rec" *> return Rec <|> return Nonrec) + >>= fun rec_flag -> + p_ident >>= fun name -> + (skip_ws *> many (skip_ws *> p_var)) >>= fun args -> + (skip_ws *> string "=" *> skip_ws *> p_expr) >>= fun body -> + (skip_ws *> many (skip_ws *> p_and p_expr)) >>= fun and_list -> + return (Let (rec_flag, name, args, body, and_list)) ;; + let app_first expr = skip_ws *> fix (fun a_exp -> diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index eec76b2e4..c0e15fdc9 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -120,7 +120,7 @@ let rec print_expr indent expr = | Function_call (func, arg) -> print_expr (indent + 2) func; print_expr (indent + 2) arg - | LetIn (rec_flag, name, args, body, in_expr) -> + | LetIn (rec_flag, name, args, body, and_list, in_expr) -> printf "let %s " (match rec_flag with @@ -136,6 +136,7 @@ let rec print_expr indent expr = List.iter (print_expr (indent + 2)) args; printf "= "; print_expr (indent + 2) body; + List.iter (print_and) and_list; printf "in\n"; print_expr (indent + 2) in_expr; printf "\n" @@ -145,10 +146,19 @@ let rec print_expr indent expr = | Some expr -> printf "Some "; print_expr (indent + 2) expr) +and print_and (And_bind(Ident(name, var_type), args, body)) = + printf "\nand "; + printf "%s " name; + (match var_type with + | None -> () + | Some str -> printf ": %s " str); + List.iter (fun arg -> print_expr 0 arg) args; + printf "= "; + print_expr 6 body ;; let print_statement indent = function - | Let (rec_flag, Ident (name, var_type), args, body) -> + | Let (rec_flag, Ident (name, var_type), args, body, and_list) -> printf "let %s " (match rec_flag with @@ -158,9 +168,10 @@ let print_statement indent = function (match var_type with | None -> () | Some str -> printf ": %s " str); - printf "= "; List.iter (print_expr (indent + 2)) args; - print_expr (indent + 2) body + printf "= "; + print_expr (indent + 2) body; + List.iter (print_and) and_list | ActivePattern (patterns, expr) -> printf "%s| ActivePattern:\n" (String.make indent '-'); List.iter diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index 40ebc47f1..f3e9142b3 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -26,7 +26,7 @@ let%expect_test "print Ast factorial" = ) )) ) ) in let program = - [ Statement (Let (Nonrec, Ident ("a", None), [], Const (Int_lt 10))) + [ Statement (Let (Nonrec, Ident ("a", None), [], Const (Int_lt 10), [])) ; Expr factorial ; Expr (Function_call (factorial, Variable (Ident ("a", None)))) ] @@ -199,6 +199,7 @@ let%expect_test "print Ast of LetIn" = , Some (Ident ("x", None)) , [] , Const (Int_lt 5) + , [] , Bin_expr (Binary_add, Variable (Ident ("x", None)), Const (Int_lt 5)) )) in print_construction sum; From 77dee1689b4eb1bf3c6f2e714f152655c1e069bc Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 10 Nov 2024 13:08:27 +0300 Subject: [PATCH 102/310] feat: update example Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/input.txt | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/bin/input.txt b/FSharpActivePatterns/bin/input.txt index 38307ed6a..2fd54233d 100644 --- a/FSharpActivePatterns/bin/input.txt +++ b/FSharpActivePatterns/bin/input.txt @@ -1,4 +1,7 @@ -let a : bool = true in -if a:int = 5 then None else func a b c -;; -let a b c = if a then Some (c, b) else ( a , b , c );; \ No newline at end of file +let rec even n = + if n = 0 then true + else odd (n - 1) +and odd n : int = + if n = 0 then false + else even (n - 1) +;; \ No newline at end of file From e573bcfb23175276bb16723208d4fe21ca032fa7 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 10 Nov 2024 13:09:17 +0300 Subject: [PATCH 103/310] fix: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 5 +- FSharpActivePatterns/lib/parser.ml | 107 ++++++++++++++------------- FSharpActivePatterns/lib/printAst.ml | 13 ++-- 3 files changed, 66 insertions(+), 59 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 37af2b3f3..628f1b3a6 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -63,7 +63,7 @@ type expr = | Function_def of expr list * expr (** fun x y -> x + y *) | Function_call of expr * expr (** [sum 1 ] *) | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) - | LetIn of is_recursive * ident option * expr list * expr * and_bind list * expr + | LetIn of is_recursive * ident option * expr list * expr * and_bind list * expr (** [let f x y = x + y in f 3 4 and g = f-x in f (g 10 5) 2] *) | Option of expr option (** [int option] *) [@@deriving eq, show { with_path = false }] @@ -71,7 +71,8 @@ type expr = and and_bind = And_bind of ident * expr list * expr (** [and sum n m = n+m] *) type statement = - | Let of is_recursive * ident * expr list * expr * and_bind list (** [let name = expr] *) + | Let of is_recursive * ident * expr list * expr * and_bind list + (** [let name = expr] *) | ActivePattern of ident list * expr (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *) [@@deriving eq, show { with_path = false }] diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 28a3c02ed..0c5813197 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -148,72 +148,77 @@ let p_if p_expr = <|> return None) ;; -let p_and p_expr = - skip_ws *> string "and" *> skip_ws_sep1 *> - lift3 - (fun name args body -> And_bind(name, args, body)) - p_ident - (many (skip_ws *> p_var)) - (skip_ws *> string "=" *> skip_ws *> p_expr) -;; -(* -let p_letin p_expr = +let p_and p_expr = skip_ws - *> string "let" + *> string "and" *> skip_ws_sep1 - *> lift4 - (fun rec_flag name args body and_list in_expr -> - LetIn (rec_flag, name, args, body, and_list, in_expr)) - (string "rec" *> return Rec <|> return Nonrec) - (p_ident >>= fun ident -> return (Some ident) <|> return None) + *> lift3 + (fun name args body -> And_bind (name, args, body)) + p_ident (many (skip_ws *> p_var)) (skip_ws *> string "=" *> skip_ws *> p_expr) - <*> skip_ws *> many (skip_ws *> p_and p_expr) - <*> skip_ws *> string "in" *> skip_ws_sep1 *> p_expr -;; *) +;; + +(* + let p_letin p_expr = + skip_ws + *> string "let" + *> skip_ws_sep1 + *> lift4 + (fun rec_flag name args body and_list in_expr -> + LetIn (rec_flag, name, args, body, and_list, in_expr)) + (string "rec" *> return Rec <|> return Nonrec) + (p_ident >>= fun ident -> return (Some ident) <|> return None) + (many (skip_ws *> p_var)) + (skip_ws *> string "=" *> skip_ws *> p_expr) + <*> skip_ws *> many (skip_ws *> p_and p_expr) + <*> skip_ws *> string "in" *> skip_ws_sep1 *> p_expr + ;; *) let p_letin p_expr = - skip_ws - *> string "let" - *> skip_ws_sep1 - *> (string "rec" *> return Rec <|> return Nonrec) + skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) >>= fun rec_flag -> - (p_ident >>= fun name -> return (Some name)) <|> return None >>= fun name_option -> - (skip_ws *> many (skip_ws *> p_var)) >>= fun args -> - (skip_ws *> string "=" *> skip_ws *> p_expr) >>= fun body -> - (skip_ws *> many (skip_ws *> p_and p_expr)) >>= fun and_list -> - skip_ws *> string "in" *> skip_ws_sep1 *> p_expr >>= fun in_expr -> - return (LetIn (rec_flag, name_option, args, body, and_list, in_expr)) + p_ident + >>= (fun name -> return (Some name)) + <|> return None + >>= fun name_option -> + skip_ws *> many (skip_ws *> p_var) + >>= fun args -> + skip_ws *> string "=" *> skip_ws *> p_expr + >>= fun body -> + skip_ws *> many (skip_ws *> p_and p_expr) + >>= fun and_list -> + skip_ws *> string "in" *> skip_ws_sep1 *> p_expr + >>= fun in_expr -> return (LetIn (rec_flag, name_option, args, body, and_list, in_expr)) ;; (* -let p_let p_expr = - skip_ws - *> string "let" - *> skip_ws_sep1 - *> lift4 - (fun rec_flag name args body and_list -> Let (rec_flag, name, args, body, and_list)) - (string "rec" *> return Rec <|> return Nonrec) - p_ident - (skip_ws *> many (skip_ws *> p_var)) - (skip_ws *> string "=" *> p_expr) - <*> skip_ws *> many (skip_ws *> p_and p_expr) -;; *) + let p_let p_expr = + skip_ws + *> string "let" + *> skip_ws_sep1 + *> lift4 + (fun rec_flag name args body and_list -> Let (rec_flag, name, args, body, and_list)) + (string "rec" *> return Rec <|> return Nonrec) + p_ident + (skip_ws *> many (skip_ws *> p_var)) + (skip_ws *> string "=" *> p_expr) + <*> skip_ws *> many (skip_ws *> p_and p_expr) + ;; *) let p_let p_expr = - skip_ws - *> string "let" - *> skip_ws_sep1 - *> (string "rec" *> return Rec <|> return Nonrec) + skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) >>= fun rec_flag -> - p_ident >>= fun name -> - (skip_ws *> many (skip_ws *> p_var)) >>= fun args -> - (skip_ws *> string "=" *> skip_ws *> p_expr) >>= fun body -> - (skip_ws *> many (skip_ws *> p_and p_expr)) >>= fun and_list -> - return (Let (rec_flag, name, args, body, and_list)) + p_ident + >>= fun name -> + skip_ws *> many (skip_ws *> p_var) + >>= fun args -> + skip_ws *> string "=" *> skip_ws *> p_expr + >>= fun body -> + skip_ws *> many (skip_ws *> p_and p_expr) + >>= fun and_list -> return (Let (rec_flag, name, args, body, and_list)) ;; - let app_first expr = skip_ws *> fix (fun a_exp -> diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index c0e15fdc9..2389a9779 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -136,7 +136,7 @@ let rec print_expr indent expr = List.iter (print_expr (indent + 2)) args; printf "= "; print_expr (indent + 2) body; - List.iter (print_and) and_list; + List.iter print_and and_list; printf "in\n"; print_expr (indent + 2) in_expr; printf "\n" @@ -146,12 +146,13 @@ let rec print_expr indent expr = | Some expr -> printf "Some "; print_expr (indent + 2) expr) -and print_and (And_bind(Ident(name, var_type), args, body)) = - printf "\nand "; + +and print_and (And_bind (Ident (name, var_type), args, body)) = + printf "\nand "; printf "%s " name; (match var_type with - | None -> () - | Some str -> printf ": %s " str); + | None -> () + | Some str -> printf ": %s " str); List.iter (fun arg -> print_expr 0 arg) args; printf "= "; print_expr 6 body @@ -171,7 +172,7 @@ let print_statement indent = function List.iter (print_expr (indent + 2)) args; printf "= "; print_expr (indent + 2) body; - List.iter (print_and) and_list + List.iter print_and and_list | ActivePattern (patterns, expr) -> printf "%s| ActivePattern:\n" (String.make indent '-'); List.iter From e7168f85d5d306ac62ffd0bcc9f175aed87fc5ac Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 10 Nov 2024 14:29:21 +0300 Subject: [PATCH 104/310] fix: add \n to printer Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/printAst.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 2389a9779..be7b7e887 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -134,7 +134,7 @@ let rec print_expr indent expr = | Some str -> printf ": %s " str) | None -> printf "()"); List.iter (print_expr (indent + 2)) args; - printf "= "; + printf "=\n"; print_expr (indent + 2) body; List.iter print_and and_list; printf "in\n"; @@ -154,7 +154,7 @@ and print_and (And_bind (Ident (name, var_type), args, body)) = | None -> () | Some str -> printf ": %s " str); List.iter (fun arg -> print_expr 0 arg) args; - printf "= "; + printf "=\n"; print_expr 6 body ;; @@ -170,7 +170,7 @@ let print_statement indent = function | None -> () | Some str -> printf ": %s " str); List.iter (print_expr (indent + 2)) args; - printf "= "; + printf "=\n"; print_expr (indent + 2) body; List.iter print_and and_list | ActivePattern (patterns, expr) -> From 11eb66b678056d0619384000542f8f05d878fcb0 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 11 Nov 2024 15:25:11 +0300 Subject: [PATCH 105/310] feat: implement lists parser Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 3 ++- FSharpActivePatterns/lib/parser.ml | 34 +++++++++++++++++++++++++++- FSharpActivePatterns/lib/printAst.ml | 22 +++++++++++++++--- 3 files changed, 54 insertions(+), 5 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 628f1b3a6..83f001b07 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -52,7 +52,8 @@ type is_recursive = type expr = | Const of literal (** [Int], [Bool], [String], [Unit], [Null] *) | Tuple of expr * expr * expr list (** [(1, "Hello world", true)] *) - | List_expr of expr * expr + | Empty_list (** [] *) + | Cons_list of expr * expr (** {[ [ 1; 2; 3 ] ]} *) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 0c5813197..4539f422e 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -35,6 +35,10 @@ let chainl1 e op = e >>= go ;; +let rec chainr1 e op = + e >>= fun rest -> op >>= (fun f -> chainr1 e op >>| f rest) <|> return rest +;; + let rec unary_chain op e = op >>= (fun unexpr -> unary_chain op e >>= fun expr -> return (unexpr expr)) <|> e ;; @@ -96,6 +100,33 @@ let p_ident = let p_var = p_ident >>| fun ident -> Variable ident +(* +let make_list expr1 expr2 = Cons_list (expr1, expr2) + +let cons p_expr = + skip_ws *> string "::" *> skip_ws *> + lift2 (fun expr1 expr2 -> Cons_list (expr1, expr2)) p_expr p_expr +;; +*) + +let p_empty_list = skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws >>= fun _ -> return Empty_list + +let make_list expr1 expr2 = Cons_list (expr1, expr2) + +let p_cons_list p_expr = chainr1 (p_expr <|> p_empty_list) (skip_ws *> string "::" *> skip_ws *> return make_list) +;; + +let p_semicolon_list p_expr = + skip_ws *> string "[" *> skip_ws *> + fix (fun p_cons_list -> + (p_expr <* skip_ws <* string "]" >>| fun expr -> Cons_list(expr, Empty_list)) <|> + (p_expr <* skip_ws <* string ";" >>= fun expr -> p_cons_list >>= fun rest -> return (Cons_list(expr, rest))) <|> + (string "]" *> skip_ws >>= fun _ -> return Empty_list) + ) +;; + +let p_list p_expr = p_semicolon_list p_expr <|> p_cons_list p_expr + (* EXPR PARSERS *) let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' let make_binexpr op expr1 expr2 = Bin_expr (op, expr1, expr2) [@@inline always] @@ -245,7 +276,8 @@ let p_expr = skip_ws *> fix (fun p_expr -> let atom = choice [ p_var; p_int; p_bool; p_parens p_expr ] in - let tuple = p_tuple atom <|> atom in + let list = p_list atom <|> atom in + let tuple = p_tuple list <|> list in let if_expr = p_if (p_expr <|> tuple) <|> tuple in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in let apply = p_apply (p_expr <|> letin_expr) <|> letin_expr in diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index be7b7e887..6ef49d903 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -64,10 +64,15 @@ let rec print_expr indent expr = | Const (Bool_lt b) -> printf "%b " b | Const (String_lt s) -> printf "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') - | List_expr (expr1, expr2) -> - printf "%s| List expr:\n" (String.make indent '-'); + | Empty_list -> print_list indent Empty_list + | Cons_list (expr1, expr2) -> + printf "["; print_expr (indent + 2) expr1; - print_expr (indent + 2) expr2 + if expr2 <> Empty_list then begin + printf "; "; + print_list indent expr2 + end; + printf "]" | Tuple (fst, snd, tail) -> printf "("; print_expr (indent + 2) fst; @@ -156,6 +161,17 @@ and print_and (And_bind (Ident (name, var_type), args, body)) = List.iter (fun arg -> print_expr 0 arg) args; printf "=\n"; print_expr 6 body + +and print_list indent = function + | Empty_list -> + printf "[]" + | Cons_list (head, Empty_list) -> + print_expr indent head + | Cons_list (head, tail) -> + print_expr indent head; + printf "; "; + print_list indent tail + | _ -> printf "" ;; let print_statement indent = function From e70a5e42451a201d9eb5cfcb9d79bb51f4fb2a40 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 11 Nov 2024 15:25:48 +0300 Subject: [PATCH 106/310] fix: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 38 ++++++++++++++++++---------- FSharpActivePatterns/lib/printAst.ml | 20 +++++++-------- 2 files changed, 33 insertions(+), 25 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 4539f422e..0022b0ff7 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -101,28 +101,38 @@ let p_ident = let p_var = p_ident >>| fun ident -> Variable ident (* -let make_list expr1 expr2 = Cons_list (expr1, expr2) + let make_list expr1 expr2 = Cons_list (expr1, expr2) -let cons p_expr = - skip_ws *> string "::" *> skip_ws *> - lift2 (fun expr1 expr2 -> Cons_list (expr1, expr2)) p_expr p_expr -;; + let cons p_expr = + skip_ws *> string "::" *> skip_ws *> + lift2 (fun expr1 expr2 -> Cons_list (expr1, expr2)) p_expr p_expr + ;; *) -let p_empty_list = skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws >>= fun _ -> return Empty_list +let p_empty_list = + skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws >>= fun _ -> return Empty_list +;; let make_list expr1 expr2 = Cons_list (expr1, expr2) -let p_cons_list p_expr = chainr1 (p_expr <|> p_empty_list) (skip_ws *> string "::" *> skip_ws *> return make_list) +let p_cons_list p_expr = + chainr1 (p_expr <|> p_empty_list) (skip_ws *> string "::" *> skip_ws *> return make_list) ;; -let p_semicolon_list p_expr = - skip_ws *> string "[" *> skip_ws *> - fix (fun p_cons_list -> - (p_expr <* skip_ws <* string "]" >>| fun expr -> Cons_list(expr, Empty_list)) <|> - (p_expr <* skip_ws <* string ";" >>= fun expr -> p_cons_list >>= fun rest -> return (Cons_list(expr, rest))) <|> - (string "]" *> skip_ws >>= fun _ -> return Empty_list) - ) +let p_semicolon_list p_expr = + skip_ws + *> string "[" + *> skip_ws + *> fix (fun p_cons_list -> + p_expr + <* skip_ws + <* string "]" + >>| (fun expr -> Cons_list (expr, Empty_list)) + <|> (p_expr + <* skip_ws + <* string ";" + >>= fun expr -> p_cons_list >>= fun rest -> return (Cons_list (expr, rest))) + <|> (string "]" *> skip_ws >>= fun _ -> return Empty_list)) ;; let p_list p_expr = p_semicolon_list p_expr <|> p_cons_list p_expr diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 6ef49d903..d765179d4 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -68,11 +68,11 @@ let rec print_expr indent expr = | Cons_list (expr1, expr2) -> printf "["; print_expr (indent + 2) expr1; - if expr2 <> Empty_list then begin + if expr2 <> Empty_list + then ( printf "; "; - print_list indent expr2 - end; - printf "]" + print_list indent expr2); + printf "]" | Tuple (fst, snd, tail) -> printf "("; print_expr (indent + 2) fst; @@ -163,14 +163,12 @@ and print_and (And_bind (Ident (name, var_type), args, body)) = print_expr 6 body and print_list indent = function - | Empty_list -> - printf "[]" - | Cons_list (head, Empty_list) -> - print_expr indent head + | Empty_list -> printf "[]" + | Cons_list (head, Empty_list) -> print_expr indent head | Cons_list (head, tail) -> - print_expr indent head; - printf "; "; - print_list indent tail + print_expr indent head; + printf "; "; + print_list indent tail | _ -> printf "" ;; From b315f9b6c1fa9568a193ac8a7d63297975776ff6 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 9 Nov 2024 23:19:51 +0300 Subject: [PATCH 107/310] feat: implemented basic qcheck Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 13 +- FSharpActivePatterns/dune-project | 2 +- FSharpActivePatterns/lib/printAst.ml | 252 +++++------------- FSharpActivePatterns/lib/printAst.mli | 4 +- FSharpActivePatterns/lib/tests/dune | 12 +- .../lib/tests/gen_construction.ml | 140 ++++++++++ .../lib/tests/run_construction.ml | 32 +++ FSharpActivePatterns/tests/dune | 4 +- FSharpActivePatterns/tests/qcheck.t | 2 + 9 files changed, 260 insertions(+), 201 deletions(-) create mode 100644 FSharpActivePatterns/lib/tests/gen_construction.ml create mode 100644 FSharpActivePatterns/lib/tests/run_construction.ml create mode 100644 FSharpActivePatterns/tests/qcheck.t diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 09e97008f..ad178c8e4 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -3,6 +3,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open FSharpActivePatterns.PrintAst +open FSharpActivePatterns.Ast open FSharpActivePatterns.Parser open Stdlib @@ -60,18 +61,20 @@ let run_repl dump_parsetree input_file = | Some n -> open_in n in let rec run_repl_helper run = + let open Format in match run ic with - | Fail -> Stdlib.Format.eprintf "Error occured\n" + | Fail -> fprintf err_formatter "Error occured\n" | Empty -> - Printf.printf "\n"; - flush stdout; + fprintf std_formatter "\n"; + print_flush (); run_repl_helper run | End -> () | Result ast -> if dump_parsetree then ( - print_construction ast; - flush stdout); + fprintf std_formatter "- : "; + print_construction std_formatter ast; + print_flush ()); run_repl_helper run in run_repl_helper run_single diff --git a/FSharpActivePatterns/dune-project b/FSharpActivePatterns/dune-project index 8c017dc56..e6c652b3f 100644 --- a/FSharpActivePatterns/dune-project +++ b/FSharpActivePatterns/dune-project @@ -30,4 +30,4 @@ bisect_ppx (odoc :with-doc) (ocamlformat :build) - )) \ No newline at end of file + )) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index d765179d4..3eb94fd38 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -5,206 +5,84 @@ open Ast open Printf -let print_bin_op indent = function - | Binary_equal -> printf "= " - | Binary_unequal -> printf "<> " - | Binary_less -> printf "< " - | Binary_less_or_equal -> printf "<= " - | Binary_greater -> printf "> " - | Binary_greater_or_equal -> printf ">= " - | Binary_add -> printf "+ " - | Binary_subtract -> printf "- " - | Binary_multiply -> printf "* " - | Logical_or -> printf "|| " - | Logical_and -> printf "&& " - | Binary_divide -> printf "/ " - | Binary_or_bitwise -> printf "%s| Binary Or Bitwise\n" (String.make indent '-') - | Binary_xor_bitwise -> printf "%s| Binary Xor Bitwise\n" (String.make indent '-') - | Binary_and_bitwise -> printf "%s| Binary And Bitwise\n" (String.make indent '-') +let print_bin_op fmt = + let open Format in + function + | Binary_equal -> fprintf fmt "= " + | Binary_unequal -> fprintf fmt "<> " + | Binary_less -> fprintf fmt "< " + | Binary_less_or_equal -> fprintf fmt "<= " + | Binary_greater -> fprintf fmt "> " + | Binary_greater_or_equal -> fprintf fmt ">= " + | Binary_add -> fprintf fmt "+ " + | Binary_subtract -> fprintf fmt "- " + | Binary_multiply -> fprintf fmt "* " + | Logical_or -> fprintf fmt "|| " + | Logical_and -> fprintf fmt "&& " + | Binary_divide -> fprintf fmt "/ " + | Binary_or_bitwise -> fprintf fmt "||| " + | Binary_xor_bitwise -> fprintf fmt "^^^ " + | Binary_and_bitwise -> fprintf fmt "&&& " ;; -let rec print_pattern indent = function - | Wild -> printf "%s| Wild\n" (String.make indent '-') - | PCons (head, tail) -> - printf "%s| PCons:\n" (String.make indent '-'); - printf "%sHead:\n" (String.make (indent + 2) '-'); - print_pattern (indent + 4) head; - printf "%sTail:\n" (String.make (indent + 2) '-'); - print_pattern (indent + 4) tail - | PTuple tuple -> - printf "%s| PTuple:\n" (String.make indent '-'); - List.iter (print_pattern (indent + 2)) tuple - | PConst literal -> - printf "%s| PConst:\n" (String.make indent '-'); - (match literal with - | Int_lt i -> printf "%sInt: %d\n" (String.make (indent + 2) '-') i - | Bool_lt b -> printf "%sBool: %b\n" (String.make (indent + 2) '-') b - | String_lt s -> printf "%sString: %S\n" (String.make (indent + 2) '-') s - | Unit_lt -> printf "%sUnit\n" (String.make (indent + 2) '-')) - | PVar (Ident (name, var_type)) -> - printf "%s " name; - (match var_type with - | None -> printf "" - | Some str -> printf ": %s " str) - | Variant variants -> - printf "%s| Variant:\n" (String.make indent '-'); - List.iter - (fun (Ident (v, _)) -> printf "%s- %s\n" (String.make (indent + 2) '-') v) - variants +let print_unary_op fmt = + let open Format in + function + | Unary_minus -> fprintf fmt "-" + | Unary_not -> fprintf fmt "not " ;; -let print_unary_op = function - | Unary_minus -> printf "-" - | Unary_not -> printf "not " -;; +let rec print_pattern fmt = + let open Format in + function + | Wild -> fprintf fmt "_ " + | PCons (hd, tl) -> fprintf fmt "%a :: %a" print_pattern hd print_pattern tl + | PTuple tuple -> fprintf fmt "TUPLE PAT WIP" + | PConst literal -> fprintf fmt "%a" print_expr (Const literal) + | PVar (Ident name) -> fprintf fmt "%s " name + | Variant variants -> fprintf fmt "VARIANTS PAT WIP" -let rec print_expr indent expr = +and print_expr fmt expr = + let open Format in match expr with - | Const (Int_lt i) -> printf "%d " i - | Const (Bool_lt b) -> printf "%b " b - | Const (String_lt s) -> printf "%s| Const(String: %S)\n" (String.make indent '-') s - | Const Unit_lt -> printf "%s| Const(Unit)\n" (String.make indent '-') - | Empty_list -> print_list indent Empty_list - | Cons_list (expr1, expr2) -> - printf "["; - print_expr (indent + 2) expr1; - if expr2 <> Empty_list - then ( - printf "; "; - print_list indent expr2); - printf "]" - | Tuple (fst, snd, tail) -> - printf "("; - print_expr (indent + 2) fst; - printf ", "; - print_expr (indent + 2) snd; - List.iter - (fun e -> - printf ", "; - print_expr indent e) - tail; - printf ") " - | Match (value, patterns) -> - printf "%s| Match:\n" (String.make indent '-'); - print_expr (indent + 2) value; - List.iter - (fun (pat, expr) -> - printf "%s| Pattern:\n" (String.make (indent + 2) '-'); - print_pattern (indent + 4) pat; - printf "%s| Inner expr:\n" (String.make (indent + 2) '-'); - print_expr (indent + 4) expr) - patterns - | Variable (Ident (name, var_type)) -> - printf "%s " name; - (match var_type with - | None -> printf "" - | Some str -> printf ": %s " str) - | Unary_expr (op, expr) -> - print_unary_op op; - print_expr (indent + 2) expr + | Const (Int_lt i) -> fprintf fmt "%d " i + | Const (Bool_lt b) -> fprintf fmt "%b " b + | Const (String_lt s) -> fprintf fmt "%S " s + | Const Unit_lt -> fprintf fmt "() " + | List_expr (expr1, expr2) -> fprintf fmt "[%a; %a]" print_expr expr1 print_expr expr2 + | Tuple t -> fprintf fmt "TUPLE WIP" + | Match (value, patterns) -> fprintf fmt "MATCH WIP" + | Variable (Ident name) -> fprintf fmt "%s " name + | Unary_expr (op, expr) -> fprintf fmt "%a %a" print_unary_op op print_expr expr | Bin_expr (op, left, right) -> - print_expr (indent + 2) left; - print_bin_op indent op; - print_expr (indent + 2) right + fprintf fmt "%a %a %a" print_expr left print_bin_op op print_expr right | If_then_else (cond, then_body, else_body) -> - printf "if "; - print_expr (indent + 2) cond; - printf "then "; - print_expr (indent + 4) then_body; + let begin_if = asprintf "if %a then %a " print_expr cond print_expr then_body in (match else_body with - | Some body -> - printf "else "; - print_expr (indent + 4) body - | None -> printf ";\n") - | Function_def (args, body) -> - printf "%s| Func:\n" (String.make indent '-'); - printf "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4)) args; - printf "%sBODY\n" (String.make (indent + 2) ' '); - print_expr (indent + 4) body - | Function_call (func, arg) -> - print_expr (indent + 2) func; - print_expr (indent + 2) arg - | LetIn (rec_flag, name, args, body, and_list, in_expr) -> - printf - "let %s " - (match rec_flag with - | Nonrec -> "" - | Rec -> "rec"); - (match name with - | Some (Ident (name, var_type)) -> - printf "%s " name; - (match var_type with - | None -> () - | Some str -> printf ": %s " str) - | None -> printf "()"); - List.iter (print_expr (indent + 2)) args; - printf "=\n"; - print_expr (indent + 2) body; - List.iter print_and and_list; - printf "in\n"; - print_expr (indent + 2) in_expr; - printf "\n" - | Option expr -> - (match expr with - | None -> printf "None " - | Some expr -> - printf "Some "; - print_expr (indent + 2) expr) - -and print_and (And_bind (Ident (name, var_type), args, body)) = - printf "\nand "; - printf "%s " name; - (match var_type with - | None -> () - | Some str -> printf ": %s " str); - List.iter (fun arg -> print_expr 0 arg) args; - printf "=\n"; - print_expr 6 body - -and print_list indent = function - | Empty_list -> printf "[]" - | Cons_list (head, Empty_list) -> print_expr indent head - | Cons_list (head, tail) -> - print_expr indent head; - printf "; "; - print_list indent tail - | _ -> printf "" + | Some body -> fprintf fmt "%s else %a" begin_if print_expr body + | None -> fprintf fmt "%s" begin_if) + | Function_def (args, body) -> fprintf fmt "func TODO" + | Function_call (func, arg) -> fprintf fmt "func_appl TODO" + | LetIn (rec_flag, name, args, body, in_expr) -> fprintf fmt "LetIn TODO" ;; -let print_statement indent = function - | Let (rec_flag, Ident (name, var_type), args, body, and_list) -> - printf - "let %s " - (match rec_flag with - | Nonrec -> "" - | Rec -> "rec"); - printf "%s " name; - (match var_type with - | None -> () - | Some str -> printf ": %s " str); - List.iter (print_expr (indent + 2)) args; - printf "=\n"; - print_expr (indent + 2) body; - List.iter print_and and_list - | ActivePattern (patterns, expr) -> - printf "%s| ActivePattern:\n" (String.make indent '-'); - List.iter - (fun (Ident (param, _)) -> printf "%s- %s\n" (String.make (indent + 2) '-') param) - patterns; - print_expr (indent + 2) expr +let print_statement fmt = + let open Format in + function + | Let (rec_flag, Ident name, args, body) -> fprintf fmt "Let TODO" + | ActivePattern (patterns, expr) -> fprintf fmt "Active pattern TODO" ;; -let print_construction = function - | Expr e -> - print_expr 0 e; - printf ";;\n" - | Statement s -> - print_statement 0 s; - printf ";;\n" +let print_construction fmt = + let open Format in + function + | Expr e -> fprintf fmt "%a\n" print_expr e + | Statement s -> fprintf fmt "%a\n" print_statement s ;; -let print_p_res = function - | Some expr -> print_construction expr - | None -> Printf.printf "Error occured" +let print_p_res fmt = + let open Format in + function + | Some c -> print_construction fmt c + | None -> fprintf fmt "Error occured\n" ;; diff --git a/FSharpActivePatterns/lib/printAst.mli b/FSharpActivePatterns/lib/printAst.mli index 43681ddfb..5cd53f883 100644 --- a/FSharpActivePatterns/lib/printAst.mli +++ b/FSharpActivePatterns/lib/printAst.mli @@ -4,5 +4,5 @@ open Ast -val print_construction : construction -> unit -val print_p_res : construction option -> unit +val print_construction : Format.formatter -> construction -> unit +val print_p_res : Format.formatter -> construction option -> unit diff --git a/FSharpActivePatterns/lib/tests/dune b/FSharpActivePatterns/lib/tests/dune index 734ae264e..2266adf2f 100644 --- a/FSharpActivePatterns/lib/tests/dune +++ b/FSharpActivePatterns/lib/tests/dune @@ -1,9 +1,13 @@ (library (name tests) - (modules Print_ast Parser) - (libraries FSharpActivePatterns) + (modules Print_ast Parser Gen_construction) + (libraries FSharpActivePatterns qcheck) (preprocess (pps ppx_expect ppx_deriving.show)) (instrumentation - (backend bisect_ppx)) - (inline_tests)) + (backend bisect_ppx))) + +(executable + (name run_construction) + (modules run_construction) + (libraries tests FSharpActivePatterns qcheck)) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml new file mode 100644 index 000000000..817802d28 --- /dev/null +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -0,0 +1,140 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +[@@@ocaml.text "/*"] + +open QCheck +open FSharpActivePatterns.Ast +open FSharpActivePatterns.PrintAst +open FSharpActivePatterns.Parser + +let int_e x = Const (Int_lt x) +let bool_e x = Const (Bool_lt x) +let unit_e = Const Unit_lt +let string_e x = Const (String_lt x) + +let gen_const = + QCheck.Gen.( + frequency + [ 1, map int_e nat; 1, map bool_e bool; 1, return unit_e; 0, map string_e string ]) +;; + +let variable_e x = Variable (Ident x) + +let gen_variable_name = + let open QCheck.Gen in + let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in + let gen_first_char = + oneof [ gen_char_of_range 'a' 'z'; gen_char_of_range 'A' 'Z'; return '_' ] + in + let gen_next_char = oneof [ gen_first_char; gen_char_of_range '0' '9' ] in + let gen_varname = + map2 + (fun first rest -> + String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) + gen_first_char + (list_size (1 -- 5) gen_next_char) + in + map variable_e gen_varname +;; + +let tuple_e l = Tuple l +let un_e unop e = Unary_expr (unop, e) +let gen_unop = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) +let bin_e op e1 e2 = Bin_expr (op, e1, e2) + +let gen_binop = + QCheck.Gen.( + oneof + @@ List.map + return + [ Binary_equal + ; Binary_unequal + ; Binary_less + ; Binary_less_or_equal + ; Binary_greater + ; Binary_greater_or_equal + ; Binary_add + ; Binary_subtract + ; Binary_multiply + ; Logical_or + ; Logical_and + ; Binary_divide + (* ; Binary_or_bitwise + ; Binary_xor_bitwise + ; Binary_and_bitwise *) + ]) +;; + +let gen_expr = + QCheck.Gen.( + sized + @@ fix (fun self n -> + match n with + | 0 -> frequency [ 1, gen_const; 1, gen_variable_name ] + | n -> + frequency + [ 0, map tuple_e (list_size (0 -- 15) (self (n / 2))) + ; 0, map2 un_e gen_unop (self (n / 2)) + ; 1, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) + ])) +;; + +let shrink_lt = + let open QCheck.Iter in + function + | Int_lt x -> QCheck.Shrink.int x >|= int_e + | Bool_lt _ -> empty + | Unit_lt -> empty + | String_lt x -> QCheck.Shrink.string x >|= string_e +;; + +let rec shrink_expr = + let open QCheck.Iter in + function + | Const lt -> shrink_lt lt + | Variable _ -> empty + | Tuple t -> QCheck.Shrink.list ~shrink:shrink_expr t >|= fun a' -> Tuple a' + | Unary_expr (op, e) -> return e <+> shrink_expr e >|= fun a' -> un_e op a' + | Bin_expr (op, e1, e2) -> + of_list [ e1; e2 ] + <+> (shrink_expr e1 >|= fun a' -> bin_e op a' e2) + <+> (shrink_expr e2 >|= fun a' -> bin_e op e1 a') + | _ -> empty +;; + +(* TODO *) +let rec shrink_statement = + let open QCheck.Iter in + function + | Let (rec_flag, ident, args, expr) -> + shrink_expr expr >|= fun a' -> Let (rec_flag, ident, args, a') + | _ -> empty +;; + +let gen_construction = QCheck.Gen.map (fun e -> Expr e) gen_expr + +let shrink_construction = + let open QCheck.Iter in + function + | Expr e -> shrink_expr e >|= fun a' -> Expr a' + | Statement s -> shrink_statement s >|= fun a' -> Statement a' +;; + +let arbitrary_construction = + QCheck.make + gen_construction + ~print:(Format.asprintf "%a" print_construction) + ~shrink:shrink_construction +;; + +let run n = + QCheck_runner.run_tests + [ QCheck.( + Test.make arbitrary_construction ~count:n (fun c -> + Some c = parse (Format.asprintf "%a\n" print_construction c))) + ] +;; diff --git a/FSharpActivePatterns/lib/tests/run_construction.ml b/FSharpActivePatterns/lib/tests/run_construction.ml new file mode 100644 index 000000000..b006b38ef --- /dev/null +++ b/FSharpActivePatterns/lib/tests/run_construction.ml @@ -0,0 +1,32 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +[@@@ocaml.text "/*"] + +open FSharpActivePatterns.PrintAst +open Tests.Gen_construction +open FSharpActivePatterns.Ast + +(* let generate n = + List.iter + Format.(fprintf std_formatter "%a\n" print_construction) + (QCheck.Gen.generate ~n gen_construction) + ;; *) + +let run_tests n = + let _ = run n in + () +;; + +let () = + Arg.parse + [ "-seed", Arg.Int QCheck_runner.set_seed, " Set seed" + ; "-stop", Arg.Unit (fun _ -> exit 0), " Exit" + ; "-gen", Arg.Int run_tests, " Number of runs" + ] + (fun _ -> assert false) + "help" +;; diff --git a/FSharpActivePatterns/tests/dune b/FSharpActivePatterns/tests/dune index 7a37b28ce..8696c8f8d 100644 --- a/FSharpActivePatterns/tests/dune +++ b/FSharpActivePatterns/tests/dune @@ -1,3 +1,3 @@ (cram - (applies_to print_ast) - (deps ../bin/main.exe)) + (applies_to qcheck) + (deps ../lib/tests/run_construction.exe)) diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t new file mode 100644 index 000000000..1225bae11 --- /dev/null +++ b/FSharpActivePatterns/tests/qcheck.t @@ -0,0 +1,2 @@ + $ ../lib/tests/run_construction.exe -seed 0 -gen 1 -stop + From f55b73f5a4286368adbac775fed6c16c8756434f Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 9 Nov 2024 23:20:28 +0300 Subject: [PATCH 108/310] tests: commented old tests Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/parser.ml | 4 ++-- FSharpActivePatterns/lib/tests/print_ast.ml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index f783ee20e..bd96c2b26 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -1,4 +1,4 @@ -(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) +(* * Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov (** SPDX-License-Identifier: LGPL-3.0-or-later *) @@ -299,4 +299,4 @@ let%expect_test "call if with parentheses" = ------| Variable(b) ARGS --| Variable(c) |}] -;; +;; *) diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml index f3e9142b3..784108b17 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/print_ast.ml @@ -1,4 +1,4 @@ -(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) +(* * Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov (** SPDX-License-Identifier: LGPL-3.0-or-later *) @@ -256,4 +256,4 @@ let%expect_test "print Ast of match_expr" = --------| PVar(xs) --| Inner expr: ----| Const(Int: 4) |}] -;; +;; *) From a5d68bed91b5cf64f55981add82f32a5fb60c3c7 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 9 Nov 2024 23:42:41 +0300 Subject: [PATCH 109/310] fix: fix bin_expr printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/printAst.ml | 2 +- FSharpActivePatterns/tests/qcheck.t | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index 3eb94fd38..f294a9283 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -55,7 +55,7 @@ and print_expr fmt expr = | Variable (Ident name) -> fprintf fmt "%s " name | Unary_expr (op, expr) -> fprintf fmt "%a %a" print_unary_op op print_expr expr | Bin_expr (op, left, right) -> - fprintf fmt "%a %a %a" print_expr left print_bin_op op print_expr right + fprintf fmt "(%a) %a (%a)" print_expr left print_bin_op op print_expr right | If_then_else (cond, then_body, else_body) -> let begin_if = asprintf "if %a then %a " print_expr cond print_expr then_body in (match else_body with diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 1225bae11..c318f9363 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,2 +1,2 @@ - $ ../lib/tests/run_construction.exe -seed 0 -gen 1 -stop + $ ../lib/tests/run_construction.exe -seed 1 -gen 2 -stop From a90612a6879fb2a80a387cf2d4de2dacd4e8d31b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 10 Nov 2024 02:12:02 +0300 Subject: [PATCH 110/310] feat: implemented ITE and LetIn qcheck Signed-off-by: Gleb Nasretdinov --- .../lib/tests/gen_construction.ml | 52 ++++++++++++++----- 1 file changed, 39 insertions(+), 13 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 817802d28..50353373e 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -15,36 +15,37 @@ let int_e x = Const (Int_lt x) let bool_e x = Const (Bool_lt x) let unit_e = Const Unit_lt let string_e x = Const (String_lt x) +let variable_e x = Variable (Ident x) let gen_const = QCheck.Gen.( frequency - [ 1, map int_e nat; 1, map bool_e bool; 1, return unit_e; 0, map string_e string ]) + [ 1, map int_e nat; 1, map bool_e bool; 0, return unit_e; 0, map string_e string ]) ;; -let variable_e x = Variable (Ident x) - -let gen_variable_name = +let gen_varname = let open QCheck.Gen in let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in let gen_first_char = oneof [ gen_char_of_range 'a' 'z'; gen_char_of_range 'A' 'Z'; return '_' ] in let gen_next_char = oneof [ gen_first_char; gen_char_of_range '0' '9' ] in - let gen_varname = - map2 - (fun first rest -> - String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) - gen_first_char - (list_size (1 -- 5) gen_next_char) - in - map variable_e gen_varname + map2 + (fun first rest -> + String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) + gen_first_char + (list_size (1 -- 5) gen_next_char) ;; +let gen_variable = QCheck.Gen.map variable_e gen_varname +let gen_ident = QCheck.Gen.map (fun s -> Ident s) gen_varname let tuple_e l = Tuple l let un_e unop e = Unary_expr (unop, e) let gen_unop = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) let bin_e op e1 e2 = Bin_expr (op, e1, e2) +let if_e i t e = If_then_else (i, t, e) +let func_def args body = Function_def (args, body) +let letin rec_flag ident args e inner_e = LetIn (rec_flag, ident, args, e, inner_e) let gen_binop = QCheck.Gen.( @@ -74,12 +75,27 @@ let gen_expr = sized @@ fix (fun self n -> match n with - | 0 -> frequency [ 1, gen_const; 1, gen_variable_name ] + | 0 -> frequency [ 1, gen_const; 1, gen_variable ] | n -> frequency [ 0, map tuple_e (list_size (0 -- 15) (self (n / 2))) ; 0, map2 un_e gen_unop (self (n / 2)) ; 1, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) + ; ( 1 + , map3 + if_e + (self (n / 2)) + (self (n / 2)) + (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) + ; 1, map2 func_def (list gen_variable) (self (n / 2)) + ; ( 1 + , map3 + letin + (oneof [ return Rec; return Nonrec ]) + (map (fun i -> Some i) gen_ident) + (list gen_variable) + <*> self (n / 2) + <*> self (n / 2) ) ])) ;; @@ -103,6 +119,16 @@ let rec shrink_expr = of_list [ e1; e2 ] <+> (shrink_expr e1 >|= fun a' -> bin_e op a' e2) <+> (shrink_expr e2 >|= fun a' -> bin_e op e1 a') + | If_then_else (i, t, Some _) -> return (If_then_else (i, t, None)) + | If_then_else (i, t, None) -> + shrink_expr i + >|= (fun a' -> If_then_else (a', t, None)) + <+> (shrink_expr t >|= fun a' -> If_then_else (i, a', None)) + | LetIn (rec_flag, ident, args, e, inner_e) -> + QCheck.Shrink.list ~shrink:shrink_expr args + >|= (fun a' -> LetIn (rec_flag, ident, a', e, inner_e)) + <+> (shrink_expr e >|= fun a' -> LetIn (rec_flag, ident, args, a', inner_e)) + <+> (shrink_expr inner_e >|= fun a' -> LetIn (rec_flag, ident, args, e, a')) | _ -> empty ;; From f993741b551f03c2e74d646b2fa9451cb4bf28cd Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 10 Nov 2024 05:09:16 +0300 Subject: [PATCH 111/310] feat: implement some pretty_printer exprs, fix variable generator Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.mli | 1 + FSharpActivePatterns/lib/printAst.ml | 37 +++++++++++++++---- .../lib/tests/gen_construction.ml | 25 +++++++------ FSharpActivePatterns/tests/qcheck.t | 2 +- 4 files changed, 46 insertions(+), 19 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.mli b/FSharpActivePatterns/lib/parser.mli index 19a074986..6e162ef4b 100644 --- a/FSharpActivePatterns/lib/parser.mli +++ b/FSharpActivePatterns/lib/parser.mli @@ -5,3 +5,4 @@ open Ast val parse : string -> construction option +val is_keyword : string -> bool diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml index f294a9283..4a2039ec7 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/printAst.ml @@ -32,6 +32,13 @@ let print_unary_op fmt = | Unary_not -> fprintf fmt "not " ;; +let print_rec_flag fmt = + let open Format in + function + | Rec -> fprintf fmt "rec" + | Nonrec -> () +;; + let rec print_pattern fmt = let open Format in function @@ -57,19 +64,35 @@ and print_expr fmt expr = | Bin_expr (op, left, right) -> fprintf fmt "(%a) %a (%a)" print_expr left print_bin_op op print_expr right | If_then_else (cond, then_body, else_body) -> - let begin_if = asprintf "if %a then %a " print_expr cond print_expr then_body in + fprintf fmt "if %a then %a " print_expr cond print_expr then_body; (match else_body with - | Some body -> fprintf fmt "%s else %a" begin_if print_expr body - | None -> fprintf fmt "%s" begin_if) - | Function_def (args, body) -> fprintf fmt "func TODO" - | Function_call (func, arg) -> fprintf fmt "func_appl TODO" - | LetIn (rec_flag, name, args, body, in_expr) -> fprintf fmt "LetIn TODO" + | Some body -> fprintf fmt "else %a " print_expr body + | None -> ()) + | Function_def (args, body) -> + fprintf fmt "fun "; + print_args fmt args; + fprintf fmt "-> %a " print_expr body + | Function_call (func, arg) -> fprintf fmt "%a %a" print_expr func print_expr arg + | LetIn (rec_flag, name, args, body, in_expr) -> + (fprintf fmt "let %a " print_rec_flag rec_flag; + match name with + | Some (Ident ident) -> fprintf fmt "%s " ident + | None -> ()); + print_args fmt args; + fprintf fmt "= %a in %a " print_expr body print_expr in_expr + +and print_args fmt args = + let open Format in + pp_print_list ~pp_sep:pp_print_space print_expr fmt args ;; let print_statement fmt = let open Format in function - | Let (rec_flag, Ident name, args, body) -> fprintf fmt "Let TODO" + | Let (rec_flag, Ident ident, args, body) -> + fprintf fmt "let %a %s " print_rec_flag rec_flag ident; + print_args fmt args; + fprintf fmt "= %a " print_expr body | ActivePattern (patterns, expr) -> fprintf fmt "Active pattern TODO" ;; diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 50353373e..cc3cb358e 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -25,16 +25,19 @@ let gen_const = let gen_varname = let open QCheck.Gen in - let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in - let gen_first_char = - oneof [ gen_char_of_range 'a' 'z'; gen_char_of_range 'A' 'Z'; return '_' ] + let rec loop = + let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in + let gen_first_char = + oneof [ gen_char_of_range 'a' 'z'; gen_char_of_range 'A' 'Z'; return '_' ] + in + let gen_next_char = oneof [ gen_first_char; gen_char_of_range '0' '9' ] in + map2 + (fun first rest -> + String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) + gen_first_char + (list_size (1 -- 5) gen_next_char) in - let gen_next_char = oneof [ gen_first_char; gen_char_of_range '0' '9' ] in - map2 - (fun first rest -> - String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) - gen_first_char - (list_size (1 -- 5) gen_next_char) + loop >>= fun name -> if is_keyword name then loop else return name ;; let gen_variable = QCheck.Gen.map variable_e gen_varname @@ -81,13 +84,13 @@ let gen_expr = [ 0, map tuple_e (list_size (0 -- 15) (self (n / 2))) ; 0, map2 un_e gen_unop (self (n / 2)) ; 1, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) - ; ( 1 + ; ( 0 , map3 if_e (self (n / 2)) (self (n / 2)) (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) - ; 1, map2 func_def (list gen_variable) (self (n / 2)) + ; 0, map2 func_def (list gen_variable) (self (n / 2)) ; ( 1 , map3 letin diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index c318f9363..174fb8104 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,2 +1,2 @@ - $ ../lib/tests/run_construction.exe -seed 1 -gen 2 -stop + $ ../lib/tests/run_construction.exe -seed 1 -gen 5 -stop From a3455fd586296257a49396f3615ca83e884ccdeb Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 05:17:32 +0300 Subject: [PATCH 112/310] feat: split AstPrinter and PrettyPrinter, change REPL behaviour Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 15 +- FSharpActivePatterns/lib/astPrinter.ml | 159 ++++++++++++++++++ .../lib/{printAst.mli => astPrinter.mli} | 5 +- FSharpActivePatterns/lib/dune | 2 +- .../lib/{printAst.ml => prettyPrinter.ml} | 74 ++++---- FSharpActivePatterns/lib/prettyPrinter.mli | 9 + .../tests/{print_ast.ml => ast_printer.ml} | 19 ++- FSharpActivePatterns/lib/tests/dune | 2 +- .../lib/tests/gen_construction.ml | 14 +- FSharpActivePatterns/lib/tests/parser.ml | 35 ++-- .../lib/tests/run_construction.ml | 2 - 11 files changed, 246 insertions(+), 90 deletions(-) create mode 100644 FSharpActivePatterns/lib/astPrinter.ml rename FSharpActivePatterns/lib/{printAst.mli => astPrinter.mli} (57%) rename FSharpActivePatterns/lib/{printAst.ml => prettyPrinter.ml} (54%) create mode 100644 FSharpActivePatterns/lib/prettyPrinter.mli rename FSharpActivePatterns/lib/tests/{print_ast.ml => ast_printer.ml} (92%) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index ad178c8e4..9f9e5870d 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -2,9 +2,9 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open FSharpActivePatterns.PrintAst -open FSharpActivePatterns.Ast +open FSharpActivePatterns.AstPrinter open FSharpActivePatterns.Parser +open FSharpActivePatterns.PrettyPrinter open Stdlib type input = @@ -70,11 +70,12 @@ let run_repl dump_parsetree input_file = run_repl_helper run | End -> () | Result ast -> - if dump_parsetree - then ( - fprintf std_formatter "- : "; - print_construction std_formatter ast; - print_flush ()); + (match dump_parsetree with + | true -> print_construction std_formatter ast + | false -> + fprintf std_formatter "- : "; + pp_construction std_formatter ast); + print_flush (); run_repl_helper run in run_repl_helper run_single diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml new file mode 100644 index 000000000..dd768fa97 --- /dev/null +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -0,0 +1,159 @@ +open Ast +open Format + +let print_bin_op indent fmt = function + | Binary_equal -> fprintf fmt "%s| Binary Equal\n" (String.make indent '-') + | Binary_unequal -> fprintf fmt "%s| Binary Unequal\n" (String.make indent '-') + | Binary_less -> fprintf fmt "%s| Binary Less\n" (String.make indent '-') + | Binary_less_or_equal -> + fprintf fmt "%s| Binary Less Or Equal\n" (String.make indent '-') + | Binary_greater -> fprintf fmt "%s| Binary Greater\n" (String.make indent '-') + | Binary_greater_or_equal -> + fprintf fmt "%s| Binary Greater Or Equal\n" (String.make indent '-') + | Binary_add -> fprintf fmt "%s| Binary Add\n" (String.make indent '-') + | Binary_subtract -> fprintf fmt "%s| Binary Subtract\n" (String.make indent '-') + | Binary_multiply -> fprintf fmt "%s| Binary Multiply\n" (String.make indent '-') + | Logical_or -> fprintf fmt "%s| Logical Or\n" (String.make indent '-') + | Logical_and -> fprintf fmt "%s| Logical And\n" (String.make indent '-') + | Binary_divide -> fprintf fmt "%s| Binary Divide\n" (String.make indent '-') + | Binary_or_bitwise -> fprintf fmt "%s| Binary Or Bitwise\n" (String.make indent '-') + | Binary_xor_bitwise -> fprintf fmt "%s| Binary Xor Bitwise\n" (String.make indent '-') + | Binary_and_bitwise -> fprintf fmt "%s| Binary And Bitwise\n" (String.make indent '-') +;; + +let rec print_pattern indent fmt = function + | Wild -> fprintf fmt "%s| Wild\n" (String.make indent '-') + | PCons (head, tail) -> + fprintf fmt "%s| PCons:\n" (String.make indent '-'); + fprintf fmt "%sHead:\n" (String.make (indent + 2) '-'); + print_pattern (indent + 4) fmt head; + fprintf fmt "%sTail:\n" (String.make (indent + 2) '-'); + print_pattern (indent + 4) fmt tail + | PTuple tuple -> + fprintf fmt "%s| PTuple:\n" (String.make indent '-'); + List.iter (print_pattern (indent + 2) fmt) tuple + | PConst literal -> + fprintf fmt "%s| PConst:\n" (String.make indent '-'); + (match literal with + | Int_lt i -> fprintf fmt "%sInt: %d\n" (String.make (indent + 2) '-') i + | Bool_lt b -> fprintf fmt "%sBool: %b\n" (String.make (indent + 2) '-') b + | String_lt s -> fprintf fmt "%sString: %S\n" (String.make (indent + 2) '-') s + | Unit_lt -> fprintf fmt "%sUnit\n" (String.make (indent + 2) '-')) + | PVar (Ident name) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name + | Variant variants -> + fprintf fmt "%s| Variant:\n" (String.make indent '-'); + List.iter + (fun (Ident v) -> fprintf fmt "%s- %s\n" (String.make (indent + 2) '-') v) + variants +;; + +let print_unary_op indent fmt = function + | Unary_minus -> fprintf fmt "%s| Unary minus\n" (String.make indent '-') + | Unary_not -> fprintf fmt "%s| Unary negative\n" (String.make indent '-') +;; + +let rec print_expr indent fmt expr = + match expr with + | Const (Int_lt i) -> fprintf fmt "%s| Const(Int: %d)\n" (String.make indent '-') i + | Const (Bool_lt b) -> fprintf fmt "%s| Const(Bool: %b)\n" (String.make indent '-') b + | Const (String_lt s) -> + fprintf fmt "%s| Const(String: %S)\n" (String.make indent '-') s + | Const Unit_lt -> fprintf fmt "%s| Const(Unit)\n" (String.make indent '-') + | List_expr (expr1, expr2) -> + fprintf fmt "%s| List expr:\n" (String.make indent '-'); + print_expr (indent + 2) fmt expr1; + print_expr (indent + 2) fmt expr2 + | Tuple t -> List.iter (print_expr indent fmt) t + | Match (value, patterns) -> + fprintf fmt "%s| Match:\n" (String.make indent '-'); + print_expr (indent + 2) fmt value; + List.iter + (fun (pat, expr) -> + fprintf fmt "%s| Pattern:\n" (String.make (indent + 2) '-'); + print_pattern (indent + 4) fmt pat; + fprintf fmt "%s| Inner expr:\n" (String.make (indent + 2) '-'); + print_expr (indent + 4) fmt expr) + patterns + | Variable (Ident name) -> + fprintf fmt "%s| Variable(%s)\n" (String.make indent '-') name + | Unary_expr (op, expr) -> + fprintf fmt "%s| Unary expr(\n" (String.make indent '-'); + print_unary_op indent fmt op; + print_expr (indent + 2) fmt expr + | Bin_expr (op, left, right) -> + fprintf fmt "%s| Binary expr(\n" (String.make indent '-'); + print_bin_op indent fmt op; + print_expr (indent + 2) fmt left; + print_expr (indent + 2) fmt right + | If_then_else (cond, then_body, else_body) -> + fprintf fmt "%s| If Then Else(\n" (String.make indent '-'); + fprintf fmt "%sCONDITION\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) fmt cond; + fprintf fmt "%sTHEN BRANCH\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) fmt then_body; + fprintf fmt "%sELSE BRANCH\n" (String.make (indent + 2) ' '); + (match else_body with + | Some body -> print_expr (indent + 2) fmt body + | None -> fprintf fmt "%s| No else body\n" (String.make (indent + 2) '-')) + | Function_def (args, body) -> + fprintf fmt "%s| Func:\n" (String.make indent '-'); + fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 4) fmt) args; + fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); + print_expr (indent + 4) fmt body + | Function_call (func, arg) -> + fprintf fmt "%s| Function Call:\n" (String.make indent '-'); + fprintf fmt "%sFUNCTION\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) fmt func; + fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) fmt arg + | LetIn (rec_flag, name, args, body, in_expr) -> + fprintf + fmt + "%s | LetIn %s %s =\n" + (String.make indent '-') + (match rec_flag with + | Nonrec -> "" + | Rec -> "Rec") + (match name with + | Some (Ident n) -> n + | None -> "Anonymous"); + fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 2) fmt) args; + fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) fmt body; + fprintf fmt "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) fmt in_expr +;; + +let print_statement indent fmt = function + | Let (rec_flag, Ident name, args, body) -> + fprintf + fmt + "%s | Let %s %s =\n" + (String.make indent '-') + (match rec_flag with + | Nonrec -> "" + | Rec -> "Rec") + name; + fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); + List.iter (print_expr (indent + 2) fmt) args; + fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) fmt body + | ActivePattern (patterns, expr) -> + fprintf fmt "%s| ActivePattern:\n" (String.make indent '-'); + List.iter + (fun (Ident param) -> fprintf fmt "%s- %s\n" (String.make (indent + 2) '-') param) + patterns; + print_expr (indent + 2) fmt expr +;; + +let print_construction fmt = function + | Expr e -> print_expr 0 fmt e + | Statement s -> print_statement 0 fmt s +;; + +let print_p_res fmt = function + | Some expr -> print_construction fmt expr + | None -> fprintf fmt "Error occured" +;; diff --git a/FSharpActivePatterns/lib/printAst.mli b/FSharpActivePatterns/lib/astPrinter.mli similarity index 57% rename from FSharpActivePatterns/lib/printAst.mli rename to FSharpActivePatterns/lib/astPrinter.mli index 5cd53f883..db17ee820 100644 --- a/FSharpActivePatterns/lib/printAst.mli +++ b/FSharpActivePatterns/lib/astPrinter.mli @@ -3,6 +3,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open Ast +open Format -val print_construction : Format.formatter -> construction -> unit -val print_p_res : Format.formatter -> construction option -> unit +val print_construction : formatter -> construction -> unit +val print_p_res : formatter -> construction option -> unit diff --git a/FSharpActivePatterns/lib/dune b/FSharpActivePatterns/lib/dune index 44620ab63..44a441777 100644 --- a/FSharpActivePatterns/lib/dune +++ b/FSharpActivePatterns/lib/dune @@ -1,7 +1,7 @@ (library (name FSharpActivePatterns) (public_name FSharpActivePatterns) - (modules Ast PrintAst Parser) + (modules Ast Parser AstPrinter PrettyPrinter) (modules_without_implementation ast) (libraries angstrom base) (preprocess diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/prettyPrinter.ml similarity index 54% rename from FSharpActivePatterns/lib/printAst.ml rename to FSharpActivePatterns/lib/prettyPrinter.ml index 4a2039ec7..21a0091cc 100644 --- a/FSharpActivePatterns/lib/printAst.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -4,10 +4,9 @@ open Ast open Printf +open Format -let print_bin_op fmt = - let open Format in - function +let pp_bin_op fmt = function | Binary_equal -> fprintf fmt "= " | Binary_unequal -> fprintf fmt "<> " | Binary_less -> fprintf fmt "< " @@ -25,87 +24,74 @@ let print_bin_op fmt = | Binary_and_bitwise -> fprintf fmt "&&& " ;; -let print_unary_op fmt = - let open Format in - function +let pp_unary_op fmt = function | Unary_minus -> fprintf fmt "-" | Unary_not -> fprintf fmt "not " ;; -let print_rec_flag fmt = - let open Format in - function +let pp_rec_flag fmt = function | Rec -> fprintf fmt "rec" | Nonrec -> () ;; -let rec print_pattern fmt = - let open Format in - function +let rec pp_pattern fmt = function | Wild -> fprintf fmt "_ " - | PCons (hd, tl) -> fprintf fmt "%a :: %a" print_pattern hd print_pattern tl + | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl | PTuple tuple -> fprintf fmt "TUPLE PAT WIP" - | PConst literal -> fprintf fmt "%a" print_expr (Const literal) + | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) | PVar (Ident name) -> fprintf fmt "%s " name | Variant variants -> fprintf fmt "VARIANTS PAT WIP" -and print_expr fmt expr = - let open Format in +and pp_expr fmt expr = match expr with | Const (Int_lt i) -> fprintf fmt "%d " i | Const (Bool_lt b) -> fprintf fmt "%b " b | Const (String_lt s) -> fprintf fmt "%S " s | Const Unit_lt -> fprintf fmt "() " - | List_expr (expr1, expr2) -> fprintf fmt "[%a; %a]" print_expr expr1 print_expr expr2 + | List_expr (expr1, expr2) -> fprintf fmt "[%a; %a]" pp_expr expr1 pp_expr expr2 | Tuple t -> fprintf fmt "TUPLE WIP" | Match (value, patterns) -> fprintf fmt "MATCH WIP" | Variable (Ident name) -> fprintf fmt "%s " name - | Unary_expr (op, expr) -> fprintf fmt "%a %a" print_unary_op op print_expr expr + | Unary_expr (op, expr) -> fprintf fmt "%a %a" pp_unary_op op pp_expr expr | Bin_expr (op, left, right) -> - fprintf fmt "(%a) %a (%a)" print_expr left print_bin_op op print_expr right + fprintf fmt "(%a) %a (%a)" pp_expr left pp_bin_op op pp_expr right | If_then_else (cond, then_body, else_body) -> - fprintf fmt "if %a then %a " print_expr cond print_expr then_body; + fprintf fmt "if %a then %a " pp_expr cond pp_expr then_body; (match else_body with - | Some body -> fprintf fmt "else %a " print_expr body + | Some body -> fprintf fmt "else %a " pp_expr body | None -> ()) | Function_def (args, body) -> fprintf fmt "fun "; - print_args fmt args; - fprintf fmt "-> %a " print_expr body - | Function_call (func, arg) -> fprintf fmt "%a %a" print_expr func print_expr arg + pp_args fmt args; + fprintf fmt "-> %a " pp_expr body + | Function_call (func, arg) -> fprintf fmt "%a %a" pp_expr func pp_expr arg | LetIn (rec_flag, name, args, body, in_expr) -> - (fprintf fmt "let %a " print_rec_flag rec_flag; + (fprintf fmt "let %a " pp_rec_flag rec_flag; match name with | Some (Ident ident) -> fprintf fmt "%s " ident | None -> ()); - print_args fmt args; - fprintf fmt "= %a in %a " print_expr body print_expr in_expr + pp_args fmt args; + fprintf fmt "= %a in %a " pp_expr body pp_expr in_expr -and print_args fmt args = +and pp_args fmt args = let open Format in - pp_print_list ~pp_sep:pp_print_space print_expr fmt args + pp_print_list ~pp_sep:pp_print_space pp_expr fmt args ;; -let print_statement fmt = - let open Format in - function +let pp_statement fmt = function | Let (rec_flag, Ident ident, args, body) -> - fprintf fmt "let %a %s " print_rec_flag rec_flag ident; - print_args fmt args; - fprintf fmt "= %a " print_expr body + fprintf fmt "let %a %s " pp_rec_flag rec_flag ident; + pp_args fmt args; + fprintf fmt "= %a " pp_expr body | ActivePattern (patterns, expr) -> fprintf fmt "Active pattern TODO" ;; -let print_construction fmt = - let open Format in - function - | Expr e -> fprintf fmt "%a\n" print_expr e - | Statement s -> fprintf fmt "%a\n" print_statement s +let pp_construction fmt = function + | Expr e -> fprintf fmt "%a\n" pp_expr e + | Statement s -> fprintf fmt "%a\n" pp_statement s ;; -let print_p_res fmt = - let open Format in - function - | Some c -> print_construction fmt c +let pp_p_res fmt = function + | Some c -> pp_construction fmt c | None -> fprintf fmt "Error occured\n" ;; diff --git a/FSharpActivePatterns/lib/prettyPrinter.mli b/FSharpActivePatterns/lib/prettyPrinter.mli new file mode 100644 index 000000000..428b94b3d --- /dev/null +++ b/FSharpActivePatterns/lib/prettyPrinter.mli @@ -0,0 +1,9 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast +open Format + +val pp_construction : formatter -> construction -> unit +val pp_p_res : formatter -> construction option -> unit diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml similarity index 92% rename from FSharpActivePatterns/lib/tests/print_ast.ml rename to FSharpActivePatterns/lib/tests/ast_printer.ml index 784108b17..8a04af8e9 100644 --- a/FSharpActivePatterns/lib/tests/print_ast.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -1,9 +1,10 @@ -(* * Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) open FSharpActivePatterns.Ast -open FSharpActivePatterns.PrintAst +open FSharpActivePatterns.AstPrinter +open Format let%expect_test "print Ast factorial" = let factorial = @@ -31,7 +32,7 @@ let%expect_test "print Ast factorial" = ; Expr (Function_call (factorial, Variable (Ident ("a", None)))) ] in - List.iter print_construction program; + List.iter (print_construction std_formatter) program; [%expect {| | Let a = @@ -109,7 +110,7 @@ let%expect_test "print Ast double func" = let args = [ var ] in let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), var) in let double = Function_def (args, binary_expr) in - print_construction @@ Expr double; + print_construction std_formatter @@ Expr double; [%expect {| | Func: @@ -140,7 +141,7 @@ let%expect_test "print Ast tuple of binary operators" = ] in let print_binary_constr operator = - print_construction @@ Expr (Bin_expr (operator, first, second)) + print_construction std_formatter @@ Expr (Bin_expr (operator, first, second)) in List.iter print_binary_constr operators; [%expect @@ -202,7 +203,7 @@ let%expect_test "print Ast of LetIn" = , [] , Bin_expr (Binary_add, Variable (Ident ("x", None)), Const (Int_lt 5)) )) in - print_construction sum; + print_construction std_formatter sum; [%expect {| | LetIn x = @@ -225,8 +226,8 @@ let%expect_test "print Ast of match_expr" = ] in let pattern_values = List.map (fun p -> p, Const (Int_lt 4)) patterns in - let match_expr = Match (Variable (Ident ("x", None)), pattern_values) in - print_construction (Expr match_expr); + let match_expr = Match (Variable (Ident "x"), pattern_values) in + print_construction std_formatter (Expr match_expr); [%expect {| | Match: @@ -256,4 +257,4 @@ let%expect_test "print Ast of match_expr" = --------| PVar(xs) --| Inner expr: ----| Const(Int: 4) |}] -;; *) +;; diff --git a/FSharpActivePatterns/lib/tests/dune b/FSharpActivePatterns/lib/tests/dune index 2266adf2f..00fbe152e 100644 --- a/FSharpActivePatterns/lib/tests/dune +++ b/FSharpActivePatterns/lib/tests/dune @@ -1,6 +1,6 @@ (library (name tests) - (modules Print_ast Parser Gen_construction) + (modules Ast_printer Parser Gen_construction) (libraries FSharpActivePatterns qcheck) (preprocess (pps ppx_expect ppx_deriving.show)) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index cc3cb358e..54455b642 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -6,10 +6,10 @@ [@@@ocaml.text "/*"] -open QCheck open FSharpActivePatterns.Ast -open FSharpActivePatterns.PrintAst +open FSharpActivePatterns.AstPrinter open FSharpActivePatterns.Parser +open FSharpActivePatterns.PrettyPrinter let int_e x = Const (Int_lt x) let bool_e x = Const (Bool_lt x) @@ -25,7 +25,7 @@ let gen_const = let gen_varname = let open QCheck.Gen in - let rec loop = + let loop = let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in let gen_first_char = oneof [ gen_char_of_range 'a' 'z'; gen_char_of_range 'A' 'Z'; return '_' ] @@ -84,14 +84,14 @@ let gen_expr = [ 0, map tuple_e (list_size (0 -- 15) (self (n / 2))) ; 0, map2 un_e gen_unop (self (n / 2)) ; 1, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) - ; ( 0 + ; ( 1 , map3 if_e (self (n / 2)) (self (n / 2)) (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) ; 0, map2 func_def (list gen_variable) (self (n / 2)) - ; ( 1 + ; ( 0 , map3 letin (oneof [ return Rec; return Nonrec ]) @@ -136,7 +136,7 @@ let rec shrink_expr = ;; (* TODO *) -let rec shrink_statement = +let shrink_statement = let open QCheck.Iter in function | Let (rec_flag, ident, args, expr) -> @@ -164,6 +164,6 @@ let run n = QCheck_runner.run_tests [ QCheck.( Test.make arbitrary_construction ~count:n (fun c -> - Some c = parse (Format.asprintf "%a\n" print_construction c))) + Some c = parse (Format.asprintf "%a\n" pp_construction c))) ] ;; diff --git a/FSharpActivePatterns/lib/tests/parser.ml b/FSharpActivePatterns/lib/tests/parser.ml index bd96c2b26..412412fed 100644 --- a/FSharpActivePatterns/lib/tests/parser.ml +++ b/FSharpActivePatterns/lib/tests/parser.ml @@ -1,13 +1,14 @@ -(* * Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) (** SPDX-License-Identifier: LGPL-3.0-or-later *) open FSharpActivePatterns.Parser -open FSharpActivePatterns.PrintAst +open FSharpActivePatterns.AstPrinter +open Format let%expect_test "binary subtract" = let input = {| a - 3|} in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | Binary expr( @@ -18,7 +19,7 @@ let%expect_test "binary subtract" = let%expect_test "function apply of letIn" = let input = {| f let x = false in true || x|} in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | Function Call: @@ -38,7 +39,7 @@ let%expect_test "function apply of letIn" = let%expect_test "arithmetic with unary operations and variables" = let input = {| - a - - b + 4|} in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | Binary expr( @@ -56,7 +57,7 @@ let%expect_test "arithmetic with unary operations and variables" = let%expect_test "sum of function applying" = let input = {| f 4 + g 3|} in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | Binary expr( @@ -75,7 +76,7 @@ let%expect_test "sum of function applying" = let%expect_test "order of logical expressions and function applying" = let input = {| let x = true in not x || true && f 12|} in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | LetIn x = @@ -100,7 +101,7 @@ let%expect_test "order of logical expressions and function applying" = let%expect_test "parse logical expression" = let input = {| (3 + 5) >= 8 || true && (5 <> 4) |} in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | Binary expr( @@ -123,7 +124,7 @@ let%expect_test "parse logical expression" = let%expect_test "parse integer expression" = let input = " (3 + 5) - (12 / 7)" in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | Binary expr( @@ -141,7 +142,7 @@ let%expect_test "parse integer expression" = let%expect_test "parse_unary_chain" = let input = "not not ( not true && false || 3 > 5)" in let result = parse input in - print_p_res result; + print_p_res std_formatter result; [%expect {| | Unary expr( @@ -164,7 +165,7 @@ let%expect_test "parse_unary_chain" = let%expect_test "parse if with comparison" = let input = "if 3 > 2 && false then 5 + 7 else 12" in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | If Then Else( @@ -187,7 +188,7 @@ let%expect_test "parse if with comparison" = let%expect_test "sum with if" = let input = "a + if 3 > 2 then 2 else 1" in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | Binary expr( @@ -209,7 +210,7 @@ let%expect_test "inner expressions with LetIn and If" = let input = "if let x = true in let y = false in x || y then 3 else if 5 > 3 then 2 else 1" in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | If Then Else( @@ -245,7 +246,7 @@ let%expect_test "inner expressions with LetIn and If" = let%expect_test "factorial" = let input = "let factorial n = if n = 0 then 1 else factorial (n - 1) in factorial b" in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | LetIn factorial = @@ -279,13 +280,13 @@ let%expect_test "factorial" = let%expect_test "fail in ITE with incorrect else expression" = let input = "if true then 1 else 2c" in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| Error occured |}] ;; let%expect_test "call if with parentheses" = let input = "(if(false)then(a) else(b))c" in - print_p_res (parse input); + print_p_res std_formatter (parse input); [%expect {| | Function Call: @@ -299,4 +300,4 @@ let%expect_test "call if with parentheses" = ------| Variable(b) ARGS --| Variable(c) |}] -;; *) +;; diff --git a/FSharpActivePatterns/lib/tests/run_construction.ml b/FSharpActivePatterns/lib/tests/run_construction.ml index b006b38ef..6d2f112de 100644 --- a/FSharpActivePatterns/lib/tests/run_construction.ml +++ b/FSharpActivePatterns/lib/tests/run_construction.ml @@ -6,9 +6,7 @@ [@@@ocaml.text "/*"] -open FSharpActivePatterns.PrintAst open Tests.Gen_construction -open FSharpActivePatterns.Ast (* let generate n = List.iter From 8726f4f0d01ef43f7059c82688fa50b708650dc0 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 05:24:26 +0300 Subject: [PATCH 113/310] fix: parentheses in ITE pretty_printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/prettyPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 21a0091cc..bdb4e3d27 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -56,7 +56,7 @@ and pp_expr fmt expr = | Bin_expr (op, left, right) -> fprintf fmt "(%a) %a (%a)" pp_expr left pp_bin_op op pp_expr right | If_then_else (cond, then_body, else_body) -> - fprintf fmt "if %a then %a " pp_expr cond pp_expr then_body; + fprintf fmt "if (%a) then (%a) " pp_expr cond pp_expr then_body; (match else_body with | Some body -> fprintf fmt "else %a " pp_expr body | None -> ()) From 576607fc6ccae4318bc8ad5a8619b3a7aa6e13cd Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 05:45:51 +0300 Subject: [PATCH 114/310] fix: unary expression pretty_printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/prettyPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index bdb4e3d27..5215e96a7 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -52,7 +52,7 @@ and pp_expr fmt expr = | Tuple t -> fprintf fmt "TUPLE WIP" | Match (value, patterns) -> fprintf fmt "MATCH WIP" | Variable (Ident name) -> fprintf fmt "%s " name - | Unary_expr (op, expr) -> fprintf fmt "%a %a" pp_unary_op op pp_expr expr + | Unary_expr (op, expr) -> fprintf fmt "%a (%a)" pp_unary_op op pp_expr expr | Bin_expr (op, left, right) -> fprintf fmt "(%a) %a (%a)" pp_expr left pp_bin_op op pp_expr right | If_then_else (cond, then_body, else_body) -> From 867dfd20d36316897b7646a1ed53b2afc1626bca Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 05:46:27 +0300 Subject: [PATCH 115/310] fix: tuple size in generator Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/gen_construction.ml | 6 +++--- FSharpActivePatterns/tests/qcheck.t | 3 +-- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 54455b642..232dfd802 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -81,8 +81,8 @@ let gen_expr = | 0 -> frequency [ 1, gen_const; 1, gen_variable ] | n -> frequency - [ 0, map tuple_e (list_size (0 -- 15) (self (n / 2))) - ; 0, map2 un_e gen_unop (self (n / 2)) + [ 0, map tuple_e (list_size (2 -- 15) (self (n / 2))) + ; 1, map2 un_e gen_unop (self (n / 2)) ; 1, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) ; ( 1 , map3 @@ -91,7 +91,7 @@ let gen_expr = (self (n / 2)) (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) ; 0, map2 func_def (list gen_variable) (self (n / 2)) - ; ( 0 + ; ( 1 , map3 letin (oneof [ return Rec; return Nonrec ]) diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 174fb8104..43d5868ab 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,2 +1 @@ - $ ../lib/tests/run_construction.exe -seed 1 -gen 5 -stop - + $ ../lib/tests/run_construction.exe -seed 1 -gen 30 -stop From ea7bfce0156c1f3cf68c82dc20e777e5bdd46579 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 06:18:04 +0300 Subject: [PATCH 116/310] feat: add Let to gen_construction Signed-off-by: Gleb Nasretdinov --- .../lib/tests/gen_construction.ml | 25 +++++++++++++++---- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 232dfd802..3da7eac7c 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -40,8 +40,8 @@ let gen_varname = loop >>= fun name -> if is_keyword name then loop else return name ;; -let gen_variable = QCheck.Gen.map variable_e gen_varname let gen_ident = QCheck.Gen.map (fun s -> Ident s) gen_varname +let gen_variable = QCheck.Gen.map variable_e gen_varname let tuple_e l = Tuple l let un_e unop e = Unary_expr (unop, e) let gen_unop = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) @@ -73,6 +73,8 @@ let gen_binop = ]) ;; +let gen_rec_flag = QCheck.Gen.(oneof [ return Rec; return Nonrec ]) + let gen_expr = QCheck.Gen.( sized @@ -94,7 +96,7 @@ let gen_expr = ; ( 1 , map3 letin - (oneof [ return Rec; return Nonrec ]) + gen_rec_flag (map (fun i -> Some i) gen_ident) (list gen_variable) <*> self (n / 2) @@ -135,16 +137,29 @@ let rec shrink_expr = | _ -> empty ;; -(* TODO *) +let let_st rec_flag ident args body = Let (rec_flag, ident, args, body) + +(* TODO: Active Pattern*) +let gen_statement = + QCheck.Gen.(map3 let_st gen_rec_flag gen_ident (list gen_variable) <*> gen_expr) +;; + +(* TODO: Active Pattern *) let shrink_statement = let open QCheck.Iter in function | Let (rec_flag, ident, args, expr) -> - shrink_expr expr >|= fun a' -> Let (rec_flag, ident, args, a') + shrink_expr expr + >|= (fun a' -> Let (rec_flag, ident, args, a')) + <+> (QCheck.Shrink.list ~shrink:shrink_expr args + >|= fun a' -> Let (rec_flag, ident, a', expr)) | _ -> empty ;; -let gen_construction = QCheck.Gen.map (fun e -> Expr e) gen_expr +let gen_construction = + QCheck.Gen.( + oneof [ (gen_expr >|= fun a' -> Expr a'); (gen_statement >|= fun a' -> Statement a') ]) +;; let shrink_construction = let open QCheck.Iter in From c2e5017ef2346b3a11c7d9b5607768d9b3be01da Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 16:29:24 +0300 Subject: [PATCH 117/310] feat: implement tuple pretty printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/prettyPrinter.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 5215e96a7..078ac796c 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -48,8 +48,11 @@ and pp_expr fmt expr = | Const (Bool_lt b) -> fprintf fmt "%b " b | Const (String_lt s) -> fprintf fmt "%S " s | Const Unit_lt -> fprintf fmt "() " - | List_expr (expr1, expr2) -> fprintf fmt "[%a; %a]" pp_expr expr1 pp_expr expr2 - | Tuple t -> fprintf fmt "TUPLE WIP" + | List_expr (expr1, expr2) -> fprintf fmt "LIST WIP" + | Tuple t -> + fprintf fmt "("; + pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt t; + fprintf fmt ")" | Match (value, patterns) -> fprintf fmt "MATCH WIP" | Variable (Ident name) -> fprintf fmt "%s " name | Unary_expr (op, expr) -> fprintf fmt "%a (%a)" pp_unary_op op pp_expr expr From ccfb454f3380aea46e7f72aa1d83dd39b24e37a2 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 16:49:37 +0300 Subject: [PATCH 118/310] feat: implement basic func_call generator Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/gen_construction.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 3da7eac7c..18360d32e 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -48,6 +48,7 @@ let gen_unop = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) let bin_e op e1 e2 = Bin_expr (op, e1, e2) let if_e i t e = If_then_else (i, t, e) let func_def args body = Function_def (args, body) +let func_call f arg = Function_call (f, arg) let letin rec_flag ident args e inner_e = LetIn (rec_flag, ident, args, e, inner_e) let gen_binop = @@ -93,6 +94,8 @@ let gen_expr = (self (n / 2)) (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) ; 0, map2 func_def (list gen_variable) (self (n / 2)) + ; 1, map2 func_call gen_variable (self (n / 2)) + (* TODO: make apply of arbitrary expr*) ; ( 1 , map3 letin From 055b1bbb44082464b78ddb67a14c7cc69be67aff Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 22:02:39 +0300 Subject: [PATCH 119/310] feat: change Let and LetIn AST Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.mli | 11 +-- FSharpActivePatterns/lib/astPrinter.ml | 75 +++++++++------ FSharpActivePatterns/lib/parser.ml | 27 +++--- FSharpActivePatterns/lib/prettyPrinter.ml | 57 +++++++---- FSharpActivePatterns/lib/tests/ast_printer.ml | 16 ++-- .../lib/tests/gen_construction.ml | 95 +++++++++++++------ 6 files changed, 178 insertions(+), 103 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 83f001b07..dfd68a64f 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -61,19 +61,18 @@ type expr = | Unary_expr of unary_operator * expr (** -x *) | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) - | Function_def of expr list * expr (** fun x y -> x + y *) + | Function_def of ident list * expr (** fun x y -> x + y *) | Function_call of expr * expr (** [sum 1 ] *) | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) - | LetIn of is_recursive * ident option * expr list * expr * and_bind list * expr - (** [let f x y = x + y in f 3 4 and g = f-x in f (g 10 5) 2] *) + | LetIn of is_recursive * let_bind * let_bind list * expr + (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) [@@deriving eq, show { with_path = false }] -and and_bind = And_bind of ident * expr list * expr (** [and sum n m = n+m] *) +and let_bind = Let_bind of ident * ident list * expr (** [and sum n m = n+m] *) type statement = - | Let of is_recursive * ident * expr list * expr * and_bind list - (** [let name = expr] *) + | Let of is_recursive * let_bind * let_bind list (** [let name = expr] *) | ActivePattern of ident list * expr (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *) [@@deriving eq, show { with_path = false }] diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index dd768fa97..dc50e1c8f 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -39,11 +39,11 @@ let rec print_pattern indent fmt = function | Bool_lt b -> fprintf fmt "%sBool: %b\n" (String.make (indent + 2) '-') b | String_lt s -> fprintf fmt "%sString: %S\n" (String.make (indent + 2) '-') s | Unit_lt -> fprintf fmt "%sUnit\n" (String.make (indent + 2) '-')) - | PVar (Ident name) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name + | PVar (Ident (name, _)) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name | Variant variants -> fprintf fmt "%s| Variant:\n" (String.make indent '-'); List.iter - (fun (Ident v) -> fprintf fmt "%s- %s\n" (String.make (indent + 2) '-') v) + (fun (Ident (v, _)) -> fprintf fmt "%s- %s\n" (String.make (indent + 2) '-') v) variants ;; @@ -52,18 +52,35 @@ let print_unary_op indent fmt = function | Unary_not -> fprintf fmt "%s| Unary negative\n" (String.make indent '-') ;; -let rec print_expr indent fmt expr = +let tag_of_ident = function + | Ident (s, _) -> s +;; + +let rec print_let_bind indent fmt = function + | Let_bind (name, args, body) -> + let name = tag_of_ident name in + let args = List.map tag_of_ident args in + fprintf fmt "%s| Let_bind:\n" (String.make indent '-'); + fprintf fmt "%sNAME:\n" (String.make (indent + 4) ' '); + fprintf fmt "%s| %s\n" (String.make (indent + 2) '-') name; + fprintf fmt "%sARGS:\n" (String.make (indent + 4) ' '); + List.iter (fun arg -> fprintf fmt "%s| %s\n" (String.make (indent + 2) '-') arg) args; + fprintf fmt "%sBODY:\n" (String.make (indent + 4) ' '); + print_expr (indent + 2) fmt body + +and print_expr indent fmt expr = match expr with | Const (Int_lt i) -> fprintf fmt "%s| Const(Int: %d)\n" (String.make indent '-') i | Const (Bool_lt b) -> fprintf fmt "%s| Const(Bool: %b)\n" (String.make indent '-') b | Const (String_lt s) -> fprintf fmt "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> fprintf fmt "%s| Const(Unit)\n" (String.make indent '-') - | List_expr (expr1, expr2) -> - fprintf fmt "%s| List expr:\n" (String.make indent '-'); + | Cons_list (expr1, expr2) -> + fprintf fmt "%s| Cons_list expr:\n" (String.make indent '-'); print_expr (indent + 2) fmt expr1; print_expr (indent + 2) fmt expr2 - | Tuple t -> List.iter (print_expr indent fmt) t + | Empty_list -> fprintf fmt "%s| Empty_list expr:\n" (String.make indent '-') + | Tuple (e1, e2, rest) -> List.iter (print_expr indent fmt) (e1 :: e2 :: rest) | Match (value, patterns) -> fprintf fmt "%s| Match:\n" (String.make indent '-'); print_expr (indent + 2) fmt value; @@ -74,7 +91,7 @@ let rec print_expr indent fmt expr = fprintf fmt "%s| Inner expr:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) fmt expr) patterns - | Variable (Ident name) -> + | Variable (Ident (name, _)) -> fprintf fmt "%s| Variable(%s)\n" (String.make indent '-') name | Unary_expr (op, expr) -> fprintf fmt "%s| Unary expr(\n" (String.make indent '-'); @@ -96,9 +113,10 @@ let rec print_expr indent fmt expr = | Some body -> print_expr (indent + 2) fmt body | None -> fprintf fmt "%s| No else body\n" (String.make (indent + 2) '-')) | Function_def (args, body) -> + let args = List.map tag_of_ident args in fprintf fmt "%s| Func:\n" (String.make indent '-'); fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 4) fmt) args; + List.iter (fun arg -> fprintf fmt "%s %s\n" (String.make (indent + 2) '-') arg) args; fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 4) fmt body | Function_call (func, arg) -> @@ -107,43 +125,42 @@ let rec print_expr indent fmt expr = print_expr (indent + 2) fmt func; fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); print_expr (indent + 2) fmt arg - | LetIn (rec_flag, name, args, body, in_expr) -> + | LetIn (rec_flag, let_bind, let_bind_list, inner_e) -> fprintf fmt - "%s | LetIn %s %s =\n" + "%s | %s LetIn=\n" (String.make indent '-') (match rec_flag with | Nonrec -> "" - | Rec -> "Rec") - (match name with - | Some (Ident n) -> n - | None -> "Anonymous"); - fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 2) fmt) args; - fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); - print_expr (indent + 2) fmt body; - fprintf fmt "%sINNER EXPRESSION\n" (String.make (indent + 2) ' '); - print_expr (indent + 2) fmt in_expr + | Rec -> "Rec"); + fprintf fmt "%sLet_binds\n" (String.make (indent + 2) ' '); + List.iter (print_let_bind (indent + 2) fmt) (let_bind :: let_bind_list); + fprintf fmt "%sINNER_EXPRESSION\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) fmt inner_e + | Option e -> + (match e with + | None -> fprintf fmt "%s| Option: None\n" (String.make indent '-') + | Some e -> + fprintf fmt "%s| Option: Some\n" (String.make indent '-'); + print_expr (indent + 2) fmt e) ;; let print_statement indent fmt = function - | Let (rec_flag, Ident name, args, body) -> + | Let (rec_flag, let_bind, let_bind_list) -> fprintf fmt - "%s | Let %s %s =\n" + "%s | %s Let=\n" (String.make indent '-') (match rec_flag with | Nonrec -> "" - | Rec -> "Rec") - name; - fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (print_expr (indent + 2) fmt) args; - fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); - print_expr (indent + 2) fmt body + | Rec -> "Rec"); + fprintf fmt "%sLet_binds\n" (String.make (indent + 2) ' '); + List.iter (print_let_bind (indent + 2) fmt) (let_bind :: let_bind_list) | ActivePattern (patterns, expr) -> fprintf fmt "%s| ActivePattern:\n" (String.make indent '-'); List.iter - (fun (Ident param) -> fprintf fmt "%s- %s\n" (String.make (indent + 2) '-') param) + (fun (Ident (param, _)) -> + fprintf fmt "%s- %s\n" (String.make (indent + 2) '-') param) patterns; print_expr (indent + 2) fmt expr ;; diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 0022b0ff7..ec2d7a640 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -189,14 +189,14 @@ let p_if p_expr = <|> return None) ;; -let p_and p_expr = +let p_let_bind p_expr = skip_ws *> string "and" *> skip_ws_sep1 *> lift3 - (fun name args body -> And_bind (name, args, body)) + (fun name args body -> Let_bind (name, args, body)) p_ident - (many (skip_ws *> p_var)) + (many (skip_ws *> p_ident)) (skip_ws *> string "=" *> skip_ws *> p_expr) ;; @@ -220,17 +220,17 @@ let p_letin p_expr = skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) >>= fun rec_flag -> p_ident - >>= (fun name -> return (Some name)) - <|> return None - >>= fun name_option -> - skip_ws *> many (skip_ws *> p_var) + >>= (fun name -> return name) + >>= fun name -> + skip_ws *> many (skip_ws *> p_ident) >>= fun args -> skip_ws *> string "=" *> skip_ws *> p_expr >>= fun body -> - skip_ws *> many (skip_ws *> p_and p_expr) - >>= fun and_list -> + skip_ws *> many (skip_ws *> p_let_bind p_expr) + >>= fun let_bind_list -> skip_ws *> string "in" *> skip_ws_sep1 *> p_expr - >>= fun in_expr -> return (LetIn (rec_flag, name_option, args, body, and_list, in_expr)) + >>= fun in_expr -> + return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) ;; (* @@ -252,12 +252,13 @@ let p_let p_expr = >>= fun rec_flag -> p_ident >>= fun name -> - skip_ws *> many (skip_ws *> p_var) + skip_ws *> many (skip_ws *> p_ident) >>= fun args -> skip_ws *> string "=" *> skip_ws *> p_expr >>= fun body -> - skip_ws *> many (skip_ws *> p_and p_expr) - >>= fun and_list -> return (Let (rec_flag, name, args, body, and_list)) + skip_ws *> many (skip_ws *> p_let_bind p_expr) + >>= fun let_bind_list -> + return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) ;; let app_first expr = diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 078ac796c..856b310b6 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -39,7 +39,7 @@ let rec pp_pattern fmt = function | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl | PTuple tuple -> fprintf fmt "TUPLE PAT WIP" | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) - | PVar (Ident name) -> fprintf fmt "%s " name + | PVar (Ident (name, _)) -> fprintf fmt "%s " name | Variant variants -> fprintf fmt "VARIANTS PAT WIP" and pp_expr fmt expr = @@ -48,13 +48,14 @@ and pp_expr fmt expr = | Const (Bool_lt b) -> fprintf fmt "%b " b | Const (String_lt s) -> fprintf fmt "%S " s | Const Unit_lt -> fprintf fmt "() " - | List_expr (expr1, expr2) -> fprintf fmt "LIST WIP" - | Tuple t -> + | Cons_list (hd, tl) -> fprintf fmt "LIST WIP" + | Empty_list -> fprintf fmt "[] " + | Tuple (e1, e2, rest) -> fprintf fmt "("; - pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt t; + pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); fprintf fmt ")" | Match (value, patterns) -> fprintf fmt "MATCH WIP" - | Variable (Ident name) -> fprintf fmt "%s " name + | Variable (Ident (name, _)) -> fprintf fmt "%s " name | Unary_expr (op, expr) -> fprintf fmt "%a (%a)" pp_unary_op op pp_expr expr | Bin_expr (op, left, right) -> fprintf fmt "(%a) %a (%a)" pp_expr left pp_bin_op op pp_expr right @@ -68,24 +69,46 @@ and pp_expr fmt expr = pp_args fmt args; fprintf fmt "-> %a " pp_expr body | Function_call (func, arg) -> fprintf fmt "%a %a" pp_expr func pp_expr arg - | LetIn (rec_flag, name, args, body, in_expr) -> - (fprintf fmt "let %a " pp_rec_flag rec_flag; - match name with - | Some (Ident ident) -> fprintf fmt "%s " ident - | None -> ()); - pp_args fmt args; - fprintf fmt "= %a in %a " pp_expr body pp_expr in_expr + | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> + fprintf fmt "let %a " pp_rec_flag rec_flag; + pp_let_bind fmt let_bind; + pp_print_list + ~pp_sep:(fun fmt () -> fprintf fmt "\n\nand ") + pp_let_bind + fmt + let_bind_list; + fprintf fmt "in\n"; + fprintf fmt "%a " pp_expr in_expr + | Option e -> + (match e with + | None -> fprintf fmt "None " + | Some e -> fprintf fmt "Some (%a)" pp_expr e) and pp_args fmt args = let open Format in - pp_print_list ~pp_sep:pp_print_space pp_expr fmt args + pp_print_list + ~pp_sep:pp_print_space + (fun fmt name -> fprintf fmt "%s" name) + fmt + (List.map + (function + | Ident (s, _) -> s) + args) + +and pp_let_bind fmt = function + | Let_bind (Ident (name, _), args, body) -> + fprintf fmt "%s %a = %a " name pp_args args pp_expr body ;; let pp_statement fmt = function - | Let (rec_flag, Ident ident, args, body) -> - fprintf fmt "let %a %s " pp_rec_flag rec_flag ident; - pp_args fmt args; - fprintf fmt "= %a " pp_expr body + | Let (rec_flag, let_bind, let_bind_list) -> + fprintf fmt "let %a " pp_rec_flag rec_flag; + pp_let_bind fmt let_bind; + pp_print_list + ~pp_sep:(fun fmt () -> fprintf fmt "\n\nand ") + pp_let_bind + fmt + let_bind_list | ActivePattern (patterns, expr) -> fprintf fmt "Active pattern TODO" ;; diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index 8a04af8e9..eca86459e 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -9,7 +9,7 @@ open Format let%expect_test "print Ast factorial" = let factorial = Function_def - ( [ Variable (Ident ("n", None)) ] + ( [ Ident ("n", None) ] , If_then_else ( Bin_expr ( Logical_or @@ -27,7 +27,7 @@ let%expect_test "print Ast factorial" = ) )) ) ) in let program = - [ Statement (Let (Nonrec, Ident ("a", None), [], Const (Int_lt 10), [])) + [ Statement (Let (Nonrec, Let_bind (Ident ("a", None), [], Const (Int_lt 10)), [])) ; Expr factorial ; Expr (Function_call (factorial, Variable (Ident ("a", None)))) ] @@ -106,9 +106,9 @@ let%expect_test "print Ast factorial" = ;; let%expect_test "print Ast double func" = - let var = Variable (Ident ("n", None)) in - let args = [ var ] in - let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), var) in + let ident = Ident ("n", None) in + let args = [ ident ] in + let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), Variable ident) in let double = Function_def (args, binary_expr) in print_construction std_formatter @@ Expr double; [%expect @@ -197,9 +197,7 @@ let%expect_test "print Ast of LetIn" = Expr (LetIn ( Nonrec - , Some (Ident ("x", None)) - , [] - , Const (Int_lt 5) + , Let_bind (Ident ("x", None), [], Const (Int_lt 5)) , [] , Bin_expr (Binary_add, Variable (Ident ("x", None)), Const (Int_lt 5)) )) in @@ -226,7 +224,7 @@ let%expect_test "print Ast of match_expr" = ] in let pattern_values = List.map (fun p -> p, Const (Int_lt 4)) patterns in - let match_expr = Match (Variable (Ident "x"), pattern_values) in + let match_expr = Match (Variable (Ident ("x", None)), pattern_values) in print_construction std_formatter (Expr match_expr); [%expect {| diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 18360d32e..d6bc96645 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -15,7 +15,7 @@ let int_e x = Const (Int_lt x) let bool_e x = Const (Bool_lt x) let unit_e = Const Unit_lt let string_e x = Const (String_lt x) -let variable_e x = Variable (Ident x) +let variable_e x = Variable (Ident (x, None)) let gen_const = QCheck.Gen.( @@ -40,16 +40,20 @@ let gen_varname = loop >>= fun name -> if is_keyword name then loop else return name ;; -let gen_ident = QCheck.Gen.map (fun s -> Ident s) gen_varname +let gen_ident = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname let gen_variable = QCheck.Gen.map variable_e gen_varname -let tuple_e l = Tuple l -let un_e unop e = Unary_expr (unop, e) let gen_unop = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) +let tuple_e e1 e2 rest = Tuple (e1, e2, rest) +let un_e unop e = Unary_expr (unop, e) let bin_e op e1 e2 = Bin_expr (op, e1, e2) let if_e i t e = If_then_else (i, t, e) let func_def args body = Function_def (args, body) let func_call f arg = Function_call (f, arg) -let letin rec_flag ident args e inner_e = LetIn (rec_flag, ident, args, e, inner_e) +let let_bind name args body = Let_bind (name, args, body) + +let letin rec_flag let_bind let_bind_list inner_e = + LetIn (rec_flag, let_bind, let_bind_list, inner_e) +;; let gen_binop = QCheck.Gen.( @@ -76,6 +80,10 @@ let gen_binop = let gen_rec_flag = QCheck.Gen.(oneof [ return Rec; return Nonrec ]) +let gen_let_bind gen = + QCheck.Gen.(map3 let_bind gen_ident (list_size (0 -- 15) gen_ident) gen) +;; + let gen_expr = QCheck.Gen.( sized @@ -84,25 +92,29 @@ let gen_expr = | 0 -> frequency [ 1, gen_const; 1, gen_variable ] | n -> frequency - [ 0, map tuple_e (list_size (2 -- 15) (self (n / 2))) - ; 1, map2 un_e gen_unop (self (n / 2)) - ; 1, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) + [ ( 0 + , map3 + tuple_e + (self (n / 2)) + (self (n / 2)) + (list_size (0 -- 15) (self (n / 2))) ) + ; 0, map2 un_e gen_unop (self (n / 2)) + ; 0, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) ; ( 1 , map3 if_e (self (n / 2)) (self (n / 2)) (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) - ; 0, map2 func_def (list gen_variable) (self (n / 2)) - ; 1, map2 func_call gen_variable (self (n / 2)) + ; 0, map2 func_def (list gen_ident) (self (n / 2)) + ; 0, map2 func_call gen_variable (self (n / 2)) (* TODO: make apply of arbitrary expr*) - ; ( 1 + ; ( 0 , map3 letin gen_rec_flag - (map (fun i -> Some i) gen_ident) - (list gen_variable) - <*> self (n / 2) + (gen_let_bind (self (n / 2))) + (list_size (0 -- 15) (gen_let_bind (self (n / 2)))) <*> self (n / 2) ) ])) ;; @@ -116,12 +128,25 @@ let shrink_lt = | String_lt x -> QCheck.Shrink.string x >|= string_e ;; -let rec shrink_expr = +let rec shrink_let_bind = + let open QCheck.Iter in + function + | Let_bind (name, args, e) -> + shrink_expr e + >|= (fun a' -> Let_bind (name, args, a')) + <+> (QCheck.Shrink.list args >|= fun a' -> Let_bind (name, a', e)) + +and shrink_expr = let open QCheck.Iter in function | Const lt -> shrink_lt lt | Variable _ -> empty - | Tuple t -> QCheck.Shrink.list ~shrink:shrink_expr t >|= fun a' -> Tuple a' + | Tuple (e1, e2, rest) -> + shrink_expr e1 + >|= (fun a' -> Tuple (a', e2, rest)) + <+> shrink_expr e2 + >|= (fun a' -> Tuple (e1, a', rest)) + <+> (QCheck.Shrink.list ~shrink:shrink_expr rest >|= fun a' -> Tuple (e1, e2, a')) | Unary_expr (op, e) -> return e <+> shrink_expr e >|= fun a' -> un_e op a' | Bin_expr (op, e1, e2) -> of_list [ e1; e2 ] @@ -132,30 +157,42 @@ let rec shrink_expr = shrink_expr i >|= (fun a' -> If_then_else (a', t, None)) <+> (shrink_expr t >|= fun a' -> If_then_else (i, a', None)) - | LetIn (rec_flag, ident, args, e, inner_e) -> - QCheck.Shrink.list ~shrink:shrink_expr args - >|= (fun a' -> LetIn (rec_flag, ident, a', e, inner_e)) - <+> (shrink_expr e >|= fun a' -> LetIn (rec_flag, ident, args, a', inner_e)) - <+> (shrink_expr inner_e >|= fun a' -> LetIn (rec_flag, ident, args, e, a')) + | LetIn (rec_flag, let_bind, let_bind_list, inner_e) -> + shrink_let_bind let_bind + >|= (fun a' -> LetIn (rec_flag, a', let_bind_list, inner_e)) + <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list + >|= fun a' -> LetIn (rec_flag, let_bind, a', inner_e)) + <+> shrink_expr inner_e + >|= fun a' -> LetIn (rec_flag, let_bind, let_bind_list, a') + | Function_call (f, arg) -> + shrink_expr f + >|= (fun a' -> Function_call (a', arg)) + <+> shrink_expr arg + >|= fun a' -> Function_call (f, a') | _ -> empty ;; -let let_st rec_flag ident args body = Let (rec_flag, ident, args, body) +let let_st rec_flag let_bind let_bind_list = Let (rec_flag, let_bind, let_bind_list) (* TODO: Active Pattern*) let gen_statement = - QCheck.Gen.(map3 let_st gen_rec_flag gen_ident (list gen_variable) <*> gen_expr) + QCheck.Gen.( + map3 + let_st + gen_rec_flag + (gen_let_bind gen_expr) + (list_size (0 -- 15) (gen_let_bind gen_expr))) ;; (* TODO: Active Pattern *) let shrink_statement = let open QCheck.Iter in function - | Let (rec_flag, ident, args, expr) -> - shrink_expr expr - >|= (fun a' -> Let (rec_flag, ident, args, a')) - <+> (QCheck.Shrink.list ~shrink:shrink_expr args - >|= fun a' -> Let (rec_flag, ident, a', expr)) + | Let (rec_flag, let_bind, let_bind_list) -> + shrink_let_bind let_bind + >|= (fun a' -> Let (rec_flag, a', let_bind_list)) + <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list + >|= fun a' -> Let (rec_flag, let_bind, a')) | _ -> empty ;; @@ -174,7 +211,7 @@ let shrink_construction = let arbitrary_construction = QCheck.make gen_construction - ~print:(Format.asprintf "%a" print_construction) + ~print:(Format.asprintf "%a" pp_construction) ~shrink:shrink_construction ;; From 69f9508c1f04455d9382dfc0a5832bd6a92ab302 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 22:16:01 +0300 Subject: [PATCH 120/310] fix: let and letin pretty_printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/prettyPrinter.ml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 856b310b6..ef6f17876 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -71,12 +71,11 @@ and pp_expr fmt expr = | Function_call (func, arg) -> fprintf fmt "%a %a" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> fprintf fmt "let %a " pp_rec_flag rec_flag; - pp_let_bind fmt let_bind; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "\n\nand ") pp_let_bind fmt - let_bind_list; + (let_bind :: let_bind_list); fprintf fmt "in\n"; fprintf fmt "%a " pp_expr in_expr | Option e -> @@ -103,12 +102,11 @@ and pp_let_bind fmt = function let pp_statement fmt = function | Let (rec_flag, let_bind, let_bind_list) -> fprintf fmt "let %a " pp_rec_flag rec_flag; - pp_let_bind fmt let_bind; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "\n\nand ") pp_let_bind fmt - let_bind_list + (let_bind :: let_bind_list) | ActivePattern (patterns, expr) -> fprintf fmt "Active pattern TODO" ;; From 352ab964c674041abc7720209bfb44342e7a73f0 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 22:46:52 +0300 Subject: [PATCH 121/310] fix: func_call pretty printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/prettyPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index ef6f17876..da385f27b 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -68,7 +68,7 @@ and pp_expr fmt expr = fprintf fmt "fun "; pp_args fmt args; fprintf fmt "-> %a " pp_expr body - | Function_call (func, arg) -> fprintf fmt "%a %a" pp_expr func pp_expr arg + | Function_call (func, arg) -> fprintf fmt "%a (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> fprintf fmt "let %a " pp_rec_flag rec_flag; pp_print_list From bddc33c07cf376ade836c27985e88aae995c7336 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 22:47:23 +0300 Subject: [PATCH 122/310] feat: implement func_def shrinker Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/gen_construction.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index d6bc96645..2357898eb 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -98,16 +98,16 @@ let gen_expr = (self (n / 2)) (self (n / 2)) (list_size (0 -- 15) (self (n / 2))) ) - ; 0, map2 un_e gen_unop (self (n / 2)) - ; 0, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) + ; 1, map2 un_e gen_unop (self (n / 2)) + ; 1, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) ; ( 1 , map3 if_e (self (n / 2)) (self (n / 2)) (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) - ; 0, map2 func_def (list gen_ident) (self (n / 2)) - ; 0, map2 func_call gen_variable (self (n / 2)) + ; 0, map2 func_def (list_size (0 -- 15) gen_ident) (self (n / 2)) + ; 1, map2 func_call gen_variable (self (n / 2)) (* TODO: make apply of arbitrary expr*) ; ( 0 , map3 @@ -169,6 +169,10 @@ and shrink_expr = >|= (fun a' -> Function_call (a', arg)) <+> shrink_expr arg >|= fun a' -> Function_call (f, a') + | Function_def (args, body) -> + QCheck.Shrink.list args + >|= (fun a' -> Function_def (a', body)) + <+> (shrink_expr body >|= fun a' -> Function_def (args, a')) | _ -> empty ;; From 1302880926389dbc320a10bf79456a10101f2bfe Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 23:05:18 +0300 Subject: [PATCH 123/310] ref: lint alerts Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/astPrinter.ml | 10 ++- FSharpActivePatterns/lib/prettyPrinter.ml | 11 ++-- .../lib/tests/gen_construction.ml | 62 +++++++++---------- FSharpActivePatterns/tests/qcheck.t | 3 + 4 files changed, 48 insertions(+), 38 deletions(-) diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index dc50e1c8f..24e955416 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -1,5 +1,13 @@ -open Ast +[@@@ocaml.text "/*"] + +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +[@@@ocaml.text "/*"] + open Format +open Ast let print_bin_op indent fmt = function | Binary_equal -> fprintf fmt "%s| Binary Equal\n" (String.make indent '-') diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index da385f27b..0b1e821e6 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -3,7 +3,6 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open Ast -open Printf open Format let pp_bin_op fmt = function @@ -37,10 +36,10 @@ let pp_rec_flag fmt = function let rec pp_pattern fmt = function | Wild -> fprintf fmt "_ " | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl - | PTuple tuple -> fprintf fmt "TUPLE PAT WIP" + | PTuple _ -> fprintf fmt "TUPLE PAT WIP" | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) | PVar (Ident (name, _)) -> fprintf fmt "%s " name - | Variant variants -> fprintf fmt "VARIANTS PAT WIP" + | Variant _ -> fprintf fmt "VARIANTS PAT WIP" and pp_expr fmt expr = match expr with @@ -48,13 +47,13 @@ and pp_expr fmt expr = | Const (Bool_lt b) -> fprintf fmt "%b " b | Const (String_lt s) -> fprintf fmt "%S " s | Const Unit_lt -> fprintf fmt "() " - | Cons_list (hd, tl) -> fprintf fmt "LIST WIP" + | Cons_list _ -> fprintf fmt "LIST WIP" | Empty_list -> fprintf fmt "[] " | Tuple (e1, e2, rest) -> fprintf fmt "("; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); fprintf fmt ")" - | Match (value, patterns) -> fprintf fmt "MATCH WIP" + | Match _ -> fprintf fmt "MATCH WIP" | Variable (Ident (name, _)) -> fprintf fmt "%s " name | Unary_expr (op, expr) -> fprintf fmt "%a (%a)" pp_unary_op op pp_expr expr | Bin_expr (op, left, right) -> @@ -107,7 +106,7 @@ let pp_statement fmt = function pp_let_bind fmt (let_bind :: let_bind_list) - | ActivePattern (patterns, expr) -> fprintf fmt "Active pattern TODO" + | ActivePattern _ -> fprintf fmt "Active pattern TODO" ;; let pp_construction fmt = function diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 2357898eb..36ba59714 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -87,36 +87,36 @@ let gen_let_bind gen = let gen_expr = QCheck.Gen.( sized - @@ fix (fun self n -> - match n with - | 0 -> frequency [ 1, gen_const; 1, gen_variable ] - | n -> - frequency - [ ( 0 - , map3 - tuple_e - (self (n / 2)) - (self (n / 2)) - (list_size (0 -- 15) (self (n / 2))) ) - ; 1, map2 un_e gen_unop (self (n / 2)) - ; 1, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) - ; ( 1 - , map3 - if_e - (self (n / 2)) - (self (n / 2)) - (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) - ; 0, map2 func_def (list_size (0 -- 15) gen_ident) (self (n / 2)) - ; 1, map2 func_call gen_variable (self (n / 2)) - (* TODO: make apply of arbitrary expr*) - ; ( 0 - , map3 - letin - gen_rec_flag - (gen_let_bind (self (n / 2))) - (list_size (0 -- 15) (gen_let_bind (self (n / 2)))) - <*> self (n / 2) ) - ])) + @@ fix (fun self -> + function + | 0 -> frequency [ 1, gen_const; 1, gen_variable ] + | n -> + frequency + [ ( 0 + , map3 + tuple_e + (self (n / 2)) + (self (n / 2)) + (list_size (0 -- 15) (self (n / 2))) ) + ; 1, map2 un_e gen_unop (self (n / 2)) + ; 1, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) + ; ( 1 + , map3 + if_e + (self (n / 2)) + (self (n / 2)) + (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) + ; 0, map2 func_def (list_size (0 -- 15) gen_ident) (self (n / 2)) + ; 1, map2 func_call gen_variable (self (n / 2)) + (* TODO: make apply of arbitrary expr*) + ; ( 0 + , map3 + letin + gen_rec_flag + (gen_let_bind (self (n / 2))) + (list_size (0 -- 15) (gen_let_bind (self (n / 2)))) + <*> self (n / 2) ) + ])) ;; let shrink_lt = @@ -215,7 +215,7 @@ let shrink_construction = let arbitrary_construction = QCheck.make gen_construction - ~print:(Format.asprintf "%a" pp_construction) + ~print:(Format.asprintf "%a" print_construction) ~shrink:shrink_construction ;; diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 43d5868ab..fea0d2a05 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1 +1,4 @@ $ ../lib/tests/run_construction.exe -seed 1 -gen 30 -stop + random seed: 1 + ================================================================================ + success (ran 1 tests) From 71762cc447d9ea4e73e1f79e211dae6bcbe28905 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 11 Nov 2024 23:16:51 +0300 Subject: [PATCH 124/310] build: add qcheck dependency Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/FSharpActivePatterns.opam | 1 + FSharpActivePatterns/dune-project | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/FSharpActivePatterns.opam b/FSharpActivePatterns/FSharpActivePatterns.opam index ff3987134..31bdd061f 100644 --- a/FSharpActivePatterns/FSharpActivePatterns.opam +++ b/FSharpActivePatterns/FSharpActivePatterns.opam @@ -12,6 +12,7 @@ doc: "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda" bug-reports: "https://github.com/Ycyken/fp2024" depends: [ "dune" {>= "3.7"} + "qcheck" "angstrom" "ppx_inline_test" {with-test} "ppx_expect" diff --git a/FSharpActivePatterns/dune-project b/FSharpActivePatterns/dune-project index e6c652b3f..f3260b9ea 100644 --- a/FSharpActivePatterns/dune-project +++ b/FSharpActivePatterns/dune-project @@ -23,11 +23,11 @@ (version 0.1) (depends dune + qcheck angstrom (ppx_inline_test :with-test) ppx_expect ppx_deriving bisect_ppx (odoc :with-doc) - (ocamlformat :build) - )) + (ocamlformat :build))) From 8a5f61f9dbeee9868b5e3295d97b2f44cd990231 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 12 Nov 2024 14:10:56 +0300 Subject: [PATCH 125/310] fix: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 4329a3431..38e8a1b69 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -55,8 +55,7 @@ type expr = | Empty_list (** [] *) | Cons_list of expr * expr (** {[ - [ 1; 2; 3 ] - [ 1; 2; 3 ] + [ 1; 2; 3 ] [ 1; 2; 3 ] ]} *) | Variable of ident (** [x], [y] *) | Unary_expr of unary_operator * expr (** -x *) From eb46e16d1da3ab424fefed287bb06806cb8cd9d4 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 12 Nov 2024 14:18:38 +0300 Subject: [PATCH 126/310] build: fix qcheck dependencies Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/FSharpActivePatterns.opam | 2 +- FSharpActivePatterns/dune-project | 2 +- FSharpActivePatterns/lib/tests/dune | 2 +- FSharpActivePatterns/lib/tests/gen_construction.ml | 2 +- FSharpActivePatterns/lib/tests/run_construction.ml | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/FSharpActivePatterns/FSharpActivePatterns.opam b/FSharpActivePatterns/FSharpActivePatterns.opam index 31bdd061f..8c6cb3248 100644 --- a/FSharpActivePatterns/FSharpActivePatterns.opam +++ b/FSharpActivePatterns/FSharpActivePatterns.opam @@ -12,7 +12,7 @@ doc: "FIX LATER https://kakadu.github.io/fp2024/docs/Lambda" bug-reports: "https://github.com/Ycyken/fp2024" depends: [ "dune" {>= "3.7"} - "qcheck" + "qcheck-core" "angstrom" "ppx_inline_test" {with-test} "ppx_expect" diff --git a/FSharpActivePatterns/dune-project b/FSharpActivePatterns/dune-project index f3260b9ea..2918ff06f 100644 --- a/FSharpActivePatterns/dune-project +++ b/FSharpActivePatterns/dune-project @@ -23,7 +23,7 @@ (version 0.1) (depends dune - qcheck + qcheck-core angstrom (ppx_inline_test :with-test) ppx_expect diff --git a/FSharpActivePatterns/lib/tests/dune b/FSharpActivePatterns/lib/tests/dune index 00fbe152e..30661f702 100644 --- a/FSharpActivePatterns/lib/tests/dune +++ b/FSharpActivePatterns/lib/tests/dune @@ -1,7 +1,7 @@ (library (name tests) (modules Ast_printer Parser Gen_construction) - (libraries FSharpActivePatterns qcheck) + (libraries FSharpActivePatterns qcheck-core qcheck-core.runner) (preprocess (pps ppx_expect ppx_deriving.show)) (instrumentation diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 36ba59714..817518987 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -220,7 +220,7 @@ let arbitrary_construction = ;; let run n = - QCheck_runner.run_tests + QCheck_base_runner.run_tests [ QCheck.( Test.make arbitrary_construction ~count:n (fun c -> Some c = parse (Format.asprintf "%a\n" pp_construction c))) diff --git a/FSharpActivePatterns/lib/tests/run_construction.ml b/FSharpActivePatterns/lib/tests/run_construction.ml index 6d2f112de..d4c141a70 100644 --- a/FSharpActivePatterns/lib/tests/run_construction.ml +++ b/FSharpActivePatterns/lib/tests/run_construction.ml @@ -21,7 +21,7 @@ let run_tests n = let () = Arg.parse - [ "-seed", Arg.Int QCheck_runner.set_seed, " Set seed" + [ "-seed", Arg.Int QCheck_base_runner.set_seed, " Set seed" ; "-stop", Arg.Unit (fun _ -> exit 0), " Exit" ; "-gen", Arg.Int run_tests, " Number of runs" ] From 239b067c0a5333ddc01e85f5c752770aadaa82a2 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 12 Nov 2024 14:22:51 +0300 Subject: [PATCH 127/310] ref: create gen_construction.mli Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/gen_construction.mli | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 FSharpActivePatterns/lib/tests/gen_construction.mli diff --git a/FSharpActivePatterns/lib/tests/gen_construction.mli b/FSharpActivePatterns/lib/tests/gen_construction.mli new file mode 100644 index 000000000..bc2e1b7aa --- /dev/null +++ b/FSharpActivePatterns/lib/tests/gen_construction.mli @@ -0,0 +1,5 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +val run : int -> int From 633201919894c344cef3d5f063d2455ec93baf2f Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 12 Nov 2024 14:30:54 +0300 Subject: [PATCH 128/310] build: fix qcheck dependencies Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/tests/dune b/FSharpActivePatterns/lib/tests/dune index 30661f702..9f2ed1383 100644 --- a/FSharpActivePatterns/lib/tests/dune +++ b/FSharpActivePatterns/lib/tests/dune @@ -10,4 +10,4 @@ (executable (name run_construction) (modules run_construction) - (libraries tests FSharpActivePatterns qcheck)) + (libraries tests FSharpActivePatterns qcheck-core.runner)) From f8bcebd42f93053609650f7b6fd3ac27027aef8b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 12 Nov 2024 14:31:49 +0300 Subject: [PATCH 129/310] ref: fix release errors Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/prettyPrinter.ml | 16 ++++++++-------- .../lib/tests/gen_construction.ml | 6 +++++- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 0b1e821e6..a43b83975 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -33,15 +33,15 @@ let pp_rec_flag fmt = function | Nonrec -> () ;; -let rec pp_pattern fmt = function - | Wild -> fprintf fmt "_ " - | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl - | PTuple _ -> fprintf fmt "TUPLE PAT WIP" - | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) - | PVar (Ident (name, _)) -> fprintf fmt "%s " name - | Variant _ -> fprintf fmt "VARIANTS PAT WIP" +(* let rec pp_pattern fmt = function + | Wild -> fprintf fmt "_ " + | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl + | PTuple _ -> fprintf fmt "TUPLE PAT WIP" + | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) + | PVar (Ident (name, _)) -> fprintf fmt "%s " name + | Variant _ -> fprintf fmt "VARIANTS PAT WIP" *) -and pp_expr fmt expr = +let rec pp_expr fmt expr = match expr with | Const (Int_lt i) -> fprintf fmt "%d " i | Const (Bool_lt b) -> fprintf fmt "%b " b diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 817518987..2e4107ec6 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -20,7 +20,11 @@ let variable_e x = Variable (Ident (x, None)) let gen_const = QCheck.Gen.( frequency - [ 1, map int_e nat; 1, map bool_e bool; 0, return unit_e; 0, map string_e string ]) + [ 1, map int_e nat + ; 1, map bool_e bool + ; 0, return unit_e + ; 0, map string_e (string ?gen:None) + ]) ;; let gen_varname = From 41a37b8ea06dc0693703c869b1e43afbdd9b4ace Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 15 Nov 2024 10:20:47 +0300 Subject: [PATCH 130/310] fix: fix bug in list parser, complete list pretty printer Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 45 ++++++++--------------- FSharpActivePatterns/lib/prettyPrinter.ml | 20 +++++++++- 2 files changed, 33 insertions(+), 32 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index ec2d7a640..d8f4f1963 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -100,15 +100,6 @@ let p_ident = let p_var = p_ident >>| fun ident -> Variable ident -(* - let make_list expr1 expr2 = Cons_list (expr1, expr2) - - let cons p_expr = - skip_ws *> string "::" *> skip_ws *> - lift2 (fun expr1 expr2 -> Cons_list (expr1, expr2)) p_expr p_expr - ;; -*) - let p_empty_list = skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws >>= fun _ -> return Empty_list ;; @@ -116,26 +107,20 @@ let p_empty_list = let make_list expr1 expr2 = Cons_list (expr1, expr2) let p_cons_list p_expr = - chainr1 (p_expr <|> p_empty_list) (skip_ws *> string "::" *> skip_ws *> return make_list) -;; - -let p_semicolon_list p_expr = skip_ws - *> string "[" - *> skip_ws - *> fix (fun p_cons_list -> - p_expr - <* skip_ws - <* string "]" - >>| (fun expr -> Cons_list (expr, Empty_list)) - <|> (p_expr - <* skip_ws - <* string ";" - >>= fun expr -> p_cons_list >>= fun rest -> return (Cons_list (expr, rest))) - <|> (string "]" *> skip_ws >>= fun _ -> return Empty_list)) + *> chainr1 + (p_expr <|> p_empty_list) + (skip_ws *> string "::" *> skip_ws *> return make_list) ;; -let p_list p_expr = p_semicolon_list p_expr <|> p_cons_list p_expr +let p_semicolon_list p_expr = + skip_ws *> string "[" *> skip_ws *> + fix (fun p_semi_list -> + choice [ + (p_expr <* skip_ws <* string ";" <* skip_ws >>= fun expr -> p_semi_list >>= fun rest -> return (Cons_list (expr, rest))); + (p_expr <* skip_ws <* string "]" <* skip_ws >>| fun expr -> Cons_list (expr, Empty_list)); + (string "]" *> skip_ws >>= fun _ -> return Empty_list) ] ) +;; (* EXPR PARSERS *) let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' @@ -286,9 +271,8 @@ let p_option p_expr = let p_expr = skip_ws *> fix (fun p_expr -> - let atom = choice [ p_var; p_int; p_bool; p_parens p_expr ] in - let list = p_list atom <|> atom in - let tuple = p_tuple list <|> list in + let atom = choice [ p_var; p_int; p_bool; p_parens p_expr; p_semicolon_list p_expr] in + let tuple = p_tuple atom <|> atom in let if_expr = p_if (p_expr <|> tuple) <|> tuple in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in let apply = p_apply (p_expr <|> letin_expr) <|> letin_expr in @@ -300,7 +284,8 @@ let p_expr = let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in let comp_and = chainl1 comp_gr log_and in let comp_or = chainl1 comp_and log_or in - let option = p_option comp_or <|> comp_or in + let cons_list = p_cons_list comp_or <|> comp_or in + let option = p_option cons_list <|> cons_list in option) ;; diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index a43b83975..69a39ac58 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -47,8 +47,15 @@ let rec pp_expr fmt expr = | Const (Bool_lt b) -> fprintf fmt "%b " b | Const (String_lt s) -> fprintf fmt "%S " s | Const Unit_lt -> fprintf fmt "() " - | Cons_list _ -> fprintf fmt "LIST WIP" - | Empty_list -> fprintf fmt "[] " + | Empty_list -> fprintf fmt "%a " pp_list Empty_list + | Cons_list (expr1, expr2) -> + fprintf fmt "["; + fprintf fmt "%a " pp_expr expr1; + if expr2 <> Empty_list + then ( + fprintf fmt "; "; + fprintf fmt "%a " pp_list expr2); + fprintf fmt "]" | Tuple (e1, e2, rest) -> fprintf fmt "("; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); @@ -96,6 +103,15 @@ and pp_args fmt args = and pp_let_bind fmt = function | Let_bind (Ident (name, _), args, body) -> fprintf fmt "%s %a = %a " name pp_args args pp_expr body + +and pp_list fmt = function + | Empty_list -> fprintf fmt "[]" + | Cons_list (head, Empty_list) -> fprintf fmt "%a " pp_expr head + | Cons_list (head, tail) -> + fprintf fmt "%a " pp_expr head; + fprintf fmt "; "; + fprintf fmt "%a " pp_list tail + | other -> fprintf fmt "%a" pp_expr other ;; let pp_statement fmt = function From 7bba637d0ab3e5ce94d4d00b220c4bbcff4f2366 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 15 Nov 2024 10:21:56 +0300 Subject: [PATCH 131/310] fix: delete outdated functions from comments Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 30 ------------------------------ 1 file changed, 30 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index d8f4f1963..15211d063 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -185,22 +185,6 @@ let p_let_bind p_expr = (skip_ws *> string "=" *> skip_ws *> p_expr) ;; -(* - let p_letin p_expr = - skip_ws - *> string "let" - *> skip_ws_sep1 - *> lift4 - (fun rec_flag name args body and_list in_expr -> - LetIn (rec_flag, name, args, body, and_list, in_expr)) - (string "rec" *> return Rec <|> return Nonrec) - (p_ident >>= fun ident -> return (Some ident) <|> return None) - (many (skip_ws *> p_var)) - (skip_ws *> string "=" *> skip_ws *> p_expr) - <*> skip_ws *> many (skip_ws *> p_and p_expr) - <*> skip_ws *> string "in" *> skip_ws_sep1 *> p_expr - ;; *) - let p_letin p_expr = skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) >>= fun rec_flag -> @@ -218,20 +202,6 @@ let p_letin p_expr = return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) ;; -(* - let p_let p_expr = - skip_ws - *> string "let" - *> skip_ws_sep1 - *> lift4 - (fun rec_flag name args body and_list -> Let (rec_flag, name, args, body, and_list)) - (string "rec" *> return Rec <|> return Nonrec) - p_ident - (skip_ws *> many (skip_ws *> p_var)) - (skip_ws *> string "=" *> p_expr) - <*> skip_ws *> many (skip_ws *> p_and p_expr) - ;; *) - let p_let p_expr = skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) >>= fun rec_flag -> From c5833177ce8166191e76b31c0b6801cce69d6e7a Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 15 Nov 2024 16:55:38 +0300 Subject: [PATCH 132/310] feat: add parser for match wildcard Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.mli | 3 ++- FSharpActivePatterns/lib/astPrinter.ml | 5 +++- FSharpActivePatterns/lib/parser.ml | 27 ++++++++++++++++++- FSharpActivePatterns/lib/prettyPrinter.ml | 12 ++++++--- FSharpActivePatterns/lib/tests/ast_printer.ml | 2 +- 5 files changed, 41 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 38e8a1b69..0e2850565 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -37,6 +37,7 @@ type unary_operator = type pattern = | Wild (** [_] *) + | PEmptyList (** [] *) | PCons of pattern * pattern (** | [hd :: tl] -> *) | PTuple of pattern list (** | [(a, b)] -> *) | PConst of literal (** | [4] -> *) @@ -63,7 +64,7 @@ type expr = | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) | Function_def of ident list * expr (** fun x y -> x + y *) | Function_call of expr * expr (** [sum 1 ] *) - | Match of expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) + | Match of expr * pattern * expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) | LetIn of is_recursive * let_bind * let_bind list * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 24e955416..41a78b1b9 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -31,6 +31,7 @@ let print_bin_op indent fmt = function let rec print_pattern indent fmt = function | Wild -> fprintf fmt "%s| Wild\n" (String.make indent '-') + | PEmptyList -> fprintf fmt "%s| EmptyList\n" (String.make indent '-') | PCons (head, tail) -> fprintf fmt "%s| PCons:\n" (String.make indent '-'); fprintf fmt "%sHead:\n" (String.make (indent + 2) '-'); @@ -89,9 +90,11 @@ and print_expr indent fmt expr = print_expr (indent + 2) fmt expr2 | Empty_list -> fprintf fmt "%s| Empty_list expr:\n" (String.make indent '-') | Tuple (e1, e2, rest) -> List.iter (print_expr indent fmt) (e1 :: e2 :: rest) - | Match (value, patterns) -> + | Match (value, pat1, expr1, patterns) -> fprintf fmt "%s| Match:\n" (String.make indent '-'); print_expr (indent + 2) fmt value; + print_pattern (indent + 2) fmt pat1; + print_expr (indent + 2) fmt expr1; List.iter (fun (pat, expr) -> fprintf fmt "%s| Pattern:\n" (String.make (indent + 2) '-'); diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 15211d063..8acccec61 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -238,6 +238,30 @@ let p_option p_expr = <|> (skip_ws *> string "Some" *> p_expr >>| fun expr -> Option (Some expr)) ;; +let make_cons_pat pat1 pat2 = PCons (pat1, pat2) +(* +let p_cons_pat p_pat = + skip_ws + *> chainr1 + (p_pat <|> p_empty_list) + (skip_ws *> string "::" *> skip_ws *> return make_cons_pat) *) + +let p_pat = + fix (fun p_pat -> + skip_ws *> string "|" *> skip_ws *> + choice [ + string "_" *> skip_ws *> string "->" *> skip_ws >>= fun _ -> return Wild + ]) +;; + +let p_match p_expr = + lift4 (fun value pat1 expr1 list -> Match (value, pat1, expr1, list)) + (skip_ws *> string "match" *> skip_ws *> p_expr <* skip_ws <* string "with" <* skip_ws) + (skip_ws *> p_pat <* skip_ws) + (skip_ws *> p_expr <* skip_ws) + (many (skip_ws *> p_pat >>= fun pat -> p_expr <* skip_ws >>= fun expr -> return (pat, expr))) +;; + let p_expr = skip_ws *> fix (fun p_expr -> @@ -255,7 +279,8 @@ let p_expr = let comp_and = chainl1 comp_gr log_and in let comp_or = chainl1 comp_and log_or in let cons_list = p_cons_list comp_or <|> comp_or in - let option = p_option cons_list <|> cons_list in + let ematch = p_match cons_list <|> cons_list in + let option = p_option ematch <|> ematch in option) ;; diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 69a39ac58..9b3a34940 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -33,15 +33,16 @@ let pp_rec_flag fmt = function | Nonrec -> () ;; -(* let rec pp_pattern fmt = function +let rec pp_pattern fmt = function | Wild -> fprintf fmt "_ " + | PEmptyList -> fprintf fmt "[] " | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl | PTuple _ -> fprintf fmt "TUPLE PAT WIP" | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) | PVar (Ident (name, _)) -> fprintf fmt "%s " name - | Variant _ -> fprintf fmt "VARIANTS PAT WIP" *) + | Variant _ -> fprintf fmt "VARIANTS PAT WIP" -let rec pp_expr fmt expr = +and pp_expr fmt expr = match expr with | Const (Int_lt i) -> fprintf fmt "%d " i | Const (Bool_lt b) -> fprintf fmt "%b " b @@ -60,7 +61,10 @@ let rec pp_expr fmt expr = fprintf fmt "("; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); fprintf fmt ")" - | Match _ -> fprintf fmt "MATCH WIP" + | Match (value, pat1, expr1, list) -> + fprintf fmt "match %a with \n" pp_expr value; + fprintf fmt "| %a -> %a \n" pp_pattern pat1 pp_expr expr1; + List.iter (fun (pat, expr) -> fprintf fmt "| %a -> %a \n" pp_pattern pat pp_expr expr) list | Variable (Ident (name, _)) -> fprintf fmt "%s " name | Unary_expr (op, expr) -> fprintf fmt "%a (%a)" pp_unary_op op pp_expr expr | Bin_expr (op, left, right) -> diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index eca86459e..17d790a2d 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -224,7 +224,7 @@ let%expect_test "print Ast of match_expr" = ] in let pattern_values = List.map (fun p -> p, Const (Int_lt 4)) patterns in - let match_expr = Match (Variable (Ident ("x", None)), pattern_values) in + let match_expr = Match (Variable (Ident ("x", None)), PConst (Int_lt 4), Const (Int_lt 4), pattern_values) in print_construction std_formatter (Expr match_expr); [%expect {| From 0f877caa31d6c48e4f6516cca12ba8460b99bde8 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 15 Nov 2024 21:29:50 +0300 Subject: [PATCH 133/310] ref: remove old empty files Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/printAst.ml | 0 FSharpActivePatterns/lib/tests/print_ast.ml | 0 2 files changed, 0 insertions(+), 0 deletions(-) delete mode 100644 FSharpActivePatterns/lib/printAst.ml delete mode 100644 FSharpActivePatterns/lib/tests/print_ast.ml diff --git a/FSharpActivePatterns/lib/printAst.ml b/FSharpActivePatterns/lib/printAst.ml deleted file mode 100644 index e69de29bb..000000000 diff --git a/FSharpActivePatterns/lib/tests/print_ast.ml b/FSharpActivePatterns/lib/tests/print_ast.ml deleted file mode 100644 index e69de29bb..000000000 From 452bc532b336b99309bae375bb39b008dab379a2 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 15 Nov 2024 21:36:29 +0300 Subject: [PATCH 134/310] ref: formatting Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 73 ++++++++++++------- FSharpActivePatterns/lib/prettyPrinter.ml | 18 +++-- FSharpActivePatterns/lib/tests/ast_printer.ml | 5 +- 3 files changed, 59 insertions(+), 37 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 8acccec61..bf0d5c258 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -113,14 +113,25 @@ let p_cons_list p_expr = (skip_ws *> string "::" *> skip_ws *> return make_list) ;; -let p_semicolon_list p_expr = - skip_ws *> string "[" *> skip_ws *> - fix (fun p_semi_list -> - choice [ - (p_expr <* skip_ws <* string ";" <* skip_ws >>= fun expr -> p_semi_list >>= fun rest -> return (Cons_list (expr, rest))); - (p_expr <* skip_ws <* string "]" <* skip_ws >>| fun expr -> Cons_list (expr, Empty_list)); - (string "]" *> skip_ws >>= fun _ -> return Empty_list) ] ) -;; +let p_semicolon_list p_expr = + skip_ws + *> string "[" + *> skip_ws + *> fix (fun p_semi_list -> + choice + [ (p_expr + <* skip_ws + <* string ";" + <* skip_ws + >>= fun expr -> p_semi_list >>= fun rest -> return (Cons_list (expr, rest))) + ; (p_expr + <* skip_ws + <* string "]" + <* skip_ws + >>| fun expr -> Cons_list (expr, Empty_list)) + ; (string "]" *> skip_ws >>= fun _ -> return Empty_list) + ]) +;; (* EXPR PARSERS *) let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' @@ -240,32 +251,38 @@ let p_option p_expr = let make_cons_pat pat1 pat2 = PCons (pat1, pat2) (* -let p_cons_pat p_pat = - skip_ws - *> chainr1 - (p_pat <|> p_empty_list) - (skip_ws *> string "::" *> skip_ws *> return make_cons_pat) *) - -let p_pat = - fix (fun p_pat -> - skip_ws *> string "|" *> skip_ws *> - choice [ - string "_" *> skip_ws *> string "->" *> skip_ws >>= fun _ -> return Wild - ]) + let p_cons_pat p_pat = + skip_ws + *> chainr1 + (p_pat <|> p_empty_list) + (skip_ws *> string "::" *> skip_ws *> return make_cons_pat) *) + +let p_pat = + fix (fun p_pat -> + skip_ws + *> string "|" + *> skip_ws + *> choice + [ (string "_" *> skip_ws *> string "->" *> skip_ws >>= fun _ -> return Wild) ]) ;; -let p_match p_expr = - lift4 (fun value pat1 expr1 list -> Match (value, pat1, expr1, list)) - (skip_ws *> string "match" *> skip_ws *> p_expr <* skip_ws <* string "with" <* skip_ws) - (skip_ws *> p_pat <* skip_ws) - (skip_ws *> p_expr <* skip_ws) - (many (skip_ws *> p_pat >>= fun pat -> p_expr <* skip_ws >>= fun expr -> return (pat, expr))) +let p_match p_expr = + lift4 + (fun value pat1 expr1 list -> Match (value, pat1, expr1, list)) + (skip_ws *> string "match" *> skip_ws *> p_expr <* skip_ws <* string "with" <* skip_ws) + (skip_ws *> p_pat <* skip_ws) + (skip_ws *> p_expr <* skip_ws) + (many + (skip_ws *> p_pat + >>= fun pat -> p_expr <* skip_ws >>= fun expr -> return (pat, expr))) ;; let p_expr = skip_ws *> fix (fun p_expr -> - let atom = choice [ p_var; p_int; p_bool; p_parens p_expr; p_semicolon_list p_expr] in + let atom = + choice [ p_var; p_int; p_bool; p_parens p_expr; p_semicolon_list p_expr ] + in let tuple = p_tuple atom <|> atom in let if_expr = p_if (p_expr <|> tuple) <|> tuple in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in @@ -278,7 +295,7 @@ let p_expr = let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in let comp_and = chainl1 comp_gr log_and in let comp_or = chainl1 comp_and log_or in - let cons_list = p_cons_list comp_or <|> comp_or in + let cons_list = p_cons_list comp_or <|> comp_or in let ematch = p_match cons_list <|> cons_list in let option = p_option ematch <|> ematch in option) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 9b3a34940..bdfbf3319 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -34,13 +34,13 @@ let pp_rec_flag fmt = function ;; let rec pp_pattern fmt = function - | Wild -> fprintf fmt "_ " - | PEmptyList -> fprintf fmt "[] " - | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl - | PTuple _ -> fprintf fmt "TUPLE PAT WIP" - | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) - | PVar (Ident (name, _)) -> fprintf fmt "%s " name - | Variant _ -> fprintf fmt "VARIANTS PAT WIP" + | Wild -> fprintf fmt "_ " + | PEmptyList -> fprintf fmt "[] " + | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl + | PTuple _ -> fprintf fmt "TUPLE PAT WIP" + | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) + | PVar (Ident (name, _)) -> fprintf fmt "%s " name + | Variant _ -> fprintf fmt "VARIANTS PAT WIP" and pp_expr fmt expr = match expr with @@ -64,7 +64,9 @@ and pp_expr fmt expr = | Match (value, pat1, expr1, list) -> fprintf fmt "match %a with \n" pp_expr value; fprintf fmt "| %a -> %a \n" pp_pattern pat1 pp_expr expr1; - List.iter (fun (pat, expr) -> fprintf fmt "| %a -> %a \n" pp_pattern pat pp_expr expr) list + List.iter + (fun (pat, expr) -> fprintf fmt "| %a -> %a \n" pp_pattern pat pp_expr expr) + list | Variable (Ident (name, _)) -> fprintf fmt "%s " name | Unary_expr (op, expr) -> fprintf fmt "%a (%a)" pp_unary_op op pp_expr expr | Bin_expr (op, left, right) -> diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index 17d790a2d..2f8c6c9e5 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -224,7 +224,10 @@ let%expect_test "print Ast of match_expr" = ] in let pattern_values = List.map (fun p -> p, Const (Int_lt 4)) patterns in - let match_expr = Match (Variable (Ident ("x", None)), PConst (Int_lt 4), Const (Int_lt 4), pattern_values) in + let match_expr = + Match + (Variable (Ident ("x", None)), PConst (Int_lt 4), Const (Int_lt 4), pattern_values) + in print_construction std_formatter (Expr match_expr); [%expect {| From aa47ddbffb4f23d64c9eed3fc94804401cc1ec19 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 15 Nov 2024 21:59:12 +0300 Subject: [PATCH 135/310] fix: tuple parser: expressions inside tuple Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index bf0d5c258..3e6d98f90 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -283,7 +283,7 @@ let p_expr = let atom = choice [ p_var; p_int; p_bool; p_parens p_expr; p_semicolon_list p_expr ] in - let tuple = p_tuple atom <|> atom in + let tuple = p_tuple (p_expr <|> atom) <|> atom in let if_expr = p_if (p_expr <|> tuple) <|> tuple in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in let apply = p_apply (p_expr <|> letin_expr) <|> letin_expr in From 4941955a1d6f7d64803493974ebfded0d8bd46b1 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 15 Nov 2024 22:28:08 +0300 Subject: [PATCH 136/310] fix: Lambda pretty printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.mli | 5 +++-- FSharpActivePatterns/lib/astPrinter.ml | 2 +- FSharpActivePatterns/lib/prettyPrinter.ml | 4 ++-- FSharpActivePatterns/lib/tests/ast_printer.ml | 4 ++-- 4 files changed, 8 insertions(+), 7 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.mli index 0e2850565..a76cd49ae 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.mli @@ -62,9 +62,10 @@ type expr = | Unary_expr of unary_operator * expr (** -x *) | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) - | Function_def of ident list * expr (** fun x y -> x + y *) + | Lambda of ident list * expr (** fun x y -> x + y *) | Function_call of expr * expr (** [sum 1 ] *) - | Match of expr * pattern * expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) + | Match of expr * pattern * expr * (pattern * expr) list + (** [match x with | x -> ... | y -> ...] *) | LetIn of is_recursive * let_bind * let_bind list * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 41a78b1b9..e6d7d2a11 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -123,7 +123,7 @@ and print_expr indent fmt expr = (match else_body with | Some body -> print_expr (indent + 2) fmt body | None -> fprintf fmt "%s| No else body\n" (String.make (indent + 2) '-')) - | Function_def (args, body) -> + | Lambda (args, body) -> let args = List.map tag_of_ident args in fprintf fmt "%s| Func:\n" (String.make indent '-'); fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index bdfbf3319..5bed78539 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -76,9 +76,9 @@ and pp_expr fmt expr = (match else_body with | Some body -> fprintf fmt "else %a " pp_expr body | None -> ()) - | Function_def (args, body) -> + | Lambda (args, body) -> fprintf fmt "fun "; - pp_args fmt args; + if args = [] then fprintf fmt "() " else pp_args fmt args; fprintf fmt "-> %a " pp_expr body | Function_call (func, arg) -> fprintf fmt "%a (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index 2f8c6c9e5..906bb4b9b 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -8,7 +8,7 @@ open Format let%expect_test "print Ast factorial" = let factorial = - Function_def + Lambda ( [ Ident ("n", None) ] , If_then_else ( Bin_expr @@ -109,7 +109,7 @@ let%expect_test "print Ast double func" = let ident = Ident ("n", None) in let args = [ ident ] in let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), Variable ident) in - let double = Function_def (args, binary_expr) in + let double = Lambda (args, binary_expr) in print_construction std_formatter @@ Expr double; [%expect {| From 01f87d2b5e95e5daedd2ec08ef96498f08e4e88f Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 15 Nov 2024 22:55:40 +0300 Subject: [PATCH 137/310] fix: renaming Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/gen_construction.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 2e4107ec6..241a1f683 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -51,7 +51,7 @@ let tuple_e e1 e2 rest = Tuple (e1, e2, rest) let un_e unop e = Unary_expr (unop, e) let bin_e op e1 e2 = Bin_expr (op, e1, e2) let if_e i t e = If_then_else (i, t, e) -let func_def args body = Function_def (args, body) +let func_def args body = Lambda (args, body) let func_call f arg = Function_call (f, arg) let let_bind name args body = Let_bind (name, args, body) @@ -173,10 +173,10 @@ and shrink_expr = >|= (fun a' -> Function_call (a', arg)) <+> shrink_expr arg >|= fun a' -> Function_call (f, a') - | Function_def (args, body) -> + | Lambda (args, body) -> QCheck.Shrink.list args - >|= (fun a' -> Function_def (a', body)) - <+> (shrink_expr body >|= fun a' -> Function_def (args, a')) + >|= (fun a' -> Lambda (a', body)) + <+> (shrink_expr body >|= fun a' -> Lambda (args, a')) | _ -> empty ;; From f1b3228307f52f02c1e5db21815454caef85fcfb Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 15 Nov 2024 23:17:57 +0300 Subject: [PATCH 138/310] ref: less spaces in list pretty printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/prettyPrinter.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 5bed78539..3eb8ba41c 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -51,11 +51,11 @@ and pp_expr fmt expr = | Empty_list -> fprintf fmt "%a " pp_list Empty_list | Cons_list (expr1, expr2) -> fprintf fmt "["; - fprintf fmt "%a " pp_expr expr1; + fprintf fmt "%a" pp_expr expr1; if expr2 <> Empty_list then ( fprintf fmt "; "; - fprintf fmt "%a " pp_list expr2); + fprintf fmt "%a" pp_list expr2); fprintf fmt "]" | Tuple (e1, e2, rest) -> fprintf fmt "("; @@ -114,9 +114,9 @@ and pp_list fmt = function | Empty_list -> fprintf fmt "[]" | Cons_list (head, Empty_list) -> fprintf fmt "%a " pp_expr head | Cons_list (head, tail) -> - fprintf fmt "%a " pp_expr head; + fprintf fmt "%a" pp_expr head; fprintf fmt "; "; - fprintf fmt "%a " pp_list tail + fprintf fmt "%a" pp_list tail | other -> fprintf fmt "%a" pp_expr other ;; From fc84a00538fa4aa9ed0d3a1eb83fcaea0f6cabb1 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 16 Nov 2024 00:11:34 +0300 Subject: [PATCH 139/310] fix: expr shrinker Signed-off-by: Gleb Nasretdinov --- .../lib/tests/gen_construction.ml | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 241a1f683..7e81dea69 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -146,10 +146,9 @@ and shrink_expr = | Const lt -> shrink_lt lt | Variable _ -> empty | Tuple (e1, e2, rest) -> - shrink_expr e1 - >|= (fun a' -> Tuple (a', e2, rest)) - <+> shrink_expr e2 - >|= (fun a' -> Tuple (e1, a', rest)) + of_list [ e1; e2 ] + <+> (shrink_expr e1 >|= fun a' -> Tuple (a', e2, rest)) + <+> (shrink_expr e2 >|= fun a' -> Tuple (e1, a', rest)) <+> (QCheck.Shrink.list ~shrink:shrink_expr rest >|= fun a' -> Tuple (e1, e2, a')) | Unary_expr (op, e) -> return e <+> shrink_expr e >|= fun a' -> un_e op a' | Bin_expr (op, e1, e2) -> @@ -158,12 +157,13 @@ and shrink_expr = <+> (shrink_expr e2 >|= fun a' -> bin_e op e1 a') | If_then_else (i, t, Some _) -> return (If_then_else (i, t, None)) | If_then_else (i, t, None) -> - shrink_expr i - >|= (fun a' -> If_then_else (a', t, None)) + of_list [ i; t ] + <+> (shrink_expr i >|= fun a' -> If_then_else (a', t, None)) <+> (shrink_expr t >|= fun a' -> If_then_else (i, a', None)) | LetIn (rec_flag, let_bind, let_bind_list, inner_e) -> - shrink_let_bind let_bind - >|= (fun a' -> LetIn (rec_flag, a', let_bind_list, inner_e)) + return inner_e + <+> (shrink_let_bind let_bind + >|= fun a' -> LetIn (rec_flag, a', let_bind_list, inner_e)) <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list >|= fun a' -> LetIn (rec_flag, let_bind, a', inner_e)) <+> shrink_expr inner_e @@ -174,8 +174,8 @@ and shrink_expr = <+> shrink_expr arg >|= fun a' -> Function_call (f, a') | Lambda (args, body) -> - QCheck.Shrink.list args - >|= (fun a' -> Lambda (a', body)) + return body + <+> (QCheck.Shrink.list args >|= fun a' -> Lambda (a', body)) <+> (shrink_expr body >|= fun a' -> Lambda (args, a')) | _ -> empty ;; From 0c8571fc58ec0c68844dfacb50c7d277020cbf66 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 16 Nov 2024 00:43:02 +0300 Subject: [PATCH 140/310] fix: tuple ast printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/astPrinter.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index e6d7d2a11..c27883999 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -89,7 +89,9 @@ and print_expr indent fmt expr = print_expr (indent + 2) fmt expr1; print_expr (indent + 2) fmt expr2 | Empty_list -> fprintf fmt "%s| Empty_list expr:\n" (String.make indent '-') - | Tuple (e1, e2, rest) -> List.iter (print_expr indent fmt) (e1 :: e2 :: rest) + | Tuple (e1, e2, rest) -> + fprintf fmt "%s| Tuple:\n" (String.make indent '-'); + List.iter (print_expr (indent + 2) fmt) (e1 :: e2 :: rest) | Match (value, pat1, expr1, patterns) -> fprintf fmt "%s| Match:\n" (String.make indent '-'); print_expr (indent + 2) fmt value; From 0df8b4377e72ddb769ee29542a9fd37f3cdd9361 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 16 Nov 2024 06:12:55 +0300 Subject: [PATCH 141/310] ref: improve printers Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/astPrinter.ml | 21 ++++++++++----------- FSharpActivePatterns/lib/prettyPrinter.ml | 5 ++--- 2 files changed, 12 insertions(+), 14 deletions(-) diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index c27883999..32384ce41 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -31,7 +31,7 @@ let print_bin_op indent fmt = function let rec print_pattern indent fmt = function | Wild -> fprintf fmt "%s| Wild\n" (String.make indent '-') - | PEmptyList -> fprintf fmt "%s| EmptyList\n" (String.make indent '-') + | PEmptyList -> fprintf fmt "%s| Empty_list\n" (String.make indent '-') | PCons (head, tail) -> fprintf fmt "%s| PCons:\n" (String.make indent '-'); fprintf fmt "%sHead:\n" (String.make (indent + 2) '-'); @@ -71,7 +71,7 @@ let rec print_let_bind indent fmt = function let args = List.map tag_of_ident args in fprintf fmt "%s| Let_bind:\n" (String.make indent '-'); fprintf fmt "%sNAME:\n" (String.make (indent + 4) ' '); - fprintf fmt "%s| %s\n" (String.make (indent + 2) '-') name; + fprintf fmt "%s| %s\n" (String.make (indent + 4) '-') name; fprintf fmt "%sARGS:\n" (String.make (indent + 4) ' '); List.iter (fun arg -> fprintf fmt "%s| %s\n" (String.make (indent + 2) '-') arg) args; fprintf fmt "%sBODY:\n" (String.make (indent + 4) ' '); @@ -88,22 +88,21 @@ and print_expr indent fmt expr = fprintf fmt "%s| Cons_list expr:\n" (String.make indent '-'); print_expr (indent + 2) fmt expr1; print_expr (indent + 2) fmt expr2 - | Empty_list -> fprintf fmt "%s| Empty_list expr:\n" (String.make indent '-') + | Empty_list -> fprintf fmt "%s| Empty_list\n" (String.make indent '-') | Tuple (e1, e2, rest) -> fprintf fmt "%s| Tuple:\n" (String.make indent '-'); List.iter (print_expr (indent + 2) fmt) (e1 :: e2 :: rest) - | Match (value, pat1, expr1, patterns) -> + | Match (value, pat1, expr1, cases) -> fprintf fmt "%s| Match:\n" (String.make indent '-'); - print_expr (indent + 2) fmt value; - print_pattern (indent + 2) fmt pat1; - print_expr (indent + 2) fmt expr1; + fprintf fmt "%s| Value:\n" (String.make (indent + 2) '-'); + print_expr (indent + 4) fmt value; List.iter (fun (pat, expr) -> fprintf fmt "%s| Pattern:\n" (String.make (indent + 2) '-'); print_pattern (indent + 4) fmt pat; fprintf fmt "%s| Inner expr:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) fmt expr) - patterns + ((pat1, expr1) :: cases) | Variable (Ident (name, _)) -> fprintf fmt "%s| Variable(%s)\n" (String.make indent '-') name | Unary_expr (op, expr) -> @@ -162,12 +161,12 @@ let print_statement indent fmt = function | Let (rec_flag, let_bind, let_bind_list) -> fprintf fmt - "%s | %s Let=\n" + "%s |%s Let:\n" (String.make indent '-') (match rec_flag with | Nonrec -> "" - | Rec -> "Rec"); - fprintf fmt "%sLet_binds\n" (String.make (indent + 2) ' '); + | Rec -> "Rec "); + fprintf fmt "%s Let_binds\n" (String.make (indent + 2) ' '); List.iter (print_let_bind (indent + 2) fmt) (let_bind :: let_bind_list) | ActivePattern (patterns, expr) -> fprintf fmt "%s| ActivePattern:\n" (String.make indent '-'); diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 3eb8ba41c..9eec35c84 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -61,12 +61,11 @@ and pp_expr fmt expr = fprintf fmt "("; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); fprintf fmt ")" - | Match (value, pat1, expr1, list) -> + | Match (value, pat1, expr1, cases) -> fprintf fmt "match %a with \n" pp_expr value; - fprintf fmt "| %a -> %a \n" pp_pattern pat1 pp_expr expr1; List.iter (fun (pat, expr) -> fprintf fmt "| %a -> %a \n" pp_pattern pat pp_expr expr) - list + ((pat1, expr1) :: cases) | Variable (Ident (name, _)) -> fprintf fmt "%s " name | Unary_expr (op, expr) -> fprintf fmt "%a (%a)" pp_unary_op op pp_expr expr | Bin_expr (op, left, right) -> From 0d63e4d9763022b288d9ad667ebe94f37296aeb9 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 16 Nov 2024 08:13:44 +0300 Subject: [PATCH 142/310] feat: add @@deriving qcheck for ast Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/{ast.mli => ast.ml} | 51 +++++++++++++++----- FSharpActivePatterns/lib/astPrinter.ml | 4 +- FSharpActivePatterns/lib/dune | 5 +- FSharpActivePatterns/lib/keywordChecker.ml | 20 ++++++++ FSharpActivePatterns/lib/keywordChecker.mli | 5 ++ FSharpActivePatterns/lib/parser.ml | 18 +------ FSharpActivePatterns/lib/parser.mli | 1 - 7 files changed, 70 insertions(+), 34 deletions(-) rename FSharpActivePatterns/lib/{ast.mli => ast.ml} (58%) create mode 100644 FSharpActivePatterns/lib/keywordChecker.ml create mode 100644 FSharpActivePatterns/lib/keywordChecker.mli diff --git a/FSharpActivePatterns/lib/ast.mli b/FSharpActivePatterns/lib/ast.ml similarity index 58% rename from FSharpActivePatterns/lib/ast.mli rename to FSharpActivePatterns/lib/ast.ml index a76cd49ae..bed92fb84 100644 --- a/FSharpActivePatterns/lib/ast.mli +++ b/FSharpActivePatterns/lib/ast.ml @@ -2,15 +2,36 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) +open KeywordChecker + type ident = Ident of string * string option (** identifier *) [@@deriving eq, show { with_path = false }] +let gen_varname = + let open QCheck.Gen in + let loop = + let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in + let gen_first_char = + oneof [ gen_char_of_range 'a' 'z'; gen_char_of_range 'A' 'Z'; return '_' ] + in + let gen_next_char = oneof [ gen_first_char; gen_char_of_range '0' '9' ] in + map2 + (fun first rest -> + String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) + gen_first_char + (list_size (1 -- 5) gen_next_char) + in + loop >>= fun name -> if is_keyword name then loop else return name +;; + +let gen_ident = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname + type literal = | Int_lt of int (** [0], [1], [30] *) | Bool_lt of bool (** [false], [true] *) | String_lt of string (** ["Hello world"] *) | Unit_lt (** [Unit] *) -[@@deriving eq, show { with_path = false }] +[@@deriving eq, show { with_path = false }, qcheck] type binary_operator = | Binary_equal (** [=] *) @@ -28,31 +49,36 @@ type binary_operator = | Binary_or_bitwise (** [|||] *) | Binary_xor_bitwise (** [^^^] *) | Binary_and_bitwise (** [&&&] *) -[@@deriving eq, show { with_path = false }] +[@@deriving eq, show { with_path = false }, qcheck] type unary_operator = | Unary_minus (** unary [-] *) | Unary_not (** unary [not] *) -[@@deriving eq, show { with_path = false }] +[@@deriving eq, show { with_path = false }, qcheck] type pattern = | Wild (** [_] *) | PEmptyList (** [] *) | PCons of pattern * pattern (** | [hd :: tl] -> *) - | PTuple of pattern list (** | [(a, b)] -> *) + | PTuple of pattern * pattern * pattern list (** | [(a, b)] -> *) + (* [@gen QCheck.Gen.(list_size (0 -- 15) gen_pattern_sized ) ] *) | PConst of literal (** | [4] -> *) | PVar of ident (** pattern identifier *) | Variant of ident list (** | [Blue, Green, Yellow] -> *) -[@@deriving eq, show { with_path = false }] + (* [@gen QCheck.Gen.(list_size (0 -- 15) gen_ident ) ] *) +[@@deriving eq, show { with_path = false }, qcheck] + +let gen_pattern = QCheck.Gen.sized gen_pattern_sized type is_recursive = | Nonrec (** let factorial n = ... *) | Rec (** let rec factorial n = ... *) -[@@deriving eq, show { with_path = false }] +[@@deriving eq, show { with_path = false }, qcheck] type expr = | Const of literal (** [Int], [Bool], [String], [Unit], [Null] *) | Tuple of expr * expr * expr list (** [(1, "Hello world", true)] *) + (* [@gen QCheck.Gen.(list_size (0 -- 15) gen_expr ) ] *) | Empty_list (** [] *) | Cons_list of expr * expr (** {[ @@ -66,20 +92,23 @@ type expr = | Function_call of expr * expr (** [sum 1 ] *) | Match of expr * pattern * expr * (pattern * expr) list (** [match x with | x -> ... | y -> ...] *) + (* [@gen QCheck.Gen.(quad gen_expr_sized gen_pattern_sized gen_expr_sized (list_size (0 -- 15) ( pair gen_pattern_sized gen_expr_sized)))] *) | LetIn of is_recursive * let_bind * let_bind list * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) + (* [@gen QCheck.Gen.(quad gen_is_recursive gen_let_bind (list_size (0--15) gen_let_bind) gen_expr_sized)] *) | Option of expr option (** [int option] *) -[@@deriving eq, show { with_path = false }] +[@@deriving eq, show { with_path = false }, qcheck] -and let_bind = Let_bind of ident * ident list * expr (** [and sum n m = n+m] *) +and let_bind = Let_bind of ident * ident list * expr (** [and sum n m = n+m] *)[@@deriving eq, show {with_path = false}, qcheck] type statement = | Let of is_recursive * let_bind * let_bind list (** [let name = expr] *) + (* [@gen QCheck.Gen.(triple gen_is_recursive gen_let_bind (list_size (0 --15) gen_let_bind) ) ] *) | ActivePattern of ident list * expr (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *) -[@@deriving eq, show { with_path = false }] +[@@deriving eq, show { with_path = false }, qcheck] type construction = - | Expr of expr (** expression *) + | Expr of expr (** expression *) [@gen QCheck.Gen.sized gen_expr_sized] | Statement of statement (** statement *) -[@@deriving eq, show { with_path = false }] +[@@deriving eq, show { with_path = false }, qcheck] diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 32384ce41..7b81d8058 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -38,9 +38,9 @@ let rec print_pattern indent fmt = function print_pattern (indent + 4) fmt head; fprintf fmt "%sTail:\n" (String.make (indent + 2) '-'); print_pattern (indent + 4) fmt tail - | PTuple tuple -> + | PTuple (p1, p2, rest) -> fprintf fmt "%s| PTuple:\n" (String.make indent '-'); - List.iter (print_pattern (indent + 2) fmt) tuple + List.iter (print_pattern (indent + 2) fmt) (p1 :: p2 :: rest) | PConst literal -> fprintf fmt "%s| PConst:\n" (String.make indent '-'); (match literal with diff --git a/FSharpActivePatterns/lib/dune b/FSharpActivePatterns/lib/dune index 44a441777..463c93066 100644 --- a/FSharpActivePatterns/lib/dune +++ b/FSharpActivePatterns/lib/dune @@ -1,10 +1,9 @@ (library (name FSharpActivePatterns) (public_name FSharpActivePatterns) - (modules Ast Parser AstPrinter PrettyPrinter) - (modules_without_implementation ast) + (modules Ast Parser AstPrinter PrettyPrinter KeywordChecker) (libraries angstrom base) (preprocess - (pps ppx_deriving.show ppx_deriving.eq)) + (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) (instrumentation (backend bisect_ppx))) diff --git a/FSharpActivePatterns/lib/keywordChecker.ml b/FSharpActivePatterns/lib/keywordChecker.ml new file mode 100644 index 000000000..084c558ff --- /dev/null +++ b/FSharpActivePatterns/lib/keywordChecker.ml @@ -0,0 +1,20 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +let is_keyword = function + | "if" + | "then" + | "else" + | "let" + | "in" + | "not" + | "true" + | "false" + | "fun" + | "match" + | "with" + | "and" + | "_" -> true + | _ -> false +;; diff --git a/FSharpActivePatterns/lib/keywordChecker.mli b/FSharpActivePatterns/lib/keywordChecker.mli new file mode 100644 index 000000000..63931a206 --- /dev/null +++ b/FSharpActivePatterns/lib/keywordChecker.mli @@ -0,0 +1,5 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +val is_keyword : string -> bool diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 3e6d98f90..2c23a7b81 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -5,6 +5,7 @@ open Angstrom open Ast open Base +open KeywordChecker (* TECHNICAL FUNCTIONS *) @@ -54,23 +55,6 @@ let p_bool = >>| fun s -> Const (Bool_lt (Bool.of_string s)) ;; -let is_keyword = function - | "if" - | "then" - | "else" - | "let" - | "in" - | "not" - | "true" - | "false" - | "fun" - | "match" - | "with" - | "and" - | "_" -> true - | _ -> false -;; - let p_type = skip_ws *> char ':' diff --git a/FSharpActivePatterns/lib/parser.mli b/FSharpActivePatterns/lib/parser.mli index 6e162ef4b..19a074986 100644 --- a/FSharpActivePatterns/lib/parser.mli +++ b/FSharpActivePatterns/lib/parser.mli @@ -5,4 +5,3 @@ open Ast val parse : string -> construction option -val is_keyword : string -> bool From 0b2933009d52fe078e0c2a8c9ee09aadaab7dc8e Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 16 Nov 2024 08:41:27 +0300 Subject: [PATCH 143/310] feat: implement lists, tuple and variables patterns parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 90 ++++++++++++++++++------------ 1 file changed, 53 insertions(+), 37 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 2c23a7b81..5a155b845 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -82,45 +82,51 @@ let p_ident = else p_type >>| fun type_opt -> Ident (str, type_opt) ;; -let p_var = p_ident >>| fun ident -> Variable ident +let p_var_expr = p_ident >>| fun ident -> Variable ident +let p_var_pat = p_ident >>| fun ident -> PVar ident -let p_empty_list = - skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws >>= fun _ -> return Empty_list +let p_empty_list empty_list = + skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws *> return empty_list ;; -let make_list expr1 expr2 = Cons_list (expr1, expr2) +let p_empty_list_expr = p_empty_list Empty_list +let p_empty_list_pat = p_empty_list PEmptyList +let make_cons_expr e1 e2 = Cons_list (e1, e2) +let make_cons_pat p1 p2 = PCons (p1, p2) -let p_cons_list p_expr = +let p_cons_list p p_empty_list make_list = skip_ws - *> chainr1 - (p_expr <|> p_empty_list) - (skip_ws *> string "::" *> skip_ws *> return make_list) + *> chainr1 (p <|> p_empty_list) (skip_ws *> string "::" *> skip_ws *> return make_list) ;; -let p_semicolon_list p_expr = +let p_cons_list_expr p_expr = p_cons_list p_expr p_empty_list_expr make_cons_expr +let p_cons_list_pat p_pat = p_cons_list p_pat p_empty_list_pat make_cons_pat + +let p_semicolon_list p empty_list cons_list = skip_ws *> string "[" *> skip_ws *> fix (fun p_semi_list -> choice - [ (p_expr + [ (p <* skip_ws <* string ";" <* skip_ws - >>= fun expr -> p_semi_list >>= fun rest -> return (Cons_list (expr, rest))) - ; (p_expr - <* skip_ws - <* string "]" - <* skip_ws - >>| fun expr -> Cons_list (expr, Empty_list)) - ; (string "]" *> skip_ws >>= fun _ -> return Empty_list) + >>= fun hd -> p_semi_list >>= fun tl -> return (cons_list hd tl)) + ; (p <* skip_ws <* string "]" <* skip_ws >>| fun hd -> cons_list hd empty_list) + ; string "]" *> skip_ws *> return empty_list ]) ;; +let p_semicolon_list_expr p_expr = p_semicolon_list p_expr Empty_list make_cons_expr +let p_semicolon_list_pat p_pat = p_semicolon_list p_pat PEmptyList make_cons_pat + (* EXPR PARSERS *) let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' let make_binexpr op expr1 expr2 = Bin_expr (op, expr1, expr2) [@@inline always] let make_unexpr op expr = Unary_expr (op, expr) [@@inline always] +let make_tuple_expr e1 e2 rest = Tuple (e1, e2, rest) [@@inline always] +let make_tuple_pat p1 p2 rest = PTuple (p1, p2, rest) let p_binexpr binop_str binop = skip_ws *> string binop_str *> skip_ws *> return (make_binexpr binop) @@ -145,18 +151,21 @@ let greater_or_equal = p_binexpr ">=" Binary_greater_or_equal let log_or = p_binexpr "||" Logical_or let log_and = p_binexpr "&&" Logical_and -let p_tuple p_expr = +let p_tuple make p = skip_ws *> string "(" *> lift3 - (fun fst snd tail -> Tuple (fst, snd, tail)) - p_expr - (skip_ws *> string "," *> skip_ws *> p_expr) - (many (skip_ws *> string "," *> skip_ws *> p_expr)) + (fun fst snd tail -> make fst snd tail) + p + (skip_ws *> string "," *> skip_ws *> p) + (many (skip_ws *> string "," *> skip_ws *> p)) <* skip_ws <* string ")" ;; +let p_tuple_expr p_expr = p_tuple make_tuple_expr p_expr +let p_tuple_pat p_pat = p_tuple make_tuple_pat p_pat + let p_if p_expr = lift3 (fun cond th el -> If_then_else (cond, th, el)) @@ -184,7 +193,7 @@ let p_letin p_expr = skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) >>= fun rec_flag -> p_ident - >>= (fun name -> return name) + >>= return >>= fun name -> skip_ws *> many (skip_ws *> p_ident) >>= fun args -> @@ -214,14 +223,15 @@ let p_let p_expr = let app_first expr = skip_ws *> fix (fun a_exp -> - let expr = choice [ p_var; p_if expr; p_letin expr; p_parens a_exp ] in + let expr = choice [ p_var_expr; p_if expr; p_letin expr; p_parens a_exp ] in expr) ;; let p_apply expr = let* name = app_first expr in let rec parse_args acc = - skip_ws *> choice [ p_var; p_bool; p_int; p_if expr; p_letin expr; p_parens expr ] + skip_ws + *> choice [ p_var_expr; p_bool; p_int; p_if expr; p_letin expr; p_parens expr ] >>= (fun arg -> parse_args (Function_call (acc, arg))) <|> return acc in @@ -242,32 +252,38 @@ let make_cons_pat pat1 pat2 = PCons (pat1, pat2) (skip_ws *> string "::" *> skip_ws *> return make_cons_pat) *) let p_pat = - fix (fun p_pat -> + fix (fun self -> skip_ws - *> string "|" - *> skip_ws *> choice - [ (string "_" *> skip_ws *> string "->" *> skip_ws >>= fun _ -> return Wild) ]) + [ p_tuple_pat self + ; p_empty_list_pat + ; p_semicolon_list_pat self + ; p_cons_list_pat p_var_pat + ; p_var_pat + ; string "_" *> return Wild + ]) + <* skip_ws + <* string "->" ;; let p_match p_expr = lift4 (fun value pat1 expr1 list -> Match (value, pat1, expr1, list)) - (skip_ws *> string "match" *> skip_ws *> p_expr <* skip_ws <* string "with" <* skip_ws) - (skip_ws *> p_pat <* skip_ws) - (skip_ws *> p_expr <* skip_ws) + (skip_ws *> string "match" *> p_expr <* skip_ws <* string "with") + (skip_ws *> string "|" *> p_pat) + (skip_ws *> p_expr) (many - (skip_ws *> p_pat - >>= fun pat -> p_expr <* skip_ws >>= fun expr -> return (pat, expr))) + (skip_ws *> string "|" *> p_pat + >>= fun pat -> p_expr >>= fun expr -> return (pat, expr))) ;; let p_expr = skip_ws *> fix (fun p_expr -> let atom = - choice [ p_var; p_int; p_bool; p_parens p_expr; p_semicolon_list p_expr ] + choice [ p_var_expr; p_int; p_bool; p_parens p_expr; p_semicolon_list_expr p_expr ] in - let tuple = p_tuple (p_expr <|> atom) <|> atom in + let tuple = p_tuple make_tuple_expr (p_expr <|> atom) <|> atom in let if_expr = p_if (p_expr <|> tuple) <|> tuple in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in let apply = p_apply (p_expr <|> letin_expr) <|> letin_expr in @@ -279,7 +295,7 @@ let p_expr = let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in let comp_and = chainl1 comp_gr log_and in let comp_or = chainl1 comp_and log_or in - let cons_list = p_cons_list comp_or <|> comp_or in + let cons_list = p_cons_list_expr comp_or <|> comp_or in let ematch = p_match cons_list <|> cons_list in let option = p_option ematch <|> ematch in option) From 62ff5c7fa1b68f3ac901e99453d7031cb1385ed7 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 16 Nov 2024 08:48:36 +0300 Subject: [PATCH 144/310] fix: add open KeywordChecker Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/gen_construction.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 7e81dea69..d0e327fc8 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -10,6 +10,7 @@ open FSharpActivePatterns.Ast open FSharpActivePatterns.AstPrinter open FSharpActivePatterns.Parser open FSharpActivePatterns.PrettyPrinter +open FSharpActivePatterns.KeywordChecker let int_e x = Const (Int_lt x) let bool_e x = Const (Bool_lt x) From c62880f979ca58c49847bbfa26eee8178be3dceb Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 16 Nov 2024 08:51:38 +0300 Subject: [PATCH 145/310] feat: add more shrinkers Signed-off-by: Gleb Nasretdinov --- .../lib/tests/gen_construction.ml | 89 +++++++++++-------- 1 file changed, 54 insertions(+), 35 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index d0e327fc8..4b5bc04a8 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -18,7 +18,7 @@ let unit_e = Const Unit_lt let string_e x = Const (String_lt x) let variable_e x = Variable (Ident (x, None)) -let gen_const = +let gen_const_manual = QCheck.Gen.( frequency [ 1, map int_e nat @@ -28,7 +28,7 @@ let gen_const = ]) ;; -let gen_varname = +let gen_varname_manual = let open QCheck.Gen in let loop = let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in @@ -45,9 +45,9 @@ let gen_varname = loop >>= fun name -> if is_keyword name then loop else return name ;; -let gen_ident = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname -let gen_variable = QCheck.Gen.map variable_e gen_varname -let gen_unop = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) +let gen_ident_manual = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname_manual +let gen_variable_manual = QCheck.Gen.map variable_e gen_varname_manual +let gen_unop_manual = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) let tuple_e e1 e2 rest = Tuple (e1, e2, rest) let un_e unop e = Unary_expr (unop, e) let bin_e op e1 e2 = Bin_expr (op, e1, e2) @@ -60,7 +60,7 @@ let letin rec_flag let_bind let_bind_list inner_e = LetIn (rec_flag, let_bind, let_bind_list, inner_e) ;; -let gen_binop = +let gen_binop_manual = QCheck.Gen.( oneof @@ List.map @@ -83,18 +83,18 @@ let gen_binop = ]) ;; -let gen_rec_flag = QCheck.Gen.(oneof [ return Rec; return Nonrec ]) +let gen_is_recursive_manual = QCheck.Gen.(oneof [ return Rec; return Nonrec ]) -let gen_let_bind gen = - QCheck.Gen.(map3 let_bind gen_ident (list_size (0 -- 15) gen_ident) gen) +let gen_let_bind_manual gen = + QCheck.Gen.(map3 let_bind gen_ident_manual (list_size (0 -- 15) gen_ident_manual) gen) ;; -let gen_expr = +let gen_expr_manual = QCheck.Gen.( sized @@ fix (fun self -> function - | 0 -> frequency [ 1, gen_const; 1, gen_variable ] + | 0 -> frequency [ 1, gen_const_manual; 1, gen_variable_manual ] | n -> frequency [ ( 0 @@ -103,23 +103,23 @@ let gen_expr = (self (n / 2)) (self (n / 2)) (list_size (0 -- 15) (self (n / 2))) ) - ; 1, map2 un_e gen_unop (self (n / 2)) - ; 1, map3 bin_e gen_binop (self (n / 2)) (self (n / 2)) + ; 1, map2 un_e gen_unop_manual (self (n / 2)) + ; 1, map3 bin_e gen_binop_manual (self (n / 2)) (self (n / 2)) ; ( 1 , map3 if_e (self (n / 2)) (self (n / 2)) (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) - ; 0, map2 func_def (list_size (0 -- 15) gen_ident) (self (n / 2)) - ; 1, map2 func_call gen_variable (self (n / 2)) + ; 0, map2 func_def (list_size (0 -- 15) gen_ident_manual) (self (n / 2)) + ; 1, map2 func_call gen_variable_manual (self (n / 2)) (* TODO: make apply of arbitrary expr*) ; ( 0 , map3 letin - gen_rec_flag - (gen_let_bind (self (n / 2))) - (list_size (0 -- 15) (gen_let_bind (self (n / 2)))) + gen_is_recursive_manual + (gen_let_bind_manual (self (n / 2))) + (list_size (0 -- 15) (gen_let_bind_manual (self (n / 2)))) <*> self (n / 2) ) ])) ;; @@ -145,18 +145,24 @@ and shrink_expr = let open QCheck.Iter in function | Const lt -> shrink_lt lt - | Variable _ -> empty | Tuple (e1, e2, rest) -> of_list [ e1; e2 ] <+> (shrink_expr e1 >|= fun a' -> Tuple (a', e2, rest)) <+> (shrink_expr e2 >|= fun a' -> Tuple (e1, a', rest)) <+> (QCheck.Shrink.list ~shrink:shrink_expr rest >|= fun a' -> Tuple (e1, e2, a')) + | Cons_list (e1, e2) -> + of_list [ e1; e2 ] + <+> (shrink_expr e1 >|= fun a' -> Cons_list (a', e2)) + <+> (shrink_expr e2 >|= fun a' -> Cons_list (e1, a')) | Unary_expr (op, e) -> return e <+> shrink_expr e >|= fun a' -> un_e op a' | Bin_expr (op, e1, e2) -> of_list [ e1; e2 ] <+> (shrink_expr e1 >|= fun a' -> bin_e op a' e2) <+> (shrink_expr e2 >|= fun a' -> bin_e op e1 a') - | If_then_else (i, t, Some _) -> return (If_then_else (i, t, None)) + | If_then_else (i, t, Some e) -> + of_list [ i; t; e; If_then_else (i, e, None) ] + <+> (shrink_expr i >|= fun a' -> If_then_else (a', t, Some e)) + <+> (shrink_expr t >|= fun a' -> If_then_else (i, a', Some e)) | If_then_else (i, t, None) -> of_list [ i; t ] <+> (shrink_expr i >|= fun a' -> If_then_else (a', t, None)) @@ -167,33 +173,40 @@ and shrink_expr = >|= fun a' -> LetIn (rec_flag, a', let_bind_list, inner_e)) <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list >|= fun a' -> LetIn (rec_flag, let_bind, a', inner_e)) - <+> shrink_expr inner_e - >|= fun a' -> LetIn (rec_flag, let_bind, let_bind_list, a') + <+> (shrink_expr inner_e >|= fun a' -> LetIn (rec_flag, let_bind, let_bind_list, a')) | Function_call (f, arg) -> - shrink_expr f - >|= (fun a' -> Function_call (a', arg)) - <+> shrink_expr arg - >|= fun a' -> Function_call (f, a') + of_list [ f; arg ] + <+> (shrink_expr f >|= fun a' -> Function_call (a', arg)) + <+> (shrink_expr arg >|= fun a' -> Function_call (f, a')) | Lambda (args, body) -> return body <+> (QCheck.Shrink.list args >|= fun a' -> Lambda (a', body)) <+> (shrink_expr body >|= fun a' -> Lambda (args, a')) + | Match (value, pat1, expr1, cases) -> + of_list [ value; expr1 ] + <+> (shrink_expr value >|= fun a' -> Match (a', pat1, expr1, cases)) + <+> (shrink_expr expr1 >|= fun a' -> Match (value, pat1, a', cases)) + <+> (QCheck.Shrink.list + ~shrink:(fun (p, e) -> shrink_expr e >|= fun a' -> p, a') + cases + >|= fun a' -> Match (value, pat1, expr1, a')) + | Option (Some e) -> + of_list [ e; Option None ] <+> (shrink_expr e >|= fun a' -> Option (Some a')) | _ -> empty ;; let let_st rec_flag let_bind let_bind_list = Let (rec_flag, let_bind, let_bind_list) (* TODO: Active Pattern*) -let gen_statement = +let gen_statement_manual = QCheck.Gen.( map3 let_st - gen_rec_flag - (gen_let_bind gen_expr) - (list_size (0 -- 15) (gen_let_bind gen_expr))) + gen_is_recursive_manual + (gen_let_bind_manual gen_expr) + (list_size (0 -- 15) (gen_let_bind_manual gen_expr))) ;; -(* TODO: Active Pattern *) let shrink_statement = let open QCheck.Iter in function @@ -202,12 +215,18 @@ let shrink_statement = >|= (fun a' -> Let (rec_flag, a', let_bind_list)) <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list >|= fun a' -> Let (rec_flag, let_bind, a')) - | _ -> empty + | ActivePattern (cases, e) -> + QCheck.Shrink.list cases + >|= (fun a' -> ActivePattern (a', e)) + <+> (shrink_expr e >|= fun a' -> ActivePattern (cases, a')) ;; -let gen_construction = +let gen_construction_manual = QCheck.Gen.( - oneof [ (gen_expr >|= fun a' -> Expr a'); (gen_statement >|= fun a' -> Statement a') ]) + oneof + [ (gen_expr_manual >|= fun a' -> Expr a') + ; (gen_statement_manual >|= fun a' -> Statement a') + ]) ;; let shrink_construction = @@ -219,7 +238,7 @@ let shrink_construction = let arbitrary_construction = QCheck.make - gen_construction + gen_construction_manual ~print:(Format.asprintf "%a" print_construction) ~shrink:shrink_construction ;; From c19aa0dd656daff1b66bd3f07007d88b5bfc44b8 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 16 Nov 2024 09:03:29 +0300 Subject: [PATCH 146/310] ref: remove unused function Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index bed92fb84..f2a262501 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -68,8 +68,6 @@ type pattern = (* [@gen QCheck.Gen.(list_size (0 -- 15) gen_ident ) ] *) [@@deriving eq, show { with_path = false }, qcheck] -let gen_pattern = QCheck.Gen.sized gen_pattern_sized - type is_recursive = | Nonrec (** let factorial n = ... *) | Rec (** let rec factorial n = ... *) From 1a89bbfe2dc3edb2fcadd755af977d6a09d2b268 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 16 Nov 2024 09:05:09 +0300 Subject: [PATCH 147/310] fix: reduce deep of manual generator Signed-off-by: Gleb Nasretdinov --- .../lib/tests/gen_construction.ml | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 4b5bc04a8..2b5d7af32 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -97,30 +97,30 @@ let gen_expr_manual = | 0 -> frequency [ 1, gen_const_manual; 1, gen_variable_manual ] | n -> frequency - [ ( 0 + [ ( 1 , map3 tuple_e - (self (n / 2)) - (self (n / 2)) - (list_size (0 -- 15) (self (n / 2))) ) - ; 1, map2 un_e gen_unop_manual (self (n / 2)) - ; 1, map3 bin_e gen_binop_manual (self (n / 2)) (self (n / 2)) + (self (n / 4)) + (self (n / 4)) + (list_size (0 -- 15) (self (n / 4))) ) + ; 1, map2 un_e gen_unop_manual (self (n / 4)) + ; 1, map3 bin_e gen_binop_manual (self (n / 4)) (self (n / 4)) ; ( 1 , map3 if_e - (self (n / 2)) - (self (n / 2)) - (oneof [ return None; map (fun e -> Some e) (self (n / 2)) ]) ) - ; 0, map2 func_def (list_size (0 -- 15) gen_ident_manual) (self (n / 2)) - ; 1, map2 func_call gen_variable_manual (self (n / 2)) + (self (n / 4)) + (self (n / 4)) + (oneof [ return None; map (fun e -> Some e) (self (n / 4)) ]) ) + ; 0, map2 func_def (list_size (0 -- 15) gen_ident_manual) (self (n / 4)) + ; 1, map2 func_call gen_variable_manual (self (n / 4)) (* TODO: make apply of arbitrary expr*) ; ( 0 , map3 letin gen_is_recursive_manual - (gen_let_bind_manual (self (n / 2))) - (list_size (0 -- 15) (gen_let_bind_manual (self (n / 2)))) - <*> self (n / 2) ) + (gen_let_bind_manual (self (n / 4))) + (list_size (0 -- 15) (gen_let_bind_manual (self (n / 4)))) + <*> self (n / 4) ) ])) ;; From 62c3e4b20dd2c6cd81beda9a5a0ffac0dc836476 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 16 Nov 2024 10:27:29 +0300 Subject: [PATCH 148/310] fix: change auto gen_expr to manual in manual gen_statement Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/gen_construction.ml | 4 ++-- FSharpActivePatterns/tests/qcheck.t | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 2b5d7af32..63167b311 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -203,8 +203,8 @@ let gen_statement_manual = map3 let_st gen_is_recursive_manual - (gen_let_bind_manual gen_expr) - (list_size (0 -- 15) (gen_let_bind_manual gen_expr))) + (gen_let_bind_manual gen_expr_manual) + (list_size (0 -- 15) (gen_let_bind_manual gen_expr_manual))) ;; let shrink_statement = diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index fea0d2a05..63f8d33c8 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_construction.exe -seed 1 -gen 30 -stop + $ ../lib/tests/run_construction.exe -seed 1 -gen 100 -stop random seed: 1 ================================================================================ success (ran 1 tests) From 67a84f431c4dd4b856e1ab877dc03f20e6ce5fbd Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 16 Nov 2024 16:33:32 +0300 Subject: [PATCH 149/310] feat: add const parsing to patterns (match), rework const parsing Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 40 ++++++++++++++++++++++++------ 1 file changed, 32 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 5a155b845..ad5643bd0 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -45,16 +45,19 @@ let rec unary_chain op e = ;; (* SIMPLE PARSERS *) -let p_int = - skip_ws *> take_while1 Char.is_digit >>| fun s -> Const (Int_lt (Int.of_string s)) -;; +let expr_const_factory parser = parser >>| fun lit -> Const lit +let pat_const_factory parser = parser >>| fun lit -> PConst lit +let p_int = skip_ws *> take_while1 Char.is_digit >>| fun s -> Int_lt (Int.of_string s) +let p_int_expr = expr_const_factory p_int +let p_int_pat = pat_const_factory p_int let p_bool = - skip_ws *> string "true" - <|> string "false" - >>| fun s -> Const (Bool_lt (Bool.of_string s)) + skip_ws *> string "true" <|> string "false" >>| fun s -> Bool_lt (Bool.of_string s) ;; +let p_bool_expr = expr_const_factory p_bool +let p_bool_pat = pat_const_factory p_bool + let p_type = skip_ws *> char ':' @@ -120,6 +123,9 @@ let p_semicolon_list p empty_list cons_list = let p_semicolon_list_expr p_expr = p_semicolon_list p_expr Empty_list make_cons_expr let p_semicolon_list_pat p_pat = p_semicolon_list p_pat PEmptyList make_cons_pat +let p_unit = skip_ws *> string "(" *> skip_ws *> string ")" *> skip_ws *> return Unit_lt +let p_unit_expr = expr_const_factory p_unit +let p_unit_pat = pat_const_factory p_unit (* EXPR PARSERS *) let p_parens p = skip_ws *> char '(' *> skip_ws *> p <* skip_ws <* char ')' @@ -231,7 +237,15 @@ let p_apply expr = let* name = app_first expr in let rec parse_args acc = skip_ws - *> choice [ p_var_expr; p_bool; p_int; p_if expr; p_letin expr; p_parens expr ] + *> choice + [ p_var_expr + ; p_bool_expr + ; p_unit_expr + ; p_int_expr + ; p_if expr + ; p_letin expr + ; p_parens expr + ] >>= (fun arg -> parse_args (Function_call (acc, arg))) <|> return acc in @@ -251,6 +265,8 @@ let make_cons_pat pat1 pat2 = PCons (pat1, pat2) (p_pat <|> p_empty_list) (skip_ws *> string "::" *> skip_ws *> return make_cons_pat) *) +let p_pat_const = choice [ p_int_pat; p_bool_pat; p_unit_pat ] + let p_pat = fix (fun self -> skip_ws @@ -260,6 +276,7 @@ let p_pat = ; p_semicolon_list_pat self ; p_cons_list_pat p_var_pat ; p_var_pat + ; p_pat_const ; string "_" *> return Wild ]) <* skip_ws @@ -281,7 +298,14 @@ let p_expr = skip_ws *> fix (fun p_expr -> let atom = - choice [ p_var_expr; p_int; p_bool; p_parens p_expr; p_semicolon_list_expr p_expr ] + choice + [ p_var_expr + ; p_int_expr + ; p_unit_expr + ; p_bool_expr + ; p_parens p_expr + ; p_semicolon_list_expr p_expr + ] in let tuple = p_tuple make_tuple_expr (p_expr <|> atom) <|> atom in let if_expr = p_if (p_expr <|> tuple) <|> tuple in From 61c9649095efe440d0aa2edd2470b7f9049b5bcd Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 16 Nov 2024 16:44:28 +0300 Subject: [PATCH 150/310] fix: add separator to option parsing Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index ad5643bd0..2c72cbef4 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -253,8 +253,8 @@ let p_apply expr = ;; let p_option p_expr = - skip_ws *> (string "None" *> return (Option None)) - <|> (skip_ws *> string "Some" *> p_expr >>| fun expr -> Option (Some expr)) + skip_ws *> (string "None" *> skip_ws_sep1 *> return (Option None)) + <|> (skip_ws *> string "Some" *> skip_ws_sep1 *> p_expr >>| fun expr -> Option (Some expr)) ;; let make_cons_pat pat1 pat2 = PCons (pat1, pat2) From 49ae652868ee25cc7bc37f659419adf973665cf7 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 17 Nov 2024 11:30:22 +0300 Subject: [PATCH 151/310] fix: rewrite let and letin via let* Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 2c72cbef4..411647ce6 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -195,7 +195,8 @@ let p_let_bind p_expr = (skip_ws *> string "=" *> skip_ws *> p_expr) ;; -let p_letin p_expr = +(* +let p_letin2 p_expr = skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) >>= fun rec_flag -> p_ident @@ -210,8 +211,20 @@ let p_letin p_expr = skip_ws *> string "in" *> skip_ws_sep1 *> p_expr >>= fun in_expr -> return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) +;; *) + +let p_letin p_expr = + skip_ws *> string "let" *> skip_ws_sep1 *> + let* rec_flag = string "rec" *> return Rec <|> return Nonrec in + let* name = skip_ws_sep1 *> p_ident in + let* args = skip_ws *> many (skip_ws *> p_ident) in + let* body = skip_ws *> string "=" *> skip_ws *> p_expr in + let* let_bind_list = skip_ws *> many (skip_ws *> p_let_bind p_expr) in + let* in_expr = skip_ws *> string "in" *> skip_ws_sep1 *> p_expr in + return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) ;; +(* let p_let p_expr = skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) >>= fun rec_flag -> @@ -224,6 +237,16 @@ let p_let p_expr = skip_ws *> many (skip_ws *> p_let_bind p_expr) >>= fun let_bind_list -> return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) +;; *) + +let p_let p_expr = + skip_ws *> string "let" *> skip_ws_sep1 *> + let* rec_flag = string "rec" *> return Rec <|> return Nonrec in + let* name = skip_ws_sep1 *> p_ident in + let* args = skip_ws *> many (skip_ws *> p_ident) in + let* body = skip_ws *> string "=" *> skip_ws *> p_expr in + let* let_bind_list = skip_ws *> many (skip_ws *> p_let_bind p_expr) in + return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) ;; let app_first expr = From 49c31467721265783d344fd94c033f21d820b953 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 17 Nov 2024 11:54:42 +0300 Subject: [PATCH 152/310] feat: add string parser Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 411647ce6..0d6c1ee63 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -58,6 +58,13 @@ let p_bool = let p_bool_expr = expr_const_factory p_bool let p_bool_pat = pat_const_factory p_bool +let p_string = + char '"' *> take_while (fun c -> not (Char.equal c '"')) <* char '"' >>| fun x -> String_lt x +;; + +let p_string_expr = expr_const_factory p_string +let p_string_pat = pat_const_factory p_string + let p_type = skip_ws *> char ':' @@ -265,6 +272,7 @@ let p_apply expr = ; p_bool_expr ; p_unit_expr ; p_int_expr + ; p_string_expr ; p_if expr ; p_letin expr ; p_parens expr @@ -288,7 +296,7 @@ let make_cons_pat pat1 pat2 = PCons (pat1, pat2) (p_pat <|> p_empty_list) (skip_ws *> string "::" *> skip_ws *> return make_cons_pat) *) -let p_pat_const = choice [ p_int_pat; p_bool_pat; p_unit_pat ] +let p_pat_const = choice [ p_int_pat; p_bool_pat; p_unit_pat; p_string_pat ] let p_pat = fix (fun self -> @@ -324,6 +332,7 @@ let p_expr = choice [ p_var_expr ; p_int_expr + ; p_string_expr ; p_unit_expr ; p_bool_expr ; p_parens p_expr From e3d663e788736c414d0d92db6563b51bbec703f3 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 17 Nov 2024 11:57:09 +0300 Subject: [PATCH 153/310] fix: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 83 +++++++++++++++++------------- 1 file changed, 46 insertions(+), 37 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 0d6c1ee63..13c6d96cf 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -58,8 +58,10 @@ let p_bool = let p_bool_expr = expr_const_factory p_bool let p_bool_pat = pat_const_factory p_bool -let p_string = - char '"' *> take_while (fun c -> not (Char.equal c '"')) <* char '"' >>| fun x -> String_lt x +let p_string = + char '"' *> take_while (fun c -> not (Char.equal c '"')) + <* char '"' + >>| fun x -> String_lt x ;; let p_string_expr = expr_const_factory p_string @@ -203,55 +205,61 @@ let p_let_bind p_expr = ;; (* -let p_letin2 p_expr = - skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) - >>= fun rec_flag -> - p_ident - >>= return - >>= fun name -> - skip_ws *> many (skip_ws *> p_ident) - >>= fun args -> - skip_ws *> string "=" *> skip_ws *> p_expr - >>= fun body -> - skip_ws *> many (skip_ws *> p_let_bind p_expr) - >>= fun let_bind_list -> - skip_ws *> string "in" *> skip_ws_sep1 *> p_expr - >>= fun in_expr -> - return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) -;; *) + let p_letin2 p_expr = + skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) + >>= fun rec_flag -> + p_ident + >>= return + >>= fun name -> + skip_ws *> many (skip_ws *> p_ident) + >>= fun args -> + skip_ws *> string "=" *> skip_ws *> p_expr + >>= fun body -> + skip_ws *> many (skip_ws *> p_let_bind p_expr) + >>= fun let_bind_list -> + skip_ws *> string "in" *> skip_ws_sep1 *> p_expr + >>= fun in_expr -> + return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) + ;; *) let p_letin p_expr = - skip_ws *> string "let" *> skip_ws_sep1 *> + skip_ws + *> string "let" + *> skip_ws_sep1 + *> let* rec_flag = string "rec" *> return Rec <|> return Nonrec in let* name = skip_ws_sep1 *> p_ident in let* args = skip_ws *> many (skip_ws *> p_ident) in - let* body = skip_ws *> string "=" *> skip_ws *> p_expr in + let* body = skip_ws *> string "=" *> skip_ws *> p_expr in let* let_bind_list = skip_ws *> many (skip_ws *> p_let_bind p_expr) in let* in_expr = skip_ws *> string "in" *> skip_ws_sep1 *> p_expr in return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) ;; (* -let p_let p_expr = - skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) - >>= fun rec_flag -> - p_ident - >>= fun name -> - skip_ws *> many (skip_ws *> p_ident) - >>= fun args -> - skip_ws *> string "=" *> skip_ws *> p_expr - >>= fun body -> - skip_ws *> many (skip_ws *> p_let_bind p_expr) - >>= fun let_bind_list -> - return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) -;; *) + let p_let p_expr = + skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) + >>= fun rec_flag -> + p_ident + >>= fun name -> + skip_ws *> many (skip_ws *> p_ident) + >>= fun args -> + skip_ws *> string "=" *> skip_ws *> p_expr + >>= fun body -> + skip_ws *> many (skip_ws *> p_let_bind p_expr) + >>= fun let_bind_list -> + return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) + ;; *) let p_let p_expr = - skip_ws *> string "let" *> skip_ws_sep1 *> + skip_ws + *> string "let" + *> skip_ws_sep1 + *> let* rec_flag = string "rec" *> return Rec <|> return Nonrec in - let* name = skip_ws_sep1 *> p_ident in + let* name = skip_ws_sep1 *> p_ident in let* args = skip_ws *> many (skip_ws *> p_ident) in - let* body = skip_ws *> string "=" *> skip_ws *> p_expr in + let* body = skip_ws *> string "=" *> skip_ws *> p_expr in let* let_bind_list = skip_ws *> many (skip_ws *> p_let_bind p_expr) in return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) ;; @@ -285,7 +293,8 @@ let p_apply expr = let p_option p_expr = skip_ws *> (string "None" *> skip_ws_sep1 *> return (Option None)) - <|> (skip_ws *> string "Some" *> skip_ws_sep1 *> p_expr >>| fun expr -> Option (Some expr)) + <|> (skip_ws *> string "Some" *> skip_ws_sep1 *> p_expr + >>| fun expr -> Option (Some expr)) ;; let make_cons_pat pat1 pat2 = PCons (pat1, pat2) From 96a68b7d4d65c82d20c4d8d29260129cde540908 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 17 Nov 2024 18:40:12 +0300 Subject: [PATCH 154/310] fix: treat rec flag correctly Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 13c6d96cf..981cd216f 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -227,8 +227,8 @@ let p_letin p_expr = *> string "let" *> skip_ws_sep1 *> - let* rec_flag = string "rec" *> return Rec <|> return Nonrec in - let* name = skip_ws_sep1 *> p_ident in + let* rec_flag = string "rec" *> skip_ws_sep1 *> return Rec <|> return Nonrec in + let* name = p_ident in let* args = skip_ws *> many (skip_ws *> p_ident) in let* body = skip_ws *> string "=" *> skip_ws *> p_expr in let* let_bind_list = skip_ws *> many (skip_ws *> p_let_bind p_expr) in @@ -256,8 +256,8 @@ let p_let p_expr = *> string "let" *> skip_ws_sep1 *> - let* rec_flag = string "rec" *> return Rec <|> return Nonrec in - let* name = skip_ws_sep1 *> p_ident in + let* rec_flag = string "rec" *> skip_ws_sep1 *> return Rec <|> return Nonrec in + let* name = p_ident in let* args = skip_ws *> many (skip_ws *> p_ident) in let* body = skip_ws *> string "=" *> skip_ws *> p_expr in let* let_bind_list = skip_ws *> many (skip_ws *> p_let_bind p_expr) in From f53cbc2390a638394498c7f65ba4a16c099d6e64 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 17 Nov 2024 23:00:09 +0300 Subject: [PATCH 155/310] fix: edit print of pattern tuple Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/prettyPrinter.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 9eec35c84..5b1eaf9a3 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -37,7 +37,10 @@ let rec pp_pattern fmt = function | Wild -> fprintf fmt "_ " | PEmptyList -> fprintf fmt "[] " | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl - | PTuple _ -> fprintf fmt "TUPLE PAT WIP" + | PTuple (p1, p2, rest) -> + fprintf fmt "("; + pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_pattern fmt (p1 :: p2 :: rest); + fprintf fmt ")" | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) | PVar (Ident (name, _)) -> fprintf fmt "%s " name | Variant _ -> fprintf fmt "VARIANTS PAT WIP" From 9861db7f755aabb62c6fbb2f22d1037ee6d359bd Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 17 Nov 2024 23:00:36 +0300 Subject: [PATCH 156/310] fix: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/prettyPrinter.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 5b1eaf9a3..c5b0951ac 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -37,9 +37,13 @@ let rec pp_pattern fmt = function | Wild -> fprintf fmt "_ " | PEmptyList -> fprintf fmt "[] " | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl - | PTuple (p1, p2, rest) -> + | PTuple (p1, p2, rest) -> fprintf fmt "("; - pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_pattern fmt (p1 :: p2 :: rest); + pp_print_list + ~pp_sep:(fun fmt () -> fprintf fmt ", ") + pp_pattern + fmt + (p1 :: p2 :: rest); fprintf fmt ")" | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) | PVar (Ident (name, _)) -> fprintf fmt "%s " name From 0e0ee3434716f10df33dea77ac490d7a8ba41ee6 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sun, 17 Nov 2024 23:05:00 +0300 Subject: [PATCH 157/310] fix: print of args in lambda Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/prettyPrinter.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index c5b0951ac..05665ec38 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -84,7 +84,9 @@ and pp_expr fmt expr = | None -> ()) | Lambda (args, body) -> fprintf fmt "fun "; - if args = [] then fprintf fmt "() " else pp_args fmt args; + (match args with + | [] -> fprintf fmt "() " + | _ -> pp_args fmt args); fprintf fmt "-> %a " pp_expr body | Function_call (func, arg) -> fprintf fmt "%a (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> From 4fa270307eea54be9e478b1c93513d8317695c0b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 17 Nov 2024 23:01:17 +0300 Subject: [PATCH 158/310] feat: implement auto-derived qcheck Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 54 +++++++++++++------ .../lib/tests/gen_construction.ml | 2 +- .../lib/tests/run_construction.ml | 12 +++-- FSharpActivePatterns/tests/qcheck.t | 2 +- 4 files changed, 46 insertions(+), 24 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index f2a262501..b36343194 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -25,6 +25,7 @@ let gen_varname = ;; let gen_ident = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname +let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 5) gen_ident) type literal = | Int_lt of int (** [0], [1], [30] *) @@ -60,12 +61,14 @@ type pattern = | Wild (** [_] *) | PEmptyList (** [] *) | PCons of pattern * pattern (** | [hd :: tl] -> *) - | PTuple of pattern * pattern * pattern list (** | [(a, b)] -> *) - (* [@gen QCheck.Gen.(list_size (0 -- 15) gen_pattern_sized ) ] *) + | PTuple of + pattern + * pattern + * (pattern list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_pattern_sized (n / 4)))]) + (** | [(a, b)] -> *) | PConst of literal (** | [4] -> *) | PVar of ident (** pattern identifier *) - | Variant of ident list (** | [Blue, Green, Yellow] -> *) - (* [@gen QCheck.Gen.(list_size (0 -- 15) gen_ident ) ] *) + | Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) [@@deriving eq, show { with_path = false }, qcheck] type is_recursive = @@ -75,8 +78,11 @@ type is_recursive = type expr = | Const of literal (** [Int], [Bool], [String], [Unit], [Null] *) - | Tuple of expr * expr * expr list (** [(1, "Hello world", true)] *) - (* [@gen QCheck.Gen.(list_size (0 -- 15) gen_expr ) ] *) + | Tuple of + expr + * expr + * (expr list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_expr_sized (n / 4)))]) + (** [(1, "Hello world", true)] *) | Empty_list (** [] *) | Cons_list of expr * expr (** {[ @@ -86,27 +92,41 @@ type expr = | Unary_expr of unary_operator * expr (** -x *) | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) - | Lambda of ident list * expr (** fun x y -> x + y *) + | Lambda of (ident list[@gen gen_ident_small_list]) * expr (** fun x y -> x + y *) | Function_call of expr * expr (** [sum 1 ] *) - | Match of expr * pattern * expr * (pattern * expr) list + | Match of + expr + * pattern + * expr + * ((pattern * expr) list + [@gen + QCheck.Gen.( + list_size (0 -- 5) (pair (gen_pattern_sized (n / 4)) (gen_expr_sized (n / 4))))]) (** [match x with | x -> ... | y -> ...] *) - (* [@gen QCheck.Gen.(quad gen_expr_sized gen_pattern_sized gen_expr_sized (list_size (0 -- 15) ( pair gen_pattern_sized gen_expr_sized)))] *) - | LetIn of is_recursive * let_bind * let_bind list * expr - (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) - (* [@gen QCheck.Gen.(quad gen_is_recursive gen_let_bind (list_size (0--15) gen_let_bind) gen_expr_sized)] *) + | LetIn of + is_recursive + * let_bind + * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_let_bind_sized (n / 4)))]) + * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) [@@deriving eq, show { with_path = false }, qcheck] -and let_bind = Let_bind of ident * ident list * expr (** [and sum n m = n+m] *)[@@deriving eq, show {with_path = false}, qcheck] +and let_bind = + | Let_bind of ident * (ident list[@gen gen_ident_small_list]) * expr + (** [and sum n m = n+m] *) +[@@deriving eq, show { with_path = false }, qcheck] type statement = - | Let of is_recursive * let_bind * let_bind list (** [let name = expr] *) - (* [@gen QCheck.Gen.(triple gen_is_recursive gen_let_bind (list_size (0 --15) gen_let_bind) ) ] *) - | ActivePattern of ident list * expr + | Let of + is_recursive + * let_bind + * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 5) gen_let_bind)]) + (** [let name = expr] *) + | ActivePattern of (ident list[@gen gen_ident_small_list]) * expr (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *) [@@deriving eq, show { with_path = false }, qcheck] type construction = - | Expr of expr (** expression *) [@gen QCheck.Gen.sized gen_expr_sized] + | Expr of expr (** expression *) | Statement of statement (** statement *) [@@deriving eq, show { with_path = false }, qcheck] diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 63167b311..814e9ee36 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -238,7 +238,7 @@ let shrink_construction = let arbitrary_construction = QCheck.make - gen_construction_manual + gen_construction ~print:(Format.asprintf "%a" print_construction) ~shrink:shrink_construction ;; diff --git a/FSharpActivePatterns/lib/tests/run_construction.ml b/FSharpActivePatterns/lib/tests/run_construction.ml index d4c141a70..015a9e648 100644 --- a/FSharpActivePatterns/lib/tests/run_construction.ml +++ b/FSharpActivePatterns/lib/tests/run_construction.ml @@ -7,12 +7,14 @@ [@@@ocaml.text "/*"] open Tests.Gen_construction +open FSharpActivePatterns.Ast +open FSharpActivePatterns.AstPrinter -(* let generate n = - List.iter - Format.(fprintf std_formatter "%a\n" print_construction) - (QCheck.Gen.generate ~n gen_construction) - ;; *) +let generate n = + List.iter + Format.(fprintf std_formatter "%a\n" print_construction) + (QCheck.Gen.generate ~n gen_construction) +;; let run_tests n = let _ = run n in diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 63f8d33c8..a92150908 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_construction.exe -seed 1 -gen 100 -stop + $ ../lib/tests/run_construction.exe -seed -20 -gen 1 -stop random seed: 1 ================================================================================ success (ran 1 tests) From 19cdf1eb0e926e41dc091e8be83451380265708f Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 00:09:16 +0300 Subject: [PATCH 159/310] feat: add parser for lambda Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.ml | 5 +- FSharpActivePatterns/lib/astPrinter.ml | 7 +- FSharpActivePatterns/lib/parser.ml | 21 +++- FSharpActivePatterns/lib/prettyPrinter.ml | 7 +- FSharpActivePatterns/lib/tests/ast_printer.ml | 8 +- .../lib/tests/gen_construction.ml | 96 ++++++++++--------- 6 files changed, 83 insertions(+), 61 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index b36343194..de4efe84a 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -92,7 +92,10 @@ type expr = | Unary_expr of unary_operator * expr (** -x *) | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) - | Lambda of (ident list[@gen gen_ident_small_list]) * expr (** fun x y -> x + y *) + | Lambda of + pattern + * (pattern list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_pattern_sized (n / 4)))]) + * expr (** fun x y -> x + y *) | Function_call of expr * expr (** [sum 1 ] *) | Match of expr diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 7b81d8058..9c0c9f92b 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -124,11 +124,12 @@ and print_expr indent fmt expr = (match else_body with | Some body -> print_expr (indent + 2) fmt body | None -> fprintf fmt "%s| No else body\n" (String.make (indent + 2) '-')) - | Lambda (args, body) -> - let args = List.map tag_of_ident args in + | Lambda (pat1, pat_list, body) -> + (*let args = List.map tag_of_ident args in*) fprintf fmt "%s| Func:\n" (String.make indent '-'); fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); - List.iter (fun arg -> fprintf fmt "%s %s\n" (String.make (indent + 2) '-') arg) args; + print_pattern (indent + 4) fmt pat1; + List.iter (fun pat -> print_pattern (indent + 4) fmt pat) pat_list; fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 4) fmt body | Function_call (func, arg) -> diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 981cd216f..9934ef14b 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -319,18 +319,30 @@ let p_pat = ; p_pat_const ; string "_" *> return Wild ]) - <* skip_ws - <* string "->" +;; + +let p_lambda p_expr = + skip_ws + *> string "fun" + *> skip_ws_sep1 + *> + let* pat = skip_ws *> p_pat <* skip_ws in + let* pat_list = many (skip_ws *> p_pat) <* skip_ws in + let* _ = skip_ws *> string "->" in + let* body = p_expr in + return (Lambda (pat, pat_list, body)) ;; let p_match p_expr = lift4 (fun value pat1 expr1 list -> Match (value, pat1, expr1, list)) (skip_ws *> string "match" *> p_expr <* skip_ws <* string "with") - (skip_ws *> string "|" *> p_pat) + (skip_ws *> string "|" *> p_pat <* skip_ws <* string "->") (skip_ws *> p_expr) (many (skip_ws *> string "|" *> p_pat + <* skip_ws + <* string "->" >>= fun pat -> p_expr >>= fun expr -> return (pat, expr))) ;; @@ -362,7 +374,8 @@ let p_expr = let comp_or = chainl1 comp_and log_or in let cons_list = p_cons_list_expr comp_or <|> comp_or in let ematch = p_match cons_list <|> cons_list in - let option = p_option ematch <|> ematch in + let efun = p_lambda ematch <|> ematch in + let option = p_option efun <|> efun in option) ;; diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 05665ec38..85b833c1d 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -82,11 +82,10 @@ and pp_expr fmt expr = (match else_body with | Some body -> fprintf fmt "else %a " pp_expr body | None -> ()) - | Lambda (args, body) -> + | Lambda (pat1, pat_list, body) -> fprintf fmt "fun "; - (match args with - | [] -> fprintf fmt "() " - | _ -> pp_args fmt args); + fprintf fmt "%a " pp_pattern pat1; + List.iter (fun pat -> fprintf fmt "%a " pp_pattern pat) pat_list; fprintf fmt "-> %a " pp_expr body | Function_call (func, arg) -> fprintf fmt "%a (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index 906bb4b9b..46ab4bdef 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -9,7 +9,8 @@ open Format let%expect_test "print Ast factorial" = let factorial = Lambda - ( [ Ident ("n", None) ] + ( PConst (Int_lt 4) + , [] , If_then_else ( Bin_expr ( Logical_or @@ -107,9 +108,10 @@ let%expect_test "print Ast factorial" = let%expect_test "print Ast double func" = let ident = Ident ("n", None) in - let args = [ ident ] in + let pat = PConst (Int_lt 4) in + let args = [] in let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), Variable ident) in - let double = Lambda (args, binary_expr) in + let double = Lambda (pat, args, binary_expr) in print_construction std_formatter @@ Expr double; [%expect {| diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 814e9ee36..0ec67b6df 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -10,7 +10,7 @@ open FSharpActivePatterns.Ast open FSharpActivePatterns.AstPrinter open FSharpActivePatterns.Parser open FSharpActivePatterns.PrettyPrinter -open FSharpActivePatterns.KeywordChecker +(*open FSharpActivePatterns.KeywordChecker*) let int_e x = Const (Int_lt x) let bool_e x = Const (Bool_lt x) @@ -18,41 +18,43 @@ let unit_e = Const Unit_lt let string_e x = Const (String_lt x) let variable_e x = Variable (Ident (x, None)) -let gen_const_manual = - QCheck.Gen.( - frequency - [ 1, map int_e nat +(* + let gen_const_manual = + QCheck.Gen.( + frequency + [ 1, map int_e nat ; 1, map bool_e bool ; 0, return unit_e ; 0, map string_e (string ?gen:None) ]) -;; + ;; -let gen_varname_manual = - let open QCheck.Gen in - let loop = - let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in - let gen_first_char = - oneof [ gen_char_of_range 'a' 'z'; gen_char_of_range 'A' 'Z'; return '_' ] - in - let gen_next_char = oneof [ gen_first_char; gen_char_of_range '0' '9' ] in - map2 - (fun first rest -> - String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) - gen_first_char - (list_size (1 -- 5) gen_next_char) - in - loop >>= fun name -> if is_keyword name then loop else return name -;; + let gen_varname_manual = + let open QCheck.Gen in + let loop = + let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in + let gen_first_char = + oneof [ gen_char_of_range 'a' 'z'; gen_char_of_range 'A' 'Z'; return '_' ] + in + let gen_next_char = oneof [ gen_first_char; gen_char_of_range '0' '9' ] in + map2 + (fun first rest -> + String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) + gen_first_char + (list_size (1 -- 5) gen_next_char) + in + loop >>= fun name -> if is_keyword name then loop else return name + ;; *) -let gen_ident_manual = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname_manual +(* + let gen_ident_manual = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname_manual let gen_variable_manual = QCheck.Gen.map variable_e gen_varname_manual -let gen_unop_manual = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) +let gen_unop_manual = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) *) let tuple_e e1 e2 rest = Tuple (e1, e2, rest) let un_e unop e = Unary_expr (unop, e) let bin_e op e1 e2 = Bin_expr (op, e1, e2) let if_e i t e = If_then_else (i, t, e) -let func_def args body = Lambda (args, body) +let func_def pat pat_list body = Lambda (pat, pat_list, body) let func_call f arg = Function_call (f, arg) let let_bind name args body = Let_bind (name, args, body) @@ -60,7 +62,8 @@ let letin rec_flag let_bind let_bind_list inner_e = LetIn (rec_flag, let_bind, let_bind_list, inner_e) ;; -let gen_binop_manual = +(* + let gen_binop_manual = QCheck.Gen.( oneof @@ List.map @@ -87,9 +90,10 @@ let gen_is_recursive_manual = QCheck.Gen.(oneof [ return Rec; return Nonrec ]) let gen_let_bind_manual gen = QCheck.Gen.(map3 let_bind gen_ident_manual (list_size (0 -- 15) gen_ident_manual) gen) -;; +;; *) -let gen_expr_manual = +(* + let gen_expr_manual = QCheck.Gen.( sized @@ fix (fun self -> @@ -122,7 +126,7 @@ let gen_expr_manual = (list_size (0 -- 15) (gen_let_bind_manual (self (n / 4)))) <*> self (n / 4) ) ])) -;; +;; *) let shrink_lt = let open QCheck.Iter in @@ -178,10 +182,8 @@ and shrink_expr = of_list [ f; arg ] <+> (shrink_expr f >|= fun a' -> Function_call (a', arg)) <+> (shrink_expr arg >|= fun a' -> Function_call (f, a')) - | Lambda (args, body) -> - return body - <+> (QCheck.Shrink.list args >|= fun a' -> Lambda (a', body)) - <+> (shrink_expr body >|= fun a' -> Lambda (args, a')) + | Lambda (pat, pat_list, body) -> + shrink_expr body >|= fun body' -> Lambda (pat, pat_list, body') | Match (value, pat1, expr1, cases) -> of_list [ value; expr1 ] <+> (shrink_expr value >|= fun a' -> Match (a', pat1, expr1, cases)) @@ -198,14 +200,15 @@ and shrink_expr = let let_st rec_flag let_bind let_bind_list = Let (rec_flag, let_bind, let_bind_list) (* TODO: Active Pattern*) -let gen_statement_manual = - QCheck.Gen.( - map3 - let_st - gen_is_recursive_manual - (gen_let_bind_manual gen_expr_manual) - (list_size (0 -- 15) (gen_let_bind_manual gen_expr_manual))) -;; +(* + let gen_statement_manual = + QCheck.Gen.( + map3 + let_st + gen_is_recursive_manual + (gen_let_bind_manual gen_expr_manual) + (list_size (0 -- 15) (gen_let_bind_manual gen_expr_manual))) + ;; *) let shrink_statement = let open QCheck.Iter in @@ -221,13 +224,14 @@ let shrink_statement = <+> (shrink_expr e >|= fun a' -> ActivePattern (cases, a')) ;; -let gen_construction_manual = - QCheck.Gen.( - oneof - [ (gen_expr_manual >|= fun a' -> Expr a') +(* + let gen_construction_manual = + QCheck.Gen.( + oneof + [ (gen_expr_manual >|= fun a' -> Expr a') ; (gen_statement_manual >|= fun a' -> Statement a') ]) -;; + ;; *) let shrink_construction = let open QCheck.Iter in From d95ae4d20ae94faee31896243f7016853d3e23f9 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 18 Nov 2024 01:54:14 +0300 Subject: [PATCH 160/310] feat: temporary remove Variants in Ast Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 2 +- FSharpActivePatterns/lib/astPrinter.ml | 5 ----- FSharpActivePatterns/lib/prettyPrinter.ml | 1 - FSharpActivePatterns/lib/tests/ast_printer.ml | 1 - FSharpActivePatterns/tests/qcheck.t | 2 +- 5 files changed, 2 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index de4efe84a..2348a7bec 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -68,7 +68,7 @@ type pattern = (** | [(a, b)] -> *) | PConst of literal (** | [4] -> *) | PVar of ident (** pattern identifier *) - | Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) + (*| Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) *) [@@deriving eq, show { with_path = false }, qcheck] type is_recursive = diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 9c0c9f92b..630869f22 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -49,11 +49,6 @@ let rec print_pattern indent fmt = function | String_lt s -> fprintf fmt "%sString: %S\n" (String.make (indent + 2) '-') s | Unit_lt -> fprintf fmt "%sUnit\n" (String.make (indent + 2) '-')) | PVar (Ident (name, _)) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name - | Variant variants -> - fprintf fmt "%s| Variant:\n" (String.make indent '-'); - List.iter - (fun (Ident (v, _)) -> fprintf fmt "%s- %s\n" (String.make (indent + 2) '-') v) - variants ;; let print_unary_op indent fmt = function diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 85b833c1d..7a81c7d71 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -47,7 +47,6 @@ let rec pp_pattern fmt = function fprintf fmt ")" | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) | PVar (Ident (name, _)) -> fprintf fmt "%s " name - | Variant _ -> fprintf fmt "VARIANTS PAT WIP" and pp_expr fmt expr = match expr with diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index 46ab4bdef..f20f38b2d 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -221,7 +221,6 @@ let%expect_test "print Ast of match_expr" = let patterns = [ PConst (Int_lt 5) ; PConst (String_lt " bar foo") - ; Variant [ Ident ("Green", None); Ident ("Blue", None); Ident ("Red", None) ] ; PCons (Wild, PVar (Ident ("xs", None))) ] in diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index a92150908..b571a329d 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_construction.exe -seed -20 -gen 1 -stop + $ ../lib/tests/run_construction.exe -seed -10 -gen 2 -stop random seed: 1 ================================================================================ success (ran 1 tests) From 99fa8735b87624b9b336bcc2b0c3e0871d1a58d5 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 18 Nov 2024 04:08:22 +0300 Subject: [PATCH 161/310] feat: temporary remove ActivePatterns in Ast Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 6 +++--- FSharpActivePatterns/lib/astPrinter.ml | 4 ++-- FSharpActivePatterns/lib/prettyPrinter.ml | 1 - FSharpActivePatterns/lib/tests/gen_construction.ml | 9 +++++---- FSharpActivePatterns/tests/qcheck.t | 2 +- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 2348a7bec..d92122a23 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -30,7 +30,7 @@ let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 5) gen_ident) type literal = | Int_lt of int (** [0], [1], [30] *) | Bool_lt of bool (** [false], [true] *) - | String_lt of string (** ["Hello world"] *) + | String_lt of (string[@gen QCheck.Gen.string_printable]) (** ["Hello world"] *) | Unit_lt (** [Unit] *) [@@deriving eq, show { with_path = false }, qcheck] @@ -125,8 +125,8 @@ type statement = * let_bind * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 5) gen_let_bind)]) (** [let name = expr] *) - | ActivePattern of (ident list[@gen gen_ident_small_list]) * expr - (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *) +(*| ActivePattern of (ident list[@gen gen_ident_small_list]) * expr + (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *)*) [@@deriving eq, show { with_path = false }, qcheck] type construction = diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 630869f22..fc8fbf0ef 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -164,13 +164,13 @@ let print_statement indent fmt = function | Rec -> "Rec "); fprintf fmt "%s Let_binds\n" (String.make (indent + 2) ' '); List.iter (print_let_bind (indent + 2) fmt) (let_bind :: let_bind_list) - | ActivePattern (patterns, expr) -> + (* | ActivePattern (patterns, expr) -> fprintf fmt "%s| ActivePattern:\n" (String.make indent '-'); List.iter (fun (Ident (param, _)) -> fprintf fmt "%s- %s\n" (String.make (indent + 2) '-') param) patterns; - print_expr (indent + 2) fmt expr + print_expr (indent + 2) fmt expr *) ;; let print_construction fmt = function diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 7a81c7d71..dbde0f0fd 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -134,7 +134,6 @@ let pp_statement fmt = function pp_let_bind fmt (let_bind :: let_bind_list) - | ActivePattern _ -> fprintf fmt "Active pattern TODO" ;; let pp_construction fmt = function diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 0ec67b6df..bbb2b372f 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -218,12 +218,13 @@ let shrink_statement = >|= (fun a' -> Let (rec_flag, a', let_bind_list)) <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list >|= fun a' -> Let (rec_flag, let_bind, a')) - | ActivePattern (cases, e) -> - QCheck.Shrink.list cases - >|= (fun a' -> ActivePattern (a', e)) - <+> (shrink_expr e >|= fun a' -> ActivePattern (cases, a')) ;; +(*| ActivePattern (cases, e) -> + QCheck.Shrink.list cases + >|= (fun a' -> ActivePattern (a', e)) + <+> (shrink_expr e >|= fun a' -> ActivePattern (cases, a')) *) + (* let gen_construction_manual = QCheck.Gen.( diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index b571a329d..f045616b2 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_construction.exe -seed -10 -gen 2 -stop + $ ../lib/tests/run_construction.exe -seed -12 -gen 2 -stop random seed: 1 ================================================================================ success (ran 1 tests) From 4964d234222f0754bc6abeb3e648caa661328a0e Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 18 Nov 2024 08:04:58 +0300 Subject: [PATCH 162/310] feat: implement signed ints parser, change int generator to non negative Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 2 +- FSharpActivePatterns/lib/astPrinter.ml | 15 ++++++++------- FSharpActivePatterns/lib/parser.ml | 9 ++++++++- FSharpActivePatterns/tests/qcheck.t | 2 +- 4 files changed, 18 insertions(+), 10 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index d92122a23..44aff3208 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -28,7 +28,7 @@ let gen_ident = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 5) gen_ident) type literal = - | Int_lt of int (** [0], [1], [30] *) + | Int_lt of (int[@gen QCheck.Gen.pint]) (** [0], [1], [30] *) | Bool_lt of bool (** [false], [true] *) | String_lt of (string[@gen QCheck.Gen.string_printable]) (** ["Hello world"] *) | Unit_lt (** [Unit] *) diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index fc8fbf0ef..9b03ccbd7 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -164,15 +164,16 @@ let print_statement indent fmt = function | Rec -> "Rec "); fprintf fmt "%s Let_binds\n" (String.make (indent + 2) ' '); List.iter (print_let_bind (indent + 2) fmt) (let_bind :: let_bind_list) - (* | ActivePattern (patterns, expr) -> - fprintf fmt "%s| ActivePattern:\n" (String.make indent '-'); - List.iter - (fun (Ident (param, _)) -> - fprintf fmt "%s- %s\n" (String.make (indent + 2) '-') param) - patterns; - print_expr (indent + 2) fmt expr *) ;; +(* | ActivePattern (patterns, expr) -> + fprintf fmt "%s| ActivePattern:\n" (String.make indent '-'); + List.iter + (fun (Ident (param, _)) -> + fprintf fmt "%s- %s\n" (String.make (indent + 2) '-') param) + patterns; + print_expr (indent + 2) fmt expr *) + let print_construction fmt = function | Expr e -> print_expr 0 fmt e | Statement s -> print_statement 0 fmt s diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 9934ef14b..2a855dcc6 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -47,7 +47,14 @@ let rec unary_chain op e = (* SIMPLE PARSERS *) let expr_const_factory parser = parser >>| fun lit -> Const lit let pat_const_factory parser = parser >>| fun lit -> PConst lit -let p_int = skip_ws *> take_while1 Char.is_digit >>| fun s -> Int_lt (Int.of_string s) + +let p_int = + skip_ws + *> let* sign = string "+" <|> string "-" <|> string "" in + let* number = take_while1 Char.is_digit in + return (Int_lt (Int.of_string (sign ^ number))) +;; + let p_int_expr = expr_const_factory p_int let p_int_pat = pat_const_factory p_int diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index f045616b2..e8bce25f7 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_construction.exe -seed -12 -gen 2 -stop + $ ../lib/tests/run_construction.exe -seed 12 -gen 1 -stop random seed: 1 ================================================================================ success (ran 1 tests) From 15a864c4380b0aac46e7589e54d176d3c9b458b9 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 18 Nov 2024 08:08:46 +0300 Subject: [PATCH 163/310] feat: improve Lambda shrinker Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/gen_construction.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index bbb2b372f..e0f84a7a1 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -183,7 +183,9 @@ and shrink_expr = <+> (shrink_expr f >|= fun a' -> Function_call (a', arg)) <+> (shrink_expr arg >|= fun a' -> Function_call (f, a')) | Lambda (pat, pat_list, body) -> - shrink_expr body >|= fun body' -> Lambda (pat, pat_list, body') + shrink_expr body + >|= (fun body' -> Lambda (pat, pat_list, body')) + <+> (QCheck.Shrink.list pat_list >|= fun pat_list' -> Lambda (pat, pat_list', body)) | Match (value, pat1, expr1, cases) -> of_list [ value; expr1 ] <+> (shrink_expr value >|= fun a' -> Match (a', pat1, expr1, cases)) From f2a6d9ca4cccbd2e4be098766ca3d90df6d91f46 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 18 Nov 2024 08:27:13 +0300 Subject: [PATCH 164/310] feat: implement pattern shrinker Signed-off-by: Gleb Nasretdinov --- .../lib/tests/gen_construction.ml | 37 +++++++++++++------ 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index e0f84a7a1..9bb292b47 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -12,12 +12,6 @@ open FSharpActivePatterns.Parser open FSharpActivePatterns.PrettyPrinter (*open FSharpActivePatterns.KeywordChecker*) -let int_e x = Const (Int_lt x) -let bool_e x = Const (Bool_lt x) -let unit_e = Const Unit_lt -let string_e x = Const (String_lt x) -let variable_e x = Variable (Ident (x, None)) - (* let gen_const_manual = QCheck.Gen.( @@ -131,10 +125,10 @@ let gen_let_bind_manual gen = let shrink_lt = let open QCheck.Iter in function - | Int_lt x -> QCheck.Shrink.int x >|= int_e + | Int_lt x -> QCheck.Shrink.int x >|= fun a' -> Int_lt a' | Bool_lt _ -> empty | Unit_lt -> empty - | String_lt x -> QCheck.Shrink.string x >|= string_e + | String_lt x -> QCheck.Shrink.string x >|= fun a' -> String_lt a' ;; let rec shrink_let_bind = @@ -148,7 +142,7 @@ let rec shrink_let_bind = and shrink_expr = let open QCheck.Iter in function - | Const lt -> shrink_lt lt + | Const lt -> shrink_lt lt >|= fun a' -> Const a' | Tuple (e1, e2, rest) -> of_list [ e1; e2 ] <+> (shrink_expr e1 >|= fun a' -> Tuple (a', e2, rest)) @@ -185,18 +179,39 @@ and shrink_expr = | Lambda (pat, pat_list, body) -> shrink_expr body >|= (fun body' -> Lambda (pat, pat_list, body')) - <+> (QCheck.Shrink.list pat_list >|= fun pat_list' -> Lambda (pat, pat_list', body)) + <+> (QCheck.Shrink.list ~shrink:shrink_pattern pat_list + >|= fun pat_list' -> Lambda (pat, pat_list', body)) | Match (value, pat1, expr1, cases) -> of_list [ value; expr1 ] <+> (shrink_expr value >|= fun a' -> Match (a', pat1, expr1, cases)) + <+> (shrink_pattern pat1 >|= fun a' -> Match (value, a', expr1, cases)) <+> (shrink_expr expr1 >|= fun a' -> Match (value, pat1, a', cases)) <+> (QCheck.Shrink.list - ~shrink:(fun (p, e) -> shrink_expr e >|= fun a' -> p, a') + ~shrink:(fun (p, e) -> + let* p_shr = shrink_pattern p in + let* e_shr = shrink_expr e in + return (p_shr, e_shr)) cases >|= fun a' -> Match (value, pat1, expr1, a')) | Option (Some e) -> of_list [ e; Option None ] <+> (shrink_expr e >|= fun a' -> Option (Some a')) | _ -> empty + +and shrink_pattern = + let open QCheck.Iter in + function + | PCons (p1, p2) -> + of_list [ p1; p2 ] + <+> (shrink_pattern p1 >|= fun p1' -> PCons (p1', p2)) + <+> (shrink_pattern p2 >|= fun p2' -> PCons (p1, p2')) + | PTuple (p1, p2, rest) -> + of_list [ p1; p2 ] + <+> (shrink_pattern p1 >|= fun p1' -> PTuple (p1', p2, rest)) + <+> (shrink_pattern p2 >|= fun p2' -> PTuple (p1, p2', rest)) + <+> (QCheck.Shrink.list ~shrink:shrink_pattern rest + >|= fun rest' -> PTuple (p1, p2, rest')) + | PConst lt -> shrink_lt lt >|= fun lt' -> PConst lt' + | _ -> empty ;; let let_st rec_flag let_bind let_bind_list = Let (rec_flag, let_bind, let_bind_list) From eca52c3e1eaa2f4178c2ec9ad5b5f683a9627a17 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 09:26:23 +0300 Subject: [PATCH 165/310] fix: enable any expr inside of apply Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 33 +++++------------------------- 1 file changed, 5 insertions(+), 28 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 2a855dcc6..69936057d 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -271,31 +271,7 @@ let p_let p_expr = return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) ;; -let app_first expr = - skip_ws - *> fix (fun a_exp -> - let expr = choice [ p_var_expr; p_if expr; p_letin expr; p_parens a_exp ] in - expr) -;; - -let p_apply expr = - let* name = app_first expr in - let rec parse_args acc = - skip_ws - *> choice - [ p_var_expr - ; p_bool_expr - ; p_unit_expr - ; p_int_expr - ; p_string_expr - ; p_if expr - ; p_letin expr - ; p_parens expr - ] - >>= (fun arg -> parse_args (Function_call (acc, arg))) - <|> return acc - in - parse_args name +let p_apply p_expr = chainl1 p_expr (return (fun expr1 expr2 -> Function_call (expr1, expr2))) ;; let p_option p_expr = @@ -370,8 +346,8 @@ let p_expr = let tuple = p_tuple make_tuple_expr (p_expr <|> atom) <|> atom in let if_expr = p_if (p_expr <|> tuple) <|> tuple in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in - let apply = p_apply (p_expr <|> letin_expr) <|> letin_expr in - let unary = choice [ unary_chain p_not apply; unary_chain unminus apply ] in + (*let apply = p_apply (p_expr <|> letin_expr) <|> letin_expr in*) + let unary = choice [ unary_chain p_not letin_expr; unary_chain unminus letin_expr ] in let factor = chainl1 unary (mul <|> div) in let term = chainl1 factor (add <|> sub) in let comp_eq = chainl1 term (equal <|> unequal) in @@ -379,7 +355,8 @@ let p_expr = let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in let comp_and = chainl1 comp_gr log_and in let comp_or = chainl1 comp_and log_or in - let cons_list = p_cons_list_expr comp_or <|> comp_or in + let apply = p_apply comp_or <|> comp_or in + let cons_list = p_cons_list_expr apply <|> apply in let ematch = p_match cons_list <|> cons_list in let efun = p_lambda ematch <|> ematch in let option = p_option efun <|> efun in From f46445014a0afc0d96d624342c5ebf718eabc5b2 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 09:33:37 +0300 Subject: [PATCH 166/310] fix: add breackets to treat apply correctly Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/prettyPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index dbde0f0fd..c6f2aac14 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -86,7 +86,7 @@ and pp_expr fmt expr = fprintf fmt "%a " pp_pattern pat1; List.iter (fun pat -> fprintf fmt "%a " pp_pattern pat) pat_list; fprintf fmt "-> %a " pp_expr body - | Function_call (func, arg) -> fprintf fmt "%a (%a)" pp_expr func pp_expr arg + | Function_call (func, arg) -> fprintf fmt "(%a) (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> fprintf fmt "let %a " pp_rec_flag rec_flag; pp_print_list From 4d476ddd3990b1acbeb80f2ff1cb09e28f9de2e9 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 18 Nov 2024 10:10:50 +0300 Subject: [PATCH 167/310] ref: rename Function_def to Apply Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 2 +- FSharpActivePatterns/lib/astPrinter.ml | 6 +++--- FSharpActivePatterns/lib/parser.ml | 4 +--- FSharpActivePatterns/lib/prettyPrinter.ml | 2 +- FSharpActivePatterns/lib/tests/ast_printer.ml | 4 ++-- FSharpActivePatterns/lib/tests/gen_construction.ml | 8 ++++---- 6 files changed, 12 insertions(+), 14 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 44aff3208..6db75db2f 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -96,7 +96,7 @@ type expr = pattern * (pattern list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_pattern_sized (n / 4)))]) * expr (** fun x y -> x + y *) - | Function_call of expr * expr (** [sum 1 ] *) + | Apply of expr * expr (** [sum 1 ] *) | Match of expr * pattern diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 9b03ccbd7..96fd85035 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -121,14 +121,14 @@ and print_expr indent fmt expr = | None -> fprintf fmt "%s| No else body\n" (String.make (indent + 2) '-')) | Lambda (pat1, pat_list, body) -> (*let args = List.map tag_of_ident args in*) - fprintf fmt "%s| Func:\n" (String.make indent '-'); + fprintf fmt "%s| Lambda:\n" (String.make indent '-'); fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); print_pattern (indent + 4) fmt pat1; List.iter (fun pat -> print_pattern (indent + 4) fmt pat) pat_list; fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 4) fmt body - | Function_call (func, arg) -> - fprintf fmt "%s| Function Call:\n" (String.make indent '-'); + | Apply (func, arg) -> + fprintf fmt "%s| Apply:\n" (String.make indent '-'); fprintf fmt "%sFUNCTION\n" (String.make (indent + 2) ' '); print_expr (indent + 2) fmt func; fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 69936057d..e973d4284 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -271,8 +271,7 @@ let p_let p_expr = return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) ;; -let p_apply p_expr = chainl1 p_expr (return (fun expr1 expr2 -> Function_call (expr1, expr2))) -;; +let p_apply p_expr = chainl1 p_expr (return (fun expr1 expr2 -> Apply (expr1, expr2))) let p_option p_expr = skip_ws *> (string "None" *> skip_ws_sep1 *> return (Option None)) @@ -346,7 +345,6 @@ let p_expr = let tuple = p_tuple make_tuple_expr (p_expr <|> atom) <|> atom in let if_expr = p_if (p_expr <|> tuple) <|> tuple in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in - (*let apply = p_apply (p_expr <|> letin_expr) <|> letin_expr in*) let unary = choice [ unary_chain p_not letin_expr; unary_chain unminus letin_expr ] in let factor = chainl1 unary (mul <|> div) in let term = chainl1 factor (add <|> sub) in diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index c6f2aac14..084dbd3a4 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -86,7 +86,7 @@ and pp_expr fmt expr = fprintf fmt "%a " pp_pattern pat1; List.iter (fun pat -> fprintf fmt "%a " pp_pattern pat) pat_list; fprintf fmt "-> %a " pp_expr body - | Function_call (func, arg) -> fprintf fmt "(%a) (%a)" pp_expr func pp_expr arg + | Apply (func, arg) -> fprintf fmt "(%a) (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> fprintf fmt "let %a " pp_rec_flag rec_flag; pp_print_list diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index f20f38b2d..75bb0a8f8 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -21,7 +21,7 @@ let%expect_test "print Ast factorial" = (Bin_expr ( Binary_multiply , Variable (Ident ("n", None)) - , Function_call + , Apply ( Variable (Ident ("factorial", None)) , Bin_expr (Binary_subtract, Variable (Ident ("n", None)), Const (Int_lt 1)) @@ -30,7 +30,7 @@ let%expect_test "print Ast factorial" = let program = [ Statement (Let (Nonrec, Let_bind (Ident ("a", None), [], Const (Int_lt 10)), [])) ; Expr factorial - ; Expr (Function_call (factorial, Variable (Ident ("a", None)))) + ; Expr (Apply (factorial, Variable (Ident ("a", None)))) ] in List.iter (print_construction std_formatter) program; diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 9bb292b47..beef6a36b 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -49,7 +49,7 @@ let un_e unop e = Unary_expr (unop, e) let bin_e op e1 e2 = Bin_expr (op, e1, e2) let if_e i t e = If_then_else (i, t, e) let func_def pat pat_list body = Lambda (pat, pat_list, body) -let func_call f arg = Function_call (f, arg) +let apply f arg = Apply (f, arg) let let_bind name args body = Let_bind (name, args, body) let letin rec_flag let_bind let_bind_list inner_e = @@ -172,10 +172,10 @@ and shrink_expr = <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list >|= fun a' -> LetIn (rec_flag, let_bind, a', inner_e)) <+> (shrink_expr inner_e >|= fun a' -> LetIn (rec_flag, let_bind, let_bind_list, a')) - | Function_call (f, arg) -> + | Apply (f, arg) -> of_list [ f; arg ] - <+> (shrink_expr f >|= fun a' -> Function_call (a', arg)) - <+> (shrink_expr arg >|= fun a' -> Function_call (f, a')) + <+> (shrink_expr f >|= fun a' -> Apply (a', arg)) + <+> (shrink_expr arg >|= fun a' -> Apply (f, a')) | Lambda (pat, pat_list, body) -> shrink_expr body >|= (fun body' -> Lambda (pat, pat_list, body')) From f99f3a1be7397ce4e1133f5bf8dc4856aa684ec4 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 18 Nov 2024 11:49:28 +0300 Subject: [PATCH 168/310] feat: create general List type Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 14 ++++---- FSharpActivePatterns/lib/astPrinter.ml | 22 ++++++------- FSharpActivePatterns/lib/prettyPrinter.ml | 32 +++++++------------ FSharpActivePatterns/lib/tests/ast_printer.ml | 2 +- .../lib/tests/gen_construction.ml | 31 ++++++++++++------ 5 files changed, 52 insertions(+), 49 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 6db75db2f..cede848ab 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -57,10 +57,14 @@ type unary_operator = | Unary_not (** unary [not] *) [@@deriving eq, show { with_path = false }, qcheck] +type 'a list_type = + | Cons_list of 'a * 'a list_type + | Empty_list +[@@deriving eq, show { with_path = false }, qcheck] + type pattern = | Wild (** [_] *) - | PEmptyList (** [] *) - | PCons of pattern * pattern (** | [hd :: tl] -> *) + | PList of pattern list_type (**[ [], hd :: tl, [1;2;3] ]*) | PTuple of pattern * pattern @@ -83,11 +87,7 @@ type expr = * expr * (expr list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_expr_sized (n / 4)))]) (** [(1, "Hello world", true)] *) - | Empty_list (** [] *) - | Cons_list of expr * expr - (** {[ - [ 1; 2; 3 ] [ 1; 2; 3 ] - ]} *) + | List of expr list_type (** [], hd :: tl, [1;2;3] *) | Variable of ident (** [x], [y] *) | Unary_expr of unary_operator * expr (** -x *) | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 96fd85035..f24334702 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -29,15 +29,17 @@ let print_bin_op indent fmt = function | Binary_and_bitwise -> fprintf fmt "%s| Binary And Bitwise\n" (String.make indent '-') ;; +let rec print_list printer indent fmt = function + | Empty_list -> fprintf fmt "%s| Empty_list:\n" (String.make indent ' ') + | Cons_list (hd, tl) -> + fprintf fmt "%s| Cons_list:\n" (String.make indent ' '); + printer (indent + 2) fmt hd; + print_list printer (indent + 2) fmt tl +;; + let rec print_pattern indent fmt = function | Wild -> fprintf fmt "%s| Wild\n" (String.make indent '-') - | PEmptyList -> fprintf fmt "%s| Empty_list\n" (String.make indent '-') - | PCons (head, tail) -> - fprintf fmt "%s| PCons:\n" (String.make indent '-'); - fprintf fmt "%sHead:\n" (String.make (indent + 2) '-'); - print_pattern (indent + 4) fmt head; - fprintf fmt "%sTail:\n" (String.make (indent + 2) '-'); - print_pattern (indent + 4) fmt tail + | PList l -> print_list print_pattern indent fmt l | PTuple (p1, p2, rest) -> fprintf fmt "%s| PTuple:\n" (String.make indent '-'); List.iter (print_pattern (indent + 2) fmt) (p1 :: p2 :: rest) @@ -79,11 +81,7 @@ and print_expr indent fmt expr = | Const (String_lt s) -> fprintf fmt "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> fprintf fmt "%s| Const(Unit)\n" (String.make indent '-') - | Cons_list (expr1, expr2) -> - fprintf fmt "%s| Cons_list expr:\n" (String.make indent '-'); - print_expr (indent + 2) fmt expr1; - print_expr (indent + 2) fmt expr2 - | Empty_list -> fprintf fmt "%s| Empty_list\n" (String.make indent '-') + | List l -> print_list print_expr indent fmt l | Tuple (e1, e2, rest) -> fprintf fmt "%s| Tuple:\n" (String.make indent '-'); List.iter (print_expr (indent + 2) fmt) (e1 :: e2 :: rest) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 084dbd3a4..a355aa4d6 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -33,10 +33,19 @@ let pp_rec_flag fmt = function | Nonrec -> () ;; +let rec pp_list pp fmt = + fprintf fmt "["; + function + | Empty_list -> fprintf fmt "]" + | Cons_list (hd, Empty_list) -> fprintf fmt "%a]" pp hd + | Cons_list (hd, tl) -> + fprintf fmt "%a; " pp hd; + fprintf fmt "%a" (pp_list pp) tl +;; + let rec pp_pattern fmt = function | Wild -> fprintf fmt "_ " - | PEmptyList -> fprintf fmt "[] " - | PCons (hd, tl) -> fprintf fmt "%a :: %a" pp_pattern hd pp_pattern tl + | PList l -> pp_list pp_pattern fmt l | PTuple (p1, p2, rest) -> fprintf fmt "("; pp_print_list @@ -54,15 +63,7 @@ and pp_expr fmt expr = | Const (Bool_lt b) -> fprintf fmt "%b " b | Const (String_lt s) -> fprintf fmt "%S " s | Const Unit_lt -> fprintf fmt "() " - | Empty_list -> fprintf fmt "%a " pp_list Empty_list - | Cons_list (expr1, expr2) -> - fprintf fmt "["; - fprintf fmt "%a" pp_expr expr1; - if expr2 <> Empty_list - then ( - fprintf fmt "; "; - fprintf fmt "%a" pp_list expr2); - fprintf fmt "]" + | List l -> fprintf fmt "%a " (pp_list pp_expr) l | Tuple (e1, e2, rest) -> fprintf fmt "("; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); @@ -115,15 +116,6 @@ and pp_args fmt args = and pp_let_bind fmt = function | Let_bind (Ident (name, _), args, body) -> fprintf fmt "%s %a = %a " name pp_args args pp_expr body - -and pp_list fmt = function - | Empty_list -> fprintf fmt "[]" - | Cons_list (head, Empty_list) -> fprintf fmt "%a " pp_expr head - | Cons_list (head, tail) -> - fprintf fmt "%a" pp_expr head; - fprintf fmt "; "; - fprintf fmt "%a" pp_list tail - | other -> fprintf fmt "%a" pp_expr other ;; let pp_statement fmt = function diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index 75bb0a8f8..545b82f9e 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -221,7 +221,7 @@ let%expect_test "print Ast of match_expr" = let patterns = [ PConst (Int_lt 5) ; PConst (String_lt " bar foo") - ; PCons (Wild, PVar (Ident ("xs", None))) + ; PList (Cons_list (Wild, Cons_list (PVar (Ident ("xs", None)), Empty_list))) ] in let pattern_values = List.map (fun p -> p, Const (Int_lt 4)) patterns in diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index beef6a36b..814bbc66e 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -148,11 +148,17 @@ and shrink_expr = <+> (shrink_expr e1 >|= fun a' -> Tuple (a', e2, rest)) <+> (shrink_expr e2 >|= fun a' -> Tuple (e1, a', rest)) <+> (QCheck.Shrink.list ~shrink:shrink_expr rest >|= fun a' -> Tuple (e1, e2, a')) - | Cons_list (e1, e2) -> - of_list [ e1; e2 ] - <+> (shrink_expr e1 >|= fun a' -> Cons_list (a', e2)) - <+> (shrink_expr e2 >|= fun a' -> Cons_list (e1, a')) - | Unary_expr (op, e) -> return e <+> shrink_expr e >|= fun a' -> un_e op a' + | List (Cons_list (hd, Cons_list (hd2, tl))) -> + of_list + [ List (Cons_list (hd, Empty_list)) + ; List (Cons_list (hd2, tl)) + ; List (Cons_list (hd, tl)) + ; List tl + ] + <+> (shrink_expr hd >|= fun hd' -> List (Cons_list (hd', Cons_list (hd2, tl)))) + <+> (shrink_expr hd2 >|= fun hd2' -> List (Cons_list (hd, Cons_list (hd2', tl)))) + | List (Cons_list (hd, Empty_list)) -> + shrink_expr hd >|= fun hd' -> List (Cons_list (hd', Empty_list)) | Bin_expr (op, e1, e2) -> of_list [ e1; e2 ] <+> (shrink_expr e1 >|= fun a' -> bin_e op a' e2) @@ -200,10 +206,17 @@ and shrink_expr = and shrink_pattern = let open QCheck.Iter in function - | PCons (p1, p2) -> - of_list [ p1; p2 ] - <+> (shrink_pattern p1 >|= fun p1' -> PCons (p1', p2)) - <+> (shrink_pattern p2 >|= fun p2' -> PCons (p1, p2')) + | PList (Cons_list (hd, Cons_list (hd2, tl))) -> + of_list + [ PList (Cons_list (hd, Empty_list)) + ; PList (Cons_list (hd2, tl)) + ; PList (Cons_list (hd, tl)) + ; PList tl + ] + <+> (shrink_pattern hd >|= fun hd' -> PList (Cons_list (hd', Cons_list (hd2, tl)))) + <+> (shrink_pattern hd2 >|= fun hd2' -> PList (Cons_list (hd, Cons_list (hd2', tl)))) + | PList (Cons_list (hd, Empty_list)) -> + shrink_pattern hd >|= fun hd' -> PList (Cons_list (hd', Empty_list)) | PTuple (p1, p2, rest) -> of_list [ p1; p2 ] <+> (shrink_pattern p1 >|= fun p1' -> PTuple (p1', p2, rest)) From 60377ed0ff4c5ce63fb15f1ae5f959bb90b2f12f Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 14:26:14 +0300 Subject: [PATCH 169/310] fix: lists and string parsers Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 126 ++++++++++++---------- FSharpActivePatterns/lib/prettyPrinter.ml | 21 ++-- 2 files changed, 80 insertions(+), 67 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index e973d4284..f42aa5f34 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -66,7 +66,7 @@ let p_bool_expr = expr_const_factory p_bool let p_bool_pat = pat_const_factory p_bool let p_string = - char '"' *> take_while (fun c -> not (Char.equal c '"')) + skip_ws *> char '"' *> take_while (fun c -> not (Char.equal c '"')) <* char '"' >>| fun x -> String_lt x ;; @@ -104,24 +104,25 @@ let p_ident = let p_var_expr = p_ident >>| fun ident -> Variable ident let p_var_pat = p_ident >>| fun ident -> PVar ident -let p_empty_list empty_list = - skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws *> return empty_list -;; - -let p_empty_list_expr = p_empty_list Empty_list -let p_empty_list_pat = p_empty_list PEmptyList -let make_cons_expr e1 e2 = Cons_list (e1, e2) -let make_cons_pat p1 p2 = PCons (p1, p2) - -let p_cons_list p p_empty_list make_list = - skip_ws - *> chainr1 (p <|> p_empty_list) (skip_ws *> string "::" *> skip_ws *> return make_list) -;; +(* + let p_empty_list empty_list = + skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws *> return empty_list + ;; + let p_empty_list_expr = p_empty_list Empty_list + let p_empty_list_pat = p_empty_list EmptyList + let make_cons_expr e1 e2 = Cons_list (e1, e2) + let make_cons_pat p1 p2 = PCons (p1, p2) + + let p_cons_list p p_empty_list make_list = + skip_ws + *> chainr1 (p <|> p_empty_list) (skip_ws *> string "::" *> skip_ws *> return make_list) + ;; -let p_cons_list_expr p_expr = p_cons_list p_expr p_empty_list_expr make_cons_expr -let p_cons_list_pat p_pat = p_cons_list p_pat p_empty_list_pat make_cons_pat + let p_cons_list_expr p_expr = p_cons_list p_expr p_empty_list_expr make_cons_expr + let p_cons_list_pat p_pat = p_cons_list p_pat p_empty_list_pat make_cons_pat *) -let p_semicolon_list p empty_list cons_list = +(* + let p_semicolon_list p empty_list cons_list = skip_ws *> string "[" *> skip_ws @@ -138,7 +139,54 @@ let p_semicolon_list p empty_list cons_list = ;; let p_semicolon_list_expr p_expr = p_semicolon_list p_expr Empty_list make_cons_expr -let p_semicolon_list_pat p_pat = p_semicolon_list p_pat PEmptyList make_cons_pat +let p_semicolon_list_pat p_pat = p_semicolon_list p_pat PEmptyList make_cons_pat *) + +let p_empty_list = + skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws *> return Empty_list +;; + +let make_list e1 e2 = Cons_list (e1, e2) + +(* elem because it is for both patterns and expressions *) +let p_cons_list p_elem = + let rec p_cons_tail acc = + skip_ws *> string "::" *> skip_ws *> p_elem + >>= (fun next -> p_cons_tail (Cons_list (next, acc))) + <|> return acc + in + p_elem + >>= fun hd -> + skip_ws *> string "::" *> skip_ws *> p_elem + >>= fun next -> p_cons_tail (Cons_list (next, Cons_list (hd, Empty_list))) +;; + +let p_cons_list_expr p_expr = p_cons_list p_expr >>= fun l -> return (List l) +let p_cons_list_pat p_pat = p_cons_list p_pat >>= fun l -> return (PList l) + +let p_semicolon_list p_elem empty_list = + skip_ws + *> string "[" + *> skip_ws + *> fix (fun p_semi_list -> + choice + [ (p_elem + <* skip_ws + <* string ";" + <* skip_ws + >>= fun hd -> p_semi_list >>= fun tl -> return (make_list hd tl)) + ; (p_elem <* skip_ws <* string "]" <* skip_ws >>| fun hd -> make_list hd empty_list) + ; string "]" *> skip_ws *> return empty_list + ]) +;; + +let p_semicolon_list_expr p_expr = + p_semicolon_list p_expr Empty_list >>= fun l -> return (List l) +;; + +let p_semicolon_list_pat p_pat = + p_semicolon_list p_pat Empty_list >>= fun l -> return (PList l) +;; + let p_unit = skip_ws *> string "(" *> skip_ws *> string ")" *> skip_ws *> return Unit_lt let p_unit_expr = expr_const_factory p_unit let p_unit_pat = pat_const_factory p_unit @@ -211,24 +259,6 @@ let p_let_bind p_expr = (skip_ws *> string "=" *> skip_ws *> p_expr) ;; -(* - let p_letin2 p_expr = - skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) - >>= fun rec_flag -> - p_ident - >>= return - >>= fun name -> - skip_ws *> many (skip_ws *> p_ident) - >>= fun args -> - skip_ws *> string "=" *> skip_ws *> p_expr - >>= fun body -> - skip_ws *> many (skip_ws *> p_let_bind p_expr) - >>= fun let_bind_list -> - skip_ws *> string "in" *> skip_ws_sep1 *> p_expr - >>= fun in_expr -> - return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) - ;; *) - let p_letin p_expr = skip_ws *> string "let" @@ -243,21 +273,6 @@ let p_letin p_expr = return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) ;; -(* - let p_let p_expr = - skip_ws *> string "let" *> skip_ws_sep1 *> (string "rec" *> return Rec <|> return Nonrec) - >>= fun rec_flag -> - p_ident - >>= fun name -> - skip_ws *> many (skip_ws *> p_ident) - >>= fun args -> - skip_ws *> string "=" *> skip_ws *> p_expr - >>= fun body -> - skip_ws *> many (skip_ws *> p_let_bind p_expr) - >>= fun let_bind_list -> - return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) - ;; *) - let p_let p_expr = skip_ws *> string "let" @@ -279,15 +294,8 @@ let p_option p_expr = >>| fun expr -> Option (Some expr)) ;; -let make_cons_pat pat1 pat2 = PCons (pat1, pat2) -(* - let p_cons_pat p_pat = - skip_ws - *> chainr1 - (p_pat <|> p_empty_list) - (skip_ws *> string "::" *> skip_ws *> return make_cons_pat) *) - let p_pat_const = choice [ p_int_pat; p_bool_pat; p_unit_pat; p_string_pat ] +let p_empty_list_pat = p_empty_list >>= fun _ -> return (PList Empty_list) let p_pat = fix (fun self -> diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index a355aa4d6..8bd811236 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -33,14 +33,19 @@ let pp_rec_flag fmt = function | Nonrec -> () ;; -let rec pp_list pp fmt = - fprintf fmt "["; - function - | Empty_list -> fprintf fmt "]" - | Cons_list (hd, Empty_list) -> fprintf fmt "%a]" pp hd +let pp_list pp fmt = function + | Empty_list -> fprintf fmt "[]" + | Cons_list (hd, Empty_list) -> fprintf fmt "[%a]" pp hd | Cons_list (hd, tl) -> - fprintf fmt "%a; " pp hd; - fprintf fmt "%a" (pp_list pp) tl + fprintf fmt "[%a" pp hd; + let rec pp_tail fmt = function + | Empty_list -> fprintf fmt "]" + | Cons_list (hd, Empty_list) -> fprintf fmt "; %a]" pp hd + | Cons_list (hd, tl) -> + fprintf fmt "; %a" pp hd; + pp_tail fmt tl + in + pp_tail fmt tl ;; let rec pp_pattern fmt = function @@ -61,7 +66,7 @@ and pp_expr fmt expr = match expr with | Const (Int_lt i) -> fprintf fmt "%d " i | Const (Bool_lt b) -> fprintf fmt "%b " b - | Const (String_lt s) -> fprintf fmt "%S " s + | Const (String_lt s) -> fprintf fmt "\"%s\"" s | Const Unit_lt -> fprintf fmt "() " | List l -> fprintf fmt "%a " (pp_list pp_expr) l | Tuple (e1, e2, rest) -> From 1f758071e0248263895b4768721a17a3f79850d9 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 14:28:03 +0300 Subject: [PATCH 170/310] ref: delete outdated functions Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 37 ------------------------------ 1 file changed, 37 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index f42aa5f34..121684f3f 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -104,43 +104,6 @@ let p_ident = let p_var_expr = p_ident >>| fun ident -> Variable ident let p_var_pat = p_ident >>| fun ident -> PVar ident -(* - let p_empty_list empty_list = - skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws *> return empty_list - ;; - let p_empty_list_expr = p_empty_list Empty_list - let p_empty_list_pat = p_empty_list EmptyList - let make_cons_expr e1 e2 = Cons_list (e1, e2) - let make_cons_pat p1 p2 = PCons (p1, p2) - - let p_cons_list p p_empty_list make_list = - skip_ws - *> chainr1 (p <|> p_empty_list) (skip_ws *> string "::" *> skip_ws *> return make_list) - ;; - - let p_cons_list_expr p_expr = p_cons_list p_expr p_empty_list_expr make_cons_expr - let p_cons_list_pat p_pat = p_cons_list p_pat p_empty_list_pat make_cons_pat *) - -(* - let p_semicolon_list p empty_list cons_list = - skip_ws - *> string "[" - *> skip_ws - *> fix (fun p_semi_list -> - choice - [ (p - <* skip_ws - <* string ";" - <* skip_ws - >>= fun hd -> p_semi_list >>= fun tl -> return (cons_list hd tl)) - ; (p <* skip_ws <* string "]" <* skip_ws >>| fun hd -> cons_list hd empty_list) - ; string "]" *> skip_ws *> return empty_list - ]) -;; - -let p_semicolon_list_expr p_expr = p_semicolon_list p_expr Empty_list make_cons_expr -let p_semicolon_list_pat p_pat = p_semicolon_list p_pat PEmptyList make_cons_pat *) - let p_empty_list = skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws *> return Empty_list ;; From b643252be1fefe22717a2222db3cb56a48ef6d15 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 16:04:05 +0300 Subject: [PATCH 171/310] fix: add missing dependency Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/dune-project | 1 + 1 file changed, 1 insertion(+) diff --git a/FSharpActivePatterns/dune-project b/FSharpActivePatterns/dune-project index 2918ff06f..d26478070 100644 --- a/FSharpActivePatterns/dune-project +++ b/FSharpActivePatterns/dune-project @@ -28,6 +28,7 @@ (ppx_inline_test :with-test) ppx_expect ppx_deriving + ppx_deriving_qcheck bisect_ppx (odoc :with-doc) (ocamlformat :build))) From 2671d518f389ea5ef6732fb18de21581ca7802e9 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 16:09:07 +0300 Subject: [PATCH 172/310] fix: new opam Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/FSharpActivePatterns.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/FSharpActivePatterns/FSharpActivePatterns.opam b/FSharpActivePatterns/FSharpActivePatterns.opam index 8c6cb3248..bb90632fe 100644 --- a/FSharpActivePatterns/FSharpActivePatterns.opam +++ b/FSharpActivePatterns/FSharpActivePatterns.opam @@ -17,6 +17,7 @@ depends: [ "ppx_inline_test" {with-test} "ppx_expect" "ppx_deriving" + "ppx_deriving_qcheck" "bisect_ppx" "odoc" {with-doc} "ocamlformat" {build} From 7f5eb6164aaf0129c65599ba59fa8065b9074680 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 17:06:49 +0300 Subject: [PATCH 173/310] fix: update test config Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/tests/qcheck.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index e8bce25f7..b4efe7358 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ $ ../lib/tests/run_construction.exe -seed 12 -gen 1 -stop - random seed: 1 + random seed: 12 ================================================================================ success (ran 1 tests) From 4e93fbaf14863192b1cf0ca14c718b5da6de3c9c Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 17:44:12 +0300 Subject: [PATCH 174/310] fix: exclude unused declarations Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 9 ++++---- .../lib/tests/gen_construction.ml | 23 +++++++++++-------- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 121684f3f..9265b78f2 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -36,9 +36,10 @@ let chainl1 e op = e >>= go ;; -let rec chainr1 e op = - e >>= fun rest -> op >>= (fun f -> chainr1 e op >>| f rest) <|> return rest -;; +(* + let rec chainr1 e op = + e >>= fun rest -> op >>= (fun f -> chainr1 e op >>| f rest) <|> return rest + ;;*) let rec unary_chain op e = op >>= (fun unexpr -> unary_chain op e >>= fun expr -> return (unexpr expr)) <|> e @@ -196,7 +197,7 @@ let p_tuple make p = <* string ")" ;; -let p_tuple_expr p_expr = p_tuple make_tuple_expr p_expr +(*let p_tuple_expr p_expr = p_tuple make_tuple_expr p_expr*) let p_tuple_pat p_pat = p_tuple make_tuple_pat p_pat let p_if p_expr = diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 814bbc66e..496131685 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -43,18 +43,20 @@ open FSharpActivePatterns.PrettyPrinter (* let gen_ident_manual = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname_manual let gen_variable_manual = QCheck.Gen.map variable_e gen_varname_manual -let gen_unop_manual = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) *) +let gen_unop_manual = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) let tuple_e e1 e2 rest = Tuple (e1, e2, rest) -let un_e unop e = Unary_expr (unop, e) +let un_e unop e = Unary_expr (unop, e)*) let bin_e op e1 e2 = Bin_expr (op, e1, e2) -let if_e i t e = If_then_else (i, t, e) -let func_def pat pat_list body = Lambda (pat, pat_list, body) -let apply f arg = Apply (f, arg) -let let_bind name args body = Let_bind (name, args, body) +(* + let if_e i t e = If_then_else (i, t, e) + let func_def pat pat_list body = Lambda (pat, pat_list, body) + let apply f arg = Apply (f, arg) + let let_bind name args body = Let_bind (name, args, body) *) -let letin rec_flag let_bind let_bind_list inner_e = - LetIn (rec_flag, let_bind, let_bind_list, inner_e) -;; +(* + let letin rec_flag let_bind let_bind_list inner_e = + LetIn (rec_flag, let_bind, let_bind_list, inner_e) + ;; *) (* let gen_binop_manual = @@ -227,7 +229,8 @@ and shrink_pattern = | _ -> empty ;; -let let_st rec_flag let_bind let_bind_list = Let (rec_flag, let_bind, let_bind_list) +(* + let let_st rec_flag let_bind let_bind_list = Let (rec_flag, let_bind, let_bind_list)*) (* TODO: Active Pattern*) (* From 10340a9079b1af7df6f52a59bcc59b05da31944d Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 17:53:03 +0300 Subject: [PATCH 175/310] fix: unused dependencies Signed-off-by: Ksenia Kotelnikova --- .../lib/tests/run_construction.ml | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/run_construction.ml b/FSharpActivePatterns/lib/tests/run_construction.ml index 015a9e648..7f44a60e7 100644 --- a/FSharpActivePatterns/lib/tests/run_construction.ml +++ b/FSharpActivePatterns/lib/tests/run_construction.ml @@ -7,14 +7,16 @@ [@@@ocaml.text "/*"] open Tests.Gen_construction -open FSharpActivePatterns.Ast -open FSharpActivePatterns.AstPrinter +(* + open FSharpActivePatterns.Ast + open FSharpActivePatterns.AstPrinter*) -let generate n = - List.iter - Format.(fprintf std_formatter "%a\n" print_construction) - (QCheck.Gen.generate ~n gen_construction) -;; +(* + let generate n = + List.iter + Format.(fprintf std_formatter "%a\n" print_construction) + (QCheck.Gen.generate ~n gen_construction) + ;;*) let run_tests n = let _ = run n in From f198618ca087dce70d50d32f51bccd3cf0ec183c Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 18:18:32 +0300 Subject: [PATCH 176/310] ref: eta reduction Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 9265b78f2..783a6865a 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -189,7 +189,7 @@ let p_tuple make p = skip_ws *> string "(" *> lift3 - (fun fst snd tail -> make fst snd tail) + make p (skip_ws *> string "," *> skip_ws *> p) (many (skip_ws *> string "," *> skip_ws *> p)) From efd3c486ccb271be6bec2054e49214b2609eb53a Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 18 Nov 2024 22:05:59 +0300 Subject: [PATCH 177/310] feat: expr and let_bind generators starts with small_nat Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 26 +++++++++++++++++++------- FSharpActivePatterns/tests/qcheck.t | 2 +- 2 files changed, 20 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index cede848ab..d9ca7a689 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -68,7 +68,7 @@ type pattern = | PTuple of pattern * pattern - * (pattern list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_pattern_sized (n / 4)))]) + * (pattern list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_pattern_sized (n / 2)))]) (** | [(a, b)] -> *) | PConst of literal (** | [4] -> *) | PVar of ident (** pattern identifier *) @@ -85,7 +85,7 @@ type expr = | Tuple of expr * expr - * (expr list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_expr_sized (n / 4)))]) + * (expr list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_expr_sized (n / 2)))]) (** [(1, "Hello world", true)] *) | List of expr list_type (** [], hd :: tl, [1;2;3] *) | Variable of ident (** [x], [y] *) @@ -93,23 +93,23 @@ type expr = | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) | Lambda of - pattern - * (pattern list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_pattern_sized (n / 4)))]) + (pattern[@gen gen_pattern_sized (n / 2)]) + * (pattern list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_pattern_sized (n / 2)))]) * expr (** fun x y -> x + y *) | Apply of expr * expr (** [sum 1 ] *) | Match of expr - * pattern + * (pattern[@gen gen_pattern_sized (n / 2)]) * expr * ((pattern * expr) list [@gen QCheck.Gen.( - list_size (0 -- 5) (pair (gen_pattern_sized (n / 4)) (gen_expr_sized (n / 4))))]) + list_size (0 -- 5) (pair (gen_pattern_sized (n / 2)) (gen_expr_sized (n / 2))))]) (** [match x with | x -> ... | y -> ...] *) | LetIn of is_recursive * let_bind - * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_let_bind_sized (n / 4)))]) + * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_let_bind_sized (n / 2)))]) * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) [@@deriving eq, show { with_path = false }, qcheck] @@ -119,6 +119,18 @@ and let_bind = (** [and sum n m = n+m] *) [@@deriving eq, show { with_path = false }, qcheck] +let gen_expr = + QCheck.Gen.( + let* n = small_nat in + gen_expr_sized n) +;; + +let gen_let_bind = + QCheck.Gen.( + let* n = small_nat in + gen_let_bind_sized n) +;; + type statement = | Let of is_recursive diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index b4efe7358..458bf74be 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_construction.exe -seed 12 -gen 1 -stop + $ ../lib/tests/run_construction.exe -seed 1 -gen 10 -stop random seed: 12 ================================================================================ success (ran 1 tests) From aa53b8ef70a98da885f9e8612d083bdb6f767846 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 22:16:03 +0300 Subject: [PATCH 178/310] feat: implemet bit opers parsers Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 783a6865a..440ea406d 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -184,6 +184,9 @@ let greater = p_binexpr ">" Binary_greater let greater_or_equal = p_binexpr ">=" Binary_greater_or_equal let log_or = p_binexpr "||" Logical_or let log_and = p_binexpr "&&" Logical_and +let bitwise_or = p_binexpr "|||" Binary_or_bitwise +let bitwise_and = p_binexpr "&&&" Binary_and_bitwise +let bitwise_xor = p_binexpr "^^^" Binary_xor_bitwise let p_tuple make p = skip_ws @@ -323,7 +326,10 @@ let p_expr = let comp_eq = chainl1 term (equal <|> unequal) in let comp_less = chainl1 comp_eq (less_or_equal <|> less) in let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in - let comp_and = chainl1 comp_gr log_and in + let bit_xor = chainl1 comp_gr bitwise_xor in + let bit_and = chainl1 bit_xor bitwise_and in + let bit_or = chainl1 bit_and bitwise_or in + let comp_and = chainl1 bit_or log_and in let comp_or = chainl1 comp_and log_or in let apply = p_apply comp_or <|> comp_or in let cons_list = p_cons_list_expr apply <|> apply in From 02672d25e460a20abfe4e97709086f2dd8606337 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 22:27:32 +0300 Subject: [PATCH 179/310] fix: boolean parsing Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 440ea406d..97b5f009f 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -60,7 +60,7 @@ let p_int_expr = expr_const_factory p_int let p_int_pat = pat_const_factory p_int let p_bool = - skip_ws *> string "true" <|> string "false" >>| fun s -> Bool_lt (Bool.of_string s) + (skip_ws *> string "true") <|> (skip_ws *> string "false") >>| fun s -> Bool_lt (Bool.of_string s) ;; let p_bool_expr = expr_const_factory p_bool @@ -274,6 +274,7 @@ let p_pat = ; p_cons_list_pat p_var_pat ; p_var_pat ; p_pat_const + ; p_string_pat ; string "_" *> return Wild ]) ;; From 3c1fa8958df992a4695803b161f4f78d5c187f6b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 18 Nov 2024 22:53:24 +0300 Subject: [PATCH 180/310] feat: string literal generator without double quotes and backslash Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 14 +++++++++++++- .../lib/tests/run_construction.ml | 16 +++++++--------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index d9ca7a689..b4722955d 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -27,10 +27,22 @@ let gen_varname = let gen_ident = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 5) gen_ident) +let gen_char = + let open QCheck.Gen in + let rec loop () = + let* char = char_range (Char.chr 32) (Char.chr 126) in + match char with + | '\\' -> loop () + | '"' -> loop () + | _ -> return char + in + loop () +;; + type literal = | Int_lt of (int[@gen QCheck.Gen.pint]) (** [0], [1], [30] *) | Bool_lt of bool (** [false], [true] *) - | String_lt of (string[@gen QCheck.Gen.string_printable]) (** ["Hello world"] *) + | String_lt of (string[@gen QCheck.Gen.string_of gen_char]) (** ["Hello world"] *) | Unit_lt (** [Unit] *) [@@deriving eq, show { with_path = false }, qcheck] diff --git a/FSharpActivePatterns/lib/tests/run_construction.ml b/FSharpActivePatterns/lib/tests/run_construction.ml index 7f44a60e7..015a9e648 100644 --- a/FSharpActivePatterns/lib/tests/run_construction.ml +++ b/FSharpActivePatterns/lib/tests/run_construction.ml @@ -7,16 +7,14 @@ [@@@ocaml.text "/*"] open Tests.Gen_construction -(* - open FSharpActivePatterns.Ast - open FSharpActivePatterns.AstPrinter*) +open FSharpActivePatterns.Ast +open FSharpActivePatterns.AstPrinter -(* - let generate n = - List.iter - Format.(fprintf std_formatter "%a\n" print_construction) - (QCheck.Gen.generate ~n gen_construction) - ;;*) +let generate n = + List.iter + Format.(fprintf std_formatter "%a\n" print_construction) + (QCheck.Gen.generate ~n gen_construction) +;; let run_tests n = let _ = run n in From d8c9120835f7377dc3ff3649b451654d10004f55 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 23:05:19 +0300 Subject: [PATCH 181/310] fix: add breackets over fun Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/prettyPrinter.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 8bd811236..aaad0bfb8 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -88,10 +88,10 @@ and pp_expr fmt expr = | Some body -> fprintf fmt "else %a " pp_expr body | None -> ()) | Lambda (pat1, pat_list, body) -> - fprintf fmt "fun "; + fprintf fmt "(fun "; fprintf fmt "%a " pp_pattern pat1; List.iter (fun pat -> fprintf fmt "%a " pp_pattern pat) pat_list; - fprintf fmt "-> %a " pp_expr body + fprintf fmt "-> %a )" pp_expr body | Apply (func, arg) -> fprintf fmt "(%a) (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> fprintf fmt "let %a " pp_rec_flag rec_flag; From 990f781089101f144ef14c99588e0a60ea7002c5 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 18 Nov 2024 23:13:50 +0300 Subject: [PATCH 182/310] feat: string generator generates small strings Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 2 +- FSharpActivePatterns/tests/qcheck.t | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index b4722955d..67713f8a3 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -42,7 +42,7 @@ let gen_char = type literal = | Int_lt of (int[@gen QCheck.Gen.pint]) (** [0], [1], [30] *) | Bool_lt of bool (** [false], [true] *) - | String_lt of (string[@gen QCheck.Gen.string_of gen_char]) (** ["Hello world"] *) + | String_lt of (string[@gen QCheck.Gen.string_small_of gen_char]) (** ["Hello world"] *) | Unit_lt (** [Unit] *) [@@deriving eq, show { with_path = false }, qcheck] diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 458bf74be..3f280edaf 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_construction.exe -seed 1 -gen 10 -stop + $ ../lib/tests/run_construction.exe -seed 1 -gen 7 -stop random seed: 12 ================================================================================ success (ran 1 tests) From 5d333e75ef11146e7036110ea8d1c51b7aaacae2 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 18 Nov 2024 23:34:27 +0300 Subject: [PATCH 183/310] fix: parsing of option Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/keywordChecker.ml | 2 ++ FSharpActivePatterns/lib/parser.ml | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/keywordChecker.ml b/FSharpActivePatterns/lib/keywordChecker.ml index 084c558ff..0e8fe5e00 100644 --- a/FSharpActivePatterns/lib/keywordChecker.ml +++ b/FSharpActivePatterns/lib/keywordChecker.ml @@ -15,6 +15,8 @@ let is_keyword = function | "match" | "with" | "and" + | "Some" + | "None" | "_" -> true | _ -> false ;; diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 97b5f009f..73994c127 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -335,7 +335,7 @@ let p_expr = let apply = p_apply comp_or <|> comp_or in let cons_list = p_cons_list_expr apply <|> apply in let ematch = p_match cons_list <|> cons_list in - let efun = p_lambda ematch <|> ematch in + let efun = p_lambda (p_expr <|> ematch) <|> ematch in let option = p_option efun <|> efun in option) ;; From 902c4345c69f98f3d10ac19a22e2d70cf389fab1 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 19 Nov 2024 00:04:02 +0300 Subject: [PATCH 184/310] fix: pattern in match priority Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/prettyPrinter.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index aaad0bfb8..e631fa62a 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -74,10 +74,11 @@ and pp_expr fmt expr = pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); fprintf fmt ")" | Match (value, pat1, expr1, cases) -> - fprintf fmt "match %a with \n" pp_expr value; + fprintf fmt "(match %a with \n" pp_expr value; List.iter (fun (pat, expr) -> fprintf fmt "| %a -> %a \n" pp_pattern pat pp_expr expr) - ((pat1, expr1) :: cases) + ((pat1, expr1) :: cases); + fprintf fmt ")" | Variable (Ident (name, _)) -> fprintf fmt "%s " name | Unary_expr (op, expr) -> fprintf fmt "%a (%a)" pp_unary_op op pp_expr expr | Bin_expr (op, left, right) -> From 24bab4725889a173957578b0c2e523daa84a8b91 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 19 Nov 2024 00:37:11 +0300 Subject: [PATCH 185/310] fix: unit and if parsing Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 73994c127..f1166924c 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -24,7 +24,7 @@ let peek_sep1 = match c with | None -> return None | Some c -> - if is_ws c || Char.equal c '(' || Char.equal c ')' + if is_ws c || Char.equal c '(' || Char.equal c ')' || Char.equal c ',' then return (Some c) else fail "need a delimiter" ;; @@ -151,7 +151,7 @@ let p_semicolon_list_pat p_pat = p_semicolon_list p_pat Empty_list >>= fun l -> return (PList l) ;; -let p_unit = skip_ws *> string "(" *> skip_ws *> string ")" *> skip_ws *> return Unit_lt +let p_unit = skip_ws *> string "(" *> skip_ws *> string ")" *> return Unit_lt let p_unit_expr = expr_const_factory p_unit let p_unit_pat = pat_const_factory p_unit From d3031bf13b10c2fe990d911db6cbf99aeab470e1 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 19 Nov 2024 00:47:25 +0300 Subject: [PATCH 186/310] feat: change match pretty printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/prettyPrinter.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index e631fa62a..c15bcac79 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -74,11 +74,10 @@ and pp_expr fmt expr = pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); fprintf fmt ")" | Match (value, pat1, expr1, cases) -> - fprintf fmt "(match %a with \n" pp_expr value; + fprintf fmt "match %a with \n" pp_expr value; List.iter - (fun (pat, expr) -> fprintf fmt "| %a -> %a \n" pp_pattern pat pp_expr expr) - ((pat1, expr1) :: cases); - fprintf fmt ")" + (fun (pat, expr) -> fprintf fmt "| %a -> (%a) \n" pp_pattern pat pp_expr expr) + ((pat1, expr1) :: cases) | Variable (Ident (name, _)) -> fprintf fmt "%s " name | Unary_expr (op, expr) -> fprintf fmt "%a (%a)" pp_unary_op op pp_expr expr | Bin_expr (op, left, right) -> From 13708057faa69598d569cad0b8d2bf1dc45086ae Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 19 Nov 2024 01:04:30 +0300 Subject: [PATCH 187/310] feat: implement unary expression shrinker Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/gen_construction.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 496131685..23446ae39 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -165,6 +165,7 @@ and shrink_expr = of_list [ e1; e2 ] <+> (shrink_expr e1 >|= fun a' -> bin_e op a' e2) <+> (shrink_expr e2 >|= fun a' -> bin_e op e1 a') + | Unary_expr (op, e) -> return e <+> (shrink_expr e >|= fun e' -> Unary_expr (op, e')) | If_then_else (i, t, Some e) -> of_list [ i; t; e; If_then_else (i, e, None) ] <+> (shrink_expr i >|= fun a' -> If_then_else (a', t, Some e)) @@ -203,7 +204,9 @@ and shrink_expr = >|= fun a' -> Match (value, pat1, expr1, a')) | Option (Some e) -> of_list [ e; Option None ] <+> (shrink_expr e >|= fun a' -> Option (Some a')) - | _ -> empty + | Option None -> empty + | Variable _ -> empty + | List Empty_list -> empty and shrink_pattern = let open QCheck.Iter in @@ -226,7 +229,9 @@ and shrink_pattern = <+> (QCheck.Shrink.list ~shrink:shrink_pattern rest >|= fun rest' -> PTuple (p1, p2, rest')) | PConst lt -> shrink_lt lt >|= fun lt' -> PConst lt' - | _ -> empty + | PList Empty_list -> empty + | Wild -> empty + | PVar _ -> empty ;; (* From aed3f169f45a0b45c0fa33208aed47adc63882a4 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 19 Nov 2024 01:10:01 +0300 Subject: [PATCH 188/310] fix: match expr shrinker Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/gen_construction.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index 23446ae39..caa2410af 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -197,9 +197,11 @@ and shrink_expr = <+> (shrink_expr expr1 >|= fun a' -> Match (value, pat1, a', cases)) <+> (QCheck.Shrink.list ~shrink:(fun (p, e) -> - let* p_shr = shrink_pattern p in + (let* p_shr = shrink_pattern p in + return (p_shr, e)) + <+> let* e_shr = shrink_expr e in - return (p_shr, e_shr)) + return (p, e_shr)) cases >|= fun a' -> Match (value, pat1, expr1, a')) | Option (Some e) -> From da35d77efbe8e861a943be7c9337883d1ab18b7a Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 19 Nov 2024 01:21:53 +0300 Subject: [PATCH 189/310] fix: match inner expr parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index f1166924c..bc29d5fd5 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -60,7 +60,9 @@ let p_int_expr = expr_const_factory p_int let p_int_pat = pat_const_factory p_int let p_bool = - (skip_ws *> string "true") <|> (skip_ws *> string "false") >>| fun s -> Bool_lt (Bool.of_string s) + skip_ws *> string "true" + <|> skip_ws *> string "false" + >>| fun s -> Bool_lt (Bool.of_string s) ;; let p_bool_expr = expr_const_factory p_bool @@ -334,7 +336,7 @@ let p_expr = let comp_or = chainl1 comp_and log_or in let apply = p_apply comp_or <|> comp_or in let cons_list = p_cons_list_expr apply <|> apply in - let ematch = p_match cons_list <|> cons_list in + let ematch = p_match (p_expr <|> cons_list) <|> cons_list in let efun = p_lambda (p_expr <|> ematch) <|> ematch in let option = p_option efun <|> efun in option) From 27ecdd9841bd3bcd8851147c61f108e608f8a395 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 19 Nov 2024 02:06:01 +0300 Subject: [PATCH 190/310] fix: remove skip_ws in the end of parsers Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 21 +++++---------------- 1 file changed, 5 insertions(+), 16 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index bc29d5fd5..5cabe134c 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -106,11 +106,7 @@ let p_ident = let p_var_expr = p_ident >>| fun ident -> Variable ident let p_var_pat = p_ident >>| fun ident -> PVar ident - -let p_empty_list = - skip_ws *> string "[" *> skip_ws *> string "]" *> skip_ws *> return Empty_list -;; - +let p_empty_list = skip_ws *> string "[" *> skip_ws *> string "]" *> return Empty_list let make_list e1 e2 = Cons_list (e1, e2) (* elem because it is for both patterns and expressions *) @@ -140,8 +136,8 @@ let p_semicolon_list p_elem empty_list = <* string ";" <* skip_ws >>= fun hd -> p_semi_list >>= fun tl -> return (make_list hd tl)) - ; (p_elem <* skip_ws <* string "]" <* skip_ws >>| fun hd -> make_list hd empty_list) - ; string "]" *> skip_ws *> return empty_list + ; (p_elem <* skip_ws <* string "]" >>| fun hd -> make_list hd empty_list) + ; string "]" *> return empty_list ]) ;; @@ -163,15 +159,8 @@ let make_binexpr op expr1 expr2 = Bin_expr (op, expr1, expr2) [@@inline always] let make_unexpr op expr = Unary_expr (op, expr) [@@inline always] let make_tuple_expr e1 e2 rest = Tuple (e1, e2, rest) [@@inline always] let make_tuple_pat p1 p2 rest = PTuple (p1, p2, rest) - -let p_binexpr binop_str binop = - skip_ws *> string binop_str *> skip_ws *> return (make_binexpr binop) -;; - -let p_unexpr unop_str unop = - skip_ws *> string unop_str *> skip_ws *> return (make_unexpr unop) -;; - +let p_binexpr binop_str binop = skip_ws *> string binop_str *> return (make_binexpr binop) +let p_unexpr unop_str unop = skip_ws *> string unop_str *> return (make_unexpr unop) let p_not = p_unexpr "not" Unary_not let unminus = p_unexpr "-" Unary_minus let add = p_binexpr "+" Binary_add From 4929201de4a0429d2c19b2eb6918aec87d626d81 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 19 Nov 2024 04:28:26 +0300 Subject: [PATCH 191/310] ref: comment unused function Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/run_construction.ml | 12 +++++------- FSharpActivePatterns/tests/qcheck.t | 2 +- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/run_construction.ml b/FSharpActivePatterns/lib/tests/run_construction.ml index 015a9e648..d4c141a70 100644 --- a/FSharpActivePatterns/lib/tests/run_construction.ml +++ b/FSharpActivePatterns/lib/tests/run_construction.ml @@ -7,14 +7,12 @@ [@@@ocaml.text "/*"] open Tests.Gen_construction -open FSharpActivePatterns.Ast -open FSharpActivePatterns.AstPrinter -let generate n = - List.iter - Format.(fprintf std_formatter "%a\n" print_construction) - (QCheck.Gen.generate ~n gen_construction) -;; +(* let generate n = + List.iter + Format.(fprintf std_formatter "%a\n" print_construction) + (QCheck.Gen.generate ~n gen_construction) + ;; *) let run_tests n = let _ = run n in diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 3f280edaf..7edac3267 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_construction.exe -seed 1 -gen 7 -stop + $ ../lib/tests/run_construction.exe -seed 12 -gen 10 -stop random seed: 12 ================================================================================ success (ran 1 tests) From 0104f60ca3de6b774f1000beaad2215dfead92eb Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 19 Nov 2024 04:29:21 +0300 Subject: [PATCH 192/310] ref: remove manual generator Signed-off-by: Gleb Nasretdinov --- .../lib/tests/gen_construction.ml | 139 ------------------ 1 file changed, 139 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/gen_construction.ml index caa2410af..1bf0e11dd 100644 --- a/FSharpActivePatterns/lib/tests/gen_construction.ml +++ b/FSharpActivePatterns/lib/tests/gen_construction.ml @@ -10,119 +10,8 @@ open FSharpActivePatterns.Ast open FSharpActivePatterns.AstPrinter open FSharpActivePatterns.Parser open FSharpActivePatterns.PrettyPrinter -(*open FSharpActivePatterns.KeywordChecker*) -(* - let gen_const_manual = - QCheck.Gen.( - frequency - [ 1, map int_e nat - ; 1, map bool_e bool - ; 0, return unit_e - ; 0, map string_e (string ?gen:None) - ]) - ;; - - let gen_varname_manual = - let open QCheck.Gen in - let loop = - let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in - let gen_first_char = - oneof [ gen_char_of_range 'a' 'z'; gen_char_of_range 'A' 'Z'; return '_' ] - in - let gen_next_char = oneof [ gen_first_char; gen_char_of_range '0' '9' ] in - map2 - (fun first rest -> - String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) - gen_first_char - (list_size (1 -- 5) gen_next_char) - in - loop >>= fun name -> if is_keyword name then loop else return name - ;; *) - -(* - let gen_ident_manual = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname_manual -let gen_variable_manual = QCheck.Gen.map variable_e gen_varname_manual -let gen_unop_manual = QCheck.Gen.(oneof @@ List.map return [ Unary_minus; Unary_not ]) -let tuple_e e1 e2 rest = Tuple (e1, e2, rest) -let un_e unop e = Unary_expr (unop, e)*) let bin_e op e1 e2 = Bin_expr (op, e1, e2) -(* - let if_e i t e = If_then_else (i, t, e) - let func_def pat pat_list body = Lambda (pat, pat_list, body) - let apply f arg = Apply (f, arg) - let let_bind name args body = Let_bind (name, args, body) *) - -(* - let letin rec_flag let_bind let_bind_list inner_e = - LetIn (rec_flag, let_bind, let_bind_list, inner_e) - ;; *) - -(* - let gen_binop_manual = - QCheck.Gen.( - oneof - @@ List.map - return - [ Binary_equal - ; Binary_unequal - ; Binary_less - ; Binary_less_or_equal - ; Binary_greater - ; Binary_greater_or_equal - ; Binary_add - ; Binary_subtract - ; Binary_multiply - ; Logical_or - ; Logical_and - ; Binary_divide - (* ; Binary_or_bitwise - ; Binary_xor_bitwise - ; Binary_and_bitwise *) - ]) -;; - -let gen_is_recursive_manual = QCheck.Gen.(oneof [ return Rec; return Nonrec ]) - -let gen_let_bind_manual gen = - QCheck.Gen.(map3 let_bind gen_ident_manual (list_size (0 -- 15) gen_ident_manual) gen) -;; *) - -(* - let gen_expr_manual = - QCheck.Gen.( - sized - @@ fix (fun self -> - function - | 0 -> frequency [ 1, gen_const_manual; 1, gen_variable_manual ] - | n -> - frequency - [ ( 1 - , map3 - tuple_e - (self (n / 4)) - (self (n / 4)) - (list_size (0 -- 15) (self (n / 4))) ) - ; 1, map2 un_e gen_unop_manual (self (n / 4)) - ; 1, map3 bin_e gen_binop_manual (self (n / 4)) (self (n / 4)) - ; ( 1 - , map3 - if_e - (self (n / 4)) - (self (n / 4)) - (oneof [ return None; map (fun e -> Some e) (self (n / 4)) ]) ) - ; 0, map2 func_def (list_size (0 -- 15) gen_ident_manual) (self (n / 4)) - ; 1, map2 func_call gen_variable_manual (self (n / 4)) - (* TODO: make apply of arbitrary expr*) - ; ( 0 - , map3 - letin - gen_is_recursive_manual - (gen_let_bind_manual (self (n / 4))) - (list_size (0 -- 15) (gen_let_bind_manual (self (n / 4)))) - <*> self (n / 4) ) - ])) -;; *) let shrink_lt = let open QCheck.Iter in @@ -236,20 +125,6 @@ and shrink_pattern = | PVar _ -> empty ;; -(* - let let_st rec_flag let_bind let_bind_list = Let (rec_flag, let_bind, let_bind_list)*) - -(* TODO: Active Pattern*) -(* - let gen_statement_manual = - QCheck.Gen.( - map3 - let_st - gen_is_recursive_manual - (gen_let_bind_manual gen_expr_manual) - (list_size (0 -- 15) (gen_let_bind_manual gen_expr_manual))) - ;; *) - let shrink_statement = let open QCheck.Iter in function @@ -260,20 +135,6 @@ let shrink_statement = >|= fun a' -> Let (rec_flag, let_bind, a')) ;; -(*| ActivePattern (cases, e) -> - QCheck.Shrink.list cases - >|= (fun a' -> ActivePattern (a', e)) - <+> (shrink_expr e >|= fun a' -> ActivePattern (cases, a')) *) - -(* - let gen_construction_manual = - QCheck.Gen.( - oneof - [ (gen_expr_manual >|= fun a' -> Expr a') - ; (gen_statement_manual >|= fun a' -> Statement a') - ]) - ;; *) - let shrink_construction = let open QCheck.Iter in function From c07ec792b6f09103b38c50ecf6cb62a4c146eccf Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 19 Nov 2024 05:18:46 +0300 Subject: [PATCH 193/310] ref: rename qcheck modules Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/dune | 6 +++--- .../lib/tests/{gen_construction.ml => qcheck_utils.ml} | 0 .../lib/tests/{gen_construction.mli => qcheck_utils.mli} | 0 .../lib/tests/{run_construction.ml => run_qcheck.ml} | 2 +- FSharpActivePatterns/tests/dune | 2 +- FSharpActivePatterns/tests/qcheck.t | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) rename FSharpActivePatterns/lib/tests/{gen_construction.ml => qcheck_utils.ml} (100%) rename FSharpActivePatterns/lib/tests/{gen_construction.mli => qcheck_utils.mli} (100%) rename FSharpActivePatterns/lib/tests/{run_construction.ml => run_qcheck.ml} (95%) diff --git a/FSharpActivePatterns/lib/tests/dune b/FSharpActivePatterns/lib/tests/dune index 9f2ed1383..5d4870845 100644 --- a/FSharpActivePatterns/lib/tests/dune +++ b/FSharpActivePatterns/lib/tests/dune @@ -1,6 +1,6 @@ (library (name tests) - (modules Ast_printer Parser Gen_construction) + (modules Ast_printer Parser Qcheck_utils) (libraries FSharpActivePatterns qcheck-core qcheck-core.runner) (preprocess (pps ppx_expect ppx_deriving.show)) @@ -8,6 +8,6 @@ (backend bisect_ppx))) (executable - (name run_construction) - (modules run_construction) + (name run_qcheck) + (modules run_qcheck) (libraries tests FSharpActivePatterns qcheck-core.runner)) diff --git a/FSharpActivePatterns/lib/tests/gen_construction.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml similarity index 100% rename from FSharpActivePatterns/lib/tests/gen_construction.ml rename to FSharpActivePatterns/lib/tests/qcheck_utils.ml diff --git a/FSharpActivePatterns/lib/tests/gen_construction.mli b/FSharpActivePatterns/lib/tests/qcheck_utils.mli similarity index 100% rename from FSharpActivePatterns/lib/tests/gen_construction.mli rename to FSharpActivePatterns/lib/tests/qcheck_utils.mli diff --git a/FSharpActivePatterns/lib/tests/run_construction.ml b/FSharpActivePatterns/lib/tests/run_qcheck.ml similarity index 95% rename from FSharpActivePatterns/lib/tests/run_construction.ml rename to FSharpActivePatterns/lib/tests/run_qcheck.ml index d4c141a70..441c3ced5 100644 --- a/FSharpActivePatterns/lib/tests/run_construction.ml +++ b/FSharpActivePatterns/lib/tests/run_qcheck.ml @@ -6,7 +6,7 @@ [@@@ocaml.text "/*"] -open Tests.Gen_construction +open Tests.Qcheck_utils (* let generate n = List.iter diff --git a/FSharpActivePatterns/tests/dune b/FSharpActivePatterns/tests/dune index 8696c8f8d..f2b8e0f4d 100644 --- a/FSharpActivePatterns/tests/dune +++ b/FSharpActivePatterns/tests/dune @@ -1,3 +1,3 @@ (cram (applies_to qcheck) - (deps ../lib/tests/run_construction.exe)) + (deps ../lib/tests/run_qcheck.exe)) diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 7edac3267..843c48083 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_construction.exe -seed 12 -gen 10 -stop + $ ../lib/tests/run_qcheck.exe -seed 12 -gen 10 -stop random seed: 12 ================================================================================ success (ran 1 tests) From 5ac344e5f1a135171a5856c21a26fd3737c21b57 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 19 Nov 2024 05:19:11 +0300 Subject: [PATCH 194/310] fix: cons list parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 5cabe134c..74f691a29 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -36,10 +36,12 @@ let chainl1 e op = e >>= go ;; -(* - let rec chainr1 e op = - e >>= fun rest -> op >>= (fun f -> chainr1 e op >>| f rest) <|> return rest - ;;*) +let rec chainr1_cons e op = + let* left = e in + (let* f = op in + chainr1_cons e op >>| f left) + <|> return (Cons_list (left, Empty_list)) +;; let rec unary_chain op e = op >>= (fun unexpr -> unary_chain op e >>= fun expr -> return (unexpr expr)) <|> e @@ -109,17 +111,11 @@ let p_var_pat = p_ident >>| fun ident -> PVar ident let p_empty_list = skip_ws *> string "[" *> skip_ws *> string "]" *> return Empty_list let make_list e1 e2 = Cons_list (e1, e2) -(* elem because it is for both patterns and expressions *) let p_cons_list p_elem = - let rec p_cons_tail acc = - skip_ws *> string "::" *> skip_ws *> p_elem - >>= (fun next -> p_cons_tail (Cons_list (next, acc))) - <|> return acc - in - p_elem - >>= fun hd -> - skip_ws *> string "::" *> skip_ws *> p_elem - >>= fun next -> p_cons_tail (Cons_list (next, Cons_list (hd, Empty_list))) + let p_cons = skip_ws *> (string "::" *> return (fun l r -> Cons_list (l, r))) in + let* first_elem = skip_ws *> p_elem <* skip_ws <* string "::" in + let* rest = chainr1_cons p_elem p_cons in + return (Cons_list (first_elem, rest)) ;; let p_cons_list_expr p_expr = p_cons_list p_expr >>= fun l -> return (List l) From 78f7b612d60abcd5842990418a607e642979a327 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 19 Nov 2024 05:51:49 +0300 Subject: [PATCH 195/310] tests: reduced number of tests in qcheck.t Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/tests/qcheck.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 843c48083..8a4587c1c 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_qcheck.exe -seed 12 -gen 10 -stop + $ ../lib/tests/run_qcheck.exe -seed 12 -gen 1 -stop random seed: 12 ================================================================================ success (ran 1 tests) From 4b68211b4d3cbc00bebbb5a35910ddc8966cf00e Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 21 Nov 2024 12:36:35 +0300 Subject: [PATCH 196/310] fix: match pretty printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/prettyPrinter.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index c15bcac79..10b783a65 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -74,7 +74,7 @@ and pp_expr fmt expr = pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); fprintf fmt ")" | Match (value, pat1, expr1, cases) -> - fprintf fmt "match %a with \n" pp_expr value; + fprintf fmt "match (%a) with \n" pp_expr value; List.iter (fun (pat, expr) -> fprintf fmt "| %a -> (%a) \n" pp_pattern pat pp_expr expr) ((pat1, expr1) :: cases) @@ -88,10 +88,9 @@ and pp_expr fmt expr = | Some body -> fprintf fmt "else %a " pp_expr body | None -> ()) | Lambda (pat1, pat_list, body) -> - fprintf fmt "(fun "; - fprintf fmt "%a " pp_pattern pat1; - List.iter (fun pat -> fprintf fmt "%a " pp_pattern pat) pat_list; - fprintf fmt "-> %a )" pp_expr body + fprintf fmt "fun "; + List.iter (fun pat -> fprintf fmt "%a " pp_pattern pat) (pat1 :: pat_list); + fprintf fmt "-> %a " pp_expr body | Apply (func, arg) -> fprintf fmt "(%a) (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> fprintf fmt "let %a " pp_rec_flag rec_flag; From 029c5af8574dff81cae79a75150959c4b059c4ef Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 21 Nov 2024 13:14:02 +0300 Subject: [PATCH 197/310] feat: add Option pattern and parentheses parsing in patterns Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 1 + FSharpActivePatterns/lib/astPrinter.ml | 7 +++++++ FSharpActivePatterns/lib/parser.ml | 17 ++++++++++------- FSharpActivePatterns/lib/prettyPrinter.ml | 4 ++++ FSharpActivePatterns/lib/tests/qcheck_utils.ml | 2 ++ 5 files changed, 24 insertions(+), 7 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 67713f8a3..081306fde 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -84,6 +84,7 @@ type pattern = (** | [(a, b)] -> *) | PConst of literal (** | [4] -> *) | PVar of ident (** pattern identifier *) + | POption of pattern option (*| Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) *) [@@deriving eq, show { with_path = false }, qcheck] diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index f24334702..bb945d42d 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -51,6 +51,13 @@ let rec print_pattern indent fmt = function | String_lt s -> fprintf fmt "%sString: %S\n" (String.make (indent + 2) '-') s | Unit_lt -> fprintf fmt "%sUnit\n" (String.make (indent + 2) '-')) | PVar (Ident (name, _)) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name + | POption p -> + fprintf fmt "%s| POption: " (String.make indent '-'); + (match p with + | None -> fprintf fmt "None\n" + | Some p -> + fprintf fmt "Some:\n"; + print_pattern (indent + 2) fmt p) ;; let print_unary_op indent fmt = function diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 74f691a29..a9e1fac38 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -242,12 +242,14 @@ let p_let p_expr = let p_apply p_expr = chainl1 p_expr (return (fun expr1 expr2 -> Apply (expr1, expr2))) -let p_option p_expr = - skip_ws *> (string "None" *> skip_ws_sep1 *> return (Option None)) - <|> (skip_ws *> string "Some" *> skip_ws_sep1 *> p_expr - >>| fun expr -> Option (Some expr)) +let p_option p make_option = + skip_ws *> (string "None" *> skip_ws_sep1 *> return (make_option None)) + <|> let+ inner = skip_ws *> string "Some" *> skip_ws_sep1 *> p in + make_option (Some inner) ;; +let make_option_expr expr = Option expr +let make_option_pat pat = POption pat let p_pat_const = choice [ p_int_pat; p_bool_pat; p_unit_pat; p_string_pat ] let p_empty_list_pat = p_empty_list >>= fun _ -> return (PList Empty_list) @@ -255,14 +257,15 @@ let p_pat = fix (fun self -> skip_ws *> choice - [ p_tuple_pat self + [ p_parens self + ; p_tuple_pat self ; p_empty_list_pat ; p_semicolon_list_pat self ; p_cons_list_pat p_var_pat ; p_var_pat ; p_pat_const - ; p_string_pat ; string "_" *> return Wild + ; p_option self make_option_pat ]) ;; @@ -323,7 +326,7 @@ let p_expr = let cons_list = p_cons_list_expr apply <|> apply in let ematch = p_match (p_expr <|> cons_list) <|> cons_list in let efun = p_lambda (p_expr <|> ematch) <|> ematch in - let option = p_option efun <|> efun in + let option = p_option efun make_option_expr <|> efun in option) ;; diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 10b783a65..866a8924e 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -61,6 +61,10 @@ let rec pp_pattern fmt = function fprintf fmt ")" | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) | PVar (Ident (name, _)) -> fprintf fmt "%s " name + | POption p -> + (match p with + | None -> fprintf fmt "None " + | Some p -> fprintf fmt "Some (%a) " pp_pattern p) and pp_expr fmt expr = match expr with diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index 1bf0e11dd..0db35cd19 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -120,6 +120,8 @@ and shrink_pattern = <+> (QCheck.Shrink.list ~shrink:shrink_pattern rest >|= fun rest' -> PTuple (p1, p2, rest')) | PConst lt -> shrink_lt lt >|= fun lt' -> PConst lt' + | POption (Some p) -> return p + | POption None -> empty | PList Empty_list -> empty | Wild -> empty | PVar _ -> empty From c78917668b28325dbe683c7b8b1a5bb52e3add54 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 21 Nov 2024 13:20:11 +0300 Subject: [PATCH 198/310] fix: List expr and patterns generators was not sized Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 081306fde..a6ed8ce4f 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -76,7 +76,9 @@ type 'a list_type = type pattern = | Wild (** [_] *) - | PList of pattern list_type (**[ [], hd :: tl, [1;2;3] ]*) + | PList of + (pattern list_type[@gen gen_list_type_sized (gen_pattern_sized (n / 2)) (n / 2)]) + (**[ [], hd :: tl, [1;2;3] ]*) | PTuple of pattern * pattern @@ -100,7 +102,8 @@ type expr = * expr * (expr list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_expr_sized (n / 2)))]) (** [(1, "Hello world", true)] *) - | List of expr list_type (** [], hd :: tl, [1;2;3] *) + | List of (expr list_type[@gen gen_list_type_sized (gen_expr_sized (n / 2)) (n / 2)]) + (** [], hd :: tl, [1;2;3] *) | Variable of ident (** [x], [y] *) | Unary_expr of unary_operator * expr (** -x *) | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) From 4aeb7f03eebfb7b93898a0a857d0075af3460788 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 21 Nov 2024 13:39:05 +0300 Subject: [PATCH 199/310] fix: Option parsing - remove extra skip_ws Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index a9e1fac38..eb28548ca 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -243,8 +243,8 @@ let p_let p_expr = let p_apply p_expr = chainl1 p_expr (return (fun expr1 expr2 -> Apply (expr1, expr2))) let p_option p make_option = - skip_ws *> (string "None" *> skip_ws_sep1 *> return (make_option None)) - <|> let+ inner = skip_ws *> string "Some" *> skip_ws_sep1 *> p in + skip_ws *> string "None" *> peek_sep1 *> return (make_option None) + <|> let+ inner = skip_ws *> string "Some" *> peek_sep1 *> p in make_option (Some inner) ;; From 939c0598b7af5fc98149b6c57e06b1570dedf777 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 21 Nov 2024 13:54:40 +0300 Subject: [PATCH 200/310] fix: remove extra whitespaces skip in parsers Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 38 +++++++++++++++--------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index eb28548ca..bbd4a439e 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -193,11 +193,11 @@ let p_tuple_pat p_pat = p_tuple make_tuple_pat p_pat let p_if p_expr = lift3 (fun cond th el -> If_then_else (cond, th, el)) - (skip_ws *> string "if" *> skip_ws_sep1 *> p_expr) - (skip_ws *> string "then" *> skip_ws_sep1 *> p_expr) + (skip_ws *> string "if" *> peek_sep1 *> p_expr) + (skip_ws *> string "then" *> peek_sep1 *> p_expr) (skip_ws *> string "else" - *> skip_ws_sep1 + *> peek_sep1 *> (p_expr <* peek_sep1 >>= fun e -> return (Some e)) <|> return None) ;; @@ -205,12 +205,12 @@ let p_if p_expr = let p_let_bind p_expr = skip_ws *> string "and" - *> skip_ws_sep1 + *> peek_sep1 *> lift3 (fun name args body -> Let_bind (name, args, body)) p_ident - (many (skip_ws *> p_ident)) - (skip_ws *> string "=" *> skip_ws *> p_expr) + (many p_ident) + (skip_ws *> string "=" *> p_expr) ;; let p_letin p_expr = @@ -218,12 +218,12 @@ let p_letin p_expr = *> string "let" *> skip_ws_sep1 *> - let* rec_flag = string "rec" *> skip_ws_sep1 *> return Rec <|> return Nonrec in + let* rec_flag = string "rec" *> peek_sep1 *> return Rec <|> return Nonrec in let* name = p_ident in - let* args = skip_ws *> many (skip_ws *> p_ident) in - let* body = skip_ws *> string "=" *> skip_ws *> p_expr in - let* let_bind_list = skip_ws *> many (skip_ws *> p_let_bind p_expr) in - let* in_expr = skip_ws *> string "in" *> skip_ws_sep1 *> p_expr in + let* args = many p_ident in + let* body = skip_ws *> string "=" *> p_expr in + let* let_bind_list = many (p_let_bind p_expr) in + let* in_expr = skip_ws *> string "in" *> peek_sep1 *> p_expr in return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) ;; @@ -232,11 +232,11 @@ let p_let p_expr = *> string "let" *> skip_ws_sep1 *> - let* rec_flag = string "rec" *> skip_ws_sep1 *> return Rec <|> return Nonrec in + let* rec_flag = string "rec" *> peek_sep1 *> return Rec <|> return Nonrec in let* name = p_ident in - let* args = skip_ws *> many (skip_ws *> p_ident) in - let* body = skip_ws *> string "=" *> skip_ws *> p_expr in - let* let_bind_list = skip_ws *> many (skip_ws *> p_let_bind p_expr) in + let* args = many p_ident in + let* body = skip_ws *> string "=" *> p_expr in + let* let_bind_list = many (p_let_bind p_expr) in return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) ;; @@ -272,10 +272,10 @@ let p_pat = let p_lambda p_expr = skip_ws *> string "fun" - *> skip_ws_sep1 + *> peek_sep1 *> - let* pat = skip_ws *> p_pat <* skip_ws in - let* pat_list = many (skip_ws *> p_pat) <* skip_ws in + let* pat = p_pat in + let* pat_list = many p_pat in let* _ = skip_ws *> string "->" in let* body = p_expr in return (Lambda (pat, pat_list, body)) @@ -286,7 +286,7 @@ let p_match p_expr = (fun value pat1 expr1 list -> Match (value, pat1, expr1, list)) (skip_ws *> string "match" *> p_expr <* skip_ws <* string "with") (skip_ws *> string "|" *> p_pat <* skip_ws <* string "->") - (skip_ws *> p_expr) + p_expr (many (skip_ws *> string "|" *> p_pat <* skip_ws From f684ceabc5fc1114cb646af9d5279cc097840544 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 22 Nov 2024 06:48:20 +0300 Subject: [PATCH 201/310] perf: reduces size of generated Ast Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index a6ed8ce4f..a27ab965e 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -19,21 +19,20 @@ let gen_varname = (fun first rest -> String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) gen_first_char - (list_size (1 -- 5) gen_next_char) + (list_size (1 -- 3) gen_next_char) in loop >>= fun name -> if is_keyword name then loop else return name ;; let gen_ident = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname -let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 5) gen_ident) +let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 3) gen_ident) let gen_char = let open QCheck.Gen in let rec loop () = let* char = char_range (Char.chr 32) (Char.chr 126) in match char with - | '\\' -> loop () - | '"' -> loop () + | '\\' | '"' -> loop () | _ -> return char in loop () @@ -42,7 +41,8 @@ let gen_char = type literal = | Int_lt of (int[@gen QCheck.Gen.pint]) (** [0], [1], [30] *) | Bool_lt of bool (** [false], [true] *) - | String_lt of (string[@gen QCheck.Gen.string_small_of gen_char]) (** ["Hello world"] *) + | String_lt of (string[@gen QCheck.Gen.(string_size (0 -- 5) ~gen:gen_char)]) + (** ["Hello world"] *) | Unit_lt (** [Unit] *) [@@deriving eq, show { with_path = false }, qcheck] @@ -77,12 +77,12 @@ type 'a list_type = type pattern = | Wild (** [_] *) | PList of - (pattern list_type[@gen gen_list_type_sized (gen_pattern_sized (n / 2)) (n / 2)]) + (pattern list_type[@gen gen_list_type_sized (gen_pattern_sized (n / 8)) (n / 2)]) (**[ [], hd :: tl, [1;2;3] ]*) | PTuple of pattern * pattern - * (pattern list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_pattern_sized (n / 2)))]) + * (pattern list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_pattern_sized (n / 8)))]) (** | [(a, b)] -> *) | PConst of literal (** | [4] -> *) | PVar of ident (** pattern identifier *) @@ -100,9 +100,9 @@ type expr = | Tuple of expr * expr - * (expr list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_expr_sized (n / 2)))]) + * (expr list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_expr_sized (n / 8)))]) (** [(1, "Hello world", true)] *) - | List of (expr list_type[@gen gen_list_type_sized (gen_expr_sized (n / 2)) (n / 2)]) + | List of (expr list_type[@gen gen_list_type_sized (gen_expr_sized (n / 8)) (n / 2)]) (** [], hd :: tl, [1;2;3] *) | Variable of ident (** [x], [y] *) | Unary_expr of unary_operator * expr (** -x *) @@ -110,7 +110,7 @@ type expr = | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) | Lambda of (pattern[@gen gen_pattern_sized (n / 2)]) - * (pattern list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_pattern_sized (n / 2)))]) + * (pattern list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_pattern_sized (n / 8)))]) * expr (** fun x y -> x + y *) | Apply of expr * expr (** [sum 1 ] *) | Match of @@ -120,12 +120,12 @@ type expr = * ((pattern * expr) list [@gen QCheck.Gen.( - list_size (0 -- 5) (pair (gen_pattern_sized (n / 2)) (gen_expr_sized (n / 2))))]) + list_size (0 -- 2) (pair (gen_pattern_sized (n / 8)) (gen_expr_sized (n / 8))))]) (** [match x with | x -> ... | y -> ...] *) | LetIn of is_recursive * let_bind - * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 5) (gen_let_bind_sized (n / 2)))]) + * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_let_bind_sized (n / 8)))]) * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) [@@deriving eq, show { with_path = false }, qcheck] From 5bc9047d7d17525cb3340bab33e219308942ce19 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 22 Nov 2024 06:51:27 +0300 Subject: [PATCH 202/310] feat: add weights in ident generator Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index a27ab965e..231ec0b6e 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -12,9 +12,10 @@ let gen_varname = let loop = let gen_char_of_range l r = map Char.chr (int_range (Char.code l) (Char.code r)) in let gen_first_char = - oneof [ gen_char_of_range 'a' 'z'; gen_char_of_range 'A' 'Z'; return '_' ] + frequency + [ 26, gen_char_of_range 'a' 'z'; 26, gen_char_of_range 'A' 'Z'; 1, return '_' ] in - let gen_next_char = oneof [ gen_first_char; gen_char_of_range '0' '9' ] in + let gen_next_char = frequency [ 53, gen_first_char; 10, gen_char_of_range '0' '9' ] in map2 (fun first rest -> String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) From 6076e3f1f187d2b5fe8cd53f3e5f48e18537dc19 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 22 Nov 2024 11:25:38 +0300 Subject: [PATCH 203/310] feat: implement escaped sequences parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 19 ++++++++++++++++--- FSharpActivePatterns/lib/prettyPrinter.ml | 2 +- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index bbd4a439e..420cd3b3c 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -70,10 +70,23 @@ let p_bool = let p_bool_expr = expr_const_factory p_bool let p_bool_pat = pat_const_factory p_bool +let p_escaped_char = + char '\\' + *> (any_char + >>= function + | '"' -> return '"' + | '\\' -> return '\\' + | 'n' -> return '\n' + | 't' -> return '\t' + | 'r' -> return '\r' + | other -> fail (Printf.sprintf "Unknown escape sequence: \\%c" other)) +;; + +let p_regular_char = satisfy (fun c -> Char.(c <> '"' && c <> '\\')) + let p_string = - skip_ws *> char '"' *> take_while (fun c -> not (Char.equal c '"')) - <* char '"' - >>| fun x -> String_lt x + let+ s = skip_ws *> char '"' *> many (p_regular_char <|> p_escaped_char) <* char '"' in + String_lt (String.of_char_list s) ;; let p_string_expr = expr_const_factory p_string diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 866a8924e..c2b76c5c2 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -70,7 +70,7 @@ and pp_expr fmt expr = match expr with | Const (Int_lt i) -> fprintf fmt "%d " i | Const (Bool_lt b) -> fprintf fmt "%b " b - | Const (String_lt s) -> fprintf fmt "\"%s\"" s + | Const (String_lt s) -> fprintf fmt "%S" s | Const Unit_lt -> fprintf fmt "() " | List l -> fprintf fmt "%a " (pp_list pp_expr) l | Tuple (e1, e2, rest) -> From f179b011e3103c7bf76f0bfc0521929d33b3cfea Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 22 Nov 2024 11:50:27 +0300 Subject: [PATCH 204/310] tests: implement string generator with escape sequences Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 37 +++++++++++++++++++---------- FSharpActivePatterns/tests/qcheck.t | 2 +- 2 files changed, 26 insertions(+), 13 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 231ec0b6e..a8c3e07be 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -15,10 +15,11 @@ let gen_varname = frequency [ 26, gen_char_of_range 'a' 'z'; 26, gen_char_of_range 'A' 'Z'; 1, return '_' ] in - let gen_next_char = frequency [ 53, gen_first_char; 10, gen_char_of_range '0' '9' ] in + let gen_next_char = + frequency [ 26 + 26 + 1, gen_first_char; 10, gen_char_of_range '0' '9' ] + in map2 - (fun first rest -> - String.make 1 first ^ String.concat "" (List.map (String.make 1) rest)) + (fun first rest -> String.make 1 first ^ Base.String.of_char_list rest) gen_first_char (list_size (1 -- 3) gen_next_char) in @@ -28,22 +29,34 @@ let gen_varname = let gen_ident = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 3) gen_ident) -let gen_char = +let gen_escape_sequence = + let open QCheck.Gen in + oneofl [ "\\\""; "\\\\"; "\\n"; "\\t" ] +;; + +let gen_string_of_regular_char = let open QCheck.Gen in - let rec loop () = - let* char = char_range (Char.chr 32) (Char.chr 126) in - match char with - | '\\' | '"' -> loop () - | _ -> return char + let gen_int = + frequency + [ 33 - 32 + 1, int_range 32 33 + ; 91 - 35 + 1, int_range 35 91 + ; 126 - 93 + 1, int_range 93 126 + ] in - loop () + map (fun c -> String.make 1 c) (map Char.chr gen_int) +;; + +let gen_string = + let open QCheck.Gen in + let atom = frequency [ 1, gen_escape_sequence; 30, gen_string_of_regular_char ] in + let+ atoms = list_size (0 -- 20) atom in + String.concat "" atoms ;; type literal = | Int_lt of (int[@gen QCheck.Gen.pint]) (** [0], [1], [30] *) | Bool_lt of bool (** [false], [true] *) - | String_lt of (string[@gen QCheck.Gen.(string_size (0 -- 5) ~gen:gen_char)]) - (** ["Hello world"] *) + | String_lt of (string[@gen gen_string]) (** ["Hello world"] *) | Unit_lt (** [Unit] *) [@@deriving eq, show { with_path = false }, qcheck] diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 8a4587c1c..f83eceae7 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_qcheck.exe -seed 12 -gen 1 -stop + $ ../lib/tests/run_qcheck.exe -seed 13 -gen 15 -stop random seed: 12 ================================================================================ success (ran 1 tests) From 6dd79217684c491f4f14308ec12e37afcf773f66 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 22 Nov 2024 18:27:00 +0300 Subject: [PATCH 205/310] perf: reduce let size generation Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index a8c3e07be..47d0d7191 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -165,7 +165,7 @@ type statement = | Let of is_recursive * let_bind - * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 5) gen_let_bind)]) + * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 2) gen_let_bind)]) (** [let name = expr] *) (*| ActivePattern of (ident list[@gen gen_ident_small_list]) * expr (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *)*) From fa743216c4fce15277fca9bcc81c344c712a0fd3 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 23 Nov 2024 16:43:27 +0300 Subject: [PATCH 206/310] fix: n delimeter for qcheck Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/ast.ml | 14 +++++++------- FSharpActivePatterns/tests/qcheck.t | 4 ++-- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 47d0d7191..f905407b7 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -91,12 +91,12 @@ type 'a list_type = type pattern = | Wild (** [_] *) | PList of - (pattern list_type[@gen gen_list_type_sized (gen_pattern_sized (n / 8)) (n / 2)]) + (pattern list_type[@gen gen_list_type_sized (gen_pattern_sized (n / 20)) (n / 20)]) (**[ [], hd :: tl, [1;2;3] ]*) | PTuple of pattern * pattern - * (pattern list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_pattern_sized (n / 8)))]) + * (pattern list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_pattern_sized (n / 20)))]) (** | [(a, b)] -> *) | PConst of literal (** | [4] -> *) | PVar of ident (** pattern identifier *) @@ -114,9 +114,9 @@ type expr = | Tuple of expr * expr - * (expr list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_expr_sized (n / 8)))]) + * (expr list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_expr_sized (n / 20)))]) (** [(1, "Hello world", true)] *) - | List of (expr list_type[@gen gen_list_type_sized (gen_expr_sized (n / 8)) (n / 2)]) + | List of (expr list_type[@gen gen_list_type_sized (gen_expr_sized (n / 20)) (n / 20)]) (** [], hd :: tl, [1;2;3] *) | Variable of ident (** [x], [y] *) | Unary_expr of unary_operator * expr (** -x *) @@ -124,7 +124,7 @@ type expr = | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) | Lambda of (pattern[@gen gen_pattern_sized (n / 2)]) - * (pattern list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_pattern_sized (n / 8)))]) + * (pattern list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_pattern_sized (n / 20)))]) * expr (** fun x y -> x + y *) | Apply of expr * expr (** [sum 1 ] *) | Match of @@ -134,12 +134,12 @@ type expr = * ((pattern * expr) list [@gen QCheck.Gen.( - list_size (0 -- 2) (pair (gen_pattern_sized (n / 8)) (gen_expr_sized (n / 8))))]) + list_size (0 -- 2) (pair (gen_pattern_sized (n / 20)) (gen_expr_sized (n / 20))))]) (** [match x with | x -> ... | y -> ...] *) | LetIn of is_recursive * let_bind - * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_let_bind_sized (n / 8)))]) + * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_let_bind_sized (n / 20)))]) * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) [@@deriving eq, show { with_path = false }, qcheck] diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index f83eceae7..01d2bd88c 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_qcheck.exe -seed 13 -gen 15 -stop - random seed: 12 + $ ../lib/tests/run_qcheck.exe -seed 119 -gen 1 -stop + random seed: 119 ================================================================================ success (ran 1 tests) From 388d8436f5b0cb29c326a03527b27bc1803259f6 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 23 Nov 2024 20:31:02 +0300 Subject: [PATCH 207/310] fix: list and cons parsers Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 24 +++---- FSharpActivePatterns/lib/astPrinter.ml | 21 +++--- FSharpActivePatterns/lib/parser.ml | 69 ++++++++----------- FSharpActivePatterns/lib/prettyPrinter.ml | 32 ++++----- FSharpActivePatterns/lib/tests/ast_printer.ml | 2 +- .../lib/tests/qcheck_utils.ml | 30 ++------ 6 files changed, 72 insertions(+), 106 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index f905407b7..9672ff159 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -76,6 +76,7 @@ type binary_operator = | Binary_or_bitwise (** [|||] *) | Binary_xor_bitwise (** [^^^] *) | Binary_and_bitwise (** [&&&] *) + | Binary_cons (** [::] *) [@@deriving eq, show { with_path = false }, qcheck] type unary_operator = @@ -83,16 +84,12 @@ type unary_operator = | Unary_not (** unary [not] *) [@@deriving eq, show { with_path = false }, qcheck] -type 'a list_type = - | Cons_list of 'a * 'a list_type - | Empty_list -[@@deriving eq, show { with_path = false }, qcheck] - type pattern = | Wild (** [_] *) | PList of - (pattern list_type[@gen gen_list_type_sized (gen_pattern_sized (n / 20)) (n / 20)]) - (**[ [], hd :: tl, [1;2;3] ]*) + (pattern list[@gen QCheck.Gen.(list_size (0 -- 3) (gen_pattern_sized (n / 20)))]) + (**[ [], [1;2;3] ] *) + | PCons of pattern * pattern (**[ hd :: tl ] *) | PTuple of pattern * pattern @@ -116,11 +113,11 @@ type expr = * expr * (expr list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_expr_sized (n / 20)))]) (** [(1, "Hello world", true)] *) - | List of (expr list_type[@gen gen_list_type_sized (gen_expr_sized (n / 20)) (n / 20)]) - (** [], hd :: tl, [1;2;3] *) + | List of (expr list[@gen QCheck.Gen.(list_size (0 -- 3) (gen_expr_sized (n / 20)))]) + (** [], [1;2;3] *) | Variable of ident (** [x], [y] *) | Unary_expr of unary_operator * expr (** -x *) - | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12] *) + | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12], hd :: tl *) | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) | Lambda of (pattern[@gen gen_pattern_sized (n / 2)]) @@ -134,12 +131,15 @@ type expr = * ((pattern * expr) list [@gen QCheck.Gen.( - list_size (0 -- 2) (pair (gen_pattern_sized (n / 20)) (gen_expr_sized (n / 20))))]) + list_size + (0 -- 2) + (pair (gen_pattern_sized (n / 20)) (gen_expr_sized (n / 20))))]) (** [match x with | x -> ... | y -> ...] *) | LetIn of is_recursive * let_bind - * (let_bind list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_let_bind_sized (n / 20)))]) + * (let_bind list + [@gen QCheck.Gen.(list_size (0 -- 2) (gen_let_bind_sized (n / 20)))]) * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) [@@deriving eq, show { with_path = false }, qcheck] diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index bb945d42d..9d32c2b37 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -27,19 +27,14 @@ let print_bin_op indent fmt = function | Binary_or_bitwise -> fprintf fmt "%s| Binary Or Bitwise\n" (String.make indent '-') | Binary_xor_bitwise -> fprintf fmt "%s| Binary Xor Bitwise\n" (String.make indent '-') | Binary_and_bitwise -> fprintf fmt "%s| Binary And Bitwise\n" (String.make indent '-') -;; - -let rec print_list printer indent fmt = function - | Empty_list -> fprintf fmt "%s| Empty_list:\n" (String.make indent ' ') - | Cons_list (hd, tl) -> - fprintf fmt "%s| Cons_list:\n" (String.make indent ' '); - printer (indent + 2) fmt hd; - print_list printer (indent + 2) fmt tl + | Binary_cons -> fprintf fmt "%s| Binary Cons\n" (String.make indent '-') ;; let rec print_pattern indent fmt = function | Wild -> fprintf fmt "%s| Wild\n" (String.make indent '-') - | PList l -> print_list print_pattern indent fmt l + | PList l -> + fprintf fmt "%s| PList:\n" (String.make indent '-'); + List.iter (print_pattern (indent + 2) fmt) l | PTuple (p1, p2, rest) -> fprintf fmt "%s| PTuple:\n" (String.make indent '-'); List.iter (print_pattern (indent + 2) fmt) (p1 :: p2 :: rest) @@ -50,6 +45,10 @@ let rec print_pattern indent fmt = function | Bool_lt b -> fprintf fmt "%sBool: %b\n" (String.make (indent + 2) '-') b | String_lt s -> fprintf fmt "%sString: %S\n" (String.make (indent + 2) '-') s | Unit_lt -> fprintf fmt "%sUnit\n" (String.make (indent + 2) '-')) + | PCons (l, r) -> + fprintf fmt "%s| PCons:\n" (String.make indent '-'); + print_pattern (indent + 2) fmt l; + print_pattern (indent + 2) fmt r | PVar (Ident (name, _)) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name | POption p -> fprintf fmt "%s| POption: " (String.make indent '-'); @@ -88,7 +87,9 @@ and print_expr indent fmt expr = | Const (String_lt s) -> fprintf fmt "%s| Const(String: %S)\n" (String.make indent '-') s | Const Unit_lt -> fprintf fmt "%s| Const(Unit)\n" (String.make indent '-') - | List l -> print_list print_expr indent fmt l + | List l -> + fprintf fmt "%s| PList:\n" (String.make indent '-'); + List.iter (print_expr (indent + 2) fmt) l | Tuple (e1, e2, rest) -> fprintf fmt "%s| Tuple:\n" (String.make indent '-'); List.iter (print_expr (indent + 2) fmt) (e1 :: e2 :: rest) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 420cd3b3c..5503bc243 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -36,11 +36,12 @@ let chainl1 e op = e >>= go ;; -let rec chainr1_cons e op = +let rec chainr1 e op = let* left = e in (let* f = op in - chainr1_cons e op >>| f left) - <|> return (Cons_list (left, Empty_list)) + let* right = chainr1 e op in + return (f left right)) + <|> return left ;; let rec unary_chain op e = @@ -121,43 +122,27 @@ let p_ident = let p_var_expr = p_ident >>| fun ident -> Variable ident let p_var_pat = p_ident >>| fun ident -> PVar ident -let p_empty_list = skip_ws *> string "[" *> skip_ws *> string "]" *> return Empty_list -let make_list e1 e2 = Cons_list (e1, e2) - -let p_cons_list p_elem = - let p_cons = skip_ws *> (string "::" *> return (fun l r -> Cons_list (l, r))) in - let* first_elem = skip_ws *> p_elem <* skip_ws <* string "::" in - let* rest = chainr1_cons p_elem p_cons in - return (Cons_list (first_elem, rest)) -;; - -let p_cons_list_expr p_expr = p_cons_list p_expr >>= fun l -> return (List l) -let p_cons_list_pat p_pat = p_cons_list p_pat >>= fun l -> return (PList l) -let p_semicolon_list p_elem empty_list = +let p_semicolon_list p_elem = skip_ws *> string "[" *> skip_ws - *> fix (fun p_semi_list -> - choice - [ (p_elem - <* skip_ws - <* string ";" - <* skip_ws - >>= fun hd -> p_semi_list >>= fun tl -> return (make_list hd tl)) - ; (p_elem <* skip_ws <* string "]" >>| fun hd -> make_list hd empty_list) - ; string "]" *> return empty_list - ]) -;; - -let p_semicolon_list_expr p_expr = - p_semicolon_list p_expr Empty_list >>= fun l -> return (List l) -;; - -let p_semicolon_list_pat p_pat = - p_semicolon_list p_pat Empty_list >>= fun l -> return (PList l) + *> let+ list = + fix (fun p_semi_list -> + choice + [ (let* hd = p_elem <* skip_ws <* string ";" in + let* tl = p_semi_list in + return (hd :: tl)) + ; (let* hd = p_elem <* skip_ws <* string "]" in + return [ hd ]) + ; skip_ws *> string "]" *> return [] + ]) + in + list ;; +let p_semicolon_list_expr p_expr = p_semicolon_list p_expr >>| fun l -> List l +let p_semicolon_list_pat p_pat = p_semicolon_list p_pat >>| fun l -> PList l let p_unit = skip_ws *> string "(" *> skip_ws *> string ")" *> return Unit_lt let p_unit_expr = expr_const_factory p_unit let p_unit_pat = pat_const_factory p_unit @@ -187,6 +172,11 @@ let log_and = p_binexpr "&&" Logical_and let bitwise_or = p_binexpr "|||" Binary_or_bitwise let bitwise_and = p_binexpr "&&&" Binary_and_bitwise let bitwise_xor = p_binexpr "^^^" Binary_xor_bitwise +let cons = p_binexpr "::" Binary_cons + +let p_cons_list_pat p_pat = + chainr1 p_pat (skip_ws *> string "::" *> return (fun l r -> PCons (l, r))) +;; let p_tuple make p = skip_ws @@ -200,7 +190,6 @@ let p_tuple make p = <* string ")" ;; -(*let p_tuple_expr p_expr = p_tuple make_tuple_expr p_expr*) let p_tuple_pat p_pat = p_tuple make_tuple_pat p_pat let p_if p_expr = @@ -264,7 +253,6 @@ let p_option p make_option = let make_option_expr expr = Option expr let make_option_pat pat = POption pat let p_pat_const = choice [ p_int_pat; p_bool_pat; p_unit_pat; p_string_pat ] -let p_empty_list_pat = p_empty_list >>= fun _ -> return (PList Empty_list) let p_pat = fix (fun self -> @@ -272,9 +260,8 @@ let p_pat = *> choice [ p_parens self ; p_tuple_pat self - ; p_empty_list_pat ; p_semicolon_list_pat self - ; p_cons_list_pat p_var_pat + ; p_cons_list_pat self ; p_var_pat ; p_pat_const ; string "_" *> return Wild @@ -327,7 +314,8 @@ let p_expr = let unary = choice [ unary_chain p_not letin_expr; unary_chain unminus letin_expr ] in let factor = chainl1 unary (mul <|> div) in let term = chainl1 factor (add <|> sub) in - let comp_eq = chainl1 term (equal <|> unequal) in + let cons_op = chainr1 term cons in + let comp_eq = chainl1 cons_op (equal <|> unequal) in let comp_less = chainl1 comp_eq (less_or_equal <|> less) in let comp_gr = chainl1 comp_less (greater_or_equal <|> greater) in let bit_xor = chainl1 comp_gr bitwise_xor in @@ -336,8 +324,7 @@ let p_expr = let comp_and = chainl1 bit_or log_and in let comp_or = chainl1 comp_and log_or in let apply = p_apply comp_or <|> comp_or in - let cons_list = p_cons_list_expr apply <|> apply in - let ematch = p_match (p_expr <|> cons_list) <|> cons_list in + let ematch = p_match (p_expr <|> apply) <|> apply in let efun = p_lambda (p_expr <|> ematch) <|> ematch in let option = p_option efun make_option_expr <|> efun in option) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index c2b76c5c2..ef7d0b06a 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -21,6 +21,7 @@ let pp_bin_op fmt = function | Binary_or_bitwise -> fprintf fmt "||| " | Binary_xor_bitwise -> fprintf fmt "^^^ " | Binary_and_bitwise -> fprintf fmt "&&& " + | Binary_cons -> fprintf fmt "::" ;; let pp_unary_op fmt = function @@ -33,24 +34,16 @@ let pp_rec_flag fmt = function | Nonrec -> () ;; -let pp_list pp fmt = function - | Empty_list -> fprintf fmt "[]" - | Cons_list (hd, Empty_list) -> fprintf fmt "[%a]" pp hd - | Cons_list (hd, tl) -> - fprintf fmt "[%a" pp hd; - let rec pp_tail fmt = function - | Empty_list -> fprintf fmt "]" - | Cons_list (hd, Empty_list) -> fprintf fmt "; %a]" pp hd - | Cons_list (hd, tl) -> - fprintf fmt "; %a" pp hd; - pp_tail fmt tl - in - pp_tail fmt tl -;; - let rec pp_pattern fmt = function | Wild -> fprintf fmt "_ " - | PList l -> pp_list pp_pattern fmt l + | PList l -> + fprintf fmt "["; + pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "; ") pp_pattern fmt l; + fprintf fmt "]" + | PCons (l, r) -> + pp_pattern fmt l; + fprintf fmt ":: "; + pp_pattern fmt r | PTuple (p1, p2, rest) -> fprintf fmt "("; pp_print_list @@ -59,7 +52,7 @@ let rec pp_pattern fmt = function fmt (p1 :: p2 :: rest); fprintf fmt ")" - | PConst literal -> fprintf fmt "%a" pp_expr (Const literal) + | PConst literal -> fprintf fmt "%a " pp_expr (Const literal) | PVar (Ident (name, _)) -> fprintf fmt "%s " name | POption p -> (match p with @@ -72,7 +65,10 @@ and pp_expr fmt expr = | Const (Bool_lt b) -> fprintf fmt "%b " b | Const (String_lt s) -> fprintf fmt "%S" s | Const Unit_lt -> fprintf fmt "() " - | List l -> fprintf fmt "%a " (pp_list pp_expr) l + | List l -> + fprintf fmt "["; + pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "; ") pp_expr fmt l; + fprintf fmt "]" | Tuple (e1, e2, rest) -> fprintf fmt "("; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index 545b82f9e..fff43e0a9 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -221,7 +221,7 @@ let%expect_test "print Ast of match_expr" = let patterns = [ PConst (Int_lt 5) ; PConst (String_lt " bar foo") - ; PList (Cons_list (Wild, Cons_list (PVar (Ident ("xs", None)), Empty_list))) + ; PList [ Wild; PVar (Ident ("xs", None)) ] ] in let pattern_values = List.map (fun p -> p, Const (Int_lt 4)) patterns in diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index 0db35cd19..af4b2d3f4 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -39,17 +39,7 @@ and shrink_expr = <+> (shrink_expr e1 >|= fun a' -> Tuple (a', e2, rest)) <+> (shrink_expr e2 >|= fun a' -> Tuple (e1, a', rest)) <+> (QCheck.Shrink.list ~shrink:shrink_expr rest >|= fun a' -> Tuple (e1, e2, a')) - | List (Cons_list (hd, Cons_list (hd2, tl))) -> - of_list - [ List (Cons_list (hd, Empty_list)) - ; List (Cons_list (hd2, tl)) - ; List (Cons_list (hd, tl)) - ; List tl - ] - <+> (shrink_expr hd >|= fun hd' -> List (Cons_list (hd', Cons_list (hd2, tl)))) - <+> (shrink_expr hd2 >|= fun hd2' -> List (Cons_list (hd, Cons_list (hd2', tl)))) - | List (Cons_list (hd, Empty_list)) -> - shrink_expr hd >|= fun hd' -> List (Cons_list (hd', Empty_list)) + | List l -> QCheck.Shrink.list ~shrink:shrink_expr l >|= fun l' -> List l' | Bin_expr (op, e1, e2) -> of_list [ e1; e2 ] <+> (shrink_expr e1 >|= fun a' -> bin_e op a' e2) @@ -97,22 +87,15 @@ and shrink_expr = of_list [ e; Option None ] <+> (shrink_expr e >|= fun a' -> Option (Some a')) | Option None -> empty | Variable _ -> empty - | List Empty_list -> empty and shrink_pattern = let open QCheck.Iter in function - | PList (Cons_list (hd, Cons_list (hd2, tl))) -> - of_list - [ PList (Cons_list (hd, Empty_list)) - ; PList (Cons_list (hd2, tl)) - ; PList (Cons_list (hd, tl)) - ; PList tl - ] - <+> (shrink_pattern hd >|= fun hd' -> PList (Cons_list (hd', Cons_list (hd2, tl)))) - <+> (shrink_pattern hd2 >|= fun hd2' -> PList (Cons_list (hd, Cons_list (hd2', tl)))) - | PList (Cons_list (hd, Empty_list)) -> - shrink_pattern hd >|= fun hd' -> PList (Cons_list (hd', Empty_list)) + | PList l -> QCheck.Shrink.list ~shrink:shrink_pattern l >|= fun l' -> PList l' + | PCons (l, r) -> + shrink_pattern l + >|= (fun l' -> PCons (l', r)) + <+> (shrink_pattern r >|= fun r' -> PCons (l, r')) | PTuple (p1, p2, rest) -> of_list [ p1; p2 ] <+> (shrink_pattern p1 >|= fun p1' -> PTuple (p1', p2, rest)) @@ -122,7 +105,6 @@ and shrink_pattern = | PConst lt -> shrink_lt lt >|= fun lt' -> PConst lt' | POption (Some p) -> return p | POption None -> empty - | PList Empty_list -> empty | Wild -> empty | PVar _ -> empty ;; From 00644d5b9e37aa047ba3f9abe8fc4563fe65abbd Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 23 Nov 2024 22:21:58 +0300 Subject: [PATCH 208/310] fix: cons and list parser Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 46 ++++++++++++++++-------------- 1 file changed, 24 insertions(+), 22 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 5503bc243..293113693 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -252,21 +252,23 @@ let p_option p make_option = let make_option_expr expr = Option expr let make_option_pat pat = POption pat -let p_pat_const = choice [ p_int_pat; p_bool_pat; p_unit_pat; p_string_pat ] +let p_pat_const = choice [ p_int_pat; p_bool_pat; p_unit_pat; p_string_pat; p_var_pat ] let p_pat = - fix (fun self -> - skip_ws - *> choice - [ p_parens self - ; p_tuple_pat self - ; p_semicolon_list_pat self - ; p_cons_list_pat self - ; p_var_pat - ; p_pat_const - ; string "_" *> return Wild - ; p_option self make_option_pat - ]) + skip_ws + *> fix (fun self -> + let atom = + choice + [ p_pat_const + ; string "_" *> return Wild + ; p_tuple_pat self + ; p_semicolon_list_pat self + ; p_parens self + ] + in + let cons = skip_ws *> p_cons_list_pat atom <|> atom in + let opt = p_option cons make_option_pat <|> cons in + opt) ;; let p_lambda p_expr = @@ -274,23 +276,23 @@ let p_lambda p_expr = *> string "fun" *> peek_sep1 *> - let* pat = p_pat in - let* pat_list = many p_pat in - let* _ = skip_ws *> string "->" in - let* body = p_expr in + let* pat = skip_ws *> p_pat <* skip_ws in + let* pat_list = (many p_pat) <* skip_ws <* string "->" in + let* body = skip_ws *> p_expr <* skip_ws in return (Lambda (pat, pat_list, body)) ;; let p_match p_expr = lift4 - (fun value pat1 expr1 list -> Match (value, pat1, expr1, list)) - (skip_ws *> string "match" *> p_expr <* skip_ws <* string "with") - (skip_ws *> string "|" *> p_pat <* skip_ws <* string "->") - p_expr + (fun value first_pat first_expr cases -> Match (value, first_pat, first_expr, cases)) + (skip_ws *> string "match" *> skip_ws *> p_expr <* skip_ws <* string "with") + (skip_ws *> string "|" *> skip_ws *> p_pat <* skip_ws <* string "->" <* skip_ws) + (p_expr <* skip_ws) (many - (skip_ws *> string "|" *> p_pat + (skip_ws *> string "|" *> skip_ws *> p_pat <* skip_ws <* string "->" + <* skip_ws >>= fun pat -> p_expr >>= fun expr -> return (pat, expr))) ;; From 5174a1613a54e8f711d8e44888f1130dde6b1130 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 24 Nov 2024 09:17:16 +0300 Subject: [PATCH 209/310] feat: improve Let shrinker Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/qcheck_utils.ml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index af4b2d3f4..b813e5077 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -113,10 +113,16 @@ let shrink_statement = let open QCheck.Iter in function | Let (rec_flag, let_bind, let_bind_list) -> - shrink_let_bind let_bind - >|= (fun a' -> Let (rec_flag, a', let_bind_list)) - <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list - >|= fun a' -> Let (rec_flag, let_bind, a')) + (let+ let_bind_shr = shrink_let_bind let_bind in + Let (rec_flag, let_bind_shr, let_bind_list)) + <+> (let+ let_bind_list_shr = + QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list + in + Let (rec_flag, let_bind, let_bind_list_shr)) + <+> + (match let_bind_list with + | [] -> empty + | hd :: _ -> return (Let (rec_flag, hd, []))) ;; let shrink_construction = From 0c0a41d957bcfde2483d441b1cf42df62278169b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 24 Nov 2024 10:21:08 +0300 Subject: [PATCH 210/310] fix: order of Application and Option Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 36 ++++++++++++++---------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 293113693..e80c11407 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -252,23 +252,21 @@ let p_option p make_option = let make_option_expr expr = Option expr let make_option_pat pat = POption pat -let p_pat_const = choice [ p_int_pat; p_bool_pat; p_unit_pat; p_string_pat; p_var_pat ] +let p_wild_pat = skip_ws *> string "_" *> return Wild + +let p_pat_const = + choice [ p_int_pat; p_bool_pat; p_unit_pat; p_string_pat; p_var_pat; p_wild_pat ] +;; let p_pat = skip_ws *> fix (fun self -> - let atom = - choice - [ p_pat_const - ; string "_" *> return Wild - ; p_tuple_pat self - ; p_semicolon_list_pat self - ; p_parens self - ] - in - let cons = skip_ws *> p_cons_list_pat atom <|> atom in - let opt = p_option cons make_option_pat <|> cons in - opt) + let atom = choice [ p_pat_const; p_parens self ] in + let tuple = p_tuple_pat (self <|> atom) <|> atom in + let semicolon_list = p_semicolon_list_pat (self <|> tuple) <|> tuple in + let opt = p_option semicolon_list make_option_pat <|> semicolon_list in + let cons = p_cons_list_pat opt in + cons) ;; let p_lambda p_expr = @@ -277,7 +275,7 @@ let p_lambda p_expr = *> peek_sep1 *> let* pat = skip_ws *> p_pat <* skip_ws in - let* pat_list = (many p_pat) <* skip_ws <* string "->" in + let* pat_list = many p_pat <* skip_ws <* string "->" in let* body = skip_ws *> p_expr <* skip_ws in return (Lambda (pat, pat_list, body)) ;; @@ -313,7 +311,9 @@ let p_expr = let tuple = p_tuple make_tuple_expr (p_expr <|> atom) <|> atom in let if_expr = p_if (p_expr <|> tuple) <|> tuple in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in - let unary = choice [ unary_chain p_not letin_expr; unary_chain unminus letin_expr ] in + let option = p_option letin_expr make_option_expr <|> letin_expr in + let apply = p_apply option <|> option in + let unary = choice [ unary_chain p_not apply; unary_chain unminus apply ] in let factor = chainl1 unary (mul <|> div) in let term = chainl1 factor (add <|> sub) in let cons_op = chainr1 term cons in @@ -325,11 +325,9 @@ let p_expr = let bit_or = chainl1 bit_and bitwise_or in let comp_and = chainl1 bit_or log_and in let comp_or = chainl1 comp_and log_or in - let apply = p_apply comp_or <|> comp_or in - let ematch = p_match (p_expr <|> apply) <|> apply in + let ematch = p_match (p_expr <|> comp_or) <|> comp_or in let efun = p_lambda (p_expr <|> ematch) <|> ematch in - let option = p_option efun make_option_expr <|> efun in - option) + efun) ;; let p_statement = p_let p_expr From 167d86b8d060e0ba87c9c374f461a8b0cbd6e552 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 24 Nov 2024 10:37:50 +0300 Subject: [PATCH 211/310] fix: Cons pattern pretty printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/prettyPrinter.ml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index ef7d0b06a..515606542 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -40,10 +40,7 @@ let rec pp_pattern fmt = function fprintf fmt "["; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "; ") pp_pattern fmt l; fprintf fmt "]" - | PCons (l, r) -> - pp_pattern fmt l; - fprintf fmt ":: "; - pp_pattern fmt r + | PCons (l, r) -> fprintf fmt "(%a) :: (%a) " pp_pattern l pp_pattern r | PTuple (p1, p2, rest) -> fprintf fmt "("; pp_print_list From 9e566151a29a9386dd061947d2e380e0d558fea9 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 24 Nov 2024 10:51:39 +0300 Subject: [PATCH 212/310] ref: remove extra skip_ws Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index e80c11407..a85b8706a 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -274,9 +274,9 @@ let p_lambda p_expr = *> string "fun" *> peek_sep1 *> - let* pat = skip_ws *> p_pat <* skip_ws in + let* pat = p_pat in let* pat_list = many p_pat <* skip_ws <* string "->" in - let* body = skip_ws *> p_expr <* skip_ws in + let* body = p_expr in return (Lambda (pat, pat_list, body)) ;; @@ -287,11 +287,9 @@ let p_match p_expr = (skip_ws *> string "|" *> skip_ws *> p_pat <* skip_ws <* string "->" <* skip_ws) (p_expr <* skip_ws) (many - (skip_ws *> string "|" *> skip_ws *> p_pat - <* skip_ws - <* string "->" - <* skip_ws - >>= fun pat -> p_expr >>= fun expr -> return (pat, expr))) + (let* pat = skip_ws *> string "|" *> p_pat <* skip_ws <* string "->" in + let* expr = p_expr in + return (pat, expr))) ;; let p_expr = From 636735f4ccb82fdb078593f906b65f7c3cfc2c17 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 24 Nov 2024 11:06:05 +0300 Subject: [PATCH 213/310] ref: unified shrinkers style Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/qcheck_utils.ml | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index b813e5077..10146c212 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -113,12 +113,10 @@ let shrink_statement = let open QCheck.Iter in function | Let (rec_flag, let_bind, let_bind_list) -> - (let+ let_bind_shr = shrink_let_bind let_bind in - Let (rec_flag, let_bind_shr, let_bind_list)) - <+> (let+ let_bind_list_shr = - QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list - in - Let (rec_flag, let_bind, let_bind_list_shr)) + shrink_let_bind let_bind + >|= (fun a' -> Let (rec_flag, a', let_bind_list)) + <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list + >|= fun a' -> Let (rec_flag, let_bind, a')) <+> (match let_bind_list with | [] -> empty From 5cedc6353f58693a99a867e6a0aa30d5b06e1be8 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 24 Nov 2024 11:12:25 +0300 Subject: [PATCH 214/310] tests: change seed in qcheck.t Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/tests/qcheck.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 01d2bd88c..6c9956dc4 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ - $ ../lib/tests/run_qcheck.exe -seed 119 -gen 1 -stop + $ ../lib/tests/run_qcheck.exe -seed 461 -gen 1 -stop random seed: 119 ================================================================================ success (ran 1 tests) From 8bc776d5174d1bc693659d33b0a835a1de19609e Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 24 Nov 2024 11:22:11 +0300 Subject: [PATCH 215/310] tests: promote Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/tests/qcheck.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/tests/qcheck.t b/FSharpActivePatterns/tests/qcheck.t index 6c9956dc4..f49c8de5f 100644 --- a/FSharpActivePatterns/tests/qcheck.t +++ b/FSharpActivePatterns/tests/qcheck.t @@ -1,4 +1,4 @@ $ ../lib/tests/run_qcheck.exe -seed 461 -gen 1 -stop - random seed: 119 + random seed: 461 ================================================================================ success (ran 1 tests) From 2f7807d321b69434bb3c31c7764f18cc614d45c7 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 24 Nov 2024 15:16:09 +0300 Subject: [PATCH 216/310] ref: remove deriving eq Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 20 ++++++++++---------- FSharpActivePatterns/lib/dune | 2 +- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 9672ff159..72b51ca2d 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -5,7 +5,7 @@ open KeywordChecker type ident = Ident of string * string option (** identifier *) -[@@deriving eq, show { with_path = false }] +[@@deriving show { with_path = false }] let gen_varname = let open QCheck.Gen in @@ -58,7 +58,7 @@ type literal = | Bool_lt of bool (** [false], [true] *) | String_lt of (string[@gen gen_string]) (** ["Hello world"] *) | Unit_lt (** [Unit] *) -[@@deriving eq, show { with_path = false }, qcheck] +[@@deriving show { with_path = false }, qcheck] type binary_operator = | Binary_equal (** [=] *) @@ -77,12 +77,12 @@ type binary_operator = | Binary_xor_bitwise (** [^^^] *) | Binary_and_bitwise (** [&&&] *) | Binary_cons (** [::] *) -[@@deriving eq, show { with_path = false }, qcheck] +[@@deriving show { with_path = false }, qcheck] type unary_operator = | Unary_minus (** unary [-] *) | Unary_not (** unary [not] *) -[@@deriving eq, show { with_path = false }, qcheck] +[@@deriving show { with_path = false }, qcheck] type pattern = | Wild (** [_] *) @@ -99,12 +99,12 @@ type pattern = | PVar of ident (** pattern identifier *) | POption of pattern option (*| Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) *) -[@@deriving eq, show { with_path = false }, qcheck] +[@@deriving show { with_path = false }, qcheck] type is_recursive = | Nonrec (** let factorial n = ... *) | Rec (** let rec factorial n = ... *) -[@@deriving eq, show { with_path = false }, qcheck] +[@@deriving show { with_path = false }, qcheck] type expr = | Const of literal (** [Int], [Bool], [String], [Unit], [Null] *) @@ -142,12 +142,12 @@ type expr = [@gen QCheck.Gen.(list_size (0 -- 2) (gen_let_bind_sized (n / 20)))]) * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) -[@@deriving eq, show { with_path = false }, qcheck] +[@@deriving show { with_path = false }, qcheck] and let_bind = | Let_bind of ident * (ident list[@gen gen_ident_small_list]) * expr (** [and sum n m = n+m] *) -[@@deriving eq, show { with_path = false }, qcheck] +[@@deriving show { with_path = false }, qcheck] let gen_expr = QCheck.Gen.( @@ -169,9 +169,9 @@ type statement = (** [let name = expr] *) (*| ActivePattern of (ident list[@gen gen_ident_small_list]) * expr (** [let (|Even|Odd|) input = if input % 2 = 0 then Even else Odd] *)*) -[@@deriving eq, show { with_path = false }, qcheck] +[@@deriving show { with_path = false }, qcheck] type construction = | Expr of expr (** expression *) | Statement of statement (** statement *) -[@@deriving eq, show { with_path = false }, qcheck] +[@@deriving show { with_path = false }, qcheck] diff --git a/FSharpActivePatterns/lib/dune b/FSharpActivePatterns/lib/dune index 463c93066..4977e20e4 100644 --- a/FSharpActivePatterns/lib/dune +++ b/FSharpActivePatterns/lib/dune @@ -4,6 +4,6 @@ (modules Ast Parser AstPrinter PrettyPrinter KeywordChecker) (libraries angstrom base) (preprocess - (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) + (pps ppx_deriving_qcheck ppx_deriving.show)) (instrumentation (backend bisect_ppx))) From 1317a261bc728fa2dedaa7e697c22fa3e01005fb Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 24 Nov 2024 15:48:18 +0300 Subject: [PATCH 217/310] tests: reduces size of expr generator Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 72b51ca2d..4ecb60612 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -109,8 +109,8 @@ type is_recursive = type expr = | Const of literal (** [Int], [Bool], [String], [Unit], [Null] *) | Tuple of - expr - * expr + (expr[@gen gen_expr_sized (n / 4)]) + * (expr[@gen gen_expr_sized (n / 4)]) * (expr list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_expr_sized (n / 20)))]) (** [(1, "Hello world", true)] *) | List of (expr list[@gen QCheck.Gen.(list_size (0 -- 3) (gen_expr_sized (n / 20)))]) @@ -118,16 +118,21 @@ type expr = | Variable of ident (** [x], [y] *) | Unary_expr of unary_operator * expr (** -x *) | Bin_expr of binary_operator * expr * expr (** [1 + 2], [3 ||| 12], hd :: tl *) - | If_then_else of expr * expr * expr option (** [if n % 2 = 0 then "Even" else "Odd"] *) + | If_then_else of + (expr[@gen gen_expr_sized (n / 4)]) + * (expr[@gen gen_expr_sized (n / 4)]) + * (expr option[@gen QCheck.Gen.option (gen_expr_sized (n / 4))]) + (** [if n % 2 = 0 then "Even" else "Odd"] *) | Lambda of (pattern[@gen gen_pattern_sized (n / 2)]) * (pattern list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_pattern_sized (n / 20)))]) * expr (** fun x y -> x + y *) - | Apply of expr * expr (** [sum 1 ] *) + | Apply of (expr[@gen gen_expr_sized (n / 4)]) * (expr[@gen gen_expr_sized (n / 4)]) + (** [sum 1 ] *) | Match of - expr - * (pattern[@gen gen_pattern_sized (n / 2)]) - * expr + (expr[@gen gen_expr_sized (n / 4)]) + * (pattern[@gen gen_pattern_sized (n / 4)]) + * (expr[@gen gen_expr_sized (n / 4)]) * ((pattern * expr) list [@gen QCheck.Gen.( From 39949915cbc64d669582383ca34534d19dfd248c Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Tue, 26 Nov 2024 02:09:51 +0300 Subject: [PATCH 218/310] ref: add empty mli for tests to show that nothing is public Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/tests/ast_printer.mli | 3 +++ FSharpActivePatterns/lib/tests/parser.mli | 3 +++ 2 files changed, 6 insertions(+) create mode 100644 FSharpActivePatterns/lib/tests/ast_printer.mli create mode 100644 FSharpActivePatterns/lib/tests/parser.mli diff --git a/FSharpActivePatterns/lib/tests/ast_printer.mli b/FSharpActivePatterns/lib/tests/ast_printer.mli new file mode 100644 index 000000000..98fe2e874 --- /dev/null +++ b/FSharpActivePatterns/lib/tests/ast_printer.mli @@ -0,0 +1,3 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) diff --git a/FSharpActivePatterns/lib/tests/parser.mli b/FSharpActivePatterns/lib/tests/parser.mli new file mode 100644 index 000000000..98fe2e874 --- /dev/null +++ b/FSharpActivePatterns/lib/tests/parser.mli @@ -0,0 +1,3 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) From b3fbbb10d8c864c8875dfae6007a0f82df67059f Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 30 Nov 2024 13:33:00 +0300 Subject: [PATCH 219/310] feat: add infer types, their prettyr printer and module R w comments (to delete later) Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/dune | 10 +- FSharpActivePatterns/lib/inferencer.ml | 139 +++++++++++++++++++++++++ FSharpActivePatterns/lib/typedTree.ml | 21 ++++ FSharpActivePatterns/lib/typesPp.ml | 13 +++ 4 files changed, 182 insertions(+), 1 deletion(-) create mode 100644 FSharpActivePatterns/lib/inferencer.ml create mode 100644 FSharpActivePatterns/lib/typedTree.ml create mode 100644 FSharpActivePatterns/lib/typesPp.ml diff --git a/FSharpActivePatterns/lib/dune b/FSharpActivePatterns/lib/dune index 4977e20e4..9801e5d06 100644 --- a/FSharpActivePatterns/lib/dune +++ b/FSharpActivePatterns/lib/dune @@ -1,7 +1,15 @@ (library (name FSharpActivePatterns) (public_name FSharpActivePatterns) - (modules Ast Parser AstPrinter PrettyPrinter KeywordChecker) + (modules + Ast + Parser + AstPrinter + PrettyPrinter + KeywordChecker + Inferencer + TypedTree + TypesPp) (libraries angstrom base) (preprocess (pps ppx_deriving_qcheck ppx_deriving.show)) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml new file mode 100644 index 000000000..d30e4cbcb --- /dev/null +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -0,0 +1,139 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast +open TypedTree +open TypesPp +open Format + +type error = + [ `Occurs_check + | `Undef_var of string + | `Unification_failed of typ * typ + ] + +let pp_error fmt : error -> _ = function + | `Occurs_check -> fprintf fmt "Occurs check failed" + | `Undef_var s -> fprintf fmt "Undefined variable '%s'" s + | `Unification_failed (fst, snd) -> + fprintf fmt "unification failed on %a and %a" pp_typ fst pp_typ snd +;; + +(* for treating result of type inference *) +module R : sig + (* signature, smth like interface before realization *) + type 'a t + + val bind : 'a t -> f:('a -> 'b t) -> 'b t + val return : 'a -> 'a t + val fail : error -> 'a t + + include Base.Monad.Infix with type 'a t := 'a t + + module Syntax : sig + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + end + + module RList : sig + val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t + end + + val fresh : int t + val run : 'a t -> ('a, error) Result.t +end = struct + (* takes current state, runs smth, outputs new state and success / error *) + type 'a t = int -> int * ('a, error) Result.t + + (* bind -- if applying new state to first arg is correct, then apply f to + new argument and new state, else output error and state that caused it *) + let ( >>= ) : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t = + fun m f st -> + let last, r = m st in + match r with + | Result.Error x -> last, Error x + | Ok a -> f a last + ;; + + (* is called to cover result in fail or ok constructions *) + let fail e st = st, Base.Result.fail e + let return x last = last, Base.Result.return x + let bind x ~f = x >>= f + + (* is called from x, function and state. if applying state to x is correct, + then output applying f to x in constructor Ok, otherwise output error and + state that caused it *) + let ( >>| ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t = + fun x f st -> + match x st with + | st, Ok x -> st, Ok (f x) + | st, Result.Error e -> st, Result.Error e + ;; + + module Syntax = struct + let ( let* ) x f = bind x ~f + end + + (* for applying f to all elements x of list xs with check that everything is + correct. If it is, outputs accumulator of all applyings *) + module RList = struct + let fold_left xs ~init ~f = + Base.List.fold_left xs ~init ~f:(fun acc x -> + let open Syntax in + let* acc = acc in + f acc x) + ;; + end + + (* takes current state, returns state + 1 *) + let fresh : int t = fun last -> last + 1, Result.Ok last + let run m = snd (m 0) +end + +type fresh = int + +(* module with all type methods *) +module Type = struct + type t = typ + + (* check that type of the arg is not inside of type v. + Runs during substitution to ensure that there are no cycles*) + let rec occurs_in v = function + | Primary _ -> false + | Type_var b -> b = v + | Arrow (fst, snd) -> occurs_in v fst || occurs_in v snd + ;; + + (* collects all type variables *) + let free_vars = + let rec helper acc = function + | Primary _ -> acc + | Type_var b -> VarSet.add b acc + | Arrow (fst, snd) -> helper (helper acc fst) snd + in + helper VarSet.empty + ;; +end + +(* module of substitution *) +(* + module Substitution : sig + type t + + val empty : t + val singleton : fresh -> typ -> t R.t + val find : t -> fresh -> typ option + val remove : t -> fresh -> t + val apply : t -> typ -> typ + val unify : typ -> typ -> t R.t + val compose : t -> t -> t R.t + val compose_all : t list -> t R.t + end = struct + open R + open R.Syntax + + type t = (fresh, typ, Int.comparator_witness) Map.OrderedType + + let empty = Map.empty (module Int) + + end*) diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml new file mode 100644 index 000000000..ba6edea72 --- /dev/null +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -0,0 +1,21 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +type binder = int [@@deriving show { with_path = false }] + +type typ = + | Primary of string + | Type_var of binder + | Arrow of typ * typ +[@@deriving show { with_path = false }] + +module VarSet = struct + include Stdlib.Set.Make (Int) + + let pp fmt s = + Format.fprintf fmt "[ "; + iter (Format.fprintf fmt "%d; ") s; + Format.fprintf fmt "]" + ;; +end diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml new file mode 100644 index 000000000..7fb949892 --- /dev/null +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -0,0 +1,13 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open TypedTree +open PrettyPrinter +open Format + +let rec pp_typ fmt = function + | Primary s -> fprintf fmt "%S" s + | Type_var var -> fprintf fmt "'_%d" var + | Arrow (fst, snd) -> fprintf fmt "(%a -> %a)" pp_typ fst pp_typ snd +;; From 4323761dbc2005e4738f0763f4b22bed3c23c79a Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 30 Nov 2024 17:52:49 +0300 Subject: [PATCH 220/310] feat: substitution module with comments (to delete later) Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/inferencer.ml | 123 ++++++++++++++++++++----- 1 file changed, 101 insertions(+), 22 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index d30e4cbcb..47dd339b6 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -2,10 +2,10 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open Ast open TypedTree open TypesPp open Format +open Base type error = [ `Occurs_check @@ -41,6 +41,10 @@ module R : sig val fresh : int t val run : 'a t -> ('a, error) Result.t + + module RMap : sig + val fold : ('a, 'b, 'c) Map.t -> init:'d t -> f:('a -> 'b -> 'd -> 'd t) -> 'd t + end end = struct (* takes current state, runs smth, outputs new state and success / error *) type 'a t = int -> int * ('a, error) Result.t @@ -85,6 +89,16 @@ end = struct ;; end + (* analogically to list. let* acc = acc is to extract value from type t *) + module RMap = struct + let fold map ~init ~f = + Map.fold map ~init ~f:(fun ~key ~data acc -> + let open Syntax in + let* acc = acc in + f key data acc) + ;; + end + (* takes current state, returns state + 1 *) let fresh : int t = fun last -> last + 1, Result.Ok last let run m = snd (m 0) @@ -116,24 +130,89 @@ module Type = struct end (* module of substitution *) -(* - module Substitution : sig - type t - - val empty : t - val singleton : fresh -> typ -> t R.t - val find : t -> fresh -> typ option - val remove : t -> fresh -> t - val apply : t -> typ -> typ - val unify : typ -> typ -> t R.t - val compose : t -> t -> t R.t - val compose_all : t list -> t R.t - end = struct - open R - open R.Syntax - - type t = (fresh, typ, Int.comparator_witness) Map.OrderedType - - let empty = Map.empty (module Int) - - end*) + +module Substitution : sig + type t + + val empty : t + val mapping : fresh -> typ -> (fresh * typ) R.t + val singleton : fresh -> typ -> t R.t + val find : t -> fresh -> typ option + val remove : t -> fresh -> t + val apply : t -> typ -> typ + val unify : typ -> typ -> t R.t + val compose : t -> t -> t R.t + val compose_all : t list -> t R.t +end = struct + open R + open R.Syntax + + (* t in this module is map of key fresh to value typ. last arg specifies + keys as int values (see fresh def) *) + type t = (fresh, typ, Int.comparator_witness) Map.t + + (* empty map *) + let empty = Map.empty (module Int) + + (* perform mapping of fresh var to typ with occurs check, if correct, + output new pair *) + let mapping k v = if Type.occurs_in k v then fail `Occurs_check else return (k, v) + + (* perform mapping, if correct, create map w 1 element as described in type t *) + let singleton k v = + let* k, v = mapping k v in + return (Map.singleton (module Int) k v) + ;; + + (* aliases for Map actions *) + let find map key = Map.find map key + let remove map key = Map.remove map key + + (* search for input in given map, if there is no match, output + input type, else output found typ value associated w this key *) + let apply map = + let rec helper = function + | Type_var b as typ -> + (match find map b with + | None -> typ + | Some x -> x) + | Arrow (fst, snd) -> Arrow (helper fst, helper snd) + | other -> other + in + helper + ;; + + (* check that two types are compatible. in third case put new pair of type_var + and type into context (map) *) + let rec unify fst snd = + match fst, snd with + | Primary fst, Primary snd when String.equal fst snd -> return empty + | Type_var f, Type_var s when Int.equal f s -> return empty + | Type_var b, t | t, Type_var b -> singleton b t + | Arrow (f1, s1), Arrow (f2, s2) -> + let* subst1 = unify f1 f2 in + let* subst2 = unify s1 s2 in + compose subst1 subst2 + | _ -> fail (`Unification_failed (fst, snd)) + + (* if value associated w this key exists in map, try to unify them, otherwise + get old substitution, form new singleton, update map so in contains new info *) + and extend key value map = + match find map key with + | Some value2 -> + let* map2 = unify value value2 in + compose map map2 + | None -> + let value = apply map value in + let* map2 = singleton key value in + RMap.fold map ~init:(return map2) ~f:(fun key value acc -> + let value = apply map2 value in + let* key, value = mapping key value in + return (Map.update acc key ~f:(fun _ -> value))) + + (* compose two maps together *) + and compose map1 map2 = RMap.fold map2 ~init:(return map1) ~f:extend + + (* compose list of maps together *) + let compose_all maps = RList.fold_left maps ~init:(return empty) ~f:compose +end From 2d5b163e05ee376f67c19cf28fca31eba3acb9a8 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 30 Nov 2024 19:57:58 +0300 Subject: [PATCH 221/310] feat: add scheme and environment modules Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/inferencer.ml | 62 +++++++++++++++++++++++++- FSharpActivePatterns/lib/typedTree.ml | 5 +++ 2 files changed, 66 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 47dd339b6..7a0720a9e 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -2,6 +2,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) +open Ast open TypedTree open TypesPp open Format @@ -169,7 +170,8 @@ end = struct let remove map key = Map.remove map key (* search for input in given map, if there is no match, output - input type, else output found typ value associated w this key *) + input type, else output found typ value associated w this key. + Basically narrow given type to conditions given in substitution *) let apply map = let rec helper = function | Type_var b as typ -> @@ -216,3 +218,61 @@ end = struct (* compose list of maps together *) let compose_all maps = RList.fold_left maps ~init:(return empty) ~f:compose end + +(* module for scheme treatment *) +module Scheme = struct + type t = scheme + + (* occurs check for both type vars set and typ in sheme *) + let occurs_in value = function + | S (vars, t) -> (not (VarSet.mem value vars)) && Type.occurs_in value t + ;; + + (* take all vars that are not bound in typ *) + let free_vars = function + | S (vars, t) -> VarSet.diff (Type.free_vars t) vars + ;; + + (* take substitution and scheme, remove its free vars from substitution, + form new scheme according to substitution (apply it to typ) *) + let apply subst (S (vars, t)) = + let subst2 = VarSet.fold (fun key s -> Substitution.remove s key) vars subst in + S (vars, Substitution.apply subst2 t) + ;; + + let pp = pp_scheme +end + +module TypeEnvironment = struct + open Base + + (* environment (context?) -- pairs of names and their types list *) + type t = (ident, scheme, String.comparator_witness) Map.t + + (* if pair (key, some old value) exists in map env, then replace old value + with new, else add pair (key, value) into map *) + let extend env key value = Map.update env key ~f:(fun _ -> value) + + let remove env key = Map.remove env key + + let empty = Map.empty (module String) + + (* apply given substitution to all elements of environment *) + let apply subst env = Map.map env ~f:(Scheme.apply subst) + + let find key env = Map.find env key + + (* collect all free vars from environment *) + let free_vars : t -> VarSet.t = + Map.fold ~init:VarSet.empty ~f:(fun ~key:_ ~data:s acc -> + VarSet.union acc (Scheme.free_vars s)) + ;; + + (* TODO: custom pp_scheme? not from deriving *) + let pp fmt map = + Stdlib.Format.fprintf fmt "{| "; + Map.iteri map ~f:(fun ~key:n ~data:s -> + Stdlib.Format.fprintf fmt "%s -> %a; " n pp_scheme s); + Stdlib.Format.fprintf fmt "|}%!" + ;; +end \ No newline at end of file diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index ba6edea72..627e5a6ea 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -19,3 +19,8 @@ module VarSet = struct Format.fprintf fmt "]" ;; end + +type binder_set = VarSet.t [@@deriving show { with_path = false }] + +(* binder_set here -- list of all type vars in context (?) *) +type scheme = S of binder_set * typ [@@deriving show { with_path = false }] From c5e49ec6c45718a044cd2cbc35037bbbac7cd4e7 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 30 Nov 2024 22:34:28 +0300 Subject: [PATCH 222/310] feat: inferencer for constants and bin expr Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/inferencer.ml | 79 +++++++++++++++++++++++--- FSharpActivePatterns/lib/typedTree.ml | 5 ++ 2 files changed, 75 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 7a0720a9e..a3599031d 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -189,6 +189,7 @@ end = struct let rec unify fst snd = match fst, snd with | Primary fst, Primary snd when String.equal fst snd -> return empty + | Primary _, Primary _ -> fail (`Unification_failed (fst, snd)) | Type_var f, Type_var s when Int.equal f s -> return empty | Type_var b, t | t, Type_var b -> singleton b t | Arrow (f1, s1), Arrow (f2, s2) -> @@ -222,9 +223,9 @@ end (* module for scheme treatment *) module Scheme = struct type t = scheme - + (* occurs check for both type vars set and typ in sheme *) - let occurs_in value = function + let occurs_in value = function | S (vars, t) -> (not (VarSet.mem value vars)) && Type.occurs_in value t ;; @@ -233,7 +234,7 @@ module Scheme = struct | S (vars, t) -> VarSet.diff (Type.free_vars t) vars ;; - (* take substitution and scheme, remove its free vars from substitution, + (* take substitution and scheme, remove its free vars from substitution, form new scheme according to substitution (apply it to typ) *) let apply subst (S (vars, t)) = let subst2 = VarSet.fold (fun key s -> Substitution.remove s key) vars subst in @@ -250,16 +251,13 @@ module TypeEnvironment = struct type t = (ident, scheme, String.comparator_witness) Map.t (* if pair (key, some old value) exists in map env, then replace old value - with new, else add pair (key, value) into map *) + with new, else add pair (key, value) into map *) let extend env key value = Map.update env key ~f:(fun _ -> value) - let remove env key = Map.remove env key - let empty = Map.empty (module String) (* apply given substitution to all elements of environment *) let apply subst env = Map.map env ~f:(Scheme.apply subst) - let find key env = Map.find env key (* collect all free vars from environment *) @@ -274,5 +272,68 @@ module TypeEnvironment = struct Map.iteri map ~f:(fun ~key:n ~data:s -> Stdlib.Format.fprintf fmt "%s -> %a; " n pp_scheme s); Stdlib.Format.fprintf fmt "|}%!" - ;; -end \ No newline at end of file + ;; +end + +open R +open R.Syntax + +let unify = Substitution.unify +let make_fresh_var = fresh >>| fun n -> Type_var n + +(* replace all type vars with fresh ones *) +let instantiate : scheme -> typ R.t = + fun (S (vars, t)) -> + VarSet.fold + (fun name ty -> + let* ty = ty in + let* fr_var = make_fresh_var in + let* subst = Substitution.singleton name fr_var in + return (Substitution.apply subst ty)) + vars + (return t) +;; + +(* take free vars of type t and environment, put difference between them + in S constructor so all vars are context independent *) +let generalize : TypeEnvironment.t -> Type.t -> Scheme.t = + fun env t -> + let free = VarSet.diff (Type.free_vars t) (TypeEnvironment.free_vars env) in + S (free, t) +;; + +let infer_expr = + let rec helper env = function + | Const const -> + (match const with + | Int_lt _ -> return (Substitution.empty, int_typ) + | Bool_lt _ -> return (Substitution.empty, bool_typ) + | String_lt _ -> return (Substitution.empty, string_typ) + | Unit_lt -> return (Substitution.empty, unit_typ)) + | Bin_expr (op, e1, e2) -> + let* subst1, typ1 = helper env e1 in + let* subst2, typ2 = helper (TypeEnvironment.apply subst1 env) e2 in + let* e1typ, e2typ, etyp = + match op with + | Logical_and | Logical_or -> return (bool_typ, bool_typ, bool_typ) + | Binary_add | Binary_subtract | Binary_multiply | Binary_divide -> + return (int_typ, int_typ, int_typ) + | _ -> failwith "WIP" + in + let* subst3 = Substitution.unify (Substitution.apply subst2 typ1) e1typ in + (*Format.printf "Checking types: res_typ1 = %a\n" pp_typ (Substitution.apply subst2 typ1); + Format.printf "Checking types: res_typ2 = %a\n" pp_typ (Substitution.apply subst3 typ2);*) + let* subst4 = Substitution.unify (Substitution.apply subst3 typ2) e2typ in + let* subst_res = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in + return (subst_res, Substitution.apply subst_res etyp) + | _ -> failwith "WIP" + in + helper +;; + +let infer_construction env = function + | Expr exp -> infer_expr env exp + | _ -> failwith "WIP" +;; + +let infer e = run (infer_construction TypeEnvironment.empty e) diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index 627e5a6ea..f4072f5b6 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -24,3 +24,8 @@ type binder_set = VarSet.t [@@deriving show { with_path = false }] (* binder_set here -- list of all type vars in context (?) *) type scheme = S of binder_set * typ [@@deriving show { with_path = false }] + +let int_typ = Primary "int" +let bool_typ = Primary "bool" +let string_typ = Primary "string" +let unit_typ = Primary "unit" From a0f3b092c7c1a6b12d90df15e99c07f1c98f4608 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Sat, 30 Nov 2024 22:35:10 +0300 Subject: [PATCH 223/310] feat: update REPL and example Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/REPL.ml | 19 +++++++++++++------ FSharpActivePatterns/bin/input.txt | 11 ++++------- 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 9f9e5870d..27f9627f6 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -5,6 +5,7 @@ open FSharpActivePatterns.AstPrinter open FSharpActivePatterns.Parser open FSharpActivePatterns.PrettyPrinter +open FSharpActivePatterns.Inferencer open Stdlib type input = @@ -70,12 +71,18 @@ let run_repl dump_parsetree input_file = run_repl_helper run | End -> () | Result ast -> - (match dump_parsetree with - | true -> print_construction std_formatter ast - | false -> - fprintf std_formatter "- : "; - pp_construction std_formatter ast); - print_flush (); + let result = infer ast in + (match result with + | Error err -> + fprintf err_formatter "Type checking failed: %a\n" pp_error err; + print_flush (); + | Ok (_, _) -> + (match dump_parsetree with + | true -> print_construction std_formatter ast + | false -> + fprintf std_formatter "- : "; + pp_construction std_formatter ast); + print_flush ()); run_repl_helper run in run_repl_helper run_single diff --git a/FSharpActivePatterns/bin/input.txt b/FSharpActivePatterns/bin/input.txt index 2fd54233d..ab98eba63 100644 --- a/FSharpActivePatterns/bin/input.txt +++ b/FSharpActivePatterns/bin/input.txt @@ -1,7 +1,4 @@ -let rec even n = - if n = 0 then true - else odd (n - 1) -and odd n : int = - if n = 0 then false - else even (n - 1) -;; \ No newline at end of file +1 + ();; +1 + "";; +1 + true;; +1 + 1;; \ No newline at end of file From 40018de1a683128b98f212aa218a4911e205a816 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 7 Dec 2024 22:24:03 +0300 Subject: [PATCH 224/310] feat: implement ite and all binexpr operators inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 32 +++++++++++++++++++++++--- 1 file changed, 29 insertions(+), 3 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index a3599031d..529ac1e6f 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -316,16 +316,42 @@ let infer_expr = let* e1typ, e2typ, etyp = match op with | Logical_and | Logical_or -> return (bool_typ, bool_typ, bool_typ) - | Binary_add | Binary_subtract | Binary_multiply | Binary_divide -> - return (int_typ, int_typ, int_typ) + | Binary_add + | Binary_subtract + | Binary_multiply + | Binary_divide + | Binary_and_bitwise + | Binary_or_bitwise + | Binary_xor_bitwise -> return (int_typ, int_typ, int_typ) + | Binary_greater | Binary_greater_or_equal | Binary_less | Binary_less_or_equal -> + return (int_typ, int_typ, bool_typ) + | Binary_equal | Binary_unequal -> + let* fr = make_fresh_var in + return (fr, fr, bool_typ) | _ -> failwith "WIP" in let* subst3 = Substitution.unify (Substitution.apply subst2 typ1) e1typ in (*Format.printf "Checking types: res_typ1 = %a\n" pp_typ (Substitution.apply subst2 typ1); - Format.printf "Checking types: res_typ2 = %a\n" pp_typ (Substitution.apply subst3 typ2);*) + Format.printf "Checking types: res_typ2 = %a\n" pp_typ (Substitution.apply subst3 typ2);*) let* subst4 = Substitution.unify (Substitution.apply subst3 typ2) e2typ in let* subst_res = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in return (subst_res, Substitution.apply subst_res etyp) + | If_then_else (c, th, Some el) -> + let* subst1, typ1 = helper env c in + let* subst2, typ2 = helper (TypeEnvironment.apply subst1 env) th in + let* subst3, typ3 = helper (TypeEnvironment.apply subst2 env) el in + let* subst4 = unify typ1 bool_typ in + let* subst5 = unify typ2 typ3 in + let* subst_result = + Substitution.compose_all [ subst1; subst2; subst3; subst4; subst5 ] + in + return (subst_result, Substitution.apply subst5 typ2) + | If_then_else (c, th, None) -> + let* subst1, typ1 = helper env c in + let* subst2, typ2 = helper (TypeEnvironment.apply subst1 env) th in + let* subst3 = unify typ1 bool_typ in + let* subst_result = Substitution.compose_all [ subst1; subst2; subst3 ] in + return (subst_result, Substitution.apply subst2 typ2) | _ -> failwith "WIP" in helper From 64a6f4a1bec6f2ef3107af99e0aed2f3b682c2c3 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 8 Dec 2024 09:10:14 +0300 Subject: [PATCH 225/310] feat: implement some pattern and expr inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 162 ++++++++++++++++--------- FSharpActivePatterns/lib/typedTree.ml | 5 + FSharpActivePatterns/lib/typesPp.ml | 1 - 3 files changed, 113 insertions(+), 55 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 529ac1e6f..e0ff4a407 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -38,6 +38,7 @@ module R : sig module RList : sig val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t + val fold_right : 'a list -> init:'b t -> f:('a -> 'b -> 'b t) -> 'b t end val fresh : int t @@ -88,6 +89,13 @@ end = struct let* acc = acc in f acc x) ;; + + let fold_right xs ~init ~f = + Base.List.fold_right xs ~init ~f:(fun x acc -> + let open Syntax in + let* acc = acc in + f x acc) + ;; end (* analogically to list. let* acc = acc is to extract value from type t *) @@ -111,7 +119,7 @@ type fresh = int module Type = struct type t = typ - (* check that type of the arg is not inside of type v. + (* check that v is not inside of second type. Runs during substitution to ensure that there are no cycles*) let rec occurs_in v = function | Primary _ -> false @@ -302,59 +310,105 @@ let generalize : TypeEnvironment.t -> Type.t -> Scheme.t = S (free, t) ;; -let infer_expr = - let rec helper env = function - | Const const -> - (match const with - | Int_lt _ -> return (Substitution.empty, int_typ) - | Bool_lt _ -> return (Substitution.empty, bool_typ) - | String_lt _ -> return (Substitution.empty, string_typ) - | Unit_lt -> return (Substitution.empty, unit_typ)) - | Bin_expr (op, e1, e2) -> - let* subst1, typ1 = helper env e1 in - let* subst2, typ2 = helper (TypeEnvironment.apply subst1 env) e2 in - let* e1typ, e2typ, etyp = - match op with - | Logical_and | Logical_or -> return (bool_typ, bool_typ, bool_typ) - | Binary_add - | Binary_subtract - | Binary_multiply - | Binary_divide - | Binary_and_bitwise - | Binary_or_bitwise - | Binary_xor_bitwise -> return (int_typ, int_typ, int_typ) - | Binary_greater | Binary_greater_or_equal | Binary_less | Binary_less_or_equal -> - return (int_typ, int_typ, bool_typ) - | Binary_equal | Binary_unequal -> - let* fr = make_fresh_var in - return (fr, fr, bool_typ) - | _ -> failwith "WIP" - in - let* subst3 = Substitution.unify (Substitution.apply subst2 typ1) e1typ in - (*Format.printf "Checking types: res_typ1 = %a\n" pp_typ (Substitution.apply subst2 typ1); - Format.printf "Checking types: res_typ2 = %a\n" pp_typ (Substitution.apply subst3 typ2);*) - let* subst4 = Substitution.unify (Substitution.apply subst3 typ2) e2typ in - let* subst_res = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in - return (subst_res, Substitution.apply subst_res etyp) - | If_then_else (c, th, Some el) -> - let* subst1, typ1 = helper env c in - let* subst2, typ2 = helper (TypeEnvironment.apply subst1 env) th in - let* subst3, typ3 = helper (TypeEnvironment.apply subst2 env) el in - let* subst4 = unify typ1 bool_typ in - let* subst5 = unify typ2 typ3 in - let* subst_result = - Substitution.compose_all [ subst1; subst2; subst3; subst4; subst5 ] - in - return (subst_result, Substitution.apply subst5 typ2) - | If_then_else (c, th, None) -> - let* subst1, typ1 = helper env c in - let* subst2, typ2 = helper (TypeEnvironment.apply subst1 env) th in - let* subst3 = unify typ1 bool_typ in - let* subst_result = Substitution.compose_all [ subst1; subst2; subst3 ] in - return (subst_result, Substitution.apply subst2 typ2) - | _ -> failwith "WIP" - in - helper +let infer_lt = function + | Int_lt _ -> return (Substitution.empty, int_typ) + | Bool_lt _ -> return (Substitution.empty, bool_typ) + | String_lt _ -> return (Substitution.empty, string_typ) + | Unit_lt -> return (Substitution.empty, unit_typ) +;; + +let rec infer_pattern env = function + | Wild -> + let* fresh_type = make_fresh_var in + return (fresh_type, env) + | PConst lt -> + let* _, t = infer_lt lt in + return (t, env) + | PVar (Ident (name, _)) -> + (* подумать что делать с типом в Ident*) + let* fresh = make_fresh_var in + let scheme = S (VarSet.empty, fresh) in + let env = TypeEnvironment.extend env name scheme in + return (fresh, env) + | POption None -> + let* fresh_type = make_fresh_var in + return (fresh_type, env) + | POption (Some p) -> infer_pattern env p + | _ -> failwith "WIP" +;; + +let rec infer_expr env = function + | Const lt -> infer_lt lt + | Variable (Ident (varname, _)) -> + (* подумать что делать с типом Ident*) + (match TypeEnvironment.find varname env with + | Some s -> + let* t = instantiate s in + return (Substitution.empty, t) + | None -> fail (`Undef_var varname)) + | Bin_expr (op, e1, e2) -> + let* subst1, typ1 = infer_expr env e1 in + let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) e2 in + let* e1typ, e2typ, etyp = + match op with + | Logical_and | Logical_or -> return (bool_typ, bool_typ, bool_typ) + | Binary_add + | Binary_subtract + | Binary_multiply + | Binary_divide + | Binary_and_bitwise + | Binary_or_bitwise + | Binary_xor_bitwise -> return (int_typ, int_typ, int_typ) + | Binary_greater | Binary_greater_or_equal | Binary_less | Binary_less_or_equal -> + return (int_typ, int_typ, bool_typ) + | Binary_equal | Binary_unequal -> + let* fresh_type = make_fresh_var in + return (fresh_type, fresh_type, bool_typ) + | _ -> failwith "Pattern inference WIP" + in + let* subst3 = Substitution.unify (Substitution.apply subst2 typ1) e1typ in + (*Format.printf "Checking types: res_typ1 = %a\n" pp_typ (Substitution.apply subst2 typ1); + Format.printf "Checking types: res_typ2 = %a\n" pp_typ (Substitution.apply subst3 typ2);*) + let* subst4 = Substitution.unify (Substitution.apply subst3 typ2) e2typ in + let* subst_res = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in + return (subst_res, Substitution.apply subst_res etyp) + | If_then_else (c, th, Some el) -> + let* subst1, typ1 = infer_expr env c in + let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) th in + let* subst3, typ3 = infer_expr (TypeEnvironment.apply subst2 env) el in + let* subst4 = unify typ1 bool_typ in + let* subst5 = unify typ2 typ3 in + let* subst_result = + Substitution.compose_all [ subst1; subst2; subst3; subst4; subst5 ] + in + return (subst_result, Substitution.apply subst5 typ2) + | If_then_else (c, th, None) -> + let* subst1, typ1 = infer_expr env c in + let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) th in + let* subst3 = unify typ1 bool_typ in + let* subst_result = Substitution.compose_all [ subst1; subst2; subst3 ] in + return (subst_result, Substitution.apply subst2 typ2) + | Apply (f, arg) -> + let* subst1, typ1 = infer_expr env f in + let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) arg in + let* fresh_type = make_fresh_var in + let* subst3 = unify (Substitution.apply subst2 typ1) (Arrow (typ2, fresh_type)) in + let* subst_result = Substitution.compose_all [ subst1; subst2; subst3 ] in + return (subst_result, Substitution.apply subst_result fresh_type) + | Lambda (arg, args, e) -> + let* arg1_type, env = infer_pattern env arg in + let* env, arg_types = + RList.fold_right + args + ~init:(return (env, [])) + ~f:(fun arg (old_env, typs) -> + let* typ, new_env = infer_pattern old_env arg in + return (new_env, typ :: typs)) + in + let* subst, e_type = infer_expr env e in + return + (subst, Substitution.apply subst (arrow_of_types arg1_type (arg_types @ [ e_type ]))) + | _ -> failwith "Expr inference WIP" ;; let infer_construction env = function diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index f4072f5b6..cbb72ee0c 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -10,6 +10,11 @@ type typ = | Arrow of typ * typ [@@deriving show { with_path = false }] +let arrow_of_types first rest = + let open Base in + List.fold_right rest ~init:first ~f:(fun left right -> Arrow (left, right)) +;; + module VarSet = struct include Stdlib.Set.Make (Int) diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index 7fb949892..14e5fc83e 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -3,7 +3,6 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open TypedTree -open PrettyPrinter open Format let rec pp_typ fmt = function From 3e247ecb50cfec2376c3a2d6b1229a922789f873 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 8 Dec 2024 22:27:25 +0300 Subject: [PATCH 226/310] feat: change repl to print types Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 7 ++++--- FSharpActivePatterns/lib/typesPp.ml | 12 ++++++++---- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 27f9627f6..0f4fc1c71 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -6,6 +6,7 @@ open FSharpActivePatterns.AstPrinter open FSharpActivePatterns.Parser open FSharpActivePatterns.PrettyPrinter open FSharpActivePatterns.Inferencer +open FSharpActivePatterns.TypesPp open Stdlib type input = @@ -75,13 +76,13 @@ let run_repl dump_parsetree input_file = (match result with | Error err -> fprintf err_formatter "Type checking failed: %a\n" pp_error err; - print_flush (); - | Ok (_, _) -> + print_flush () + | Ok (_, t) -> (match dump_parsetree with | true -> print_construction std_formatter ast | false -> fprintf std_formatter "- : "; - pp_construction std_formatter ast); + pp_typ std_formatter t); print_flush ()); run_repl_helper run in diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index 14e5fc83e..bf01ecf91 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -5,8 +5,12 @@ open TypedTree open Format -let rec pp_typ fmt = function - | Primary s -> fprintf fmt "%S" s - | Type_var var -> fprintf fmt "'_%d" var - | Arrow (fst, snd) -> fprintf fmt "(%a -> %a)" pp_typ fst pp_typ snd +let pp_typ fmt typ = + let rec helper fmt = function + | Primary s -> fprintf fmt "%S" s + | Type_var var -> fprintf fmt "'_%d" var + | Arrow (fst, snd) -> fprintf fmt "(%a) -> %a" helper fst helper snd + in + helper fmt typ; + fprintf fmt "\n" ;; From 9306e0389c19c1ff482b7ee46eed96ce1e40f0ae Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 8 Dec 2024 22:41:14 +0300 Subject: [PATCH 227/310] fix: arrow of many types constructor and lambda inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 6 ++---- FSharpActivePatterns/lib/typedTree.ml | 4 ++-- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index e0ff4a407..989784a8f 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -396,18 +396,16 @@ let rec infer_expr env = function let* subst_result = Substitution.compose_all [ subst1; subst2; subst3 ] in return (subst_result, Substitution.apply subst_result fresh_type) | Lambda (arg, args, e) -> - let* arg1_type, env = infer_pattern env arg in let* env, arg_types = RList.fold_right - args + (arg :: args) ~init:(return (env, [])) ~f:(fun arg (old_env, typs) -> let* typ, new_env = infer_pattern old_env arg in return (new_env, typ :: typs)) in let* subst, e_type = infer_expr env e in - return - (subst, Substitution.apply subst (arrow_of_types arg1_type (arg_types @ [ e_type ]))) + return (subst, Substitution.apply subst (arrow_of_types arg_types e_type)) | _ -> failwith "Expr inference WIP" ;; diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index cbb72ee0c..5c9c17370 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -10,9 +10,9 @@ type typ = | Arrow of typ * typ [@@deriving show { with_path = false }] -let arrow_of_types first rest = +let arrow_of_types first_types last = let open Base in - List.fold_right rest ~init:first ~f:(fun left right -> Arrow (left, right)) + List.fold_right first_types ~init:last ~f:(fun left right -> Arrow (left, right)) ;; module VarSet = struct From daaafbc1f9c8443d2b1953ab4f17062da68ea0c9 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 9 Dec 2024 10:09:25 +0300 Subject: [PATCH 228/310] feat: add tuple, list, option inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 1 - FSharpActivePatterns/lib/inferencer.ml | 85 ++++++++++++++++++++++++-- FSharpActivePatterns/lib/typedTree.ml | 13 ++-- FSharpActivePatterns/lib/typesPp.ml | 12 +++- 4 files changed, 99 insertions(+), 12 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 0f4fc1c71..6484a1e42 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -4,7 +4,6 @@ open FSharpActivePatterns.AstPrinter open FSharpActivePatterns.Parser -open FSharpActivePatterns.PrettyPrinter open FSharpActivePatterns.Inferencer open FSharpActivePatterns.TypesPp open Stdlib diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 989784a8f..c89fd1f71 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -122,17 +122,24 @@ module Type = struct (* check that v is not inside of second type. Runs during substitution to ensure that there are no cycles*) let rec occurs_in v = function - | Primary _ -> false + | Primitive _ -> false | Type_var b -> b = v | Arrow (fst, snd) -> occurs_in v fst || occurs_in v snd + | Type_list typ -> occurs_in v typ + | Type_tuple (fst, snd, rest) -> + occurs_in v fst || occurs_in v snd || List.exists rest ~f:(occurs_in v) + | TOption t -> occurs_in v t ;; (* collects all type variables *) let free_vars = let rec helper acc = function - | Primary _ -> acc + | Primitive _ -> acc | Type_var b -> VarSet.add b acc | Arrow (fst, snd) -> helper (helper acc fst) snd + | Type_list typ -> helper acc typ + | Type_tuple (fst, snd, rest) -> List.fold (fst :: snd :: rest) ~init:acc ~f:helper + | TOption t -> helper acc t in helper VarSet.empty ;; @@ -196,14 +203,27 @@ end = struct and type into context (map) *) let rec unify fst snd = match fst, snd with - | Primary fst, Primary snd when String.equal fst snd -> return empty - | Primary _, Primary _ -> fail (`Unification_failed (fst, snd)) + | Primitive fst, Primitive snd when String.equal fst snd -> return empty + | Primitive _, Primitive _ -> fail (`Unification_failed (fst, snd)) | Type_var f, Type_var s when Int.equal f s -> return empty | Type_var b, t | t, Type_var b -> singleton b t | Arrow (f1, s1), Arrow (f2, s2) -> let* subst1 = unify f1 f2 in let* subst2 = unify s1 s2 in compose subst1 subst2 + | Type_list t1, Type_list t2 -> unify t1 t2 + | TOption t1, TOption t2 -> unify t1 t2 + | Type_tuple (t1_1, t1_2, t1_rest), Type_tuple (t2_1, t2_2, t2_rest) + when List.length t1_rest = List.length t2_rest -> + let type_pairs = List.zip_exn (t1_1 :: t1_2 :: t1_rest) (t2_1 :: t2_2 :: t2_rest) in + let* substitutions = + List.fold type_pairs ~init:(return []) ~f:(fun acc (t1, t2) -> + let* acc = acc in + let* subst = unify t1 t2 in + return (subst :: acc)) + in + let substitution_result = compose_all substitutions in + substitution_result | _ -> fail (`Unification_failed (fst, snd)) (* if value associated w this key exists in map, try to unify them, otherwise @@ -225,7 +245,7 @@ end = struct and compose map1 map2 = RMap.fold map2 ~init:(return map1) ~f:extend (* compose list of maps together *) - let compose_all maps = RList.fold_left maps ~init:(return empty) ~f:compose + and compose_all maps = RList.fold_left maps ~init:(return empty) ~f:compose end (* module for scheme treatment *) @@ -346,6 +366,16 @@ let rec infer_expr env = function let* t = instantiate s in return (Substitution.empty, t) | None -> fail (`Undef_var varname)) + | Unary_expr (op, e) -> + let* op_typ = + match op with + | Unary_minus -> return int_typ + | Unary_not -> return bool_typ + in + let* e_subst, e_typ = infer_expr env e in + let* subst = unify op_typ (Substitution.apply e_subst e_typ) in + let* subst_result = Substitution.compose_all [ e_subst; subst ] in + return (subst_result, e_typ) | Bin_expr (op, e1, e2) -> let* subst1, typ1 = infer_expr env e1 in let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) e2 in @@ -372,6 +402,51 @@ let rec infer_expr env = function let* subst4 = Substitution.unify (Substitution.apply subst3 typ2) e2typ in let* subst_res = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in return (subst_res, Substitution.apply subst_res etyp) + | Option None -> + let* fresh_typ = make_fresh_var in + return (Substitution.empty, TOption fresh_typ) + | Option (Some e) -> + let* subst, typ = infer_expr env e in + return (subst, TOption typ) + | Tuple (fst, snd, rest) -> + let* subst1, typ1 = infer_expr env fst in + let* subst2, typ2 = infer_expr env snd in + let* subst_rest, typs_rest = + List.fold_right + rest + ~f:(fun e acc -> + let* subst_acc, typs = acc in + let* subst, typ = infer_expr env e in + let* subst_acc = Substitution.compose subst_acc subst in + return (subst_acc, typ :: typs)) + ~init:(return (Substitution.empty, [])) + in + let* subst_result = Substitution.compose_all [ subst1; subst2; subst_rest ] in + let typ1 = Substitution.apply subst_result typ1 in + let typ2 = Substitution.apply subst_result typ2 in + let typs_rest = + List.map typs_rest ~f:(fun typ -> Substitution.apply subst_result typ) + in + return (subst_result, Type_tuple (typ1, typ2, typs_rest)) + | List [] -> + let* fresh_type = make_fresh_var in + return (Substitution.empty, Type_list fresh_type) + | List (hd :: tl) -> + let* subst1, typ1 = infer_expr env hd in + let typ1 = Substitution.apply subst1 typ1 in + let* subst_unify, typ_unified = + List.fold + tl + ~f:(fun acc e -> + let* subst_acc, typ_acc = acc in + let* subst, typ = infer_expr env e in + let* subst_unify = unify typ_acc typ in + let typ_acc = Substitution.apply subst_unify typ_acc in + let* subst_acc = Substitution.compose_all [ subst; subst_acc; subst_unify ] in + return (subst_acc, typ_acc)) + ~init:(return (subst1, typ1)) + in + return (subst_unify, Type_list typ_unified) | If_then_else (c, th, Some el) -> let* subst1, typ1 = infer_expr env c in let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) th in diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index 5c9c17370..54ff2528f 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -5,9 +5,12 @@ type binder = int [@@deriving show { with_path = false }] type typ = - | Primary of string + | Primitive of string | Type_var of binder | Arrow of typ * typ + | Type_list of typ + | Type_tuple of typ * typ * typ list + | TOption of typ [@@deriving show { with_path = false }] let arrow_of_types first_types last = @@ -30,7 +33,7 @@ type binder_set = VarSet.t [@@deriving show { with_path = false }] (* binder_set here -- list of all type vars in context (?) *) type scheme = S of binder_set * typ [@@deriving show { with_path = false }] -let int_typ = Primary "int" -let bool_typ = Primary "bool" -let string_typ = Primary "string" -let unit_typ = Primary "unit" +let int_typ = Primitive "int" +let bool_typ = Primitive "bool" +let string_typ = Primitive "string" +let unit_typ = Primitive "unit" diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index bf01ecf91..3ec2d58f1 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -7,9 +7,19 @@ open Format let pp_typ fmt typ = let rec helper fmt = function - | Primary s -> fprintf fmt "%S" s + | Primitive s -> fprintf fmt "%S" s | Type_var var -> fprintf fmt "'_%d" var | Arrow (fst, snd) -> fprintf fmt "(%a) -> %a" helper fst helper snd + | Type_list typ -> fprintf fmt "%a list" helper typ + | Type_tuple (first, second, rest) -> + fprintf fmt "("; + Format.pp_print_list + ~pp_sep:(fun fmt () -> fprintf fmt ", ") + pp_typ + fmt + (first :: second :: rest); + fprintf fmt ")" + | TOption t -> fprintf fmt "(%a) option" pp_typ t in helper fmt typ; fprintf fmt "\n" From fdf86d37ca38db3b0f0365e67726e679d17d8ebc Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 9 Dec 2024 12:46:50 +0300 Subject: [PATCH 229/310] ref: fail errors Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 50 +++++++++++++++++++++++--- FSharpActivePatterns/lib/typesPp.mli | 8 +++++ 2 files changed, 54 insertions(+), 4 deletions(-) create mode 100644 FSharpActivePatterns/lib/typesPp.mli diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index c89fd1f71..85ee181ac 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -12,6 +12,7 @@ type error = [ `Occurs_check | `Undef_var of string | `Unification_failed of typ * typ + | `WIP of string ] let pp_error fmt : error -> _ = function @@ -19,6 +20,7 @@ let pp_error fmt : error -> _ = function | `Undef_var s -> fprintf fmt "Undefined variable '%s'" s | `Unification_failed (fst, snd) -> fprintf fmt "unification failed on %a and %a" pp_typ fst pp_typ snd + | `WIP s -> fprintf fmt "%s" s ;; (* for treating result of type inference *) @@ -354,7 +356,7 @@ let rec infer_pattern env = function let* fresh_type = make_fresh_var in return (fresh_type, env) | POption (Some p) -> infer_pattern env p - | _ -> failwith "WIP" + | _ -> fail (`WIP "Pattern inference WIP") ;; let rec infer_expr env = function @@ -394,7 +396,7 @@ let rec infer_expr env = function | Binary_equal | Binary_unequal -> let* fresh_type = make_fresh_var in return (fresh_type, fresh_type, bool_typ) - | _ -> failwith "Pattern inference WIP" + | _ -> fail (`WIP "Cons inference WIP") in let* subst3 = Substitution.unify (Substitution.apply subst2 typ1) e1typ in (*Format.printf "Checking types: res_typ1 = %a\n" pp_typ (Substitution.apply subst2 typ1); @@ -481,12 +483,52 @@ let rec infer_expr env = function in let* subst, e_type = infer_expr env e in return (subst, Substitution.apply subst (arrow_of_types arg_types e_type)) - | _ -> failwith "Expr inference WIP" + (* | LetIn (Rec, let_bind, let_binds, e) -> + let bind_names = + List.map (let_bind :: let_binds) ~f:(fun let_bind -> + match let_bind with + | Let_bind (Ident (name, _), _, _) -> name) + in + let* env = + List.fold + ~init:(return env) + ~f:(fun acc name -> + let* fresh_type = make_fresh_var in + let* acc = acc in + return (TypeEnvironment.extend acc name (S (VarSet.empty, fresh_type)))) + bind_names + in + x *) + | _ -> fail (`WIP "Expr inference WIP") ;; +(* and infer_let_bind env fresh_type = function + | Let_bind (_, args, e) -> + let arg_names = + List.map args ~f:(fun arg -> + match arg with + | Ident (name, _) -> name) + in + let* env = + List.fold + ~init:(return env) + ~f:(fun acc arg -> + let* fresh_type = make_fresh_var in + let* acc = acc in + return (TypeEnvironment.extend acc arg (S (VarSet.empty, fresh_type)))) + arg_names + in + let* subst1, typ1 = infer_expr env e in + let* subst2 = unify (Substitution.apply subst1 fresh_type) typ1 in + let* subst = Substitution.compose subst1 subst2 in + let env = TypeEnvironment.apply subst env in + let typ2 = generalize env (Substitution.apply subst fresh_type) in + return (subst, typ2) + ;; *) + let infer_construction env = function | Expr exp -> infer_expr env exp - | _ -> failwith "WIP" + | _ -> fail (`WIP "Statement inference WIP") ;; let infer e = run (infer_construction TypeEnvironment.empty e) diff --git a/FSharpActivePatterns/lib/typesPp.mli b/FSharpActivePatterns/lib/typesPp.mli new file mode 100644 index 000000000..3b4a29818 --- /dev/null +++ b/FSharpActivePatterns/lib/typesPp.mli @@ -0,0 +1,8 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open TypedTree +open Format + +val pp_typ : formatter -> typ -> unit From a353624226808ffd646426544f8b7239011744ce Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 9 Dec 2024 13:40:42 +0300 Subject: [PATCH 230/310] feat: implement cons, list and tuple patterns Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 42 ++++++++++++++++++++++++-- 1 file changed, 40 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 85ee181ac..65df4b2a9 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -356,7 +356,43 @@ let rec infer_pattern env = function let* fresh_type = make_fresh_var in return (fresh_type, env) | POption (Some p) -> infer_pattern env p - | _ -> fail (`WIP "Pattern inference WIP") + | PList [] -> + let* fresh_type = make_fresh_var in + return (Type_list fresh_type, env) + | PList (hd :: tl) -> + let* typ1, env = infer_pattern env hd in + let* subst_unify, typ_unified = + List.fold + tl + ~f:(fun acc p -> + let* subst_acc, typ_acc = acc in + let* typ, _ = infer_pattern env p in + let* subst_unify = unify typ_acc typ in + let typ_acc = Substitution.apply subst_unify typ_acc in + let* subst_acc = Substitution.compose_all [ subst_acc; subst_unify ] in + return (subst_acc, typ_acc)) + ~init:(return (Substitution.empty, typ1)) + in + return (typ_unified, TypeEnvironment.apply subst_unify env) + | PCons (hd, tl) -> + let* typ1, env = infer_pattern env hd in + let* typ2, env = infer_pattern env tl in + let* subst = Substitution.unify typ2 (Type_list typ1) in + let env = TypeEnvironment.apply subst env in + return (Substitution.apply subst typ2, env) + | PTuple (fst, snd, rest) -> + let* typ1, _ = infer_pattern env fst in + let* typ2, _ = infer_pattern env snd in + let* typs_rest = + List.fold_right + rest + ~f:(fun p patterns_acc -> + let* patterns_acc = patterns_acc in + let* typ, _ = infer_pattern env p in + return (typ :: patterns_acc)) + ~init:(return []) + in + return (Type_tuple (typ1, typ2, typs_rest), env) ;; let rec infer_expr env = function @@ -396,7 +432,9 @@ let rec infer_expr env = function | Binary_equal | Binary_unequal -> let* fresh_type = make_fresh_var in return (fresh_type, fresh_type, bool_typ) - | _ -> fail (`WIP "Cons inference WIP") + | Binary_cons -> + let* fresh_type = make_fresh_var in + return (fresh_type, Type_list fresh_type, Type_list fresh_type) in let* subst3 = Substitution.unify (Substitution.apply subst2 typ1) e1typ in (*Format.printf "Checking types: res_typ1 = %a\n" pp_typ (Substitution.apply subst2 typ1); From 3415edfde1da12c77f958af86fa0174b14938857 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 9 Dec 2024 19:30:33 +0300 Subject: [PATCH 231/310] feat: mli for typedTree Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/typedTree.mli | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 FSharpActivePatterns/lib/typedTree.mli diff --git a/FSharpActivePatterns/lib/typedTree.mli b/FSharpActivePatterns/lib/typedTree.mli new file mode 100644 index 000000000..03326f01e --- /dev/null +++ b/FSharpActivePatterns/lib/typedTree.mli @@ -0,0 +1,25 @@ + +type binder = int + +type typ = + | Primitive of string + | Type_var of binder + | Arrow of typ * typ + | Type_list of typ + | Type_tuple of typ * typ * typ list + | TOption of typ + +val arrow_of_types: typ list -> typ -> typ + +module VarSet : sig + include module type of Stdlib.Set.Make (Int) + + val pp: Format.formatter -> t -> unit +end + +type binder_set = VarSet.t +type scheme = S of binder_set * typ [@@deriving show { with_path = false }] +val int_typ: typ +val bool_typ: typ +val string_typ: typ +val unit_typ: typ \ No newline at end of file From 21fe543da978d28bce6bf65f0dbfe3b3238d67d9 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 9 Dec 2024 19:30:58 +0300 Subject: [PATCH 232/310] fix: call of helper in pp Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/typesPp.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index 3ec2d58f1..8e18b1ef4 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -15,11 +15,11 @@ let pp_typ fmt typ = fprintf fmt "("; Format.pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") - pp_typ + helper fmt (first :: second :: rest); fprintf fmt ")" - | TOption t -> fprintf fmt "(%a) option" pp_typ t + | TOption t -> fprintf fmt "(%a) option" helper t in helper fmt typ; fprintf fmt "\n" From 26e76a409be371e9814a31909a9c57c79b9fa5dd Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Mon, 9 Dec 2024 19:34:54 +0300 Subject: [PATCH 233/310] ref: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/typedTree.mli | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/lib/typedTree.mli b/FSharpActivePatterns/lib/typedTree.mli index 03326f01e..09c2ff54a 100644 --- a/FSharpActivePatterns/lib/typedTree.mli +++ b/FSharpActivePatterns/lib/typedTree.mli @@ -1,3 +1,6 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) type binder = int @@ -9,17 +12,18 @@ type typ = | Type_tuple of typ * typ * typ list | TOption of typ -val arrow_of_types: typ list -> typ -> typ +val arrow_of_types : typ list -> typ -> typ module VarSet : sig - include module type of Stdlib.Set.Make (Int) - - val pp: Format.formatter -> t -> unit + include module type of Stdlib.Set.Make (Int) + + val pp : Format.formatter -> t -> unit end type binder_set = VarSet.t type scheme = S of binder_set * typ [@@deriving show { with_path = false }] -val int_typ: typ -val bool_typ: typ -val string_typ: typ -val unit_typ: typ \ No newline at end of file + +val int_typ : typ +val bool_typ : typ +val string_typ : typ +val unit_typ : typ From f5b2fa307a686c8a27c394907e19814b36c774f8 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 9 Dec 2024 22:23:51 +0300 Subject: [PATCH 234/310] fix: implement substitution for all types Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 65df4b2a9..42ecfb99f 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -196,7 +196,11 @@ end = struct | None -> typ | Some x -> x) | Arrow (fst, snd) -> Arrow (helper fst, helper snd) - | other -> other + | Type_list t -> Type_list (helper t) + | Type_tuple (fst, snd, rest) -> + Type_tuple (helper fst, helper snd, List.map rest ~f:helper) + | Primitive t -> Primitive t + | TOption t -> TOption (helper t) in helper ;; From 66481bdf45b73fc9d1d5990a98397325638a279d Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 9 Dec 2024 22:59:27 +0300 Subject: [PATCH 235/310] feat: inferencer.mli Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 2 +- FSharpActivePatterns/lib/inferencer.ml | 6 ++++-- FSharpActivePatterns/lib/inferencer.mli | 17 +++++++++++++++++ 3 files changed, 22 insertions(+), 3 deletions(-) create mode 100644 FSharpActivePatterns/lib/inferencer.mli diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 6484a1e42..89e6e8c23 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -76,7 +76,7 @@ let run_repl dump_parsetree input_file = | Error err -> fprintf err_formatter "Type checking failed: %a\n" pp_error err; print_flush () - | Ok (_, t) -> + | Ok t -> (match dump_parsetree with | true -> print_construction std_formatter ast | false -> diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 42ecfb99f..92bdb6d98 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -569,8 +569,10 @@ let rec infer_expr env = function ;; *) let infer_construction env = function - | Expr exp -> infer_expr env exp + | Expr exp -> + let* _, typ = infer_expr env exp in + return typ | _ -> fail (`WIP "Statement inference WIP") ;; -let infer e = run (infer_construction TypeEnvironment.empty e) +let infer c = run (infer_construction TypeEnvironment.empty c) diff --git a/FSharpActivePatterns/lib/inferencer.mli b/FSharpActivePatterns/lib/inferencer.mli new file mode 100644 index 000000000..04854645b --- /dev/null +++ b/FSharpActivePatterns/lib/inferencer.mli @@ -0,0 +1,17 @@ +(** Copyright 2024-2025, Ksenia Kotelnikova , Gleb Nasretdinov *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +open Ast +open TypedTree +open Format + +type error = + [ `Occurs_check + | `Undef_var of string + | `Unification_failed of typ * typ + | `WIP of string + ] + +val pp_error : formatter -> error -> unit +val infer : construction -> (typ, error) result From c8d1451a004184da12c75285911e6e6a0fc722c2 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 9 Dec 2024 23:17:58 +0300 Subject: [PATCH 236/310] lint: unused value Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 93 ++++++++++++++++---------- 1 file changed, 56 insertions(+), 37 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 92bdb6d98..3cfe55884 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -28,7 +28,7 @@ module R : sig (* signature, smth like interface before realization *) type 'a t - val bind : 'a t -> f:('a -> 'b t) -> 'b t + (* val bind : 'a t -> f:('a -> 'b t) -> 'b t *) val return : 'a -> 'a t val fail : error -> 'a t @@ -118,7 +118,12 @@ end type fresh = int (* module with all type methods *) -module Type = struct +module Type : sig + type t = typ + + val occurs_in : fresh -> t -> bool + (* val free_vars : t -> binder_set *) +end = struct type t = typ (* check that v is not inside of second type. @@ -134,17 +139,17 @@ module Type = struct ;; (* collects all type variables *) - let free_vars = - let rec helper acc = function - | Primitive _ -> acc - | Type_var b -> VarSet.add b acc - | Arrow (fst, snd) -> helper (helper acc fst) snd - | Type_list typ -> helper acc typ - | Type_tuple (fst, snd, rest) -> List.fold (fst :: snd :: rest) ~init:acc ~f:helper - | TOption t -> helper acc t - in - helper VarSet.empty - ;; + (* let free_vars = + let rec helper acc = function + | Primitive _ -> acc + | Type_var b -> VarSet.add b acc + | Arrow (fst, snd) -> helper (helper acc fst) snd + | Type_list typ -> helper acc typ + | Type_tuple (fst, snd, rest) -> List.fold (fst :: snd :: rest) ~init:acc ~f:helper + | TOption t -> helper acc t + in + helper VarSet.empty + ;; *) end (* module of substitution *) @@ -153,9 +158,11 @@ module Substitution : sig type t val empty : t - val mapping : fresh -> typ -> (fresh * typ) R.t + + (* val mapping : fresh -> typ -> (fresh * typ) R.t *) val singleton : fresh -> typ -> t R.t - val find : t -> fresh -> typ option + + (* val find : t -> fresh -> typ option *) val remove : t -> fresh -> t val apply : t -> typ -> typ val unify : typ -> typ -> t R.t @@ -255,18 +262,24 @@ end = struct end (* module for scheme treatment *) -module Scheme = struct +module Scheme : sig + type t = scheme + + (* val occurs_in : fresh -> t -> bool *) + val apply : Substitution.t -> t -> t + (* val free_vars : t -> binder_set *) +end = struct type t = scheme (* occurs check for both type vars set and typ in sheme *) - let occurs_in value = function - | S (vars, t) -> (not (VarSet.mem value vars)) && Type.occurs_in value t - ;; + (* let occurs_in value = function + | S (vars, t) -> (not (VarSet.mem value vars)) && Type.occurs_in value t + ;; *) (* take all vars that are not bound in typ *) - let free_vars = function - | S (vars, t) -> VarSet.diff (Type.free_vars t) vars - ;; + (* let free_vars = function + | S (vars, t) -> VarSet.diff (Type.free_vars t) vars + ;; *) (* take substitution and scheme, remove its free vars from substitution, form new scheme according to substitution (apply it to typ) *) @@ -275,19 +288,25 @@ module Scheme = struct S (vars, Substitution.apply subst2 t) ;; - let pp = pp_scheme + (* let pp = pp_scheme *) end -module TypeEnvironment = struct +module TypeEnvironment : sig + val extend : ('a, 'b, 'c) Base.Map.t -> 'a -> 'b -> ('a, 'b, 'c) Base.Map.t + val apply : Substitution.t -> ('a, scheme, 'b) Base.Map.t -> ('a, scheme, 'b) Base.Map.t + val empty : (string, 'a, Base.String.comparator_witness) Base.Map.t + val find : 'a -> ('a, 'b, 'c) Base.Map.t -> 'b option +end = struct open Base (* environment (context?) -- pairs of names and their types list *) - type t = (ident, scheme, String.comparator_witness) Map.t + (* type t = (ident, scheme, String.comparator_witness) Map.t *) (* if pair (key, some old value) exists in map env, then replace old value with new, else add pair (key, value) into map *) let extend env key value = Map.update env key ~f:(fun _ -> value) - let remove env key = Map.remove env key + + (* let remove env key = Map.remove env key *) let empty = Map.empty (module String) (* apply given substitution to all elements of environment *) @@ -295,18 +314,18 @@ module TypeEnvironment = struct let find key env = Map.find env key (* collect all free vars from environment *) - let free_vars : t -> VarSet.t = - Map.fold ~init:VarSet.empty ~f:(fun ~key:_ ~data:s acc -> - VarSet.union acc (Scheme.free_vars s)) - ;; + (* let free_vars : t -> VarSet.t = + Map.fold ~init:VarSet.empty ~f:(fun ~key:_ ~data:s acc -> + VarSet.union acc (Scheme.free_vars s)) + ;; *) (* TODO: custom pp_scheme? not from deriving *) - let pp fmt map = + (* let pp fmt map = Stdlib.Format.fprintf fmt "{| "; Map.iteri map ~f:(fun ~key:n ~data:s -> Stdlib.Format.fprintf fmt "%s -> %a; " n pp_scheme s); Stdlib.Format.fprintf fmt "|}%!" - ;; + ;; *) end open R @@ -330,11 +349,11 @@ let instantiate : scheme -> typ R.t = (* take free vars of type t and environment, put difference between them in S constructor so all vars are context independent *) -let generalize : TypeEnvironment.t -> Type.t -> Scheme.t = - fun env t -> - let free = VarSet.diff (Type.free_vars t) (TypeEnvironment.free_vars env) in - S (free, t) -;; +(* let generalize : TypeEnvironment.t -> Type.t -> Scheme.t = + fun env t -> + let free = VarSet.diff (Type.free_vars t) (TypeEnvironment.free_vars env) in + S (free, t) + ;; *) let infer_lt = function | Int_lt _ -> return (Substitution.empty, int_typ) From bdbd9a5f7c94592208f527a3f03050e4634fc6bf Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 10 Dec 2024 00:16:43 +0300 Subject: [PATCH 237/310] resolve merge conflics Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 4 ---- FSharpActivePatterns/lib/typesPp.mli | 4 ---- 2 files changed, 8 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 35df8c4cc..89e6e8c23 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -4,12 +4,8 @@ open FSharpActivePatterns.AstPrinter open FSharpActivePatterns.Parser -<<<<<<< HEAD open FSharpActivePatterns.Inferencer open FSharpActivePatterns.TypesPp -======= -open FSharpActivePatterns.PrettyPrinter ->>>>>>> kakadu/master open Stdlib type input = diff --git a/FSharpActivePatterns/lib/typesPp.mli b/FSharpActivePatterns/lib/typesPp.mli index 1f00e119a..3b4a29818 100644 --- a/FSharpActivePatterns/lib/typesPp.mli +++ b/FSharpActivePatterns/lib/typesPp.mli @@ -2,11 +2,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -<<<<<<<< HEAD:FSharpActivePatterns/lib/typesPp.mli open TypedTree open Format val pp_typ : formatter -> typ -> unit -======== -val is_keyword : string -> bool ->>>>>>>> kakadu/master:FSharpActivePatterns/lib/keywordChecker.mli From a2bf023ebfddc736e9611d506452a50a054f59e0 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 14 Dec 2024 16:57:39 +0300 Subject: [PATCH 238/310] ref: eta reduction Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 3cfe55884..ef7a1aef5 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -190,8 +190,8 @@ end = struct ;; (* aliases for Map actions *) - let find map key = Map.find map key - let remove map key = Map.remove map key + let find = Map.find + let remove = Map.remove (* search for input in given map, if there is no match, output input type, else output found typ value associated w this key. From 0053cad387f22a298044fba385b3c6a74be38dc8 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 15 Dec 2024 15:56:49 +0300 Subject: [PATCH 239/310] feat: implement LetIn inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 225 +++++++++++++++---------- FSharpActivePatterns/lib/typedTree.ml | 6 +- FSharpActivePatterns/lib/typedTree.mli | 2 +- FSharpActivePatterns/lib/typesPp.ml | 5 +- 4 files changed, 143 insertions(+), 95 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index ef7a1aef5..d5c24714c 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -122,7 +122,7 @@ module Type : sig type t = typ val occurs_in : fresh -> t -> bool - (* val free_vars : t -> binder_set *) + val free_vars : t -> binder_set end = struct type t = typ @@ -139,17 +139,17 @@ end = struct ;; (* collects all type variables *) - (* let free_vars = - let rec helper acc = function - | Primitive _ -> acc - | Type_var b -> VarSet.add b acc - | Arrow (fst, snd) -> helper (helper acc fst) snd - | Type_list typ -> helper acc typ - | Type_tuple (fst, snd, rest) -> List.fold (fst :: snd :: rest) ~init:acc ~f:helper - | TOption t -> helper acc t - in - helper VarSet.empty - ;; *) + let free_vars = + let rec helper acc = function + | Primitive _ -> acc + | Type_var b -> VarSet.add b acc + | Arrow (fst, snd) -> helper (helper acc fst) snd + | Type_list typ -> helper acc typ + | Type_tuple (fst, snd, rest) -> List.fold (fst :: snd :: rest) ~init:acc ~f:helper + | TOption t -> helper acc t + in + helper VarSet.empty + ;; end (* module of substitution *) @@ -217,7 +217,6 @@ end = struct let rec unify fst snd = match fst, snd with | Primitive fst, Primitive snd when String.equal fst snd -> return empty - | Primitive _, Primitive _ -> fail (`Unification_failed (fst, snd)) | Type_var f, Type_var s when Int.equal f s -> return empty | Type_var b, t | t, Type_var b -> singleton b t | Arrow (f1, s1), Arrow (f2, s2) -> @@ -267,7 +266,7 @@ module Scheme : sig (* val occurs_in : fresh -> t -> bool *) val apply : Substitution.t -> t -> t - (* val free_vars : t -> binder_set *) + val free_vars : t -> binder_set end = struct type t = scheme @@ -277,30 +276,33 @@ end = struct ;; *) (* take all vars that are not bound in typ *) - (* let free_vars = function - | S (vars, t) -> VarSet.diff (Type.free_vars t) vars - ;; *) + let free_vars = function + | Scheme (vars, t) -> VarSet.diff (Type.free_vars t) vars + ;; (* take substitution and scheme, remove its free vars from substitution, form new scheme according to substitution (apply it to typ) *) - let apply subst (S (vars, t)) = + let apply subst (Scheme (vars, t)) = let subst2 = VarSet.fold (fun key s -> Substitution.remove s key) vars subst in - S (vars, Substitution.apply subst2 t) + Scheme (vars, Substitution.apply subst2 t) ;; (* let pp = pp_scheme *) end module TypeEnvironment : sig - val extend : ('a, 'b, 'c) Base.Map.t -> 'a -> 'b -> ('a, 'b, 'c) Base.Map.t - val apply : Substitution.t -> ('a, scheme, 'b) Base.Map.t -> ('a, scheme, 'b) Base.Map.t - val empty : (string, 'a, Base.String.comparator_witness) Base.Map.t - val find : 'a -> ('a, 'b, 'c) Base.Map.t -> 'b option + type t + + val free_vars : t -> VarSet.t + val extend : t -> string -> scheme -> t + val apply : Substitution.t -> t -> t + val empty : t + val find : string -> t -> scheme option end = struct open Base (* environment (context?) -- pairs of names and their types list *) - (* type t = (ident, scheme, String.comparator_witness) Map.t *) + type t = (string, scheme, String.comparator_witness) Map.t (* if pair (key, some old value) exists in map env, then replace old value with new, else add pair (key, value) into map *) @@ -314,10 +316,10 @@ end = struct let find key env = Map.find env key (* collect all free vars from environment *) - (* let free_vars : t -> VarSet.t = - Map.fold ~init:VarSet.empty ~f:(fun ~key:_ ~data:s acc -> - VarSet.union acc (Scheme.free_vars s)) - ;; *) + let free_vars : t -> VarSet.t = + Map.fold ~init:VarSet.empty ~f:(fun ~key:_ ~data:s acc -> + VarSet.union acc (Scheme.free_vars s)) + ;; (* TODO: custom pp_scheme? not from deriving *) (* let pp fmt map = @@ -336,7 +338,7 @@ let make_fresh_var = fresh >>| fun n -> Type_var n (* replace all type vars with fresh ones *) let instantiate : scheme -> typ R.t = - fun (S (vars, t)) -> + fun (Scheme (vars, t)) -> VarSet.fold (fun name ty -> let* ty = ty in @@ -349,11 +351,11 @@ let instantiate : scheme -> typ R.t = (* take free vars of type t and environment, put difference between them in S constructor so all vars are context independent *) -(* let generalize : TypeEnvironment.t -> Type.t -> Scheme.t = - fun env t -> - let free = VarSet.diff (Type.free_vars t) (TypeEnvironment.free_vars env) in - S (free, t) - ;; *) +let generalize : TypeEnvironment.t -> Type.t -> Scheme.t = + fun env t -> + let free = VarSet.diff (Type.free_vars t) (TypeEnvironment.free_vars env) in + Scheme (free, t) +;; let infer_lt = function | Int_lt _ -> return (Substitution.empty, int_typ) @@ -364,24 +366,24 @@ let infer_lt = function let rec infer_pattern env = function | Wild -> - let* fresh_type = make_fresh_var in - return (fresh_type, env) + let* fresh_var = make_fresh_var in + return (fresh_var, env) | PConst lt -> let* _, t = infer_lt lt in return (t, env) | PVar (Ident (name, _)) -> (* подумать что делать с типом в Ident*) let* fresh = make_fresh_var in - let scheme = S (VarSet.empty, fresh) in + let scheme = Scheme (VarSet.empty, fresh) in let env = TypeEnvironment.extend env name scheme in return (fresh, env) | POption None -> - let* fresh_type = make_fresh_var in - return (fresh_type, env) + let* fresh_var = make_fresh_var in + return (fresh_var, env) | POption (Some p) -> infer_pattern env p | PList [] -> - let* fresh_type = make_fresh_var in - return (Type_list fresh_type, env) + let* fresh_var = make_fresh_var in + return (Type_list fresh_var, env) | PList (hd :: tl) -> let* typ1, env = infer_pattern env hd in let* subst_unify, typ_unified = @@ -453,11 +455,11 @@ let rec infer_expr env = function | Binary_greater | Binary_greater_or_equal | Binary_less | Binary_less_or_equal -> return (int_typ, int_typ, bool_typ) | Binary_equal | Binary_unequal -> - let* fresh_type = make_fresh_var in - return (fresh_type, fresh_type, bool_typ) + let* fresh_var = make_fresh_var in + return (fresh_var, fresh_var, bool_typ) | Binary_cons -> - let* fresh_type = make_fresh_var in - return (fresh_type, Type_list fresh_type, Type_list fresh_type) + let* fresh_var = make_fresh_var in + return (fresh_var, Type_list fresh_var, Type_list fresh_var) in let* subst3 = Substitution.unify (Substitution.apply subst2 typ1) e1typ in (*Format.printf "Checking types: res_typ1 = %a\n" pp_typ (Substitution.apply subst2 typ1); @@ -492,8 +494,8 @@ let rec infer_expr env = function in return (subst_result, Type_tuple (typ1, typ2, typs_rest)) | List [] -> - let* fresh_type = make_fresh_var in - return (Substitution.empty, Type_list fresh_type) + let* fresh_var = make_fresh_var in + return (Substitution.empty, Type_list fresh_var) | List (hd :: tl) -> let* subst1, typ1 = infer_expr env hd in let typ1 = Substitution.apply subst1 typ1 in @@ -529,10 +531,10 @@ let rec infer_expr env = function | Apply (f, arg) -> let* subst1, typ1 = infer_expr env f in let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) arg in - let* fresh_type = make_fresh_var in - let* subst3 = unify (Substitution.apply subst2 typ1) (Arrow (typ2, fresh_type)) in + let* fresh_var = make_fresh_var in + let* subst3 = unify (Substitution.apply subst2 typ1) (Arrow (typ2, fresh_var)) in let* subst_result = Substitution.compose_all [ subst1; subst2; subst3 ] in - return (subst_result, Substitution.apply subst_result fresh_type) + return (subst_result, Substitution.apply subst_result fresh_var) | Lambda (arg, args, e) -> let* env, arg_types = RList.fold_right @@ -544,48 +546,91 @@ let rec infer_expr env = function in let* subst, e_type = infer_expr env e in return (subst, Substitution.apply subst (arrow_of_types arg_types e_type)) - (* | LetIn (Rec, let_bind, let_binds, e) -> - let bind_names = - List.map (let_bind :: let_binds) ~f:(fun let_bind -> - match let_bind with - | Let_bind (Ident (name, _), _, _) -> name) - in - let* env = - List.fold - ~init:(return env) - ~f:(fun acc name -> - let* fresh_type = make_fresh_var in - let* acc = acc in - return (TypeEnvironment.extend acc name (S (VarSet.empty, fresh_type)))) - bind_names - in - x *) + | LetIn (Rec, let_bind, let_binds, e) -> + let bind_names = + List.map (let_bind :: let_binds) ~f:(function Let_bind (Ident (name, _), _, _) -> + name) + in + let fresh_vars = + List.init (List.length (let_bind :: let_binds)) ~f:(fun _ -> make_fresh_var) + in + let* env = + List.fold2_exn + ~init:(return env) + ~f:(fun acc bind_name fresh_var -> + let* fresh_var = fresh_var in + let* acc = acc in + return (TypeEnvironment.extend acc bind_name (Scheme (VarSet.empty, fresh_var)))) + bind_names + fresh_vars + in + let* env, subst1 = + List.fold + (let_bind :: let_binds) + ~init:(return (env, Substitution.empty)) + ~f:(fun acc let_bind -> + let* env, subst_acc = acc in + let* subst, bind_varname, scheme = infer_let_bind env let_bind in + let env = TypeEnvironment.extend env bind_varname scheme in + let env = TypeEnvironment.apply subst env in + let* subst_acc = Substitution.compose subst_acc subst in + return (env, subst_acc)) + in + let* subst2, typ = infer_expr env e in + let* subst_final = Substitution.compose subst1 subst2 in + return (subst_final, typ) + | LetIn (Nonrec, let_bind, let_binds, e) -> + let* env, subst1 = + List.fold + (let_bind :: let_binds) + ~init:(return (env, Substitution.empty)) + ~f:(fun acc let_bind -> + let* env, subst_acc = acc in + let* subst, bind_varname, scheme = infer_let_bind env let_bind in + let env = TypeEnvironment.extend env bind_varname scheme in + let env = TypeEnvironment.apply subst env in + let* subst_acc = Substitution.compose subst_acc subst in + return (env, subst_acc)) + in + let* subst2, typ = infer_expr env e in + let* subst_final = Substitution.compose subst1 subst2 in + return (subst_final, typ) | _ -> fail (`WIP "Expr inference WIP") -;; -(* and infer_let_bind env fresh_type = function - | Let_bind (_, args, e) -> - let arg_names = - List.map args ~f:(fun arg -> - match arg with - | Ident (name, _) -> name) - in - let* env = - List.fold - ~init:(return env) - ~f:(fun acc arg -> - let* fresh_type = make_fresh_var in - let* acc = acc in - return (TypeEnvironment.extend acc arg (S (VarSet.empty, fresh_type)))) - arg_names - in - let* subst1, typ1 = infer_expr env e in - let* subst2 = unify (Substitution.apply subst1 fresh_type) typ1 in - let* subst = Substitution.compose subst1 subst2 in - let env = TypeEnvironment.apply subst env in - let typ2 = generalize env (Substitution.apply subst fresh_type) in - return (subst, typ2) - ;; *) +and infer_let_bind env = function + | Let_bind (Ident (bind_varname, _), args, e) -> + let fresh_vars = List.init (List.length args) ~f:(fun _ -> make_fresh_var) in + let arg_names = + List.map args ~f:(fun arg -> + match arg with + | Ident (name, _) -> name) + in + let* env = + List.fold2_exn + ~init:(return env) + ~f:(fun acc arg fresh_var -> + let* acc = acc in + let* fresh_var = fresh_var in + return (TypeEnvironment.extend acc arg (Scheme (VarSet.empty, fresh_var)))) + arg_names + fresh_vars + in + let* subst1, typ1 = infer_expr env e in + (* If let_bind is recursive, then bind_varname was already in environment *) + let* bind_typevar = + match TypeEnvironment.find bind_varname env with + | Some (Scheme (_, bind_typevar)) -> return bind_typevar + | None -> make_fresh_var + in + let env = + TypeEnvironment.extend env bind_varname (Scheme (VarSet.empty, bind_typevar)) + in + let* subst2 = unify (Substitution.apply subst1 bind_typevar) typ1 in + let* subst = Substitution.compose subst1 subst2 in + let env = TypeEnvironment.apply subst env in + let bind_var_scheme = generalize env (Substitution.apply subst bind_typevar) in + return (subst, bind_varname, bind_var_scheme) +;; let infer_construction env = function | Expr exp -> diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index 54ff2528f..26ab398a2 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -13,9 +13,9 @@ type typ = | TOption of typ [@@deriving show { with_path = false }] -let arrow_of_types first_types last = +let arrow_of_types first_types last_type = let open Base in - List.fold_right first_types ~init:last ~f:(fun left right -> Arrow (left, right)) + List.fold_right first_types ~init:last_type ~f:(fun left right -> Arrow (left, right)) ;; module VarSet = struct @@ -31,7 +31,7 @@ end type binder_set = VarSet.t [@@deriving show { with_path = false }] (* binder_set here -- list of all type vars in context (?) *) -type scheme = S of binder_set * typ [@@deriving show { with_path = false }] +type scheme = Scheme of binder_set * typ [@@deriving show { with_path = false }] let int_typ = Primitive "int" let bool_typ = Primitive "bool" diff --git a/FSharpActivePatterns/lib/typedTree.mli b/FSharpActivePatterns/lib/typedTree.mli index 09c2ff54a..d8f8667a1 100644 --- a/FSharpActivePatterns/lib/typedTree.mli +++ b/FSharpActivePatterns/lib/typedTree.mli @@ -21,7 +21,7 @@ module VarSet : sig end type binder_set = VarSet.t -type scheme = S of binder_set * typ [@@deriving show { with_path = false }] +type scheme = Scheme of binder_set * typ [@@deriving show { with_path = false }] val int_typ : typ val bool_typ : typ diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index 8e18b1ef4..59207a761 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -9,7 +9,10 @@ let pp_typ fmt typ = let rec helper fmt = function | Primitive s -> fprintf fmt "%S" s | Type_var var -> fprintf fmt "'_%d" var - | Arrow (fst, snd) -> fprintf fmt "(%a) -> %a" helper fst helper snd + | Arrow (fst, snd) -> + (match fst with + | Arrow _ -> fprintf fmt "(%a) -> %a" helper fst helper snd + | _ -> fprintf fmt "%a -> %a" helper fst helper snd) | Type_list typ -> fprintf fmt "%a list" helper typ | Type_tuple (first, second, rest) -> fprintf fmt "("; From 96cd905b90be9182c2d88a116e1ab8662ef58170 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 15 Dec 2024 16:09:13 +0300 Subject: [PATCH 240/310] ref: move duplicated code to functions Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 70 +++++++++++--------------- 1 file changed, 29 insertions(+), 41 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index d5c24714c..b2ef31783 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -547,56 +547,44 @@ let rec infer_expr env = function let* subst, e_type = infer_expr env e in return (subst, Substitution.apply subst (arrow_of_types arg_types e_type)) | LetIn (Rec, let_bind, let_binds, e) -> - let bind_names = - List.map (let_bind :: let_binds) ~f:(function Let_bind (Ident (name, _), _, _) -> - name) - in - let fresh_vars = - List.init (List.length (let_bind :: let_binds)) ~f:(fun _ -> make_fresh_var) - in - let* env = - List.fold2_exn - ~init:(return env) - ~f:(fun acc bind_name fresh_var -> - let* fresh_var = fresh_var in - let* acc = acc in - return (TypeEnvironment.extend acc bind_name (Scheme (VarSet.empty, fresh_var)))) - bind_names - fresh_vars - in - let* env, subst1 = - List.fold - (let_bind :: let_binds) - ~init:(return (env, Substitution.empty)) - ~f:(fun acc let_bind -> - let* env, subst_acc = acc in - let* subst, bind_varname, scheme = infer_let_bind env let_bind in - let env = TypeEnvironment.extend env bind_varname scheme in - let env = TypeEnvironment.apply subst env in - let* subst_acc = Substitution.compose subst_acc subst in - return (env, subst_acc)) - in + let* env = extend_env_with_bind_names env (let_bind :: let_binds) in + let* env, subst1 = extend_env_with_let_binds env (let_bind :: let_binds) in let* subst2, typ = infer_expr env e in let* subst_final = Substitution.compose subst1 subst2 in return (subst_final, typ) | LetIn (Nonrec, let_bind, let_binds, e) -> - let* env, subst1 = - List.fold - (let_bind :: let_binds) - ~init:(return (env, Substitution.empty)) - ~f:(fun acc let_bind -> - let* env, subst_acc = acc in - let* subst, bind_varname, scheme = infer_let_bind env let_bind in - let env = TypeEnvironment.extend env bind_varname scheme in - let env = TypeEnvironment.apply subst env in - let* subst_acc = Substitution.compose subst_acc subst in - return (env, subst_acc)) - in + let* env, subst1 = extend_env_with_let_binds env (let_bind :: let_binds) in let* subst2, typ = infer_expr env e in let* subst_final = Substitution.compose subst1 subst2 in return (subst_final, typ) | _ -> fail (`WIP "Expr inference WIP") +and extend_env_with_let_binds env let_binds = + List.fold + let_binds + ~init:(return (env, Substitution.empty)) + ~f:(fun acc let_bind -> + let* env, subst_acc = acc in + let* subst, bind_varname, scheme = infer_let_bind env let_bind in + let env = TypeEnvironment.extend env bind_varname scheme in + let env = TypeEnvironment.apply subst env in + let* subst_acc = Substitution.compose subst_acc subst in + return (env, subst_acc)) + +and extend_env_with_bind_names env let_binds = + let bind_names = + List.map let_binds ~f:(function Let_bind (Ident (name, _), _, _) -> name) + in + let fresh_vars = List.init (List.length let_binds) ~f:(fun _ -> make_fresh_var) in + List.fold2_exn + ~init:(return env) + ~f:(fun acc bind_name fresh_var -> + let* fresh_var = fresh_var in + let* acc = acc in + return (TypeEnvironment.extend acc bind_name (Scheme (VarSet.empty, fresh_var)))) + bind_names + fresh_vars + and infer_let_bind env = function | Let_bind (Ident (bind_varname, _), args, e) -> let fresh_vars = List.init (List.length args) ~f:(fun _ -> make_fresh_var) in From 87feba28165f1e6aa1e38acebc08661b5f4b6403 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 15 Dec 2024 17:42:51 +0300 Subject: [PATCH 241/310] ref: move function from mutual recursion definition Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 29 +++++++++++++------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index b2ef31783..68898efef 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -420,6 +420,21 @@ let rec infer_pattern env = function return (Type_tuple (typ1, typ2, typs_rest), env) ;; +let extend_env_with_bind_names env let_binds = + let bind_names = + List.map let_binds ~f:(function Let_bind (Ident (name, _), _, _) -> name) + in + let fresh_vars = List.init (List.length let_binds) ~f:(fun _ -> make_fresh_var) in + List.fold2_exn + ~init:(return env) + ~f:(fun acc bind_name fresh_var -> + let* fresh_var = fresh_var in + let* acc = acc in + return (TypeEnvironment.extend acc bind_name (Scheme (VarSet.empty, fresh_var)))) + bind_names + fresh_vars +;; + let rec infer_expr env = function | Const lt -> infer_lt lt | Variable (Ident (varname, _)) -> @@ -571,20 +586,6 @@ and extend_env_with_let_binds env let_binds = let* subst_acc = Substitution.compose subst_acc subst in return (env, subst_acc)) -and extend_env_with_bind_names env let_binds = - let bind_names = - List.map let_binds ~f:(function Let_bind (Ident (name, _), _, _) -> name) - in - let fresh_vars = List.init (List.length let_binds) ~f:(fun _ -> make_fresh_var) in - List.fold2_exn - ~init:(return env) - ~f:(fun acc bind_name fresh_var -> - let* fresh_var = fresh_var in - let* acc = acc in - return (TypeEnvironment.extend acc bind_name (Scheme (VarSet.empty, fresh_var)))) - bind_names - fresh_vars - and infer_let_bind env = function | Let_bind (Ident (bind_varname, _), args, e) -> let fresh_vars = List.init (List.length args) ~f:(fun _ -> make_fresh_var) in From 283f3cb610fe2f74ec74772e53bac24de6574688 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 15 Dec 2024 18:04:03 +0300 Subject: [PATCH 242/310] fix: Let bind inference with arguments Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 68898efef..9382b314e 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -588,7 +588,13 @@ and extend_env_with_let_binds env let_binds = and infer_let_bind env = function | Let_bind (Ident (bind_varname, _), args, e) -> - let fresh_vars = List.init (List.length args) ~f:(fun _ -> make_fresh_var) in + let* fresh_vars = + (* Hack for get typ list, not typ t list*) + List.fold args ~init:(return []) ~f:(fun acc _ -> + let* fresh_var = make_fresh_var in + let* acc = acc in + return (fresh_var :: acc)) + in let arg_names = List.map args ~f:(fun arg -> match arg with @@ -599,7 +605,6 @@ and infer_let_bind env = function ~init:(return env) ~f:(fun acc arg fresh_var -> let* acc = acc in - let* fresh_var = fresh_var in return (TypeEnvironment.extend acc arg (Scheme (VarSet.empty, fresh_var)))) arg_names fresh_vars @@ -611,13 +616,14 @@ and infer_let_bind env = function | Some (Scheme (_, bind_typevar)) -> return bind_typevar | None -> make_fresh_var in + let bind_type = arrow_of_types fresh_vars bind_typevar in let env = - TypeEnvironment.extend env bind_varname (Scheme (VarSet.empty, bind_typevar)) + TypeEnvironment.extend env bind_varname (Scheme (VarSet.empty, bind_type)) in let* subst2 = unify (Substitution.apply subst1 bind_typevar) typ1 in let* subst = Substitution.compose subst1 subst2 in let env = TypeEnvironment.apply subst env in - let bind_var_scheme = generalize env (Substitution.apply subst bind_typevar) in + let bind_var_scheme = generalize env (Substitution.apply subst bind_type) in return (subst, bind_varname, bind_var_scheme) ;; From 3ee7bcb05c662401d6c8f1f37a65f2326ec3f950 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 15 Dec 2024 18:44:20 +0300 Subject: [PATCH 243/310] feat: implement Let statements inference, REPL with TypeEnvironment Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 24 +++++++----- FSharpActivePatterns/lib/inferencer.ml | 49 ++++++++++++++++++++----- FSharpActivePatterns/lib/inferencer.mli | 12 +++++- 3 files changed, 64 insertions(+), 21 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 89e6e8c23..1be28108d 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -61,31 +61,35 @@ let run_repl dump_parsetree input_file = | None -> stdin | Some n -> open_in n in - let rec run_repl_helper run = + let rec run_repl_helper run env = let open Format in match run ic with | Fail -> fprintf err_formatter "Error occured\n" | Empty -> fprintf std_formatter "\n"; print_flush (); - run_repl_helper run + run_repl_helper run env | End -> () | Result ast -> - let result = infer ast in + let result = infer ast env in (match result with | Error err -> fprintf err_formatter "Type checking failed: %a\n" pp_error err; - print_flush () - | Ok t -> + print_flush (); + run_repl_helper run env + | Ok (env, types) -> (match dump_parsetree with | true -> print_construction std_formatter ast | false -> - fprintf std_formatter "- : "; - pp_typ std_formatter t); - print_flush ()); - run_repl_helper run + List.iter + (fun t -> + fprintf std_formatter "- : "; + pp_typ std_formatter t) + types; + print_flush ()); + run_repl_helper run env) in - run_repl_helper run_single + run_repl_helper run_single TypeEnvironment.empty ;; type opts = diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 9382b314e..3e5fab246 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -297,7 +297,8 @@ module TypeEnvironment : sig val extend : t -> string -> scheme -> t val apply : Substitution.t -> t -> t val empty : t - val find : string -> t -> scheme option + val find : t -> string -> scheme option + val find_exn : t -> string -> scheme end = struct open Base @@ -313,7 +314,8 @@ end = struct (* apply given substitution to all elements of environment *) let apply subst env = Map.map env ~f:(Scheme.apply subst) - let find key env = Map.find env key + let find = Map.find + let find_exn = Map.find_exn (* collect all free vars from environment *) let free_vars : t -> VarSet.t = @@ -420,10 +422,12 @@ let rec infer_pattern env = function return (Type_tuple (typ1, typ2, typs_rest), env) ;; +let extract_names_from_let_binds let_binds = + List.map let_binds ~f:(function Let_bind (Ident (name, _), _, _) -> name) +;; + let extend_env_with_bind_names env let_binds = - let bind_names = - List.map let_binds ~f:(function Let_bind (Ident (name, _), _, _) -> name) - in + let bind_names = extract_names_from_let_binds let_binds in let fresh_vars = List.init (List.length let_binds) ~f:(fun _ -> make_fresh_var) in List.fold2_exn ~init:(return env) @@ -439,7 +443,7 @@ let rec infer_expr env = function | Const lt -> infer_lt lt | Variable (Ident (varname, _)) -> (* подумать что делать с типом Ident*) - (match TypeEnvironment.find varname env with + (match TypeEnvironment.find env varname with | Some s -> let* t = instantiate s in return (Substitution.empty, t) @@ -612,7 +616,7 @@ and infer_let_bind env = function let* subst1, typ1 = infer_expr env e in (* If let_bind is recursive, then bind_varname was already in environment *) let* bind_typevar = - match TypeEnvironment.find bind_varname env with + match TypeEnvironment.find env bind_varname with | Some (Scheme (_, bind_typevar)) -> return bind_typevar | None -> make_fresh_var in @@ -627,11 +631,36 @@ and infer_let_bind env = function return (subst, bind_varname, bind_var_scheme) ;; +let infer_statement env = function + | Let (Rec, let_bind, let_binds) -> + let* env = extend_env_with_bind_names env (let_bind :: let_binds) in + let* env, _ = extend_env_with_let_binds env (let_bind :: let_binds) in + let bind_names = extract_names_from_let_binds let_binds in + let bind_types = + List.map bind_names ~f:(fun name -> + match TypeEnvironment.find_exn env name with + | Scheme (_, typ) -> typ) + in + return (env, bind_types) + | Let (Nonrec, let_bind, let_binds) -> + let let_binds = let_bind :: let_binds in + let* env, _ = extend_env_with_let_binds env let_binds in + let bind_names = extract_names_from_let_binds let_binds in + let bind_types = + List.map bind_names ~f:(fun name -> + match TypeEnvironment.find_exn env name with + | Scheme (_, typ) -> typ) + in + return (env, bind_types) +;; + let infer_construction env = function | Expr exp -> let* _, typ = infer_expr env exp in - return typ - | _ -> fail (`WIP "Statement inference WIP") + return (env, [ typ ]) + | Statement s -> + let* env, types = infer_statement env s in + return (env, types) ;; -let infer c = run (infer_construction TypeEnvironment.empty c) +let infer c env = run (infer_construction env c) diff --git a/FSharpActivePatterns/lib/inferencer.mli b/FSharpActivePatterns/lib/inferencer.mli index 04854645b..3c7b36f36 100644 --- a/FSharpActivePatterns/lib/inferencer.mli +++ b/FSharpActivePatterns/lib/inferencer.mli @@ -6,6 +6,12 @@ open Ast open TypedTree open Format +module TypeEnvironment : sig + type t + + val empty : t +end + type error = [ `Occurs_check | `Undef_var of string @@ -14,4 +20,8 @@ type error = ] val pp_error : formatter -> error -> unit -val infer : construction -> (typ, error) result + +val infer + : construction + -> TypeEnvironment.t + -> (TypeEnvironment.t * typ list, error) result From 8d3d4c05d50abc7f0dbb6a7479ecade3e292c669 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 15 Dec 2024 18:47:42 +0300 Subject: [PATCH 244/310] ref: remove old comments Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 3e5fab246..c21cb51f1 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -481,8 +481,6 @@ let rec infer_expr env = function return (fresh_var, Type_list fresh_var, Type_list fresh_var) in let* subst3 = Substitution.unify (Substitution.apply subst2 typ1) e1typ in - (*Format.printf "Checking types: res_typ1 = %a\n" pp_typ (Substitution.apply subst2 typ1); - Format.printf "Checking types: res_typ2 = %a\n" pp_typ (Substitution.apply subst3 typ2);*) let* subst4 = Substitution.unify (Substitution.apply subst3 typ2) e2typ in let* subst_res = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in return (subst_res, Substitution.apply subst_res etyp) From a2325adeabce8f06517ff114d2a5239973d118c0 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sun, 15 Dec 2024 19:39:20 +0300 Subject: [PATCH 245/310] fix: inference of Let with shadowing Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 28 ++++++++++++++++---------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index c21cb51f1..cf4b0c9a7 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -299,6 +299,7 @@ module TypeEnvironment : sig val empty : t val find : t -> string -> scheme option val find_exn : t -> string -> scheme + val find_typ_exn : t -> string -> typ end = struct open Base @@ -317,6 +318,11 @@ end = struct let find = Map.find let find_exn = Map.find_exn + let find_typ_exn env key = + match find_exn env key with + | Scheme (_, typ) -> typ + ;; + (* collect all free vars from environment *) let free_vars : t -> VarSet.t = Map.fold ~init:VarSet.empty ~f:(fun ~key:_ ~data:s acc -> @@ -565,30 +571,30 @@ let rec infer_expr env = function return (subst, Substitution.apply subst (arrow_of_types arg_types e_type)) | LetIn (Rec, let_bind, let_binds, e) -> let* env = extend_env_with_bind_names env (let_bind :: let_binds) in - let* env, subst1 = extend_env_with_let_binds env (let_bind :: let_binds) in + let* env, subst1 = extend_env_with_let_binds env Rec (let_bind :: let_binds) in let* subst2, typ = infer_expr env e in let* subst_final = Substitution.compose subst1 subst2 in return (subst_final, typ) | LetIn (Nonrec, let_bind, let_binds, e) -> - let* env, subst1 = extend_env_with_let_binds env (let_bind :: let_binds) in + let* env, subst1 = extend_env_with_let_binds env Nonrec (let_bind :: let_binds) in let* subst2, typ = infer_expr env e in let* subst_final = Substitution.compose subst1 subst2 in return (subst_final, typ) | _ -> fail (`WIP "Expr inference WIP") -and extend_env_with_let_binds env let_binds = +and extend_env_with_let_binds env is_rec let_binds = List.fold let_binds ~init:(return (env, Substitution.empty)) ~f:(fun acc let_bind -> let* env, subst_acc = acc in - let* subst, bind_varname, scheme = infer_let_bind env let_bind in + let* subst, bind_varname, scheme = infer_let_bind env is_rec let_bind in let env = TypeEnvironment.extend env bind_varname scheme in let env = TypeEnvironment.apply subst env in let* subst_acc = Substitution.compose subst_acc subst in return (env, subst_acc)) -and infer_let_bind env = function +and infer_let_bind env is_rec = function | Let_bind (Ident (bind_varname, _), args, e) -> let* fresh_vars = (* Hack for get typ list, not typ t list*) @@ -612,11 +618,11 @@ and infer_let_bind env = function fresh_vars in let* subst1, typ1 = infer_expr env e in - (* If let_bind is recursive, then bind_varname was already in environment *) + (* If let_bind is recursive, then bind_varname is already in environment *) let* bind_typevar = - match TypeEnvironment.find env bind_varname with - | Some (Scheme (_, bind_typevar)) -> return bind_typevar - | None -> make_fresh_var + match is_rec with + | Rec -> return (TypeEnvironment.find_typ_exn env bind_varname) + | Nonrec -> make_fresh_var in let bind_type = arrow_of_types fresh_vars bind_typevar in let env = @@ -632,7 +638,7 @@ and infer_let_bind env = function let infer_statement env = function | Let (Rec, let_bind, let_binds) -> let* env = extend_env_with_bind_names env (let_bind :: let_binds) in - let* env, _ = extend_env_with_let_binds env (let_bind :: let_binds) in + let* env, _ = extend_env_with_let_binds env Rec (let_bind :: let_binds) in let bind_names = extract_names_from_let_binds let_binds in let bind_types = List.map bind_names ~f:(fun name -> @@ -642,7 +648,7 @@ let infer_statement env = function return (env, bind_types) | Let (Nonrec, let_bind, let_binds) -> let let_binds = let_bind :: let_binds in - let* env, _ = extend_env_with_let_binds env let_binds in + let* env, _ = extend_env_with_let_binds env Nonrec let_binds in let bind_names = extract_names_from_let_binds let_binds in let bind_types = List.map bind_names ~f:(fun name -> From 41d269bc9851d57781eb3f21e8426cd12fb6a3f0 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 16 Dec 2024 12:43:20 +0300 Subject: [PATCH 246/310] fix: recursive generalize Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 59 +++++++++++++++----------- 1 file changed, 34 insertions(+), 25 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index cf4b0c9a7..ba8a27f83 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -300,6 +300,7 @@ module TypeEnvironment : sig val find : t -> string -> scheme option val find_exn : t -> string -> scheme val find_typ_exn : t -> string -> typ + val remove : t -> string -> t end = struct open Base @@ -309,8 +310,7 @@ end = struct (* if pair (key, some old value) exists in map env, then replace old value with new, else add pair (key, value) into map *) let extend env key value = Map.update env key ~f:(fun _ -> value) - - (* let remove env key = Map.remove env key *) + let remove env key = Map.remove env key let empty = Map.empty (module String) (* apply given substitution to all elements of environment *) @@ -348,21 +348,26 @@ let make_fresh_var = fresh >>| fun n -> Type_var n let instantiate : scheme -> typ R.t = fun (Scheme (vars, t)) -> VarSet.fold - (fun name ty -> - let* ty = ty in + (fun name typ -> + let* typ = typ in let* fr_var = make_fresh_var in let* subst = Substitution.singleton name fr_var in - return (Substitution.apply subst ty)) + return (Substitution.apply subst typ)) vars (return t) ;; (* take free vars of type t and environment, put difference between them in S constructor so all vars are context independent *) -let generalize : TypeEnvironment.t -> Type.t -> Scheme.t = - fun env t -> - let free = VarSet.diff (Type.free_vars t) (TypeEnvironment.free_vars env) in - Scheme (free, t) +let generalize env typ = + let free = VarSet.diff (Type.free_vars typ) (TypeEnvironment.free_vars env) in + Scheme (free, typ) +;; + +let generalize_rec env typ rec_name = + let env = TypeEnvironment.remove env rec_name in + let free = VarSet.diff (Type.free_vars typ) (TypeEnvironment.free_vars env) in + Scheme (free, typ) ;; let infer_lt = function @@ -510,11 +515,6 @@ let rec infer_expr env = function ~init:(return (Substitution.empty, [])) in let* subst_result = Substitution.compose_all [ subst1; subst2; subst_rest ] in - let typ1 = Substitution.apply subst_result typ1 in - let typ2 = Substitution.apply subst_result typ2 in - let typs_rest = - List.map typs_rest ~f:(fun typ -> Substitution.apply subst_result typ) - in return (subst_result, Type_tuple (typ1, typ2, typs_rest)) | List [] -> let* fresh_var = make_fresh_var in @@ -555,9 +555,10 @@ let rec infer_expr env = function let* subst1, typ1 = infer_expr env f in let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) arg in let* fresh_var = make_fresh_var in - let* subst3 = unify (Substitution.apply subst2 typ1) (Arrow (typ2, fresh_var)) in + let typ1 = Substitution.apply subst2 typ1 in + let* subst3 = unify typ1 (Arrow (typ2, fresh_var)) in let* subst_result = Substitution.compose_all [ subst1; subst2; subst3 ] in - return (subst_result, Substitution.apply subst_result fresh_var) + return (subst_result, Substitution.apply subst3 fresh_var) | Lambda (arg, args, e) -> let* env, arg_types = RList.fold_right @@ -570,8 +571,9 @@ let rec infer_expr env = function let* subst, e_type = infer_expr env e in return (subst, Substitution.apply subst (arrow_of_types arg_types e_type)) | LetIn (Rec, let_bind, let_binds, e) -> - let* env = extend_env_with_bind_names env (let_bind :: let_binds) in - let* env, subst1 = extend_env_with_let_binds env Rec (let_bind :: let_binds) in + let let_binds = let_bind :: let_binds in + let* env = extend_env_with_bind_names env let_binds in + let* env, subst1 = extend_env_with_let_binds env Rec let_binds in let* subst2, typ = infer_expr env e in let* subst_final = Substitution.compose subst1 subst2 in return (subst_final, typ) @@ -608,7 +610,7 @@ and infer_let_bind env is_rec = function match arg with | Ident (name, _) -> name) in - let* env = + let* env_with_args = List.fold2_exn ~init:(return env) ~f:(fun acc arg fresh_var -> @@ -617,21 +619,28 @@ and infer_let_bind env is_rec = function arg_names fresh_vars in - let* subst1, typ1 = infer_expr env e in - (* If let_bind is recursive, then bind_varname is already in environment *) + let* subst1, typ1 = infer_expr env_with_args e in + let bind_type = arrow_of_types fresh_vars typ1 in + (* If let_bind is recursive, then bind_varname was already in environment *) let* bind_typevar = match is_rec with | Rec -> return (TypeEnvironment.find_typ_exn env bind_varname) | Nonrec -> make_fresh_var in - let bind_type = arrow_of_types fresh_vars bind_typevar in let env = - TypeEnvironment.extend env bind_varname (Scheme (VarSet.empty, bind_type)) + match is_rec with + | Rec -> TypeEnvironment.extend env bind_varname (Scheme (VarSet.empty, bind_type)) + | Nonrec -> env in - let* subst2 = unify (Substitution.apply subst1 bind_typevar) typ1 in + let* subst2 = unify (Substitution.apply subst1 bind_typevar) bind_type in let* subst = Substitution.compose subst1 subst2 in let env = TypeEnvironment.apply subst env in - let bind_var_scheme = generalize env (Substitution.apply subst bind_type) in + let bind_type = Substitution.apply subst bind_type in + let bind_var_scheme = + match is_rec with + | Rec -> generalize_rec env bind_type bind_varname + | Nonrec -> generalize env bind_type + in return (subst, bind_varname, bind_var_scheme) ;; From c98aed773f06a2f37e95c0dca89e39134acc7d83 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 16 Dec 2024 13:43:15 +0300 Subject: [PATCH 247/310] fix: REPL now runs with new state Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 16 ++++++++-------- FSharpActivePatterns/lib/inferencer.ml | 6 +++--- FSharpActivePatterns/lib/inferencer.mli | 3 ++- 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 1be28108d..f8ebe5386 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -61,23 +61,23 @@ let run_repl dump_parsetree input_file = | None -> stdin | Some n -> open_in n in - let rec run_repl_helper run env = + let rec run_repl_helper run env state = let open Format in match run ic with | Fail -> fprintf err_formatter "Error occured\n" | Empty -> fprintf std_formatter "\n"; print_flush (); - run_repl_helper run env + run_repl_helper run env state | End -> () | Result ast -> - let result = infer ast env in + let result = infer ast env state in (match result with - | Error err -> + | new_state, Error err -> fprintf err_formatter "Type checking failed: %a\n" pp_error err; print_flush (); - run_repl_helper run env - | Ok (env, types) -> + run_repl_helper run env new_state + | new_state, Ok (env, types) -> (match dump_parsetree with | true -> print_construction std_formatter ast | false -> @@ -87,9 +87,9 @@ let run_repl dump_parsetree input_file = pp_typ std_formatter t) types; print_flush ()); - run_repl_helper run env) + run_repl_helper run env new_state) in - run_repl_helper run_single TypeEnvironment.empty + run_repl_helper run_single TypeEnvironment.empty 0 ;; type opts = diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index ba8a27f83..bafd5b1bd 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -44,7 +44,7 @@ module R : sig end val fresh : int t - val run : 'a t -> ('a, error) Result.t + val run : 'a t -> int -> int * ('a, error) Result.t module RMap : sig val fold : ('a, 'b, 'c) Map.t -> init:'d t -> f:('a -> 'b -> 'd -> 'd t) -> 'd t @@ -112,7 +112,7 @@ end = struct (* takes current state, returns state + 1 *) let fresh : int t = fun last -> last + 1, Result.Ok last - let run m = snd (m 0) + let run m state = m state end type fresh = int @@ -676,4 +676,4 @@ let infer_construction env = function return (env, types) ;; -let infer c env = run (infer_construction env c) +let infer c env state = run (infer_construction env c) state diff --git a/FSharpActivePatterns/lib/inferencer.mli b/FSharpActivePatterns/lib/inferencer.mli index 3c7b36f36..3ac24e5bf 100644 --- a/FSharpActivePatterns/lib/inferencer.mli +++ b/FSharpActivePatterns/lib/inferencer.mli @@ -24,4 +24,5 @@ val pp_error : formatter -> error -> unit val infer : construction -> TypeEnvironment.t - -> (TypeEnvironment.t * typ list, error) result + -> int + -> int * (TypeEnvironment.t * typ list, error) result From 82af8ddbd4b373c5a9e2b8319babb4c5f000de94 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 16 Dec 2024 14:09:59 +0300 Subject: [PATCH 248/310] fix: extend env in let rec Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index bafd5b1bd..a012b12f5 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -646,8 +646,9 @@ and infer_let_bind env is_rec = function let infer_statement env = function | Let (Rec, let_bind, let_binds) -> - let* env = extend_env_with_bind_names env (let_bind :: let_binds) in - let* env, _ = extend_env_with_let_binds env Rec (let_bind :: let_binds) in + let let_binds = let_bind :: let_binds in + let* env = extend_env_with_bind_names env let_binds in + let* env, _ = extend_env_with_let_binds env Rec let_binds in let bind_names = extract_names_from_let_binds let_binds in let bind_types = List.map bind_names ~f:(fun name -> From 42cd94919ab8c2221f9de6312d50c0cea7292ee0 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 16 Dec 2024 16:17:08 +0300 Subject: [PATCH 249/310] fix: apply parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index a85b8706a..35740d110 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -242,7 +242,7 @@ let p_let p_expr = return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) ;; -let p_apply p_expr = chainl1 p_expr (return (fun expr1 expr2 -> Apply (expr1, expr2))) +let p_apply p_expr = chainl1 (p_expr <* peek_sep1) (return (fun expr1 expr2 -> Apply (expr1, expr2))) let p_option p make_option = skip_ws *> string "None" *> peek_sep1 *> return (make_option None) From c685d44673495fc1e05fe22a81c1989547c0ccaa Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 16 Dec 2024 17:04:19 +0300 Subject: [PATCH 250/310] feat: implement match inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index a012b12f5..ee1419735 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -582,7 +582,25 @@ let rec infer_expr env = function let* subst2, typ = infer_expr env e in let* subst_final = Substitution.compose subst1 subst2 in return (subst_final, typ) - | _ -> fail (`WIP "Expr inference WIP") + | Match (e, p1, e1, rest) -> + let* subst_init, match_type = infer_expr env e in + let env = TypeEnvironment.apply subst_init env in + let* fresh_typevar = make_fresh_var in + let* subst, typ = + List.fold + ((p1, e1) :: rest) + ~init:(return (subst_init, fresh_typevar)) + ~f:(fun acc (pat, expr) -> + let* subst1, return_type = acc in + let* pat, env = infer_pattern env pat in + let* subst2 = unify match_type pat in + let env = TypeEnvironment.apply subst2 env in + let* subst3, expr_typ = infer_expr env expr in + let* subst4 = unify return_type expr_typ in + let* subst = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in + return (subst, Substitution.apply subst return_type)) + in + return (subst, typ) and extend_env_with_let_binds env is_rec let_binds = List.fold From d7f8d4a3fefd6bba8397382302f3ee99057d20a7 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 16 Dec 2024 17:21:46 +0300 Subject: [PATCH 251/310] fix: let bind inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index ee1419735..631cdda6a 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -638,7 +638,7 @@ and infer_let_bind env is_rec = function fresh_vars in let* subst1, typ1 = infer_expr env_with_args e in - let bind_type = arrow_of_types fresh_vars typ1 in + let bind_type = Substitution.apply subst1 (arrow_of_types fresh_vars typ1) in (* If let_bind is recursive, then bind_varname was already in environment *) let* bind_typevar = match is_rec with From 1d8c2bba9f564c62292ae9eee29de9f8b934c953 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 16 Dec 2024 17:49:58 +0300 Subject: [PATCH 252/310] ref: lint and fmt Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 6 +----- FSharpActivePatterns/lib/parser.ml | 4 +++- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 631cdda6a..80f89e2b3 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -623,11 +623,7 @@ and infer_let_bind env is_rec = function let* acc = acc in return (fresh_var :: acc)) in - let arg_names = - List.map args ~f:(fun arg -> - match arg with - | Ident (name, _) -> name) - in + let arg_names = List.map args ~f:(function Ident (name, _) -> name) in let* env_with_args = List.fold2_exn ~init:(return env) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 35740d110..6b7a84491 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -242,7 +242,9 @@ let p_let p_expr = return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) ;; -let p_apply p_expr = chainl1 (p_expr <* peek_sep1) (return (fun expr1 expr2 -> Apply (expr1, expr2))) +let p_apply p_expr = + chainl1 (p_expr <* peek_sep1) (return (fun expr1 expr2 -> Apply (expr1, expr2))) +;; let p_option p make_option = skip_ws *> string "None" *> peek_sep1 *> return (make_option None) From dfd1cd6c740d7e7f09c7c929009e617cb43a1be8 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Mon, 16 Dec 2024 18:11:06 +0300 Subject: [PATCH 253/310] ref: eta reduction Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 80f89e2b3..f1f98cbe1 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -112,7 +112,7 @@ end = struct (* takes current state, returns state + 1 *) let fresh : int t = fun last -> last + 1, Result.Ok last - let run m state = m state + let run m = m end type fresh = int @@ -310,7 +310,7 @@ end = struct (* if pair (key, some old value) exists in map env, then replace old value with new, else add pair (key, value) into map *) let extend env key value = Map.update env key ~f:(fun _ -> value) - let remove env key = Map.remove env key + let remove = Map.remove let empty = Map.empty (module String) (* apply given substitution to all elements of environment *) From 8d4654fa5556aad3a32eb8fdd0dbd1f4449fd6cb Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 17 Dec 2024 16:51:05 +0300 Subject: [PATCH 254/310] fix: let binds like 'let rec x = x + 1' Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index f1f98cbe1..783338e8c 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -616,6 +616,12 @@ and extend_env_with_let_binds env is_rec let_binds = and infer_let_bind env is_rec = function | Let_bind (Ident (bind_varname, _), args, e) -> + (* to avoid binds like let rec x = x + 1 *) + let env = + match List.length args with + | 0 -> TypeEnvironment.remove env bind_varname + | _ -> env + in let* fresh_vars = (* Hack for get typ list, not typ t list*) List.fold args ~init:(return []) ~f:(fun acc _ -> From 64c8d614668254b343583c0daba4e332f9962901 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Tue, 17 Dec 2024 21:58:07 +0300 Subject: [PATCH 255/310] feat: add function Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 9 ++++++ FSharpActivePatterns/lib/astPrinter.ml | 11 ++++++- FSharpActivePatterns/lib/inferencer.ml | 26 +++++++++++++--- FSharpActivePatterns/lib/keywordChecker.ml | 1 + FSharpActivePatterns/lib/parser.ml | 31 +++++++++++++------ FSharpActivePatterns/lib/prettyPrinter.ml | 5 +++ .../lib/tests/qcheck_utils.ml | 15 ++++++++- 7 files changed, 82 insertions(+), 16 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 4ecb60612..5b6f87c5a 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -129,6 +129,15 @@ type expr = * expr (** fun x y -> x + y *) | Apply of (expr[@gen gen_expr_sized (n / 4)]) * (expr[@gen gen_expr_sized (n / 4)]) (** [sum 1 ] *) + | Function of + (pattern[@gen gen_pattern_sized (n / 4)]) + * (expr[@gen gen_expr_sized (n / 4)]) + * ((pattern * expr) list + [@gen + QCheck.Gen.( + list_size + (0 -- 2) + (pair (gen_pattern_sized (n / 20)) (gen_expr_sized (n / 20))))]) | Match of (expr[@gen gen_expr_sized (n / 4)]) * (pattern[@gen gen_pattern_sized (n / 4)]) diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 9d32c2b37..52906aa21 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -93,6 +93,15 @@ and print_expr indent fmt expr = | Tuple (e1, e2, rest) -> fprintf fmt "%s| Tuple:\n" (String.make indent '-'); List.iter (print_expr (indent + 2) fmt) (e1 :: e2 :: rest) + | Function (pat1, expr1, cases) -> + fprintf fmt "%s| Function:\n" (String.make indent '-'); + List.iter + (fun (pat, expr) -> + fprintf fmt "%s| Pattern:\n" (String.make (indent + 2) '-'); + print_pattern (indent + 4) fmt pat; + fprintf fmt "%s| Case expr:\n" (String.make (indent + 2) '-'); + print_expr (indent + 4) fmt expr) + ((pat1, expr1) :: cases) | Match (value, pat1, expr1, cases) -> fprintf fmt "%s| Match:\n" (String.make indent '-'); fprintf fmt "%s| Value:\n" (String.make (indent + 2) '-'); @@ -101,7 +110,7 @@ and print_expr indent fmt expr = (fun (pat, expr) -> fprintf fmt "%s| Pattern:\n" (String.make (indent + 2) '-'); print_pattern (indent + 4) fmt pat; - fprintf fmt "%s| Inner expr:\n" (String.make (indent + 2) '-'); + fprintf fmt "%s| Case expr:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) fmt expr) ((pat1, expr1) :: cases) | Variable (Ident (name, _)) -> diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 783338e8c..aefde55df 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -582,14 +582,32 @@ let rec infer_expr env = function let* subst2, typ = infer_expr env e in let* subst_final = Substitution.compose subst1 subst2 in return (subst_final, typ) + | Function (p1, e1, rest) -> + let* arg_type = make_fresh_var in + let* return_type = make_fresh_var in + let* subst, return_type = + List.fold + ((p1, e1) :: rest) + ~init:(return (Substitution.empty, return_type)) + ~f:(fun acc (pat, expr) -> + let* subst1, return_type = acc in + let* pat, env = infer_pattern env pat in + let* subst2 = unify arg_type pat in + let env = TypeEnvironment.apply subst2 env in + let* subst3, expr_typ = infer_expr env expr in + let* subst4 = unify return_type expr_typ in + let* subst = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in + return (subst, Substitution.apply subst return_type)) + in + return (subst, Arrow (Substitution.apply subst arg_type, return_type)) | Match (e, p1, e1, rest) -> let* subst_init, match_type = infer_expr env e in let env = TypeEnvironment.apply subst_init env in - let* fresh_typevar = make_fresh_var in - let* subst, typ = + let* return_type = make_fresh_var in + let* subst, return_type = List.fold ((p1, e1) :: rest) - ~init:(return (subst_init, fresh_typevar)) + ~init:(return (subst_init, return_type)) ~f:(fun acc (pat, expr) -> let* subst1, return_type = acc in let* pat, env = infer_pattern env pat in @@ -600,7 +618,7 @@ let rec infer_expr env = function let* subst = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in return (subst, Substitution.apply subst return_type)) in - return (subst, typ) + return (subst, return_type) and extend_env_with_let_binds env is_rec let_binds = List.fold diff --git a/FSharpActivePatterns/lib/keywordChecker.ml b/FSharpActivePatterns/lib/keywordChecker.ml index 0e8fe5e00..741e76941 100644 --- a/FSharpActivePatterns/lib/keywordChecker.ml +++ b/FSharpActivePatterns/lib/keywordChecker.ml @@ -17,6 +17,7 @@ let is_keyword = function | "and" | "Some" | "None" + | "function" | "_" -> true | _ -> false ;; diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 6b7a84491..c0bf8fab0 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -282,16 +282,26 @@ let p_lambda p_expr = return (Lambda (pat, pat_list, body)) ;; +let p_case p_expr = + let* pat = skip_ws *> string "|" *> p_pat <* skip_ws <* string "->" in + let* expr = p_expr in + return (pat, expr) +;; + let p_match p_expr = - lift4 - (fun value first_pat first_expr cases -> Match (value, first_pat, first_expr, cases)) - (skip_ws *> string "match" *> skip_ws *> p_expr <* skip_ws <* string "with") - (skip_ws *> string "|" *> skip_ws *> p_pat <* skip_ws <* string "->" <* skip_ws) - (p_expr <* skip_ws) - (many - (let* pat = skip_ws *> string "|" *> p_pat <* skip_ws <* string "->" in - let* expr = p_expr in - return (pat, expr))) + let* value = skip_ws *> string "match" *> p_expr <* skip_ws <* string "with" in + let* first_pat, first_expr = p_case p_expr in + let* cases = many (p_case p_expr) in + return (Match (value, first_pat, first_expr, cases)) +;; + +let p_function p_expr = + skip_ws + *> string "function" + *> + let* first_pat, first_expr = p_case p_expr in + let* cases = many (p_case p_expr) in + return (Function (first_pat, first_expr, cases)) ;; let p_expr = @@ -325,7 +335,8 @@ let p_expr = let bit_or = chainl1 bit_and bitwise_or in let comp_and = chainl1 bit_or log_and in let comp_or = chainl1 comp_and log_or in - let ematch = p_match (p_expr <|> comp_or) <|> comp_or in + let p_function = p_function (p_expr <|> comp_or) <|> comp_or in + let ematch = p_match (p_expr <|> p_function) <|> p_function in let efun = p_lambda (p_expr <|> ematch) <|> ematch in efun) ;; diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 515606542..8ccb70700 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -70,6 +70,11 @@ and pp_expr fmt expr = fprintf fmt "("; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); fprintf fmt ")" + | Function (pat1, expr1, cases) -> + fprintf fmt "function "; + List.iter + (fun (pat, expr) -> fprintf fmt "| %a -> (%a) \n" pp_pattern pat pp_expr expr) + ((pat1, expr1) :: cases) | Match (value, pat1, expr1, cases) -> fprintf fmt "match (%a) with \n" pp_expr value; List.iter diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index 10146c212..fb7d7dad3 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -69,8 +69,21 @@ and shrink_expr = >|= (fun body' -> Lambda (pat, pat_list, body')) <+> (QCheck.Shrink.list ~shrink:shrink_pattern pat_list >|= fun pat_list' -> Lambda (pat, pat_list', body)) + | Function (pat1, expr1, cases) -> + of_list (expr1 :: List.map snd cases) + <+> (shrink_pattern pat1 >|= fun a' -> Function (a', expr1, cases)) + <+> (shrink_expr expr1 >|= fun a' -> Function (pat1, a', cases)) + <+> (QCheck.Shrink.list + ~shrink:(fun (p, e) -> + (let* p_shr = shrink_pattern p in + return (p_shr, e)) + <+> + let* e_shr = shrink_expr e in + return (p, e_shr)) + cases + >|= fun a' -> Function (pat1, expr1, a')) | Match (value, pat1, expr1, cases) -> - of_list [ value; expr1 ] + of_list (value :: expr1 :: List.map snd cases) <+> (shrink_expr value >|= fun a' -> Match (a', pat1, expr1, cases)) <+> (shrink_pattern pat1 >|= fun a' -> Match (value, a', expr1, cases)) <+> (shrink_expr expr1 >|= fun a' -> Match (value, pat1, a', cases)) From a0b6a009dd8723ebab3c9e219bae20336f0b5468 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Wed, 18 Dec 2024 12:13:13 +0300 Subject: [PATCH 256/310] ref: add type case = pattern * expr Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 28 +++++++------------ FSharpActivePatterns/lib/astPrinter.ml | 4 +-- FSharpActivePatterns/lib/inferencer.ml | 4 +-- FSharpActivePatterns/lib/parser.ml | 8 +++--- FSharpActivePatterns/lib/prettyPrinter.ml | 4 +-- FSharpActivePatterns/lib/tests/ast_printer.ml | 2 +- .../lib/tests/qcheck_utils.ml | 18 ++++++------ 7 files changed, 30 insertions(+), 38 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 5b6f87c5a..a3f06c661 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -106,7 +106,10 @@ type is_recursive = | Rec (** let rec factorial n = ... *) [@@deriving show { with_path = false }, qcheck] -type expr = +type case = (pattern[@gen gen_pattern_sized n]) * (expr[@gen gen_expr_sized n]) +[@@deriving show { with_path = false }, qcheck] + +and expr = | Const of literal (** [Int], [Bool], [String], [Unit], [Null] *) | Tuple of (expr[@gen gen_expr_sized (n / 4)]) @@ -130,25 +133,14 @@ type expr = | Apply of (expr[@gen gen_expr_sized (n / 4)]) * (expr[@gen gen_expr_sized (n / 4)]) (** [sum 1 ] *) | Function of - (pattern[@gen gen_pattern_sized (n / 4)]) - * (expr[@gen gen_expr_sized (n / 4)]) - * ((pattern * expr) list - [@gen - QCheck.Gen.( - list_size - (0 -- 2) - (pair (gen_pattern_sized (n / 20)) (gen_expr_sized (n / 20))))]) + (case[@gen gen_case_sized (n / 4)]) + * (case list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_case_sized (n / 20)))]) + (** [function | p1 -> e1 | p2 -> e2 | ... |]*) | Match of (expr[@gen gen_expr_sized (n / 4)]) - * (pattern[@gen gen_pattern_sized (n / 4)]) - * (expr[@gen gen_expr_sized (n / 4)]) - * ((pattern * expr) list - [@gen - QCheck.Gen.( - list_size - (0 -- 2) - (pair (gen_pattern_sized (n / 20)) (gen_expr_sized (n / 20))))]) - (** [match x with | x -> ... | y -> ...] *) + * (case[@gen gen_case_sized (n / 4)]) + * (case list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_case_sized (n / 20)))]) + (** [match x with | p1 -> e1 | p2 -> e2 | ...] *) | LetIn of is_recursive * let_bind diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 52906aa21..e6a4ee346 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -93,7 +93,7 @@ and print_expr indent fmt expr = | Tuple (e1, e2, rest) -> fprintf fmt "%s| Tuple:\n" (String.make indent '-'); List.iter (print_expr (indent + 2) fmt) (e1 :: e2 :: rest) - | Function (pat1, expr1, cases) -> + | Function ((pat1, expr1), cases) -> fprintf fmt "%s| Function:\n" (String.make indent '-'); List.iter (fun (pat, expr) -> @@ -102,7 +102,7 @@ and print_expr indent fmt expr = fprintf fmt "%s| Case expr:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) fmt expr) ((pat1, expr1) :: cases) - | Match (value, pat1, expr1, cases) -> + | Match (value, (pat1, expr1), cases) -> fprintf fmt "%s| Match:\n" (String.make indent '-'); fprintf fmt "%s| Value:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) fmt value; diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index aefde55df..00c142437 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -582,7 +582,7 @@ let rec infer_expr env = function let* subst2, typ = infer_expr env e in let* subst_final = Substitution.compose subst1 subst2 in return (subst_final, typ) - | Function (p1, e1, rest) -> + | Function ((p1, e1), rest) -> let* arg_type = make_fresh_var in let* return_type = make_fresh_var in let* subst, return_type = @@ -600,7 +600,7 @@ let rec infer_expr env = function return (subst, Substitution.apply subst return_type)) in return (subst, Arrow (Substitution.apply subst arg_type, return_type)) - | Match (e, p1, e1, rest) -> + | Match (e, (p1, e1), rest) -> let* subst_init, match_type = infer_expr env e in let env = TypeEnvironment.apply subst_init env in let* return_type = make_fresh_var in diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index c0bf8fab0..863434a47 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -290,18 +290,18 @@ let p_case p_expr = let p_match p_expr = let* value = skip_ws *> string "match" *> p_expr <* skip_ws <* string "with" in - let* first_pat, first_expr = p_case p_expr in + let* pat1, expr1 = p_case p_expr in let* cases = many (p_case p_expr) in - return (Match (value, first_pat, first_expr, cases)) + return (Match (value, (pat1, expr1), cases)) ;; let p_function p_expr = skip_ws *> string "function" *> - let* first_pat, first_expr = p_case p_expr in + let* pat1, expr1 = p_case p_expr in let* cases = many (p_case p_expr) in - return (Function (first_pat, first_expr, cases)) + return (Function ((pat1, expr1), cases)) ;; let p_expr = diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 8ccb70700..613513334 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -70,12 +70,12 @@ and pp_expr fmt expr = fprintf fmt "("; pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); fprintf fmt ")" - | Function (pat1, expr1, cases) -> + | Function ((pat1, expr1), cases) -> fprintf fmt "function "; List.iter (fun (pat, expr) -> fprintf fmt "| %a -> (%a) \n" pp_pattern pat pp_expr expr) ((pat1, expr1) :: cases) - | Match (value, pat1, expr1, cases) -> + | Match (value, (pat1, expr1), cases) -> fprintf fmt "match (%a) with \n" pp_expr value; List.iter (fun (pat, expr) -> fprintf fmt "| %a -> (%a) \n" pp_pattern pat pp_expr expr) diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index fff43e0a9..215214089 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -227,7 +227,7 @@ let%expect_test "print Ast of match_expr" = let pattern_values = List.map (fun p -> p, Const (Int_lt 4)) patterns in let match_expr = Match - (Variable (Ident ("x", None)), PConst (Int_lt 4), Const (Int_lt 4), pattern_values) + (Variable (Ident ("x", None)), (PConst (Int_lt 4), Const (Int_lt 4)), pattern_values) in print_construction std_formatter (Expr match_expr); [%expect diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index fb7d7dad3..13c19aa56 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -69,10 +69,10 @@ and shrink_expr = >|= (fun body' -> Lambda (pat, pat_list, body')) <+> (QCheck.Shrink.list ~shrink:shrink_pattern pat_list >|= fun pat_list' -> Lambda (pat, pat_list', body)) - | Function (pat1, expr1, cases) -> + | Function ((pat1, expr1), cases) -> of_list (expr1 :: List.map snd cases) - <+> (shrink_pattern pat1 >|= fun a' -> Function (a', expr1, cases)) - <+> (shrink_expr expr1 >|= fun a' -> Function (pat1, a', cases)) + <+> (shrink_pattern pat1 >|= fun a' -> Function ((a', expr1), cases)) + <+> (shrink_expr expr1 >|= fun a' -> Function ((pat1, a'), cases)) <+> (QCheck.Shrink.list ~shrink:(fun (p, e) -> (let* p_shr = shrink_pattern p in @@ -81,12 +81,12 @@ and shrink_expr = let* e_shr = shrink_expr e in return (p, e_shr)) cases - >|= fun a' -> Function (pat1, expr1, a')) - | Match (value, pat1, expr1, cases) -> + >|= fun a' -> Function ((pat1, expr1), a')) + | Match (value, (pat1, expr1), cases) -> of_list (value :: expr1 :: List.map snd cases) - <+> (shrink_expr value >|= fun a' -> Match (a', pat1, expr1, cases)) - <+> (shrink_pattern pat1 >|= fun a' -> Match (value, a', expr1, cases)) - <+> (shrink_expr expr1 >|= fun a' -> Match (value, pat1, a', cases)) + <+> (shrink_expr value >|= fun a' -> Match (a', (pat1, expr1), cases)) + <+> (shrink_pattern pat1 >|= fun a' -> Match (value, (a', expr1), cases)) + <+> (shrink_expr expr1 >|= fun a' -> Match (value, (pat1, a'), cases)) <+> (QCheck.Shrink.list ~shrink:(fun (p, e) -> (let* p_shr = shrink_pattern p in @@ -95,7 +95,7 @@ and shrink_expr = let* e_shr = shrink_expr e in return (p, e_shr)) cases - >|= fun a' -> Match (value, pat1, expr1, a')) + >|= fun a' -> Match (value, (pat1, expr1), a')) | Option (Some e) -> of_list [ e; Option None ] <+> (shrink_expr e >|= fun a' -> Option (Some a')) | Option None -> empty From 0942aed2a4ec67b134c745dd6f3bda0047026106 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Wed, 18 Dec 2024 16:43:49 +0300 Subject: [PATCH 257/310] feat: infix operators Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/input.txt | 6 ++-- FSharpActivePatterns/lib/parser.ml | 43 ++++++++++++++++++++--- FSharpActivePatterns/lib/prettyPrinter.ml | 3 ++ 3 files changed, 44 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/bin/input.txt b/FSharpActivePatterns/bin/input.txt index fa5782d8f..deefc7f83 100644 --- a/FSharpActivePatterns/bin/input.txt +++ b/FSharpActivePatterns/bin/input.txt @@ -1,4 +1,2 @@ -1 + ();; -1 + "";; -1 + true;; -1 + 1;; +let (<|>) a b = a + b;; +5 <|> 6 <|> 7;; \ No newline at end of file diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 863434a47..2cf27f3d1 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -101,6 +101,31 @@ let p_type = <|> return None ;; +let p_inf_oper = + skip_ws + *> take_while1 (function + | '+' + | '-' + | '<' + | '>' + | '*' + | '|' + | '!' + | '$' + | '%' + | '&' + | '.' + | '/' + | ':' + | '=' + | '?' + | '@' + | '^' + | '~' -> true + | _ -> false) + >>= fun str -> return (Ident (str, None)) +;; + let p_ident = let find_string = skip_ws @@ -210,7 +235,7 @@ let p_let_bind p_expr = *> peek_sep1 *> lift3 (fun name args body -> Let_bind (name, args, body)) - p_ident + (p_ident <|> p_parens p_inf_oper) (many p_ident) (skip_ws *> string "=" *> p_expr) ;; @@ -221,7 +246,7 @@ let p_letin p_expr = *> skip_ws_sep1 *> let* rec_flag = string "rec" *> peek_sep1 *> return Rec <|> return Nonrec in - let* name = p_ident in + let* name = p_ident <|> p_parens p_inf_oper in let* args = many p_ident in let* body = skip_ws *> string "=" *> p_expr in let* let_bind_list = many (p_let_bind p_expr) in @@ -235,7 +260,7 @@ let p_let p_expr = *> skip_ws_sep1 *> let* rec_flag = string "rec" *> peek_sep1 *> return Rec <|> return Nonrec in - let* name = p_ident in + let* name = p_ident <|> p_parens p_inf_oper in let* args = many p_ident in let* body = skip_ws *> string "=" *> p_expr in let* let_bind_list = many (p_let_bind p_expr) in @@ -304,6 +329,15 @@ let p_function p_expr = return (Function ((pat1, expr1), cases)) ;; +let p_inf_oper_expr p_expr = + skip_ws + *> chainl1 + p_expr + (p_inf_oper + >>= fun op -> + return (fun expr1 expr2 -> Apply (Apply (Variable op, expr1), expr2))) +;; + let p_expr = skip_ws *> fix (fun p_expr -> @@ -335,7 +369,8 @@ let p_expr = let bit_or = chainl1 bit_and bitwise_or in let comp_and = chainl1 bit_or log_and in let comp_or = chainl1 comp_and log_or in - let p_function = p_function (p_expr <|> comp_or) <|> comp_or in + let inf_oper = p_inf_oper_expr comp_or <|> comp_or in + let p_function = p_function (p_expr <|> inf_oper) <|> inf_oper in let ematch = p_match (p_expr <|> p_function) <|> p_function in let efun = p_lambda (p_expr <|> ematch) <|> ematch in efun) diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 613513334..21bd7815a 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -93,6 +93,9 @@ and pp_expr fmt expr = fprintf fmt "fun "; List.iter (fun pat -> fprintf fmt "%a " pp_pattern pat) (pat1 :: pat_list); fprintf fmt "-> %a " pp_expr body + | Apply (Apply (Variable (Ident (op, _)), left), right) + when String.for_all (fun c -> String.contains "!$%&*+-./:<=>?@^|~" c) op -> + fprintf fmt "(%a %s %a)" pp_expr left op pp_expr right | Apply (func, arg) -> fprintf fmt "(%a) (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> fprintf fmt "let %a " pp_rec_flag rec_flag; From 9170dba67251a237490893a35dd0352b9902924f Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Wed, 18 Dec 2024 23:11:19 +0300 Subject: [PATCH 258/310] feat: implement patterns in let bindings Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 24 +- FSharpActivePatterns/lib/astPrinter.ml | 29 ++- FSharpActivePatterns/lib/inferencer.ml | 238 +++++++++--------- FSharpActivePatterns/lib/inferencer.mli | 4 +- FSharpActivePatterns/lib/parser.ml | 121 +++++---- FSharpActivePatterns/lib/prettyPrinter.ml | 52 +++- FSharpActivePatterns/lib/tests/ast_printer.ml | 31 ++- .../lib/tests/qcheck_utils.ml | 12 +- FSharpActivePatterns/lib/typedTree.ml | 4 +- FSharpActivePatterns/lib/typedTree.mli | 4 + FSharpActivePatterns/lib/typesPp.ml | 2 +- 11 files changed, 294 insertions(+), 227 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index a3f06c661..ef4833d47 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -3,9 +3,9 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) open KeywordChecker +open TypedTree -type ident = Ident of string * string option (** identifier *) -[@@deriving show { with_path = false }] +type ident = Ident of string (** identifier *) [@@deriving show { with_path = false }] let gen_varname = let open QCheck.Gen in @@ -26,8 +26,8 @@ let gen_varname = loop >>= fun name -> if is_keyword name then loop else return name ;; -let gen_ident = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname -let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 3) gen_ident) +let gen_ident = QCheck.Gen.map (fun s -> Ident s) gen_varname +(* let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 3) gen_ident) *) let gen_escape_sequence = let open QCheck.Gen in @@ -101,6 +101,10 @@ type pattern = (*| Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) *) [@@deriving show { with_path = false }, qcheck] +type typed_pattern = pattern * typ option [@@deriving show { with_path = false }] + +let gen_typed_pattern_sized n = QCheck.Gen.(pair (gen_pattern_sized n) (return None)) + type is_recursive = | Nonrec (** let factorial n = ... *) | Rec (** let rec factorial n = ... *) @@ -127,8 +131,9 @@ and expr = * (expr option[@gen QCheck.Gen.option (gen_expr_sized (n / 4))]) (** [if n % 2 = 0 then "Even" else "Odd"] *) | Lambda of - (pattern[@gen gen_pattern_sized (n / 2)]) - * (pattern list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_pattern_sized (n / 20)))]) + (typed_pattern[@gen gen_typed_pattern_sized (n / 2)]) + * (typed_pattern list + [@gen QCheck.Gen.(list_size (0 -- 2) (gen_typed_pattern_sized (n / 20)))]) * expr (** fun x y -> x + y *) | Apply of (expr[@gen gen_expr_sized (n / 4)]) * (expr[@gen gen_expr_sized (n / 4)]) (** [sum 1 ] *) @@ -151,8 +156,11 @@ and expr = [@@deriving show { with_path = false }, qcheck] and let_bind = - | Let_bind of ident * (ident list[@gen gen_ident_small_list]) * expr - (** [and sum n m = n+m] *) + | Let_bind of + (typed_pattern[@gen gen_typed_pattern_sized (n / 2)]) + * (typed_pattern list + [@gen QCheck.Gen.(list_size (0 -- 3) (gen_typed_pattern_sized (n / 4)))]) + * expr (** [let sum n m = n + m] *) [@@deriving show { with_path = false }, qcheck] let gen_expr = diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index e6a4ee346..c2eca1025 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -49,7 +49,7 @@ let rec print_pattern indent fmt = function fprintf fmt "%s| PCons:\n" (String.make indent '-'); print_pattern (indent + 2) fmt l; print_pattern (indent + 2) fmt r - | PVar (Ident (name, _)) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name + | PVar (Ident name) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name | POption p -> fprintf fmt "%s| POption: " (String.make indent '-'); (match p with @@ -64,19 +64,25 @@ let print_unary_op indent fmt = function | Unary_not -> fprintf fmt "%s| Unary negative\n" (String.make indent '-') ;; -let tag_of_ident = function - | Ident (s, _) -> s +let case_to_pair = function + | p, e -> p, e +;; + +let tpattern_to_pattern = function + | p, _ -> p ;; let rec print_let_bind indent fmt = function | Let_bind (name, args, body) -> - let name = tag_of_ident name in - let args = List.map tag_of_ident args in + let name = tpattern_to_pattern name in + let args = List.map tpattern_to_pattern args in fprintf fmt "%s| Let_bind:\n" (String.make indent '-'); fprintf fmt "%sNAME:\n" (String.make (indent + 4) ' '); - fprintf fmt "%s| %s\n" (String.make (indent + 4) '-') name; + fprintf fmt "%s| %a\n" (String.make (indent + 4) '-') pp_pattern name; fprintf fmt "%sARGS:\n" (String.make (indent + 4) ' '); - List.iter (fun arg -> fprintf fmt "%s| %s\n" (String.make (indent + 2) '-') arg) args; + List.iter + (fun arg -> fprintf fmt "%s| %a\n" (String.make (indent + 2) '-') pp_pattern arg) + args; fprintf fmt "%sBODY:\n" (String.make (indent + 4) ' '); print_expr (indent + 2) fmt body @@ -94,6 +100,7 @@ and print_expr indent fmt expr = fprintf fmt "%s| Tuple:\n" (String.make indent '-'); List.iter (print_expr (indent + 2) fmt) (e1 :: e2 :: rest) | Function ((pat1, expr1), cases) -> + let cases = List.map case_to_pair cases in fprintf fmt "%s| Function:\n" (String.make indent '-'); List.iter (fun (pat, expr) -> @@ -103,6 +110,7 @@ and print_expr indent fmt expr = print_expr (indent + 4) fmt expr) ((pat1, expr1) :: cases) | Match (value, (pat1, expr1), cases) -> + let cases = List.map case_to_pair cases in fprintf fmt "%s| Match:\n" (String.make indent '-'); fprintf fmt "%s| Value:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) fmt value; @@ -113,7 +121,7 @@ and print_expr indent fmt expr = fprintf fmt "%s| Case expr:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) fmt expr) ((pat1, expr1) :: cases) - | Variable (Ident (name, _)) -> + | Variable (Ident name) -> fprintf fmt "%s| Variable(%s)\n" (String.make indent '-') name | Unary_expr (op, expr) -> fprintf fmt "%s| Unary expr(\n" (String.make indent '-'); @@ -134,11 +142,12 @@ and print_expr indent fmt expr = (match else_body with | Some body -> print_expr (indent + 2) fmt body | None -> fprintf fmt "%s| No else body\n" (String.make (indent + 2) '-')) - | Lambda (pat1, pat_list, body) -> + | Lambda ((arg1, _), args, body) -> + let pat_list = List.map tpattern_to_pattern args in (*let args = List.map tag_of_ident args in*) fprintf fmt "%s| Lambda:\n" (String.make indent '-'); fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); - print_pattern (indent + 4) fmt pat1; + print_pattern (indent + 4) fmt arg1; List.iter (fun pat -> print_pattern (indent + 4) fmt pat) pat_list; fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 4) fmt body diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 00c142437..f60b2b918 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -12,7 +12,9 @@ type error = [ `Occurs_check | `Undef_var of string | `Unification_failed of typ * typ - | `WIP of string + | `Not_allowed_right_hand_side_let_rec + | `Not_allowed_left_hand_side_let_rec + | `Args_after_not_variable_let ] let pp_error fmt : error -> _ = function @@ -20,7 +22,12 @@ let pp_error fmt : error -> _ = function | `Undef_var s -> fprintf fmt "Undefined variable '%s'" s | `Unification_failed (fst, snd) -> fprintf fmt "unification failed on %a and %a" pp_typ fst pp_typ snd - | `WIP s -> fprintf fmt "%s" s + | `Not_allowed_right_hand_side_let_rec -> + fprintf fmt "This kind of expression is not allowed as right-hand side of `let rec'" + | `Not_allowed_left_hand_side_let_rec -> + fprintf fmt "Only variables are allowed as left-hand side of `let rec'" + | `Args_after_not_variable_let -> + fprintf fmt "Arguments in let allowed only after variable" ;; (* for treating result of type inference *) @@ -295,6 +302,7 @@ module TypeEnvironment : sig val free_vars : t -> VarSet.t val extend : t -> string -> scheme -> t + val extend_many : t -> (string * scheme) list -> t val apply : Substitution.t -> t -> t val empty : t val find : t -> string -> scheme option @@ -310,6 +318,11 @@ end = struct (* if pair (key, some old value) exists in map env, then replace old value with new, else add pair (key, value) into map *) let extend env key value = Map.update env key ~f:(fun _ -> value) + + let extend_many env list = + List.fold list ~init:env ~f:(fun env (k, v) -> extend env k v) + ;; + let remove = Map.remove let empty = Map.empty (module String) @@ -371,89 +384,126 @@ let generalize_rec env typ rec_name = ;; let infer_lt = function - | Int_lt _ -> return (Substitution.empty, int_typ) - | Bool_lt _ -> return (Substitution.empty, bool_typ) - | String_lt _ -> return (Substitution.empty, string_typ) - | Unit_lt -> return (Substitution.empty, unit_typ) + | Int_lt _ -> return int_typ + | Bool_lt _ -> return bool_typ + | String_lt _ -> return string_typ + | Unit_lt -> return unit_typ ;; let rec infer_pattern env = function | Wild -> let* fresh_var = make_fresh_var in - return (fresh_var, env) + return (env, fresh_var) | PConst lt -> - let* _, t = infer_lt lt in - return (t, env) - | PVar (Ident (name, _)) -> - (* подумать что делать с типом в Ident*) + let* t = infer_lt lt in + return (env, t) + | PVar (Ident name) -> let* fresh = make_fresh_var in let scheme = Scheme (VarSet.empty, fresh) in let env = TypeEnvironment.extend env name scheme in - return (fresh, env) + return (env, fresh) | POption None -> let* fresh_var = make_fresh_var in - return (fresh_var, env) - | POption (Some p) -> infer_pattern env p + return (env, TOption fresh_var) + | POption (Some p) -> + let* env, typ = infer_pattern env p in + return (env, TOption typ) | PList [] -> let* fresh_var = make_fresh_var in - return (Type_list fresh_var, env) + return (env, Type_list fresh_var) | PList (hd :: tl) -> - let* typ1, env = infer_pattern env hd in - let* subst_unify, typ_unified = - List.fold - tl - ~f:(fun acc p -> - let* subst_acc, typ_acc = acc in - let* typ, _ = infer_pattern env p in - let* subst_unify = unify typ_acc typ in - let typ_acc = Substitution.apply subst_unify typ_acc in - let* subst_acc = Substitution.compose_all [ subst_acc; subst_unify ] in - return (subst_acc, typ_acc)) - ~init:(return (Substitution.empty, typ1)) - in - return (typ_unified, TypeEnvironment.apply subst_unify env) + let* env, typ1 = infer_pattern env hd in + let* env, typ2 = infer_pattern env (PList tl) in + let* subst = Substitution.unify typ2 (Type_list typ1) in + let env = TypeEnvironment.apply subst env in + return (env, Substitution.apply subst typ2) | PCons (hd, tl) -> - let* typ1, env = infer_pattern env hd in - let* typ2, env = infer_pattern env tl in + let* env, typ1 = infer_pattern env hd in + let* env, typ2 = infer_pattern env tl in let* subst = Substitution.unify typ2 (Type_list typ1) in let env = TypeEnvironment.apply subst env in - return (Substitution.apply subst typ2, env) + return (env, Substitution.apply subst typ2) | PTuple (fst, snd, rest) -> - let* typ1, _ = infer_pattern env fst in - let* typ2, _ = infer_pattern env snd in + let* _, typ1 = infer_pattern env fst in + let* _, typ2 = infer_pattern env snd in let* typs_rest = List.fold_right rest ~f:(fun p patterns_acc -> let* patterns_acc = patterns_acc in - let* typ, _ = infer_pattern env p in + let* _, typ = infer_pattern env p in return (typ :: patterns_acc)) ~init:(return []) in - return (Type_tuple (typ1, typ2, typs_rest), env) + return (env, Type_tuple (typ1, typ2, typs_rest)) +;; + +let infer_typed_pattern env : typed_pattern -> (TypeEnvironment.t * typ) t = function + | pat, Some typ -> + let* env, inferred_typ = infer_pattern env pat in + let* subst = unify typ inferred_typ in + return (TypeEnvironment.apply subst env, Substitution.apply subst typ) + | pat, None -> infer_pattern env pat +;; + +let infer_typed_patterns env patterns = + List.fold_right + patterns + ~init:(return (env, [])) + ~f:(fun pat acc -> + let* old_env, typs = acc in + let* new_env, typ = infer_typed_pattern old_env pat in + return (new_env, typ :: typs)) +;; + +let extract_names_from_pattern = + let rec helper = function + | PVar (Ident name) -> [ name ] + | PList l -> List.concat (List.map l ~f:helper) + | PCons (hd, tl) -> List.concat [ helper hd; helper tl ] + | PTuple (fst, snd, rest) -> + List.concat [ helper fst; helper snd; List.concat (List.map rest ~f:helper) ] + | POption (Some p) -> helper p + | _ -> [] + in + function + | pat, _ -> helper pat +;; + +let extract_bind_names_from_let_binds let_binds = + List.concat + (List.map let_binds ~f:(function Let_bind (pat, _, _) -> + extract_names_from_pattern pat)) ;; -let extract_names_from_let_binds let_binds = - List.map let_binds ~f:(function Let_bind (Ident (name, _), _, _) -> name) +let extract_bind_patterns_from_let_binds let_binds = + List.map let_binds ~f:(function Let_bind (pat, _, _) -> pat) ;; let extend_env_with_bind_names env let_binds = - let bind_names = extract_names_from_let_binds let_binds in - let fresh_vars = List.init (List.length let_binds) ~f:(fun _ -> make_fresh_var) in - List.fold2_exn - ~init:(return env) - ~f:(fun acc bind_name fresh_var -> - let* fresh_var = fresh_var in - let* acc = acc in - return (TypeEnvironment.extend acc bind_name (Scheme (VarSet.empty, fresh_var)))) - bind_names - fresh_vars + (* to prevent binds like let rec x = x + 1*) + let let_binds = + List.filter let_binds ~f:(function Let_bind (_, args, _) -> List.length args <> 0) + in + let bind_names = extract_bind_patterns_from_let_binds let_binds in + let* env, _ = infer_typed_patterns env bind_names in + return env +;; + +let check_let_bind_correctness is_rec let_bind = + match let_bind, is_rec with + | Let_bind ((PVar _, _), _, _), _ -> return let_bind + | Let_bind _, Rec -> fail `Not_allowed_left_hand_side_let_rec + | Let_bind (_, args, _), _ when List.length args <> 0 -> + fail `Args_after_not_variable_let + | _ -> return let_bind ;; let rec infer_expr env = function - | Const lt -> infer_lt lt - | Variable (Ident (varname, _)) -> - (* подумать что делать с типом Ident*) + | Const lt -> + let* t = infer_lt lt in + return (Substitution.empty, t) + | Variable (Ident varname) -> (match TypeEnvironment.find env varname with | Some s -> let* t = instantiate s in @@ -560,14 +610,7 @@ let rec infer_expr env = function let* subst_result = Substitution.compose_all [ subst1; subst2; subst3 ] in return (subst_result, Substitution.apply subst3 fresh_var) | Lambda (arg, args, e) -> - let* env, arg_types = - RList.fold_right - (arg :: args) - ~init:(return (env, [])) - ~f:(fun arg (old_env, typs) -> - let* typ, new_env = infer_pattern old_env arg in - return (new_env, typ :: typs)) - in + let* env, arg_types = infer_typed_patterns env (arg :: args) in let* subst, e_type = infer_expr env e in return (subst, Substitution.apply subst (arrow_of_types arg_types e_type)) | LetIn (Rec, let_bind, let_binds, e) -> @@ -591,7 +634,7 @@ let rec infer_expr env = function ~init:(return (Substitution.empty, return_type)) ~f:(fun acc (pat, expr) -> let* subst1, return_type = acc in - let* pat, env = infer_pattern env pat in + let* env, pat = infer_pattern env pat in let* subst2 = unify arg_type pat in let env = TypeEnvironment.apply subst2 env in let* subst3, expr_typ = infer_expr env expr in @@ -610,7 +653,7 @@ let rec infer_expr env = function ~init:(return (subst_init, return_type)) ~f:(fun acc (pat, expr) -> let* subst1, return_type = acc in - let* pat, env = infer_pattern env pat in + let* env, pat = infer_pattern env pat in let* subst2 = unify match_type pat in let env = TypeEnvironment.apply subst2 env in let* subst3, expr_typ = infer_expr env expr in @@ -626,60 +669,31 @@ and extend_env_with_let_binds env is_rec let_binds = ~init:(return (env, Substitution.empty)) ~f:(fun acc let_bind -> let* env, subst_acc = acc in - let* subst, bind_varname, scheme = infer_let_bind env is_rec let_bind in - let env = TypeEnvironment.extend env bind_varname scheme in + let* subst, names_schemes_list = infer_let_bind env is_rec let_bind in + let env = TypeEnvironment.extend_many env names_schemes_list in let env = TypeEnvironment.apply subst env in let* subst_acc = Substitution.compose subst_acc subst in return (env, subst_acc)) -and infer_let_bind env is_rec = function - | Let_bind (Ident (bind_varname, _), args, e) -> - (* to avoid binds like let rec x = x + 1 *) - let env = - match List.length args with - | 0 -> TypeEnvironment.remove env bind_varname - | _ -> env - in - let* fresh_vars = - (* Hack for get typ list, not typ t list*) - List.fold args ~init:(return []) ~f:(fun acc _ -> - let* fresh_var = make_fresh_var in - let* acc = acc in - return (fresh_var :: acc)) - in - let arg_names = List.map args ~f:(function Ident (name, _) -> name) in - let* env_with_args = - List.fold2_exn - ~init:(return env) - ~f:(fun acc arg fresh_var -> - let* acc = acc in - return (TypeEnvironment.extend acc arg (Scheme (VarSet.empty, fresh_var)))) - arg_names - fresh_vars - in - let* subst1, typ1 = infer_expr env_with_args e in - let bind_type = Substitution.apply subst1 (arrow_of_types fresh_vars typ1) in - (* If let_bind is recursive, then bind_varname was already in environment *) - let* bind_typevar = - match is_rec with - | Rec -> return (TypeEnvironment.find_typ_exn env bind_varname) - | Nonrec -> make_fresh_var - in - let env = +and infer_let_bind env is_rec let_bind = + let* (Let_bind (name, args, e)) = check_let_bind_correctness is_rec let_bind in + let* env, args_types = infer_typed_patterns env args in + let* subst1, typ1 = infer_expr env e in + let bind_type = Substitution.apply subst1 (arrow_of_types args_types typ1) in + (* If let_bind is recursive, then bind_varname was already in environment *) + let* env, name_type = infer_typed_pattern env name in + let* subst2 = unify (Substitution.apply subst1 name_type) bind_type in + let* subst = Substitution.compose subst1 subst2 in + let env = TypeEnvironment.apply subst env in + let names = extract_names_from_pattern name in + let names_schemes_list = + List.map names ~f:(fun name -> + let name_type = TypeEnvironment.find_typ_exn env name in match is_rec with - | Rec -> TypeEnvironment.extend env bind_varname (Scheme (VarSet.empty, bind_type)) - | Nonrec -> env - in - let* subst2 = unify (Substitution.apply subst1 bind_typevar) bind_type in - let* subst = Substitution.compose subst1 subst2 in - let env = TypeEnvironment.apply subst env in - let bind_type = Substitution.apply subst bind_type in - let bind_var_scheme = - match is_rec with - | Rec -> generalize_rec env bind_type bind_varname - | Nonrec -> generalize env bind_type - in - return (subst, bind_varname, bind_var_scheme) + | Rec -> name, generalize_rec env name_type name + | Nonrec -> name, generalize env name_type) + in + return (subst, names_schemes_list) ;; let infer_statement env = function @@ -687,7 +701,7 @@ let infer_statement env = function let let_binds = let_bind :: let_binds in let* env = extend_env_with_bind_names env let_binds in let* env, _ = extend_env_with_let_binds env Rec let_binds in - let bind_names = extract_names_from_let_binds let_binds in + let bind_names = extract_bind_names_from_let_binds let_binds in let bind_types = List.map bind_names ~f:(fun name -> match TypeEnvironment.find_exn env name with @@ -697,7 +711,7 @@ let infer_statement env = function | Let (Nonrec, let_bind, let_binds) -> let let_binds = let_bind :: let_binds in let* env, _ = extend_env_with_let_binds env Nonrec let_binds in - let bind_names = extract_names_from_let_binds let_binds in + let bind_names = extract_bind_names_from_let_binds let_binds in let bind_types = List.map bind_names ~f:(fun name -> match TypeEnvironment.find_exn env name with diff --git a/FSharpActivePatterns/lib/inferencer.mli b/FSharpActivePatterns/lib/inferencer.mli index 3ac24e5bf..a1a8da3dd 100644 --- a/FSharpActivePatterns/lib/inferencer.mli +++ b/FSharpActivePatterns/lib/inferencer.mli @@ -16,7 +16,9 @@ type error = [ `Occurs_check | `Undef_var of string | `Unification_failed of typ * typ - | `WIP of string + | `Not_allowed_right_hand_side_let_rec + | `Not_allowed_left_hand_side_let_rec + | `Args_after_not_variable_let ] val pp_error : formatter -> error -> unit diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 2cf27f3d1..e89739bb1 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -6,6 +6,7 @@ open Angstrom open Ast open Base open KeywordChecker +open TypedTree (* TECHNICAL FUNCTIONS *) @@ -93,14 +94,6 @@ let p_string = let p_string_expr = expr_const_factory p_string let p_string_pat = pat_const_factory p_string -let p_type = - skip_ws - *> char ':' - *> skip_ws - *> (choice [ string "int"; string "bool" ] >>| fun var_type -> Some var_type) - <|> return None -;; - let p_inf_oper = skip_ws *> take_while1 (function @@ -123,11 +116,11 @@ let p_inf_oper = | '^' | '~' -> true | _ -> false) - >>= fun str -> return (Ident (str, None)) + >>= fun str -> return (Ident str) ;; -let p_ident = - let find_string = +let p_varname = + let p_string = skip_ws *> lift2 ( ^ ) @@ -138,13 +131,17 @@ let p_ident = | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> true | _ -> false)) in - find_string - >>= fun str -> - if is_keyword str - then fail "keywords are not allowed as variable names" - else p_type >>| fun type_opt -> Ident (str, type_opt) + let* str = p_string in + if is_keyword str then fail "keywords are not allowed as variable names" else return str +;; + +let p_ident = + let* varname = p_varname in + return (Ident varname) ;; +let p_type = skip_ws *> char ':' *> skip_ws *> p_varname >>| fun s -> Primitive s +let p_type_option = p_type >>| (fun t -> Some t) <|> return None let p_var_expr = p_ident >>| fun ident -> Variable ident let p_var_pat = p_ident >>| fun ident -> PVar ident @@ -229,48 +226,6 @@ let p_if p_expr = <|> return None) ;; -let p_let_bind p_expr = - skip_ws - *> string "and" - *> peek_sep1 - *> lift3 - (fun name args body -> Let_bind (name, args, body)) - (p_ident <|> p_parens p_inf_oper) - (many p_ident) - (skip_ws *> string "=" *> p_expr) -;; - -let p_letin p_expr = - skip_ws - *> string "let" - *> skip_ws_sep1 - *> - let* rec_flag = string "rec" *> peek_sep1 *> return Rec <|> return Nonrec in - let* name = p_ident <|> p_parens p_inf_oper in - let* args = many p_ident in - let* body = skip_ws *> string "=" *> p_expr in - let* let_bind_list = many (p_let_bind p_expr) in - let* in_expr = skip_ws *> string "in" *> peek_sep1 *> p_expr in - return (LetIn (rec_flag, Let_bind (name, args, body), let_bind_list, in_expr)) -;; - -let p_let p_expr = - skip_ws - *> string "let" - *> skip_ws_sep1 - *> - let* rec_flag = string "rec" *> peek_sep1 *> return Rec <|> return Nonrec in - let* name = p_ident <|> p_parens p_inf_oper in - let* args = many p_ident in - let* body = skip_ws *> string "=" *> p_expr in - let* let_bind_list = many (p_let_bind p_expr) in - return (Let (rec_flag, Let_bind (name, args, body), let_bind_list)) -;; - -let p_apply p_expr = - chainl1 (p_expr <* peek_sep1) (return (fun expr1 expr2 -> Apply (expr1, expr2))) -;; - let p_option p make_option = skip_ws *> string "None" *> peek_sep1 *> return (make_option None) <|> let+ inner = skip_ws *> string "Some" *> peek_sep1 *> p in @@ -296,15 +251,59 @@ let p_pat = cons) ;; +let p_typed_arg : typed_pattern t = + let typed_pattern = + let* p = p_pat in + let* t = p_type_option in + return (p, t) + in + p_parens typed_pattern <|> (p_pat >>| fun p -> p, None) +;; + +let p_let_bind p_expr = + let* name = p_pat <|> (p_parens p_inf_oper >>| fun oper -> PVar oper) in + let* args = many p_typed_arg in + let* name_typ = p_type_option <* skip_ws <* string "=" in + let* body = p_expr in + return (Let_bind ((name, name_typ), args, body)) +;; + +let p_letin p_expr = + skip_ws + *> string "let" + *> skip_ws_sep1 + *> + let* rec_flag = string "rec" *> peek_sep1 *> return Rec <|> return Nonrec in + let* let_bind1 = p_let_bind p_expr in + let* let_binds = many (skip_ws *> string "and" *> peek_sep1 *> p_let_bind p_expr) in + let* in_expr = skip_ws *> string "in" *> peek_sep1 *> p_expr in + return (LetIn (rec_flag, let_bind1, let_binds, in_expr)) +;; + +let p_let p_expr = + skip_ws + *> string "let" + *> skip_ws_sep1 + *> + let* rec_flag = string "rec" *> peek_sep1 *> return Rec <|> return Nonrec in + let* let_bind1 = p_let_bind p_expr in + let* let_binds = many (skip_ws *> string "and" *> peek_sep1 *> p_let_bind p_expr) in + return (Let (rec_flag, let_bind1, let_binds)) +;; + +let p_apply p_expr = + chainl1 (p_expr <* peek_sep1) (return (fun expr1 expr2 -> Apply (expr1, expr2))) +;; + let p_lambda p_expr = skip_ws *> string "fun" *> peek_sep1 *> - let* pat = p_pat in - let* pat_list = many p_pat <* skip_ws <* string "->" in + let* arg1 = p_typed_arg in + let* args = many p_typed_arg <* skip_ws <* string "->" in let* body = p_expr in - return (Lambda (pat, pat_list, body)) + return (Lambda (arg1, args, body)) ;; let p_case p_expr = diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 21bd7815a..566641c9c 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -4,6 +4,7 @@ open Ast open Format +open TypesPp let pp_bin_op fmt = function | Binary_equal -> fprintf fmt "= " @@ -50,7 +51,7 @@ let rec pp_pattern fmt = function (p1 :: p2 :: rest); fprintf fmt ")" | PConst literal -> fprintf fmt "%a " pp_expr (Const literal) - | PVar (Ident (name, _)) -> fprintf fmt "%s " name + | PVar (Ident name) -> fprintf fmt "%s " name | POption p -> (match p with | None -> fprintf fmt "None " @@ -71,16 +72,28 @@ and pp_expr fmt expr = pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); fprintf fmt ")" | Function ((pat1, expr1), cases) -> + let cases = + List.map + (function + | a, b -> a, b) + cases + in fprintf fmt "function "; List.iter (fun (pat, expr) -> fprintf fmt "| %a -> (%a) \n" pp_pattern pat pp_expr expr) ((pat1, expr1) :: cases) | Match (value, (pat1, expr1), cases) -> + let cases = + List.map + (function + | p, e -> p, e) + cases + in fprintf fmt "match (%a) with \n" pp_expr value; List.iter (fun (pat, expr) -> fprintf fmt "| %a -> (%a) \n" pp_pattern pat pp_expr expr) ((pat1, expr1) :: cases) - | Variable (Ident (name, _)) -> fprintf fmt "%s " name + | Variable (Ident name) -> fprintf fmt "%s " name | Unary_expr (op, expr) -> fprintf fmt "%a (%a)" pp_unary_op op pp_expr expr | Bin_expr (op, left, right) -> fprintf fmt "(%a) %a (%a)" pp_expr left pp_bin_op op pp_expr right @@ -89,13 +102,24 @@ and pp_expr fmt expr = (match else_body with | Some body -> fprintf fmt "else %a " pp_expr body | None -> ()) - | Lambda (pat1, pat_list, body) -> + | Lambda (arg1, args, body) -> + let args = + List.map + (function + | p, t -> p, t) + (arg1 :: args) + in fprintf fmt "fun "; - List.iter (fun pat -> fprintf fmt "%a " pp_pattern pat) (pat1 :: pat_list); + List.iter + (fun (pat, typ) -> + match typ with + | Some t -> fprintf fmt "(%a:%a) " pp_pattern pat pp_typ t + | None -> fprintf fmt "%a" pp_pattern pat) + args; fprintf fmt "-> %a " pp_expr body - | Apply (Apply (Variable (Ident (op, _)), left), right) + | Apply (Apply (Variable (Ident op), left), right) when String.for_all (fun c -> String.contains "!$%&*+-./:<=>?@^|~" c) op -> - fprintf fmt "(%a %s %a)" pp_expr left op pp_expr right + fprintf fmt "(%a) %s (%a)" pp_expr left op pp_expr right | Apply (func, arg) -> fprintf fmt "(%a) (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> fprintf fmt "let %a " pp_rec_flag rec_flag; @@ -115,16 +139,18 @@ and pp_args fmt args = let open Format in pp_print_list ~pp_sep:pp_print_space - (fun fmt name -> fprintf fmt "%s" name) + (fun fmt -> function + | argname, Some typ -> fprintf fmt "(%a:%a)" pp_pattern argname pp_typ typ + | argname, None -> fprintf fmt "%a" pp_pattern argname) fmt - (List.map - (function - | Ident (s, _) -> s) - args) + args and pp_let_bind fmt = function - | Let_bind (Ident (name, _), args, body) -> - fprintf fmt "%s %a = %a " name pp_args args pp_expr body + | Let_bind (name, args, body) -> + (match name with + | pat, Some typ -> + fprintf fmt "%a %a :%a = %a " pp_pattern pat pp_args args pp_typ typ pp_expr body + | pat, None -> fprintf fmt "%a %a = %a " pp_pattern pat pp_args args pp_expr body) ;; let pp_statement fmt = function diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index 215214089..4f738e046 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -9,28 +9,28 @@ open Format let%expect_test "print Ast factorial" = let factorial = Lambda - ( PConst (Int_lt 4) + ( (PConst (Int_lt 4), None) , [] , If_then_else ( Bin_expr ( Logical_or - , Bin_expr (Binary_equal, Variable (Ident ("n", None)), Const (Int_lt 0)) - , Bin_expr (Binary_equal, Variable (Ident ("n", None)), Const (Int_lt 1)) ) + , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 0)) + , Bin_expr (Binary_equal, Variable (Ident "n"), Const (Int_lt 1)) ) , Const (Int_lt 1) , Some (Bin_expr ( Binary_multiply - , Variable (Ident ("n", None)) + , Variable (Ident "n") , Apply - ( Variable (Ident ("factorial", None)) - , Bin_expr - (Binary_subtract, Variable (Ident ("n", None)), Const (Int_lt 1)) + ( Variable (Ident "factorial") + , Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) ) )) ) ) in let program = - [ Statement (Let (Nonrec, Let_bind (Ident ("a", None), [], Const (Int_lt 10)), [])) + [ Statement + (Let (Nonrec, Let_bind ((PVar (Ident "a"), None), [], Const (Int_lt 10)), [])) ; Expr factorial - ; Expr (Apply (factorial, Variable (Ident ("a", None)))) + ; Expr (Apply (factorial, Variable (Ident "a"))) ] in List.iter (print_construction std_formatter) program; @@ -107,8 +107,8 @@ let%expect_test "print Ast factorial" = ;; let%expect_test "print Ast double func" = - let ident = Ident ("n", None) in - let pat = PConst (Int_lt 4) in + let ident = Ident "n" in + let pat = PConst (Int_lt 4), None in let args = [] in let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), Variable ident) in let double = Lambda (pat, args, binary_expr) in @@ -199,9 +199,9 @@ let%expect_test "print Ast of LetIn" = Expr (LetIn ( Nonrec - , Let_bind (Ident ("x", None), [], Const (Int_lt 5)) + , Let_bind ((PVar (Ident "x"), None), [], Const (Int_lt 5)) , [] - , Bin_expr (Binary_add, Variable (Ident ("x", None)), Const (Int_lt 5)) )) + , Bin_expr (Binary_add, Variable (Ident "x"), Const (Int_lt 5)) )) in print_construction std_formatter sum; [%expect @@ -221,13 +221,12 @@ let%expect_test "print Ast of match_expr" = let patterns = [ PConst (Int_lt 5) ; PConst (String_lt " bar foo") - ; PList [ Wild; PVar (Ident ("xs", None)) ] + ; PList [ Wild; PVar (Ident "xs") ] ] in let pattern_values = List.map (fun p -> p, Const (Int_lt 4)) patterns in let match_expr = - Match - (Variable (Ident ("x", None)), (PConst (Int_lt 4), Const (Int_lt 4)), pattern_values) + Match (Variable (Ident "x"), (PConst (Int_lt 4), Const (Int_lt 4)), pattern_values) in print_construction std_formatter (Expr match_expr); [%expect diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index 13c19aa56..6cf6c8323 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -28,7 +28,11 @@ let rec shrink_let_bind = | Let_bind (name, args, e) -> shrink_expr e >|= (fun a' -> Let_bind (name, args, a')) - <+> (QCheck.Shrink.list args >|= fun a' -> Let_bind (name, a', e)) + <+> (QCheck.Shrink.list (List.map fst args) + >|= fun a' -> + let a' = List.map (fun p -> p, None) a' in + Let_bind (name, a', e)) + <+> (shrink_pattern (fst name) >|= fun a' -> Let_bind ((a', None), args, e)) and shrink_expr = let open QCheck.Iter in @@ -67,8 +71,10 @@ and shrink_expr = | Lambda (pat, pat_list, body) -> shrink_expr body >|= (fun body' -> Lambda (pat, pat_list, body')) - <+> (QCheck.Shrink.list ~shrink:shrink_pattern pat_list - >|= fun pat_list' -> Lambda (pat, pat_list', body)) + <+> (QCheck.Shrink.list ~shrink:shrink_pattern (List.map fst pat_list) + >|= fun a' -> + let a' = List.map (fun p -> p, None) a' in + Lambda (pat, a', body)) | Function ((pat1, expr1), cases) -> of_list (expr1 :: List.map snd cases) <+> (shrink_pattern pat1 >|= fun a' -> Function ((a', expr1), cases)) diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index 26ab398a2..4afb3515f 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -2,7 +2,7 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -type binder = int [@@deriving show { with_path = false }] +type binder = int [@@deriving show { with_path = false }, qcheck] type typ = | Primitive of string @@ -11,7 +11,7 @@ type typ = | Type_list of typ | Type_tuple of typ * typ * typ list | TOption of typ -[@@deriving show { with_path = false }] +[@@deriving show { with_path = false }, qcheck] let arrow_of_types first_types last_type = let open Base in diff --git a/FSharpActivePatterns/lib/typedTree.mli b/FSharpActivePatterns/lib/typedTree.mli index d8f8667a1..c88ae8c87 100644 --- a/FSharpActivePatterns/lib/typedTree.mli +++ b/FSharpActivePatterns/lib/typedTree.mli @@ -2,6 +2,8 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) +open QCheck + type binder = int type typ = @@ -12,6 +14,8 @@ type typ = | Type_tuple of typ * typ * typ list | TOption of typ +val gen_typ_sized : int -> typ QCheck.Gen.t +val pp_typ : Format.formatter -> typ -> unit val arrow_of_types : typ list -> typ -> typ module VarSet : sig diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index 59207a761..1d836d95e 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -22,7 +22,7 @@ let pp_typ fmt typ = fmt (first :: second :: rest); fprintf fmt ")" - | TOption t -> fprintf fmt "(%a) option" helper t + | TOption t -> fprintf fmt "%a option" helper t in helper fmt typ; fprintf fmt "\n" From df741febc150f8d288bc858898ab99274160d5c3 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Wed, 18 Dec 2024 23:44:30 +0300 Subject: [PATCH 259/310] ref: lint Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 8 -------- FSharpActivePatterns/lib/typedTree.ml | 4 +++- FSharpActivePatterns/lib/typedTree.mli | 2 -- 3 files changed, 3 insertions(+), 11 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index f60b2b918..165a7cc2a 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -47,7 +47,6 @@ module R : sig module RList : sig val fold_left : 'a list -> init:'b t -> f:('b -> 'a -> 'b t) -> 'b t - val fold_right : 'a list -> init:'b t -> f:('a -> 'b -> 'b t) -> 'b t end val fresh : int t @@ -98,13 +97,6 @@ end = struct let* acc = acc in f acc x) ;; - - let fold_right xs ~init ~f = - Base.List.fold_right xs ~init ~f:(fun x acc -> - let open Syntax in - let* acc = acc in - f x acc) - ;; end (* analogically to list. let* acc = acc is to extract value from type t *) diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index 4afb3515f..44aee06e8 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -4,8 +4,10 @@ type binder = int [@@deriving show { with_path = false }, qcheck] +let gen_primitive = QCheck.Gen.oneofl [ "int"; "bool"; "string"; "unit" ] + type typ = - | Primitive of string + | Primitive of (string[@gen gen_primitive]) | Type_var of binder | Arrow of typ * typ | Type_list of typ diff --git a/FSharpActivePatterns/lib/typedTree.mli b/FSharpActivePatterns/lib/typedTree.mli index c88ae8c87..b3e5dc4bf 100644 --- a/FSharpActivePatterns/lib/typedTree.mli +++ b/FSharpActivePatterns/lib/typedTree.mli @@ -2,8 +2,6 @@ (** SPDX-License-Identifier: LGPL-3.0-or-later *) -open QCheck - type binder = int type typ = From 3e8ed3816eafd2ea544454b975272289b8b1056a Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 00:07:05 +0300 Subject: [PATCH 260/310] fix: tuple inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 165a7cc2a..79518beb7 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -416,16 +416,16 @@ let rec infer_pattern env = function let env = TypeEnvironment.apply subst env in return (env, Substitution.apply subst typ2) | PTuple (fst, snd, rest) -> - let* _, typ1 = infer_pattern env fst in - let* _, typ2 = infer_pattern env snd in - let* typs_rest = + let* env, typ1 = infer_pattern env fst in + let* env, typ2 = infer_pattern env snd in + let* env, typs_rest = List.fold_right rest - ~f:(fun p patterns_acc -> - let* patterns_acc = patterns_acc in - let* _, typ = infer_pattern env p in - return (typ :: patterns_acc)) - ~init:(return []) + ~f:(fun p acc -> + let* env, types = acc in + let* env, typ = infer_pattern env p in + return (env, typ :: types)) + ~init:(return (env, [])) in return (env, Type_tuple (typ1, typ2, typs_rest)) ;; From 367a112f8fe0360c630e26830dd6705b6196d833 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 13:00:22 +0300 Subject: [PATCH 261/310] fix: recursive let inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 83 ++++++++++++++++---------- 1 file changed, 50 insertions(+), 33 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 79518beb7..bfd20b917 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -300,7 +300,9 @@ module TypeEnvironment : sig val find : t -> string -> scheme option val find_exn : t -> string -> scheme val find_typ_exn : t -> string -> typ + val find_typ : t -> string -> typ option val remove : t -> string -> t + (* val pp : t -> formatter -> unit *) end = struct open Base @@ -323,24 +325,28 @@ end = struct let find = Map.find let find_exn = Map.find_exn + let find_typ env key = + match find env key with + | Some (Scheme (_, typ)) -> Some typ + | None -> None + ;; + let find_typ_exn env key = match find_exn env key with | Scheme (_, typ) -> typ ;; + (* let pp t fmt = + Map.iter_keys t ~f:(fun k -> + let v = find_typ_exn t k in + fprintf fmt "%s : %a" k pp_typ v) + ;; *) + (* collect all free vars from environment *) let free_vars : t -> VarSet.t = Map.fold ~init:VarSet.empty ~f:(fun ~key:_ ~data:s acc -> VarSet.union acc (Scheme.free_vars s)) ;; - - (* TODO: custom pp_scheme? not from deriving *) - (* let pp fmt map = - Stdlib.Format.fprintf fmt "{| "; - Map.iteri map ~f:(fun ~key:n ~data:s -> - Stdlib.Format.fprintf fmt "%s -> %a; " n pp_scheme s); - Stdlib.Format.fprintf fmt "|}%!" - ;; *) end open R @@ -382,7 +388,7 @@ let infer_lt = function | Unit_lt -> return unit_typ ;; -let rec infer_pattern env = function +let rec infer_pattern env ~shadow = function | Wild -> let* fresh_var = make_fresh_var in return (env, fresh_var) @@ -392,59 +398,66 @@ let rec infer_pattern env = function | PVar (Ident name) -> let* fresh = make_fresh_var in let scheme = Scheme (VarSet.empty, fresh) in - let env = TypeEnvironment.extend env name scheme in - return (env, fresh) + let env, typ = + match shadow with + | true -> TypeEnvironment.extend env name scheme, fresh + | false -> + let typ = TypeEnvironment.find_typ env name in + env, Option.value typ ~default:fresh + in + return (env, typ) | POption None -> let* fresh_var = make_fresh_var in return (env, TOption fresh_var) | POption (Some p) -> - let* env, typ = infer_pattern env p in + let* env, typ = infer_pattern env ~shadow p in return (env, TOption typ) | PList [] -> let* fresh_var = make_fresh_var in return (env, Type_list fresh_var) | PList (hd :: tl) -> - let* env, typ1 = infer_pattern env hd in - let* env, typ2 = infer_pattern env (PList tl) in + let* env, typ1 = infer_pattern env ~shadow hd in + let* env, typ2 = infer_pattern env ~shadow (PList tl) in let* subst = Substitution.unify typ2 (Type_list typ1) in let env = TypeEnvironment.apply subst env in return (env, Substitution.apply subst typ2) | PCons (hd, tl) -> - let* env, typ1 = infer_pattern env hd in - let* env, typ2 = infer_pattern env tl in + let* env, typ1 = infer_pattern env ~shadow hd in + let* env, typ2 = infer_pattern env ~shadow tl in let* subst = Substitution.unify typ2 (Type_list typ1) in let env = TypeEnvironment.apply subst env in return (env, Substitution.apply subst typ2) | PTuple (fst, snd, rest) -> - let* env, typ1 = infer_pattern env fst in - let* env, typ2 = infer_pattern env snd in + let* env, typ1 = infer_pattern env ~shadow fst in + let* env, typ2 = infer_pattern env ~shadow snd in let* env, typs_rest = List.fold_right rest ~f:(fun p acc -> let* env, types = acc in - let* env, typ = infer_pattern env p in + let* env, typ = infer_pattern env ~shadow p in return (env, typ :: types)) ~init:(return (env, [])) in return (env, Type_tuple (typ1, typ2, typs_rest)) ;; -let infer_typed_pattern env : typed_pattern -> (TypeEnvironment.t * typ) t = function +let infer_typed_pattern env ~shadow : typed_pattern -> (TypeEnvironment.t * typ) t + = function | pat, Some typ -> - let* env, inferred_typ = infer_pattern env pat in + let* env, inferred_typ = infer_pattern env ~shadow pat in let* subst = unify typ inferred_typ in return (TypeEnvironment.apply subst env, Substitution.apply subst typ) - | pat, None -> infer_pattern env pat + | pat, None -> infer_pattern env ~shadow pat ;; -let infer_typed_patterns env patterns = +let infer_typed_patterns env ~shadow patterns = List.fold_right patterns ~init:(return (env, [])) ~f:(fun pat acc -> let* old_env, typs = acc in - let* new_env, typ = infer_typed_pattern old_env pat in + let* new_env, typ = infer_typed_pattern old_env ~shadow pat in return (new_env, typ :: typs)) ;; @@ -478,7 +491,7 @@ let extend_env_with_bind_names env let_binds = List.filter let_binds ~f:(function Let_bind (_, args, _) -> List.length args <> 0) in let bind_names = extract_bind_patterns_from_let_binds let_binds in - let* env, _ = infer_typed_patterns env bind_names in + let* env, _ = infer_typed_patterns env ~shadow:true bind_names in return env ;; @@ -596,13 +609,13 @@ let rec infer_expr env = function | Apply (f, arg) -> let* subst1, typ1 = infer_expr env f in let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) arg in - let* fresh_var = make_fresh_var in let typ1 = Substitution.apply subst2 typ1 in + let* fresh_var = make_fresh_var in let* subst3 = unify typ1 (Arrow (typ2, fresh_var)) in let* subst_result = Substitution.compose_all [ subst1; subst2; subst3 ] in return (subst_result, Substitution.apply subst3 fresh_var) | Lambda (arg, args, e) -> - let* env, arg_types = infer_typed_patterns env (arg :: args) in + let* env, arg_types = infer_typed_patterns env ~shadow:true (arg :: args) in let* subst, e_type = infer_expr env e in return (subst, Substitution.apply subst (arrow_of_types arg_types e_type)) | LetIn (Rec, let_bind, let_binds, e) -> @@ -626,7 +639,7 @@ let rec infer_expr env = function ~init:(return (Substitution.empty, return_type)) ~f:(fun acc (pat, expr) -> let* subst1, return_type = acc in - let* env, pat = infer_pattern env pat in + let* env, pat = infer_pattern env ~shadow:true pat in let* subst2 = unify arg_type pat in let env = TypeEnvironment.apply subst2 env in let* subst3, expr_typ = infer_expr env expr in @@ -645,7 +658,7 @@ let rec infer_expr env = function ~init:(return (subst_init, return_type)) ~f:(fun acc (pat, expr) -> let* subst1, return_type = acc in - let* env, pat = infer_pattern env pat in + let* env, pat = infer_pattern env ~shadow:true pat in let* subst2 = unify match_type pat in let env = TypeEnvironment.apply subst2 env in let* subst3, expr_typ = infer_expr env expr in @@ -669,11 +682,15 @@ and extend_env_with_let_binds env is_rec let_binds = and infer_let_bind env is_rec let_bind = let* (Let_bind (name, args, e)) = check_let_bind_correctness is_rec let_bind in - let* env, args_types = infer_typed_patterns env args in - let* subst1, typ1 = infer_expr env e in - let bind_type = Substitution.apply subst1 (arrow_of_types args_types typ1) in + let* env, args_types = infer_typed_patterns env ~shadow:true args in + let* subst1, rvalue_type = infer_expr env e in + let bind_type = Substitution.apply subst1 (arrow_of_types args_types rvalue_type) in (* If let_bind is recursive, then bind_varname was already in environment *) - let* env, name_type = infer_typed_pattern env name in + let* env, name_type = + match is_rec with + | Nonrec -> infer_typed_pattern env ~shadow:true name + | Rec -> infer_typed_pattern env ~shadow:false name + in let* subst2 = unify (Substitution.apply subst1 name_type) bind_type in let* subst = Substitution.compose subst1 subst2 in let env = TypeEnvironment.apply subst env in From 6f74e0f2b4896a8b6783ecc08d940a41d134d861 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Thu, 19 Dec 2024 12:47:33 +0300 Subject: [PATCH 262/310] feat: tuples without parens Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index e89739bb1..c2a5f3839 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -200,16 +200,21 @@ let p_cons_list_pat p_pat = chainr1 p_pat (skip_ws *> string "::" *> return (fun l r -> PCons (l, r))) ;; -let p_tuple make p = +let p_tuple_no_parens make p = skip_ws - *> string "(" - *> lift3 - make - p - (skip_ws *> string "," *> skip_ws *> p) - (many (skip_ws *> string "," *> skip_ws *> p)) - <* skip_ws - <* string ")" + *> + let tuple = + lift3 + make + p + (skip_ws *> string "," *> skip_ws *> p) + (many (skip_ws *> string "," *> skip_ws *> p)) + in + tuple +;; + +let p_tuple make p = + skip_ws *> p_parens (p_tuple_no_parens make p) <|> skip_ws *> p_tuple_no_parens make p ;; let p_tuple_pat p_pat = p_tuple make_tuple_pat p_pat @@ -351,8 +356,7 @@ let p_expr = ; p_semicolon_list_expr p_expr ] in - let tuple = p_tuple make_tuple_expr (p_expr <|> atom) <|> atom in - let if_expr = p_if (p_expr <|> tuple) <|> tuple in + let if_expr = p_if (p_expr <|> atom) <|> atom in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in let option = p_option letin_expr make_option_expr <|> letin_expr in let apply = p_apply option <|> option in @@ -372,7 +376,8 @@ let p_expr = let p_function = p_function (p_expr <|> inf_oper) <|> inf_oper in let ematch = p_match (p_expr <|> p_function) <|> p_function in let efun = p_lambda (p_expr <|> ematch) <|> ematch in - efun) + let tuple = p_tuple_no_parens make_tuple_expr efun <|> efun in + tuple) ;; let p_statement = p_let p_expr From e17faf30353f48f6b6f15a81542033c68ad56bd1 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Thu, 19 Dec 2024 13:28:09 +0300 Subject: [PATCH 263/310] fix: tuples without parens + example Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/input.txt | 11 +++++++++-- FSharpActivePatterns/lib/parser.ml | 26 ++++++++++---------------- 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/FSharpActivePatterns/bin/input.txt b/FSharpActivePatterns/bin/input.txt index deefc7f83..4be39a852 100644 --- a/FSharpActivePatterns/bin/input.txt +++ b/FSharpActivePatterns/bin/input.txt @@ -1,2 +1,9 @@ -let (<|>) a b = a + b;; -5 <|> 6 <|> 7;; \ No newline at end of file +let a, b = 1, 2;; + +1, 2 + (1, 2) + 4;; + +if 1, 2 then (3, 4) else ((0, 1), 0);; + +match (1, 2) with +| 3, 4 -> None +| (5, 6) -> None;; \ No newline at end of file diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index c2a5f3839..bc07c63eb 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -201,16 +201,10 @@ let p_cons_list_pat p_pat = ;; let p_tuple_no_parens make p = - skip_ws - *> - let tuple = - lift3 - make - p - (skip_ws *> string "," *> skip_ws *> p) - (many (skip_ws *> string "," *> skip_ws *> p)) - in - tuple + let* fst = p <* skip_ws <* string "," <* skip_ws in + let* snd = p in + let* rest = many (skip_ws *> string "," *> p) in + return (make fst snd rest) ;; let p_tuple make p = @@ -249,9 +243,9 @@ let p_pat = skip_ws *> fix (fun self -> let atom = choice [ p_pat_const; p_parens self ] in - let tuple = p_tuple_pat (self <|> atom) <|> atom in - let semicolon_list = p_semicolon_list_pat (self <|> tuple) <|> tuple in - let opt = p_option semicolon_list make_option_pat <|> semicolon_list in + let semicolon_list = p_semicolon_list_pat (self <|> atom) <|> atom in + let tuple = p_tuple make_tuple_pat semicolon_list <|> semicolon_list in + let opt = p_option tuple make_option_pat <|> tuple in let cons = p_cons_list_pat opt in cons) ;; @@ -358,7 +352,8 @@ let p_expr = in let if_expr = p_if (p_expr <|> atom) <|> atom in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in - let option = p_option letin_expr make_option_expr <|> letin_expr in + let tuple = p_tuple make_tuple_expr letin_expr <|> letin_expr in + let option = p_option tuple make_option_expr <|> tuple in let apply = p_apply option <|> option in let unary = choice [ unary_chain p_not apply; unary_chain unminus apply ] in let factor = chainl1 unary (mul <|> div) in @@ -376,8 +371,7 @@ let p_expr = let p_function = p_function (p_expr <|> inf_oper) <|> inf_oper in let ematch = p_match (p_expr <|> p_function) <|> p_function in let efun = p_lambda (p_expr <|> ematch) <|> ematch in - let tuple = p_tuple_no_parens make_tuple_expr efun <|> efun in - tuple) + efun) ;; let p_statement = p_let p_expr From f305125541f0f81b02d66b215ac8a16d952099cf Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 13:37:02 +0300 Subject: [PATCH 264/310] fix: add '->' to keywords Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/keywordChecker.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/FSharpActivePatterns/lib/keywordChecker.ml b/FSharpActivePatterns/lib/keywordChecker.ml index 741e76941..7d1849ca9 100644 --- a/FSharpActivePatterns/lib/keywordChecker.ml +++ b/FSharpActivePatterns/lib/keywordChecker.ml @@ -18,6 +18,7 @@ let is_keyword = function | "Some" | "None" | "function" + | "->" | "_" -> true | _ -> false ;; From 6face784cd01349c0c580f401ee87639bea69e5a Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 13:46:41 +0300 Subject: [PATCH 265/310] fix: add '|' in keywords and add operator keywords check Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/keywordChecker.ml | 1 + FSharpActivePatterns/lib/parser.ml | 55 ++++++++++++---------- 2 files changed, 31 insertions(+), 25 deletions(-) diff --git a/FSharpActivePatterns/lib/keywordChecker.ml b/FSharpActivePatterns/lib/keywordChecker.ml index 7d1849ca9..2c85d8868 100644 --- a/FSharpActivePatterns/lib/keywordChecker.ml +++ b/FSharpActivePatterns/lib/keywordChecker.ml @@ -19,6 +19,7 @@ let is_keyword = function | "None" | "function" | "->" + | "|" | "_" -> true | _ -> false ;; diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index bc07c63eb..183723ded 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -95,32 +95,36 @@ let p_string_expr = expr_const_factory p_string let p_string_pat = pat_const_factory p_string let p_inf_oper = - skip_ws - *> take_while1 (function - | '+' - | '-' - | '<' - | '>' - | '*' - | '|' - | '!' - | '$' - | '%' - | '&' - | '.' - | '/' - | ':' - | '=' - | '?' - | '@' - | '^' - | '~' -> true - | _ -> false) - >>= fun str -> return (Ident str) + let* oper = + skip_ws + *> take_while1 (function + | '+' + | '-' + | '<' + | '>' + | '*' + | '|' + | '!' + | '$' + | '%' + | '&' + | '.' + | '/' + | ':' + | '=' + | '?' + | '@' + | '^' + | '~' -> true + | _ -> false) + in + if is_keyword oper + then fail "keywords are not allowed as variable names" + else return (Ident oper) ;; let p_varname = - let p_string = + let* name = skip_ws *> lift2 ( ^ ) @@ -131,8 +135,9 @@ let p_varname = | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> true | _ -> false)) in - let* str = p_string in - if is_keyword str then fail "keywords are not allowed as variable names" else return str + if is_keyword name + then fail "keywords are not allowed as variable names" + else return name ;; let p_ident = From bab838b9070da272d02512cf1b3817e6e1f8fb0d Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 13:59:43 +0300 Subject: [PATCH 266/310] ref: tuple parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 183723ded..e6f906af5 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -205,15 +205,14 @@ let p_cons_list_pat p_pat = chainr1 p_pat (skip_ws *> string "::" *> return (fun l r -> PCons (l, r))) ;; -let p_tuple_no_parens make p = - let* fst = p <* skip_ws <* string "," <* skip_ws in - let* snd = p in - let* rest = many (skip_ws *> string "," *> p) in - return (make fst snd rest) -;; - let p_tuple make p = - skip_ws *> p_parens (p_tuple_no_parens make p) <|> skip_ws *> p_tuple_no_parens make p + let tuple = + let* fst = p <* skip_ws <* string "," in + let* snd = p in + let* rest = many (skip_ws *> string "," *> p) in + return (make fst snd rest) + in + p_parens tuple <|> tuple ;; let p_tuple_pat p_pat = p_tuple make_tuple_pat p_pat From c677d3e2cb49c9333500ca7bbb20a2534ff0f7b2 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 14:26:21 +0300 Subject: [PATCH 267/310] feat: add print_int to start environment Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 9 ++++++++- FSharpActivePatterns/lib/inferencer.mli | 1 + 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index f8ebe5386..1cf7a814e 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -5,6 +5,7 @@ open FSharpActivePatterns.AstPrinter open FSharpActivePatterns.Parser open FSharpActivePatterns.Inferencer +open FSharpActivePatterns.TypedTree open FSharpActivePatterns.TypesPp open Stdlib @@ -89,7 +90,13 @@ let run_repl dump_parsetree input_file = print_flush ()); run_repl_helper run env new_state) in - run_repl_helper run_single TypeEnvironment.empty 0 + let env = + TypeEnvironment.extend + TypeEnvironment.empty + "print_int" + (Scheme (VarSet.empty, Arrow (int_typ, unit_typ))) + in + run_repl_helper run_single env 0 ;; type opts = diff --git a/FSharpActivePatterns/lib/inferencer.mli b/FSharpActivePatterns/lib/inferencer.mli index a1a8da3dd..98316260c 100644 --- a/FSharpActivePatterns/lib/inferencer.mli +++ b/FSharpActivePatterns/lib/inferencer.mli @@ -10,6 +10,7 @@ module TypeEnvironment : sig type t val empty : t + val extend : t -> string -> scheme -> t end type error = From b058dda1845e03a510ef45b5a165b905d1cbd0d7 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Thu, 19 Dec 2024 14:56:20 +0300 Subject: [PATCH 268/310] fix: application and if in semicolon list Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index e6f906af5..e6cac4974 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -25,7 +25,7 @@ let peek_sep1 = match c with | None -> return None | Some c -> - if is_ws c || Char.equal c '(' || Char.equal c ')' || Char.equal c ',' + if is_ws c || Char.equal c '(' || Char.equal c ')' || Char.equal c ',' || Char.equal c ']' || Char.equal c ';' then return (Some c) else fail "need a delimiter" ;; From d95acf6b7178db2345774a2f1a2a4b6023905b17 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Thu, 19 Dec 2024 15:08:25 +0300 Subject: [PATCH 269/310] fix: option in tuple + example Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/input.txt | 6 ++++-- FSharpActivePatterns/lib/parser.ml | 12 ++++++------ 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/bin/input.txt b/FSharpActivePatterns/bin/input.txt index 4be39a852..5b3b65edb 100644 --- a/FSharpActivePatterns/bin/input.txt +++ b/FSharpActivePatterns/bin/input.txt @@ -4,6 +4,8 @@ let a, b = 1, 2;; if 1, 2 then (3, 4) else ((0, 1), 0);; -match (1, 2) with +match Some a b, 2 with | 3, 4 -> None -| (5, 6) -> None;; \ No newline at end of file +| 5, 6 -> None;; + +let x, Some y = 1, Some 2;; \ No newline at end of file diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index e6cac4974..68ca14130 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -248,9 +248,9 @@ let p_pat = *> fix (fun self -> let atom = choice [ p_pat_const; p_parens self ] in let semicolon_list = p_semicolon_list_pat (self <|> atom) <|> atom in - let tuple = p_tuple make_tuple_pat semicolon_list <|> semicolon_list in - let opt = p_option tuple make_option_pat <|> tuple in - let cons = p_cons_list_pat opt in + let opt = p_option semicolon_list make_option_pat <|> semicolon_list in + let tuple = p_tuple make_tuple_pat opt <|> opt in + let cons = p_cons_list_pat tuple in cons) ;; @@ -356,9 +356,9 @@ let p_expr = in let if_expr = p_if (p_expr <|> atom) <|> atom in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in - let tuple = p_tuple make_tuple_expr letin_expr <|> letin_expr in - let option = p_option tuple make_option_expr <|> tuple in - let apply = p_apply option <|> option in + let option = p_option letin_expr make_option_expr <|> letin_expr in + let tuple = p_tuple make_tuple_expr option <|> option in + let apply = p_apply tuple <|> tuple in let unary = choice [ unary_chain p_not apply; unary_chain unminus apply ] in let factor = chainl1 unary (mul <|> div) in let term = chainl1 factor (add <|> sub) in From 715d0525a02c346e68cb55a065eb910c88459c38 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 16:27:11 +0300 Subject: [PATCH 270/310] feat: types in arguments of application Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 8 ++++-- FSharpActivePatterns/lib/astPrinter.ml | 12 +++------ FSharpActivePatterns/lib/inferencer.ml | 12 +++++++-- FSharpActivePatterns/lib/parser.ml | 25 ++++++++++++++++--- FSharpActivePatterns/lib/prettyPrinter.ml | 6 +++-- FSharpActivePatterns/lib/tests/ast_printer.ml | 6 ++--- .../lib/tests/qcheck_utils.ml | 7 +++--- 7 files changed, 52 insertions(+), 24 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index ef4833d47..f2993d624 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -135,8 +135,7 @@ and expr = * (typed_pattern list [@gen QCheck.Gen.(list_size (0 -- 2) (gen_typed_pattern_sized (n / 20)))]) * expr (** fun x y -> x + y *) - | Apply of (expr[@gen gen_expr_sized (n / 4)]) * (expr[@gen gen_expr_sized (n / 4)]) - (** [sum 1 ] *) + | Apply of (expr[@gen gen_expr_sized (n / 4)]) * typed_expr (** [sum 1 ] *) | Function of (case[@gen gen_case_sized (n / 4)]) * (case list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_case_sized (n / 20)))]) @@ -155,6 +154,11 @@ and expr = | Option of expr option (** [int option] *) [@@deriving show { with_path = false }, qcheck] +and typed_expr = + (expr[@gen gen_expr_sized (n / 4)]) + * (typ option[@gen QCheck.Gen.(option (gen_typ_sized (n / 4)))]) +[@@deriving show { with_path = false }, qcheck] + and let_bind = | Let_bind of (typed_pattern[@gen gen_typed_pattern_sized (n / 2)]) diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index c2eca1025..a65e95c3f 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -64,13 +64,8 @@ let print_unary_op indent fmt = function | Unary_not -> fprintf fmt "%s| Unary negative\n" (String.make indent '-') ;; -let case_to_pair = function - | p, e -> p, e -;; - -let tpattern_to_pattern = function - | p, _ -> p -;; +let tpattern_to_pattern = fst +let texpr_to_expr = fst let rec print_let_bind indent fmt = function | Let_bind (name, args, body) -> @@ -100,7 +95,6 @@ and print_expr indent fmt expr = fprintf fmt "%s| Tuple:\n" (String.make indent '-'); List.iter (print_expr (indent + 2) fmt) (e1 :: e2 :: rest) | Function ((pat1, expr1), cases) -> - let cases = List.map case_to_pair cases in fprintf fmt "%s| Function:\n" (String.make indent '-'); List.iter (fun (pat, expr) -> @@ -110,7 +104,6 @@ and print_expr indent fmt expr = print_expr (indent + 4) fmt expr) ((pat1, expr1) :: cases) | Match (value, (pat1, expr1), cases) -> - let cases = List.map case_to_pair cases in fprintf fmt "%s| Match:\n" (String.make indent '-'); fprintf fmt "%s| Value:\n" (String.make (indent + 2) '-'); print_expr (indent + 4) fmt value; @@ -152,6 +145,7 @@ and print_expr indent fmt expr = fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 4) fmt body | Apply (func, arg) -> + let arg = texpr_to_expr arg in fprintf fmt "%s| Apply:\n" (String.make indent '-'); fprintf fmt "%sFUNCTION\n" (String.make (indent + 2) ' '); print_expr (indent + 2) fmt func; diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index bfd20b917..feb6568b0 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -523,7 +523,7 @@ let rec infer_expr env = function let* e_subst, e_typ = infer_expr env e in let* subst = unify op_typ (Substitution.apply e_subst e_typ) in let* subst_result = Substitution.compose_all [ e_subst; subst ] in - return (subst_result, e_typ) + return (subst_result, Substitution.apply subst e_typ) | Bin_expr (op, e1, e2) -> let* subst1, typ1 = infer_expr env e1 in let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) e2 in @@ -608,7 +608,7 @@ let rec infer_expr env = function return (subst_result, Substitution.apply subst2 typ2) | Apply (f, arg) -> let* subst1, typ1 = infer_expr env f in - let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) arg in + let* subst2, typ2 = infer_typed_expr (TypeEnvironment.apply subst1 env) arg in let typ1 = Substitution.apply subst2 typ1 in let* fresh_var = make_fresh_var in let* subst3 = unify typ1 (Arrow (typ2, fresh_var)) in @@ -668,6 +668,14 @@ let rec infer_expr env = function in return (subst, return_type) +and infer_typed_expr env = function + | expr, Some typ -> + let* subst1, expr_typ = infer_expr env expr in + let* subst2 = unify expr_typ (Substitution.apply subst1 typ) in + let* subst_result = Substitution.compose subst1 subst2 in + return (subst_result, Substitution.apply subst2 expr_typ) + | expr, None -> infer_expr env expr + and extend_env_with_let_binds env is_rec let_binds = List.fold let_binds diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 68ca14130..47a586626 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -25,7 +25,13 @@ let peek_sep1 = match c with | None -> return None | Some c -> - if is_ws c || Char.equal c '(' || Char.equal c ')' || Char.equal c ',' || Char.equal c ']' || Char.equal c ';' + if is_ws c + || Char.equal c '(' + || Char.equal c ')' + || Char.equal c ',' + || Char.equal c ']' + || Char.equal c ':' + || Char.equal c ';' then return (Some c) else fail "need a delimiter" ;; @@ -295,7 +301,19 @@ let p_let p_expr = ;; let p_apply p_expr = - chainl1 (p_expr <* peek_sep1) (return (fun expr1 expr2 -> Apply (expr1, expr2))) + let* func = p_expr <* peek_sep1 in + let p_typed_arg = + p_parens + (let* arg = p_expr in + let* typ = p_type in + return (arg, Some typ)) + in + let p_not_typed_arg = + let* expr = p_expr <* peek_sep1 in + return (expr, None) + in + let* args = many (p_typed_arg <|> p_not_typed_arg) in + return (List.fold args ~init:func ~f:(fun acc arg -> Apply (acc, arg))) ;; let p_lambda p_expr = @@ -337,7 +355,8 @@ let p_inf_oper_expr p_expr = p_expr (p_inf_oper >>= fun op -> - return (fun expr1 expr2 -> Apply (Apply (Variable op, expr1), expr2))) + return (fun expr1 expr2 -> + Apply (Apply (Variable op, (expr1, None)), (expr2, None)))) ;; let p_expr = diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 566641c9c..29aa5ba82 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -117,10 +117,12 @@ and pp_expr fmt expr = | None -> fprintf fmt "%a" pp_pattern pat) args; fprintf fmt "-> %a " pp_expr body - | Apply (Apply (Variable (Ident op), left), right) + | Apply (Apply (Variable (Ident op), (left, None)), (right, None)) when String.for_all (fun c -> String.contains "!$%&*+-./:<=>?@^|~" c) op -> fprintf fmt "(%a) %s (%a)" pp_expr left op pp_expr right - | Apply (func, arg) -> fprintf fmt "(%a) (%a)" pp_expr func pp_expr arg + | Apply (func, (arg, Some t)) -> + fprintf fmt "(%a) (%a : %a)" pp_expr func pp_expr arg pp_typ t + | Apply (func, (arg, None)) -> fprintf fmt "(%a) (%a)" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> fprintf fmt "let %a " pp_rec_flag rec_flag; pp_print_list diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index 4f738e046..62dd1220c 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -23,14 +23,14 @@ let%expect_test "print Ast factorial" = , Variable (Ident "n") , Apply ( Variable (Ident "factorial") - , Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) - ) )) ) ) + , ( Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) + , None ) ) )) ) ) in let program = [ Statement (Let (Nonrec, Let_bind ((PVar (Ident "a"), None), [], Const (Int_lt 10)), [])) ; Expr factorial - ; Expr (Apply (factorial, Variable (Ident "a"))) + ; Expr (Apply (factorial, (Variable (Ident "a"), None))) ] in List.iter (print_construction std_formatter) program; diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index 6cf6c8323..052d2b347 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -64,10 +64,11 @@ and shrink_expr = <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list >|= fun a' -> LetIn (rec_flag, let_bind, a', inner_e)) <+> (shrink_expr inner_e >|= fun a' -> LetIn (rec_flag, let_bind, let_bind_list, a')) - | Apply (f, arg) -> + | Apply (f, (arg, None)) -> of_list [ f; arg ] - <+> (shrink_expr f >|= fun a' -> Apply (a', arg)) - <+> (shrink_expr arg >|= fun a' -> Apply (f, a')) + <+> (shrink_expr f >|= fun a' -> Apply (a', (arg, None))) + <+> (shrink_expr arg >|= fun a' -> Apply (f, (a', None))) + | Apply (f, (arg, Some _)) -> return (Apply (f, (arg, None))) | Lambda (pat, pat_list, body) -> shrink_expr body >|= (fun body' -> Lambda (pat, pat_list, body')) From 0c5ce912f9c87496d46c602248177e3f57fbba38 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Thu, 19 Dec 2024 16:50:44 +0300 Subject: [PATCH 271/310] feat: match with single argument Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 47a586626..963c57f84 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -333,6 +333,13 @@ let p_case p_expr = return (pat, expr) ;; +let p_single_case_match p_expr = + let* value = skip_ws *> string "match" *> p_expr <* skip_ws <* string "with" in + let* pat = skip_ws *> p_pat <* skip_ws <* string "->" in + let* expr = p_expr in + return (Match(value, (pat, expr), [])) +;; + let p_match p_expr = let* value = skip_ws *> string "match" *> p_expr <* skip_ws <* string "with" in let* pat1, expr1 = p_case p_expr in @@ -393,7 +400,8 @@ let p_expr = let inf_oper = p_inf_oper_expr comp_or <|> comp_or in let p_function = p_function (p_expr <|> inf_oper) <|> inf_oper in let ematch = p_match (p_expr <|> p_function) <|> p_function in - let efun = p_lambda (p_expr <|> ematch) <|> ematch in + let e_sin_match = p_single_case_match ematch <|> ematch in + let efun = p_lambda (p_expr <|> e_sin_match) <|> e_sin_match in efun) ;; From 4c8fc613ff8b39a0323c5f54b05c0d466e11ff04 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Thu, 19 Dec 2024 16:59:01 +0300 Subject: [PATCH 272/310] feat: first case in function and match Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 963c57f84..404482ca5 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -333,16 +333,15 @@ let p_case p_expr = return (pat, expr) ;; -let p_single_case_match p_expr = - let* value = skip_ws *> string "match" *> p_expr <* skip_ws <* string "with" in - let* pat = skip_ws *> p_pat <* skip_ws <* string "->" in +let p_first_case p_expr = + let* pat = skip_ws *> ((string "|" *> p_pat) <|> p_pat) <* skip_ws <* string "->" in let* expr = p_expr in - return (Match(value, (pat, expr), [])) + return (pat, expr) ;; let p_match p_expr = let* value = skip_ws *> string "match" *> p_expr <* skip_ws <* string "with" in - let* pat1, expr1 = p_case p_expr in + let* pat1, expr1 = p_first_case p_expr in let* cases = many (p_case p_expr) in return (Match (value, (pat1, expr1), cases)) ;; @@ -351,7 +350,7 @@ let p_function p_expr = skip_ws *> string "function" *> - let* pat1, expr1 = p_case p_expr in + let* pat1, expr1 = p_first_case p_expr in let* cases = many (p_case p_expr) in return (Function ((pat1, expr1), cases)) ;; @@ -400,8 +399,7 @@ let p_expr = let inf_oper = p_inf_oper_expr comp_or <|> comp_or in let p_function = p_function (p_expr <|> inf_oper) <|> inf_oper in let ematch = p_match (p_expr <|> p_function) <|> p_function in - let e_sin_match = p_single_case_match ematch <|> ematch in - let efun = p_lambda (p_expr <|> e_sin_match) <|> e_sin_match in + let efun = p_lambda (p_expr <|> ematch) <|> ematch in efun) ;; From 000c7d503a89ed8e7659e1d5cd773c8c8f7a9d31 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 17:09:53 +0300 Subject: [PATCH 273/310] fix: order of application and tuple --- FSharpActivePatterns/lib/parser.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 404482ca5..bd873783f 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -334,7 +334,7 @@ let p_case p_expr = ;; let p_first_case p_expr = - let* pat = skip_ws *> ((string "|" *> p_pat) <|> p_pat) <* skip_ws <* string "->" in + let* pat = skip_ws *> (string "|" *> p_pat <|> p_pat) <* skip_ws <* string "->" in let* expr = p_expr in return (pat, expr) ;; @@ -382,9 +382,9 @@ let p_expr = let if_expr = p_if (p_expr <|> atom) <|> atom in let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in let option = p_option letin_expr make_option_expr <|> letin_expr in - let tuple = p_tuple make_tuple_expr option <|> option in - let apply = p_apply tuple <|> tuple in - let unary = choice [ unary_chain p_not apply; unary_chain unminus apply ] in + let apply = p_apply option <|> option in + let tuple = p_tuple make_tuple_expr apply <|> apply in + let unary = choice [ unary_chain p_not tuple; unary_chain unminus tuple ] in let factor = chainl1 unary (mul <|> div) in let term = chainl1 factor (add <|> sub) in let cons_op = chainr1 term cons in From 03500c139d2635e339d106f0f60cfc22e9fb4cf9 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 17:10:09 +0300 Subject: [PATCH 274/310] fix: -dparsetree option in REPL Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 1cf7a814e..e0c194edc 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -72,23 +72,23 @@ let run_repl dump_parsetree input_file = run_repl_helper run env state | End -> () | Result ast -> - let result = infer ast env state in - (match result with - | new_state, Error err -> - fprintf err_formatter "Type checking failed: %a\n" pp_error err; - print_flush (); - run_repl_helper run env new_state - | new_state, Ok (env, types) -> - (match dump_parsetree with - | true -> print_construction std_formatter ast - | false -> + (match dump_parsetree with + | true -> print_construction std_formatter ast + | false -> + let result = infer ast env state in + (match result with + | new_state, Error err -> + fprintf err_formatter "Type checking failed: %a\n" pp_error err; + print_flush (); + run_repl_helper run env new_state + | new_state, Ok (env, types) -> List.iter (fun t -> fprintf std_formatter "- : "; pp_typ std_formatter t) types; - print_flush ()); - run_repl_helper run env new_state) + print_flush (); + run_repl_helper run env new_state)) in let env = TypeEnvironment.extend From 50bd7973c235cd98ebd7321911fc4f34ba327105 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 18:26:05 +0300 Subject: [PATCH 275/310] fix: generalizing in type inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 49 ++++++++++++++++---------- 1 file changed, 30 insertions(+), 19 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index feb6568b0..bc16cd180 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -167,6 +167,7 @@ module Substitution : sig val unify : typ -> typ -> t R.t val compose : t -> t -> t R.t val compose_all : t list -> t R.t + (* val pp : formatter -> t -> unit *) end = struct open R open R.Syntax @@ -178,6 +179,12 @@ end = struct (* empty map *) let empty = Map.empty (module Int) + (* let pp fmt s = + Map.iter_keys s ~f:(fun k -> + let v = Map.find_exn s k in + fprintf fmt "%d: %a" k pp_typ v) + ;; *) + (* perform mapping of fresh var to typ with occurs check, if correct, output new pair *) let mapping k v = if Type.occurs_in k v then fail `Occurs_check else return (k, v) @@ -266,6 +273,7 @@ module Scheme : sig (* val occurs_in : fresh -> t -> bool *) val apply : Substitution.t -> t -> t val free_vars : t -> binder_set + (* val pp : formatter -> t -> unit *) end = struct type t = scheme @@ -274,6 +282,10 @@ end = struct | S (vars, t) -> (not (VarSet.mem value vars)) && Type.occurs_in value t ;; *) + (* let pp fmt = function + | Scheme (binder_s, t) -> fprintf fmt "%a %a" VarSet.pp binder_s pp_typ t + ;; *) + (* take all vars that are not bound in typ *) let free_vars = function | Scheme (vars, t) -> VarSet.diff (Type.free_vars t) vars @@ -301,8 +313,8 @@ module TypeEnvironment : sig val find_exn : t -> string -> scheme val find_typ_exn : t -> string -> typ val find_typ : t -> string -> typ option - val remove : t -> string -> t - (* val pp : t -> formatter -> unit *) + val remove_many : t -> string list -> t + (* val pp : formatter -> t -> unit *) end = struct open Base @@ -318,6 +330,7 @@ end = struct ;; let remove = Map.remove + let remove_many t keys = List.fold ~init:t keys ~f:(fun acc k -> remove acc k) let empty = Map.empty (module String) (* apply given substitution to all elements of environment *) @@ -336,10 +349,10 @@ end = struct | Scheme (_, typ) -> typ ;; - (* let pp t fmt = + (* let pp fmt t = Map.iter_keys t ~f:(fun k -> - let v = find_typ_exn t k in - fprintf fmt "%s : %a" k pp_typ v) + let (Scheme (binder_s, typ)) = find_exn t k in + fprintf fmt "%s : %a %a" k VarSet.pp binder_s pp_typ typ) ;; *) (* collect all free vars from environment *) @@ -375,12 +388,6 @@ let generalize env typ = Scheme (free, typ) ;; -let generalize_rec env typ rec_name = - let env = TypeEnvironment.remove env rec_name in - let free = VarSet.diff (Type.free_vars typ) (TypeEnvironment.free_vars env) in - Scheme (free, typ) -;; - let infer_lt = function | Int_lt _ -> return int_typ | Bool_lt _ -> return bool_typ @@ -461,7 +468,7 @@ let infer_typed_patterns env ~shadow patterns = return (new_env, typ :: typs)) ;; -let extract_names_from_pattern = +let extract_names_from_tpattern = let rec helper = function | PVar (Ident name) -> [ name ] | PList l -> List.concat (List.map l ~f:helper) @@ -475,10 +482,15 @@ let extract_names_from_pattern = | pat, _ -> helper pat ;; +let extract_names_from_tpatterns pats = + List.fold pats ~init:[] ~f:(fun acc p -> + List.concat [ acc; extract_names_from_tpattern p ]) +;; + let extract_bind_names_from_let_binds let_binds = List.concat (List.map let_binds ~f:(function Let_bind (pat, _, _) -> - extract_names_from_pattern pat)) + extract_names_from_tpattern pat)) ;; let extract_bind_patterns_from_let_binds let_binds = @@ -702,13 +714,12 @@ and infer_let_bind env is_rec let_bind = let* subst2 = unify (Substitution.apply subst1 name_type) bind_type in let* subst = Substitution.compose subst1 subst2 in let env = TypeEnvironment.apply subst env in - let names = extract_names_from_pattern name in + let names = extract_names_from_tpattern name in + let arg_names = extract_names_from_tpatterns args in + let names_types = List.map names ~f:(fun n -> n, TypeEnvironment.find_typ_exn env n) in + let env = TypeEnvironment.remove_many env (List.concat [ names; arg_names ]) in let names_schemes_list = - List.map names ~f:(fun name -> - let name_type = TypeEnvironment.find_typ_exn env name in - match is_rec with - | Rec -> name, generalize_rec env name_type name - | Nonrec -> name, generalize env name_type) + List.map names_types ~f:(fun (name, name_type) -> name, generalize env name_type) in return (subst, names_schemes_list) ;; From 4dd532d746091e6f567c0ea72c76fbaef3a7ca5f Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 18:26:17 +0300 Subject: [PATCH 276/310] ref: pattern parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index bd873783f..0bbe31f7d 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -255,7 +255,7 @@ let p_pat = let atom = choice [ p_pat_const; p_parens self ] in let semicolon_list = p_semicolon_list_pat (self <|> atom) <|> atom in let opt = p_option semicolon_list make_option_pat <|> semicolon_list in - let tuple = p_tuple make_tuple_pat opt <|> opt in + let tuple = p_tuple_pat opt <|> opt in let cons = p_cons_list_pat tuple in cons) ;; From ea6d00a3eff4066d8d348bd242cec3d7a5266b9b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 19:06:49 +0300 Subject: [PATCH 277/310] fix: match inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index bc16cd180..f0d5e2122 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -672,10 +672,11 @@ let rec infer_expr env = function let* subst1, return_type = acc in let* env, pat = infer_pattern env ~shadow:true pat in let* subst2 = unify match_type pat in - let env = TypeEnvironment.apply subst2 env in + let* subst12 = Substitution.compose subst1 subst2 in + let env = TypeEnvironment.apply subst12 env in let* subst3, expr_typ = infer_expr env expr in let* subst4 = unify return_type expr_typ in - let* subst = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in + let* subst = Substitution.compose_all [ subst12; subst3; subst4 ] in return (subst, Substitution.apply subst return_type)) in return (subst, return_type) From ed98eb34e6f1fa5cd5a1191c7fca92ec6ec32ab1 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 19:57:12 +0300 Subject: [PATCH 278/310] fix: LetIn inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 35 +++++++++++--------------- 1 file changed, 14 insertions(+), 21 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index f0d5e2122..5fca01ec6 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -633,15 +633,13 @@ let rec infer_expr env = function | LetIn (Rec, let_bind, let_binds, e) -> let let_binds = let_bind :: let_binds in let* env = extend_env_with_bind_names env let_binds in - let* env, subst1 = extend_env_with_let_binds env Rec let_binds in - let* subst2, typ = infer_expr env e in - let* subst_final = Substitution.compose subst1 subst2 in - return (subst_final, typ) + let* env = extend_env_with_let_binds env Rec let_binds in + let* subst, typ = infer_expr env e in + return (subst, typ) | LetIn (Nonrec, let_bind, let_binds, e) -> - let* env, subst1 = extend_env_with_let_binds env Nonrec (let_bind :: let_binds) in - let* subst2, typ = infer_expr env e in - let* subst_final = Substitution.compose subst1 subst2 in - return (subst_final, typ) + let* env = extend_env_with_let_binds env Nonrec (let_bind :: let_binds) in + let* subst, typ = infer_expr env e in + return (subst, typ) | Function ((p1, e1), rest) -> let* arg_type = make_fresh_var in let* return_type = make_fresh_var in @@ -690,16 +688,11 @@ and infer_typed_expr env = function | expr, None -> infer_expr env expr and extend_env_with_let_binds env is_rec let_binds = - List.fold - let_binds - ~init:(return (env, Substitution.empty)) - ~f:(fun acc let_bind -> - let* env, subst_acc = acc in - let* subst, names_schemes_list = infer_let_bind env is_rec let_bind in - let env = TypeEnvironment.extend_many env names_schemes_list in - let env = TypeEnvironment.apply subst env in - let* subst_acc = Substitution.compose subst_acc subst in - return (env, subst_acc)) + List.fold let_binds ~init:(return env) ~f:(fun acc let_bind -> + let* env = acc in + let* names_schemes_list = infer_let_bind env is_rec let_bind in + let env = TypeEnvironment.extend_many env names_schemes_list in + return env) and infer_let_bind env is_rec let_bind = let* (Let_bind (name, args, e)) = check_let_bind_correctness is_rec let_bind in @@ -722,14 +715,14 @@ and infer_let_bind env is_rec let_bind = let names_schemes_list = List.map names_types ~f:(fun (name, name_type) -> name, generalize env name_type) in - return (subst, names_schemes_list) + return names_schemes_list ;; let infer_statement env = function | Let (Rec, let_bind, let_binds) -> let let_binds = let_bind :: let_binds in let* env = extend_env_with_bind_names env let_binds in - let* env, _ = extend_env_with_let_binds env Rec let_binds in + let* env = extend_env_with_let_binds env Rec let_binds in let bind_names = extract_bind_names_from_let_binds let_binds in let bind_types = List.map bind_names ~f:(fun name -> @@ -739,7 +732,7 @@ let infer_statement env = function return (env, bind_types) | Let (Nonrec, let_bind, let_binds) -> let let_binds = let_bind :: let_binds in - let* env, _ = extend_env_with_let_binds env Nonrec let_binds in + let* env = extend_env_with_let_binds env Nonrec let_binds in let bind_names = extract_bind_names_from_let_binds let_binds in let bind_types = List.map bind_names ~f:(fun name -> From 1c22029f38374bd6576cc46cb728bd8b31d8b4ce Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 22:37:33 +0300 Subject: [PATCH 279/310] feat: implement pattern and expr Constraints Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 24 +++---- FSharpActivePatterns/lib/astPrinter.ml | 14 ++--- FSharpActivePatterns/lib/inferencer.ml | 62 +++++++++---------- FSharpActivePatterns/lib/keywordChecker.ml | 2 + FSharpActivePatterns/lib/parser.ml | 58 ++++++++--------- FSharpActivePatterns/lib/prettyPrinter.ml | 30 +++------ FSharpActivePatterns/lib/tests/ast_printer.ml | 15 +++-- .../lib/tests/qcheck_utils.ml | 22 +++---- 8 files changed, 91 insertions(+), 136 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index f2993d624..1fe2a60af 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -98,11 +98,10 @@ type pattern = | PConst of literal (** | [4] -> *) | PVar of ident (** pattern identifier *) | POption of pattern option - (*| Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) *) + (*| Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) *) + | PConstraint of pattern * (typ[@gen gen_typ_sized (n / 4)]) [@@deriving show { with_path = false }, qcheck] -type typed_pattern = pattern * typ option [@@deriving show { with_path = false }] - let gen_typed_pattern_sized n = QCheck.Gen.(pair (gen_pattern_sized n) (return None)) type is_recursive = @@ -131,11 +130,11 @@ and expr = * (expr option[@gen QCheck.Gen.option (gen_expr_sized (n / 4))]) (** [if n % 2 = 0 then "Even" else "Odd"] *) | Lambda of - (typed_pattern[@gen gen_typed_pattern_sized (n / 2)]) - * (typed_pattern list - [@gen QCheck.Gen.(list_size (0 -- 2) (gen_typed_pattern_sized (n / 20)))]) + (pattern[@gen gen_pattern_sized (n / 2)]) + * (pattern list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_pattern_sized (n / 20)))]) * expr (** fun x y -> x + y *) - | Apply of (expr[@gen gen_expr_sized (n / 4)]) * typed_expr (** [sum 1 ] *) + | Apply of (expr[@gen gen_expr_sized (n / 4)]) * (expr[@gen gen_expr_sized (n / 4)]) + (** [sum 1 ] *) | Function of (case[@gen gen_case_sized (n / 4)]) * (case list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_case_sized (n / 20)))]) @@ -152,18 +151,13 @@ and expr = [@gen QCheck.Gen.(list_size (0 -- 2) (gen_let_bind_sized (n / 20)))]) * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) -[@@deriving show { with_path = false }, qcheck] - -and typed_expr = - (expr[@gen gen_expr_sized (n / 4)]) - * (typ option[@gen QCheck.Gen.(option (gen_typ_sized (n / 4)))]) + | EConstraint of expr * (typ[@gen gen_typ_sized (n / 4)]) [@@deriving show { with_path = false }, qcheck] and let_bind = | Let_bind of - (typed_pattern[@gen gen_typed_pattern_sized (n / 2)]) - * (typed_pattern list - [@gen QCheck.Gen.(list_size (0 -- 3) (gen_typed_pattern_sized (n / 4)))]) + (pattern[@gen gen_pattern_sized (n / 2)]) + * (pattern list[@gen QCheck.Gen.(list_size (0 -- 3) (gen_pattern_sized (n / 4)))]) * expr (** [let sum n m = n + m] *) [@@deriving show { with_path = false }, qcheck] diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index a65e95c3f..7a30841a0 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -57,6 +57,7 @@ let rec print_pattern indent fmt = function | Some p -> fprintf fmt "Some:\n"; print_pattern (indent + 2) fmt p) + | PConstraint (p, _) -> print_pattern indent fmt p ;; let print_unary_op indent fmt = function @@ -64,13 +65,8 @@ let print_unary_op indent fmt = function | Unary_not -> fprintf fmt "%s| Unary negative\n" (String.make indent '-') ;; -let tpattern_to_pattern = fst -let texpr_to_expr = fst - let rec print_let_bind indent fmt = function | Let_bind (name, args, body) -> - let name = tpattern_to_pattern name in - let args = List.map tpattern_to_pattern args in fprintf fmt "%s| Let_bind:\n" (String.make indent '-'); fprintf fmt "%sNAME:\n" (String.make (indent + 4) ' '); fprintf fmt "%s| %a\n" (String.make (indent + 4) '-') pp_pattern name; @@ -135,17 +131,14 @@ and print_expr indent fmt expr = (match else_body with | Some body -> print_expr (indent + 2) fmt body | None -> fprintf fmt "%s| No else body\n" (String.make (indent + 2) '-')) - | Lambda ((arg1, _), args, body) -> - let pat_list = List.map tpattern_to_pattern args in - (*let args = List.map tag_of_ident args in*) + | Lambda (arg1, args, body) -> fprintf fmt "%s| Lambda:\n" (String.make indent '-'); fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); print_pattern (indent + 4) fmt arg1; - List.iter (fun pat -> print_pattern (indent + 4) fmt pat) pat_list; + List.iter (fun pat -> print_pattern (indent + 4) fmt pat) (arg1 :: args); fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 4) fmt body | Apply (func, arg) -> - let arg = texpr_to_expr arg in fprintf fmt "%s| Apply:\n" (String.make indent '-'); fprintf fmt "%sFUNCTION\n" (String.make (indent + 2) ' '); print_expr (indent + 2) fmt func; @@ -169,6 +162,7 @@ and print_expr indent fmt expr = | Some e -> fprintf fmt "%s| Option: Some\n" (String.make indent '-'); print_expr (indent + 2) fmt e) + | EConstraint (e, _) -> print_expr indent fmt e ;; let print_statement indent fmt = function diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 5fca01ec6..1d77b9c8b 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -447,28 +447,23 @@ let rec infer_pattern env ~shadow = function ~init:(return (env, [])) in return (env, Type_tuple (typ1, typ2, typs_rest)) + | PConstraint (p, t) -> + let* env, inferred_typ = infer_pattern env ~shadow p in + let* subst = unify t inferred_typ in + return (TypeEnvironment.apply subst env, Substitution.apply subst t) ;; -let infer_typed_pattern env ~shadow : typed_pattern -> (TypeEnvironment.t * typ) t - = function - | pat, Some typ -> - let* env, inferred_typ = infer_pattern env ~shadow pat in - let* subst = unify typ inferred_typ in - return (TypeEnvironment.apply subst env, Substitution.apply subst typ) - | pat, None -> infer_pattern env ~shadow pat -;; - -let infer_typed_patterns env ~shadow patterns = +let infer_patterns env ~shadow patterns = List.fold_right patterns ~init:(return (env, [])) ~f:(fun pat acc -> let* old_env, typs = acc in - let* new_env, typ = infer_typed_pattern old_env ~shadow pat in + let* new_env, typ = infer_pattern old_env ~shadow pat in return (new_env, typ :: typs)) ;; -let extract_names_from_tpattern = +let extract_names_from_pattern pat = let rec helper = function | PVar (Ident name) -> [ name ] | PList l -> List.concat (List.map l ~f:helper) @@ -476,21 +471,23 @@ let extract_names_from_tpattern = | PTuple (fst, snd, rest) -> List.concat [ helper fst; helper snd; List.concat (List.map rest ~f:helper) ] | POption (Some p) -> helper p - | _ -> [] + | PConstraint (p, _) -> helper p + | POption None -> [] + | Wild -> [] + | PConst _ -> [] in - function - | pat, _ -> helper pat + helper pat ;; -let extract_names_from_tpatterns pats = +let extract_names_from_patterns pats = List.fold pats ~init:[] ~f:(fun acc p -> - List.concat [ acc; extract_names_from_tpattern p ]) + List.concat [ acc; extract_names_from_pattern p ]) ;; let extract_bind_names_from_let_binds let_binds = List.concat (List.map let_binds ~f:(function Let_bind (pat, _, _) -> - extract_names_from_tpattern pat)) + extract_names_from_pattern pat)) ;; let extract_bind_patterns_from_let_binds let_binds = @@ -503,13 +500,13 @@ let extend_env_with_bind_names env let_binds = List.filter let_binds ~f:(function Let_bind (_, args, _) -> List.length args <> 0) in let bind_names = extract_bind_patterns_from_let_binds let_binds in - let* env, _ = infer_typed_patterns env ~shadow:true bind_names in + let* env, _ = infer_patterns env ~shadow:true bind_names in return env ;; let check_let_bind_correctness is_rec let_bind = match let_bind, is_rec with - | Let_bind ((PVar _, _), _, _), _ -> return let_bind + | Let_bind (PVar _, _, _), _ -> return let_bind | Let_bind _, Rec -> fail `Not_allowed_left_hand_side_let_rec | Let_bind (_, args, _), _ when List.length args <> 0 -> fail `Args_after_not_variable_let @@ -620,14 +617,14 @@ let rec infer_expr env = function return (subst_result, Substitution.apply subst2 typ2) | Apply (f, arg) -> let* subst1, typ1 = infer_expr env f in - let* subst2, typ2 = infer_typed_expr (TypeEnvironment.apply subst1 env) arg in + let* subst2, typ2 = infer_expr (TypeEnvironment.apply subst1 env) arg in let typ1 = Substitution.apply subst2 typ1 in let* fresh_var = make_fresh_var in let* subst3 = unify typ1 (Arrow (typ2, fresh_var)) in let* subst_result = Substitution.compose_all [ subst1; subst2; subst3 ] in return (subst_result, Substitution.apply subst3 fresh_var) | Lambda (arg, args, e) -> - let* env, arg_types = infer_typed_patterns env ~shadow:true (arg :: args) in + let* env, arg_types = infer_patterns env ~shadow:true (arg :: args) in let* subst, e_type = infer_expr env e in return (subst, Substitution.apply subst (arrow_of_types arg_types e_type)) | LetIn (Rec, let_bind, let_binds, e) -> @@ -678,14 +675,11 @@ let rec infer_expr env = function return (subst, Substitution.apply subst return_type)) in return (subst, return_type) - -and infer_typed_expr env = function - | expr, Some typ -> - let* subst1, expr_typ = infer_expr env expr in - let* subst2 = unify expr_typ (Substitution.apply subst1 typ) in + | EConstraint (e, t) -> + let* subst1, e_type = infer_expr env e in + let* subst2 = unify e_type (Substitution.apply subst1 t) in let* subst_result = Substitution.compose subst1 subst2 in - return (subst_result, Substitution.apply subst2 expr_typ) - | expr, None -> infer_expr env expr + return (subst_result, Substitution.apply subst2 e_type) and extend_env_with_let_binds env is_rec let_binds = List.fold let_binds ~init:(return env) ~f:(fun acc let_bind -> @@ -696,20 +690,20 @@ and extend_env_with_let_binds env is_rec let_binds = and infer_let_bind env is_rec let_bind = let* (Let_bind (name, args, e)) = check_let_bind_correctness is_rec let_bind in - let* env, args_types = infer_typed_patterns env ~shadow:true args in + let* env, args_types = infer_patterns env ~shadow:true args in let* subst1, rvalue_type = infer_expr env e in let bind_type = Substitution.apply subst1 (arrow_of_types args_types rvalue_type) in (* If let_bind is recursive, then bind_varname was already in environment *) let* env, name_type = match is_rec with - | Nonrec -> infer_typed_pattern env ~shadow:true name - | Rec -> infer_typed_pattern env ~shadow:false name + | Nonrec -> infer_pattern env ~shadow:true name + | Rec -> infer_pattern env ~shadow:false name in let* subst2 = unify (Substitution.apply subst1 name_type) bind_type in let* subst = Substitution.compose subst1 subst2 in let env = TypeEnvironment.apply subst env in - let names = extract_names_from_tpattern name in - let arg_names = extract_names_from_tpatterns args in + let names = extract_names_from_pattern name in + let arg_names = extract_names_from_patterns args in let names_types = List.map names ~f:(fun n -> n, TypeEnvironment.find_typ_exn env n) in let env = TypeEnvironment.remove_many env (List.concat [ names; arg_names ]) in let names_schemes_list = diff --git a/FSharpActivePatterns/lib/keywordChecker.ml b/FSharpActivePatterns/lib/keywordChecker.ml index 2c85d8868..ff3687d1f 100644 --- a/FSharpActivePatterns/lib/keywordChecker.ml +++ b/FSharpActivePatterns/lib/keywordChecker.ml @@ -20,6 +20,8 @@ let is_keyword = function | "function" | "->" | "|" + | ":" + | "::" | "_" -> true | _ -> false ;; diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 0bbe31f7d..cc483d9b6 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -152,7 +152,6 @@ let p_ident = ;; let p_type = skip_ws *> char ':' *> skip_ws *> p_varname >>| fun s -> Primitive s -let p_type_option = p_type >>| (fun t -> Some t) <|> return None let p_var_expr = p_ident >>| fun ident -> Variable ident let p_var_pat = p_ident >>| fun ident -> PVar ident @@ -249,6 +248,13 @@ let p_pat_const = choice [ p_int_pat; p_bool_pat; p_unit_pat; p_string_pat; p_var_pat; p_wild_pat ] ;; +let p_constraint_pat p_pat = + p_parens + (let* pat = p_pat in + let* typ = p_type in + return (PConstraint (pat, typ))) +;; + let p_pat = skip_ws *> fix (fun self -> @@ -257,24 +263,15 @@ let p_pat = let opt = p_option semicolon_list make_option_pat <|> semicolon_list in let tuple = p_tuple_pat opt <|> opt in let cons = p_cons_list_pat tuple in - cons) -;; - -let p_typed_arg : typed_pattern t = - let typed_pattern = - let* p = p_pat in - let* t = p_type_option in - return (p, t) - in - p_parens typed_pattern <|> (p_pat >>| fun p -> p, None) + let constr = p_constraint_pat cons <|> cons in + constr) ;; let p_let_bind p_expr = let* name = p_pat <|> (p_parens p_inf_oper >>| fun oper -> PVar oper) in - let* args = many p_typed_arg in - let* name_typ = p_type_option <* skip_ws <* string "=" in - let* body = p_expr in - return (Let_bind ((name, name_typ), args, body)) + let* args = many p_pat in + let* body = skip_ws *> string "=" *> p_expr in + return (Let_bind (name, args, body)) ;; let p_letin p_expr = @@ -301,19 +298,7 @@ let p_let p_expr = ;; let p_apply p_expr = - let* func = p_expr <* peek_sep1 in - let p_typed_arg = - p_parens - (let* arg = p_expr in - let* typ = p_type in - return (arg, Some typ)) - in - let p_not_typed_arg = - let* expr = p_expr <* peek_sep1 in - return (expr, None) - in - let* args = many (p_typed_arg <|> p_not_typed_arg) in - return (List.fold args ~init:func ~f:(fun acc arg -> Apply (acc, arg))) + chainl1 (p_expr <* peek_sep1) (return (fun expr1 expr2 -> Apply (expr1, expr2))) ;; let p_lambda p_expr = @@ -321,8 +306,8 @@ let p_lambda p_expr = *> string "fun" *> peek_sep1 *> - let* arg1 = p_typed_arg in - let* args = many p_typed_arg <* skip_ws <* string "->" in + let* arg1 = p_pat in + let* args = many p_pat <* skip_ws <* string "->" in let* body = p_expr in return (Lambda (arg1, args, body)) ;; @@ -361,8 +346,14 @@ let p_inf_oper_expr p_expr = p_expr (p_inf_oper >>= fun op -> - return (fun expr1 expr2 -> - Apply (Apply (Variable op, (expr1, None)), (expr2, None)))) + return (fun expr1 expr2 -> Apply (Apply (Variable op, expr1), expr2))) +;; + +let p_constraint_expr p_expr = + p_parens + (let* expr = p_expr in + let* typ = p_type in + return (EConstraint (expr, typ))) ;; let p_expr = @@ -400,7 +391,8 @@ let p_expr = let p_function = p_function (p_expr <|> inf_oper) <|> inf_oper in let ematch = p_match (p_expr <|> p_function) <|> p_function in let efun = p_lambda (p_expr <|> ematch) <|> ematch in - efun) + let constr = p_constraint_expr (p_expr <|> efun) <|> efun in + constr) ;; let p_statement = p_let p_expr diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index 29aa5ba82..e4eeb1117 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -56,6 +56,7 @@ let rec pp_pattern fmt = function (match p with | None -> fprintf fmt "None " | Some p -> fprintf fmt "Some (%a) " pp_pattern p) + | PConstraint (p, t) -> fprintf fmt "(%a : %a) " pp_pattern p pp_typ t and pp_expr fmt expr = match expr with @@ -103,26 +104,13 @@ and pp_expr fmt expr = | Some body -> fprintf fmt "else %a " pp_expr body | None -> ()) | Lambda (arg1, args, body) -> - let args = - List.map - (function - | p, t -> p, t) - (arg1 :: args) - in fprintf fmt "fun "; - List.iter - (fun (pat, typ) -> - match typ with - | Some t -> fprintf fmt "(%a:%a) " pp_pattern pat pp_typ t - | None -> fprintf fmt "%a" pp_pattern pat) - args; + List.iter (fun pat -> fprintf fmt "(%a) " pp_pattern pat) (arg1 :: args); fprintf fmt "-> %a " pp_expr body - | Apply (Apply (Variable (Ident op), (left, None)), (right, None)) + | Apply (Apply (Variable (Ident op), left), right) when String.for_all (fun c -> String.contains "!$%&*+-./:<=>?@^|~" c) op -> fprintf fmt "(%a) %s (%a)" pp_expr left op pp_expr right - | Apply (func, (arg, Some t)) -> - fprintf fmt "(%a) (%a : %a)" pp_expr func pp_expr arg pp_typ t - | Apply (func, (arg, None)) -> fprintf fmt "(%a) (%a)" pp_expr func pp_expr arg + | Apply (func, arg) -> fprintf fmt "(%a) %a" pp_expr func pp_expr arg | LetIn (rec_flag, let_bind, let_bind_list, in_expr) -> fprintf fmt "let %a " pp_rec_flag rec_flag; pp_print_list @@ -136,23 +124,19 @@ and pp_expr fmt expr = (match e with | None -> fprintf fmt "None " | Some e -> fprintf fmt "Some (%a)" pp_expr e) + | EConstraint (e, t) -> fprintf fmt "(%a : %a) " pp_expr e pp_typ t and pp_args fmt args = let open Format in pp_print_list ~pp_sep:pp_print_space - (fun fmt -> function - | argname, Some typ -> fprintf fmt "(%a:%a)" pp_pattern argname pp_typ typ - | argname, None -> fprintf fmt "%a" pp_pattern argname) + (fun fmt arg -> fprintf fmt "%a" pp_pattern arg) fmt args and pp_let_bind fmt = function | Let_bind (name, args, body) -> - (match name with - | pat, Some typ -> - fprintf fmt "%a %a :%a = %a " pp_pattern pat pp_args args pp_typ typ pp_expr body - | pat, None -> fprintf fmt "%a %a = %a " pp_pattern pat pp_args args pp_expr body) + fprintf fmt "%a %a = %a " pp_pattern name pp_args args pp_expr body ;; let pp_statement fmt = function diff --git a/FSharpActivePatterns/lib/tests/ast_printer.ml b/FSharpActivePatterns/lib/tests/ast_printer.ml index 62dd1220c..c68ae1950 100644 --- a/FSharpActivePatterns/lib/tests/ast_printer.ml +++ b/FSharpActivePatterns/lib/tests/ast_printer.ml @@ -9,7 +9,7 @@ open Format let%expect_test "print Ast factorial" = let factorial = Lambda - ( (PConst (Int_lt 4), None) + ( PConst (Int_lt 4) , [] , If_then_else ( Bin_expr @@ -23,14 +23,13 @@ let%expect_test "print Ast factorial" = , Variable (Ident "n") , Apply ( Variable (Ident "factorial") - , ( Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) - , None ) ) )) ) ) + , Bin_expr (Binary_subtract, Variable (Ident "n"), Const (Int_lt 1)) + ) )) ) ) in let program = - [ Statement - (Let (Nonrec, Let_bind ((PVar (Ident "a"), None), [], Const (Int_lt 10)), [])) + [ Statement (Let (Nonrec, Let_bind (PVar (Ident "a"), [], Const (Int_lt 10)), [])) ; Expr factorial - ; Expr (Apply (factorial, (Variable (Ident "a"), None))) + ; Expr (Apply (factorial, Variable (Ident "a"))) ] in List.iter (print_construction std_formatter) program; @@ -108,7 +107,7 @@ let%expect_test "print Ast factorial" = let%expect_test "print Ast double func" = let ident = Ident "n" in - let pat = PConst (Int_lt 4), None in + let pat = PConst (Int_lt 4) in let args = [] in let binary_expr = Bin_expr (Binary_multiply, Const (Int_lt 2), Variable ident) in let double = Lambda (pat, args, binary_expr) in @@ -199,7 +198,7 @@ let%expect_test "print Ast of LetIn" = Expr (LetIn ( Nonrec - , Let_bind ((PVar (Ident "x"), None), [], Const (Int_lt 5)) + , Let_bind (PVar (Ident "x"), [], Const (Int_lt 5)) , [] , Bin_expr (Binary_add, Variable (Ident "x"), Const (Int_lt 5)) )) in diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index 052d2b347..919b76081 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -28,11 +28,8 @@ let rec shrink_let_bind = | Let_bind (name, args, e) -> shrink_expr e >|= (fun a' -> Let_bind (name, args, a')) - <+> (QCheck.Shrink.list (List.map fst args) - >|= fun a' -> - let a' = List.map (fun p -> p, None) a' in - Let_bind (name, a', e)) - <+> (shrink_pattern (fst name) >|= fun a' -> Let_bind ((a', None), args, e)) + <+> (QCheck.Shrink.list args >|= fun a' -> Let_bind (name, a', e)) + <+> (shrink_pattern name >|= fun a' -> Let_bind (a', args, e)) and shrink_expr = let open QCheck.Iter in @@ -64,18 +61,15 @@ and shrink_expr = <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list >|= fun a' -> LetIn (rec_flag, let_bind, a', inner_e)) <+> (shrink_expr inner_e >|= fun a' -> LetIn (rec_flag, let_bind, let_bind_list, a')) - | Apply (f, (arg, None)) -> + | Apply (f, arg) -> of_list [ f; arg ] - <+> (shrink_expr f >|= fun a' -> Apply (a', (arg, None))) - <+> (shrink_expr arg >|= fun a' -> Apply (f, (a', None))) - | Apply (f, (arg, Some _)) -> return (Apply (f, (arg, None))) + <+> (shrink_expr f >|= fun a' -> Apply (a', arg)) + <+> (shrink_expr arg >|= fun a' -> Apply (f, a')) | Lambda (pat, pat_list, body) -> shrink_expr body >|= (fun body' -> Lambda (pat, pat_list, body')) - <+> (QCheck.Shrink.list ~shrink:shrink_pattern (List.map fst pat_list) - >|= fun a' -> - let a' = List.map (fun p -> p, None) a' in - Lambda (pat, a', body)) + <+> (QCheck.Shrink.list ~shrink:shrink_pattern pat_list + >|= fun a' -> Lambda (pat, a', body)) | Function ((pat1, expr1), cases) -> of_list (expr1 :: List.map snd cases) <+> (shrink_pattern pat1 >|= fun a' -> Function ((a', expr1), cases)) @@ -107,6 +101,7 @@ and shrink_expr = of_list [ e; Option None ] <+> (shrink_expr e >|= fun a' -> Option (Some a')) | Option None -> empty | Variable _ -> empty + | EConstraint (e, _) -> return e and shrink_pattern = let open QCheck.Iter in @@ -127,6 +122,7 @@ and shrink_pattern = | POption None -> empty | Wild -> empty | PVar _ -> empty + | PConstraint (p, _) -> return p ;; let shrink_statement = From f618cf7904269cd1cff0d9f117f205bea17426cc Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 23:07:52 +0300 Subject: [PATCH 280/310] fix: Expr constraint parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index cc483d9b6..b27529d65 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -350,10 +350,9 @@ let p_inf_oper_expr p_expr = ;; let p_constraint_expr p_expr = - p_parens - (let* expr = p_expr in - let* typ = p_type in - return (EConstraint (expr, typ))) + let* expr = p_expr in + let* typ = p_type in + return (EConstraint (expr, typ)) ;; let p_expr = @@ -368,6 +367,7 @@ let p_expr = ; p_bool_expr ; p_parens p_expr ; p_semicolon_list_expr p_expr + ; p_parens (p_constraint_expr p_expr) ] in let if_expr = p_if (p_expr <|> atom) <|> atom in @@ -391,8 +391,7 @@ let p_expr = let p_function = p_function (p_expr <|> inf_oper) <|> inf_oper in let ematch = p_match (p_expr <|> p_function) <|> p_function in let efun = p_lambda (p_expr <|> ematch) <|> ematch in - let constr = p_constraint_expr (p_expr <|> efun) <|> efun in - constr) + efun) ;; let p_statement = p_let p_expr From 959d55dd61258dce62846e00647e44651c0a7c8c Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 19 Dec 2024 23:19:14 +0300 Subject: [PATCH 281/310] fix: Pattern constraint parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index b27529d65..f87d8a604 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -249,22 +249,20 @@ let p_pat_const = ;; let p_constraint_pat p_pat = - p_parens - (let* pat = p_pat in - let* typ = p_type in - return (PConstraint (pat, typ))) + let* pat = p_pat in + let* typ = p_type in + return (PConstraint (pat, typ)) ;; let p_pat = skip_ws *> fix (fun self -> - let atom = choice [ p_pat_const; p_parens self ] in + let atom = choice [ p_pat_const; p_parens self; p_parens (p_constraint_pat self) ] in let semicolon_list = p_semicolon_list_pat (self <|> atom) <|> atom in let opt = p_option semicolon_list make_option_pat <|> semicolon_list in let tuple = p_tuple_pat opt <|> opt in let cons = p_cons_list_pat tuple in - let constr = p_constraint_pat cons <|> cons in - constr) + cons) ;; let p_let_bind p_expr = From 298b6b239ab9096627c4ad9daf0708f4264fc541 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 20 Dec 2024 01:25:30 +0300 Subject: [PATCH 282/310] fix: types pretty printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/typesPp.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index 1d836d95e..418cf6366 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -7,7 +7,7 @@ open Format let pp_typ fmt typ = let rec helper fmt = function - | Primitive s -> fprintf fmt "%S" s + | Primitive s -> fprintf fmt "%s" s | Type_var var -> fprintf fmt "'_%d" var | Arrow (fst, snd) -> (match fst with From bd71b8f78a5f196984f94d77eba023d08a26d93b Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 20 Dec 2024 02:59:38 +0300 Subject: [PATCH 283/310] feat: input file now works without delimiters Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 53 +++++++++++++++++++++--------- FSharpActivePatterns/bin/dune | 2 +- FSharpActivePatterns/bin/input.txt | 44 +++++++++++++++++++++---- 3 files changed, 75 insertions(+), 24 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index e0c194edc..7481463cf 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -43,8 +43,8 @@ let input_upto_sep sep ic = fill_buffer buffer ;; -let run_single ic = - match input_upto_sep ";;" ic with +let run_single input = + match input with | EOF -> End | Input input -> let trimmed_input = String.trim input in @@ -57,30 +57,30 @@ let run_single ic = ;; let run_repl dump_parsetree input_file = - let ic = - match input_file with - | None -> stdin - | Some n -> open_in n - in - let rec run_repl_helper run env state = + (* TODO: refactor repl runners *) + let run_repl_helper input env state = let open Format in - match run ic with - | Fail -> fprintf err_formatter "Error occured\n" + match input with + | Fail -> + fprintf err_formatter "Error occured\n"; + None | Empty -> fprintf std_formatter "\n"; print_flush (); - run_repl_helper run env state - | End -> () + Some (env, state) + | End -> None | Result ast -> (match dump_parsetree with - | true -> print_construction std_formatter ast + | true -> + print_construction std_formatter ast; + Some (env, state) | false -> let result = infer ast env state in (match result with | new_state, Error err -> fprintf err_formatter "Type checking failed: %a\n" pp_error err; print_flush (); - run_repl_helper run env new_state + Some (env, new_state) | new_state, Ok (env, types) -> List.iter (fun t -> @@ -88,7 +88,7 @@ let run_repl dump_parsetree input_file = pp_typ std_formatter t) types; print_flush (); - run_repl_helper run env new_state)) + Some (env, new_state))) in let env = TypeEnvironment.extend @@ -96,7 +96,28 @@ let run_repl dump_parsetree input_file = "print_int" (Scheme (VarSet.empty, Arrow (int_typ, unit_typ))) in - run_repl_helper run_single env 0 + let rec run_file inputs env state = + match inputs with + | [] -> () + | hd :: tl -> + (match run_repl_helper hd env state with + | Some (env, state) -> run_file tl env state + | None -> ()) + in + let rec run_repl env state ic = + let input = run_single (input_upto_sep ";;" ic) in + match run_repl_helper input env state with + | Some (env, state) -> run_repl env state ic + | None -> () + in + match input_file with + | None -> run_repl env 0 stdin + | Some n -> + let content = In_channel.input_all (open_in n) in + let re = Str.regexp "\n\n" in + let splitted = Str.split re content in + let splitted = List.map (fun s -> run_single (Input s)) splitted in + run_file splitted env 0 ;; type opts = diff --git a/FSharpActivePatterns/bin/dune b/FSharpActivePatterns/bin/dune index 64ac7d7d3..1e10d57b2 100644 --- a/FSharpActivePatterns/bin/dune +++ b/FSharpActivePatterns/bin/dune @@ -1,6 +1,6 @@ (executable (public_name repl) (name REPL) - (libraries FSharpActivePatterns stdlib) + (libraries FSharpActivePatterns stdlib str) (instrumentation (backend bisect_ppx))) diff --git a/FSharpActivePatterns/bin/input.txt b/FSharpActivePatterns/bin/input.txt index 5b3b65edb..b1312d900 100644 --- a/FSharpActivePatterns/bin/input.txt +++ b/FSharpActivePatterns/bin/input.txt @@ -1,11 +1,41 @@ -let a, b = 1, 2;; +let rec length xs = + match xs with + | [] -> 0 + | h::tl -> 1 + length tl -1, 2 + (1, 2) + 4;; +let length_tail = + let rec helper acc xs = + match xs with + | [] -> acc + | h::tl -> helper (acc + 1) tl + in + helper 0 -if 1, 2 then (3, 4) else ((0, 1), 0);; +let rec map f xs = + match xs with + | [] -> [] + | a::[] -> [f a] + | a::b::[] -> [f a; f b] + | a::b::c::[] -> [f a; f b; f c] + | a::b::c::d::tl -> f a :: f b :: f c :: f d :: map f tl -match Some a b, 2 with -| 3, 4 -> None -| 5, 6 -> None;; +let rec append xs ys = match xs with [] -> ys | x::xs -> x::(append xs ys) -let x, Some y = 1, Some 2;; \ No newline at end of file +let concat = + let rec helper xs = + match xs with + | [] -> [] + | h::tl -> append h (helper tl) + in helper + +let rec iter f xs = match xs with [] -> () | h::tl -> let () = f h in iter f tl + +let rec cartesian xs ys = + match xs with + | [] -> [] + | h::tl -> append (map (fun a -> (h,a)) ys) (cartesian tl ys) + +let main = + let () = iter print_int [1;2;3] in + let () = print_int (length (cartesian [1;2] [1;2;3;4])) in + 0 From a3e01e4f75deece4dc3475e5e365399a0afa1253 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 20 Dec 2024 04:21:55 +0300 Subject: [PATCH 284/310] feat: add cram tests for inferencer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/tests/dune | 25 +++++++ FSharpActivePatterns/tests/inference.t | 92 ++++++++++++++++++++++++++ FSharpActivePatterns/tests/manytests | 1 + 3 files changed, 118 insertions(+) create mode 100644 FSharpActivePatterns/tests/inference.t create mode 120000 FSharpActivePatterns/tests/manytests diff --git a/FSharpActivePatterns/tests/dune b/FSharpActivePatterns/tests/dune index f2b8e0f4d..9ea42e28e 100644 --- a/FSharpActivePatterns/tests/dune +++ b/FSharpActivePatterns/tests/dune @@ -1,3 +1,28 @@ (cram (applies_to qcheck) (deps ../lib/tests/run_qcheck.exe)) + +(cram + (applies_to inference) + (deps + ../bin/REPL.exe + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/do_not_type/004let_poly.ml + manytests/do_not_type/015tuples.ml + manytests/do_not_type/099.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/009let_poly.ml + manytests/typed/010sukharev.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) diff --git a/FSharpActivePatterns/tests/inference.t b/FSharpActivePatterns/tests/inference.t new file mode 100644 index 000000000..3bbcb74e8 --- /dev/null +++ b/FSharpActivePatterns/tests/inference.t @@ -0,0 +1,92 @@ + $ ../bin/REPL.exe -fromfile manytests/do_not_type/001.ml + Type checking failed: Undefined variable 'fac' + $ ../bin/REPL.exe -fromfile manytests/do_not_type/002if.ml + Type checking failed: unification failed on int + and bool + + $ ../bin/REPL.exe -fromfile manytests/do_not_type/003occurs.ml + Type checking failed: Occurs check failed + $ ../bin/REPL.exe -fromfile manytests/do_not_type/004let_poly.ml + - : int -> int option -> int + Type checking failed: unification failed on bool + and int + + $ ../bin/REPL.exe -fromfile manytests/do_not_type/015tuples.ml + Type checking failed: Only variables are allowed as left-hand side of `let rec' + Type checking failed: unification failed on ('_0, '_1) + and (int, int, int) + + $ ../bin/REPL.exe -fromfile manytests/do_not_type/099.ml + Type checking failed: Only variables are allowed as left-hand side of `let rec' + Type checking failed: Undefined variable 'x' + Type checking failed: unification failed on '_1 option + and '_0 -> '_0 + + Type checking failed: unification failed on unit + and '_2 -> '_2 + + $ ../bin/REPL.exe -fromfile manytests/typed/001fac.ml + - : int -> int + - : int + $ ../bin/REPL.exe -fromfile manytests/typed/002fac.ml + - : int -> (int -> '_7) -> '_7 + - : int + $ ../bin/REPL.exe -fromfile manytests/typed/003fib.ml + - : int -> int -> int -> int + - : int -> int + - : int + $ ../bin/REPL.exe -fromfile manytests/typed/004manyargs.ml + - : '_0 -> '_0 + - : '_5 -> '_4 -> '_3 -> int + - : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int + - : int + $ ../bin/REPL.exe -fromfile manytests/typed/005fix.ml + - : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 + - : (int -> int) -> int -> int + - : int + $ ../bin/REPL.exe -fromfile manytests/typed/006partial.ml + - : bool -> int -> int + Error occured + $ ../bin/REPL.exe -fromfile manytests/typed/006partial2.ml + - : int -> int -> int -> int + - : int + $ ../bin/REPL.exe -fromfile manytests/typed/006partial3.ml + - : '_0 -> '_2 -> int -> unit + - : int + $ ../bin/REPL.exe -fromfile manytests/typed/007order.ml + - : unit -> unit -> int -> unit -> int -> int -> unit -> int -> '_0 -> int + - : unit + $ ../bin/REPL.exe -fromfile manytests/typed/008ascription.ml + - : ('_0 -> bool -> int) -> ('_0 -> bool) -> '_0 -> int + - : int + $ ../bin/REPL.exe -fromfile manytests/typed/009let_poly.ml + - : (int, bool) + $ ../bin/REPL.exe -fromfile manytests/typed/010sukharev.ml + - : int -> int -> (int, '_1) -> bool + - : int + - : (int, string) option + - : int -> '_14 + - : int + - : '_28 option -> '_28 + - : int option -> int + - : int -> bool + - : '_42 -> '_42 + - : '_43 -> '_43 + $ ../bin/REPL.exe -fromfile manytests/typed/015tuples.ml + - : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 + - : ('_9 -> '_11) -> '_7 -> ('_11, '_11) + - : '_14 -> ('_22 -> '_26, '_22 -> '_26) + - : '_33 -> int -> int + - : '_40 -> int -> int + - : ('_47 -> '_48, '_47 -> '_48) + Type checking failed: Undefined variable 'modd' + Error occured + $ ../bin/REPL.exe -fromfile manytests/typed/016lists.ml + - : '_3 list -> int + - : '_18 list -> int + - : ('_25 -> '_56) -> '_25 list -> '_56 list + - : '_67 list -> '_67 list -> '_67 list + - : '_81 list list -> '_81 list + - : '_85 -> '_87 list -> unit + - : '_98 list -> '_105 list -> ('_98, '_105) list + - : int diff --git a/FSharpActivePatterns/tests/manytests b/FSharpActivePatterns/tests/manytests new file mode 120000 index 000000000..0bd48791d --- /dev/null +++ b/FSharpActivePatterns/tests/manytests @@ -0,0 +1 @@ +../../manytests \ No newline at end of file From 7432db42a89a2b7eb7f358d8712c88dce8af591e Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 20 Dec 2024 18:43:25 +0300 Subject: [PATCH 285/310] feat: implement REPL with indents, printing of names Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 112 ++++++++++-------- FSharpActivePatterns/lib/astPrinter.ml | 4 +- FSharpActivePatterns/lib/astPrinter.mli | 2 +- FSharpActivePatterns/lib/inferencer.ml | 18 +-- FSharpActivePatterns/lib/inferencer.mli | 2 +- FSharpActivePatterns/lib/parser.ml | 4 +- FSharpActivePatterns/lib/parser.mli | 2 +- .../lib/tests/qcheck_utils.ml | 2 +- FSharpActivePatterns/tests/inference.t | 103 ++++++++-------- 9 files changed, 129 insertions(+), 120 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 7481463cf..fe9741aa7 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -7,15 +7,15 @@ open FSharpActivePatterns.Parser open FSharpActivePatterns.Inferencer open FSharpActivePatterns.TypedTree open FSharpActivePatterns.TypesPp +open FSharpActivePatterns.Ast open Stdlib type input = | Input of string | EOF -type 'a run_result = - | Result of 'a - | Fail +type run_result = + | Result of (construction, string) result | Empty | End @@ -43,52 +43,83 @@ let input_upto_sep sep ic = fill_buffer buffer ;; -let run_single input = +let input_with_indents ic = + let take_line () = In_channel.input_line ic in + let rec fill_buffer b = + let start_pos = pos_in ic in + let line = take_line () in + match line with + | None -> Input (Buffer.contents b) + | Some line -> + let is_empty = String.length line = 0 in + let is_continue = + List.exists (fun pref -> String.starts_with ~prefix:pref line) [ " "; "\t"; "\n" ] + || is_empty + in + (match is_continue with + | true -> + Buffer.add_string b line; + Buffer.add_string b "\n"; + fill_buffer b + | false -> + seek_in ic start_pos; + Buffer.add_string b "\n"; + Input (Buffer.contents b)) + in + let buffer = Buffer.create 1024 in + let first_line = take_line () in + match first_line with + | None -> + EOF + | Some first_line -> + Buffer.add_string buffer first_line; + fill_buffer buffer +;; + +let run_single ic = + let input = + match ic with + | None -> input_upto_sep ";;" stdin + | Some ic -> input_with_indents ic + in match input with | EOF -> End | Input input -> let trimmed_input = String.trim input in - if trimmed_input = "" - then Empty - else ( - match parse trimmed_input with - | Some ast -> Result ast - | None -> Fail) + if trimmed_input = "" then Empty else Result (parse trimmed_input) ;; let run_repl dump_parsetree input_file = - (* TODO: refactor repl runners *) - let run_repl_helper input env state = + let ic = + match input_file with + | None -> None + | Some n -> Some (open_in n) + in + let rec run_repl_helper run env state = let open Format in - match input with - | Fail -> - fprintf err_formatter "Error occured\n"; - None + match run ic with + | Result (Error e) -> fprintf err_formatter "%s\n" e | Empty -> fprintf std_formatter "\n"; print_flush (); - Some (env, state) - | End -> None - | Result ast -> + run_repl_helper run env state + | End -> () + | Result (Ok ast) -> (match dump_parsetree with - | true -> - print_construction std_formatter ast; - Some (env, state) + | true -> print_construction std_formatter ast | false -> let result = infer ast env state in (match result with | new_state, Error err -> fprintf err_formatter "Type checking failed: %a\n" pp_error err; print_flush (); - Some (env, new_state) - | new_state, Ok (env, types) -> + run_repl_helper run env new_state + | new_state, Ok (env, names_and_types) -> List.iter - (fun t -> - fprintf std_formatter "- : "; - pp_typ std_formatter t) - types; + (fun (n, t) -> fprintf std_formatter "%s : %a" n pp_typ t) + names_and_types; print_flush (); - Some (env, new_state))) + run_repl_helper run env new_state)) in let env = TypeEnvironment.extend @@ -96,28 +127,7 @@ let run_repl dump_parsetree input_file = "print_int" (Scheme (VarSet.empty, Arrow (int_typ, unit_typ))) in - let rec run_file inputs env state = - match inputs with - | [] -> () - | hd :: tl -> - (match run_repl_helper hd env state with - | Some (env, state) -> run_file tl env state - | None -> ()) - in - let rec run_repl env state ic = - let input = run_single (input_upto_sep ";;" ic) in - match run_repl_helper input env state with - | Some (env, state) -> run_repl env state ic - | None -> () - in - match input_file with - | None -> run_repl env 0 stdin - | Some n -> - let content = In_channel.input_all (open_in n) in - let re = Str.regexp "\n\n" in - let splitted = Str.split re content in - let splitted = List.map (fun s -> run_single (Input s)) splitted in - run_file splitted env 0 + run_repl_helper run_single env 0 ;; type opts = diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 7a30841a0..a0db5cabe 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -192,6 +192,6 @@ let print_construction fmt = function ;; let print_p_res fmt = function - | Some expr -> print_construction fmt expr - | None -> fprintf fmt "Error occured" + | Ok ast -> print_construction fmt ast + | Error e -> fprintf fmt "%s\n" e ;; diff --git a/FSharpActivePatterns/lib/astPrinter.mli b/FSharpActivePatterns/lib/astPrinter.mli index db17ee820..c2a769e9c 100644 --- a/FSharpActivePatterns/lib/astPrinter.mli +++ b/FSharpActivePatterns/lib/astPrinter.mli @@ -6,4 +6,4 @@ open Ast open Format val print_construction : formatter -> construction -> unit -val print_p_res : formatter -> construction option -> unit +val print_p_res : formatter -> (construction, tag) result -> unit diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 1d77b9c8b..410f4a485 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -718,31 +718,31 @@ let infer_statement env = function let* env = extend_env_with_bind_names env let_binds in let* env = extend_env_with_let_binds env Rec let_binds in let bind_names = extract_bind_names_from_let_binds let_binds in - let bind_types = + let bind_names_with_types = List.map bind_names ~f:(fun name -> match TypeEnvironment.find_exn env name with - | Scheme (_, typ) -> typ) + | Scheme (_, typ) -> name, typ) in - return (env, bind_types) + return (env, bind_names_with_types) | Let (Nonrec, let_bind, let_binds) -> let let_binds = let_bind :: let_binds in let* env = extend_env_with_let_binds env Nonrec let_binds in let bind_names = extract_bind_names_from_let_binds let_binds in - let bind_types = + let bind_names_with_types = List.map bind_names ~f:(fun name -> match TypeEnvironment.find_exn env name with - | Scheme (_, typ) -> typ) + | Scheme (_, typ) -> name, typ) in - return (env, bind_types) + return (env, bind_names_with_types) ;; let infer_construction env = function | Expr exp -> let* _, typ = infer_expr env exp in - return (env, [ typ ]) + return (env, [ "-", typ ]) | Statement s -> - let* env, types = infer_statement env s in - return (env, types) + let* env, names_and_types = infer_statement env s in + return (env, names_and_types) ;; let infer c env state = run (infer_construction env c) state diff --git a/FSharpActivePatterns/lib/inferencer.mli b/FSharpActivePatterns/lib/inferencer.mli index 98316260c..770439acc 100644 --- a/FSharpActivePatterns/lib/inferencer.mli +++ b/FSharpActivePatterns/lib/inferencer.mli @@ -28,4 +28,4 @@ val infer : construction -> TypeEnvironment.t -> int - -> int * (TypeEnvironment.t * typ list, error) result + -> int * (TypeEnvironment.t * (string * typ) list, error) result diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index f87d8a604..4d83c29ab 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -400,7 +400,5 @@ let p_construction = (* MAIN PARSE FUNCTION *) let parse (str : string) = - match parse_string ~consume:All (skip_ws *> p_construction <* skip_ws) str with - | Ok ast -> Some ast - | Error _ -> None + parse_string ~consume:All (skip_ws *> p_construction <* skip_ws) str ;; diff --git a/FSharpActivePatterns/lib/parser.mli b/FSharpActivePatterns/lib/parser.mli index 19a074986..6d0484176 100644 --- a/FSharpActivePatterns/lib/parser.mli +++ b/FSharpActivePatterns/lib/parser.mli @@ -4,4 +4,4 @@ open Ast -val parse : string -> construction option +val parse : string -> (construction, string) result diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index 919b76081..fd6cde746 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -157,6 +157,6 @@ let run n = QCheck_base_runner.run_tests [ QCheck.( Test.make arbitrary_construction ~count:n (fun c -> - Some c = parse (Format.asprintf "%a\n" pp_construction c))) + Ok c = parse (Format.asprintf "%a\n" pp_construction c))) ] ;; diff --git a/FSharpActivePatterns/tests/inference.t b/FSharpActivePatterns/tests/inference.t index 3bbcb74e8..8c0dbc451 100644 --- a/FSharpActivePatterns/tests/inference.t +++ b/FSharpActivePatterns/tests/inference.t @@ -7,7 +7,7 @@ $ ../bin/REPL.exe -fromfile manytests/do_not_type/003occurs.ml Type checking failed: Occurs check failed $ ../bin/REPL.exe -fromfile manytests/do_not_type/004let_poly.ml - - : int -> int option -> int + _2 : int -> int option -> int Type checking failed: unification failed on bool and int @@ -26,67 +26,68 @@ and '_2 -> '_2 $ ../bin/REPL.exe -fromfile manytests/typed/001fac.ml - - : int -> int - - : int + fac : int -> int + main : int $ ../bin/REPL.exe -fromfile manytests/typed/002fac.ml - - : int -> (int -> '_7) -> '_7 - - : int + fac_cps : int -> (int -> '_7) -> '_7 + main : int $ ../bin/REPL.exe -fromfile manytests/typed/003fib.ml - - : int -> int -> int -> int - - : int -> int - - : int + fib_acc : int -> int -> int -> int + fib : int -> int + main : int $ ../bin/REPL.exe -fromfile manytests/typed/004manyargs.ml - - : '_0 -> '_0 - - : '_5 -> '_4 -> '_3 -> int - - : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int - - : int + wrap : '_0 -> '_0 + test3 : '_5 -> '_4 -> '_3 -> int + test10 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int + main : int $ ../bin/REPL.exe -fromfile manytests/typed/005fix.ml - - : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 - - : (int -> int) -> int -> int - - : int + fix : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 + fac : (int -> int) -> int -> int + main : int $ ../bin/REPL.exe -fromfile manytests/typed/006partial.ml - - : bool -> int -> int - Error occured + foo : bool -> int -> int + foo : int -> int + main : int $ ../bin/REPL.exe -fromfile manytests/typed/006partial2.ml - - : int -> int -> int -> int - - : int + foo : int -> int -> int -> int + main : int $ ../bin/REPL.exe -fromfile manytests/typed/006partial3.ml - - : '_0 -> '_2 -> int -> unit - - : int + foo : '_0 -> '_2 -> int -> unit + main : int $ ../bin/REPL.exe -fromfile manytests/typed/007order.ml - - : unit -> unit -> int -> unit -> int -> int -> unit -> int -> '_0 -> int - - : unit + _start : unit -> unit -> int -> unit -> int -> int -> unit -> int -> '_0 -> int + main : unit $ ../bin/REPL.exe -fromfile manytests/typed/008ascription.ml - - : ('_0 -> bool -> int) -> ('_0 -> bool) -> '_0 -> int - - : int + addi : ('_0 -> bool -> int) -> ('_0 -> bool) -> '_0 -> int + main : int $ ../bin/REPL.exe -fromfile manytests/typed/009let_poly.ml - - : (int, bool) + temp : (int, bool) $ ../bin/REPL.exe -fromfile manytests/typed/010sukharev.ml - - : int -> int -> (int, '_1) -> bool - - : int - - : (int, string) option - - : int -> '_14 - - : int - - : '_28 option -> '_28 - - : int option -> int - - : int -> bool - - : '_42 -> '_42 - - : '_43 -> '_43 + _1 : int -> int -> (int, '_1) -> bool + _2 : int + _3 : (int, string) option + _4 : int -> '_14 + _5 : int + _6 : '_28 option -> '_28 + int_of_option : int option -> int + _42 : int -> bool + id1 : '_42 -> '_42 + id2 : '_43 -> '_43 $ ../bin/REPL.exe -fromfile manytests/typed/015tuples.ml - - : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 - - : ('_9 -> '_11) -> '_7 -> ('_11, '_11) - - : '_14 -> ('_22 -> '_26, '_22 -> '_26) - - : '_33 -> int -> int - - : '_40 -> int -> int - - : ('_47 -> '_48, '_47 -> '_48) + fix : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 + map : ('_9 -> '_11) -> '_7 -> ('_11, '_11) + fixpoly : '_14 -> ('_22 -> '_26, '_22 -> '_26) + feven : '_33 -> int -> int + fodd : '_40 -> int -> int + tie : ('_47 -> '_48, '_47 -> '_48) Type checking failed: Undefined variable 'modd' - Error occured + : string $ ../bin/REPL.exe -fromfile manytests/typed/016lists.ml - - : '_3 list -> int - - : '_18 list -> int - - : ('_25 -> '_56) -> '_25 list -> '_56 list - - : '_67 list -> '_67 list -> '_67 list - - : '_81 list list -> '_81 list - - : '_85 -> '_87 list -> unit - - : '_98 list -> '_105 list -> ('_98, '_105) list - - : int + length : '_3 list -> int + length_tail : '_18 list -> int + map : ('_25 -> '_56) -> '_25 list -> '_56 list + append : '_67 list -> '_67 list -> '_67 list + concat : '_81 list list -> '_81 list + iter : '_85 -> '_87 list -> unit + cartesian : '_98 list -> '_105 list -> ('_98, '_105) list + main : int From 9c6e9d81564b6740cc387688633f37c464d196a7 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 20 Dec 2024 20:11:05 +0300 Subject: [PATCH 286/310] fix: add subst returning in LetIn inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 35 +++++++++++++++----------- FSharpActivePatterns/tests/inference.t | 32 ++++++++++++----------- 2 files changed, 39 insertions(+), 28 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 410f4a485..9bbb3925b 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -630,13 +630,15 @@ let rec infer_expr env = function | LetIn (Rec, let_bind, let_binds, e) -> let let_binds = let_bind :: let_binds in let* env = extend_env_with_bind_names env let_binds in - let* env = extend_env_with_let_binds env Rec let_binds in - let* subst, typ = infer_expr env e in - return (subst, typ) + let* env, subst1 = extend_env_with_let_binds env Rec let_binds in + let* subst2, typ = infer_expr env e in + let* subst_final = Substitution.compose subst1 subst2 in + return (subst_final, typ) | LetIn (Nonrec, let_bind, let_binds, e) -> - let* env = extend_env_with_let_binds env Nonrec (let_bind :: let_binds) in - let* subst, typ = infer_expr env e in - return (subst, typ) + let* env, subst1 = extend_env_with_let_binds env Nonrec (let_bind :: let_binds) in + let* subst2, typ = infer_expr env e in + let* subst_final = Substitution.compose subst1 subst2 in + return (subst_final, typ) | Function ((p1, e1), rest) -> let* arg_type = make_fresh_var in let* return_type = make_fresh_var in @@ -682,11 +684,16 @@ let rec infer_expr env = function return (subst_result, Substitution.apply subst2 e_type) and extend_env_with_let_binds env is_rec let_binds = - List.fold let_binds ~init:(return env) ~f:(fun acc let_bind -> - let* env = acc in - let* names_schemes_list = infer_let_bind env is_rec let_bind in - let env = TypeEnvironment.extend_many env names_schemes_list in - return env) + List.fold + let_binds + ~init:(return (env, Substitution.empty)) + ~f:(fun acc let_bind -> + let* env, subst_acc = acc in + let* subst, names_schemes_list = infer_let_bind env is_rec let_bind in + let env = TypeEnvironment.extend_many env names_schemes_list in + let env = TypeEnvironment.apply subst env in + let* subst_acc = Substitution.compose subst_acc subst in + return (env, subst_acc)) and infer_let_bind env is_rec let_bind = let* (Let_bind (name, args, e)) = check_let_bind_correctness is_rec let_bind in @@ -709,14 +716,14 @@ and infer_let_bind env is_rec let_bind = let names_schemes_list = List.map names_types ~f:(fun (name, name_type) -> name, generalize env name_type) in - return names_schemes_list + return (subst, names_schemes_list) ;; let infer_statement env = function | Let (Rec, let_bind, let_binds) -> let let_binds = let_bind :: let_binds in let* env = extend_env_with_bind_names env let_binds in - let* env = extend_env_with_let_binds env Rec let_binds in + let* env, _ = extend_env_with_let_binds env Rec let_binds in let bind_names = extract_bind_names_from_let_binds let_binds in let bind_names_with_types = List.map bind_names ~f:(fun name -> @@ -726,7 +733,7 @@ let infer_statement env = function return (env, bind_names_with_types) | Let (Nonrec, let_bind, let_binds) -> let let_binds = let_bind :: let_binds in - let* env = extend_env_with_let_binds env Nonrec let_binds in + let* env, _ = extend_env_with_let_binds env Nonrec let_binds in let bind_names = extract_bind_names_from_let_binds let_binds in let bind_names_with_types = List.map bind_names ~f:(fun name -> diff --git a/FSharpActivePatterns/tests/inference.t b/FSharpActivePatterns/tests/inference.t index 8c0dbc451..6c68b75a3 100644 --- a/FSharpActivePatterns/tests/inference.t +++ b/FSharpActivePatterns/tests/inference.t @@ -7,10 +7,12 @@ $ ../bin/REPL.exe -fromfile manytests/do_not_type/003occurs.ml Type checking failed: Occurs check failed $ ../bin/REPL.exe -fromfile manytests/do_not_type/004let_poly.ml - _2 : int -> int option -> int Type checking failed: unification failed on bool and int + Type checking failed: unification failed on string + and int + $ ../bin/REPL.exe -fromfile manytests/do_not_type/015tuples.ml Type checking failed: Only variables are allowed as left-hand side of `let rec' Type checking failed: unification failed on ('_0, '_1) @@ -37,7 +39,7 @@ main : int $ ../bin/REPL.exe -fromfile manytests/typed/004manyargs.ml wrap : '_0 -> '_0 - test3 : '_5 -> '_4 -> '_3 -> int + test3 : int -> int -> int -> int test10 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int main : int $ ../bin/REPL.exe -fromfile manytests/typed/005fix.ml @@ -52,10 +54,10 @@ foo : int -> int -> int -> int main : int $ ../bin/REPL.exe -fromfile manytests/typed/006partial3.ml - foo : '_0 -> '_2 -> int -> unit + foo : int -> int -> int -> unit main : int $ ../bin/REPL.exe -fromfile manytests/typed/007order.ml - _start : unit -> unit -> int -> unit -> int -> int -> unit -> int -> '_0 -> int + _start : unit -> unit -> int -> unit -> int -> int -> unit -> int -> int -> int main : unit $ ../bin/REPL.exe -fromfile manytests/typed/008ascription.ml addi : ('_0 -> bool -> int) -> ('_0 -> bool) -> '_0 -> int @@ -67,19 +69,21 @@ _2 : int _3 : (int, string) option _4 : int -> '_14 - _5 : int - _6 : '_28 option -> '_28 + _6 : '_26 option -> '_26 int_of_option : int option -> int _42 : int -> bool - id1 : '_42 -> '_42 - id2 : '_43 -> '_43 + id1 : '_40 -> '_40 + id2 : '_41 -> '_41 + Type checking failed: unification failed on string + and int + $ ../bin/REPL.exe -fromfile manytests/typed/015tuples.ml fix : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 - map : ('_9 -> '_11) -> '_7 -> ('_11, '_11) - fixpoly : '_14 -> ('_22 -> '_26, '_22 -> '_26) - feven : '_33 -> int -> int - fodd : '_40 -> int -> int - tie : ('_47 -> '_48, '_47 -> '_48) + map : ('_9 -> '_11) -> ('_9, '_9) -> ('_11, '_11) + fixpoly : (('_21 -> '_25, '_21 -> '_25) -> '_21 -> '_25, ('_21 -> '_25, '_21 -> '_25) -> '_21 -> '_25) -> ('_21 -> '_25, '_21 -> '_25) + feven : ('_33, int -> int) -> int -> int + fodd : (int -> int, '_41) -> int -> int + tie : (int -> int, int -> int) Type checking failed: Undefined variable 'modd' : string $ ../bin/REPL.exe -fromfile manytests/typed/016lists.ml @@ -88,6 +92,6 @@ map : ('_25 -> '_56) -> '_25 list -> '_56 list append : '_67 list -> '_67 list -> '_67 list concat : '_81 list list -> '_81 list - iter : '_85 -> '_87 list -> unit + iter : ('_87 -> unit) -> '_87 list -> unit cartesian : '_98 list -> '_105 list -> ('_98, '_105) list main : int From 12e3f4658af6d939a1197f1be78f6a6078e993bf Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 20 Dec 2024 23:21:12 +0300 Subject: [PATCH 287/310] fix: and parsing in REPL Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/bin/REPL.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index fe9741aa7..38a310dbd 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -8,6 +8,7 @@ open FSharpActivePatterns.Inferencer open FSharpActivePatterns.TypedTree open FSharpActivePatterns.TypesPp open FSharpActivePatterns.Ast +open FSharpActivePatterns.PrettyPrinter open Stdlib type input = @@ -55,10 +56,12 @@ let input_with_indents ic = let is_continue = List.exists (fun pref -> String.starts_with ~prefix:pref line) [ " "; "\t"; "\n" ] || is_empty + || String.starts_with ~prefix:"and" (String.trim line) in (match is_continue with | true -> - Buffer.add_string b line; + let newline = " " ^ line in + Buffer.add_string b newline; Buffer.add_string b "\n"; fill_buffer b | false -> From 6d667f4dd93cb59a21fa6d1ffbe544afe395dc3d Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 20 Dec 2024 23:47:09 +0300 Subject: [PATCH 288/310] fix: repl with file Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 14 ++++---------- FSharpActivePatterns/tests/inference.t | 5 +++-- 2 files changed, 7 insertions(+), 12 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 38a310dbd..e567a441c 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -8,7 +8,6 @@ open FSharpActivePatterns.Inferencer open FSharpActivePatterns.TypedTree open FSharpActivePatterns.TypesPp open FSharpActivePatterns.Ast -open FSharpActivePatterns.PrettyPrinter open Stdlib type input = @@ -60,9 +59,7 @@ let input_with_indents ic = in (match is_continue with | true -> - let newline = " " ^ line in - Buffer.add_string b newline; - Buffer.add_string b "\n"; + Buffer.add_string b (line ^ "\n"); fill_buffer b | false -> seek_in ic start_pos; @@ -72,10 +69,9 @@ let input_with_indents ic = let buffer = Buffer.create 1024 in let first_line = take_line () in match first_line with - | None -> - EOF + | None -> EOF | Some first_line -> - Buffer.add_string buffer first_line; + Buffer.add_string buffer (first_line ^ "\n"); fill_buffer buffer ;; @@ -87,9 +83,7 @@ let run_single ic = in match input with | EOF -> End - | Input input -> - let trimmed_input = String.trim input in - if trimmed_input = "" then Empty else Result (parse trimmed_input) + | Input input -> if String.trim input = "" then Empty else Result (parse input) ;; let run_repl dump_parsetree input_file = diff --git a/FSharpActivePatterns/tests/inference.t b/FSharpActivePatterns/tests/inference.t index 6c68b75a3..6f6123d68 100644 --- a/FSharpActivePatterns/tests/inference.t +++ b/FSharpActivePatterns/tests/inference.t @@ -84,8 +84,9 @@ feven : ('_33, int -> int) -> int -> int fodd : (int -> int, '_41) -> int -> int tie : (int -> int, int -> int) - Type checking failed: Undefined variable 'modd' - : string + meven : int -> int + modd : int -> int + main : int $ ../bin/REPL.exe -fromfile manytests/typed/016lists.ml length : '_3 list -> int length_tail : '_18 list -> int From a9acc2568548cab2c63d2a093b47e321910236f6 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 21 Dec 2024 00:11:45 +0300 Subject: [PATCH 289/310] ref: linter Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 9bbb3925b..845617948 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -330,7 +330,7 @@ end = struct ;; let remove = Map.remove - let remove_many t keys = List.fold ~init:t keys ~f:(fun acc k -> remove acc k) + let remove_many t keys = List.fold ~init:t keys ~f:remove let empty = Map.empty (module String) (* apply given substitution to all elements of environment *) @@ -406,11 +406,11 @@ let rec infer_pattern env ~shadow = function let* fresh = make_fresh_var in let scheme = Scheme (VarSet.empty, fresh) in let env, typ = - match shadow with - | true -> TypeEnvironment.extend env name scheme, fresh - | false -> + if shadow + then TypeEnvironment.extend env name scheme, fresh + else ( let typ = TypeEnvironment.find_typ env name in - env, Option.value typ ~default:fresh + env, Option.value typ ~default:fresh) in return (env, typ) | POption None -> From 8fcec1ad1942e6b17728d74fdbfb32c3255a79f0 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 21 Dec 2024 15:56:53 +0300 Subject: [PATCH 290/310] feat: REPL with file prints without duplicates Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 29 ++++++++++++++++------- FSharpActivePatterns/lib/inferencer.ml | 25 +++++++++++++------- FSharpActivePatterns/lib/inferencer.mli | 2 ++ FSharpActivePatterns/tests/inference.t | 31 ++++++++++++------------- 4 files changed, 53 insertions(+), 34 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index e567a441c..92627dc75 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -95,15 +95,19 @@ let run_repl dump_parsetree input_file = let rec run_repl_helper run env state = let open Format in match run ic with - | Result (Error e) -> fprintf err_formatter "%s\n" e + | Result (Error _) -> + fprintf err_formatter "Parsing error\n"; + run_repl_helper run env state | Empty -> fprintf std_formatter "\n"; print_flush (); run_repl_helper run env state - | End -> () + | End -> env | Result (Ok ast) -> (match dump_parsetree with - | true -> print_construction std_formatter ast + | true -> + print_construction std_formatter ast; + run_repl_helper run env state | false -> let result = infer ast env state in (match result with @@ -112,11 +116,14 @@ let run_repl dump_parsetree input_file = print_flush (); run_repl_helper run env new_state | new_state, Ok (env, names_and_types) -> - List.iter - (fun (n, t) -> fprintf std_formatter "%s : %a" n pp_typ t) - names_and_types; - print_flush (); - run_repl_helper run env new_state)) + (match ic with + | None -> + List.iter + (fun (n, t) -> fprintf std_formatter "%s : %a" n pp_typ t) + names_and_types; + print_flush (); + run_repl_helper run env new_state + | Some _ -> run_repl_helper run env new_state))) in let env = TypeEnvironment.extend @@ -124,7 +131,11 @@ let run_repl dump_parsetree input_file = "print_int" (Scheme (VarSet.empty, Arrow (int_typ, unit_typ))) in - run_repl_helper run_single env 0 + let env = run_repl_helper run_single env 0 in + let env = TypeEnvironment.remove env "print_int" in + match ic with + | Some _ -> TypeEnvironment.pp_without_freevars Format.std_formatter env + | None -> () ;; type opts = diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 845617948..fdb91a314 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -178,12 +178,7 @@ end = struct (* empty map *) let empty = Map.empty (module Int) - - (* let pp fmt s = - Map.iter_keys s ~f:(fun k -> - let v = Map.find_exn s k in - fprintf fmt "%d: %a" k pp_typ v) - ;; *) + (* let pp fmt s = Map.iteri s ~f:(fun ~key ~data -> fprintf fmt "%d: %a" key pp_typ data) *) (* perform mapping of fresh var to typ with occurs check, if correct, output new pair *) @@ -273,7 +268,9 @@ module Scheme : sig (* val occurs_in : fresh -> t -> bool *) val apply : Substitution.t -> t -> t val free_vars : t -> binder_set + (* val pp : formatter -> t -> unit *) + val typ : t -> typ end = struct type t = scheme @@ -299,6 +296,11 @@ end = struct ;; (* let pp = pp_scheme *) + + let typ s = + match s with + | Scheme (_, t) -> t + ;; end module TypeEnvironment : sig @@ -313,7 +315,10 @@ module TypeEnvironment : sig val find_exn : t -> string -> scheme val find_typ_exn : t -> string -> typ val find_typ : t -> string -> typ option + val remove : t -> string -> t val remove_many : t -> string list -> t + val pp_without_freevars : formatter -> t -> unit + (* val pp : formatter -> t -> unit *) end = struct open Base @@ -350,11 +355,13 @@ end = struct ;; (* let pp fmt t = - Map.iter_keys t ~f:(fun k -> - let (Scheme (binder_s, typ)) = find_exn t k in - fprintf fmt "%s : %a %a" k VarSet.pp binder_s pp_typ typ) + Map.iteri t ~f:(fun ~key ~data -> fprintf fmt "%s : %a" key Scheme.pp data) ;; *) + let pp_without_freevars fmt t = + Map.iteri t ~f:(fun ~key ~data -> fprintf fmt "%s : %a" key pp_typ (Scheme.typ data)) + ;; + (* collect all free vars from environment *) let free_vars : t -> VarSet.t = Map.fold ~init:VarSet.empty ~f:(fun ~key:_ ~data:s acc -> diff --git a/FSharpActivePatterns/lib/inferencer.mli b/FSharpActivePatterns/lib/inferencer.mli index 770439acc..952225aa1 100644 --- a/FSharpActivePatterns/lib/inferencer.mli +++ b/FSharpActivePatterns/lib/inferencer.mli @@ -11,6 +11,8 @@ module TypeEnvironment : sig val empty : t val extend : t -> string -> scheme -> t + val remove : t -> string -> t + val pp_without_freevars : formatter -> t -> unit end type error = diff --git a/FSharpActivePatterns/tests/inference.t b/FSharpActivePatterns/tests/inference.t index 6f6123d68..68813a840 100644 --- a/FSharpActivePatterns/tests/inference.t +++ b/FSharpActivePatterns/tests/inference.t @@ -34,20 +34,19 @@ fac_cps : int -> (int -> '_7) -> '_7 main : int $ ../bin/REPL.exe -fromfile manytests/typed/003fib.ml - fib_acc : int -> int -> int -> int fib : int -> int + fib_acc : int -> int -> int -> int main : int $ ../bin/REPL.exe -fromfile manytests/typed/004manyargs.ml - wrap : '_0 -> '_0 - test3 : int -> int -> int -> int - test10 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int main : int + test10 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int + test3 : int -> int -> int -> int + wrap : '_0 -> '_0 $ ../bin/REPL.exe -fromfile manytests/typed/005fix.ml - fix : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 fac : (int -> int) -> int -> int + fix : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 main : int $ ../bin/REPL.exe -fromfile manytests/typed/006partial.ml - foo : bool -> int -> int foo : int -> int main : int $ ../bin/REPL.exe -fromfile manytests/typed/006partial2.ml @@ -69,30 +68,30 @@ _2 : int _3 : (int, string) option _4 : int -> '_14 - _6 : '_26 option -> '_26 - int_of_option : int option -> int _42 : int -> bool + _6 : '_26 option -> '_26 id1 : '_40 -> '_40 id2 : '_41 -> '_41 + int_of_option : int option -> int Type checking failed: unification failed on string and int $ ../bin/REPL.exe -fromfile manytests/typed/015tuples.ml + feven : ('_33, int -> int) -> int -> int fix : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 - map : ('_9 -> '_11) -> ('_9, '_9) -> ('_11, '_11) fixpoly : (('_21 -> '_25, '_21 -> '_25) -> '_21 -> '_25, ('_21 -> '_25, '_21 -> '_25) -> '_21 -> '_25) -> ('_21 -> '_25, '_21 -> '_25) - feven : ('_33, int -> int) -> int -> int fodd : (int -> int, '_41) -> int -> int - tie : (int -> int, int -> int) + main : int + map : ('_9 -> '_11) -> ('_9, '_9) -> ('_11, '_11) meven : int -> int modd : int -> int - main : int + tie : (int -> int, int -> int) $ ../bin/REPL.exe -fromfile manytests/typed/016lists.ml - length : '_3 list -> int - length_tail : '_18 list -> int - map : ('_25 -> '_56) -> '_25 list -> '_56 list append : '_67 list -> '_67 list -> '_67 list + cartesian : '_98 list -> '_105 list -> ('_98, '_105) list concat : '_81 list list -> '_81 list iter : ('_87 -> unit) -> '_87 list -> unit - cartesian : '_98 list -> '_105 list -> ('_98, '_105) list + length : '_3 list -> int + length_tail : '_18 list -> int main : int + map : ('_25 -> '_56) -> '_25 list -> '_56 list From 8b4c335348e928ff59d39f3dc5b9a67fb3d304c4 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 21 Dec 2024 16:00:05 +0300 Subject: [PATCH 291/310] feat: tuple type pretty printer with '*' instead of ',' Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/typesPp.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index 418cf6366..d590212ce 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -17,7 +17,7 @@ let pp_typ fmt typ = | Type_tuple (first, second, rest) -> fprintf fmt "("; Format.pp_print_list - ~pp_sep:(fun fmt () -> fprintf fmt ", ") + ~pp_sep:(fun fmt () -> fprintf fmt " * ") helper fmt (first :: second :: rest); From 417c2157120259399b072c16bbcb567e634ed899 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 21 Dec 2024 16:05:19 +0300 Subject: [PATCH 292/310] tests: promote tests Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/tests/inference.t | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/FSharpActivePatterns/tests/inference.t b/FSharpActivePatterns/tests/inference.t index 68813a840..15f1d0984 100644 --- a/FSharpActivePatterns/tests/inference.t +++ b/FSharpActivePatterns/tests/inference.t @@ -15,8 +15,8 @@ $ ../bin/REPL.exe -fromfile manytests/do_not_type/015tuples.ml Type checking failed: Only variables are allowed as left-hand side of `let rec' - Type checking failed: unification failed on ('_0, '_1) - and (int, int, int) + Type checking failed: unification failed on ('_0 * '_1) + and (int * int * int) $ ../bin/REPL.exe -fromfile manytests/do_not_type/099.ml Type checking failed: Only variables are allowed as left-hand side of `let rec' @@ -62,11 +62,11 @@ addi : ('_0 -> bool -> int) -> ('_0 -> bool) -> '_0 -> int main : int $ ../bin/REPL.exe -fromfile manytests/typed/009let_poly.ml - temp : (int, bool) + temp : (int * bool) $ ../bin/REPL.exe -fromfile manytests/typed/010sukharev.ml - _1 : int -> int -> (int, '_1) -> bool + _1 : int -> int -> (int * '_1) -> bool _2 : int - _3 : (int, string) option + _3 : (int * string) option _4 : int -> '_14 _42 : int -> bool _6 : '_26 option -> '_26 @@ -77,18 +77,18 @@ and int $ ../bin/REPL.exe -fromfile manytests/typed/015tuples.ml - feven : ('_33, int -> int) -> int -> int + feven : ('_33 * int -> int) -> int -> int fix : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 - fixpoly : (('_21 -> '_25, '_21 -> '_25) -> '_21 -> '_25, ('_21 -> '_25, '_21 -> '_25) -> '_21 -> '_25) -> ('_21 -> '_25, '_21 -> '_25) - fodd : (int -> int, '_41) -> int -> int + fixpoly : (('_21 -> '_25 * '_21 -> '_25) -> '_21 -> '_25 * ('_21 -> '_25 * '_21 -> '_25) -> '_21 -> '_25) -> ('_21 -> '_25 * '_21 -> '_25) + fodd : (int -> int * '_41) -> int -> int main : int - map : ('_9 -> '_11) -> ('_9, '_9) -> ('_11, '_11) + map : ('_9 -> '_11) -> ('_9 * '_9) -> ('_11 * '_11) meven : int -> int modd : int -> int - tie : (int -> int, int -> int) + tie : (int -> int * int -> int) $ ../bin/REPL.exe -fromfile manytests/typed/016lists.ml append : '_67 list -> '_67 list -> '_67 list - cartesian : '_98 list -> '_105 list -> ('_98, '_105) list + cartesian : '_98 list -> '_105 list -> ('_98 * '_105) list concat : '_81 list list -> '_81 list iter : ('_87 -> unit) -> '_87 list -> unit length : '_3 list -> int From 6ade315626f9a26358ef67bc09510127ac6cb238 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 21 Dec 2024 16:39:27 +0300 Subject: [PATCH 293/310] ref: linter Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index fdb91a314..1ab98b086 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -297,8 +297,7 @@ end = struct (* let pp = pp_scheme *) - let typ s = - match s with + let typ = function | Scheme (_, t) -> t ;; end From 23acfc953ca8caafe1c0e6381387e0c140139d01 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Thu, 26 Dec 2024 18:15:23 +0300 Subject: [PATCH 294/310] feat: inference of polymorphic patterns in Match Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 20 +++++++++++++++++--- FSharpActivePatterns/tests/inference.t | 10 ++++------ 2 files changed, 21 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 1ab98b086..082b1dc09 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -317,7 +317,6 @@ module TypeEnvironment : sig val remove : t -> string -> t val remove_many : t -> string list -> t val pp_without_freevars : formatter -> t -> unit - (* val pp : formatter -> t -> unit *) end = struct open Base @@ -485,6 +484,22 @@ let extract_names_from_pattern pat = helper pat ;; +let infer_match_pattern env ~shadow pattern match_type = + let* env, pat_typ = infer_pattern env ~shadow pattern in + let* subst = unify pat_typ match_type in + let env = TypeEnvironment.apply subst env in + let pat_names = extract_names_from_pattern pattern in + let generalized_schemes = + List.map pat_names ~f:(fun name -> + let typ = TypeEnvironment.find_typ_exn env name in + let env = TypeEnvironment.remove env name in + let generalized_typ = generalize env typ in + name, generalized_typ) + in + let env = TypeEnvironment.extend_many env generalized_schemes in + return (env, subst) +;; + let extract_names_from_patterns pats = List.fold pats ~init:[] ~f:(fun acc p -> List.concat [ acc; extract_names_from_pattern p ]) @@ -673,8 +688,7 @@ let rec infer_expr env = function ~init:(return (subst_init, return_type)) ~f:(fun acc (pat, expr) -> let* subst1, return_type = acc in - let* env, pat = infer_pattern env ~shadow:true pat in - let* subst2 = unify match_type pat in + let* env, subst2 = infer_match_pattern env ~shadow:true pat match_type in let* subst12 = Substitution.compose subst1 subst2 in let env = TypeEnvironment.apply subst12 env in let* subst3, expr_typ = infer_expr env expr in diff --git a/FSharpActivePatterns/tests/inference.t b/FSharpActivePatterns/tests/inference.t index 15f1d0984..e57a1255e 100644 --- a/FSharpActivePatterns/tests/inference.t +++ b/FSharpActivePatterns/tests/inference.t @@ -69,13 +69,11 @@ _3 : (int * string) option _4 : int -> '_14 _42 : int -> bool - _6 : '_26 option -> '_26 - id1 : '_40 -> '_40 - id2 : '_41 -> '_41 + _5 : int + _6 : '_30 option -> '_30 + id1 : '_44 -> '_44 + id2 : '_45 -> '_45 int_of_option : int option -> int - Type checking failed: unification failed on string - and int - $ ../bin/REPL.exe -fromfile manytests/typed/015tuples.ml feven : ('_33 * int -> int) -> int -> int fix : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 From b9b20a747435d139f583d98a9d2b4388b73c8db5 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Thu, 26 Dec 2024 20:12:38 +0300 Subject: [PATCH 295/310] ref: change types pp logic Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/typesPp.ml | 13 +++++++++---- FSharpActivePatterns/tests/inference.t | 20 ++++++++++---------- 2 files changed, 19 insertions(+), 14 deletions(-) diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index d590212ce..b4070b04f 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -15,14 +15,19 @@ let pp_typ fmt typ = | _ -> fprintf fmt "%a -> %a" helper fst helper snd) | Type_list typ -> fprintf fmt "%a list" helper typ | Type_tuple (first, second, rest) -> - fprintf fmt "("; Format.pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt " * ") - helper + (fun fmt typ -> + match typ with + | Arrow _ -> fprintf fmt "(%a)" helper typ + | _ -> helper fmt typ) fmt (first :: second :: rest); - fprintf fmt ")" - | TOption t -> fprintf fmt "%a option" helper t + | TOption t -> + match t with + | Type_tuple _ | Arrow _ -> + fprintf fmt "(%a) option" helper t; + | t -> fprintf fmt "%a option" helper t in helper fmt typ; fprintf fmt "\n" diff --git a/FSharpActivePatterns/tests/inference.t b/FSharpActivePatterns/tests/inference.t index e57a1255e..9603112a8 100644 --- a/FSharpActivePatterns/tests/inference.t +++ b/FSharpActivePatterns/tests/inference.t @@ -15,8 +15,8 @@ $ ../bin/REPL.exe -fromfile manytests/do_not_type/015tuples.ml Type checking failed: Only variables are allowed as left-hand side of `let rec' - Type checking failed: unification failed on ('_0 * '_1) - and (int * int * int) + Type checking failed: unification failed on '_0 * '_1 + and int * int * int $ ../bin/REPL.exe -fromfile manytests/do_not_type/099.ml Type checking failed: Only variables are allowed as left-hand side of `let rec' @@ -62,9 +62,9 @@ addi : ('_0 -> bool -> int) -> ('_0 -> bool) -> '_0 -> int main : int $ ../bin/REPL.exe -fromfile manytests/typed/009let_poly.ml - temp : (int * bool) + temp : int * bool $ ../bin/REPL.exe -fromfile manytests/typed/010sukharev.ml - _1 : int -> int -> (int * '_1) -> bool + _1 : int -> int -> int * '_1 -> bool _2 : int _3 : (int * string) option _4 : int -> '_14 @@ -75,18 +75,18 @@ id2 : '_45 -> '_45 int_of_option : int option -> int $ ../bin/REPL.exe -fromfile manytests/typed/015tuples.ml - feven : ('_33 * int -> int) -> int -> int + feven : '_33 * (int -> int) -> int -> int fix : (('_1 -> '_5) -> '_1 -> '_5) -> '_1 -> '_5 - fixpoly : (('_21 -> '_25 * '_21 -> '_25) -> '_21 -> '_25 * ('_21 -> '_25 * '_21 -> '_25) -> '_21 -> '_25) -> ('_21 -> '_25 * '_21 -> '_25) - fodd : (int -> int * '_41) -> int -> int + fixpoly : (('_21 -> '_25) * ('_21 -> '_25) -> '_21 -> '_25) * (('_21 -> '_25) * ('_21 -> '_25) -> '_21 -> '_25) -> ('_21 -> '_25) * ('_21 -> '_25) + fodd : (int -> int) * '_41 -> int -> int main : int - map : ('_9 -> '_11) -> ('_9 * '_9) -> ('_11 * '_11) + map : ('_9 -> '_11) -> '_9 * '_9 -> '_11 * '_11 meven : int -> int modd : int -> int - tie : (int -> int * int -> int) + tie : (int -> int) * (int -> int) $ ../bin/REPL.exe -fromfile manytests/typed/016lists.ml append : '_67 list -> '_67 list -> '_67 list - cartesian : '_98 list -> '_105 list -> ('_98 * '_105) list + cartesian : '_98 list -> '_105 list -> '_98 * '_105 list concat : '_81 list list -> '_81 list iter : ('_87 -> unit) -> '_87 list -> unit length : '_3 list -> int From 953cd4974be3776c40226aec4b981ebf2737e81b Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Thu, 26 Dec 2024 20:14:47 +0300 Subject: [PATCH 296/310] ref: formatting Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/typesPp.ml | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index b4070b04f..6873b0048 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -18,16 +18,15 @@ let pp_typ fmt typ = Format.pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt " * ") (fun fmt typ -> - match typ with - | Arrow _ -> fprintf fmt "(%a)" helper typ - | _ -> helper fmt typ) + match typ with + | Arrow _ -> fprintf fmt "(%a)" helper typ + | _ -> helper fmt typ) fmt - (first :: second :: rest); - | TOption t -> - match t with - | Type_tuple _ | Arrow _ -> - fprintf fmt "(%a) option" helper t; - | t -> fprintf fmt "%a option" helper t + (first :: second :: rest) + | TOption t -> + (match t with + | Type_tuple _ | Arrow _ -> fprintf fmt "(%a) option" helper t + | t -> fprintf fmt "%a option" helper t) in helper fmt typ; fprintf fmt "\n" From cfb8efed2af1d19d728b53ee1f3fc19b0ff14472 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 27 Dec 2024 14:58:02 +0300 Subject: [PATCH 297/310] ref: peek_sep1 Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/parser.ml | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index 4d83c29ab..e7c98315b 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -25,15 +25,9 @@ let peek_sep1 = match c with | None -> return None | Some c -> - if is_ws c - || Char.equal c '(' - || Char.equal c ')' - || Char.equal c ',' - || Char.equal c ']' - || Char.equal c ':' - || Char.equal c ';' - then return (Some c) - else fail "need a delimiter" + match c with + | '(' | ')' | ']' | ';' | ':' | ',' -> return (Some c) + | _ -> if is_ws c then return (Some c) else fail "need a delimiter" ;; let skip_ws_sep1 = peek_sep1 *> skip_ws From 16fad50899011dd19e072d722744ef93ca6472a4 Mon Sep 17 00:00:00 2001 From: Ksenia Kotelnikova Date: Fri, 27 Dec 2024 15:05:52 +0300 Subject: [PATCH 298/310] ref: not empty list check Signed-off-by: Ksenia Kotelnikova --- FSharpActivePatterns/lib/inferencer.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 082b1dc09..f8ee12491 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -518,7 +518,7 @@ let extract_bind_patterns_from_let_binds let_binds = let extend_env_with_bind_names env let_binds = (* to prevent binds like let rec x = x + 1*) let let_binds = - List.filter let_binds ~f:(function Let_bind (_, args, _) -> List.length args <> 0) + List.filter let_binds ~f:(function Let_bind (_, args, _) -> not (List.is_empty args)) in let bind_names = extract_bind_patterns_from_let_binds let_binds in let* env, _ = infer_patterns env ~shadow:true bind_names in From 12b47ef1ef1c2ad5785667cfa343013b9f70052f Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 27 Dec 2024 22:59:40 +0300 Subject: [PATCH 299/310] tests: improve Let, LetIn, Constraint shrinkers, change types generator Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 4 ++-- .../lib/tests/qcheck_utils.ml | 19 ++++++++++++++++--- FSharpActivePatterns/lib/typedTree.ml | 4 ++++ FSharpActivePatterns/lib/typedTree.mli | 2 +- 4 files changed, 23 insertions(+), 6 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 1fe2a60af..8c11ac1d2 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -99,7 +99,7 @@ type pattern = | PVar of ident (** pattern identifier *) | POption of pattern option (*| Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) *) - | PConstraint of pattern * (typ[@gen gen_typ_sized (n / 4)]) + | PConstraint of pattern * (typ[@gen gen_typ]) [@@deriving show { with_path = false }, qcheck] let gen_typed_pattern_sized n = QCheck.Gen.(pair (gen_pattern_sized n) (return None)) @@ -151,7 +151,7 @@ and expr = [@gen QCheck.Gen.(list_size (0 -- 2) (gen_let_bind_sized (n / 20)))]) * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) - | EConstraint of expr * (typ[@gen gen_typ_sized (n / 4)]) + | EConstraint of expr * (typ[@gen gen_typ]) [@@deriving show { with_path = false }, qcheck] and let_bind = diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index fd6cde746..5e2319a7d 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -22,6 +22,13 @@ let shrink_lt = | String_lt x -> QCheck.Shrink.string x >|= fun a' -> String_lt a' ;; +let exprs_from_let_binds let_binds = + List.map + (function + | Let_bind (_, _, e) -> e) + let_binds +;; + let rec shrink_let_bind = let open QCheck.Iter in function @@ -55,7 +62,7 @@ and shrink_expr = <+> (shrink_expr i >|= fun a' -> If_then_else (a', t, None)) <+> (shrink_expr t >|= fun a' -> If_then_else (i, a', None)) | LetIn (rec_flag, let_bind, let_bind_list, inner_e) -> - return inner_e + of_list (inner_e :: exprs_from_let_binds (let_bind :: let_bind_list)) <+> (shrink_let_bind let_bind >|= fun a' -> LetIn (rec_flag, a', let_bind_list, inner_e)) <+> (QCheck.Shrink.list ~shrink:shrink_let_bind let_bind_list @@ -101,7 +108,7 @@ and shrink_expr = of_list [ e; Option None ] <+> (shrink_expr e >|= fun a' -> Option (Some a')) | Option None -> empty | Variable _ -> empty - | EConstraint (e, _) -> return e + | EConstraint (e, t) -> return e <+> shrink_expr e >|= fun a' -> EConstraint (a', t) and shrink_pattern = let open QCheck.Iter in @@ -143,7 +150,13 @@ let shrink_construction = let open QCheck.Iter in function | Expr e -> shrink_expr e >|= fun a' -> Expr a' - | Statement s -> shrink_statement s >|= fun a' -> Statement a' + | Statement s -> + shrink_statement s + >|= (fun a' -> Statement a') + <+> + (match s with + | Let (_, let_bind, let_binds) -> + of_list (exprs_from_let_binds (let_bind :: let_binds)) >|= fun a' -> Expr a') ;; let arbitrary_construction = diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index 44aee06e8..db765accb 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -15,6 +15,10 @@ type typ = | TOption of typ [@@deriving show { with_path = false }, qcheck] +let gen_typ = + QCheck.Gen.(oneofl [ "string"; "int"; "unit"; "bool" ] >|= fun t -> Primitive t) +;; + let arrow_of_types first_types last_type = let open Base in List.fold_right first_types ~init:last_type ~f:(fun left right -> Arrow (left, right)) diff --git a/FSharpActivePatterns/lib/typedTree.mli b/FSharpActivePatterns/lib/typedTree.mli index b3e5dc4bf..374aea41e 100644 --- a/FSharpActivePatterns/lib/typedTree.mli +++ b/FSharpActivePatterns/lib/typedTree.mli @@ -12,7 +12,7 @@ type typ = | Type_tuple of typ * typ * typ list | TOption of typ -val gen_typ_sized : int -> typ QCheck.Gen.t +val gen_typ : typ QCheck.Gen.t val pp_typ : Format.formatter -> typ -> unit val arrow_of_types : typ list -> typ -> typ From 1602be339be1a36e51e0c35a126b08fb47773e2e Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Fri, 27 Dec 2024 23:00:58 +0300 Subject: [PATCH 300/310] fix: ast_printer and ast pretty_printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/astPrinter.ml | 20 +++++++++++++++----- FSharpActivePatterns/lib/prettyPrinter.ml | 21 +++++++-------------- 2 files changed, 22 insertions(+), 19 deletions(-) diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index a0db5cabe..2e8612afc 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -8,6 +8,7 @@ open Format open Ast +open TypesPp let print_bin_op indent fmt = function | Binary_equal -> fprintf fmt "%s| Binary Equal\n" (String.make indent '-') @@ -57,7 +58,12 @@ let rec print_pattern indent fmt = function | Some p -> fprintf fmt "Some:\n"; print_pattern (indent + 2) fmt p) - | PConstraint (p, _) -> print_pattern indent fmt p + | PConstraint (p, t) -> + fprintf fmt "%s| PConstraint\n" (String.make indent ' '); + fprintf fmt "%sPattern:\n" (String.make (indent + 2) ' '); + print_pattern (indent + 2) fmt p; + fprintf fmt "%sType:\n" (String.make (indent + 2) ' '); + fprintf fmt "%s| %a" (String.make (indent + 2) '-') pp_typ t ;; let print_unary_op indent fmt = function @@ -134,7 +140,6 @@ and print_expr indent fmt expr = | Lambda (arg1, args, body) -> fprintf fmt "%s| Lambda:\n" (String.make indent '-'); fprintf fmt "%sARGS\n" (String.make (indent + 2) ' '); - print_pattern (indent + 4) fmt arg1; List.iter (fun pat -> print_pattern (indent + 4) fmt pat) (arg1 :: args); fprintf fmt "%sBODY\n" (String.make (indent + 2) ' '); print_expr (indent + 4) fmt body @@ -147,11 +152,11 @@ and print_expr indent fmt expr = | LetIn (rec_flag, let_bind, let_bind_list, inner_e) -> fprintf fmt - "%s | %s LetIn=\n" + "%s| %sLetIn=\n" (String.make indent '-') (match rec_flag with | Nonrec -> "" - | Rec -> "Rec"); + | Rec -> "Rec "); fprintf fmt "%sLet_binds\n" (String.make (indent + 2) ' '); List.iter (print_let_bind (indent + 2) fmt) (let_bind :: let_bind_list); fprintf fmt "%sINNER_EXPRESSION\n" (String.make (indent + 2) ' '); @@ -162,7 +167,12 @@ and print_expr indent fmt expr = | Some e -> fprintf fmt "%s| Option: Some\n" (String.make indent '-'); print_expr (indent + 2) fmt e) - | EConstraint (e, _) -> print_expr indent fmt e + | EConstraint (e, t) -> + fprintf fmt "%s| EConstraint\n" (String.make indent ' '); + fprintf fmt "%sExpr:\n" (String.make (indent + 2) ' '); + print_expr (indent + 2) fmt e; + fprintf fmt "%sType:\n" (String.make (indent + 2) ' '); + fprintf fmt "%s| %a" (String.make (indent + 2) '-') pp_typ t ;; let print_statement indent fmt = function diff --git a/FSharpActivePatterns/lib/prettyPrinter.ml b/FSharpActivePatterns/lib/prettyPrinter.ml index e4eeb1117..5233b4031 100644 --- a/FSharpActivePatterns/lib/prettyPrinter.ml +++ b/FSharpActivePatterns/lib/prettyPrinter.ml @@ -70,26 +70,18 @@ and pp_expr fmt expr = fprintf fmt "]" | Tuple (e1, e2, rest) -> fprintf fmt "("; - pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") pp_expr fmt (e1 :: e2 :: rest); + pp_print_list + ~pp_sep:(fun fmt () -> fprintf fmt ", ") + pp_parens_expr + fmt + (e1 :: e2 :: rest); fprintf fmt ")" | Function ((pat1, expr1), cases) -> - let cases = - List.map - (function - | a, b -> a, b) - cases - in fprintf fmt "function "; List.iter (fun (pat, expr) -> fprintf fmt "| %a -> (%a) \n" pp_pattern pat pp_expr expr) ((pat1, expr1) :: cases) | Match (value, (pat1, expr1), cases) -> - let cases = - List.map - (function - | p, e -> p, e) - cases - in fprintf fmt "match (%a) with \n" pp_expr value; List.iter (fun (pat, expr) -> fprintf fmt "| %a -> (%a) \n" pp_pattern pat pp_expr expr) @@ -137,7 +129,8 @@ and pp_args fmt args = and pp_let_bind fmt = function | Let_bind (name, args, body) -> fprintf fmt "%a %a = %a " pp_pattern name pp_args args pp_expr body -;; + +and pp_parens_expr fmt expr = fprintf fmt "(%a)" pp_expr expr let pp_statement fmt = function | Let (rec_flag, let_bind, let_bind_list) -> From 0216157e2249963f1f71bcc378735790a6056be3 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 28 Dec 2024 00:28:41 +0300 Subject: [PATCH 301/310] fix: ast_printer, ast pp, remove unused deriving Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/bin/REPL.ml | 2 +- FSharpActivePatterns/lib/ast.ml | 1 + FSharpActivePatterns/lib/astPrinter.ml | 12 +++---- FSharpActivePatterns/lib/inferencer.ml | 5 +-- FSharpActivePatterns/lib/typedTree.ml | 3 +- FSharpActivePatterns/lib/typedTree.mli | 3 +- FSharpActivePatterns/lib/typesPp.ml | 46 ++++++++++++-------------- 7 files changed, 33 insertions(+), 39 deletions(-) diff --git a/FSharpActivePatterns/bin/REPL.ml b/FSharpActivePatterns/bin/REPL.ml index 92627dc75..319a4febe 100644 --- a/FSharpActivePatterns/bin/REPL.ml +++ b/FSharpActivePatterns/bin/REPL.ml @@ -119,7 +119,7 @@ let run_repl dump_parsetree input_file = (match ic with | None -> List.iter - (fun (n, t) -> fprintf std_formatter "%s : %a" n pp_typ t) + (fun (n, t) -> fprintf std_formatter "%s : %a\n" n pp_typ t) names_and_types; print_flush (); run_repl_helper run env new_state diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 8c11ac1d2..75dca82a6 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -4,6 +4,7 @@ open KeywordChecker open TypedTree +open TypesPp type ident = Ident of string (** identifier *) [@@deriving show { with_path = false }] diff --git a/FSharpActivePatterns/lib/astPrinter.ml b/FSharpActivePatterns/lib/astPrinter.ml index 2e8612afc..0c8bd4a05 100644 --- a/FSharpActivePatterns/lib/astPrinter.ml +++ b/FSharpActivePatterns/lib/astPrinter.ml @@ -52,7 +52,7 @@ let rec print_pattern indent fmt = function print_pattern (indent + 2) fmt r | PVar (Ident name) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name | POption p -> - fprintf fmt "%s| POption: " (String.make indent '-'); + fprintf fmt "%s| POption " (String.make indent '-'); (match p with | None -> fprintf fmt "None\n" | Some p -> @@ -63,7 +63,7 @@ let rec print_pattern indent fmt = function fprintf fmt "%sPattern:\n" (String.make (indent + 2) ' '); print_pattern (indent + 2) fmt p; fprintf fmt "%sType:\n" (String.make (indent + 2) ' '); - fprintf fmt "%s| %a" (String.make (indent + 2) '-') pp_typ t + fprintf fmt "%s| %a\n" (String.make (indent + 2) '-') pp_typ t ;; let print_unary_op indent fmt = function @@ -75,11 +75,9 @@ let rec print_let_bind indent fmt = function | Let_bind (name, args, body) -> fprintf fmt "%s| Let_bind:\n" (String.make indent '-'); fprintf fmt "%sNAME:\n" (String.make (indent + 4) ' '); - fprintf fmt "%s| %a\n" (String.make (indent + 4) '-') pp_pattern name; + print_pattern (indent + 4) fmt name; fprintf fmt "%sARGS:\n" (String.make (indent + 4) ' '); - List.iter - (fun arg -> fprintf fmt "%s| %a\n" (String.make (indent + 2) '-') pp_pattern arg) - args; + List.iter (fun arg -> print_pattern (indent + 2) fmt arg) args; fprintf fmt "%sBODY:\n" (String.make (indent + 4) ' '); print_expr (indent + 2) fmt body @@ -172,7 +170,7 @@ and print_expr indent fmt expr = fprintf fmt "%sExpr:\n" (String.make (indent + 2) ' '); print_expr (indent + 2) fmt e; fprintf fmt "%sType:\n" (String.make (indent + 2) ' '); - fprintf fmt "%s| %a" (String.make (indent + 2) '-') pp_typ t + fprintf fmt "%s| %a\n" (String.make (indent + 2) '-') pp_typ t ;; let print_statement indent fmt = function diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index f8ee12491..d1c4f3686 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -21,7 +21,7 @@ let pp_error fmt : error -> _ = function | `Occurs_check -> fprintf fmt "Occurs check failed" | `Undef_var s -> fprintf fmt "Undefined variable '%s'" s | `Unification_failed (fst, snd) -> - fprintf fmt "unification failed on %a and %a" pp_typ fst pp_typ snd + fprintf fmt "unification failed on %a and %a\n" pp_typ fst pp_typ snd | `Not_allowed_right_hand_side_let_rec -> fprintf fmt "This kind of expression is not allowed as right-hand side of `let rec'" | `Not_allowed_left_hand_side_let_rec -> @@ -357,7 +357,8 @@ end = struct ;; *) let pp_without_freevars fmt t = - Map.iteri t ~f:(fun ~key ~data -> fprintf fmt "%s : %a" key pp_typ (Scheme.typ data)) + Map.iteri t ~f:(fun ~key ~data -> + fprintf fmt "%s : %a\n" key pp_typ (Scheme.typ data)) ;; (* collect all free vars from environment *) diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index db765accb..1e737287e 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -13,7 +13,6 @@ type typ = | Type_list of typ | Type_tuple of typ * typ * typ list | TOption of typ -[@@deriving show { with_path = false }, qcheck] let gen_typ = QCheck.Gen.(oneofl [ "string"; "int"; "unit"; "bool" ] >|= fun t -> Primitive t) @@ -37,7 +36,7 @@ end type binder_set = VarSet.t [@@deriving show { with_path = false }] (* binder_set here -- list of all type vars in context (?) *) -type scheme = Scheme of binder_set * typ [@@deriving show { with_path = false }] +type scheme = Scheme of binder_set * typ let int_typ = Primitive "int" let bool_typ = Primitive "bool" diff --git a/FSharpActivePatterns/lib/typedTree.mli b/FSharpActivePatterns/lib/typedTree.mli index 374aea41e..54d5fa942 100644 --- a/FSharpActivePatterns/lib/typedTree.mli +++ b/FSharpActivePatterns/lib/typedTree.mli @@ -13,7 +13,6 @@ type typ = | TOption of typ val gen_typ : typ QCheck.Gen.t -val pp_typ : Format.formatter -> typ -> unit val arrow_of_types : typ list -> typ -> typ module VarSet : sig @@ -23,7 +22,7 @@ module VarSet : sig end type binder_set = VarSet.t -type scheme = Scheme of binder_set * typ [@@deriving show { with_path = false }] +type scheme = Scheme of binder_set * typ val int_typ : typ val bool_typ : typ diff --git a/FSharpActivePatterns/lib/typesPp.ml b/FSharpActivePatterns/lib/typesPp.ml index 6873b0048..840c717dd 100644 --- a/FSharpActivePatterns/lib/typesPp.ml +++ b/FSharpActivePatterns/lib/typesPp.ml @@ -5,29 +5,25 @@ open TypedTree open Format -let pp_typ fmt typ = - let rec helper fmt = function - | Primitive s -> fprintf fmt "%s" s - | Type_var var -> fprintf fmt "'_%d" var - | Arrow (fst, snd) -> - (match fst with - | Arrow _ -> fprintf fmt "(%a) -> %a" helper fst helper snd - | _ -> fprintf fmt "%a -> %a" helper fst helper snd) - | Type_list typ -> fprintf fmt "%a list" helper typ - | Type_tuple (first, second, rest) -> - Format.pp_print_list - ~pp_sep:(fun fmt () -> fprintf fmt " * ") - (fun fmt typ -> - match typ with - | Arrow _ -> fprintf fmt "(%a)" helper typ - | _ -> helper fmt typ) - fmt - (first :: second :: rest) - | TOption t -> - (match t with - | Type_tuple _ | Arrow _ -> fprintf fmt "(%a) option" helper t - | t -> fprintf fmt "%a option" helper t) - in - helper fmt typ; - fprintf fmt "\n" +let rec pp_typ fmt = function + | Primitive s -> fprintf fmt "%s" s + | Type_var var -> fprintf fmt "'_%d" var + | Arrow (fst, snd) -> + (match fst with + | Arrow _ -> fprintf fmt "(%a) -> %a" pp_typ fst pp_typ snd + | _ -> fprintf fmt "%a -> %a" pp_typ fst pp_typ snd) + | Type_list typ -> fprintf fmt "%a list" pp_typ typ + | Type_tuple (first, second, rest) -> + Format.pp_print_list + ~pp_sep:(fun fmt () -> fprintf fmt " * ") + (fun fmt typ -> + match typ with + | Arrow _ -> fprintf fmt "(%a)" pp_typ typ + | _ -> pp_typ fmt typ) + fmt + (first :: second :: rest) + | TOption t -> + (match t with + | Type_tuple _ | Arrow _ -> fprintf fmt "(%a) option" pp_typ t + | t -> fprintf fmt "%a option" pp_typ t) ;; From 4c5267032403f7039212fb5f476570400a52aeab Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 28 Dec 2024 00:30:51 +0300 Subject: [PATCH 302/310] feat: qcheck printer shows generated and parsed ast Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/qcheck_utils.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index 5e2319a7d..17b5bf54c 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -162,7 +162,14 @@ let shrink_construction = let arbitrary_construction = QCheck.make gen_construction - ~print:(Format.asprintf "%a" print_construction) + ~print: + (let open Format in + asprintf "%a" (fun fmt c -> + let pp = pp_construction in + fprintf fmt "Generated:\n%a" pp c; + match parse (Format.asprintf "%a\n" pp c) with + | Ok parsed -> fprintf fmt "Parsed:\n%a" pp parsed + | Error e -> fprintf fmt "Parsing error:\n%s\n" e)) ~shrink:shrink_construction ;; From a32990834db66edda26117001c2da9c2ad05daa9 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 28 Dec 2024 00:31:40 +0300 Subject: [PATCH 303/310] fix: tuple priority in parser Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/parser.ml | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/parser.ml b/FSharpActivePatterns/lib/parser.ml index e7c98315b..c649e24a3 100644 --- a/FSharpActivePatterns/lib/parser.ml +++ b/FSharpActivePatterns/lib/parser.ml @@ -25,9 +25,9 @@ let peek_sep1 = match c with | None -> return None | Some c -> - match c with - | '(' | ')' | ']' | ';' | ':' | ',' -> return (Some c) - | _ -> if is_ws c then return (Some c) else fail "need a delimiter" + (match c with + | '(' | ')' | ']' | ';' | ':' | ',' -> return (Some c) + | _ -> if is_ws c then return (Some c) else fail "need a delimiter") ;; let skip_ws_sep1 = peek_sep1 *> skip_ws @@ -254,9 +254,9 @@ let p_pat = let atom = choice [ p_pat_const; p_parens self; p_parens (p_constraint_pat self) ] in let semicolon_list = p_semicolon_list_pat (self <|> atom) <|> atom in let opt = p_option semicolon_list make_option_pat <|> semicolon_list in - let tuple = p_tuple_pat opt <|> opt in - let cons = p_cons_list_pat tuple in - cons) + let cons = p_cons_list_pat opt in + let tuple = p_tuple_pat cons <|> cons in + tuple) ;; let p_let_bind p_expr = @@ -366,8 +366,7 @@ let p_expr = let letin_expr = p_letin (p_expr <|> if_expr) <|> if_expr in let option = p_option letin_expr make_option_expr <|> letin_expr in let apply = p_apply option <|> option in - let tuple = p_tuple make_tuple_expr apply <|> apply in - let unary = choice [ unary_chain p_not tuple; unary_chain unminus tuple ] in + let unary = choice [ unary_chain p_not apply; unary_chain unminus apply ] in let factor = chainl1 unary (mul <|> div) in let term = chainl1 factor (add <|> sub) in let cons_op = chainr1 term cons in @@ -380,7 +379,8 @@ let p_expr = let comp_and = chainl1 bit_or log_and in let comp_or = chainl1 comp_and log_or in let inf_oper = p_inf_oper_expr comp_or <|> comp_or in - let p_function = p_function (p_expr <|> inf_oper) <|> inf_oper in + let tuple = p_tuple make_tuple_expr inf_oper <|> inf_oper in + let p_function = p_function (p_expr <|> tuple) <|> tuple in let ematch = p_match (p_expr <|> p_function) <|> p_function in let efun = p_lambda (p_expr <|> ematch) <|> ematch in efun) From cd3aae2869d9048c4a3bd642dc3fddea131872cd Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 28 Dec 2024 00:31:52 +0300 Subject: [PATCH 304/310] tests: dune promote Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/tests/inference.t | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/FSharpActivePatterns/tests/inference.t b/FSharpActivePatterns/tests/inference.t index 9603112a8..b2739faf7 100644 --- a/FSharpActivePatterns/tests/inference.t +++ b/FSharpActivePatterns/tests/inference.t @@ -1,31 +1,25 @@ $ ../bin/REPL.exe -fromfile manytests/do_not_type/001.ml Type checking failed: Undefined variable 'fac' $ ../bin/REPL.exe -fromfile manytests/do_not_type/002if.ml - Type checking failed: unification failed on int - and bool + Type checking failed: unification failed on int and bool $ ../bin/REPL.exe -fromfile manytests/do_not_type/003occurs.ml Type checking failed: Occurs check failed $ ../bin/REPL.exe -fromfile manytests/do_not_type/004let_poly.ml - Type checking failed: unification failed on bool - and int + Type checking failed: unification failed on bool and int - Type checking failed: unification failed on string - and int + Type checking failed: unification failed on string and int $ ../bin/REPL.exe -fromfile manytests/do_not_type/015tuples.ml Type checking failed: Only variables are allowed as left-hand side of `let rec' - Type checking failed: unification failed on '_0 * '_1 - and int * int * int + Type checking failed: unification failed on '_0 * '_1 and int * int * int $ ../bin/REPL.exe -fromfile manytests/do_not_type/099.ml Type checking failed: Only variables are allowed as left-hand side of `let rec' Type checking failed: Undefined variable 'x' - Type checking failed: unification failed on '_1 option - and '_0 -> '_0 + Type checking failed: unification failed on '_1 option and '_0 -> '_0 - Type checking failed: unification failed on unit - and '_2 -> '_2 + Type checking failed: unification failed on unit and '_2 -> '_2 $ ../bin/REPL.exe -fromfile manytests/typed/001fac.ml fac : int -> int From b093ac2a3e2d4ed3cc3e5a0d80662c9e9c4a4546 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 28 Dec 2024 01:23:30 +0300 Subject: [PATCH 305/310] fix: change list to set in extracting names from pattern, add many bounds check Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 62 ++++++++++++++++--------- FSharpActivePatterns/lib/inferencer.mli | 1 + 2 files changed, 41 insertions(+), 22 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index d1c4f3686..47bca363b 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -15,6 +15,7 @@ type error = | `Not_allowed_right_hand_side_let_rec | `Not_allowed_left_hand_side_let_rec | `Args_after_not_variable_let + | `Bound_several_times ] let pp_error fmt : error -> _ = function @@ -28,6 +29,7 @@ let pp_error fmt : error -> _ = function fprintf fmt "Only variables are allowed as left-hand side of `let rec'" | `Args_after_not_variable_let -> fprintf fmt "Arguments in let allowed only after variable" + | `Bound_several_times -> fprintf fmt "Variable is bound several times" ;; (* for treating result of type inference *) @@ -469,27 +471,40 @@ let infer_patterns env ~shadow patterns = return (new_env, typ :: typs)) ;; -let extract_names_from_pattern pat = - let rec helper = function - | PVar (Ident name) -> [ name ] - | PList l -> List.concat (List.map l ~f:helper) - | PCons (hd, tl) -> List.concat [ helper hd; helper tl ] - | PTuple (fst, snd, rest) -> - List.concat [ helper fst; helper snd; List.concat (List.map rest ~f:helper) ] - | POption (Some p) -> helper p - | PConstraint (p, _) -> helper p - | POption None -> [] - | Wild -> [] - | PConst _ -> [] - in - helper pat +module StringSet = struct + include Stdlib.Set.Make (String) + + let union_disjoint s1 s2 = + let* s1 = s1 in + let* s2 = s2 in + if is_empty (inter s1 s2) then return (union s1 s2) else fail `Bound_several_times + ;; + + let union_disjoint_many sets = + List.fold ~init:(return empty) ~f:(fun acc set -> union_disjoint acc set) sets + ;; +end + +let rec extract_names_from_pattern = + let extr = extract_names_from_pattern in + function + | PVar (Ident name) -> return (StringSet.singleton name) + | PList l -> StringSet.union_disjoint_many (List.map l ~f:extr) + | PCons (hd, tl) -> StringSet.union_disjoint (extr hd) (extr tl) + | PTuple (fst, snd, rest) -> + StringSet.union_disjoint_many (List.map ~f:extr (fst :: snd :: rest)) + | POption (Some p) -> extr p + | PConstraint (p, _) -> extr p + | POption None -> return StringSet.empty + | Wild -> return StringSet.empty + | PConst _ -> return StringSet.empty ;; let infer_match_pattern env ~shadow pattern match_type = let* env, pat_typ = infer_pattern env ~shadow pattern in let* subst = unify pat_typ match_type in let env = TypeEnvironment.apply subst env in - let pat_names = extract_names_from_pattern pattern in + let* pat_names = extract_names_from_pattern pattern >>| StringSet.elements in let generalized_schemes = List.map pat_names ~f:(fun name -> let typ = TypeEnvironment.find_typ_exn env name in @@ -502,12 +517,11 @@ let infer_match_pattern env ~shadow pattern match_type = ;; let extract_names_from_patterns pats = - List.fold pats ~init:[] ~f:(fun acc p -> - List.concat [ acc; extract_names_from_pattern p ]) + StringSet.union_disjoint_many (List.map ~f:extract_names_from_pattern pats) ;; let extract_bind_names_from_let_binds let_binds = - List.concat + StringSet.union_disjoint_many (List.map let_binds ~f:(function Let_bind (pat, _, _) -> extract_names_from_pattern pat)) ;; @@ -730,8 +744,8 @@ and infer_let_bind env is_rec let_bind = let* subst2 = unify (Substitution.apply subst1 name_type) bind_type in let* subst = Substitution.compose subst1 subst2 in let env = TypeEnvironment.apply subst env in - let names = extract_names_from_pattern name in - let arg_names = extract_names_from_patterns args in + let* names = extract_names_from_pattern name >>| StringSet.elements in + let* arg_names = extract_names_from_patterns args >>| StringSet.elements in let names_types = List.map names ~f:(fun n -> n, TypeEnvironment.find_typ_exn env n) in let env = TypeEnvironment.remove_many env (List.concat [ names; arg_names ]) in let names_schemes_list = @@ -745,7 +759,9 @@ let infer_statement env = function let let_binds = let_bind :: let_binds in let* env = extend_env_with_bind_names env let_binds in let* env, _ = extend_env_with_let_binds env Rec let_binds in - let bind_names = extract_bind_names_from_let_binds let_binds in + let* bind_names = + extract_bind_names_from_let_binds let_binds >>| StringSet.elements + in let bind_names_with_types = List.map bind_names ~f:(fun name -> match TypeEnvironment.find_exn env name with @@ -755,7 +771,9 @@ let infer_statement env = function | Let (Nonrec, let_bind, let_binds) -> let let_binds = let_bind :: let_binds in let* env, _ = extend_env_with_let_binds env Nonrec let_binds in - let bind_names = extract_bind_names_from_let_binds let_binds in + let* bind_names = + extract_bind_names_from_let_binds let_binds >>| StringSet.elements + in let bind_names_with_types = List.map bind_names ~f:(fun name -> match TypeEnvironment.find_exn env name with diff --git a/FSharpActivePatterns/lib/inferencer.mli b/FSharpActivePatterns/lib/inferencer.mli index 952225aa1..f9ed9c1c6 100644 --- a/FSharpActivePatterns/lib/inferencer.mli +++ b/FSharpActivePatterns/lib/inferencer.mli @@ -22,6 +22,7 @@ type error = | `Not_allowed_right_hand_side_let_rec | `Not_allowed_left_hand_side_let_rec | `Args_after_not_variable_let + | `Bound_several_times ] val pp_error : formatter -> error -> unit From b039f0c4bc888805e04e43c9e29b388939e12921 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 28 Dec 2024 01:26:31 +0300 Subject: [PATCH 306/310] ref: rename typ generator Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/ast.ml | 6 ++---- FSharpActivePatterns/lib/typedTree.ml | 4 +--- FSharpActivePatterns/lib/typedTree.mli | 2 +- 3 files changed, 4 insertions(+), 8 deletions(-) diff --git a/FSharpActivePatterns/lib/ast.ml b/FSharpActivePatterns/lib/ast.ml index 75dca82a6..4cc306c35 100644 --- a/FSharpActivePatterns/lib/ast.ml +++ b/FSharpActivePatterns/lib/ast.ml @@ -100,11 +100,9 @@ type pattern = | PVar of ident (** pattern identifier *) | POption of pattern option (*| Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) *) - | PConstraint of pattern * (typ[@gen gen_typ]) + | PConstraint of pattern * (typ[@gen gen_typ_primitive]) [@@deriving show { with_path = false }, qcheck] -let gen_typed_pattern_sized n = QCheck.Gen.(pair (gen_pattern_sized n) (return None)) - type is_recursive = | Nonrec (** let factorial n = ... *) | Rec (** let rec factorial n = ... *) @@ -152,7 +150,7 @@ and expr = [@gen QCheck.Gen.(list_size (0 -- 2) (gen_let_bind_sized (n / 20)))]) * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *) | Option of expr option (** [int option] *) - | EConstraint of expr * (typ[@gen gen_typ]) + | EConstraint of expr * (typ[@gen gen_typ_primitive]) [@@deriving show { with_path = false }, qcheck] and let_bind = diff --git a/FSharpActivePatterns/lib/typedTree.ml b/FSharpActivePatterns/lib/typedTree.ml index 1e737287e..93079c14d 100644 --- a/FSharpActivePatterns/lib/typedTree.ml +++ b/FSharpActivePatterns/lib/typedTree.ml @@ -4,8 +4,6 @@ type binder = int [@@deriving show { with_path = false }, qcheck] -let gen_primitive = QCheck.Gen.oneofl [ "int"; "bool"; "string"; "unit" ] - type typ = | Primitive of (string[@gen gen_primitive]) | Type_var of binder @@ -14,7 +12,7 @@ type typ = | Type_tuple of typ * typ * typ list | TOption of typ -let gen_typ = +let gen_typ_primitive = QCheck.Gen.(oneofl [ "string"; "int"; "unit"; "bool" ] >|= fun t -> Primitive t) ;; diff --git a/FSharpActivePatterns/lib/typedTree.mli b/FSharpActivePatterns/lib/typedTree.mli index 54d5fa942..e5ad1655a 100644 --- a/FSharpActivePatterns/lib/typedTree.mli +++ b/FSharpActivePatterns/lib/typedTree.mli @@ -12,7 +12,7 @@ type typ = | Type_tuple of typ * typ * typ list | TOption of typ -val gen_typ : typ QCheck.Gen.t +val gen_typ_primitive : typ QCheck.Gen.t val arrow_of_types : typ list -> typ -> typ module VarSet : sig From 0c8bbc59a4801356ae893dec43c4c1cf91b7bf2d Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 28 Dec 2024 01:26:59 +0300 Subject: [PATCH 307/310] tests: change qcheck printer to ast printer Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/tests/qcheck_utils.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/FSharpActivePatterns/lib/tests/qcheck_utils.ml b/FSharpActivePatterns/lib/tests/qcheck_utils.ml index 17b5bf54c..6084e6655 100644 --- a/FSharpActivePatterns/lib/tests/qcheck_utils.ml +++ b/FSharpActivePatterns/lib/tests/qcheck_utils.ml @@ -165,7 +165,7 @@ let arbitrary_construction = ~print: (let open Format in asprintf "%a" (fun fmt c -> - let pp = pp_construction in + let pp = print_construction in fprintf fmt "Generated:\n%a" pp c; match parse (Format.asprintf "%a\n" pp c) with | Ok parsed -> fprintf fmt "Parsed:\n%a" pp parsed From 7b658865628df20dd931f1b12ff127355f8659fb Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 28 Dec 2024 02:06:28 +0300 Subject: [PATCH 308/310] ref: remove repeated code from match and function inference Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 75 ++++++++++++++------------ 1 file changed, 41 insertions(+), 34 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 47bca363b..c5710a47b 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -676,48 +676,55 @@ let rec infer_expr env = function let* subst_final = Substitution.compose subst1 subst2 in return (subst_final, typ) | Function ((p1, e1), rest) -> - let* arg_type = make_fresh_var in - let* return_type = make_fresh_var in - let* subst, return_type = - List.fold - ((p1, e1) :: rest) - ~init:(return (Substitution.empty, return_type)) - ~f:(fun acc (pat, expr) -> - let* subst1, return_type = acc in - let* env, pat = infer_pattern env ~shadow:true pat in - let* subst2 = unify arg_type pat in - let env = TypeEnvironment.apply subst2 env in - let* subst3, expr_typ = infer_expr env expr in - let* subst4 = unify return_type expr_typ in - let* subst = Substitution.compose_all [ subst1; subst2; subst3; subst4 ] in - return (subst, Substitution.apply subst return_type)) - in - return (subst, Arrow (Substitution.apply subst arg_type, return_type)) + let* match_t = make_fresh_var in + let* return_t = make_fresh_var in + infer_matching_expr + env + ((p1, e1) :: rest) + Substitution.empty + match_t + return_t + ~with_arg:true | Match (e, (p1, e1), rest) -> - let* subst_init, match_type = infer_expr env e in + let* subst_init, match_t = infer_expr env e in let env = TypeEnvironment.apply subst_init env in - let* return_type = make_fresh_var in - let* subst, return_type = - List.fold - ((p1, e1) :: rest) - ~init:(return (subst_init, return_type)) - ~f:(fun acc (pat, expr) -> - let* subst1, return_type = acc in - let* env, subst2 = infer_match_pattern env ~shadow:true pat match_type in - let* subst12 = Substitution.compose subst1 subst2 in - let env = TypeEnvironment.apply subst12 env in - let* subst3, expr_typ = infer_expr env expr in - let* subst4 = unify return_type expr_typ in - let* subst = Substitution.compose_all [ subst12; subst3; subst4 ] in - return (subst, Substitution.apply subst return_type)) - in - return (subst, return_type) + let* return_t = make_fresh_var in + infer_matching_expr env ((p1, e1) :: rest) subst_init match_t return_t ~with_arg:false | EConstraint (e, t) -> let* subst1, e_type = infer_expr env e in let* subst2 = unify e_type (Substitution.apply subst1 t) in let* subst_result = Substitution.compose subst1 subst2 in return (subst_result, Substitution.apply subst2 e_type) +and infer_matching_expr env cases subst_init match_t return_t ~with_arg = + let* subst, return_t = + List.fold + cases + ~init:(return (subst_init, return_t)) + ~f:(fun acc (pat, expr) -> + let* subst1, return_type = acc in + let* env, subst2 = + match with_arg with + | true -> + let* env, pat = infer_pattern env ~shadow:true pat in + let* subst2 = unify match_t pat in + return (env, subst2) + | false -> infer_match_pattern env ~shadow:true pat match_t + in + let* subst12 = Substitution.compose subst1 subst2 in + let env = TypeEnvironment.apply subst12 env in + let* subst3, expr_typ = infer_expr env expr in + let* subst4 = unify return_type expr_typ in + let* subst = Substitution.compose_all [ subst12; subst3; subst4 ] in + return (subst, Substitution.apply subst return_type)) + in + let final_typ = + match with_arg with + | true -> Arrow (Substitution.apply subst match_t, return_t) + | false -> return_t + in + return (subst, final_typ) + and extend_env_with_let_binds env is_rec let_binds = List.fold let_binds From c4d57e5ae8aa5b1cc3deb6a8935c66b73b0babc3 Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 28 Dec 2024 02:25:22 +0300 Subject: [PATCH 309/310] ref: eta reduction, remove redundant match Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index c5710a47b..9b83e8516 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -480,9 +480,7 @@ module StringSet = struct if is_empty (inter s1 s2) then return (union s1 s2) else fail `Bound_several_times ;; - let union_disjoint_many sets = - List.fold ~init:(return empty) ~f:(fun acc set -> union_disjoint acc set) sets - ;; + let union_disjoint_many sets = List.fold ~init:(return empty) ~f:union_disjoint sets end let rec extract_names_from_pattern = @@ -704,12 +702,12 @@ and infer_matching_expr env cases subst_init match_t return_t ~with_arg = ~f:(fun acc (pat, expr) -> let* subst1, return_type = acc in let* env, subst2 = - match with_arg with - | true -> + if with_arg + then let* env, pat = infer_pattern env ~shadow:true pat in let* subst2 = unify match_t pat in return (env, subst2) - | false -> infer_match_pattern env ~shadow:true pat match_t + else infer_match_pattern env ~shadow:true pat match_t in let* subst12 = Substitution.compose subst1 subst2 in let env = TypeEnvironment.apply subst12 env in @@ -719,9 +717,7 @@ and infer_matching_expr env cases subst_init match_t return_t ~with_arg = return (subst, Substitution.apply subst return_type)) in let final_typ = - match with_arg with - | true -> Arrow (Substitution.apply subst match_t, return_t) - | false -> return_t + if with_arg then Arrow (Substitution.apply subst match_t, return_t) else return_t in return (subst, final_typ) From bdbe09c673ffe9f32210483f1188f5d9506b2c5f Mon Sep 17 00:00:00 2001 From: Gleb Nasretdinov Date: Sat, 28 Dec 2024 02:27:11 +0300 Subject: [PATCH 310/310] ref: remove old comments Signed-off-by: Gleb Nasretdinov --- FSharpActivePatterns/lib/inferencer.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/FSharpActivePatterns/lib/inferencer.ml b/FSharpActivePatterns/lib/inferencer.ml index 9b83e8516..091125c2b 100644 --- a/FSharpActivePatterns/lib/inferencer.ml +++ b/FSharpActivePatterns/lib/inferencer.ml @@ -34,7 +34,6 @@ let pp_error fmt : error -> _ = function (* for treating result of type inference *) module R : sig - (* signature, smth like interface before realization *) type 'a t (* val bind : 'a t -> f:('a -> 'b t) -> 'b t *)