diff --git a/.gitmodules b/.gitmodules index 89ed412..e39542e 100644 --- a/.gitmodules +++ b/.gitmodules @@ -7,3 +7,6 @@ [submodule "ocaml"] path = ocaml url = https://github.com/ocaml/ocaml.git +[submodule "merlin_414"] + path = merlin_414 + url = https://github.com/ocaml/merlin.git diff --git a/Makefile b/Makefile index dcc24ff..9a5e1e5 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,7 @@ init: opam switch create . 5.1.1 --no-install -y opam install . --deps-only -y - opam install menhir.20210419 ocamlformat ocaml-lsp-server -y + opam install menhir.20201216 ocamlformat ocaml-lsp-server -y .PHONY: build build: diff --git a/dune b/dune index ad6afb6..c00aa63 100644 --- a/dune +++ b/dune @@ -1,3 +1,2 @@ -(vendored_dirs merlin ocaml-lsp) - -(data_only_dirs ocaml merlin-extend) +(vendored_dirs merlin-extend) +(data_only_dirs ocaml ocamlmerlin_mlx_414 merlin merlin_414) diff --git a/menhirLib/LICENSE b/menhirLib/LICENSE new file mode 100644 index 0000000..564dfd1 --- /dev/null +++ b/menhirLib/LICENSE @@ -0,0 +1,869 @@ +In the following, + +* "THE RUNTIME LIBRARY" refers to the files in the subdirectories lib/ + and cst/. + +* "THE SDK" refers to the files in the subdirectory sdk/. + +* "THE COQ LIBRARY" refers to the files in the subdirectory coq-menhirlib/. + +* "THE GENERATOR" refers to the files that are + not part of THE RUNTIME LIBRARY, + not part of the SDK, + not part of THE COQ LIBRARY, + and not located in the subdirectory test/. + +The files in the subdirectory test/ are not covered by this license. + +THE GENERATOR is distributed under the terms of the GNU General Public +License version 2 (included below). + +THE RUNTIME LIBRARY and the SDK are distributed under the terms of the +GNU Library General Public License version 2 (included below). + +As a special exception to the GNU Library General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute +that executable file under terms of your choice, without any of the +additional requirements listed in clause 6 of the GNU Library General +Public License. By "a publicly distributed version of the Library", +we mean either the unmodified Library as distributed by INRIA, or a +modified version of the Library that is distributed under the +conditions defined in clause 3 of the GNU Library General Public +License. This exception does not however invalidate any other reasons +why the executable file might be covered by the GNU Library General +Public License. + +THE COQ LIBRARY is distributed under the terms of the GNU Lesser +General Public License as published by the Free Software Foundation, +either version 3 of the License, or (at your option) any later +version. Version 3 of the GNU Lesser General Public License is +included in the file coq-menhirlib/LICENSE. + +---------------------------------------------------------------------- + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) 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 +this service 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 make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. 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. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute 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 and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the 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 a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, 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. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE 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. + + 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 +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This 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 2 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, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision 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, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This 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. + +---------------------------------------------------------------------- + + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, 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 +this service 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 make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, + MA 02111-1307, USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/mlx/menhirLib.ml b/menhirLib/menhirLib.ml similarity index 99% rename from mlx/menhirLib.ml rename to menhirLib/menhirLib.ml index 753d5e7..f178293 100644 --- a/mlx/menhirLib.ml +++ b/menhirLib/menhirLib.ml @@ -1509,7 +1509,8 @@ module Make (T : TABLE) = struct (* In the legacy strategy, we call [reduce] instead of [announce_reduce], apparently in an attempt to hide the reduction steps performed during - error handling. In the simplified strategy, all reductions steps are + error handling. This seems inconsistent, as the default reduction steps + are still announced. In the simplified strategy, all reductions are announced. *) match strategy with @@ -1545,15 +1546,7 @@ module Make (T : TABLE) = struct else begin (* The stack is nonempty. Pop a cell, updating the current state - to the state [cell.state] found in the popped cell, and continue - error handling there. *) - - (* I note that if the new state [cell.state] has a default reduction, - then it is ignored. It is unclear whether this is intentional. It - could be a good thing, as it avoids a scenario where the parser - diverges by repeatedly popping, performing a default reduction of - an epsilon production, popping, etc. Still, the question of whether - to obey default reductions while error handling seems obscure. *) + with that found in the popped cell, and try again. *) let env = { env with stack = next; @@ -3792,5 +3785,5 @@ module MakeEngineTable (T : TableFormat.TABLES) = struct end end module StaticVersion = struct -let require_20210419 = () +let require_20201216 = () end diff --git a/mlx/menhirLib.mli b/menhirLib/menhirLib.mli similarity index 99% rename from mlx/menhirLib.mli rename to menhirLib/menhirLib.mli index 9d19a7c..98db99e 100644 --- a/mlx/menhirLib.mli +++ b/menhirLib/menhirLib.mli @@ -1803,5 +1803,5 @@ module MakeEngineTable and type nonterminal = int end module StaticVersion : sig -val require_20210419: unit +val require_20201216: unit end diff --git a/mlx/dune b/mlx/dune index b98f004..3c20f61 100644 --- a/mlx/dune +++ b/mlx/dune @@ -57,7 +57,4 @@ (files ../ocaml/parsing/docstrings.{ml,mli})) (copy_files - (mode promote) - (enabled_if - (<> %{profile} "release")) - (files ../ocaml/boot/menhir/menhirLib.{ml,mli})) + (files ../menhirLib/menhirLib.{ml,mli})) diff --git a/mlx/parser.ml b/mlx/parser.ml index 9910a49..5a672be 100644 --- a/mlx/parser.ml +++ b/mlx/parser.ml @@ -2,7 +2,7 @@ (* This generated code requires the following version of MenhirLib: *) let () = - MenhirLib.StaticVersion.require_20210419 + MenhirLib.StaticVersion.require_20201216 module MenhirBasics = struct @@ -3471,11 +3471,14 @@ module Tables = struct # 3472 "mlx/parser.ml" in - let _3 = + let _3 = + let _1 = _1_inlined1 in + # 3825 "mlx/parser.mly" ( Override ) -# 3478 "mlx/parser.ml" - in +# 3480 "mlx/parser.ml" + + in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in @@ -3484,7 +3487,7 @@ module Tables = struct ( let loc = (_startpos__2_, _endpos__5_) in let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in mkclass ~loc:_sloc ~attrs:_4 (Pcl_open(od, _7)) ) -# 3488 "mlx/parser.ml" +# 3491 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3516,7 +3519,7 @@ module Tables = struct let _v : (Parsetree.class_expr) = # 1905 "mlx/parser.mly" ( Cl.attr _1 _2 ) -# 3520 "mlx/parser.ml" +# 3523 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3551,18 +3554,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 3555 "mlx/parser.ml" +# 3558 "mlx/parser.ml" in # 1003 "mlx/parser.mly" ( xs ) -# 3560 "mlx/parser.ml" +# 3563 "mlx/parser.ml" in # 1908 "mlx/parser.mly" ( Pcl_apply(_1, _2) ) -# 3566 "mlx/parser.ml" +# 3569 "mlx/parser.ml" in let _endpos__1_ = _endpos_xs_ in @@ -3572,13 +3575,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 3576 "mlx/parser.ml" +# 3579 "mlx/parser.ml" in # 1911 "mlx/parser.mly" ( _1 ) -# 3582 "mlx/parser.ml" +# 3585 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3604,7 +3607,7 @@ module Tables = struct let _1 = # 1910 "mlx/parser.mly" ( Pcl_extension _1 ) -# 3608 "mlx/parser.ml" +# 3611 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -3612,13 +3615,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 3616 "mlx/parser.ml" +# 3619 "mlx/parser.ml" in # 1911 "mlx/parser.mly" ( _1 ) -# 3622 "mlx/parser.ml" +# 3625 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3673,7 +3676,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 3677 "mlx/parser.ml" +# 3680 "mlx/parser.ml" in let _endpos__6_ = _endpos__1_inlined2_ in @@ -3682,13 +3685,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 3686 "mlx/parser.ml" +# 3689 "mlx/parser.ml" in let _2 = # 3824 "mlx/parser.mly" ( Fresh ) -# 3692 "mlx/parser.ml" +# 3695 "mlx/parser.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in @@ -3697,7 +3700,7 @@ module Tables = struct # 1960 "mlx/parser.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3701 "mlx/parser.ml" +# 3704 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3759,7 +3762,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 3763 "mlx/parser.ml" +# 3766 "mlx/parser.ml" in let _endpos__6_ = _endpos__1_inlined3_ in @@ -3768,14 +3771,17 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 3772 "mlx/parser.ml" +# 3775 "mlx/parser.ml" in - let _2 = + let _2 = + let _1 = _1_inlined1 in + # 3825 "mlx/parser.mly" ( Override ) -# 3778 "mlx/parser.ml" - in +# 3783 "mlx/parser.ml" + + in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in @@ -3783,7 +3789,7 @@ module Tables = struct # 1960 "mlx/parser.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3787 "mlx/parser.ml" +# 3793 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3825,7 +3831,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 3829 "mlx/parser.ml" +# 3835 "mlx/parser.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3837,7 +3843,7 @@ module Tables = struct ( let v, attrs = _2 in let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_val v) ~attrs:(attrs@_3) ~docs ) -# 3841 "mlx/parser.ml" +# 3847 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3879,7 +3885,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 3883 "mlx/parser.ml" +# 3889 "mlx/parser.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3891,7 +3897,7 @@ module Tables = struct ( let meth, attrs = _2 in let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_method meth) ~attrs:(attrs@_3) ~docs ) -# 3895 "mlx/parser.ml" +# 3901 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3939,7 +3945,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 3943 "mlx/parser.ml" +# 3949 "mlx/parser.ml" in let _endpos__4_ = _endpos__1_inlined2_ in @@ -3948,7 +3954,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 3952 "mlx/parser.ml" +# 3958 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -3958,7 +3964,7 @@ module Tables = struct # 1971 "mlx/parser.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 3962 "mlx/parser.ml" +# 3968 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4006,7 +4012,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 4010 "mlx/parser.ml" +# 4016 "mlx/parser.ml" in let _endpos__4_ = _endpos__1_inlined2_ in @@ -4015,7 +4021,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 4019 "mlx/parser.ml" +# 4025 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -4025,7 +4031,7 @@ module Tables = struct # 1974 "mlx/parser.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_initializer _3) ~attrs:(_2@_4) ~docs ) -# 4029 "mlx/parser.ml" +# 4035 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4059,7 +4065,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 4063 "mlx/parser.ml" +# 4069 "mlx/parser.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -4070,7 +4076,7 @@ module Tables = struct # 1977 "mlx/parser.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_extension _1) ~attrs:_2 ~docs ) -# 4074 "mlx/parser.ml" +# 4080 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4096,7 +4102,7 @@ module Tables = struct let _1 = # 1980 "mlx/parser.mly" ( Pcf_attribute _1 ) -# 4100 "mlx/parser.ml" +# 4106 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -4104,13 +4110,13 @@ module Tables = struct # 952 "mlx/parser.mly" ( mkcf ~loc:_sloc _1 ) -# 4108 "mlx/parser.ml" +# 4114 "mlx/parser.ml" in # 1981 "mlx/parser.mly" ( _1 ) -# 4114 "mlx/parser.ml" +# 4120 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4142,7 +4148,7 @@ module Tables = struct let _v : (Parsetree.class_expr) = # 1875 "mlx/parser.mly" ( _2 ) -# 4146 "mlx/parser.ml" +# 4152 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4189,7 +4195,7 @@ module Tables = struct let _1 = # 1878 "mlx/parser.mly" ( Pcl_constraint(_4, _2) ) -# 4193 "mlx/parser.ml" +# 4199 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in let _endpos = _endpos__1_ in @@ -4198,13 +4204,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 4202 "mlx/parser.ml" +# 4208 "mlx/parser.ml" in # 1881 "mlx/parser.mly" ( _1 ) -# 4208 "mlx/parser.ml" +# 4214 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4237,7 +4243,7 @@ module Tables = struct let _1 = # 1880 "mlx/parser.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, _2) ) -# 4241 "mlx/parser.ml" +# 4247 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in @@ -4246,13 +4252,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 4250 "mlx/parser.ml" +# 4256 "mlx/parser.ml" in # 1881 "mlx/parser.mly" ( _1 ) -# 4256 "mlx/parser.ml" +# 4262 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4292,7 +4298,7 @@ module Tables = struct let _1 = # 1936 "mlx/parser.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 4296 "mlx/parser.ml" +# 4302 "mlx/parser.ml" in let _endpos__1_ = _endpos_e_ in let _endpos = _endpos__1_ in @@ -4301,13 +4307,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 4305 "mlx/parser.ml" +# 4311 "mlx/parser.ml" in # 1937 "mlx/parser.mly" ( _1 ) -# 4311 "mlx/parser.ml" +# 4317 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4340,7 +4346,7 @@ module Tables = struct let _1 = # 1936 "mlx/parser.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 4344 "mlx/parser.ml" +# 4350 "mlx/parser.ml" in let _endpos__1_ = _endpos_e_ in let _endpos = _endpos__1_ in @@ -4349,13 +4355,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 4353 "mlx/parser.ml" +# 4359 "mlx/parser.ml" in # 1937 "mlx/parser.mly" ( _1 ) -# 4359 "mlx/parser.ml" +# 4365 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4380,7 +4386,7 @@ module Tables = struct let _v : (Longident.t) = # 3706 "mlx/parser.mly" ( _1 ) -# 4384 "mlx/parser.ml" +# 4390 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4422,7 +4428,7 @@ module Tables = struct # 1945 "mlx/parser.mly" ( reloc_pat ~loc:_sloc _2 ) -# 4426 "mlx/parser.ml" +# 4432 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4476,7 +4482,7 @@ module Tables = struct let _1 = # 1947 "mlx/parser.mly" ( Ppat_constraint(_2, _4) ) -# 4480 "mlx/parser.ml" +# 4486 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in let _endpos = _endpos__1_ in @@ -4485,13 +4491,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 4489 "mlx/parser.ml" +# 4495 "mlx/parser.ml" in # 1948 "mlx/parser.mly" ( _1 ) -# 4495 "mlx/parser.ml" +# 4501 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4512,7 +4518,7 @@ module Tables = struct # 1950 "mlx/parser.mly" ( ghpat ~loc:_sloc Ppat_any ) -# 4516 "mlx/parser.ml" +# 4522 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4551,7 +4557,7 @@ module Tables = struct let _v : (Parsetree.core_type) = # 2075 "mlx/parser.mly" ( _2 ) -# 4555 "mlx/parser.ml" +# 4561 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4570,7 +4576,7 @@ module Tables = struct let _1 = # 2076 "mlx/parser.mly" ( Ptyp_any ) -# 4574 "mlx/parser.ml" +# 4580 "mlx/parser.ml" in let _endpos__1_ = _endpos__0_ in let _endpos = _endpos__1_ in @@ -4579,13 +4585,13 @@ module Tables = struct # 938 "mlx/parser.mly" ( mktyp ~loc:_sloc _1 ) -# 4583 "mlx/parser.ml" +# 4589 "mlx/parser.ml" in # 2077 "mlx/parser.mly" ( _1 ) -# 4589 "mlx/parser.ml" +# 4595 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4633,7 +4639,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 4637 "mlx/parser.ml" +# 4643 "mlx/parser.ml" in let _endpos__4_ = _endpos__1_inlined2_ in @@ -4642,7 +4648,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 4646 "mlx/parser.ml" +# 4652 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -4652,7 +4658,7 @@ module Tables = struct # 2085 "mlx/parser.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_inherit _3) ~attrs:(_2@_4) ~docs ) -# 4656 "mlx/parser.ml" +# 4662 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4712,7 +4718,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 4716 "mlx/parser.ml" +# 4722 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let flags : (Asttypes.mutable_flag * Asttypes.virtual_flag) = Obj.magic flags in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -4725,7 +4731,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 4729 "mlx/parser.ml" +# 4735 "mlx/parser.ml" in let _endpos__4_ = _endpos__1_inlined3_ in @@ -4735,7 +4741,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 4739 "mlx/parser.ml" +# 4745 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -4743,7 +4749,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 4747 "mlx/parser.ml" +# 4753 "mlx/parser.ml" in @@ -4752,7 +4758,7 @@ module Tables = struct let mut, virt = flags in label, mut, virt, ty ) -# 4756 "mlx/parser.ml" +# 4762 "mlx/parser.ml" in let _2 = @@ -4760,7 +4766,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 4764 "mlx/parser.ml" +# 4770 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -4770,7 +4776,7 @@ module Tables = struct # 2088 "mlx/parser.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_val _3) ~attrs:(_2@_4) ~docs ) -# 4774 "mlx/parser.ml" +# 4780 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4830,7 +4836,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 4834 "mlx/parser.ml" +# 4840 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.private_flag * Asttypes.virtual_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -4843,7 +4849,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 4847 "mlx/parser.ml" +# 4853 "mlx/parser.ml" in let _endpos__7_ = _endpos__1_inlined4_ in @@ -4852,7 +4858,7 @@ module Tables = struct # 3333 "mlx/parser.mly" ( _1 ) -# 4856 "mlx/parser.ml" +# 4862 "mlx/parser.ml" in let _4 = @@ -4860,7 +4866,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 4864 "mlx/parser.ml" +# 4870 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -4868,7 +4874,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 4872 "mlx/parser.ml" +# 4878 "mlx/parser.ml" in let _2 = @@ -4876,7 +4882,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 4880 "mlx/parser.ml" +# 4886 "mlx/parser.ml" in let _endpos = _endpos__7_ in @@ -4887,7 +4893,7 @@ module Tables = struct ( let (p, v) = _3 in let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_method (_4, p, v, _6)) ~attrs:(_2@_7) ~docs ) -# 4891 "mlx/parser.ml" +# 4897 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4935,7 +4941,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 4939 "mlx/parser.ml" +# 4945 "mlx/parser.ml" in let _endpos__4_ = _endpos__1_inlined2_ in @@ -4944,7 +4950,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 4948 "mlx/parser.ml" +# 4954 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -4954,7 +4960,7 @@ module Tables = struct # 2096 "mlx/parser.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 4958 "mlx/parser.ml" +# 4964 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4988,7 +4994,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 4992 "mlx/parser.ml" +# 4998 "mlx/parser.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -4999,7 +5005,7 @@ module Tables = struct # 2099 "mlx/parser.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_extension _1) ~attrs:_2 ~docs ) -# 5003 "mlx/parser.ml" +# 5009 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5025,7 +5031,7 @@ module Tables = struct let _1 = # 2102 "mlx/parser.mly" ( Pctf_attribute _1 ) -# 5029 "mlx/parser.ml" +# 5035 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -5033,13 +5039,13 @@ module Tables = struct # 950 "mlx/parser.mly" ( mkctf ~loc:_sloc _1 ) -# 5037 "mlx/parser.ml" +# 5043 "mlx/parser.ml" in # 2103 "mlx/parser.mly" ( _1 ) -# 5043 "mlx/parser.ml" +# 5049 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5070,25 +5076,25 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 5074 "mlx/parser.ml" +# 5080 "mlx/parser.ml" in let tys = let tys = # 2061 "mlx/parser.mly" ( [] ) -# 5081 "mlx/parser.ml" +# 5087 "mlx/parser.ml" in # 2067 "mlx/parser.mly" ( tys ) -# 5086 "mlx/parser.ml" +# 5092 "mlx/parser.ml" in # 2044 "mlx/parser.mly" ( Pcty_constr (cid, tys) ) -# 5092 "mlx/parser.ml" +# 5098 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -5097,13 +5103,13 @@ module Tables = struct # 948 "mlx/parser.mly" ( mkcty ~loc:_sloc _1 ) -# 5101 "mlx/parser.ml" +# 5107 "mlx/parser.ml" in # 2047 "mlx/parser.mly" ( _1 ) -# 5107 "mlx/parser.ml" +# 5113 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5156,7 +5162,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 5160 "mlx/parser.ml" +# 5166 "mlx/parser.ml" in let tys = @@ -5165,30 +5171,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5169 "mlx/parser.ml" +# 5175 "mlx/parser.ml" in # 1035 "mlx/parser.mly" ( xs ) -# 5174 "mlx/parser.ml" +# 5180 "mlx/parser.ml" in # 2063 "mlx/parser.mly" ( params ) -# 5180 "mlx/parser.ml" +# 5186 "mlx/parser.ml" in # 2067 "mlx/parser.mly" ( tys ) -# 5186 "mlx/parser.ml" +# 5192 "mlx/parser.ml" in # 2044 "mlx/parser.mly" ( Pcty_constr (cid, tys) ) -# 5192 "mlx/parser.ml" +# 5198 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5198,13 +5204,13 @@ module Tables = struct # 948 "mlx/parser.mly" ( mkcty ~loc:_sloc _1 ) -# 5202 "mlx/parser.ml" +# 5208 "mlx/parser.ml" in # 2047 "mlx/parser.mly" ( _1 ) -# 5208 "mlx/parser.ml" +# 5214 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5230,7 +5236,7 @@ module Tables = struct let _1 = # 2046 "mlx/parser.mly" ( Pcty_extension _1 ) -# 5234 "mlx/parser.ml" +# 5240 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -5238,13 +5244,13 @@ module Tables = struct # 948 "mlx/parser.mly" ( mkcty ~loc:_sloc _1 ) -# 5242 "mlx/parser.ml" +# 5248 "mlx/parser.ml" in # 2047 "mlx/parser.mly" ( _1 ) -# 5248 "mlx/parser.ml" +# 5254 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5301,12 +5307,12 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5305 "mlx/parser.ml" +# 5311 "mlx/parser.ml" in # 2081 "mlx/parser.mly" ( _1 ) -# 5310 "mlx/parser.ml" +# 5316 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in @@ -5315,13 +5321,13 @@ module Tables = struct # 896 "mlx/parser.mly" ( extra_csig _startpos _endpos _1 ) -# 5319 "mlx/parser.ml" +# 5325 "mlx/parser.ml" in # 2071 "mlx/parser.mly" ( Csig.mk _1 _2 ) -# 5325 "mlx/parser.ml" +# 5331 "mlx/parser.ml" in let _2 = @@ -5329,7 +5335,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 5333 "mlx/parser.ml" +# 5339 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -5338,7 +5344,7 @@ module Tables = struct # 2049 "mlx/parser.mly" ( mkcty ~loc:_sloc ~attrs:_2 (Pcty_signature _3) ) -# 5342 "mlx/parser.ml" +# 5348 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5395,12 +5401,12 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5399 "mlx/parser.ml" +# 5405 "mlx/parser.ml" in # 2081 "mlx/parser.mly" ( _1 ) -# 5404 "mlx/parser.ml" +# 5410 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in @@ -5409,13 +5415,13 @@ module Tables = struct # 896 "mlx/parser.mly" ( extra_csig _startpos _endpos _1 ) -# 5413 "mlx/parser.ml" +# 5419 "mlx/parser.ml" in # 2071 "mlx/parser.mly" ( Csig.mk _1 _2 ) -# 5419 "mlx/parser.ml" +# 5425 "mlx/parser.ml" in let _2 = @@ -5423,7 +5429,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 5427 "mlx/parser.ml" +# 5433 "mlx/parser.ml" in let _loc__4_ = (_startpos__4_, _endpos__4_) in @@ -5431,7 +5437,7 @@ module Tables = struct # 2051 "mlx/parser.mly" ( unclosed "object" _loc__1_ "end" _loc__4_ ) -# 5435 "mlx/parser.ml" +# 5441 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5463,7 +5469,7 @@ module Tables = struct let _v : (Parsetree.class_type) = # 2053 "mlx/parser.mly" ( Cty.attr _1 _2 ) -# 5467 "mlx/parser.ml" +# 5473 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5528,7 +5534,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 5532 "mlx/parser.ml" +# 5538 "mlx/parser.ml" in let _endpos__5_ = _endpos__1_inlined2_ in @@ -5537,13 +5543,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 5541 "mlx/parser.ml" +# 5547 "mlx/parser.ml" in let _3 = # 3824 "mlx/parser.mly" ( Fresh ) -# 5547 "mlx/parser.ml" +# 5553 "mlx/parser.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in @@ -5553,7 +5559,7 @@ module Tables = struct ( let loc = (_startpos__2_, _endpos__5_) in let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in mkcty ~loc:_sloc ~attrs:_4 (Pcty_open(od, _7)) ) -# 5557 "mlx/parser.ml" +# 5563 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5625,7 +5631,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 5629 "mlx/parser.ml" +# 5635 "mlx/parser.ml" in let _endpos__5_ = _endpos__1_inlined3_ in @@ -5634,14 +5640,17 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 5638 "mlx/parser.ml" +# 5644 "mlx/parser.ml" in - let _3 = + let _3 = + let _1 = _1_inlined1 in + # 3825 "mlx/parser.mly" ( Override ) -# 5644 "mlx/parser.ml" - in +# 5652 "mlx/parser.ml" + + in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in @@ -5650,7 +5659,7 @@ module Tables = struct ( let loc = (_startpos__2_, _endpos__5_) in let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in mkcty ~loc:_sloc ~attrs:_4 (Pcty_open(od, _7)) ) -# 5654 "mlx/parser.ml" +# 5663 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5689,7 +5698,7 @@ module Tables = struct let _v : (Parsetree.class_expr) = # 1915 "mlx/parser.mly" ( _2 ) -# 5693 "mlx/parser.ml" +# 5702 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5730,7 +5739,7 @@ module Tables = struct # 1917 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__3_ ) -# 5734 "mlx/parser.ml" +# 5743 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5761,25 +5770,25 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 5765 "mlx/parser.ml" +# 5774 "mlx/parser.ml" in let tys = let tys = # 2061 "mlx/parser.mly" ( [] ) -# 5772 "mlx/parser.ml" +# 5781 "mlx/parser.ml" in # 2067 "mlx/parser.mly" ( tys ) -# 5777 "mlx/parser.ml" +# 5786 "mlx/parser.ml" in # 1920 "mlx/parser.mly" ( Pcl_constr(cid, tys) ) -# 5783 "mlx/parser.ml" +# 5792 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -5788,13 +5797,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 5792 "mlx/parser.ml" +# 5801 "mlx/parser.ml" in # 1927 "mlx/parser.mly" ( _1 ) -# 5798 "mlx/parser.ml" +# 5807 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5847,7 +5856,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 5851 "mlx/parser.ml" +# 5860 "mlx/parser.ml" in let tys = @@ -5856,30 +5865,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5860 "mlx/parser.ml" +# 5869 "mlx/parser.ml" in # 1035 "mlx/parser.mly" ( xs ) -# 5865 "mlx/parser.ml" +# 5874 "mlx/parser.ml" in # 2063 "mlx/parser.mly" ( params ) -# 5871 "mlx/parser.ml" +# 5880 "mlx/parser.ml" in # 2067 "mlx/parser.mly" ( tys ) -# 5877 "mlx/parser.ml" +# 5886 "mlx/parser.ml" in # 1920 "mlx/parser.mly" ( Pcl_constr(cid, tys) ) -# 5883 "mlx/parser.ml" +# 5892 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5889,13 +5898,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 5893 "mlx/parser.ml" +# 5902 "mlx/parser.ml" in # 1927 "mlx/parser.mly" ( _1 ) -# 5899 "mlx/parser.ml" +# 5908 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5954,12 +5963,12 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5958 "mlx/parser.ml" +# 5967 "mlx/parser.ml" in # 1954 "mlx/parser.mly" ( _1 ) -# 5963 "mlx/parser.ml" +# 5972 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in @@ -5968,13 +5977,13 @@ module Tables = struct # 895 "mlx/parser.mly" ( extra_cstr _startpos _endpos _1 ) -# 5972 "mlx/parser.ml" +# 5981 "mlx/parser.ml" in # 1941 "mlx/parser.mly" ( Cstr.mk _1 _2 ) -# 5978 "mlx/parser.ml" +# 5987 "mlx/parser.ml" in let _2 = @@ -5982,7 +5991,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 5986 "mlx/parser.ml" +# 5995 "mlx/parser.ml" in let _loc__4_ = (_startpos__4_, _endpos__4_) in @@ -5990,7 +5999,7 @@ module Tables = struct # 1922 "mlx/parser.mly" ( unclosed "object" _loc__1_ "end" _loc__4_ ) -# 5994 "mlx/parser.ml" +# 6003 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in @@ -6000,13 +6009,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 6004 "mlx/parser.ml" +# 6013 "mlx/parser.ml" in # 1927 "mlx/parser.mly" ( _1 ) -# 6010 "mlx/parser.ml" +# 6019 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6060,7 +6069,7 @@ module Tables = struct let _1 = # 1924 "mlx/parser.mly" ( Pcl_constraint(_2, _4) ) -# 6064 "mlx/parser.ml" +# 6073 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in let _endpos = _endpos__1_ in @@ -6069,13 +6078,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 6073 "mlx/parser.ml" +# 6082 "mlx/parser.ml" in # 1927 "mlx/parser.mly" ( _1 ) -# 6079 "mlx/parser.ml" +# 6088 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6132,7 +6141,7 @@ module Tables = struct # 1926 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__5_ ) -# 6136 "mlx/parser.ml" +# 6145 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -6142,13 +6151,13 @@ module Tables = struct # 954 "mlx/parser.mly" ( mkclass ~loc:_sloc _1 ) -# 6146 "mlx/parser.ml" +# 6155 "mlx/parser.ml" in # 1927 "mlx/parser.mly" ( _1 ) -# 6152 "mlx/parser.ml" +# 6161 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6205,12 +6214,12 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 6209 "mlx/parser.ml" +# 6218 "mlx/parser.ml" in # 1954 "mlx/parser.mly" ( _1 ) -# 6214 "mlx/parser.ml" +# 6223 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in @@ -6219,13 +6228,13 @@ module Tables = struct # 895 "mlx/parser.mly" ( extra_cstr _startpos _endpos _1 ) -# 6223 "mlx/parser.ml" +# 6232 "mlx/parser.ml" in # 1941 "mlx/parser.mly" ( Cstr.mk _1 _2 ) -# 6229 "mlx/parser.ml" +# 6238 "mlx/parser.ml" in let _2 = @@ -6233,7 +6242,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 6237 "mlx/parser.ml" +# 6246 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -6242,7 +6251,7 @@ module Tables = struct # 1929 "mlx/parser.mly" ( mkclass ~loc:_sloc ~attrs:_2 (Pcl_structure _3) ) -# 6246 "mlx/parser.ml" +# 6255 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6267,7 +6276,7 @@ module Tables = struct let _v : (Parsetree.class_type) = # 2032 "mlx/parser.mly" ( _1 ) -# 6271 "mlx/parser.ml" +# 6280 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6315,12 +6324,12 @@ module Tables = struct let label = # 3396 "mlx/parser.mly" ( Optional label ) -# 6319 "mlx/parser.ml" +# 6328 "mlx/parser.ml" in # 2038 "mlx/parser.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6324 "mlx/parser.ml" +# 6333 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -6330,13 +6339,13 @@ module Tables = struct # 948 "mlx/parser.mly" ( mkcty ~loc:_sloc _1 ) -# 6334 "mlx/parser.ml" +# 6343 "mlx/parser.ml" in # 2039 "mlx/parser.mly" ( _1 ) -# 6340 "mlx/parser.ml" +# 6349 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6385,7 +6394,7 @@ module Tables = struct let label : ( # 714 "mlx/parser.mly" (string) -# 6389 "mlx/parser.ml" +# 6398 "mlx/parser.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -6395,12 +6404,12 @@ module Tables = struct let label = # 3398 "mlx/parser.mly" ( Labelled label ) -# 6399 "mlx/parser.ml" +# 6408 "mlx/parser.ml" in # 2038 "mlx/parser.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6404 "mlx/parser.ml" +# 6413 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -6410,13 +6419,13 @@ module Tables = struct # 948 "mlx/parser.mly" ( mkcty ~loc:_sloc _1 ) -# 6414 "mlx/parser.ml" +# 6423 "mlx/parser.ml" in # 2039 "mlx/parser.mly" ( _1 ) -# 6420 "mlx/parser.ml" +# 6429 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6457,12 +6466,12 @@ module Tables = struct let label = # 3400 "mlx/parser.mly" ( Nolabel ) -# 6461 "mlx/parser.ml" +# 6470 "mlx/parser.ml" in # 2038 "mlx/parser.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6466 "mlx/parser.ml" +# 6475 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_domain_) in @@ -6472,13 +6481,13 @@ module Tables = struct # 948 "mlx/parser.mly" ( mkcty ~loc:_sloc _1 ) -# 6476 "mlx/parser.ml" +# 6485 "mlx/parser.ml" in # 2039 "mlx/parser.mly" ( _1 ) -# 6482 "mlx/parser.ml" +# 6491 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6556,14 +6565,14 @@ module Tables = struct }; }; } = _menhir_stack in - let bs : (Parsetree.class_type_declaration list) = Obj.magic bs in + let bs : (Parsetree.class_type Parsetree.class_infos list) = Obj.magic bs in let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let csig : (Parsetree.class_type) = Obj.magic csig in let _8 : unit = Obj.magic _8 in let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 6567 "mlx/parser.ml" +# 6576 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -6581,7 +6590,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 6585 "mlx/parser.ml" +# 6594 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -6593,7 +6602,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 6597 "mlx/parser.ml" +# 6606 "mlx/parser.ml" in let attrs1 = @@ -6601,7 +6610,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 6605 "mlx/parser.ml" +# 6614 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -6616,19 +6625,19 @@ module Tables = struct ext, Ci.mk id csig ~virt ~params ~attrs ~loc ~docs ) -# 6620 "mlx/parser.ml" +# 6629 "mlx/parser.ml" in # 1132 "mlx/parser.mly" ( let (x, b) = a in x, b :: bs ) -# 6626 "mlx/parser.ml" +# 6635 "mlx/parser.ml" in # 2165 "mlx/parser.mly" ( _1 ) -# 6632 "mlx/parser.ml" +# 6641 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6653,7 +6662,7 @@ module Tables = struct let _v : (Longident.t) = # 3703 "mlx/parser.mly" ( _1 ) -# 6657 "mlx/parser.ml" +# 6666 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6674,7 +6683,7 @@ module Tables = struct let _1 : ( # 699 "mlx/parser.mly" (string * char option) -# 6678 "mlx/parser.ml" +# 6687 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -6682,7 +6691,7 @@ module Tables = struct let _v : (Parsetree.constant) = # 3568 "mlx/parser.mly" ( let (n, m) = _1 in Pconst_integer (n, m) ) -# 6686 "mlx/parser.ml" +# 6695 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6703,7 +6712,7 @@ module Tables = struct let _1 : ( # 657 "mlx/parser.mly" (char) -# 6707 "mlx/parser.ml" +# 6716 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -6711,7 +6720,7 @@ module Tables = struct let _v : (Parsetree.constant) = # 3569 "mlx/parser.mly" ( Pconst_char _1 ) -# 6715 "mlx/parser.ml" +# 6724 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6732,7 +6741,7 @@ module Tables = struct let _1 : ( # 754 "mlx/parser.mly" (string * Location.t * string option) -# 6736 "mlx/parser.ml" +# 6745 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -6740,7 +6749,7 @@ module Tables = struct let _v : (Parsetree.constant) = # 3570 "mlx/parser.mly" ( let (s, strloc, d) = _1 in Pconst_string (s, strloc, d) ) -# 6744 "mlx/parser.ml" +# 6753 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6761,7 +6770,7 @@ module Tables = struct let _1 : ( # 677 "mlx/parser.mly" (string * char option) -# 6765 "mlx/parser.ml" +# 6774 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -6769,7 +6778,7 @@ module Tables = struct let _v : (Parsetree.constant) = # 3571 "mlx/parser.mly" ( let (f, m) = _1 in Pconst_float (f, m) ) -# 6773 "mlx/parser.ml" +# 6782 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6801,7 +6810,7 @@ module Tables = struct let _v : (string) = # 3642 "mlx/parser.mly" ( "[]" ) -# 6805 "mlx/parser.ml" +# 6814 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6833,7 +6842,7 @@ module Tables = struct let _v : (string) = # 3643 "mlx/parser.mly" ( "()" ) -# 6837 "mlx/parser.ml" +# 6846 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6858,7 +6867,7 @@ module Tables = struct let _v : (string) = # 3644 "mlx/parser.mly" ( "false" ) -# 6862 "mlx/parser.ml" +# 6871 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6883,7 +6892,7 @@ module Tables = struct let _v : (string) = # 3645 "mlx/parser.mly" ( "true" ) -# 6887 "mlx/parser.ml" +# 6896 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6904,7 +6913,7 @@ module Tables = struct let _1 : ( # 767 "mlx/parser.mly" (string) -# 6908 "mlx/parser.ml" +# 6917 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -6912,7 +6921,7 @@ module Tables = struct let _v : (string) = # 3648 "mlx/parser.mly" ( _1 ) -# 6916 "mlx/parser.ml" +# 6925 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6951,12 +6960,12 @@ module Tables = struct let _v : (string) = let _1 = # 3639 "mlx/parser.mly" ( "::" ) -# 6955 "mlx/parser.ml" +# 6964 "mlx/parser.ml" in # 3649 "mlx/parser.mly" ( _1 ) -# 6960 "mlx/parser.ml" +# 6969 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6981,7 +6990,7 @@ module Tables = struct let _v : (string) = # 3650 "mlx/parser.mly" ( _1 ) -# 6985 "mlx/parser.ml" +# 6994 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7006,7 +7015,7 @@ module Tables = struct let _v : (Longident.t) = # 3653 "mlx/parser.mly" ( _1 ) -# 7010 "mlx/parser.ml" +# 7019 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7056,15 +7065,18 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in - let _v : (Longident.t) = let _3 = + let _v : (Longident.t) = let _3 = + let (_2, _1) = (_2_inlined1, _1_inlined1) in + # 3639 "mlx/parser.mly" ( "::" ) -# 7063 "mlx/parser.ml" - in +# 7074 "mlx/parser.ml" + + in # 3654 "mlx/parser.mly" ( Ldot(_1,_3) ) -# 7068 "mlx/parser.ml" +# 7080 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7103,12 +7115,12 @@ module Tables = struct let _v : (Longident.t) = let _1 = # 3639 "mlx/parser.mly" ( "::" ) -# 7107 "mlx/parser.ml" +# 7119 "mlx/parser.ml" in # 3655 "mlx/parser.mly" ( Lident _1 ) -# 7112 "mlx/parser.ml" +# 7124 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7133,7 +7145,7 @@ module Tables = struct let _v : (Longident.t) = # 3656 "mlx/parser.mly" ( Lident _1 ) -# 7137 "mlx/parser.ml" +# 7149 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7172,7 +7184,7 @@ module Tables = struct let _v : (Parsetree.core_type * Parsetree.core_type) = # 2121 "mlx/parser.mly" ( _1, _3 ) -# 7176 "mlx/parser.ml" +# 7188 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7199,24 +7211,24 @@ module Tables = struct let xs = # 1019 "mlx/parser.mly" ( [ x ] ) -# 7203 "mlx/parser.ml" +# 7215 "mlx/parser.ml" in # 253 "" ( List.rev xs ) -# 7208 "mlx/parser.ml" +# 7220 "mlx/parser.ml" in # 1039 "mlx/parser.mly" ( xs ) -# 7214 "mlx/parser.ml" +# 7226 "mlx/parser.ml" in # 3199 "mlx/parser.mly" ( Pcstr_tuple tys ) -# 7220 "mlx/parser.ml" +# 7232 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7257,24 +7269,24 @@ module Tables = struct let xs = # 1023 "mlx/parser.mly" ( x :: xs ) -# 7261 "mlx/parser.ml" +# 7273 "mlx/parser.ml" in # 253 "" ( List.rev xs ) -# 7266 "mlx/parser.ml" +# 7278 "mlx/parser.ml" in # 1039 "mlx/parser.mly" ( xs ) -# 7272 "mlx/parser.ml" +# 7284 "mlx/parser.ml" in # 3199 "mlx/parser.mly" ( Pcstr_tuple tys ) -# 7278 "mlx/parser.ml" +# 7290 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7313,7 +7325,7 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = # 3201 "mlx/parser.mly" ( Pcstr_record _2 ) -# 7317 "mlx/parser.ml" +# 7329 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7338,7 +7350,7 @@ module Tables = struct let _v : (Parsetree.constructor_declaration list) = # 3115 "mlx/parser.mly" ( [] ) -# 7342 "mlx/parser.ml" +# 7354 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7363,12 +7375,12 @@ module Tables = struct let _v : (Parsetree.constructor_declaration list) = let cs = # 1124 "mlx/parser.mly" ( List.rev xs ) -# 7367 "mlx/parser.ml" +# 7379 "mlx/parser.ml" in # 3117 "mlx/parser.mly" ( cs ) -# 7372 "mlx/parser.ml" +# 7384 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7393,12 +7405,12 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = # 3358 "mlx/parser.mly" ( _1 ) -# 7397 "mlx/parser.ml" +# 7409 "mlx/parser.ml" in # 3348 "mlx/parser.mly" ( _1 ) -# 7402 "mlx/parser.ml" +# 7414 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7430,7 +7442,7 @@ module Tables = struct let _v : (Parsetree.core_type) = # 3350 "mlx/parser.mly" ( Typ.attr _1 _2 ) -# 7434 "mlx/parser.ml" +# 7446 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7455,7 +7467,7 @@ module Tables = struct let _v : (Asttypes.direction_flag) = # 3769 "mlx/parser.mly" ( Upto ) -# 7459 "mlx/parser.ml" +# 7471 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7480,7 +7492,7 @@ module Tables = struct let _v : (Asttypes.direction_flag) = # 3770 "mlx/parser.mly" ( Downto ) -# 7484 "mlx/parser.ml" +# 7496 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7505,7 +7517,7 @@ module Tables = struct let _v : (Parsetree.expression) = # 2288 "mlx/parser.mly" ( _1 ) -# 7509 "mlx/parser.ml" +# 7521 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7585,7 +7597,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 7589 "mlx/parser.ml" +# 7601 "mlx/parser.ml" in let _3 = @@ -7595,19 +7607,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 7599 "mlx/parser.ml" +# 7611 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 7605 "mlx/parser.ml" +# 7617 "mlx/parser.ml" in # 2321 "mlx/parser.mly" ( Pexp_letmodule(_4, _5, _7), _3 ) -# 7611 "mlx/parser.ml" +# 7623 "mlx/parser.ml" in let _endpos__1_ = _endpos__7_ in @@ -7618,7 +7630,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 7622 "mlx/parser.ml" +# 7634 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7687,7 +7699,7 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in - let _2_inlined1 : (Ast_helper.str list * Parsetree.constructor_arguments * + let _2_inlined1 : (Dune__exe__Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic _2_inlined1 in let _1_inlined3 : (string) = Obj.magic _1_inlined3 in let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in @@ -7705,7 +7717,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 7709 "mlx/parser.ml" +# 7721 "mlx/parser.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -7716,7 +7728,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 7720 "mlx/parser.ml" +# 7732 "mlx/parser.ml" in let _endpos = _endpos__3_ in @@ -7726,7 +7738,7 @@ module Tables = struct # 3179 "mlx/parser.mly" ( let vars, args, res = _2 in Te.decl _1 ~vars ~args ?res ~attrs:_3 ~loc:(make_loc _sloc) ) -# 7730 "mlx/parser.ml" +# 7742 "mlx/parser.ml" in let _3 = @@ -7736,19 +7748,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 7740 "mlx/parser.ml" +# 7752 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 7746 "mlx/parser.ml" +# 7758 "mlx/parser.ml" in # 2323 "mlx/parser.mly" ( Pexp_letexception(_4, _6), _3 ) -# 7752 "mlx/parser.ml" +# 7764 "mlx/parser.ml" in let _endpos__1_ = _endpos__6_ in @@ -7759,7 +7771,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 7763 "mlx/parser.ml" +# 7775 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7831,26 +7843,26 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 7835 "mlx/parser.ml" +# 7847 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 7841 "mlx/parser.ml" +# 7853 "mlx/parser.ml" in let _3 = # 3824 "mlx/parser.mly" ( Fresh ) -# 7847 "mlx/parser.ml" +# 7859 "mlx/parser.ml" in # 2325 "mlx/parser.mly" ( let open_loc = make_loc (_startpos__2_, _endpos__5_) in let od = Opn.mk _5 ~override:_3 ~loc:open_loc in Pexp_open(od, _7), _4 ) -# 7854 "mlx/parser.ml" +# 7866 "mlx/parser.ml" in let _endpos__1_ = _endpos__7_ in @@ -7861,7 +7873,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 7865 "mlx/parser.ml" +# 7877 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7940,26 +7952,29 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 7944 "mlx/parser.ml" +# 7956 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 7950 "mlx/parser.ml" +# 7962 "mlx/parser.ml" in - let _3 = + let _3 = + let _1 = _1_inlined1 in + # 3825 "mlx/parser.mly" ( Override ) -# 7956 "mlx/parser.ml" - in +# 7970 "mlx/parser.ml" + + in # 2325 "mlx/parser.mly" ( let open_loc = make_loc (_startpos__2_, _endpos__5_) in let od = Opn.mk _5 ~override:_3 ~loc:open_loc in Pexp_open(od, _7), _4 ) -# 7963 "mlx/parser.ml" +# 7978 "mlx/parser.ml" in let _endpos__1_ = _endpos__7_ in @@ -7970,7 +7985,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 7974 "mlx/parser.ml" +# 7989 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8019,18 +8034,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8023 "mlx/parser.ml" +# 8038 "mlx/parser.ml" in # 1096 "mlx/parser.mly" ( xs ) -# 8028 "mlx/parser.ml" +# 8043 "mlx/parser.ml" in # 2662 "mlx/parser.mly" ( xs ) -# 8034 "mlx/parser.ml" +# 8049 "mlx/parser.ml" in let _2 = @@ -8040,19 +8055,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 8044 "mlx/parser.ml" +# 8059 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 8050 "mlx/parser.ml" +# 8065 "mlx/parser.ml" in # 2329 "mlx/parser.mly" ( Pexp_function _3, _2 ) -# 8056 "mlx/parser.ml" +# 8071 "mlx/parser.ml" in let _endpos__1_ = _endpos_xs_ in @@ -8063,7 +8078,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8067 "mlx/parser.ml" +# 8082 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8121,20 +8136,20 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 8125 "mlx/parser.ml" +# 8140 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 8131 "mlx/parser.ml" +# 8146 "mlx/parser.ml" in # 2331 "mlx/parser.mly" ( let (l,o,p) = _3 in Pexp_fun(l, o, p, _4), _2 ) -# 8138 "mlx/parser.ml" +# 8153 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in @@ -8145,7 +8160,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8149 "mlx/parser.ml" +# 8164 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8220,7 +8235,7 @@ module Tables = struct let _5 = # 2549 "mlx/parser.mly" ( xs ) -# 8224 "mlx/parser.ml" +# 8239 "mlx/parser.ml" in let _2 = let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in @@ -8229,13 +8244,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 8233 "mlx/parser.ml" +# 8248 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 8239 "mlx/parser.ml" +# 8254 "mlx/parser.ml" in let _endpos = _endpos__7_ in @@ -8244,7 +8259,7 @@ module Tables = struct # 2334 "mlx/parser.mly" ( (mk_newtypes ~loc:_sloc _5 _7).pexp_desc, _2 ) -# 8248 "mlx/parser.ml" +# 8263 "mlx/parser.ml" in let _endpos__1_ = _endpos__7_ in @@ -8255,7 +8270,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8259 "mlx/parser.ml" +# 8274 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8318,18 +8333,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8322 "mlx/parser.ml" +# 8337 "mlx/parser.ml" in # 1096 "mlx/parser.mly" ( xs ) -# 8327 "mlx/parser.ml" +# 8342 "mlx/parser.ml" in # 2662 "mlx/parser.mly" ( xs ) -# 8333 "mlx/parser.ml" +# 8348 "mlx/parser.ml" in let _2 = @@ -8339,19 +8354,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 8343 "mlx/parser.ml" +# 8358 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 8349 "mlx/parser.ml" +# 8364 "mlx/parser.ml" in # 2336 "mlx/parser.mly" ( Pexp_match(_3, _5), _2 ) -# 8355 "mlx/parser.ml" +# 8370 "mlx/parser.ml" in let _endpos__1_ = _endpos_xs_ in @@ -8362,7 +8377,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8366 "mlx/parser.ml" +# 8381 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8425,18 +8440,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8429 "mlx/parser.ml" +# 8444 "mlx/parser.ml" in # 1096 "mlx/parser.mly" ( xs ) -# 8434 "mlx/parser.ml" +# 8449 "mlx/parser.ml" in # 2662 "mlx/parser.mly" ( xs ) -# 8440 "mlx/parser.ml" +# 8455 "mlx/parser.ml" in let _2 = @@ -8446,19 +8461,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 8450 "mlx/parser.ml" +# 8465 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 8456 "mlx/parser.ml" +# 8471 "mlx/parser.ml" in # 2338 "mlx/parser.mly" ( Pexp_try(_3, _5), _2 ) -# 8462 "mlx/parser.ml" +# 8477 "mlx/parser.ml" in let _endpos__1_ = _endpos_xs_ in @@ -8469,7 +8484,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8473 "mlx/parser.ml" +# 8488 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8534,19 +8549,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 8538 "mlx/parser.ml" +# 8553 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 8544 "mlx/parser.ml" +# 8559 "mlx/parser.ml" in # 2340 "mlx/parser.mly" ( syntax_error() ) -# 8550 "mlx/parser.ml" +# 8565 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -8557,7 +8572,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8561 "mlx/parser.ml" +# 8576 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8636,19 +8651,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 8640 "mlx/parser.ml" +# 8655 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 8646 "mlx/parser.ml" +# 8661 "mlx/parser.ml" in # 2342 "mlx/parser.mly" ( Pexp_ifthenelse(_3, _5, Some _7), _2 ) -# 8652 "mlx/parser.ml" +# 8667 "mlx/parser.ml" in let _endpos__1_ = _endpos__7_ in @@ -8659,7 +8674,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8663 "mlx/parser.ml" +# 8678 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8724,19 +8739,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 8728 "mlx/parser.ml" +# 8743 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 8734 "mlx/parser.ml" +# 8749 "mlx/parser.ml" in # 2344 "mlx/parser.mly" ( Pexp_ifthenelse(_3, _5, None), _2 ) -# 8740 "mlx/parser.ml" +# 8755 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -8747,7 +8762,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8751 "mlx/parser.ml" +# 8766 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8812,11 +8827,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_inlined1_ in let _v : (Parsetree.expression) = let _1 = - let _4 = + let _4 = + let (_3, _1) = (_3_inlined1, _1_inlined3) in + # 2357 "mlx/parser.mly" ( e ) -# 8819 "mlx/parser.ml" - in +# 8836 "mlx/parser.ml" + + in let _2 = let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in let _2 = @@ -8824,19 +8842,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 8828 "mlx/parser.ml" +# 8846 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 8834 "mlx/parser.ml" +# 8852 "mlx/parser.ml" in # 2346 "mlx/parser.mly" ( Pexp_while(_3, _4), _2 ) -# 8840 "mlx/parser.ml" +# 8858 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_inlined1_ in @@ -8847,7 +8865,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8851 "mlx/parser.ml" +# 8869 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8913,13 +8931,13 @@ module Tables = struct let _endpos = _endpos__3_inlined1_ in let _v : (Parsetree.expression) = let _1 = let _4 = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined3_, _startpos__1_inlined3_) in + let (_endpos__1_, _startpos__1_, _3, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _3_inlined1, _1_inlined3) in let _loc__2_ = (_startpos__2_, _endpos__2_) in let _loc__1_ = (_startpos__1_, _endpos__1_) in # 2359 "mlx/parser.mly" ( unclosed "do" _loc__1_ "done" _loc__2_ ) -# 8923 "mlx/parser.ml" +# 8941 "mlx/parser.ml" in let _2 = @@ -8929,19 +8947,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 8933 "mlx/parser.ml" +# 8951 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 8939 "mlx/parser.ml" +# 8957 "mlx/parser.ml" in # 2346 "mlx/parser.mly" ( Pexp_while(_3, _4), _2 ) -# 8945 "mlx/parser.ml" +# 8963 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_inlined1_ in @@ -8952,7 +8970,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8956 "mlx/parser.ml" +# 8974 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9045,11 +9063,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_inlined1_ in let _v : (Parsetree.expression) = let _1 = - let _8 = + let _8 = + let (_3, _1) = (_3_inlined1, _1_inlined3) in + # 2357 "mlx/parser.mly" ( e ) -# 9052 "mlx/parser.ml" - in +# 9072 "mlx/parser.ml" + + in let _2 = let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in let _2 = @@ -9057,19 +9078,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 9061 "mlx/parser.ml" +# 9082 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 9067 "mlx/parser.ml" +# 9088 "mlx/parser.ml" in # 2349 "mlx/parser.mly" ( Pexp_for(_3, _5, _7, _6, _8), _2 ) -# 9073 "mlx/parser.ml" +# 9094 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_inlined1_ in @@ -9080,7 +9101,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9084 "mlx/parser.ml" +# 9105 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9174,13 +9195,13 @@ module Tables = struct let _endpos = _endpos__3_inlined1_ in let _v : (Parsetree.expression) = let _1 = let _8 = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined3_, _startpos__1_inlined3_) in + let (_endpos__1_, _startpos__1_, _3, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _3_inlined1, _1_inlined3) in let _loc__2_ = (_startpos__2_, _endpos__2_) in let _loc__1_ = (_startpos__1_, _endpos__1_) in # 2359 "mlx/parser.mly" ( unclosed "do" _loc__1_ "done" _loc__2_ ) -# 9184 "mlx/parser.ml" +# 9205 "mlx/parser.ml" in let _2 = @@ -9190,19 +9211,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 9194 "mlx/parser.ml" +# 9215 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 9200 "mlx/parser.ml" +# 9221 "mlx/parser.ml" in # 2349 "mlx/parser.mly" ( Pexp_for(_3, _5, _7, _6, _8), _2 ) -# 9206 "mlx/parser.ml" +# 9227 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_inlined1_ in @@ -9213,7 +9234,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9217 "mlx/parser.ml" +# 9238 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9264,19 +9285,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 9268 "mlx/parser.ml" +# 9289 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 9274 "mlx/parser.ml" +# 9295 "mlx/parser.ml" in # 2351 "mlx/parser.mly" ( Pexp_assert _3, _2 ) -# 9280 "mlx/parser.ml" +# 9301 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -9287,7 +9308,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9291 "mlx/parser.ml" +# 9312 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9338,19 +9359,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 9342 "mlx/parser.ml" +# 9363 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 9348 "mlx/parser.ml" +# 9369 "mlx/parser.ml" in # 2353 "mlx/parser.mly" ( Pexp_lazy _3, _2 ) -# 9354 "mlx/parser.ml" +# 9375 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -9361,7 +9382,7 @@ module Tables = struct # 2290 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9365 "mlx/parser.ml" +# 9386 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9396,18 +9417,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9400 "mlx/parser.ml" +# 9421 "mlx/parser.ml" in # 1003 "mlx/parser.mly" ( xs ) -# 9405 "mlx/parser.ml" +# 9426 "mlx/parser.ml" in # 2363 "mlx/parser.mly" ( Pexp_apply(_1, _2) ) -# 9411 "mlx/parser.ml" +# 9432 "mlx/parser.ml" in let _endpos__1_ = _endpos_xs_ in @@ -9417,13 +9438,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 9421 "mlx/parser.ml" +# 9442 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 9427 "mlx/parser.ml" +# 9448 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9452,24 +9473,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9456 "mlx/parser.ml" +# 9477 "mlx/parser.ml" in # 1063 "mlx/parser.mly" ( xs ) -# 9461 "mlx/parser.ml" +# 9482 "mlx/parser.ml" in # 2689 "mlx/parser.mly" ( es ) -# 9467 "mlx/parser.ml" +# 9488 "mlx/parser.ml" in # 2365 "mlx/parser.mly" ( Pexp_tuple(_1) ) -# 9473 "mlx/parser.ml" +# 9494 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -9479,13 +9500,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 9483 "mlx/parser.ml" +# 9504 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 9489 "mlx/parser.ml" +# 9510 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9523,13 +9544,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 9527 "mlx/parser.ml" +# 9548 "mlx/parser.ml" in # 2367 "mlx/parser.mly" ( Pexp_construct(_1, Some _2) ) -# 9533 "mlx/parser.ml" +# 9554 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in @@ -9539,13 +9560,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 9543 "mlx/parser.ml" +# 9564 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 9549 "mlx/parser.ml" +# 9570 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9578,7 +9599,7 @@ module Tables = struct let _1 = # 2369 "mlx/parser.mly" ( Pexp_variant(_1, Some _2) ) -# 9582 "mlx/parser.ml" +# 9603 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in @@ -9587,13 +9608,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 9591 "mlx/parser.ml" +# 9612 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 9597 "mlx/parser.ml" +# 9618 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9627,7 +9648,7 @@ module Tables = struct let op : ( # 689 "mlx/parser.mly" (string) -# 9631 "mlx/parser.ml" +# 9652 "mlx/parser.ml" ) = Obj.magic op in let e1 : (Parsetree.expression) = Obj.magic e1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -9639,7 +9660,7 @@ module Tables = struct let _1 = # 3612 "mlx/parser.mly" ( op ) -# 9643 "mlx/parser.ml" +# 9664 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in let _endpos = _endpos__1_ in @@ -9648,13 +9669,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 9652 "mlx/parser.ml" +# 9673 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 9658 "mlx/parser.ml" +# 9679 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9664,13 +9685,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 9668 "mlx/parser.ml" +# 9689 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 9674 "mlx/parser.ml" +# 9695 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9704,7 +9725,7 @@ module Tables = struct let op : ( # 690 "mlx/parser.mly" (string) -# 9708 "mlx/parser.ml" +# 9729 "mlx/parser.ml" ) = Obj.magic op in let e1 : (Parsetree.expression) = Obj.magic e1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -9716,7 +9737,7 @@ module Tables = struct let _1 = # 3613 "mlx/parser.mly" ( op ) -# 9720 "mlx/parser.ml" +# 9741 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in let _endpos = _endpos__1_ in @@ -9725,13 +9746,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 9729 "mlx/parser.ml" +# 9750 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 9735 "mlx/parser.ml" +# 9756 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9741,13 +9762,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 9745 "mlx/parser.ml" +# 9766 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 9751 "mlx/parser.ml" +# 9772 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9781,7 +9802,7 @@ module Tables = struct let op : ( # 691 "mlx/parser.mly" (string) -# 9785 "mlx/parser.ml" +# 9806 "mlx/parser.ml" ) = Obj.magic op in let e1 : (Parsetree.expression) = Obj.magic e1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -9793,7 +9814,7 @@ module Tables = struct let _1 = # 3614 "mlx/parser.mly" ( op ) -# 9797 "mlx/parser.ml" +# 9818 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in let _endpos = _endpos__1_ in @@ -9802,13 +9823,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 9806 "mlx/parser.ml" +# 9827 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 9812 "mlx/parser.ml" +# 9833 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9818,13 +9839,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 9822 "mlx/parser.ml" +# 9843 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 9828 "mlx/parser.ml" +# 9849 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9858,7 +9879,7 @@ module Tables = struct let op : ( # 692 "mlx/parser.mly" (string) -# 9862 "mlx/parser.ml" +# 9883 "mlx/parser.ml" ) = Obj.magic op in let e1 : (Parsetree.expression) = Obj.magic e1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -9870,7 +9891,7 @@ module Tables = struct let _1 = # 3615 "mlx/parser.mly" ( op ) -# 9874 "mlx/parser.ml" +# 9895 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in let _endpos = _endpos__1_ in @@ -9879,13 +9900,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 9883 "mlx/parser.ml" +# 9904 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 9889 "mlx/parser.ml" +# 9910 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9895,13 +9916,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 9899 "mlx/parser.ml" +# 9920 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 9905 "mlx/parser.ml" +# 9926 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9935,7 +9956,7 @@ module Tables = struct let op : ( # 693 "mlx/parser.mly" (string) -# 9939 "mlx/parser.ml" +# 9960 "mlx/parser.ml" ) = Obj.magic op in let e1 : (Parsetree.expression) = Obj.magic e1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -9947,7 +9968,7 @@ module Tables = struct let _1 = # 3616 "mlx/parser.mly" ( op ) -# 9951 "mlx/parser.ml" +# 9972 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in let _endpos = _endpos__1_ in @@ -9956,13 +9977,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 9960 "mlx/parser.ml" +# 9981 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 9966 "mlx/parser.ml" +# 9987 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9972,13 +9993,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 9976 "mlx/parser.ml" +# 9997 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 9982 "mlx/parser.ml" +# 10003 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10020,7 +10041,7 @@ module Tables = struct let _1 = # 3617 "mlx/parser.mly" ("+") -# 10024 "mlx/parser.ml" +# 10045 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10028,13 +10049,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10032 "mlx/parser.ml" +# 10053 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10038 "mlx/parser.ml" +# 10059 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10044,13 +10065,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10048 "mlx/parser.ml" +# 10069 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10054 "mlx/parser.ml" +# 10075 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10092,7 +10113,7 @@ module Tables = struct let _1 = # 3618 "mlx/parser.mly" ("+.") -# 10096 "mlx/parser.ml" +# 10117 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10100,13 +10121,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10104 "mlx/parser.ml" +# 10125 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10110 "mlx/parser.ml" +# 10131 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10116,13 +10137,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10120 "mlx/parser.ml" +# 10141 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10126 "mlx/parser.ml" +# 10147 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10164,7 +10185,7 @@ module Tables = struct let _1 = # 3619 "mlx/parser.mly" ("+=") -# 10168 "mlx/parser.ml" +# 10189 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10172,13 +10193,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10176 "mlx/parser.ml" +# 10197 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10182 "mlx/parser.ml" +# 10203 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10188,13 +10209,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10192 "mlx/parser.ml" +# 10213 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10198 "mlx/parser.ml" +# 10219 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10236,7 +10257,7 @@ module Tables = struct let _1 = # 3620 "mlx/parser.mly" ("-") -# 10240 "mlx/parser.ml" +# 10261 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10244,13 +10265,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10248 "mlx/parser.ml" +# 10269 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10254 "mlx/parser.ml" +# 10275 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10260,13 +10281,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10264 "mlx/parser.ml" +# 10285 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10270 "mlx/parser.ml" +# 10291 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10308,7 +10329,7 @@ module Tables = struct let _1 = # 3621 "mlx/parser.mly" ("-.") -# 10312 "mlx/parser.ml" +# 10333 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10316,13 +10337,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10320 "mlx/parser.ml" +# 10341 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10326 "mlx/parser.ml" +# 10347 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10332,13 +10353,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10336 "mlx/parser.ml" +# 10357 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10342 "mlx/parser.ml" +# 10363 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10380,7 +10401,7 @@ module Tables = struct let _1 = # 3622 "mlx/parser.mly" ("*") -# 10384 "mlx/parser.ml" +# 10405 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10388,13 +10409,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10392 "mlx/parser.ml" +# 10413 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10398 "mlx/parser.ml" +# 10419 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10404,13 +10425,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10408 "mlx/parser.ml" +# 10429 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10414 "mlx/parser.ml" +# 10435 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10452,7 +10473,7 @@ module Tables = struct let _1 = # 3623 "mlx/parser.mly" ("%") -# 10456 "mlx/parser.ml" +# 10477 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10460,13 +10481,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10464 "mlx/parser.ml" +# 10485 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10470 "mlx/parser.ml" +# 10491 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10476,13 +10497,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10480 "mlx/parser.ml" +# 10501 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10486 "mlx/parser.ml" +# 10507 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10524,7 +10545,7 @@ module Tables = struct let _1 = # 3624 "mlx/parser.mly" ("=") -# 10528 "mlx/parser.ml" +# 10549 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10532,13 +10553,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10536 "mlx/parser.ml" +# 10557 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10542 "mlx/parser.ml" +# 10563 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10548,13 +10569,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10552 "mlx/parser.ml" +# 10573 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10558 "mlx/parser.ml" +# 10579 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10596,7 +10617,7 @@ module Tables = struct let _1 = # 3625 "mlx/parser.mly" ("<") -# 10600 "mlx/parser.ml" +# 10621 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10604,13 +10625,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10608 "mlx/parser.ml" +# 10629 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10614 "mlx/parser.ml" +# 10635 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10620,13 +10641,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10624 "mlx/parser.ml" +# 10645 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10630 "mlx/parser.ml" +# 10651 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10668,7 +10689,7 @@ module Tables = struct let _1 = # 3626 "mlx/parser.mly" (">") -# 10672 "mlx/parser.ml" +# 10693 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10676,13 +10697,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10680 "mlx/parser.ml" +# 10701 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10686 "mlx/parser.ml" +# 10707 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10692,13 +10713,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10696 "mlx/parser.ml" +# 10717 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10702 "mlx/parser.ml" +# 10723 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10740,7 +10761,7 @@ module Tables = struct let _1 = # 3627 "mlx/parser.mly" ("or") -# 10744 "mlx/parser.ml" +# 10765 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10748,13 +10769,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10752 "mlx/parser.ml" +# 10773 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10758 "mlx/parser.ml" +# 10779 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10764,13 +10785,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10768 "mlx/parser.ml" +# 10789 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10774 "mlx/parser.ml" +# 10795 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10812,7 +10833,7 @@ module Tables = struct let _1 = # 3628 "mlx/parser.mly" ("||") -# 10816 "mlx/parser.ml" +# 10837 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10820,13 +10841,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10824 "mlx/parser.ml" +# 10845 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10830 "mlx/parser.ml" +# 10851 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10836,13 +10857,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10840 "mlx/parser.ml" +# 10861 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10846 "mlx/parser.ml" +# 10867 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10884,7 +10905,7 @@ module Tables = struct let _1 = # 3629 "mlx/parser.mly" ("&") -# 10888 "mlx/parser.ml" +# 10909 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10892,13 +10913,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10896 "mlx/parser.ml" +# 10917 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10902 "mlx/parser.ml" +# 10923 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10908,13 +10929,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10912 "mlx/parser.ml" +# 10933 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10918 "mlx/parser.ml" +# 10939 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10956,7 +10977,7 @@ module Tables = struct let _1 = # 3630 "mlx/parser.mly" ("&&") -# 10960 "mlx/parser.ml" +# 10981 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -10964,13 +10985,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 10968 "mlx/parser.ml" +# 10989 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 10974 "mlx/parser.ml" +# 10995 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10980,13 +11001,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 10984 "mlx/parser.ml" +# 11005 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 10990 "mlx/parser.ml" +# 11011 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11028,7 +11049,7 @@ module Tables = struct let _1 = # 3631 "mlx/parser.mly" (":=") -# 11032 "mlx/parser.ml" +# 11053 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -11036,13 +11057,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 11040 "mlx/parser.ml" +# 11061 "mlx/parser.ml" in # 2371 "mlx/parser.mly" ( mkinfix e1 op e2 ) -# 11046 "mlx/parser.ml" +# 11067 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11052,13 +11073,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 11056 "mlx/parser.ml" +# 11077 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 11062 "mlx/parser.ml" +# 11083 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11093,7 +11114,7 @@ module Tables = struct # 2373 "mlx/parser.mly" ( mkuminus ~oploc:_loc__1_ _1 _2 ) -# 11097 "mlx/parser.ml" +# 11118 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in @@ -11103,13 +11124,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 11107 "mlx/parser.ml" +# 11128 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 11113 "mlx/parser.ml" +# 11134 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11144,7 +11165,7 @@ module Tables = struct # 2375 "mlx/parser.mly" ( mkuplus ~oploc:_loc__1_ _1 _2 ) -# 11148 "mlx/parser.ml" +# 11169 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in @@ -11154,13 +11175,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 11158 "mlx/parser.ml" +# 11179 "mlx/parser.ml" in # 2293 "mlx/parser.mly" ( _1 ) -# 11164 "mlx/parser.ml" +# 11185 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11202,7 +11223,7 @@ module Tables = struct # 2295 "mlx/parser.mly" ( expr_of_let_bindings ~loc:_sloc _1 _3 ) -# 11206 "mlx/parser.ml" +# 11227 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11244,7 +11265,7 @@ module Tables = struct let _1 : ( # 695 "mlx/parser.mly" (string) -# 11248 "mlx/parser.ml" +# 11269 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -11256,7 +11277,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 11260 "mlx/parser.ml" +# 11281 "mlx/parser.ml" in let _startpos_pbop_op_ = _startpos__1_ in @@ -11270,7 +11291,7 @@ module Tables = struct let pbop_loc = make_loc _sloc in let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in mkexp ~loc:_sloc (Pexp_letop{ let_; ands; body}) ) -# 11274 "mlx/parser.ml" +# 11295 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11313,7 +11334,7 @@ module Tables = struct # 2303 "mlx/parser.mly" ( mkexp_cons ~loc:_sloc _loc__2_ (ghexp ~loc:_sloc (Pexp_tuple[_1;_3])) ) -# 11317 "mlx/parser.ml" +# 11338 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11348,7 +11369,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 11352 "mlx/parser.ml" +# 11373 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -11357,7 +11378,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 11361 "mlx/parser.ml" +# 11382 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -11365,7 +11386,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 11369 "mlx/parser.ml" +# 11390 "mlx/parser.ml" in let _endpos = _endpos__3_ in @@ -11374,7 +11395,7 @@ module Tables = struct # 2305 "mlx/parser.mly" ( mkexp ~loc:_sloc (Pexp_setinstvar(_1, _3)) ) -# 11378 "mlx/parser.ml" +# 11399 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11432,7 +11453,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 11436 "mlx/parser.ml" +# 11457 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -11441,7 +11462,7 @@ module Tables = struct # 2307 "mlx/parser.mly" ( mkexp ~loc:_sloc (Pexp_setfield(_1, _3, _5)) ) -# 11445 "mlx/parser.ml" +# 11466 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11509,12 +11530,12 @@ module Tables = struct let r = # 2308 "mlx/parser.mly" (Some v) -# 11513 "mlx/parser.ml" +# 11534 "mlx/parser.ml" in # 2268 "mlx/parser.mly" ( array, d, Paren, i, r ) -# 11518 "mlx/parser.ml" +# 11539 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11524,7 +11545,7 @@ module Tables = struct # 2309 "mlx/parser.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11528 "mlx/parser.ml" +# 11549 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11592,12 +11613,12 @@ module Tables = struct let r = # 2308 "mlx/parser.mly" (Some v) -# 11596 "mlx/parser.ml" +# 11617 "mlx/parser.ml" in # 2270 "mlx/parser.mly" ( array, d, Brace, i, r ) -# 11601 "mlx/parser.ml" +# 11622 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11607,7 +11628,7 @@ module Tables = struct # 2309 "mlx/parser.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11611 "mlx/parser.ml" +# 11632 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11675,12 +11696,12 @@ module Tables = struct let r = # 2308 "mlx/parser.mly" (Some v) -# 11679 "mlx/parser.ml" +# 11700 "mlx/parser.ml" in # 2272 "mlx/parser.mly" ( array, d, Bracket, i, r ) -# 11684 "mlx/parser.ml" +# 11705 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11690,7 +11711,7 @@ module Tables = struct # 2309 "mlx/parser.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11694 "mlx/parser.ml" +# 11715 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11752,7 +11773,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 11756 "mlx/parser.ml" +# 11777 "mlx/parser.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -11762,29 +11783,29 @@ module Tables = struct let r = # 2310 "mlx/parser.mly" (Some v) -# 11766 "mlx/parser.ml" +# 11787 "mlx/parser.ml" in let i = # 2729 "mlx/parser.mly" ( es ) -# 11771 "mlx/parser.ml" +# 11792 "mlx/parser.ml" in let d = let _1 = # 124 "" ( None ) -# 11777 "mlx/parser.ml" +# 11798 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 11782 "mlx/parser.ml" +# 11803 "mlx/parser.ml" in # 2268 "mlx/parser.mly" ( array, d, Paren, i, r ) -# 11788 "mlx/parser.ml" +# 11809 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11794,7 +11815,7 @@ module Tables = struct # 2311 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 11798 "mlx/parser.ml" +# 11819 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11868,7 +11889,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 11872 "mlx/parser.ml" +# 11893 "mlx/parser.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -11877,15 +11898,18 @@ module Tables = struct let _startpos = _startpos_array_ in let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = - let r = + let r = + let _1 = _1_inlined1 in + # 2310 "mlx/parser.mly" (Some v) -# 11884 "mlx/parser.ml" - in +# 11907 "mlx/parser.ml" + + in let i = # 2729 "mlx/parser.mly" ( es ) -# 11889 "mlx/parser.ml" +# 11913 "mlx/parser.ml" in let d = let _1 = @@ -11893,24 +11917,24 @@ module Tables = struct let x = # 2284 "mlx/parser.mly" (_2) -# 11897 "mlx/parser.ml" +# 11921 "mlx/parser.ml" in # 126 "" ( Some x ) -# 11902 "mlx/parser.ml" +# 11926 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 11908 "mlx/parser.ml" +# 11932 "mlx/parser.ml" in # 2268 "mlx/parser.mly" ( array, d, Paren, i, r ) -# 11914 "mlx/parser.ml" +# 11938 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11920,7 +11944,7 @@ module Tables = struct # 2311 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 11924 "mlx/parser.ml" +# 11948 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11982,7 +12006,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 11986 "mlx/parser.ml" +# 12010 "mlx/parser.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -11992,29 +12016,29 @@ module Tables = struct let r = # 2310 "mlx/parser.mly" (Some v) -# 11996 "mlx/parser.ml" +# 12020 "mlx/parser.ml" in let i = # 2729 "mlx/parser.mly" ( es ) -# 12001 "mlx/parser.ml" +# 12025 "mlx/parser.ml" in let d = let _1 = # 124 "" ( None ) -# 12007 "mlx/parser.ml" +# 12031 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 12012 "mlx/parser.ml" +# 12036 "mlx/parser.ml" in # 2270 "mlx/parser.mly" ( array, d, Brace, i, r ) -# 12018 "mlx/parser.ml" +# 12042 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12024,7 +12048,7 @@ module Tables = struct # 2311 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12028 "mlx/parser.ml" +# 12052 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12098,7 +12122,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 12102 "mlx/parser.ml" +# 12126 "mlx/parser.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -12107,15 +12131,18 @@ module Tables = struct let _startpos = _startpos_array_ in let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = - let r = + let r = + let _1 = _1_inlined1 in + # 2310 "mlx/parser.mly" (Some v) -# 12114 "mlx/parser.ml" - in +# 12140 "mlx/parser.ml" + + in let i = # 2729 "mlx/parser.mly" ( es ) -# 12119 "mlx/parser.ml" +# 12146 "mlx/parser.ml" in let d = let _1 = @@ -12123,24 +12150,24 @@ module Tables = struct let x = # 2284 "mlx/parser.mly" (_2) -# 12127 "mlx/parser.ml" +# 12154 "mlx/parser.ml" in # 126 "" ( Some x ) -# 12132 "mlx/parser.ml" +# 12159 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 12138 "mlx/parser.ml" +# 12165 "mlx/parser.ml" in # 2270 "mlx/parser.mly" ( array, d, Brace, i, r ) -# 12144 "mlx/parser.ml" +# 12171 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12150,7 +12177,7 @@ module Tables = struct # 2311 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12154 "mlx/parser.ml" +# 12181 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12212,7 +12239,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 12216 "mlx/parser.ml" +# 12243 "mlx/parser.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -12222,29 +12249,29 @@ module Tables = struct let r = # 2310 "mlx/parser.mly" (Some v) -# 12226 "mlx/parser.ml" +# 12253 "mlx/parser.ml" in let i = # 2729 "mlx/parser.mly" ( es ) -# 12231 "mlx/parser.ml" +# 12258 "mlx/parser.ml" in let d = let _1 = # 124 "" ( None ) -# 12237 "mlx/parser.ml" +# 12264 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 12242 "mlx/parser.ml" +# 12269 "mlx/parser.ml" in # 2272 "mlx/parser.mly" ( array, d, Bracket, i, r ) -# 12248 "mlx/parser.ml" +# 12275 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12254,7 +12281,7 @@ module Tables = struct # 2311 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12258 "mlx/parser.ml" +# 12285 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12328,7 +12355,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 12332 "mlx/parser.ml" +# 12359 "mlx/parser.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -12337,15 +12364,18 @@ module Tables = struct let _startpos = _startpos_array_ in let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = - let r = + let r = + let _1 = _1_inlined1 in + # 2310 "mlx/parser.mly" (Some v) -# 12344 "mlx/parser.ml" - in +# 12373 "mlx/parser.ml" + + in let i = # 2729 "mlx/parser.mly" ( es ) -# 12349 "mlx/parser.ml" +# 12379 "mlx/parser.ml" in let d = let _1 = @@ -12353,24 +12383,24 @@ module Tables = struct let x = # 2284 "mlx/parser.mly" (_2) -# 12357 "mlx/parser.ml" +# 12387 "mlx/parser.ml" in # 126 "" ( Some x ) -# 12362 "mlx/parser.ml" +# 12392 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 12368 "mlx/parser.ml" +# 12398 "mlx/parser.ml" in # 2272 "mlx/parser.mly" ( array, d, Bracket, i, r ) -# 12374 "mlx/parser.ml" +# 12404 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12380,7 +12410,7 @@ module Tables = struct # 2311 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12384 "mlx/parser.ml" +# 12414 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12412,7 +12442,7 @@ module Tables = struct let _v : (Parsetree.expression) = # 2313 "mlx/parser.mly" ( Exp.attr _1 _2 ) -# 12416 "mlx/parser.ml" +# 12446 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12438,7 +12468,7 @@ module Tables = struct # 2316 "mlx/parser.mly" ( not_expecting _loc__1_ "wildcard \"_\"" ) -# 12442 "mlx/parser.ml" +# 12472 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12456,7 +12486,7 @@ module Tables = struct let _v : (string Location.loc option) = # 3925 "mlx/parser.mly" ( None ) -# 12460 "mlx/parser.ml" +# 12490 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12488,7 +12518,7 @@ module Tables = struct let _v : (string Location.loc option) = # 3926 "mlx/parser.mly" ( Some _2 ) -# 12492 "mlx/parser.ml" +# 12522 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12534,7 +12564,7 @@ module Tables = struct let _v : (Parsetree.extension) = # 3938 "mlx/parser.mly" ( (_2, _3) ) -# 12538 "mlx/parser.ml" +# 12568 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12555,7 +12585,7 @@ module Tables = struct let _1 : ( # 756 "mlx/parser.mly" (string * Location.t * string * Location.t * string option) -# 12559 "mlx/parser.ml" +# 12589 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -12566,7 +12596,7 @@ module Tables = struct # 3940 "mlx/parser.mly" ( mk_quotedext ~loc:_sloc _1 ) -# 12570 "mlx/parser.ml" +# 12600 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12621,7 +12651,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 12625 "mlx/parser.ml" +# 12655 "mlx/parser.ml" in let _endpos_attrs_ = _endpos__1_inlined3_ in @@ -12633,7 +12663,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 12637 "mlx/parser.ml" +# 12667 "mlx/parser.ml" in let cid = @@ -12644,7 +12674,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 12648 "mlx/parser.ml" +# 12678 "mlx/parser.ml" in let _endpos = _endpos_attrs_ in @@ -12654,7 +12684,7 @@ module Tables = struct # 3268 "mlx/parser.mly" ( let info = symbol_info _endpos in Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 12658 "mlx/parser.ml" +# 12688 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12702,7 +12732,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 12706 "mlx/parser.ml" +# 12736 "mlx/parser.ml" in let _endpos_attrs_ = _endpos__1_inlined2_ in @@ -12714,7 +12744,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 12718 "mlx/parser.ml" +# 12748 "mlx/parser.ml" in let cid = @@ -12724,14 +12754,14 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 12728 "mlx/parser.ml" +# 12758 "mlx/parser.ml" in let _startpos_cid_ = _startpos__1_ in let _1 = # 3743 "mlx/parser.mly" ( () ) -# 12735 "mlx/parser.ml" +# 12765 "mlx/parser.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos_cid_ in @@ -12740,7 +12770,7 @@ module Tables = struct # 3268 "mlx/parser.mly" ( let info = symbol_info _endpos in Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 12744 "mlx/parser.ml" +# 12774 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12790,7 +12820,7 @@ module Tables = struct # 3913 "mlx/parser.mly" ( mark_symbol_docs _sloc; Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 12794 "mlx/parser.ml" +# 12824 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12808,12 +12838,12 @@ module Tables = struct let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let params = # 2061 "mlx/parser.mly" ( [] ) -# 12812 "mlx/parser.ml" +# 12842 "mlx/parser.ml" in # 1886 "mlx/parser.mly" ( params ) -# 12817 "mlx/parser.ml" +# 12847 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12854,24 +12884,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 12858 "mlx/parser.ml" +# 12888 "mlx/parser.ml" in # 1035 "mlx/parser.mly" ( xs ) -# 12863 "mlx/parser.ml" +# 12893 "mlx/parser.ml" in # 2063 "mlx/parser.mly" ( params ) -# 12869 "mlx/parser.ml" +# 12899 "mlx/parser.ml" in # 1886 "mlx/parser.mly" ( params ) -# 12875 "mlx/parser.ml" +# 12905 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12896,7 +12926,7 @@ module Tables = struct let _v : (Parsetree.expression) = # 2648 "mlx/parser.mly" ( _1 ) -# 12900 "mlx/parser.ml" +# 12930 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12938,7 +12968,7 @@ module Tables = struct # 2650 "mlx/parser.mly" ( mkexp_constraint ~loc:_sloc _3 _1 ) -# 12942 "mlx/parser.ml" +# 12972 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12970,7 +13000,7 @@ module Tables = struct let _v : (Parsetree.expression) = # 2674 "mlx/parser.mly" ( _2 ) -# 12974 "mlx/parser.ml" +# 13004 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13017,7 +13047,7 @@ module Tables = struct let _1 = # 2676 "mlx/parser.mly" ( Pexp_constraint (_4, _2) ) -# 13021 "mlx/parser.ml" +# 13051 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in let _endpos = _endpos__1_ in @@ -13026,13 +13056,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 13030 "mlx/parser.ml" +# 13060 "mlx/parser.ml" in # 2677 "mlx/parser.mly" ( _1 ) -# 13036 "mlx/parser.ml" +# 13066 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13070,7 +13100,7 @@ module Tables = struct let (l,o,p) = _1 in ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) ) -# 13074 "mlx/parser.ml" +# 13104 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13123,7 +13153,7 @@ module Tables = struct let _v : (Parsetree.expression) = let _3 = # 2549 "mlx/parser.mly" ( xs ) -# 13127 "mlx/parser.ml" +# 13157 "mlx/parser.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in @@ -13131,7 +13161,7 @@ module Tables = struct # 2685 "mlx/parser.mly" ( mk_newtypes ~loc:_sloc _3 _5 ) -# 13135 "mlx/parser.ml" +# 13165 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13156,7 +13186,7 @@ module Tables = struct let _v : (Parsetree.core_type) = # 3384 "mlx/parser.mly" ( ty ) -# 13160 "mlx/parser.ml" +# 13190 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13204,17 +13234,17 @@ module Tables = struct let domain = # 899 "mlx/parser.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13208 "mlx/parser.ml" +# 13238 "mlx/parser.ml" in let label = # 3396 "mlx/parser.mly" ( Optional label ) -# 13213 "mlx/parser.ml" +# 13243 "mlx/parser.ml" in # 3390 "mlx/parser.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13218 "mlx/parser.ml" +# 13248 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13224,13 +13254,13 @@ module Tables = struct # 938 "mlx/parser.mly" ( mktyp ~loc:_sloc _1 ) -# 13228 "mlx/parser.ml" +# 13258 "mlx/parser.ml" in # 3392 "mlx/parser.mly" ( _1 ) -# 13234 "mlx/parser.ml" +# 13264 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13279,7 +13309,7 @@ module Tables = struct let label : ( # 714 "mlx/parser.mly" (string) -# 13283 "mlx/parser.ml" +# 13313 "mlx/parser.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -13289,17 +13319,17 @@ module Tables = struct let domain = # 899 "mlx/parser.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13293 "mlx/parser.ml" +# 13323 "mlx/parser.ml" in let label = # 3398 "mlx/parser.mly" ( Labelled label ) -# 13298 "mlx/parser.ml" +# 13328 "mlx/parser.ml" in # 3390 "mlx/parser.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13303 "mlx/parser.ml" +# 13333 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13309,13 +13339,13 @@ module Tables = struct # 938 "mlx/parser.mly" ( mktyp ~loc:_sloc _1 ) -# 13313 "mlx/parser.ml" +# 13343 "mlx/parser.ml" in # 3392 "mlx/parser.mly" ( _1 ) -# 13319 "mlx/parser.ml" +# 13349 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13356,17 +13386,17 @@ module Tables = struct let domain = # 899 "mlx/parser.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13360 "mlx/parser.ml" +# 13390 "mlx/parser.ml" in let label = # 3400 "mlx/parser.mly" ( Nolabel ) -# 13365 "mlx/parser.ml" +# 13395 "mlx/parser.ml" in # 3390 "mlx/parser.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13370 "mlx/parser.ml" +# 13400 "mlx/parser.ml" in let _endpos__1_ = _endpos_codomain_ in @@ -13376,13 +13406,13 @@ module Tables = struct # 938 "mlx/parser.mly" ( mktyp ~loc:_sloc _1 ) -# 13380 "mlx/parser.ml" +# 13410 "mlx/parser.ml" in # 3392 "mlx/parser.mly" ( _1 ) -# 13386 "mlx/parser.ml" +# 13416 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13415,7 +13445,7 @@ module Tables = struct # 1289 "mlx/parser.mly" ( _startpos, Unit ) -# 13419 "mlx/parser.ml" +# 13449 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13473,14 +13503,14 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 13477 "mlx/parser.ml" +# 13507 "mlx/parser.ml" in let _startpos = _startpos__1_ in # 1292 "mlx/parser.mly" ( _startpos, Named (x, mty) ) -# 13484 "mlx/parser.ml" +# 13514 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13495,11 +13525,11 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in - let _v : (Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Dune__exe__Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = # 3183 "mlx/parser.mly" ( ([],Pcstr_tuple [],None) ) -# 13503 "mlx/parser.ml" +# 13533 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13528,11 +13558,11 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in - let _v : (Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Dune__exe__Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = # 3184 "mlx/parser.mly" ( ([],_2,None) ) -# 13536 "mlx/parser.ml" +# 13566 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13575,11 +13605,11 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in - let _v : (Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Dune__exe__Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = # 3186 "mlx/parser.mly" ( ([],_2,Some _4) ) -# 13583 "mlx/parser.ml" +# 13613 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13636,30 +13666,30 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__6_ in - let _v : (Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Dune__exe__Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = let _2 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 13646 "mlx/parser.ml" +# 13676 "mlx/parser.ml" in # 1003 "mlx/parser.mly" ( xs ) -# 13651 "mlx/parser.ml" +# 13681 "mlx/parser.ml" in # 3319 "mlx/parser.mly" ( _1 ) -# 13657 "mlx/parser.ml" +# 13687 "mlx/parser.ml" in # 3189 "mlx/parser.mly" ( (_2,_4,Some _6) ) -# 13663 "mlx/parser.ml" +# 13693 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13688,11 +13718,11 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in - let _v : (Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Dune__exe__Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = # 3191 "mlx/parser.mly" ( ([],Pcstr_tuple [],Some _2) ) -# 13696 "mlx/parser.ml" +# 13726 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13735,30 +13765,30 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in - let _v : (Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Dune__exe__Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = let _2 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 13745 "mlx/parser.ml" +# 13775 "mlx/parser.ml" in # 1003 "mlx/parser.mly" ( xs ) -# 13750 "mlx/parser.ml" +# 13780 "mlx/parser.ml" in # 3319 "mlx/parser.mly" ( _1 ) -# 13756 "mlx/parser.ml" +# 13786 "mlx/parser.ml" in # 3193 "mlx/parser.mly" ( (_2,Pcstr_tuple [],Some _4) ) -# 13762 "mlx/parser.ml" +# 13792 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13795,21 +13825,21 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in - let vars_args_res : (Ast_helper.str list * Parsetree.constructor_arguments * + let vars_args_res : (Dune__exe__Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic vars_args_res in let _1_inlined1 : (string) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined2_ in - let _v : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = let attrs = + let _v : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = let attrs = let _1 = _1_inlined2 in # 3922 "mlx/parser.mly" ( _1 ) -# 13813 "mlx/parser.ml" +# 13843 "mlx/parser.ml" in let _endpos_attrs_ = _endpos__1_inlined2_ in @@ -13821,7 +13851,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 13825 "mlx/parser.ml" +# 13855 "mlx/parser.ml" in let _endpos = _endpos_attrs_ in @@ -13835,7 +13865,7 @@ module Tables = struct let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 13839 "mlx/parser.ml" +# 13869 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13866,20 +13896,20 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in - let vars_args_res : (Ast_helper.str list * Parsetree.constructor_arguments * + let vars_args_res : (Dune__exe__Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic vars_args_res in let _1 : (string) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined1_ in - let _v : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = let attrs = + let _v : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = let attrs = let _1 = _1_inlined1 in # 3922 "mlx/parser.mly" ( _1 ) -# 13883 "mlx/parser.ml" +# 13913 "mlx/parser.ml" in let _endpos_attrs_ = _endpos__1_inlined1_ in @@ -13890,14 +13920,14 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 13894 "mlx/parser.ml" +# 13924 "mlx/parser.ml" in let _startpos_cid_ = _startpos__1_ in let _1 = # 3743 "mlx/parser.mly" ( () ) -# 13901 "mlx/parser.ml" +# 13931 "mlx/parser.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos_cid_ in @@ -13910,7 +13940,7 @@ module Tables = struct let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 13914 "mlx/parser.ml" +# 13944 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13983,7 +14013,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 13987 "mlx/parser.ml" +# 14017 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -13998,7 +14028,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 14002 "mlx/parser.ml" +# 14032 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14007,25 +14037,28 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14011 "mlx/parser.ml" +# 14041 "mlx/parser.ml" in # 985 "mlx/parser.mly" ( xs ) -# 14016 "mlx/parser.ml" +# 14046 "mlx/parser.ml" in # 3036 "mlx/parser.mly" ( _1 ) -# 14022 "mlx/parser.ml" +# 14052 "mlx/parser.ml" in - let kind_priv_manifest = + let kind_priv_manifest = + let _1 = _1_inlined3 in + # 3071 "mlx/parser.mly" ( _2 ) -# 14028 "mlx/parser.ml" - in +# 14060 "mlx/parser.ml" + + in let id = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _endpos = _endpos__1_ in @@ -14034,20 +14067,20 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 14038 "mlx/parser.ml" +# 14071 "mlx/parser.ml" in let flag = # 3763 "mlx/parser.mly" ( Recursive ) -# 14044 "mlx/parser.ml" +# 14077 "mlx/parser.ml" in let attrs1 = let _1 = _1_inlined1 in # 3922 "mlx/parser.mly" ( _1 ) -# 14051 "mlx/parser.ml" +# 14084 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -14063,7 +14096,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14067 "mlx/parser.ml" +# 14100 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14142,7 +14175,7 @@ module Tables = struct let _1_inlined3 : ( # 714 "mlx/parser.mly" (string) -# 14146 "mlx/parser.ml" +# 14179 "mlx/parser.ml" ) = Obj.magic _1_inlined3 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined2 : unit = Obj.magic _1_inlined2 in @@ -14158,7 +14191,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 14162 "mlx/parser.ml" +# 14195 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined5_ in @@ -14167,25 +14200,28 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14171 "mlx/parser.ml" +# 14204 "mlx/parser.ml" in # 985 "mlx/parser.mly" ( xs ) -# 14176 "mlx/parser.ml" +# 14209 "mlx/parser.ml" in # 3036 "mlx/parser.mly" ( _1 ) -# 14182 "mlx/parser.ml" +# 14215 "mlx/parser.ml" in - let kind_priv_manifest = + let kind_priv_manifest = + let _1 = _1_inlined4 in + # 3071 "mlx/parser.mly" ( _2 ) -# 14188 "mlx/parser.ml" - in +# 14223 "mlx/parser.ml" + + in let id = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in let _endpos = _endpos__1_ in @@ -14194,18 +14230,18 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 14198 "mlx/parser.ml" +# 14234 "mlx/parser.ml" in let flag = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos__1_inlined2_) in + let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in # 3765 "mlx/parser.mly" ( not_expecting _loc "nonrec flag" ) -# 14209 "mlx/parser.ml" +# 14245 "mlx/parser.ml" in let attrs1 = @@ -14213,7 +14249,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 14217 "mlx/parser.ml" +# 14253 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -14229,7 +14265,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14233 "mlx/parser.ml" +# 14269 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14295,7 +14331,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 14299 "mlx/parser.ml" +# 14335 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -14310,7 +14346,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 14314 "mlx/parser.ml" +# 14350 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -14319,18 +14355,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14323 "mlx/parser.ml" +# 14359 "mlx/parser.ml" in # 985 "mlx/parser.mly" ( xs ) -# 14328 "mlx/parser.ml" +# 14364 "mlx/parser.ml" in # 3036 "mlx/parser.mly" ( _1 ) -# 14334 "mlx/parser.ml" +# 14370 "mlx/parser.ml" in let id = @@ -14341,20 +14377,20 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 14345 "mlx/parser.ml" +# 14381 "mlx/parser.ml" in let flag = # 3759 "mlx/parser.mly" ( Recursive ) -# 14351 "mlx/parser.ml" +# 14387 "mlx/parser.ml" in let attrs1 = let _1 = _1_inlined1 in # 3922 "mlx/parser.mly" ( _1 ) -# 14358 "mlx/parser.ml" +# 14394 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -14370,7 +14406,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14374 "mlx/parser.ml" +# 14410 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14442,7 +14478,7 @@ module Tables = struct let _1_inlined3 : ( # 714 "mlx/parser.mly" (string) -# 14446 "mlx/parser.ml" +# 14482 "mlx/parser.ml" ) = Obj.magic _1_inlined3 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined2 : unit = Obj.magic _1_inlined2 in @@ -14458,7 +14494,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 14462 "mlx/parser.ml" +# 14498 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14467,18 +14503,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14471 "mlx/parser.ml" +# 14507 "mlx/parser.ml" in # 985 "mlx/parser.mly" ( xs ) -# 14476 "mlx/parser.ml" +# 14512 "mlx/parser.ml" in # 3036 "mlx/parser.mly" ( _1 ) -# 14482 "mlx/parser.ml" +# 14518 "mlx/parser.ml" in let id = @@ -14489,20 +14525,23 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 14493 "mlx/parser.ml" +# 14529 "mlx/parser.ml" in - let flag = + let flag = + let _1 = _1_inlined2 in + # 3760 "mlx/parser.mly" ( Nonrecursive ) -# 14499 "mlx/parser.ml" - in +# 14537 "mlx/parser.ml" + + in let attrs1 = let _1 = _1_inlined1 in # 3922 "mlx/parser.mly" ( _1 ) -# 14506 "mlx/parser.ml" +# 14545 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -14518,7 +14557,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14522 "mlx/parser.ml" +# 14561 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14539,7 +14578,7 @@ module Tables = struct let _1 : ( # 767 "mlx/parser.mly" (string) -# 14543 "mlx/parser.ml" +# 14582 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -14547,7 +14586,7 @@ module Tables = struct let _v : (string) = # 3584 "mlx/parser.mly" ( _1 ) -# 14551 "mlx/parser.ml" +# 14590 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14568,7 +14607,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 14572 "mlx/parser.ml" +# 14611 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -14576,7 +14615,7 @@ module Tables = struct let _v : (string) = # 3585 "mlx/parser.mly" ( _1 ) -# 14580 "mlx/parser.ml" +# 14619 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14608,7 +14647,7 @@ module Tables = struct let _v : (Parsetree.structure) = # 1156 "mlx/parser.mly" ( _1 ) -# 14612 "mlx/parser.ml" +# 14651 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14626,7 +14665,7 @@ module Tables = struct let _v : (string) = # 3634 "mlx/parser.mly" ( "" ) -# 14630 "mlx/parser.ml" +# 14669 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14658,7 +14697,7 @@ module Tables = struct let _v : (string) = # 3635 "mlx/parser.mly" ( ";.." ) -# 14662 "mlx/parser.ml" +# 14701 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14690,7 +14729,7 @@ module Tables = struct let _v : (Parsetree.signature) = # 1163 "mlx/parser.mly" ( _1 ) -# 14694 "mlx/parser.ml" +# 14733 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14736,7 +14775,7 @@ module Tables = struct let _v : (Parsetree.extension) = # 3943 "mlx/parser.mly" ( (_2, _3) ) -# 14740 "mlx/parser.ml" +# 14779 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14757,7 +14796,7 @@ module Tables = struct let _1 : ( # 758 "mlx/parser.mly" (string * Location.t * string * Location.t * string option) -# 14761 "mlx/parser.ml" +# 14800 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -14768,7 +14807,7 @@ module Tables = struct # 3945 "mlx/parser.mly" ( mk_quotedext ~loc:_sloc _1 ) -# 14772 "mlx/parser.ml" +# 14811 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14813,12 +14852,12 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14817 "mlx/parser.ml" +# 14856 "mlx/parser.ml" in # 985 "mlx/parser.mly" ( xs ) -# 14822 "mlx/parser.ml" +# 14861 "mlx/parser.ml" in let _loc_tag_ = (_startpos_tag_, _endpos_tag_) in @@ -14830,7 +14869,7 @@ module Tables = struct mkexp ~loc children in Jsx_helper.make_jsx_element () ~raise ~loc:_loc_tag_ ~tag ~end_tag:None ~props ~children ) -# 14834 "mlx/parser.ml" +# 14873 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14897,12 +14936,12 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14901 "mlx/parser.ml" +# 14940 "mlx/parser.ml" in # 985 "mlx/parser.mly" ( xs ) -# 14906 "mlx/parser.ml" +# 14945 "mlx/parser.ml" in let (_endpos_children_, _startpos_children_) = (_endpos_xs_inlined1_, _startpos_xs_inlined1_) in @@ -14910,12 +14949,12 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14914 "mlx/parser.ml" +# 14953 "mlx/parser.ml" in # 985 "mlx/parser.mly" ( xs ) -# 14919 "mlx/parser.ml" +# 14958 "mlx/parser.ml" in let _loc_tag_ = (_startpos_tag_, _endpos_tag_) in @@ -14932,7 +14971,7 @@ module Tables = struct Jsx_helper.make_jsx_element () ~raise ~loc:_loc_tag_ ~tag ~end_tag:(Some (end_tag, _loc_end_tag__)) ~props ~children ) -# 14936 "mlx/parser.ml" +# 14975 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14953,7 +14992,7 @@ module Tables = struct let id : ( # 768 "mlx/parser.mly" (string) -# 14957 "mlx/parser.ml" +# 14996 "mlx/parser.ml" ) = Obj.magic id in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_id_ in @@ -14964,7 +15003,7 @@ module Tables = struct # 3663 "mlx/parser.mly" ( `Module, _sloc, Lident id ) -# 14968 "mlx/parser.ml" +# 15007 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14985,7 +15024,7 @@ module Tables = struct let id : ( # 715 "mlx/parser.mly" (string) -# 14989 "mlx/parser.ml" +# 15028 "mlx/parser.ml" ) = Obj.magic id in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_id_ in @@ -14996,7 +15035,7 @@ module Tables = struct # 3664 "mlx/parser.mly" ( `Value, _sloc, Lident id ) -# 15000 "mlx/parser.ml" +# 15039 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15031,7 +15070,7 @@ module Tables = struct let prefix : ( # 768 "mlx/parser.mly" (string) -# 15035 "mlx/parser.ml" +# 15074 "mlx/parser.ml" ) = Obj.magic prefix in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_prefix_ in @@ -15048,7 +15087,7 @@ module Tables = struct | Lapply _ -> assert false in `Module, _sloc, rebase id ) -# 15052 "mlx/parser.ml" +# 15091 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15083,7 +15122,7 @@ module Tables = struct let prefix : ( # 768 "mlx/parser.mly" (string) -# 15087 "mlx/parser.ml" +# 15126 "mlx/parser.ml" ) = Obj.magic prefix in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_prefix_ in @@ -15100,7 +15139,7 @@ module Tables = struct | Lapply _ -> assert false in `Value, _sloc, rebase id ) -# 15104 "mlx/parser.ml" +# 15143 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15121,7 +15160,7 @@ module Tables = struct let id : ( # 769 "mlx/parser.mly" (string) -# 15125 "mlx/parser.ml" +# 15164 "mlx/parser.ml" ) = Obj.magic id in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_id_ in @@ -15132,7 +15171,7 @@ module Tables = struct # 3663 "mlx/parser.mly" ( `Module, _sloc, Lident id ) -# 15136 "mlx/parser.ml" +# 15175 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15153,7 +15192,7 @@ module Tables = struct let id : ( # 716 "mlx/parser.mly" (string) -# 15157 "mlx/parser.ml" +# 15196 "mlx/parser.ml" ) = Obj.magic id in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_id_ in @@ -15164,7 +15203,7 @@ module Tables = struct # 3664 "mlx/parser.mly" ( `Value, _sloc, Lident id ) -# 15168 "mlx/parser.ml" +# 15207 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15199,7 +15238,7 @@ module Tables = struct let prefix : ( # 769 "mlx/parser.mly" (string) -# 15203 "mlx/parser.ml" +# 15242 "mlx/parser.ml" ) = Obj.magic prefix in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_prefix_ in @@ -15216,7 +15255,7 @@ module Tables = struct | Lapply _ -> assert false in `Module, _sloc, rebase id ) -# 15220 "mlx/parser.ml" +# 15259 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15251,7 +15290,7 @@ module Tables = struct let prefix : ( # 769 "mlx/parser.mly" (string) -# 15255 "mlx/parser.ml" +# 15294 "mlx/parser.ml" ) = Obj.magic prefix in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_prefix_ in @@ -15268,7 +15307,7 @@ module Tables = struct | Lapply _ -> assert false in `Value, _sloc, rebase id ) -# 15272 "mlx/parser.ml" +# 15311 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15289,7 +15328,7 @@ module Tables = struct let name : ( # 714 "mlx/parser.mly" (string) -# 15293 "mlx/parser.ml" +# 15332 "mlx/parser.ml" ) = Obj.magic name in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_name_ in @@ -15302,7 +15341,7 @@ module Tables = struct # 2525 "mlx/parser.mly" ( _loc_name_, `Prop_punned name ) -# 15306 "mlx/parser.ml" +# 15345 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15329,7 +15368,7 @@ module Tables = struct let name : ( # 714 "mlx/parser.mly" (string) -# 15333 "mlx/parser.ml" +# 15372 "mlx/parser.ml" ) = Obj.magic name in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -15343,7 +15382,7 @@ module Tables = struct # 2526 "mlx/parser.mly" ( _loc_name_, `Prop_opt_punned name ) -# 15347 "mlx/parser.ml" +# 15386 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15378,7 +15417,7 @@ module Tables = struct let name : ( # 714 "mlx/parser.mly" (string) -# 15382 "mlx/parser.ml" +# 15421 "mlx/parser.ml" ) = Obj.magic name in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_name_ in @@ -15391,7 +15430,7 @@ module Tables = struct # 2527 "mlx/parser.mly" ( _loc_name_, `Prop (name, expr) ) -# 15395 "mlx/parser.ml" +# 15434 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15432,7 +15471,7 @@ module Tables = struct let name : ( # 714 "mlx/parser.mly" (string) -# 15436 "mlx/parser.ml" +# 15475 "mlx/parser.ml" ) = Obj.magic name in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -15446,7 +15485,7 @@ module Tables = struct # 2528 "mlx/parser.mly" ( _loc_name_, `Prop_opt (name, expr) ) -# 15450 "mlx/parser.ml" +# 15489 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15494,7 +15533,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 15498 "mlx/parser.ml" +# 15537 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _1 : (Asttypes.mutable_flag) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -15505,7 +15544,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 15509 "mlx/parser.ml" +# 15548 "mlx/parser.ml" in let _endpos__5_ = _endpos__1_inlined3_ in @@ -15514,7 +15553,7 @@ module Tables = struct # 3337 "mlx/parser.mly" ( _1 ) -# 15518 "mlx/parser.ml" +# 15557 "mlx/parser.ml" in let _2 = @@ -15522,7 +15561,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 15526 "mlx/parser.ml" +# 15565 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -15530,7 +15569,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 15534 "mlx/parser.ml" +# 15573 "mlx/parser.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15544,7 +15583,7 @@ module Tables = struct # 3210 "mlx/parser.mly" ( let info = symbol_info _endpos in Type.field _2 _4 ~mut:_1 ~attrs:_5 ~loc:(make_loc _sloc) ~info ) -# 15548 "mlx/parser.ml" +# 15587 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15606,7 +15645,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 15610 "mlx/parser.ml" +# 15649 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _1 : (Asttypes.mutable_flag) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -15617,7 +15656,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 15621 "mlx/parser.ml" +# 15660 "mlx/parser.ml" in let _endpos__7_ = _endpos__1_inlined4_ in @@ -15626,7 +15665,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 15630 "mlx/parser.ml" +# 15669 "mlx/parser.ml" in let _endpos__5_ = _endpos__1_inlined3_ in @@ -15635,7 +15674,7 @@ module Tables = struct # 3337 "mlx/parser.mly" ( _1 ) -# 15639 "mlx/parser.ml" +# 15678 "mlx/parser.ml" in let _2 = @@ -15643,7 +15682,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 15647 "mlx/parser.ml" +# 15686 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -15651,7 +15690,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 15655 "mlx/parser.ml" +# 15694 "mlx/parser.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15669,7 +15708,7 @@ module Tables = struct | None -> symbol_info _endpos in Type.field _2 _4 ~mut:_1 ~attrs:(_5 @ _7) ~loc:(make_loc _sloc) ~info ) -# 15673 "mlx/parser.ml" +# 15712 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15694,7 +15733,7 @@ module Tables = struct let _v : (Parsetree.label_declaration list) = # 3204 "mlx/parser.mly" ( [_1] ) -# 15698 "mlx/parser.ml" +# 15737 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15719,7 +15758,7 @@ module Tables = struct let _v : (Parsetree.label_declaration list) = # 3205 "mlx/parser.mly" ( [_1] ) -# 15723 "mlx/parser.ml" +# 15762 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15751,7 +15790,7 @@ module Tables = struct let _v : (Parsetree.label_declaration list) = # 3206 "mlx/parser.mly" ( _1 :: _2 ) -# 15755 "mlx/parser.ml" +# 15794 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15772,7 +15811,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 15776 "mlx/parser.ml" +# 15815 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15785,7 +15824,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 15789 "mlx/parser.ml" +# 15828 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -15794,13 +15833,13 @@ module Tables = struct # 2256 "mlx/parser.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15798 "mlx/parser.ml" +# 15837 "mlx/parser.ml" in # 2248 "mlx/parser.mly" ( x ) -# 15804 "mlx/parser.ml" +# 15843 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15835,7 +15874,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 15839 "mlx/parser.ml" +# 15878 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15848,7 +15887,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 15852 "mlx/parser.ml" +# 15891 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -15857,7 +15896,7 @@ module Tables = struct # 2256 "mlx/parser.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15861 "mlx/parser.ml" +# 15900 "mlx/parser.ml" in let _startpos_x_ = _startpos__1_ in @@ -15869,7 +15908,7 @@ module Tables = struct ( let lab, pat = x in lab, mkpat ~loc:_sloc (Ppat_constraint (pat, cty)) ) -# 15873 "mlx/parser.ml" +# 15912 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15894,7 +15933,7 @@ module Tables = struct let _v : (Longident.t) = # 3684 "mlx/parser.mly" ( _1 ) -# 15898 "mlx/parser.ml" +# 15937 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15919,7 +15958,7 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression) = # 2532 "mlx/parser.mly" ( (Nolabel, _1) ) -# 15923 "mlx/parser.ml" +# 15962 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15947,7 +15986,7 @@ module Tables = struct let _1 : ( # 700 "mlx/parser.mly" (string) -# 15951 "mlx/parser.ml" +# 15990 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15955,7 +15994,7 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression) = # 2534 "mlx/parser.mly" ( (Labelled _1, _2) ) -# 15959 "mlx/parser.ml" +# 15998 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15982,7 +16021,7 @@ module Tables = struct let label : ( # 714 "mlx/parser.mly" (string) -# 15986 "mlx/parser.ml" +# 16025 "mlx/parser.ml" ) = Obj.magic label in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -15993,7 +16032,7 @@ module Tables = struct # 2536 "mlx/parser.mly" ( let loc = _loc_label_ in (Labelled label, mkexpvar ~loc label) ) -# 15997 "mlx/parser.ml" +# 16036 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16040,7 +16079,7 @@ module Tables = struct let label : ( # 714 "mlx/parser.mly" (string) -# 16044 "mlx/parser.ml" +# 16083 "mlx/parser.ml" ) = Obj.magic label in let _2 : unit = Obj.magic _2 in let _1 : unit = Obj.magic _1 in @@ -16053,7 +16092,7 @@ module Tables = struct # 2539 "mlx/parser.mly" ( (Labelled label, mkexp_constraint ~loc:(_startpos__2_, _endpos) (mkexpvar ~loc:_loc_label_ label) ty) ) -# 16057 "mlx/parser.ml" +# 16096 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16080,7 +16119,7 @@ module Tables = struct let label : ( # 714 "mlx/parser.mly" (string) -# 16084 "mlx/parser.ml" +# 16123 "mlx/parser.ml" ) = Obj.magic label in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -16091,7 +16130,7 @@ module Tables = struct # 2542 "mlx/parser.mly" ( let loc = _loc_label_ in (Optional label, mkexpvar ~loc label) ) -# 16095 "mlx/parser.ml" +# 16134 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16119,7 +16158,7 @@ module Tables = struct let _1 : ( # 733 "mlx/parser.mly" (string) -# 16123 "mlx/parser.ml" +# 16162 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -16127,7 +16166,7 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression) = # 2545 "mlx/parser.mly" ( (Optional _1, _2) ) -# 16131 "mlx/parser.ml" +# 16170 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16182,13 +16221,13 @@ module Tables = struct # 2244 "mlx/parser.mly" ( _1 ) -# 16186 "mlx/parser.ml" +# 16225 "mlx/parser.ml" in # 2218 "mlx/parser.mly" ( (Optional (fst _3), _4, snd _3) ) -# 16192 "mlx/parser.ml" +# 16231 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16215,7 +16254,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 16219 "mlx/parser.ml" +# 16258 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -16230,7 +16269,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 16234 "mlx/parser.ml" +# 16273 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -16239,13 +16278,13 @@ module Tables = struct # 2256 "mlx/parser.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 16243 "mlx/parser.ml" +# 16282 "mlx/parser.ml" in # 2220 "mlx/parser.mly" ( (Optional (fst _2), None, snd _2) ) -# 16249 "mlx/parser.ml" +# 16288 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16294,7 +16333,7 @@ module Tables = struct let _1 : ( # 733 "mlx/parser.mly" (string) -# 16298 "mlx/parser.ml" +# 16337 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -16304,13 +16343,13 @@ module Tables = struct # 2244 "mlx/parser.mly" ( _1 ) -# 16308 "mlx/parser.ml" +# 16347 "mlx/parser.ml" in # 2222 "mlx/parser.mly" ( (Optional _1, _4, _3) ) -# 16314 "mlx/parser.ml" +# 16353 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16338,7 +16377,7 @@ module Tables = struct let _1 : ( # 733 "mlx/parser.mly" (string) -# 16342 "mlx/parser.ml" +# 16381 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -16346,7 +16385,7 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = # 2224 "mlx/parser.mly" ( (Optional _1, None, _2) ) -# 16350 "mlx/parser.ml" +# 16389 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16392,7 +16431,7 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = # 2226 "mlx/parser.mly" ( (Labelled (fst _3), None, snd _3) ) -# 16396 "mlx/parser.ml" +# 16435 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16419,7 +16458,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 16423 "mlx/parser.ml" +# 16462 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -16434,7 +16473,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 16438 "mlx/parser.ml" +# 16477 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -16443,13 +16482,13 @@ module Tables = struct # 2256 "mlx/parser.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 16447 "mlx/parser.ml" +# 16486 "mlx/parser.ml" in # 2228 "mlx/parser.mly" ( (Labelled (fst _2), None, snd _2) ) -# 16453 "mlx/parser.ml" +# 16492 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16477,7 +16516,7 @@ module Tables = struct let _1 : ( # 700 "mlx/parser.mly" (string) -# 16481 "mlx/parser.ml" +# 16520 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -16485,7 +16524,7 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = # 2230 "mlx/parser.mly" ( (Labelled _1, None, _2) ) -# 16489 "mlx/parser.ml" +# 16528 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16510,7 +16549,7 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = # 2232 "mlx/parser.mly" ( (Nolabel, None, _1) ) -# 16514 "mlx/parser.ml" +# 16553 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16537,7 +16576,7 @@ module Tables = struct Parsetree.value_constraint option * bool) = # 2585 "mlx/parser.mly" ( let p,e,c = _1 in (p,e,c,false) ) -# 16541 "mlx/parser.ml" +# 16580 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16566,7 +16605,7 @@ module Tables = struct # 2588 "mlx/parser.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1, None, true) ) -# 16570 "mlx/parser.ml" +# 16609 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16603,13 +16642,13 @@ module Tables = struct # 2552 "mlx/parser.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16607 "mlx/parser.ml" +# 16646 "mlx/parser.ml" in # 2556 "mlx/parser.mly" ( (_1, _2, None) ) -# 16613 "mlx/parser.ml" +# 16652 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16660,7 +16699,7 @@ module Tables = struct # 2552 "mlx/parser.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16664 "mlx/parser.ml" +# 16703 "mlx/parser.ml" in @@ -16675,7 +16714,7 @@ module Tables = struct in (v, _4, Some t) ) -# 16679 "mlx/parser.ml" +# 16718 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16741,29 +16780,30 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = let _3 = + let _2 = _2_inlined1 in let _1 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 16750 "mlx/parser.ml" +# 16790 "mlx/parser.ml" in # 1003 "mlx/parser.mly" ( xs ) -# 16755 "mlx/parser.ml" +# 16795 "mlx/parser.ml" in # 3319 "mlx/parser.mly" ( _1 ) -# 16761 "mlx/parser.ml" +# 16801 "mlx/parser.ml" in # 3323 "mlx/parser.mly" ( Ptyp_poly(_1, _3) ) -# 16767 "mlx/parser.ml" +# 16807 "mlx/parser.ml" in let _startpos__3_ = _startpos_xs_ in @@ -16774,7 +16814,7 @@ module Tables = struct # 2552 "mlx/parser.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16778 "mlx/parser.ml" +# 16818 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in @@ -16784,7 +16824,7 @@ module Tables = struct let t = ghtyp ~loc:(_loc__3_) _3 in (_1, _5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) ) -# 16788 "mlx/parser.ml" +# 16828 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16859,7 +16899,7 @@ module Tables = struct Parsetree.value_constraint option) = let _4 = # 2549 "mlx/parser.mly" ( xs ) -# 16863 "mlx/parser.ml" +# 16903 "mlx/parser.ml" in let _1 = let _endpos = _endpos__1_ in @@ -16868,7 +16908,7 @@ module Tables = struct # 2552 "mlx/parser.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16872 "mlx/parser.ml" +# 16912 "mlx/parser.ml" in @@ -16877,7 +16917,7 @@ module Tables = struct Pvc_constraint { locally_abstract_univars=_4; typ = _6} in (_1, _8, Some constraint') ) -# 16881 "mlx/parser.ml" +# 16921 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16917,7 +16957,7 @@ module Tables = struct Parsetree.value_constraint option) = # 2579 "mlx/parser.mly" ( (_1, _3, None) ) -# 16921 "mlx/parser.ml" +# 16961 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16971,7 +17011,7 @@ module Tables = struct Parsetree.value_constraint option) = # 2581 "mlx/parser.mly" ( (_1, _5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=_3 })) ) -# 16975 "mlx/parser.ml" +# 17015 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17035,7 +17075,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 17039 "mlx/parser.ml" +# 17079 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in @@ -17044,7 +17084,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 17048 "mlx/parser.ml" +# 17088 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -17056,13 +17096,13 @@ module Tables = struct let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 17060 "mlx/parser.ml" +# 17100 "mlx/parser.ml" in # 2598 "mlx/parser.mly" ( _1 ) -# 17066 "mlx/parser.ml" +# 17106 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17094,7 +17134,7 @@ module Tables = struct let _v : (let_bindings) = # 2599 "mlx/parser.mly" ( addlb _1 _2 ) -# 17098 "mlx/parser.ml" +# 17138 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17151,7 +17191,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 17155 "mlx/parser.ml" +# 17195 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in @@ -17160,13 +17200,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 17164 "mlx/parser.ml" +# 17204 "mlx/parser.ml" in let ext = # 3929 "mlx/parser.mly" ( None ) -# 17170 "mlx/parser.ml" +# 17210 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in @@ -17177,13 +17217,13 @@ module Tables = struct let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 17181 "mlx/parser.ml" +# 17221 "mlx/parser.ml" in # 2598 "mlx/parser.mly" ( _1 ) -# 17187 "mlx/parser.ml" +# 17227 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17254,7 +17294,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 17258 "mlx/parser.ml" +# 17298 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17263,18 +17303,18 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 17267 "mlx/parser.ml" +# 17307 "mlx/parser.ml" in let ext = - let _startpos__1_ = _startpos__1_inlined1_ in + let (_startpos__1_, _1) = (_startpos__1_inlined1_, _1_inlined1) in let _endpos = _endpos__2_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in # 3931 "mlx/parser.mly" ( not_expecting _loc "extension" ) -# 17278 "mlx/parser.ml" +# 17318 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -17286,13 +17326,13 @@ module Tables = struct let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 17290 "mlx/parser.ml" +# 17330 "mlx/parser.ml" in # 2598 "mlx/parser.mly" ( _1 ) -# 17296 "mlx/parser.ml" +# 17336 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17324,7 +17364,7 @@ module Tables = struct let _v : (let_bindings) = # 2599 "mlx/parser.mly" ( addlb _1 _2 ) -# 17328 "mlx/parser.ml" +# 17368 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17349,7 +17389,7 @@ module Tables = struct let _v : (Parsetree.pattern) = # 2260 "mlx/parser.mly" ( _1 ) -# 17353 "mlx/parser.ml" +# 17393 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17389,7 +17429,7 @@ module Tables = struct let _1 = # 2262 "mlx/parser.mly" ( Ppat_constraint(_1, _3) ) -# 17393 "mlx/parser.ml" +# 17433 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in @@ -17398,13 +17438,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 17402 "mlx/parser.ml" +# 17442 "mlx/parser.ml" in # 2263 "mlx/parser.mly" ( _1 ) -# 17408 "mlx/parser.ml" +# 17448 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17440,13 +17480,13 @@ module Tables = struct # 2552 "mlx/parser.mly" ( mkpatvar ~loc:_sloc _1 ) -# 17444 "mlx/parser.ml" +# 17484 "mlx/parser.ml" in # 2625 "mlx/parser.mly" ( (pat, exp) ) -# 17450 "mlx/parser.ml" +# 17490 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17474,7 +17514,7 @@ module Tables = struct # 2628 "mlx/parser.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1) ) -# 17478 "mlx/parser.ml" +# 17518 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17528,7 +17568,7 @@ module Tables = struct # 2630 "mlx/parser.mly" ( let loc = (_startpos_pat_, _endpos_typ_) in (ghpat ~loc (Ppat_constraint(pat, typ)), exp) ) -# 17532 "mlx/parser.ml" +# 17572 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17567,7 +17607,7 @@ module Tables = struct let _v : (Parsetree.pattern * Parsetree.expression) = # 2633 "mlx/parser.mly" ( (pat, exp) ) -# 17571 "mlx/parser.ml" +# 17611 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17593,7 +17633,7 @@ module Tables = struct # 2637 "mlx/parser.mly" ( let let_pat, let_exp = body in let_pat, let_exp, [] ) -# 17597 "mlx/parser.ml" +# 17637 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17627,7 +17667,7 @@ module Tables = struct let _1 : ( # 696 "mlx/parser.mly" (string) -# 17631 "mlx/parser.ml" +# 17671 "mlx/parser.ml" ) = Obj.magic _1 in let bindings : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = Obj.magic bindings in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -17640,7 +17680,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 17644 "mlx/parser.ml" +# 17684 "mlx/parser.ml" in let _endpos = _endpos_body_ in @@ -17653,7 +17693,7 @@ module Tables = struct let pbop_loc = make_loc _sloc in let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in let_pat, let_exp, and_ :: rev_ands ) -# 17657 "mlx/parser.ml" +# 17697 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17668,10 +17708,10 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in - let _v : (Parsetree.class_declaration list) = + let _v : (Parsetree.class_expr Parsetree.class_infos list) = # 211 "" ( [] ) -# 17675 "mlx/parser.ml" +# 17715 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17731,13 +17771,13 @@ module Tables = struct }; }; } = _menhir_stack in - let xs : (Parsetree.class_declaration list) = Obj.magic xs in + let xs : (Parsetree.class_expr Parsetree.class_infos list) = Obj.magic xs in let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 17741 "mlx/parser.ml" +# 17781 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -17746,13 +17786,13 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos_xs_ in - let _v : (Parsetree.class_declaration list) = let x = + let _v : (Parsetree.class_expr Parsetree.class_infos list) = let x = let attrs2 = let _1 = _1_inlined3 in # 3918 "mlx/parser.mly" ( _1 ) -# 17756 "mlx/parser.ml" +# 17796 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17764,7 +17804,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 17768 "mlx/parser.ml" +# 17808 "mlx/parser.ml" in let attrs1 = @@ -17772,7 +17812,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 17776 "mlx/parser.ml" +# 17816 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -17787,13 +17827,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs ) -# 17791 "mlx/parser.ml" +# 17831 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 17797 "mlx/parser.ml" +# 17837 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17808,10 +17848,10 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in - let _v : (Parsetree.class_description list) = + let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 17815 "mlx/parser.ml" +# 17855 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17877,14 +17917,14 @@ module Tables = struct }; }; } = _menhir_stack in - let xs : (Parsetree.class_description list) = Obj.magic xs in + let xs : (Parsetree.class_type Parsetree.class_infos list) = Obj.magic xs in let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let cty : (Parsetree.class_type) = Obj.magic cty in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 17888 "mlx/parser.ml" +# 17928 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -17893,13 +17933,13 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos_xs_ in - let _v : (Parsetree.class_description list) = let x = + let _v : (Parsetree.class_type Parsetree.class_infos list) = let x = let attrs2 = let _1 = _1_inlined3 in # 3918 "mlx/parser.mly" ( _1 ) -# 17903 "mlx/parser.ml" +# 17943 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17911,7 +17951,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 17915 "mlx/parser.ml" +# 17955 "mlx/parser.ml" in let attrs1 = @@ -17919,7 +17959,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 17923 "mlx/parser.ml" +# 17963 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -17934,13 +17974,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs ) -# 17938 "mlx/parser.ml" +# 17978 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 17944 "mlx/parser.ml" +# 17984 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17955,10 +17995,10 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in - let _v : (Parsetree.class_type_declaration list) = + let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 17962 "mlx/parser.ml" +# 18002 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18024,14 +18064,14 @@ module Tables = struct }; }; } = _menhir_stack in - let xs : (Parsetree.class_type_declaration list) = Obj.magic xs in + let xs : (Parsetree.class_type Parsetree.class_infos list) = Obj.magic xs in let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let csig : (Parsetree.class_type) = Obj.magic csig in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 18035 "mlx/parser.ml" +# 18075 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -18040,13 +18080,13 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos_xs_ in - let _v : (Parsetree.class_type_declaration list) = let x = + let _v : (Parsetree.class_type Parsetree.class_infos list) = let x = let attrs2 = let _1 = _1_inlined3 in # 3918 "mlx/parser.mly" ( _1 ) -# 18050 "mlx/parser.ml" +# 18090 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18058,7 +18098,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 18062 "mlx/parser.ml" +# 18102 "mlx/parser.ml" in let attrs1 = @@ -18066,7 +18106,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 18070 "mlx/parser.ml" +# 18110 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -18081,13 +18121,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs ) -# 18085 "mlx/parser.ml" +# 18125 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 18091 "mlx/parser.ml" +# 18131 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18105,7 +18145,7 @@ module Tables = struct let _v : (Parsetree.module_binding list) = # 211 "" ( [] ) -# 18109 "mlx/parser.ml" +# 18149 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18168,7 +18208,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 18172 "mlx/parser.ml" +# 18212 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18180,7 +18220,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 18184 "mlx/parser.ml" +# 18224 "mlx/parser.ml" in let attrs1 = @@ -18188,7 +18228,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 18192 "mlx/parser.ml" +# 18232 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -18203,13 +18243,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Mb.mk name body ~attrs ~loc ~text ~docs ) -# 18207 "mlx/parser.ml" +# 18247 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 18213 "mlx/parser.ml" +# 18253 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18227,7 +18267,7 @@ module Tables = struct let _v : (Parsetree.module_declaration list) = # 211 "" ( [] ) -# 18231 "mlx/parser.ml" +# 18271 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18297,7 +18337,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 18301 "mlx/parser.ml" +# 18341 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18309,7 +18349,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 18313 "mlx/parser.ml" +# 18353 "mlx/parser.ml" in let attrs1 = @@ -18317,7 +18357,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 18321 "mlx/parser.ml" +# 18361 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -18332,13 +18372,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Md.mk name mty ~attrs ~loc ~text ~docs ) -# 18336 "mlx/parser.ml" +# 18376 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 18342 "mlx/parser.ml" +# 18382 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18356,7 +18396,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 18360 "mlx/parser.ml" +# 18400 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18388,7 +18428,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 18392 "mlx/parser.ml" +# 18432 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18406,7 +18446,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 18410 "mlx/parser.ml" +# 18450 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18473,7 +18513,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 18477 "mlx/parser.ml" +# 18517 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -18488,7 +18528,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 18492 "mlx/parser.ml" +# 18532 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18497,18 +18537,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18501 "mlx/parser.ml" +# 18541 "mlx/parser.ml" in # 985 "mlx/parser.mly" ( xs ) -# 18506 "mlx/parser.ml" +# 18546 "mlx/parser.ml" in # 3036 "mlx/parser.mly" ( _1 ) -# 18512 "mlx/parser.ml" +# 18552 "mlx/parser.ml" in let id = @@ -18519,7 +18559,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 18523 "mlx/parser.ml" +# 18563 "mlx/parser.ml" in let attrs1 = @@ -18527,7 +18567,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 18531 "mlx/parser.ml" +# 18571 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -18543,13 +18583,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18547 "mlx/parser.ml" +# 18587 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 18553 "mlx/parser.ml" +# 18593 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18567,7 +18607,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 18571 "mlx/parser.ml" +# 18611 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18641,7 +18681,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 18645 "mlx/parser.ml" +# 18685 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -18656,7 +18696,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 18660 "mlx/parser.ml" +# 18700 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -18665,25 +18705,28 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18669 "mlx/parser.ml" +# 18709 "mlx/parser.ml" in # 985 "mlx/parser.mly" ( xs ) -# 18674 "mlx/parser.ml" +# 18714 "mlx/parser.ml" in # 3036 "mlx/parser.mly" ( _1 ) -# 18680 "mlx/parser.ml" +# 18720 "mlx/parser.ml" in - let kind_priv_manifest = + let kind_priv_manifest = + let _1 = _1_inlined3 in + # 3071 "mlx/parser.mly" ( _2 ) -# 18686 "mlx/parser.ml" - in +# 18728 "mlx/parser.ml" + + in let id = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _endpos = _endpos__1_ in @@ -18692,7 +18735,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 18696 "mlx/parser.ml" +# 18739 "mlx/parser.ml" in let attrs1 = @@ -18700,7 +18743,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 18704 "mlx/parser.ml" +# 18747 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -18716,13 +18759,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18720 "mlx/parser.ml" +# 18763 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 18726 "mlx/parser.ml" +# 18769 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18740,7 +18783,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 18744 "mlx/parser.ml" +# 18787 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18772,7 +18815,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 18776 "mlx/parser.ml" +# 18819 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18790,7 +18833,7 @@ module Tables = struct let _v : (Parsetree.signature_item list list) = # 211 "" ( [] ) -# 18794 "mlx/parser.ml" +# 18837 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18825,19 +18868,19 @@ module Tables = struct # 911 "mlx/parser.mly" ( text_sig _startpos ) -# 18829 "mlx/parser.ml" +# 18872 "mlx/parser.ml" in # 1662 "mlx/parser.mly" ( _1 ) -# 18835 "mlx/parser.ml" +# 18878 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 18841 "mlx/parser.ml" +# 18884 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18872,19 +18915,19 @@ module Tables = struct # 909 "mlx/parser.mly" ( text_sig _startpos @ [_1] ) -# 18876 "mlx/parser.ml" +# 18919 "mlx/parser.ml" in # 1662 "mlx/parser.mly" ( _1 ) -# 18882 "mlx/parser.ml" +# 18925 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 18888 "mlx/parser.ml" +# 18931 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18902,7 +18945,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 18906 "mlx/parser.ml" +# 18949 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18937,12 +18980,12 @@ module Tables = struct let items = # 971 "mlx/parser.mly" ( [] ) -# 18941 "mlx/parser.ml" +# 18984 "mlx/parser.ml" in # 1401 "mlx/parser.mly" ( items ) -# 18946 "mlx/parser.ml" +# 18989 "mlx/parser.ml" in let xs = @@ -18950,25 +18993,25 @@ module Tables = struct # 907 "mlx/parser.mly" ( text_str _startpos ) -# 18954 "mlx/parser.ml" +# 18997 "mlx/parser.ml" in # 267 "" ( xs @ ys ) -# 18960 "mlx/parser.ml" +# 19003 "mlx/parser.ml" in # 1417 "mlx/parser.mly" ( _1 ) -# 18966 "mlx/parser.ml" +# 19009 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 18972 "mlx/parser.ml" +# 19015 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19022,12 +19065,12 @@ module Tables = struct let attrs = # 3918 "mlx/parser.mly" ( _1 ) -# 19026 "mlx/parser.ml" +# 19069 "mlx/parser.ml" in # 1408 "mlx/parser.mly" ( mkstrexp e attrs ) -# 19031 "mlx/parser.ml" +# 19074 "mlx/parser.ml" in let _startpos__1_ = _startpos_e_ in @@ -19035,7 +19078,7 @@ module Tables = struct # 905 "mlx/parser.mly" ( text_str _startpos @ [_1] ) -# 19039 "mlx/parser.ml" +# 19082 "mlx/parser.ml" in let _startpos__1_ = _startpos_e_ in @@ -19045,19 +19088,19 @@ module Tables = struct # 924 "mlx/parser.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 19049 "mlx/parser.ml" +# 19092 "mlx/parser.ml" in # 973 "mlx/parser.mly" ( x ) -# 19055 "mlx/parser.ml" +# 19098 "mlx/parser.ml" in # 1401 "mlx/parser.mly" ( items ) -# 19061 "mlx/parser.ml" +# 19104 "mlx/parser.ml" in let xs = @@ -19065,25 +19108,25 @@ module Tables = struct # 907 "mlx/parser.mly" ( text_str _startpos ) -# 19069 "mlx/parser.ml" +# 19112 "mlx/parser.ml" in # 267 "" ( xs @ ys ) -# 19075 "mlx/parser.ml" +# 19118 "mlx/parser.ml" in # 1417 "mlx/parser.mly" ( _1 ) -# 19081 "mlx/parser.ml" +# 19124 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 19087 "mlx/parser.ml" +# 19130 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19118,19 +19161,19 @@ module Tables = struct # 905 "mlx/parser.mly" ( text_str _startpos @ [_1] ) -# 19122 "mlx/parser.ml" +# 19165 "mlx/parser.ml" in # 1417 "mlx/parser.mly" ( _1 ) -# 19128 "mlx/parser.ml" +# 19171 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 19134 "mlx/parser.ml" +# 19177 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19148,7 +19191,7 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = # 211 "" ( [] ) -# 19152 "mlx/parser.ml" +# 19195 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19182,13 +19225,13 @@ module Tables = struct # 919 "mlx/parser.mly" ( text_csig _startpos @ [_1] ) -# 19186 "mlx/parser.ml" +# 19229 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 19192 "mlx/parser.ml" +# 19235 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19206,7 +19249,7 @@ module Tables = struct let _v : (Parsetree.class_field list list) = # 211 "" ( [] ) -# 19210 "mlx/parser.ml" +# 19253 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19240,13 +19283,13 @@ module Tables = struct # 917 "mlx/parser.mly" ( text_cstr _startpos @ [_1] ) -# 19244 "mlx/parser.ml" +# 19287 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 19250 "mlx/parser.ml" +# 19293 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19264,7 +19307,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 19268 "mlx/parser.ml" +# 19311 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19298,13 +19341,13 @@ module Tables = struct # 905 "mlx/parser.mly" ( text_str _startpos @ [_1] ) -# 19302 "mlx/parser.ml" +# 19345 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 19308 "mlx/parser.ml" +# 19351 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19322,7 +19365,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = # 211 "" ( [] ) -# 19326 "mlx/parser.ml" +# 19369 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19357,30 +19400,30 @@ module Tables = struct let _1 = # 971 "mlx/parser.mly" ( [] ) -# 19361 "mlx/parser.ml" +# 19404 "mlx/parser.ml" in # 1203 "mlx/parser.mly" ( _1 ) -# 19366 "mlx/parser.ml" +# 19409 "mlx/parser.ml" in # 183 "" ( x ) -# 19372 "mlx/parser.ml" +# 19415 "mlx/parser.ml" in # 1215 "mlx/parser.mly" ( _1 ) -# 19378 "mlx/parser.ml" +# 19421 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 19384 "mlx/parser.ml" +# 19427 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19434,18 +19477,18 @@ module Tables = struct let attrs = # 3918 "mlx/parser.mly" ( _1 ) -# 19438 "mlx/parser.ml" +# 19481 "mlx/parser.ml" in # 1408 "mlx/parser.mly" ( mkstrexp e attrs ) -# 19443 "mlx/parser.ml" +# 19486 "mlx/parser.ml" in # 915 "mlx/parser.mly" ( Ptop_def [_1] ) -# 19449 "mlx/parser.ml" +# 19492 "mlx/parser.ml" in let _startpos__1_ = _startpos_e_ in @@ -19453,37 +19496,37 @@ module Tables = struct # 913 "mlx/parser.mly" ( text_def _startpos @ [_1] ) -# 19457 "mlx/parser.ml" +# 19500 "mlx/parser.ml" in # 973 "mlx/parser.mly" ( x ) -# 19463 "mlx/parser.ml" +# 19506 "mlx/parser.ml" in # 1203 "mlx/parser.mly" ( _1 ) -# 19469 "mlx/parser.ml" +# 19512 "mlx/parser.ml" in # 183 "" ( x ) -# 19475 "mlx/parser.ml" +# 19518 "mlx/parser.ml" in # 1215 "mlx/parser.mly" ( _1 ) -# 19481 "mlx/parser.ml" +# 19524 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 19487 "mlx/parser.ml" +# 19530 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19517,25 +19560,25 @@ module Tables = struct let _1 = # 915 "mlx/parser.mly" ( Ptop_def [_1] ) -# 19521 "mlx/parser.ml" +# 19564 "mlx/parser.ml" in let _startpos = _startpos__1_ in # 913 "mlx/parser.mly" ( text_def _startpos @ [_1] ) -# 19527 "mlx/parser.ml" +# 19570 "mlx/parser.ml" in # 1215 "mlx/parser.mly" ( _1 ) -# 19533 "mlx/parser.ml" +# 19576 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 19539 "mlx/parser.ml" +# 19582 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19573,26 +19616,26 @@ module Tables = struct # 924 "mlx/parser.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 19577 "mlx/parser.ml" +# 19620 "mlx/parser.ml" in let _startpos = _startpos__1_ in # 913 "mlx/parser.mly" ( text_def _startpos @ [_1] ) -# 19584 "mlx/parser.ml" +# 19627 "mlx/parser.ml" in # 1215 "mlx/parser.mly" ( _1 ) -# 19590 "mlx/parser.ml" +# 19633 "mlx/parser.ml" in # 213 "" ( x :: xs ) -# 19596 "mlx/parser.ml" +# 19639 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19631,7 +19674,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 124 "" ( None ) -# 19635 "mlx/parser.ml" +# 19678 "mlx/parser.ml" in let x = let label = @@ -19641,7 +19684,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 19645 "mlx/parser.ml" +# 19688 "mlx/parser.ml" in let _startpos_label_ = _startpos__1_ in @@ -19663,13 +19706,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19667 "mlx/parser.ml" +# 19710 "mlx/parser.ml" in # 1140 "mlx/parser.mly" ( [x], None ) -# 19673 "mlx/parser.ml" +# 19716 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19715,7 +19758,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 126 "" ( Some x ) -# 19719 "mlx/parser.ml" +# 19762 "mlx/parser.ml" in let x = let label = @@ -19725,7 +19768,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 19729 "mlx/parser.ml" +# 19772 "mlx/parser.ml" in let _startpos_label_ = _startpos__1_ in @@ -19747,13 +19790,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19751 "mlx/parser.ml" +# 19794 "mlx/parser.ml" in # 1140 "mlx/parser.mly" ( [x], None ) -# 19757 "mlx/parser.ml" +# 19800 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19818,7 +19861,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 19822 "mlx/parser.ml" +# 19865 "mlx/parser.ml" in let _startpos_label_ = _startpos__1_ in @@ -19840,13 +19883,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19844 "mlx/parser.ml" +# 19887 "mlx/parser.ml" in # 1142 "mlx/parser.mly" ( [x], Some y ) -# 19850 "mlx/parser.ml" +# 19893 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19904,7 +19947,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 19908 "mlx/parser.ml" +# 19951 "mlx/parser.ml" in let _startpos_label_ = _startpos__1_ in @@ -19926,14 +19969,14 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19930 "mlx/parser.ml" +# 19973 "mlx/parser.ml" in # 1146 "mlx/parser.mly" ( let xs, y = tail in x :: xs, y ) -# 19937 "mlx/parser.ml" +# 19980 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19972,7 +20015,7 @@ module Tables = struct let _v : (Parsetree.case) = # 2666 "mlx/parser.mly" ( Exp.case _1 _3 ) -# 19976 "mlx/parser.ml" +# 20019 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20025,7 +20068,7 @@ module Tables = struct let _v : (Parsetree.case) = # 2668 "mlx/parser.mly" ( Exp.case _1 ~guard:_3 _5 ) -# 20029 "mlx/parser.ml" +# 20072 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20065,7 +20108,7 @@ module Tables = struct # 2670 "mlx/parser.mly" ( Exp.case _1 (Exp.unreachable ~loc:(make_loc _loc__3_) ()) ) -# 20069 "mlx/parser.ml" +# 20112 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20128,7 +20171,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 20132 "mlx/parser.ml" +# 20175 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20139,7 +20182,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 20143 "mlx/parser.ml" +# 20186 "mlx/parser.ml" in let _endpos__6_ = _endpos__1_inlined3_ in @@ -20148,7 +20191,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 20152 "mlx/parser.ml" +# 20195 "mlx/parser.ml" in let _endpos__4_ = _endpos__1_inlined2_ in @@ -20157,14 +20200,14 @@ module Tables = struct # 3337 "mlx/parser.mly" ( _1 ) -# 20161 "mlx/parser.ml" +# 20204 "mlx/parser.ml" in let _1 = let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 20168 "mlx/parser.ml" +# 20211 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -20172,7 +20215,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 20176 "mlx/parser.ml" +# 20219 "mlx/parser.ml" in let _endpos = _endpos__6_ in @@ -20187,13 +20230,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20191 "mlx/parser.ml" +# 20234 "mlx/parser.ml" in # 3528 "mlx/parser.mly" ( let (f, c) = tail in (head :: f, c) ) -# 20197 "mlx/parser.ml" +# 20240 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20236,13 +20279,13 @@ module Tables = struct # 3558 "mlx/parser.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20240 "mlx/parser.ml" +# 20283 "mlx/parser.ml" in # 3528 "mlx/parser.mly" ( let (f, c) = tail in (head :: f, c) ) -# 20246 "mlx/parser.ml" +# 20289 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20298,7 +20341,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 20302 "mlx/parser.ml" +# 20345 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20309,7 +20352,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 20313 "mlx/parser.ml" +# 20356 "mlx/parser.ml" in let _endpos__6_ = _endpos__1_inlined3_ in @@ -20318,7 +20361,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 20322 "mlx/parser.ml" +# 20365 "mlx/parser.ml" in let _endpos__4_ = _endpos__1_inlined2_ in @@ -20327,14 +20370,14 @@ module Tables = struct # 3337 "mlx/parser.mly" ( _1 ) -# 20331 "mlx/parser.ml" +# 20374 "mlx/parser.ml" in let _1 = let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 20338 "mlx/parser.ml" +# 20381 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -20342,7 +20385,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 20346 "mlx/parser.ml" +# 20389 "mlx/parser.ml" in let _endpos = _endpos__6_ in @@ -20357,13 +20400,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20361 "mlx/parser.ml" +# 20404 "mlx/parser.ml" in # 3531 "mlx/parser.mly" ( [head], Closed ) -# 20367 "mlx/parser.ml" +# 20410 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20399,13 +20442,13 @@ module Tables = struct # 3558 "mlx/parser.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20403 "mlx/parser.ml" +# 20446 "mlx/parser.ml" in # 3531 "mlx/parser.mly" ( [head], Closed ) -# 20409 "mlx/parser.ml" +# 20452 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20447,7 +20490,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 20451 "mlx/parser.ml" +# 20494 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20458,7 +20501,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 20462 "mlx/parser.ml" +# 20505 "mlx/parser.ml" in let _endpos__4_ = _endpos__1_inlined2_ in @@ -20467,14 +20510,14 @@ module Tables = struct # 3337 "mlx/parser.mly" ( _1 ) -# 20471 "mlx/parser.ml" +# 20514 "mlx/parser.ml" in let _1 = let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 20478 "mlx/parser.ml" +# 20521 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -20482,7 +20525,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 20486 "mlx/parser.ml" +# 20529 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -20493,13 +20536,13 @@ module Tables = struct ( let info = symbol_info _endpos in let attrs = add_info_attrs info _4 in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20497 "mlx/parser.ml" +# 20540 "mlx/parser.ml" in # 3534 "mlx/parser.mly" ( [head], Closed ) -# 20503 "mlx/parser.ml" +# 20546 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20528,13 +20571,13 @@ module Tables = struct # 3558 "mlx/parser.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20532 "mlx/parser.ml" +# 20575 "mlx/parser.ml" in # 3534 "mlx/parser.mly" ( [head], Closed ) -# 20538 "mlx/parser.ml" +# 20581 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20559,7 +20602,7 @@ module Tables = struct let _v : (Parsetree.object_field list * Asttypes.closed_flag) = # 3536 "mlx/parser.mly" ( [], Open ) -# 20563 "mlx/parser.ml" +# 20606 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20606,7 +20649,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 20610 "mlx/parser.ml" +# 20653 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let private_ : (Asttypes.private_flag) = Obj.magic private_ in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -20619,7 +20662,7 @@ module Tables = struct # 3333 "mlx/parser.mly" ( _1 ) -# 20623 "mlx/parser.ml" +# 20666 "mlx/parser.ml" in let label = @@ -20627,7 +20670,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 20631 "mlx/parser.ml" +# 20674 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -20635,23 +20678,23 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 20639 "mlx/parser.ml" +# 20682 "mlx/parser.ml" in let attrs = # 3922 "mlx/parser.mly" ( _1 ) -# 20645 "mlx/parser.ml" +# 20688 "mlx/parser.ml" in let _1 = # 3821 "mlx/parser.mly" ( Fresh ) -# 20650 "mlx/parser.ml" +# 20693 "mlx/parser.ml" in # 2002 "mlx/parser.mly" ( (label, private_, Cfk_virtual ty), attrs ) -# 20655 "mlx/parser.ml" +# 20698 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20691,7 +20734,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 20695 "mlx/parser.ml" +# 20738 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -20704,7 +20747,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 20708 "mlx/parser.ml" +# 20751 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -20712,18 +20755,18 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 20716 "mlx/parser.ml" +# 20759 "mlx/parser.ml" in let _2 = # 3922 "mlx/parser.mly" ( _1 ) -# 20722 "mlx/parser.ml" +# 20765 "mlx/parser.ml" in let _1 = # 3824 "mlx/parser.mly" ( Fresh ) -# 20727 "mlx/parser.ml" +# 20770 "mlx/parser.ml" in # 2004 "mlx/parser.mly" @@ -20731,7 +20774,7 @@ module Tables = struct let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in (_4, _3, Cfk_concrete (_1, ghexp ~loc (Pexp_poly (e, None)))), _2 ) -# 20735 "mlx/parser.ml" +# 20778 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20777,7 +20820,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 20781 "mlx/parser.ml" +# 20824 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -20791,7 +20834,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 20795 "mlx/parser.ml" +# 20838 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -20799,7 +20842,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 20803 "mlx/parser.ml" +# 20846 "mlx/parser.ml" in let _2 = @@ -20807,13 +20850,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 20811 "mlx/parser.ml" +# 20854 "mlx/parser.ml" in let _1 = # 3825 "mlx/parser.mly" ( Override ) -# 20817 "mlx/parser.ml" +# 20860 "mlx/parser.ml" in # 2004 "mlx/parser.mly" @@ -20821,7 +20864,7 @@ module Tables = struct let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in (_4, _3, Cfk_concrete (_1, ghexp ~loc (Pexp_poly (e, None)))), _2 ) -# 20825 "mlx/parser.ml" +# 20868 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20882,7 +20925,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 20886 "mlx/parser.ml" +# 20929 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -20895,7 +20938,7 @@ module Tables = struct # 3333 "mlx/parser.mly" ( _1 ) -# 20899 "mlx/parser.ml" +# 20942 "mlx/parser.ml" in let _startpos__6_ = _startpos__1_inlined2_ in @@ -20904,7 +20947,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 20908 "mlx/parser.ml" +# 20951 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -20912,18 +20955,18 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 20916 "mlx/parser.ml" +# 20959 "mlx/parser.ml" in let _2 = # 3922 "mlx/parser.mly" ( _1 ) -# 20922 "mlx/parser.ml" +# 20965 "mlx/parser.ml" in let _1 = # 3824 "mlx/parser.mly" ( Fresh ) -# 20927 "mlx/parser.ml" +# 20970 "mlx/parser.ml" in # 2010 "mlx/parser.mly" @@ -20931,7 +20974,7 @@ module Tables = struct let loc = (_startpos__6_, _endpos__8_) in ghexp ~loc (Pexp_poly(_8, Some _6)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 20935 "mlx/parser.ml" +# 20978 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20998,7 +21041,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 21002 "mlx/parser.ml" +# 21045 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -21012,7 +21055,7 @@ module Tables = struct # 3333 "mlx/parser.mly" ( _1 ) -# 21016 "mlx/parser.ml" +# 21059 "mlx/parser.ml" in let _startpos__6_ = _startpos__1_inlined3_ in @@ -21021,7 +21064,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 21025 "mlx/parser.ml" +# 21068 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -21029,7 +21072,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 21033 "mlx/parser.ml" +# 21076 "mlx/parser.ml" in let _2 = @@ -21037,13 +21080,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 21041 "mlx/parser.ml" +# 21084 "mlx/parser.ml" in let _1 = # 3825 "mlx/parser.mly" ( Override ) -# 21047 "mlx/parser.ml" +# 21090 "mlx/parser.ml" in # 2010 "mlx/parser.mly" @@ -21051,7 +21094,7 @@ module Tables = struct let loc = (_startpos__6_, _endpos__8_) in ghexp ~loc (Pexp_poly(_8, Some _6)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21055 "mlx/parser.ml" +# 21098 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21133,7 +21176,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 21137 "mlx/parser.ml" +# 21180 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -21144,7 +21187,7 @@ module Tables = struct Parsetree.attributes) = let _7 = # 2549 "mlx/parser.mly" ( xs ) -# 21148 "mlx/parser.ml" +# 21191 "mlx/parser.ml" in let _startpos__7_ = _startpos_xs_ in let _4 = @@ -21152,7 +21195,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 21156 "mlx/parser.ml" +# 21199 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -21160,20 +21203,20 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 21164 "mlx/parser.ml" +# 21207 "mlx/parser.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = # 3922 "mlx/parser.mly" ( _1 ) -# 21171 "mlx/parser.ml" +# 21214 "mlx/parser.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = # 3824 "mlx/parser.mly" ( Fresh ) -# 21177 "mlx/parser.ml" +# 21220 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__11_ in @@ -21200,7 +21243,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21204 "mlx/parser.ml" +# 21247 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21288,7 +21331,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 21292 "mlx/parser.ml" +# 21335 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -21300,7 +21343,7 @@ module Tables = struct Parsetree.attributes) = let _7 = # 2549 "mlx/parser.mly" ( xs ) -# 21304 "mlx/parser.ml" +# 21347 "mlx/parser.ml" in let _startpos__7_ = _startpos_xs_ in let _4 = @@ -21308,7 +21351,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 21312 "mlx/parser.ml" +# 21355 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -21316,7 +21359,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 21320 "mlx/parser.ml" +# 21363 "mlx/parser.ml" in let _startpos__4_ = _startpos__1_inlined2_ in @@ -21325,14 +21368,14 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 21329 "mlx/parser.ml" +# 21372 "mlx/parser.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = # 3825 "mlx/parser.mly" ( Override ) -# 21336 "mlx/parser.ml" +# 21379 "mlx/parser.ml" in let _endpos = _endpos__11_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -21358,7 +21401,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21362 "mlx/parser.ml" +# 21405 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21379,7 +21422,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 21383 "mlx/parser.ml" +# 21426 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -21387,7 +21430,7 @@ module Tables = struct let _v : (Longident.t) = # 3659 "mlx/parser.mly" ( Lident _1 ) -# 21391 "mlx/parser.ml" +# 21434 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21420,7 +21463,7 @@ module Tables = struct let _3 : ( # 714 "mlx/parser.mly" (string) -# 21424 "mlx/parser.ml" +# 21467 "mlx/parser.ml" ) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : (Longident.t) = Obj.magic _1 in @@ -21430,7 +21473,7 @@ module Tables = struct let _v : (Longident.t) = # 3660 "mlx/parser.mly" ( Ldot(_1,_3) ) -# 21434 "mlx/parser.ml" +# 21477 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21451,7 +21494,7 @@ module Tables = struct let _1 : ( # 767 "mlx/parser.mly" (string) -# 21455 "mlx/parser.ml" +# 21498 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -21459,7 +21502,7 @@ module Tables = struct let _v : (Longident.t) = # 3659 "mlx/parser.mly" ( Lident _1 ) -# 21463 "mlx/parser.ml" +# 21506 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21492,7 +21535,7 @@ module Tables = struct let _3 : ( # 767 "mlx/parser.mly" (string) -# 21496 "mlx/parser.ml" +# 21539 "mlx/parser.ml" ) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : (Longident.t) = Obj.magic _1 in @@ -21502,7 +21545,7 @@ module Tables = struct let _v : (Longident.t) = # 3660 "mlx/parser.mly" ( Ldot(_1,_3) ) -# 21506 "mlx/parser.ml" +# 21549 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21527,12 +21570,12 @@ module Tables = struct let _v : (Longident.t) = let _1 = # 3715 "mlx/parser.mly" ( _1 ) -# 21531 "mlx/parser.ml" +# 21574 "mlx/parser.ml" in # 3659 "mlx/parser.mly" ( Lident _1 ) -# 21536 "mlx/parser.ml" +# 21579 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21572,18 +21615,18 @@ module Tables = struct let _1 = # 3639 "mlx/parser.mly" ( "::" ) -# 21576 "mlx/parser.ml" +# 21619 "mlx/parser.ml" in # 3715 "mlx/parser.mly" ( _1 ) -# 21581 "mlx/parser.ml" +# 21624 "mlx/parser.ml" in # 3659 "mlx/parser.mly" ( Lident _1 ) -# 21587 "mlx/parser.ml" +# 21630 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21608,12 +21651,12 @@ module Tables = struct let _v : (Longident.t) = let _1 = # 3715 "mlx/parser.mly" ( _1 ) -# 21612 "mlx/parser.ml" +# 21655 "mlx/parser.ml" in # 3659 "mlx/parser.mly" ( Lident _1 ) -# 21617 "mlx/parser.ml" +# 21660 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21654,13 +21697,13 @@ module Tables = struct # 3715 "mlx/parser.mly" ( _1 ) -# 21658 "mlx/parser.ml" +# 21701 "mlx/parser.ml" in # 3660 "mlx/parser.mly" ( Ldot(_1,_3) ) -# 21664 "mlx/parser.ml" +# 21707 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21711,21 +21754,22 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = let _3 = + let (_2, _1) = (_2_inlined1, _1_inlined1) in let _1 = # 3639 "mlx/parser.mly" ( "::" ) -# 21718 "mlx/parser.ml" +# 21762 "mlx/parser.ml" in # 3715 "mlx/parser.mly" ( _1 ) -# 21723 "mlx/parser.ml" +# 21767 "mlx/parser.ml" in # 3660 "mlx/parser.mly" ( Ldot(_1,_3) ) -# 21729 "mlx/parser.ml" +# 21773 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21766,13 +21810,13 @@ module Tables = struct # 3715 "mlx/parser.mly" ( _1 ) -# 21770 "mlx/parser.ml" +# 21814 "mlx/parser.ml" in # 3660 "mlx/parser.mly" ( Ldot(_1,_3) ) -# 21776 "mlx/parser.ml" +# 21820 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21797,7 +21841,7 @@ module Tables = struct let _v : (Longident.t) = # 3659 "mlx/parser.mly" ( Lident _1 ) -# 21801 "mlx/parser.ml" +# 21845 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21836,7 +21880,7 @@ module Tables = struct let _v : (Longident.t) = # 3660 "mlx/parser.mly" ( Ldot(_1,_3) ) -# 21840 "mlx/parser.ml" +# 21884 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21857,7 +21901,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 21861 "mlx/parser.ml" +# 21905 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -21865,7 +21909,7 @@ module Tables = struct let _v : (Longident.t) = # 3659 "mlx/parser.mly" ( Lident _1 ) -# 21869 "mlx/parser.ml" +# 21913 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21898,7 +21942,7 @@ module Tables = struct let _3 : ( # 714 "mlx/parser.mly" (string) -# 21902 "mlx/parser.ml" +# 21946 "mlx/parser.ml" ) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : (Longident.t) = Obj.magic _1 in @@ -21908,7 +21952,7 @@ module Tables = struct let _v : (Longident.t) = # 3660 "mlx/parser.mly" ( Ldot(_1,_3) ) -# 21912 "mlx/parser.ml" +# 21956 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21929,7 +21973,7 @@ module Tables = struct let _1 : ( # 767 "mlx/parser.mly" (string) -# 21933 "mlx/parser.ml" +# 21977 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -21937,7 +21981,7 @@ module Tables = struct let _v : (Longident.t) = # 3659 "mlx/parser.mly" ( Lident _1 ) -# 21941 "mlx/parser.ml" +# 21985 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21970,7 +22014,7 @@ module Tables = struct let _3 : ( # 767 "mlx/parser.mly" (string) -# 21974 "mlx/parser.ml" +# 22018 "mlx/parser.ml" ) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : (Longident.t) = Obj.magic _1 in @@ -21980,7 +22024,7 @@ module Tables = struct let _v : (Longident.t) = # 3660 "mlx/parser.mly" ( Ldot(_1,_3) ) -# 21984 "mlx/parser.ml" +# 22028 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22005,7 +22049,7 @@ module Tables = struct let _v : (Longident.t) = # 3659 "mlx/parser.mly" ( Lident _1 ) -# 22009 "mlx/parser.ml" +# 22053 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22044,7 +22088,7 @@ module Tables = struct let _v : (Longident.t) = # 3660 "mlx/parser.mly" ( Ldot(_1,_3) ) -# 22048 "mlx/parser.ml" +# 22092 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22069,7 +22113,7 @@ module Tables = struct let _v : (Longident.t) = # 3693 "mlx/parser.mly" ( _1 ) -# 22073 "mlx/parser.ml" +# 22117 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22118,7 +22162,7 @@ module Tables = struct # 3695 "mlx/parser.mly" ( lapply ~loc:_sloc _1 _3 ) -# 22122 "mlx/parser.ml" +# 22166 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22158,7 +22202,7 @@ module Tables = struct # 3697 "mlx/parser.mly" ( expecting _loc__3_ "module path" ) -# 22162 "mlx/parser.ml" +# 22206 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22183,7 +22227,7 @@ module Tables = struct let _v : (Longident.t) = # 3690 "mlx/parser.mly" ( _1 ) -# 22187 "mlx/parser.ml" +# 22231 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22215,7 +22259,7 @@ module Tables = struct let _v : (Parsetree.module_expr) = # 1477 "mlx/parser.mly" ( me ) -# 22219 "mlx/parser.ml" +# 22263 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22248,7 +22292,7 @@ module Tables = struct # 1479 "mlx/parser.mly" ( expecting _loc__1_ "=" ) -# 22252 "mlx/parser.ml" +# 22296 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22295,7 +22339,7 @@ module Tables = struct let _1 = # 1482 "mlx/parser.mly" ( Pmod_constraint(me, mty) ) -# 22299 "mlx/parser.ml" +# 22343 "mlx/parser.ml" in let _endpos__1_ = _endpos_me_ in let _endpos = _endpos__1_ in @@ -22304,13 +22348,13 @@ module Tables = struct # 944 "mlx/parser.mly" ( mkmod ~loc:_sloc _1 ) -# 22308 "mlx/parser.ml" +# 22352 "mlx/parser.ml" in # 1486 "mlx/parser.mly" ( _1 ) -# 22314 "mlx/parser.ml" +# 22358 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22344,7 +22388,7 @@ module Tables = struct # 1484 "mlx/parser.mly" ( let (_, arg) = arg_and_pos in Pmod_functor(arg, body) ) -# 22348 "mlx/parser.ml" +# 22392 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_body_, _startpos_arg_and_pos_) in let _endpos = _endpos__1_ in @@ -22353,13 +22397,13 @@ module Tables = struct # 944 "mlx/parser.mly" ( mkmod ~loc:_sloc _1 ) -# 22357 "mlx/parser.ml" +# 22401 "mlx/parser.ml" in # 1486 "mlx/parser.mly" ( _1 ) -# 22363 "mlx/parser.ml" +# 22407 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22391,7 +22435,7 @@ module Tables = struct let _v : (Parsetree.module_type) = # 1729 "mlx/parser.mly" ( mty ) -# 22395 "mlx/parser.ml" +# 22439 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22424,7 +22468,7 @@ module Tables = struct # 1731 "mlx/parser.mly" ( expecting _loc__1_ ":" ) -# 22428 "mlx/parser.ml" +# 22472 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22458,7 +22502,7 @@ module Tables = struct # 1734 "mlx/parser.mly" ( let (_, arg) = arg_and_pos in Pmty_functor(arg, body) ) -# 22462 "mlx/parser.ml" +# 22506 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_body_, _startpos_arg_and_pos_) in let _endpos = _endpos__1_ in @@ -22467,13 +22511,13 @@ module Tables = struct # 946 "mlx/parser.mly" ( mkmty ~loc:_sloc _1 ) -# 22471 "mlx/parser.ml" +# 22515 "mlx/parser.ml" in # 1737 "mlx/parser.mly" ( _1 ) -# 22477 "mlx/parser.ml" +# 22521 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22521,7 +22565,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 22525 "mlx/parser.ml" +# 22569 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -22530,7 +22574,7 @@ module Tables = struct # 1315 "mlx/parser.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_structure s) ) -# 22534 "mlx/parser.ml" +# 22578 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22578,7 +22622,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 22582 "mlx/parser.ml" +# 22626 "mlx/parser.ml" in let _loc__4_ = (_startpos__4_, _endpos__4_) in @@ -22586,7 +22630,7 @@ module Tables = struct # 1317 "mlx/parser.mly" ( unclosed "struct" _loc__1_ "end" _loc__4_ ) -# 22590 "mlx/parser.ml" +# 22634 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22619,7 +22663,7 @@ module Tables = struct # 1319 "mlx/parser.mly" ( expecting _loc__1_ "struct" ) -# 22623 "mlx/parser.ml" +# 22667 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22674,7 +22718,7 @@ module Tables = struct # 1281 "mlx/parser.mly" ( _1 ) -# 22678 "mlx/parser.ml" +# 22722 "mlx/parser.ml" in let attrs = @@ -22682,7 +22726,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 22686 "mlx/parser.ml" +# 22730 "mlx/parser.ml" in let _endpos = _endpos_me_ in @@ -22695,7 +22739,7 @@ module Tables = struct mkmod ~loc:(startpos, _endpos) (Pmod_functor (arg, acc)) ) me args ) ) -# 22699 "mlx/parser.ml" +# 22743 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22720,7 +22764,7 @@ module Tables = struct let _v : (Parsetree.module_expr) = # 1327 "mlx/parser.mly" ( me ) -# 22724 "mlx/parser.ml" +# 22768 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22752,7 +22796,7 @@ module Tables = struct let _v : (Parsetree.module_expr) = # 1329 "mlx/parser.mly" ( Mod.attr me attr ) -# 22756 "mlx/parser.ml" +# 22800 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22783,13 +22827,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 22787 "mlx/parser.ml" +# 22831 "mlx/parser.ml" in # 1333 "mlx/parser.mly" ( Pmod_ident x ) -# 22793 "mlx/parser.ml" +# 22837 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -22798,13 +22842,13 @@ module Tables = struct # 944 "mlx/parser.mly" ( mkmod ~loc:_sloc _1 ) -# 22802 "mlx/parser.ml" +# 22846 "mlx/parser.ml" in # 1344 "mlx/parser.mly" ( _1 ) -# 22808 "mlx/parser.ml" +# 22852 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22837,7 +22881,7 @@ module Tables = struct let _1 = # 1336 "mlx/parser.mly" ( Pmod_apply(me1, me2) ) -# 22841 "mlx/parser.ml" +# 22885 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_me2_, _startpos_me1_) in let _endpos = _endpos__1_ in @@ -22846,13 +22890,13 @@ module Tables = struct # 944 "mlx/parser.mly" ( mkmod ~loc:_sloc _1 ) -# 22850 "mlx/parser.ml" +# 22894 "mlx/parser.ml" in # 1344 "mlx/parser.mly" ( _1 ) -# 22856 "mlx/parser.ml" +# 22900 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22892,7 +22936,7 @@ module Tables = struct let _1 = # 1339 "mlx/parser.mly" ( Pmod_apply_unit me ) -# 22896 "mlx/parser.ml" +# 22940 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_me_) in let _endpos = _endpos__1_ in @@ -22901,13 +22945,13 @@ module Tables = struct # 944 "mlx/parser.mly" ( mkmod ~loc:_sloc _1 ) -# 22905 "mlx/parser.ml" +# 22949 "mlx/parser.ml" in # 1344 "mlx/parser.mly" ( _1 ) -# 22911 "mlx/parser.ml" +# 22955 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22933,7 +22977,7 @@ module Tables = struct let _1 = # 1342 "mlx/parser.mly" ( Pmod_extension ex ) -# 22937 "mlx/parser.ml" +# 22981 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_ex_, _startpos_ex_) in let _endpos = _endpos__1_ in @@ -22942,13 +22986,13 @@ module Tables = struct # 944 "mlx/parser.mly" ( mkmod ~loc:_sloc _1 ) -# 22946 "mlx/parser.ml" +# 22990 "mlx/parser.ml" in # 1344 "mlx/parser.mly" ( _1 ) -# 22952 "mlx/parser.ml" +# 22996 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22969,7 +23013,7 @@ module Tables = struct let x : ( # 767 "mlx/parser.mly" (string) -# 22973 "mlx/parser.ml" +# 23017 "mlx/parser.ml" ) = Obj.magic x in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_x_ in @@ -22977,7 +23021,7 @@ module Tables = struct let _v : (string option) = # 1298 "mlx/parser.mly" ( Some x ) -# 22981 "mlx/parser.ml" +# 23025 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23002,7 +23046,7 @@ module Tables = struct let _v : (string option) = # 1301 "mlx/parser.mly" ( None ) -# 23006 "mlx/parser.ml" +# 23050 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23062,7 +23106,7 @@ module Tables = struct let _1_inlined2 : ( # 767 "mlx/parser.mly" (string) -# 23066 "mlx/parser.ml" +# 23110 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in let ext : (string Location.loc option) = Obj.magic ext in @@ -23075,7 +23119,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 23079 "mlx/parser.ml" +# 23123 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -23087,7 +23131,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 23091 "mlx/parser.ml" +# 23135 "mlx/parser.ml" in let uid = @@ -23098,7 +23142,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 23102 "mlx/parser.ml" +# 23146 "mlx/parser.ml" in let attrs1 = @@ -23106,7 +23150,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 23110 "mlx/parser.ml" +# 23154 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -23120,7 +23164,7 @@ module Tables = struct let docs = symbol_docs _sloc in Ms.mk uid body ~attrs ~loc ~docs, ext ) -# 23124 "mlx/parser.ml" +# 23168 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23173,7 +23217,7 @@ module Tables = struct let _1_inlined2 : ( # 767 "mlx/parser.mly" (string) -# 23177 "mlx/parser.ml" +# 23221 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in let _2 : (string Location.loc option) = Obj.magic _2 in @@ -23189,7 +23233,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 23193 "mlx/parser.ml" +# 23237 "mlx/parser.ml" in let _3 = @@ -23197,14 +23241,14 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 23201 "mlx/parser.ml" +# 23245 "mlx/parser.ml" in let _loc__6_ = (_startpos__6_, _endpos__6_) in # 1774 "mlx/parser.mly" ( expecting _loc__6_ "module path" ) -# 23208 "mlx/parser.ml" +# 23252 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23252,7 +23296,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 23256 "mlx/parser.ml" +# 23300 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -23261,7 +23305,7 @@ module Tables = struct # 1611 "mlx/parser.mly" ( mkmty ~loc:_sloc ~attrs (Pmty_signature s) ) -# 23265 "mlx/parser.ml" +# 23309 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23309,7 +23353,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 23313 "mlx/parser.ml" +# 23357 "mlx/parser.ml" in let _loc__4_ = (_startpos__4_, _endpos__4_) in @@ -23317,7 +23361,7 @@ module Tables = struct # 1613 "mlx/parser.mly" ( unclosed "sig" _loc__1_ "end" _loc__4_ ) -# 23321 "mlx/parser.ml" +# 23365 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23350,7 +23394,7 @@ module Tables = struct # 1615 "mlx/parser.mly" ( expecting _loc__1_ "sig" ) -# 23354 "mlx/parser.ml" +# 23398 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23405,7 +23449,7 @@ module Tables = struct # 1281 "mlx/parser.mly" ( _1 ) -# 23409 "mlx/parser.ml" +# 23453 "mlx/parser.ml" in let attrs = @@ -23413,7 +23457,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 23417 "mlx/parser.ml" +# 23461 "mlx/parser.ml" in let _endpos = _endpos_mty_ in @@ -23426,7 +23470,7 @@ module Tables = struct mkmty ~loc:(startpos, _endpos) (Pmty_functor (arg, acc)) ) mty args ) ) -# 23430 "mlx/parser.ml" +# 23474 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23481,7 +23525,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 23485 "mlx/parser.ml" +# 23529 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -23490,7 +23534,7 @@ module Tables = struct # 1625 "mlx/parser.mly" ( mkmty ~loc:_sloc ~attrs:_4 (Pmty_typeof _5) ) -# 23494 "mlx/parser.ml" +# 23538 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23529,7 +23573,7 @@ module Tables = struct let _v : (Parsetree.module_type) = # 1627 "mlx/parser.mly" ( _2 ) -# 23533 "mlx/parser.ml" +# 23577 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23570,7 +23614,7 @@ module Tables = struct # 1629 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__3_ ) -# 23574 "mlx/parser.ml" +# 23618 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23602,7 +23646,7 @@ module Tables = struct let _v : (Parsetree.module_type) = # 1631 "mlx/parser.mly" ( Mty.attr _1 _2 ) -# 23606 "mlx/parser.ml" +# 23650 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23633,13 +23677,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 23637 "mlx/parser.ml" +# 23681 "mlx/parser.ml" in # 1634 "mlx/parser.mly" ( Pmty_ident _1 ) -# 23643 "mlx/parser.ml" +# 23687 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -23648,13 +23692,13 @@ module Tables = struct # 946 "mlx/parser.mly" ( mkmty ~loc:_sloc _1 ) -# 23652 "mlx/parser.ml" +# 23696 "mlx/parser.ml" in # 1647 "mlx/parser.mly" ( _1 ) -# 23658 "mlx/parser.ml" +# 23702 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23701,7 +23745,7 @@ module Tables = struct let _1 = # 1636 "mlx/parser.mly" ( Pmty_functor(Unit, _4) ) -# 23705 "mlx/parser.ml" +# 23749 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in let _endpos = _endpos__1_ in @@ -23710,13 +23754,13 @@ module Tables = struct # 946 "mlx/parser.mly" ( mkmty ~loc:_sloc _1 ) -# 23714 "mlx/parser.ml" +# 23758 "mlx/parser.ml" in # 1647 "mlx/parser.mly" ( _1 ) -# 23720 "mlx/parser.ml" +# 23764 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23756,7 +23800,7 @@ module Tables = struct let _1 = # 1639 "mlx/parser.mly" ( Pmty_functor(Named (mknoloc None, _1), _3) ) -# 23760 "mlx/parser.ml" +# 23804 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in @@ -23765,13 +23809,13 @@ module Tables = struct # 946 "mlx/parser.mly" ( mkmty ~loc:_sloc _1 ) -# 23769 "mlx/parser.ml" +# 23813 "mlx/parser.ml" in # 1647 "mlx/parser.mly" ( _1 ) -# 23775 "mlx/parser.ml" +# 23819 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23813,18 +23857,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 23817 "mlx/parser.ml" +# 23861 "mlx/parser.ml" in # 1035 "mlx/parser.mly" ( xs ) -# 23822 "mlx/parser.ml" +# 23866 "mlx/parser.ml" in # 1641 "mlx/parser.mly" ( Pmty_with(_1, _3) ) -# 23828 "mlx/parser.ml" +# 23872 "mlx/parser.ml" in let _endpos__1_ = _endpos_xs_ in @@ -23834,13 +23878,13 @@ module Tables = struct # 946 "mlx/parser.mly" ( mkmty ~loc:_sloc _1 ) -# 23838 "mlx/parser.ml" +# 23882 "mlx/parser.ml" in # 1647 "mlx/parser.mly" ( _1 ) -# 23844 "mlx/parser.ml" +# 23888 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23866,7 +23910,7 @@ module Tables = struct let _1 = # 1645 "mlx/parser.mly" ( Pmty_extension _1 ) -# 23870 "mlx/parser.ml" +# 23914 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -23874,13 +23918,13 @@ module Tables = struct # 946 "mlx/parser.mly" ( mkmty ~loc:_sloc _1 ) -# 23878 "mlx/parser.ml" +# 23922 "mlx/parser.ml" in # 1647 "mlx/parser.mly" ( _1 ) -# 23884 "mlx/parser.ml" +# 23928 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23949,7 +23993,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 23953 "mlx/parser.ml" +# 23997 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -23961,7 +24005,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 23965 "mlx/parser.ml" +# 24009 "mlx/parser.ml" in let attrs1 = @@ -23969,7 +24013,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 23973 "mlx/parser.ml" +# 24017 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -23983,7 +24027,7 @@ module Tables = struct let docs = symbol_docs _sloc in Mtd.mk id ?typ ~attrs ~loc ~docs, ext ) -# 23987 "mlx/parser.ml" +# 24031 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24059,7 +24103,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 24063 "mlx/parser.ml" +# 24107 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -24071,7 +24115,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 24075 "mlx/parser.ml" +# 24119 "mlx/parser.ml" in let attrs1 = @@ -24079,7 +24123,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 24083 "mlx/parser.ml" +# 24127 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -24093,7 +24137,7 @@ module Tables = struct let docs = symbol_docs _sloc in Mtd.mk id ~typ ~attrs ~loc ~docs, ext ) -# 24097 "mlx/parser.ml" +# 24141 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24118,7 +24162,7 @@ module Tables = struct let _v : (Longident.t) = # 3700 "mlx/parser.mly" ( _1 ) -# 24122 "mlx/parser.ml" +# 24166 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24136,7 +24180,7 @@ module Tables = struct let _v : (Asttypes.mutable_flag) = # 3781 "mlx/parser.mly" ( Immutable ) -# 24140 "mlx/parser.ml" +# 24184 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24161,7 +24205,7 @@ module Tables = struct let _v : (Asttypes.mutable_flag) = # 3782 "mlx/parser.mly" ( Mutable ) -# 24165 "mlx/parser.ml" +# 24209 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24179,7 +24223,7 @@ module Tables = struct let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = # 3790 "mlx/parser.mly" ( Immutable, Concrete ) -# 24183 "mlx/parser.ml" +# 24227 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24204,7 +24248,7 @@ module Tables = struct let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = # 3792 "mlx/parser.mly" ( Mutable, Concrete ) -# 24208 "mlx/parser.ml" +# 24252 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24229,7 +24273,7 @@ module Tables = struct let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = # 3794 "mlx/parser.mly" ( Immutable, Virtual ) -# 24233 "mlx/parser.ml" +# 24277 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24261,7 +24305,7 @@ module Tables = struct let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = # 3797 "mlx/parser.mly" ( Mutable, Virtual ) -# 24265 "mlx/parser.ml" +# 24309 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24293,7 +24337,7 @@ module Tables = struct let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = # 3797 "mlx/parser.mly" ( Mutable, Virtual ) -# 24297 "mlx/parser.ml" +# 24341 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24325,7 +24369,7 @@ module Tables = struct let _v : (string) = # 3752 "mlx/parser.mly" ( _2 ) -# 24329 "mlx/parser.ml" +# 24373 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24346,7 +24390,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 24350 "mlx/parser.ml" +# 24394 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -24358,13 +24402,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 24362 "mlx/parser.ml" +# 24406 "mlx/parser.ml" in # 221 "" ( [ x ] ) -# 24368 "mlx/parser.ml" +# 24412 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24392,7 +24436,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 24396 "mlx/parser.ml" +# 24440 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -24404,13 +24448,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 24408 "mlx/parser.ml" +# 24452 "mlx/parser.ml" in # 223 "" ( x :: xs ) -# 24414 "mlx/parser.ml" +# 24458 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24431,7 +24475,7 @@ module Tables = struct let s : ( # 754 "mlx/parser.mly" (string * Location.t * string option) -# 24435 "mlx/parser.ml" +# 24479 "mlx/parser.ml" ) = Obj.magic s in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_s_ in @@ -24439,12 +24483,12 @@ module Tables = struct let _v : (string list) = let x = # 3748 "mlx/parser.mly" ( let body, _, _ = s in body ) -# 24443 "mlx/parser.ml" +# 24487 "mlx/parser.ml" in # 221 "" ( [ x ] ) -# 24448 "mlx/parser.ml" +# 24492 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24472,7 +24516,7 @@ module Tables = struct let s : ( # 754 "mlx/parser.mly" (string * Location.t * string option) -# 24476 "mlx/parser.ml" +# 24520 "mlx/parser.ml" ) = Obj.magic s in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_s_ in @@ -24480,12 +24524,12 @@ module Tables = struct let _v : (string list) = let x = # 3748 "mlx/parser.mly" ( let body, _, _ = s in body ) -# 24484 "mlx/parser.ml" +# 24528 "mlx/parser.ml" in # 223 "" ( x :: xs ) -# 24489 "mlx/parser.ml" +# 24533 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24510,12 +24554,12 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3777 "mlx/parser.mly" ( Public ) -# 24514 "mlx/parser.ml" +# 24558 "mlx/parser.ml" in # 3045 "mlx/parser.mly" ( (Ptype_abstract, priv, Some ty) ) -# 24519 "mlx/parser.ml" +# 24563 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24547,12 +24591,12 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3778 "mlx/parser.mly" ( Private ) -# 24551 "mlx/parser.ml" +# 24595 "mlx/parser.ml" in # 3045 "mlx/parser.mly" ( (Ptype_abstract, priv, Some ty) ) -# 24556 "mlx/parser.ml" +# 24600 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24577,24 +24621,24 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3777 "mlx/parser.mly" ( Public ) -# 24581 "mlx/parser.ml" +# 24625 "mlx/parser.ml" in let oty = let _1 = # 124 "" ( None ) -# 24587 "mlx/parser.ml" +# 24631 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 24592 "mlx/parser.ml" +# 24636 "mlx/parser.ml" in # 3049 "mlx/parser.mly" ( (Ptype_variant cs, priv, oty) ) -# 24598 "mlx/parser.ml" +# 24642 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24626,24 +24670,24 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3778 "mlx/parser.mly" ( Private ) -# 24630 "mlx/parser.ml" +# 24674 "mlx/parser.ml" in let oty = let _1 = # 124 "" ( None ) -# 24636 "mlx/parser.ml" +# 24680 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 24641 "mlx/parser.ml" +# 24685 "mlx/parser.ml" in # 3049 "mlx/parser.mly" ( (Ptype_variant cs, priv, oty) ) -# 24647 "mlx/parser.ml" +# 24691 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24682,31 +24726,31 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3777 "mlx/parser.mly" ( Public ) -# 24686 "mlx/parser.ml" +# 24730 "mlx/parser.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24693 "mlx/parser.ml" +# 24737 "mlx/parser.ml" in # 126 "" ( Some x ) -# 24698 "mlx/parser.ml" +# 24742 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 24704 "mlx/parser.ml" +# 24748 "mlx/parser.ml" in # 3049 "mlx/parser.mly" ( (Ptype_variant cs, priv, oty) ) -# 24710 "mlx/parser.ml" +# 24754 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24752,31 +24796,31 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3778 "mlx/parser.mly" ( Private ) -# 24756 "mlx/parser.ml" +# 24800 "mlx/parser.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24763 "mlx/parser.ml" +# 24807 "mlx/parser.ml" in # 126 "" ( Some x ) -# 24768 "mlx/parser.ml" +# 24812 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 24774 "mlx/parser.ml" +# 24818 "mlx/parser.ml" in # 3049 "mlx/parser.mly" ( (Ptype_variant cs, priv, oty) ) -# 24780 "mlx/parser.ml" +# 24824 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24801,24 +24845,24 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3777 "mlx/parser.mly" ( Public ) -# 24805 "mlx/parser.ml" +# 24849 "mlx/parser.ml" in let oty = let _1 = # 124 "" ( None ) -# 24811 "mlx/parser.ml" +# 24855 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 24816 "mlx/parser.ml" +# 24860 "mlx/parser.ml" in # 3053 "mlx/parser.mly" ( (Ptype_open, priv, oty) ) -# 24822 "mlx/parser.ml" +# 24866 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24850,24 +24894,24 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3778 "mlx/parser.mly" ( Private ) -# 24854 "mlx/parser.ml" +# 24898 "mlx/parser.ml" in let oty = let _1 = # 124 "" ( None ) -# 24860 "mlx/parser.ml" +# 24904 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 24865 "mlx/parser.ml" +# 24909 "mlx/parser.ml" in # 3053 "mlx/parser.mly" ( (Ptype_open, priv, oty) ) -# 24871 "mlx/parser.ml" +# 24915 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24906,31 +24950,31 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3777 "mlx/parser.mly" ( Public ) -# 24910 "mlx/parser.ml" +# 24954 "mlx/parser.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24917 "mlx/parser.ml" +# 24961 "mlx/parser.ml" in # 126 "" ( Some x ) -# 24922 "mlx/parser.ml" +# 24966 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 24928 "mlx/parser.ml" +# 24972 "mlx/parser.ml" in # 3053 "mlx/parser.mly" ( (Ptype_open, priv, oty) ) -# 24934 "mlx/parser.ml" +# 24978 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24976,31 +25020,31 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3778 "mlx/parser.mly" ( Private ) -# 24980 "mlx/parser.ml" +# 25024 "mlx/parser.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24987 "mlx/parser.ml" +# 25031 "mlx/parser.ml" in # 126 "" ( Some x ) -# 24992 "mlx/parser.ml" +# 25036 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 24998 "mlx/parser.ml" +# 25042 "mlx/parser.ml" in # 3053 "mlx/parser.mly" ( (Ptype_open, priv, oty) ) -# 25004 "mlx/parser.ml" +# 25048 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25039,24 +25083,24 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3777 "mlx/parser.mly" ( Public ) -# 25043 "mlx/parser.ml" +# 25087 "mlx/parser.ml" in let oty = let _1 = # 124 "" ( None ) -# 25049 "mlx/parser.ml" +# 25093 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 25054 "mlx/parser.ml" +# 25098 "mlx/parser.ml" in # 3057 "mlx/parser.mly" ( (Ptype_record ls, priv, oty) ) -# 25060 "mlx/parser.ml" +# 25104 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25102,24 +25146,24 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3778 "mlx/parser.mly" ( Private ) -# 25106 "mlx/parser.ml" +# 25150 "mlx/parser.ml" in let oty = let _1 = # 124 "" ( None ) -# 25112 "mlx/parser.ml" +# 25156 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 25117 "mlx/parser.ml" +# 25161 "mlx/parser.ml" in # 3057 "mlx/parser.mly" ( (Ptype_record ls, priv, oty) ) -# 25123 "mlx/parser.ml" +# 25167 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25172,31 +25216,31 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3777 "mlx/parser.mly" ( Public ) -# 25176 "mlx/parser.ml" +# 25220 "mlx/parser.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 25183 "mlx/parser.ml" +# 25227 "mlx/parser.ml" in # 126 "" ( Some x ) -# 25188 "mlx/parser.ml" +# 25232 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 25194 "mlx/parser.ml" +# 25238 "mlx/parser.ml" in # 3057 "mlx/parser.mly" ( (Ptype_record ls, priv, oty) ) -# 25200 "mlx/parser.ml" +# 25244 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25256,31 +25300,31 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = # 3778 "mlx/parser.mly" ( Private ) -# 25260 "mlx/parser.ml" +# 25304 "mlx/parser.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 25267 "mlx/parser.ml" +# 25311 "mlx/parser.ml" in # 126 "" ( Some x ) -# 25272 "mlx/parser.ml" +# 25316 "mlx/parser.ml" in # 3061 "mlx/parser.mly" ( _1 ) -# 25278 "mlx/parser.ml" +# 25322 "mlx/parser.ml" in # 3057 "mlx/parser.mly" ( (Ptype_record ls, priv, oty) ) -# 25284 "mlx/parser.ml" +# 25328 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25330,12 +25374,12 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined2_ in - let _v : (Parsetree.open_declaration * string Location.loc option) = let attrs2 = + let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined2 in # 3918 "mlx/parser.mly" ( _1 ) -# 25339 "mlx/parser.ml" +# 25383 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in @@ -25344,13 +25388,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 25348 "mlx/parser.ml" +# 25392 "mlx/parser.ml" in let override = # 3824 "mlx/parser.mly" ( Fresh ) -# 25354 "mlx/parser.ml" +# 25398 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in @@ -25363,7 +25407,7 @@ module Tables = struct let docs = symbol_docs _sloc in Opn.mk me ~override ~attrs ~loc ~docs, ext ) -# 25367 "mlx/parser.ml" +# 25411 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25420,12 +25464,12 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined3_ in - let _v : (Parsetree.open_declaration * string Location.loc option) = let attrs2 = + let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in # 3918 "mlx/parser.mly" ( _1 ) -# 25429 "mlx/parser.ml" +# 25473 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -25434,14 +25478,17 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 25438 "mlx/parser.ml" +# 25482 "mlx/parser.ml" in - let override = + let override = + let _1 = _1_inlined1 in + # 3825 "mlx/parser.mly" ( Override ) -# 25444 "mlx/parser.ml" - in +# 25490 "mlx/parser.ml" + + in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in @@ -25453,7 +25500,7 @@ module Tables = struct let docs = symbol_docs _sloc in Opn.mk me ~override ~attrs ~loc ~docs, ext ) -# 25457 "mlx/parser.ml" +# 25504 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25503,12 +25550,12 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined3_ in - let _v : (Parsetree.open_description * string Location.loc option) = let attrs2 = + let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in # 3918 "mlx/parser.mly" ( _1 ) -# 25512 "mlx/parser.ml" +# 25559 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -25520,7 +25567,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 25524 "mlx/parser.ml" +# 25571 "mlx/parser.ml" in let attrs1 = @@ -25528,13 +25575,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 25532 "mlx/parser.ml" +# 25579 "mlx/parser.ml" in let override = # 3824 "mlx/parser.mly" ( Fresh ) -# 25538 "mlx/parser.ml" +# 25585 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in @@ -25547,7 +25594,7 @@ module Tables = struct let docs = symbol_docs _sloc in Opn.mk id ~override ~attrs ~loc ~docs, ext ) -# 25551 "mlx/parser.ml" +# 25598 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25604,12 +25651,12 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined4_ in - let _v : (Parsetree.open_description * string Location.loc option) = let attrs2 = + let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in # 3918 "mlx/parser.mly" ( _1 ) -# 25613 "mlx/parser.ml" +# 25660 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -25621,7 +25668,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 25625 "mlx/parser.ml" +# 25672 "mlx/parser.ml" in let attrs1 = @@ -25629,14 +25676,17 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 25633 "mlx/parser.ml" +# 25680 "mlx/parser.ml" in - let override = + let override = + let _1 = _1_inlined1 in + # 3825 "mlx/parser.mly" ( Override ) -# 25639 "mlx/parser.ml" - in +# 25688 "mlx/parser.ml" + + in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in @@ -25648,7 +25698,7 @@ module Tables = struct let docs = symbol_docs _sloc in Opn.mk id ~override ~attrs ~loc ~docs, ext ) -# 25652 "mlx/parser.ml" +# 25702 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25669,7 +25719,7 @@ module Tables = struct let _1 : ( # 740 "mlx/parser.mly" (string) -# 25673 "mlx/parser.ml" +# 25723 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -25677,7 +25727,7 @@ module Tables = struct let _v : (string) = # 3598 "mlx/parser.mly" ( _1 ) -# 25681 "mlx/parser.ml" +# 25731 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25698,7 +25748,7 @@ module Tables = struct let _1 : ( # 695 "mlx/parser.mly" (string) -# 25702 "mlx/parser.ml" +# 25752 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -25706,7 +25756,7 @@ module Tables = struct let _v : (string) = # 3599 "mlx/parser.mly" ( _1 ) -# 25710 "mlx/parser.ml" +# 25760 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25727,7 +25777,7 @@ module Tables = struct let _1 : ( # 696 "mlx/parser.mly" (string) -# 25731 "mlx/parser.ml" +# 25781 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -25735,7 +25785,7 @@ module Tables = struct let _v : (string) = # 3600 "mlx/parser.mly" ( _1 ) -# 25739 "mlx/parser.ml" +# 25789 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25777,7 +25827,7 @@ module Tables = struct let _1 : ( # 694 "mlx/parser.mly" (string) -# 25781 "mlx/parser.ml" +# 25831 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -25785,7 +25835,7 @@ module Tables = struct let _v : (string) = # 3601 "mlx/parser.mly" ( "."^ _1 ^"(" ^ _3 ^ ")" ) -# 25789 "mlx/parser.ml" +# 25839 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25834,7 +25884,7 @@ module Tables = struct let _1 : ( # 694 "mlx/parser.mly" (string) -# 25838 "mlx/parser.ml" +# 25888 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -25842,7 +25892,7 @@ module Tables = struct let _v : (string) = # 3602 "mlx/parser.mly" ( "."^ _1 ^ "(" ^ _3 ^ ")<-" ) -# 25846 "mlx/parser.ml" +# 25896 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25884,7 +25934,7 @@ module Tables = struct let _1 : ( # 694 "mlx/parser.mly" (string) -# 25888 "mlx/parser.ml" +# 25938 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -25892,7 +25942,7 @@ module Tables = struct let _v : (string) = # 3603 "mlx/parser.mly" ( "."^ _1 ^"[" ^ _3 ^ "]" ) -# 25896 "mlx/parser.ml" +# 25946 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25941,7 +25991,7 @@ module Tables = struct let _1 : ( # 694 "mlx/parser.mly" (string) -# 25945 "mlx/parser.ml" +# 25995 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -25949,7 +25999,7 @@ module Tables = struct let _v : (string) = # 3604 "mlx/parser.mly" ( "."^ _1 ^ "[" ^ _3 ^ "]<-" ) -# 25953 "mlx/parser.ml" +# 26003 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25991,7 +26041,7 @@ module Tables = struct let _1 : ( # 694 "mlx/parser.mly" (string) -# 25995 "mlx/parser.ml" +# 26045 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -25999,7 +26049,7 @@ module Tables = struct let _v : (string) = # 3605 "mlx/parser.mly" ( "."^ _1 ^"{" ^ _3 ^ "}" ) -# 26003 "mlx/parser.ml" +# 26053 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26048,7 +26098,7 @@ module Tables = struct let _1 : ( # 694 "mlx/parser.mly" (string) -# 26052 "mlx/parser.ml" +# 26102 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -26056,7 +26106,7 @@ module Tables = struct let _v : (string) = # 3606 "mlx/parser.mly" ( "."^ _1 ^ "{" ^ _3 ^ "}<-" ) -# 26060 "mlx/parser.ml" +# 26110 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26077,7 +26127,7 @@ module Tables = struct let _1 : ( # 751 "mlx/parser.mly" (string) -# 26081 "mlx/parser.ml" +# 26131 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -26085,7 +26135,7 @@ module Tables = struct let _v : (string) = # 3607 "mlx/parser.mly" ( _1 ) -# 26089 "mlx/parser.ml" +# 26139 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26110,7 +26160,7 @@ module Tables = struct let _v : (string) = # 3608 "mlx/parser.mly" ( "!" ) -# 26114 "mlx/parser.ml" +# 26164 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26131,7 +26181,7 @@ module Tables = struct let op : ( # 689 "mlx/parser.mly" (string) -# 26135 "mlx/parser.ml" +# 26185 "mlx/parser.ml" ) = Obj.magic op in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_op_ in @@ -26139,12 +26189,12 @@ module Tables = struct let _v : (string) = let _1 = # 3612 "mlx/parser.mly" ( op ) -# 26143 "mlx/parser.ml" +# 26193 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26148 "mlx/parser.ml" +# 26198 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26165,7 +26215,7 @@ module Tables = struct let op : ( # 690 "mlx/parser.mly" (string) -# 26169 "mlx/parser.ml" +# 26219 "mlx/parser.ml" ) = Obj.magic op in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_op_ in @@ -26173,12 +26223,12 @@ module Tables = struct let _v : (string) = let _1 = # 3613 "mlx/parser.mly" ( op ) -# 26177 "mlx/parser.ml" +# 26227 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26182 "mlx/parser.ml" +# 26232 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26199,7 +26249,7 @@ module Tables = struct let op : ( # 691 "mlx/parser.mly" (string) -# 26203 "mlx/parser.ml" +# 26253 "mlx/parser.ml" ) = Obj.magic op in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_op_ in @@ -26207,12 +26257,12 @@ module Tables = struct let _v : (string) = let _1 = # 3614 "mlx/parser.mly" ( op ) -# 26211 "mlx/parser.ml" +# 26261 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26216 "mlx/parser.ml" +# 26266 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26233,7 +26283,7 @@ module Tables = struct let op : ( # 692 "mlx/parser.mly" (string) -# 26237 "mlx/parser.ml" +# 26287 "mlx/parser.ml" ) = Obj.magic op in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_op_ in @@ -26241,12 +26291,12 @@ module Tables = struct let _v : (string) = let _1 = # 3615 "mlx/parser.mly" ( op ) -# 26245 "mlx/parser.ml" +# 26295 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26250 "mlx/parser.ml" +# 26300 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26267,7 +26317,7 @@ module Tables = struct let op : ( # 693 "mlx/parser.mly" (string) -# 26271 "mlx/parser.ml" +# 26321 "mlx/parser.ml" ) = Obj.magic op in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_op_ in @@ -26275,12 +26325,12 @@ module Tables = struct let _v : (string) = let _1 = # 3616 "mlx/parser.mly" ( op ) -# 26279 "mlx/parser.ml" +# 26329 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26284 "mlx/parser.ml" +# 26334 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26305,12 +26355,12 @@ module Tables = struct let _v : (string) = let _1 = # 3617 "mlx/parser.mly" ("+") -# 26309 "mlx/parser.ml" +# 26359 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26314 "mlx/parser.ml" +# 26364 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26335,12 +26385,12 @@ module Tables = struct let _v : (string) = let _1 = # 3618 "mlx/parser.mly" ("+.") -# 26339 "mlx/parser.ml" +# 26389 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26344 "mlx/parser.ml" +# 26394 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26365,12 +26415,12 @@ module Tables = struct let _v : (string) = let _1 = # 3619 "mlx/parser.mly" ("+=") -# 26369 "mlx/parser.ml" +# 26419 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26374 "mlx/parser.ml" +# 26424 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26395,12 +26445,12 @@ module Tables = struct let _v : (string) = let _1 = # 3620 "mlx/parser.mly" ("-") -# 26399 "mlx/parser.ml" +# 26449 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26404 "mlx/parser.ml" +# 26454 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26425,12 +26475,12 @@ module Tables = struct let _v : (string) = let _1 = # 3621 "mlx/parser.mly" ("-.") -# 26429 "mlx/parser.ml" +# 26479 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26434 "mlx/parser.ml" +# 26484 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26455,12 +26505,12 @@ module Tables = struct let _v : (string) = let _1 = # 3622 "mlx/parser.mly" ("*") -# 26459 "mlx/parser.ml" +# 26509 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26464 "mlx/parser.ml" +# 26514 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26485,12 +26535,12 @@ module Tables = struct let _v : (string) = let _1 = # 3623 "mlx/parser.mly" ("%") -# 26489 "mlx/parser.ml" +# 26539 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26494 "mlx/parser.ml" +# 26544 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26515,12 +26565,12 @@ module Tables = struct let _v : (string) = let _1 = # 3624 "mlx/parser.mly" ("=") -# 26519 "mlx/parser.ml" +# 26569 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26524 "mlx/parser.ml" +# 26574 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26545,12 +26595,12 @@ module Tables = struct let _v : (string) = let _1 = # 3625 "mlx/parser.mly" ("<") -# 26549 "mlx/parser.ml" +# 26599 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26554 "mlx/parser.ml" +# 26604 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26575,12 +26625,12 @@ module Tables = struct let _v : (string) = let _1 = # 3626 "mlx/parser.mly" (">") -# 26579 "mlx/parser.ml" +# 26629 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26584 "mlx/parser.ml" +# 26634 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26605,12 +26655,12 @@ module Tables = struct let _v : (string) = let _1 = # 3627 "mlx/parser.mly" ("or") -# 26609 "mlx/parser.ml" +# 26659 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26614 "mlx/parser.ml" +# 26664 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26635,12 +26685,12 @@ module Tables = struct let _v : (string) = let _1 = # 3628 "mlx/parser.mly" ("||") -# 26639 "mlx/parser.ml" +# 26689 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26644 "mlx/parser.ml" +# 26694 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26665,12 +26715,12 @@ module Tables = struct let _v : (string) = let _1 = # 3629 "mlx/parser.mly" ("&") -# 26669 "mlx/parser.ml" +# 26719 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26674 "mlx/parser.ml" +# 26724 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26695,12 +26745,12 @@ module Tables = struct let _v : (string) = let _1 = # 3630 "mlx/parser.mly" ("&&") -# 26699 "mlx/parser.ml" +# 26749 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26704 "mlx/parser.ml" +# 26754 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26725,12 +26775,12 @@ module Tables = struct let _v : (string) = let _1 = # 3631 "mlx/parser.mly" (":=") -# 26729 "mlx/parser.ml" +# 26779 "mlx/parser.ml" in # 3609 "mlx/parser.mly" ( _1 ) -# 26734 "mlx/parser.ml" +# 26784 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26755,7 +26805,7 @@ module Tables = struct let _v : (bool) = # 3513 "mlx/parser.mly" ( true ) -# 26759 "mlx/parser.ml" +# 26809 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26773,7 +26823,7 @@ module Tables = struct let _v : (bool) = # 3514 "mlx/parser.mly" ( false ) -# 26777 "mlx/parser.ml" +# 26827 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26791,7 +26841,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26795 "mlx/parser.ml" +# 26845 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26816,7 +26866,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26820 "mlx/parser.ml" +# 26870 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26834,7 +26884,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26838 "mlx/parser.ml" +# 26888 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26859,7 +26909,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26863 "mlx/parser.ml" +# 26913 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26877,7 +26927,7 @@ module Tables = struct let _v : (string Location.loc option) = # 114 "" ( None ) -# 26881 "mlx/parser.ml" +# 26931 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26904,7 +26954,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 26908 "mlx/parser.ml" +# 26958 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -26919,19 +26969,19 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 26923 "mlx/parser.ml" +# 26973 "mlx/parser.ml" in # 183 "" ( x ) -# 26929 "mlx/parser.ml" +# 26979 "mlx/parser.ml" in # 116 "" ( Some x ) -# 26935 "mlx/parser.ml" +# 26985 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26949,7 +26999,7 @@ module Tables = struct let _v : (Parsetree.core_type option) = # 114 "" ( None ) -# 26953 "mlx/parser.ml" +# 27003 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26981,12 +27031,12 @@ module Tables = struct let _v : (Parsetree.core_type option) = let x = # 183 "" ( x ) -# 26985 "mlx/parser.ml" +# 27035 "mlx/parser.ml" in # 116 "" ( Some x ) -# 26990 "mlx/parser.ml" +# 27040 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27004,7 +27054,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 27008 "mlx/parser.ml" +# 27058 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27036,12 +27086,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 27040 "mlx/parser.ml" +# 27090 "mlx/parser.ml" in # 116 "" ( Some x ) -# 27045 "mlx/parser.ml" +# 27095 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27059,7 +27109,7 @@ module Tables = struct let _v : (Parsetree.module_type option) = # 114 "" ( None ) -# 27063 "mlx/parser.ml" +# 27113 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27091,12 +27141,12 @@ module Tables = struct let _v : (Parsetree.module_type option) = let x = # 183 "" ( x ) -# 27095 "mlx/parser.ml" +# 27145 "mlx/parser.ml" in # 116 "" ( Some x ) -# 27100 "mlx/parser.ml" +# 27150 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27114,7 +27164,7 @@ module Tables = struct let _v : (Parsetree.pattern option) = # 114 "" ( None ) -# 27118 "mlx/parser.ml" +# 27168 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27146,12 +27196,12 @@ module Tables = struct let _v : (Parsetree.pattern option) = let x = # 183 "" ( x ) -# 27150 "mlx/parser.ml" +# 27200 "mlx/parser.ml" in # 116 "" ( Some x ) -# 27155 "mlx/parser.ml" +# 27205 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27169,7 +27219,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 27173 "mlx/parser.ml" +# 27223 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27201,12 +27251,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 27205 "mlx/parser.ml" +# 27255 "mlx/parser.ml" in # 116 "" ( Some x ) -# 27210 "mlx/parser.ml" +# 27260 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27224,7 +27274,7 @@ module Tables = struct let _v : ((Parsetree.core_type option * Parsetree.core_type option) option) = # 114 "" ( None ) -# 27228 "mlx/parser.ml" +# 27278 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27249,7 +27299,7 @@ module Tables = struct let _v : ((Parsetree.core_type option * Parsetree.core_type option) option) = # 116 "" ( Some x ) -# 27253 "mlx/parser.ml" +# 27303 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27270,7 +27320,7 @@ module Tables = struct let _1 : ( # 733 "mlx/parser.mly" (string) -# 27274 "mlx/parser.ml" +# 27324 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -27278,7 +27328,7 @@ module Tables = struct let _v : (string) = # 3836 "mlx/parser.mly" ( _1 ) -# 27282 "mlx/parser.ml" +# 27332 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27312,7 +27362,7 @@ module Tables = struct let _2 : ( # 714 "mlx/parser.mly" (string) -# 27316 "mlx/parser.ml" +# 27366 "mlx/parser.ml" ) = Obj.magic _2 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -27321,7 +27371,7 @@ module Tables = struct let _v : (string) = # 3837 "mlx/parser.mly" ( _2 ) -# 27325 "mlx/parser.ml" +# 27375 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27377,7 +27427,7 @@ module Tables = struct # 1353 "mlx/parser.mly" ( mkmod ~loc:_sloc (Pmod_constraint(me, mty)) ) -# 27381 "mlx/parser.ml" +# 27431 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27432,7 +27482,7 @@ module Tables = struct # 1355 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__5_ ) -# 27436 "mlx/parser.ml" +# 27486 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27471,7 +27521,7 @@ module Tables = struct let _v : (Parsetree.module_expr) = # 1358 "mlx/parser.mly" ( me (* TODO consider reloc *) ) -# 27475 "mlx/parser.ml" +# 27525 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27512,7 +27562,7 @@ module Tables = struct # 1360 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__3_ ) -# 27516 "mlx/parser.ml" +# 27566 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27565,14 +27615,14 @@ module Tables = struct let _v : (Parsetree.module_expr) = let e = # 1377 "mlx/parser.mly" ( e ) -# 27569 "mlx/parser.ml" +# 27619 "mlx/parser.ml" in let attrs = let _1 = _1_inlined1 in # 3922 "mlx/parser.mly" ( _1 ) -# 27576 "mlx/parser.ml" +# 27626 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -27581,7 +27631,7 @@ module Tables = struct # 1364 "mlx/parser.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27585 "mlx/parser.ml" +# 27635 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27646,7 +27696,7 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.module_expr) = let e = - let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in + let (_endpos__1_, _startpos__1_, _1, _2) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2, _2_inlined1) in let ty = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -27656,7 +27706,7 @@ module Tables = struct ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 27660 "mlx/parser.ml" +# 27710 "mlx/parser.ml" in let _endpos_ty_ = _endpos__1_ in @@ -27666,7 +27716,7 @@ module Tables = struct # 1379 "mlx/parser.mly" ( ghexp ~loc:_loc (Pexp_constraint (e, ty)) ) -# 27670 "mlx/parser.ml" +# 27720 "mlx/parser.ml" in let attrs = @@ -27674,7 +27724,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 27678 "mlx/parser.ml" +# 27728 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -27683,7 +27733,7 @@ module Tables = struct # 1364 "mlx/parser.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27687 "mlx/parser.ml" +# 27737 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27762,7 +27812,7 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.module_expr) = let e = - let (_endpos__1_inlined1_, _startpos__1_inlined1_, _endpos__1_, _startpos__1_, _1_inlined1, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined3, _1_inlined2) in + let (_endpos__1_inlined1_, _startpos__1_inlined1_, _endpos__1_, _startpos__1_, _1_inlined1, _1, _2) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined3, _1_inlined2, _2_inlined1) in let ty2 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _endpos = _endpos__1_ in @@ -27773,7 +27823,7 @@ module Tables = struct ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 27777 "mlx/parser.ml" +# 27827 "mlx/parser.ml" in let _endpos_ty2_ = _endpos__1_inlined1_ in @@ -27786,7 +27836,7 @@ module Tables = struct ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 27790 "mlx/parser.ml" +# 27840 "mlx/parser.ml" in let _endpos = _endpos_ty2_ in @@ -27795,7 +27845,7 @@ module Tables = struct # 1381 "mlx/parser.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, Some ty1, ty2)) ) -# 27799 "mlx/parser.ml" +# 27849 "mlx/parser.ml" in let attrs = @@ -27803,7 +27853,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 27807 "mlx/parser.ml" +# 27857 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -27812,7 +27862,7 @@ module Tables = struct # 1364 "mlx/parser.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27816 "mlx/parser.ml" +# 27866 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27877,7 +27927,7 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.module_expr) = let e = - let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in + let (_endpos__1_, _startpos__1_, _1, _2) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2, _2_inlined1) in let ty2 = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -27887,7 +27937,7 @@ module Tables = struct ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 27891 "mlx/parser.ml" +# 27941 "mlx/parser.ml" in let _endpos_ty2_ = _endpos__1_ in @@ -27897,7 +27947,7 @@ module Tables = struct # 1383 "mlx/parser.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, None, ty2)) ) -# 27901 "mlx/parser.ml" +# 27951 "mlx/parser.ml" in let attrs = @@ -27905,7 +27955,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 27909 "mlx/parser.ml" +# 27959 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -27914,7 +27964,7 @@ module Tables = struct # 1364 "mlx/parser.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27918 "mlx/parser.ml" +# 27968 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27976,7 +28026,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 27980 "mlx/parser.ml" +# 28030 "mlx/parser.ml" in let _loc__6_ = (_startpos__6_, _endpos__6_) in @@ -27984,7 +28034,7 @@ module Tables = struct # 1366 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__6_ ) -# 27988 "mlx/parser.ml" +# 28038 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28046,7 +28096,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 28050 "mlx/parser.ml" +# 28100 "mlx/parser.ml" in let _loc__6_ = (_startpos__6_, _endpos__6_) in @@ -28054,7 +28104,7 @@ module Tables = struct # 1368 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__6_ ) -# 28058 "mlx/parser.ml" +# 28108 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28109,7 +28159,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 28113 "mlx/parser.ml" +# 28163 "mlx/parser.ml" in let _loc__5_ = (_startpos__5_, _endpos__5_) in @@ -28117,7 +28167,7 @@ module Tables = struct # 1370 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__5_ ) -# 28121 "mlx/parser.ml" +# 28171 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28149,7 +28199,7 @@ module Tables = struct let _v : (Longident.t) = # 1271 "mlx/parser.mly" ( _1 ) -# 28153 "mlx/parser.ml" +# 28203 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28181,7 +28231,7 @@ module Tables = struct let _v : (Longident.t) = # 1256 "mlx/parser.mly" ( _1 ) -# 28185 "mlx/parser.ml" +# 28235 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28213,7 +28263,7 @@ module Tables = struct let _v : (Parsetree.core_type) = # 1231 "mlx/parser.mly" ( _1 ) -# 28217 "mlx/parser.ml" +# 28267 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28245,7 +28295,7 @@ module Tables = struct let _v : (Parsetree.expression) = # 1236 "mlx/parser.mly" ( _1 ) -# 28249 "mlx/parser.ml" +# 28299 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28277,7 +28327,7 @@ module Tables = struct let _v : (Longident.t) = # 1261 "mlx/parser.mly" ( _1 ) -# 28281 "mlx/parser.ml" +# 28331 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28309,7 +28359,7 @@ module Tables = struct let _v : (Longident.t) = # 1266 "mlx/parser.mly" ( _1 ) -# 28313 "mlx/parser.ml" +# 28363 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28341,7 +28391,7 @@ module Tables = struct let _v : (Parsetree.module_expr) = # 1226 "mlx/parser.mly" ( _1 ) -# 28345 "mlx/parser.ml" +# 28395 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28373,7 +28423,7 @@ module Tables = struct let _v : (Parsetree.module_type) = # 1221 "mlx/parser.mly" ( _1 ) -# 28377 "mlx/parser.ml" +# 28427 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28405,7 +28455,7 @@ module Tables = struct let _v : (Longident.t) = # 1246 "mlx/parser.mly" ( _1 ) -# 28409 "mlx/parser.ml" +# 28459 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28437,7 +28487,7 @@ module Tables = struct let _v : (Parsetree.pattern) = # 1241 "mlx/parser.mly" ( _1 ) -# 28441 "mlx/parser.ml" +# 28491 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28469,7 +28519,7 @@ module Tables = struct let _v : (Longident.t) = # 1251 "mlx/parser.mly" ( _1 ) -# 28473 "mlx/parser.ml" +# 28523 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28513,13 +28563,13 @@ module Tables = struct # 2774 "mlx/parser.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 28517 "mlx/parser.ml" +# 28567 "mlx/parser.ml" in # 2762 "mlx/parser.mly" ( _1 ) -# 28523 "mlx/parser.ml" +# 28573 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28551,12 +28601,12 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = # 2776 "mlx/parser.mly" ( Pat.attr _1 _2 ) -# 28555 "mlx/parser.ml" +# 28605 "mlx/parser.ml" in # 2762 "mlx/parser.mly" ( _1 ) -# 28560 "mlx/parser.ml" +# 28610 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28581,12 +28631,12 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = # 2778 "mlx/parser.mly" ( _1 ) -# 28585 "mlx/parser.ml" +# 28635 "mlx/parser.ml" in # 2762 "mlx/parser.mly" ( _1 ) -# 28590 "mlx/parser.ml" +# 28640 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28633,13 +28683,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 28637 "mlx/parser.ml" +# 28687 "mlx/parser.ml" in # 2781 "mlx/parser.mly" ( Ppat_alias(_1, _3) ) -# 28643 "mlx/parser.ml" +# 28693 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -28649,19 +28699,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 28653 "mlx/parser.ml" +# 28703 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 28659 "mlx/parser.ml" +# 28709 "mlx/parser.ml" in # 2762 "mlx/parser.mly" ( _1 ) -# 28665 "mlx/parser.ml" +# 28715 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28704,7 +28754,7 @@ module Tables = struct # 2783 "mlx/parser.mly" ( expecting _loc__3_ "identifier" ) -# 28708 "mlx/parser.ml" +# 28758 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -28714,19 +28764,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 28718 "mlx/parser.ml" +# 28768 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 28724 "mlx/parser.ml" +# 28774 "mlx/parser.ml" in # 2762 "mlx/parser.mly" ( _1 ) -# 28730 "mlx/parser.ml" +# 28780 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28753,7 +28803,7 @@ module Tables = struct let _1 = # 2785 "mlx/parser.mly" ( Ppat_tuple(List.rev _1) ) -# 28757 "mlx/parser.ml" +# 28807 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -28761,19 +28811,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 28765 "mlx/parser.ml" +# 28815 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 28771 "mlx/parser.ml" +# 28821 "mlx/parser.ml" in # 2762 "mlx/parser.mly" ( _1 ) -# 28777 "mlx/parser.ml" +# 28827 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28816,7 +28866,7 @@ module Tables = struct # 2787 "mlx/parser.mly" ( expecting _loc__3_ "pattern" ) -# 28820 "mlx/parser.ml" +# 28870 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -28826,19 +28876,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 28830 "mlx/parser.ml" +# 28880 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 28836 "mlx/parser.ml" +# 28886 "mlx/parser.ml" in # 2762 "mlx/parser.mly" ( _1 ) -# 28842 "mlx/parser.ml" +# 28892 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28879,7 +28929,7 @@ module Tables = struct let _1 = # 2789 "mlx/parser.mly" ( Ppat_or(_1, _3) ) -# 28883 "mlx/parser.ml" +# 28933 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in @@ -28888,19 +28938,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 28892 "mlx/parser.ml" +# 28942 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 28898 "mlx/parser.ml" +# 28948 "mlx/parser.ml" in # 2762 "mlx/parser.mly" ( _1 ) -# 28904 "mlx/parser.ml" +# 28954 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28943,7 +28993,7 @@ module Tables = struct # 2791 "mlx/parser.mly" ( expecting _loc__3_ "pattern" ) -# 28947 "mlx/parser.ml" +# 28997 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -28953,19 +29003,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 28957 "mlx/parser.ml" +# 29007 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 28963 "mlx/parser.ml" +# 29013 "mlx/parser.ml" in # 2762 "mlx/parser.mly" ( _1 ) -# 28969 "mlx/parser.ml" +# 29019 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29015,13 +29065,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 29019 "mlx/parser.ml" +# 29069 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 29025 "mlx/parser.ml" +# 29075 "mlx/parser.ml" in let _endpos = _endpos__3_ in @@ -29030,7 +29080,7 @@ module Tables = struct # 2764 "mlx/parser.mly" ( mkpat_attrs ~loc:_sloc (Ppat_exception _3) _2) -# 29034 "mlx/parser.ml" +# 29084 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29069,7 +29119,7 @@ module Tables = struct let _v : (Parsetree.pattern list) = # 2891 "mlx/parser.mly" ( _3 :: _1 ) -# 29073 "mlx/parser.ml" +# 29123 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29108,7 +29158,7 @@ module Tables = struct let _v : (Parsetree.pattern list) = # 2892 "mlx/parser.mly" ( [_3; _1] ) -# 29112 "mlx/parser.ml" +# 29162 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29148,7 +29198,7 @@ module Tables = struct # 2893 "mlx/parser.mly" ( expecting _loc__3_ "pattern" ) -# 29152 "mlx/parser.ml" +# 29202 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29187,7 +29237,7 @@ module Tables = struct let _v : (Parsetree.pattern list) = # 2891 "mlx/parser.mly" ( _3 :: _1 ) -# 29191 "mlx/parser.ml" +# 29241 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29226,7 +29276,7 @@ module Tables = struct let _v : (Parsetree.pattern list) = # 2892 "mlx/parser.mly" ( [_3; _1] ) -# 29230 "mlx/parser.ml" +# 29280 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29266,7 +29316,7 @@ module Tables = struct # 2893 "mlx/parser.mly" ( expecting _loc__3_ "pattern" ) -# 29270 "mlx/parser.ml" +# 29320 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29291,7 +29341,7 @@ module Tables = struct let _v : (Parsetree.pattern) = # 2797 "mlx/parser.mly" ( _1 ) -# 29295 "mlx/parser.ml" +# 29345 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29329,13 +29379,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 29333 "mlx/parser.ml" +# 29383 "mlx/parser.ml" in # 2800 "mlx/parser.mly" ( Ppat_construct(_1, Some ([], _2)) ) -# 29339 "mlx/parser.ml" +# 29389 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in @@ -29345,13 +29395,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 29349 "mlx/parser.ml" +# 29399 "mlx/parser.ml" in # 2806 "mlx/parser.mly" ( _1 ) -# 29355 "mlx/parser.ml" +# 29405 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29413,7 +29463,7 @@ module Tables = struct let newtypes = # 2549 "mlx/parser.mly" ( xs ) -# 29417 "mlx/parser.ml" +# 29467 "mlx/parser.ml" in let constr = let _endpos = _endpos__1_ in @@ -29422,13 +29472,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 29426 "mlx/parser.ml" +# 29476 "mlx/parser.ml" in # 2803 "mlx/parser.mly" ( Ppat_construct(constr, Some (newtypes, pat)) ) -# 29432 "mlx/parser.ml" +# 29482 "mlx/parser.ml" in let _endpos__1_ = _endpos_pat_ in @@ -29438,13 +29488,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 29442 "mlx/parser.ml" +# 29492 "mlx/parser.ml" in # 2806 "mlx/parser.mly" ( _1 ) -# 29448 "mlx/parser.ml" +# 29498 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29477,7 +29527,7 @@ module Tables = struct let _1 = # 2805 "mlx/parser.mly" ( Ppat_variant(_1, Some _2) ) -# 29481 "mlx/parser.ml" +# 29531 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in @@ -29486,13 +29536,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 29490 "mlx/parser.ml" +# 29540 "mlx/parser.ml" in # 2806 "mlx/parser.mly" ( _1 ) -# 29496 "mlx/parser.ml" +# 29546 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29542,13 +29592,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 29546 "mlx/parser.ml" +# 29596 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 29552 "mlx/parser.ml" +# 29602 "mlx/parser.ml" in let _endpos = _endpos__3_ in @@ -29557,7 +29607,7 @@ module Tables = struct # 2808 "mlx/parser.mly" ( mkpat_attrs ~loc:_sloc (Ppat_lazy _3) _2) -# 29561 "mlx/parser.ml" +# 29611 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29601,13 +29651,13 @@ module Tables = struct # 2774 "mlx/parser.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 29605 "mlx/parser.ml" +# 29655 "mlx/parser.ml" in # 2769 "mlx/parser.mly" ( _1 ) -# 29611 "mlx/parser.ml" +# 29661 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29639,12 +29689,12 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = # 2776 "mlx/parser.mly" ( Pat.attr _1 _2 ) -# 29643 "mlx/parser.ml" +# 29693 "mlx/parser.ml" in # 2769 "mlx/parser.mly" ( _1 ) -# 29648 "mlx/parser.ml" +# 29698 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29669,12 +29719,12 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = # 2778 "mlx/parser.mly" ( _1 ) -# 29673 "mlx/parser.ml" +# 29723 "mlx/parser.ml" in # 2769 "mlx/parser.mly" ( _1 ) -# 29678 "mlx/parser.ml" +# 29728 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29721,13 +29771,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 29725 "mlx/parser.ml" +# 29775 "mlx/parser.ml" in # 2781 "mlx/parser.mly" ( Ppat_alias(_1, _3) ) -# 29731 "mlx/parser.ml" +# 29781 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -29737,19 +29787,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 29741 "mlx/parser.ml" +# 29791 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 29747 "mlx/parser.ml" +# 29797 "mlx/parser.ml" in # 2769 "mlx/parser.mly" ( _1 ) -# 29753 "mlx/parser.ml" +# 29803 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29792,7 +29842,7 @@ module Tables = struct # 2783 "mlx/parser.mly" ( expecting _loc__3_ "identifier" ) -# 29796 "mlx/parser.ml" +# 29846 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -29802,19 +29852,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 29806 "mlx/parser.ml" +# 29856 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 29812 "mlx/parser.ml" +# 29862 "mlx/parser.ml" in # 2769 "mlx/parser.mly" ( _1 ) -# 29818 "mlx/parser.ml" +# 29868 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29841,7 +29891,7 @@ module Tables = struct let _1 = # 2785 "mlx/parser.mly" ( Ppat_tuple(List.rev _1) ) -# 29845 "mlx/parser.ml" +# 29895 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -29849,19 +29899,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 29853 "mlx/parser.ml" +# 29903 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 29859 "mlx/parser.ml" +# 29909 "mlx/parser.ml" in # 2769 "mlx/parser.mly" ( _1 ) -# 29865 "mlx/parser.ml" +# 29915 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29904,7 +29954,7 @@ module Tables = struct # 2787 "mlx/parser.mly" ( expecting _loc__3_ "pattern" ) -# 29908 "mlx/parser.ml" +# 29958 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -29914,19 +29964,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 29918 "mlx/parser.ml" +# 29968 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 29924 "mlx/parser.ml" +# 29974 "mlx/parser.ml" in # 2769 "mlx/parser.mly" ( _1 ) -# 29930 "mlx/parser.ml" +# 29980 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29967,7 +30017,7 @@ module Tables = struct let _1 = # 2789 "mlx/parser.mly" ( Ppat_or(_1, _3) ) -# 29971 "mlx/parser.ml" +# 30021 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in @@ -29976,19 +30026,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 29980 "mlx/parser.ml" +# 30030 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 29986 "mlx/parser.ml" +# 30036 "mlx/parser.ml" in # 2769 "mlx/parser.mly" ( _1 ) -# 29992 "mlx/parser.ml" +# 30042 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30031,7 +30081,7 @@ module Tables = struct # 2791 "mlx/parser.mly" ( expecting _loc__3_ "pattern" ) -# 30035 "mlx/parser.ml" +# 30085 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -30041,19 +30091,19 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 30045 "mlx/parser.ml" +# 30095 "mlx/parser.ml" in # 2792 "mlx/parser.mly" ( _1 ) -# 30051 "mlx/parser.ml" +# 30101 "mlx/parser.ml" in # 2769 "mlx/parser.mly" ( _1 ) -# 30057 "mlx/parser.ml" +# 30107 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30074,7 +30124,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 30078 "mlx/parser.ml" +# 30128 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -30088,13 +30138,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 30092 "mlx/parser.ml" +# 30142 "mlx/parser.ml" in # 2237 "mlx/parser.mly" ( Ppat_var _1 ) -# 30098 "mlx/parser.ml" +# 30148 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -30103,13 +30153,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 30107 "mlx/parser.ml" +# 30157 "mlx/parser.ml" in # 2239 "mlx/parser.mly" ( _1 ) -# 30113 "mlx/parser.ml" +# 30163 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30135,7 +30185,7 @@ module Tables = struct let _1 = # 2238 "mlx/parser.mly" ( Ppat_any ) -# 30139 "mlx/parser.ml" +# 30189 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -30143,13 +30193,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 30147 "mlx/parser.ml" +# 30197 "mlx/parser.ml" in # 2239 "mlx/parser.mly" ( _1 ) -# 30153 "mlx/parser.ml" +# 30203 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30174,7 +30224,7 @@ module Tables = struct let _v : (Parsetree.payload) = # 3948 "mlx/parser.mly" ( PStr _1 ) -# 30178 "mlx/parser.ml" +# 30228 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30206,7 +30256,7 @@ module Tables = struct let _v : (Parsetree.payload) = # 3949 "mlx/parser.mly" ( PSig _2 ) -# 30210 "mlx/parser.ml" +# 30260 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30238,7 +30288,7 @@ module Tables = struct let _v : (Parsetree.payload) = # 3950 "mlx/parser.mly" ( PTyp _2 ) -# 30242 "mlx/parser.ml" +# 30292 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30270,7 +30320,7 @@ module Tables = struct let _v : (Parsetree.payload) = # 3951 "mlx/parser.mly" ( PPat (_2, None) ) -# 30274 "mlx/parser.ml" +# 30324 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30316,7 +30366,7 @@ module Tables = struct let _v : (Parsetree.payload) = # 3952 "mlx/parser.mly" ( PPat (_2, Some _4) ) -# 30320 "mlx/parser.ml" +# 30370 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30341,7 +30391,7 @@ module Tables = struct let _v : (Parsetree.core_type) = # 3327 "mlx/parser.mly" ( _1 ) -# 30345 "mlx/parser.ml" +# 30395 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30384,24 +30434,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 30388 "mlx/parser.ml" +# 30438 "mlx/parser.ml" in # 1003 "mlx/parser.mly" ( xs ) -# 30393 "mlx/parser.ml" +# 30443 "mlx/parser.ml" in # 3319 "mlx/parser.mly" ( _1 ) -# 30399 "mlx/parser.ml" +# 30449 "mlx/parser.ml" in # 3323 "mlx/parser.mly" ( Ptyp_poly(_1, _3) ) -# 30405 "mlx/parser.ml" +# 30455 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_xs_) in @@ -30411,13 +30461,13 @@ module Tables = struct # 938 "mlx/parser.mly" ( mktyp ~loc:_sloc _1 ) -# 30415 "mlx/parser.ml" +# 30465 "mlx/parser.ml" in # 3329 "mlx/parser.mly" ( _1 ) -# 30421 "mlx/parser.ml" +# 30471 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30442,12 +30492,12 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = # 3358 "mlx/parser.mly" ( _1 ) -# 30446 "mlx/parser.ml" +# 30496 "mlx/parser.ml" in # 3327 "mlx/parser.mly" ( _1 ) -# 30451 "mlx/parser.ml" +# 30501 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30488,31 +30538,31 @@ module Tables = struct let _3 = # 3358 "mlx/parser.mly" ( _1 ) -# 30492 "mlx/parser.ml" +# 30542 "mlx/parser.ml" in let _1 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 30499 "mlx/parser.ml" +# 30549 "mlx/parser.ml" in # 1003 "mlx/parser.mly" ( xs ) -# 30504 "mlx/parser.ml" +# 30554 "mlx/parser.ml" in # 3319 "mlx/parser.mly" ( _1 ) -# 30510 "mlx/parser.ml" +# 30560 "mlx/parser.ml" in # 3323 "mlx/parser.mly" ( Ptyp_poly(_1, _3) ) -# 30516 "mlx/parser.ml" +# 30566 "mlx/parser.ml" in let _startpos__1_ = _startpos_xs_ in @@ -30522,13 +30572,13 @@ module Tables = struct # 938 "mlx/parser.mly" ( mktyp ~loc:_sloc _1 ) -# 30526 "mlx/parser.ml" +# 30576 "mlx/parser.ml" in # 3329 "mlx/parser.mly" ( _1 ) -# 30532 "mlx/parser.ml" +# 30582 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30577,7 +30627,7 @@ module Tables = struct # 3909 "mlx/parser.mly" ( Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 30581 "mlx/parser.ml" +# 30631 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30660,7 +30710,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 30664 "mlx/parser.ml" +# 30714 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -30672,7 +30722,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 30676 "mlx/parser.ml" +# 30726 "mlx/parser.ml" in let attrs1 = @@ -30680,7 +30730,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 30684 "mlx/parser.ml" +# 30734 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -30693,7 +30743,7 @@ module Tables = struct let docs = symbol_docs _sloc in Val.mk id ty ~prim ~attrs ~loc ~docs, ext ) -# 30697 "mlx/parser.ml" +# 30747 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30711,12 +30761,12 @@ module Tables = struct let _v : (Asttypes.private_flag) = let _1 = # 3777 "mlx/parser.mly" ( Public ) -# 30715 "mlx/parser.ml" +# 30765 "mlx/parser.ml" in # 3774 "mlx/parser.mly" ( _1 ) -# 30720 "mlx/parser.ml" +# 30770 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30741,12 +30791,12 @@ module Tables = struct let _v : (Asttypes.private_flag) = let _1 = # 3778 "mlx/parser.mly" ( Private ) -# 30745 "mlx/parser.ml" +# 30795 "mlx/parser.ml" in # 3774 "mlx/parser.mly" ( _1 ) -# 30750 "mlx/parser.ml" +# 30800 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30764,7 +30814,7 @@ module Tables = struct let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = # 3800 "mlx/parser.mly" ( Public, Concrete ) -# 30768 "mlx/parser.ml" +# 30818 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30789,7 +30839,7 @@ module Tables = struct let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = # 3801 "mlx/parser.mly" ( Private, Concrete ) -# 30793 "mlx/parser.ml" +# 30843 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30814,7 +30864,7 @@ module Tables = struct let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = # 3802 "mlx/parser.mly" ( Public, Virtual ) -# 30818 "mlx/parser.ml" +# 30868 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30846,7 +30896,7 @@ module Tables = struct let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = # 3803 "mlx/parser.mly" ( Private, Virtual ) -# 30850 "mlx/parser.ml" +# 30900 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30878,7 +30928,7 @@ module Tables = struct let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = # 3804 "mlx/parser.mly" ( Private, Virtual ) -# 30882 "mlx/parser.ml" +# 30932 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30896,7 +30946,7 @@ module Tables = struct let _v : (Asttypes.rec_flag) = # 3755 "mlx/parser.mly" ( Nonrecursive ) -# 30900 "mlx/parser.ml" +# 30950 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30921,7 +30971,7 @@ module Tables = struct let _v : (Asttypes.rec_flag) = # 3756 "mlx/parser.mly" ( Recursive ) -# 30925 "mlx/parser.ml" +# 30975 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30947,12 +30997,12 @@ module Tables = struct (Longident.t Location.loc * Parsetree.expression) list) = let eo = # 124 "" ( None ) -# 30951 "mlx/parser.ml" +# 31001 "mlx/parser.ml" in # 2694 "mlx/parser.mly" ( eo, fields ) -# 30956 "mlx/parser.ml" +# 31006 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30993,18 +31043,18 @@ module Tables = struct let x = # 191 "" ( x ) -# 30997 "mlx/parser.ml" +# 31047 "mlx/parser.ml" in # 126 "" ( Some x ) -# 31002 "mlx/parser.ml" +# 31052 "mlx/parser.ml" in # 2694 "mlx/parser.mly" ( eo, fields ) -# 31008 "mlx/parser.ml" +# 31058 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31022,9 +31072,9 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = Obj.magic d in + let d : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in @@ -31034,12 +31084,12 @@ module Tables = struct let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 31038 "mlx/parser.ml" +# 31088 "mlx/parser.ml" in # 1113 "mlx/parser.mly" ( [x] ) -# 31043 "mlx/parser.ml" +# 31093 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31057,9 +31107,9 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = Obj.magic d in + let d : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in @@ -31069,12 +31119,12 @@ module Tables = struct let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 31073 "mlx/parser.ml" +# 31123 "mlx/parser.ml" in # 1116 "mlx/parser.mly" ( [x] ) -# 31078 "mlx/parser.ml" +# 31128 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31098,9 +31148,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; }; } = _menhir_stack in - let d : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = Obj.magic d in + let d : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = Obj.magic d in let xs : (Parsetree.constructor_declaration list) = Obj.magic xs in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_xs_ in @@ -31111,12 +31161,12 @@ module Tables = struct let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 31115 "mlx/parser.ml" +# 31165 "mlx/parser.ml" in # 1120 "mlx/parser.mly" ( x :: xs ) -# 31120 "mlx/parser.ml" +# 31170 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31134,9 +31184,9 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = Obj.magic d in + let d : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in @@ -31147,18 +31197,18 @@ module Tables = struct let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 31151 "mlx/parser.ml" +# 31201 "mlx/parser.ml" in # 3251 "mlx/parser.mly" ( _1 ) -# 31156 "mlx/parser.ml" +# 31206 "mlx/parser.ml" in # 1113 "mlx/parser.mly" ( [x] ) -# 31162 "mlx/parser.ml" +# 31212 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31183,12 +31233,12 @@ module Tables = struct let _v : (Parsetree.extension_constructor list) = let x = # 3253 "mlx/parser.mly" ( _1 ) -# 31187 "mlx/parser.ml" +# 31237 "mlx/parser.ml" in # 1113 "mlx/parser.mly" ( [x] ) -# 31192 "mlx/parser.ml" +# 31242 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31206,9 +31256,9 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = Obj.magic d in + let d : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in @@ -31219,18 +31269,18 @@ module Tables = struct let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 31223 "mlx/parser.ml" +# 31273 "mlx/parser.ml" in # 3251 "mlx/parser.mly" ( _1 ) -# 31228 "mlx/parser.ml" +# 31278 "mlx/parser.ml" in # 1116 "mlx/parser.mly" ( [x] ) -# 31234 "mlx/parser.ml" +# 31284 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31255,12 +31305,12 @@ module Tables = struct let _v : (Parsetree.extension_constructor list) = let x = # 3253 "mlx/parser.mly" ( _1 ) -# 31259 "mlx/parser.ml" +# 31309 "mlx/parser.ml" in # 1116 "mlx/parser.mly" ( [x] ) -# 31264 "mlx/parser.ml" +# 31314 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31284,9 +31334,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; }; } = _menhir_stack in - let d : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = Obj.magic d in + let d : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = Obj.magic d in let xs : (Parsetree.extension_constructor list) = Obj.magic xs in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_xs_ in @@ -31298,18 +31348,18 @@ module Tables = struct let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 31302 "mlx/parser.ml" +# 31352 "mlx/parser.ml" in # 3251 "mlx/parser.mly" ( _1 ) -# 31307 "mlx/parser.ml" +# 31357 "mlx/parser.ml" in # 1120 "mlx/parser.mly" ( x :: xs ) -# 31313 "mlx/parser.ml" +# 31363 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31341,12 +31391,12 @@ module Tables = struct let _v : (Parsetree.extension_constructor list) = let x = # 3253 "mlx/parser.mly" ( _1 ) -# 31345 "mlx/parser.ml" +# 31395 "mlx/parser.ml" in # 1120 "mlx/parser.mly" ( x :: xs ) -# 31350 "mlx/parser.ml" +# 31400 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31364,9 +31414,9 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = Obj.magic d in + let d : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in @@ -31376,12 +31426,12 @@ module Tables = struct let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 31380 "mlx/parser.ml" +# 31430 "mlx/parser.ml" in # 1113 "mlx/parser.mly" ( [x] ) -# 31385 "mlx/parser.ml" +# 31435 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31399,9 +31449,9 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = Obj.magic d in + let d : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in @@ -31411,12 +31461,12 @@ module Tables = struct let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 31415 "mlx/parser.ml" +# 31465 "mlx/parser.ml" in # 1116 "mlx/parser.mly" ( [x] ) -# 31420 "mlx/parser.ml" +# 31470 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31440,9 +31490,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; }; } = _menhir_stack in - let d : (Ast_helper.str * Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option * Parsetree.attributes * Warnings.loc * - Docstrings.info) = Obj.magic d in + let d : (Dune__exe__Ast_helper.str * Dune__exe__Ast_helper.str list * + Parsetree.constructor_arguments * Parsetree.core_type option * + Parsetree.attributes * Warnings.loc * Dune__exe__Docstrings.info) = Obj.magic d in let xs : (Parsetree.extension_constructor list) = Obj.magic xs in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_xs_ in @@ -31453,12 +31503,12 @@ module Tables = struct let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 31457 "mlx/parser.ml" +# 31507 "mlx/parser.ml" in # 1120 "mlx/parser.mly" ( x :: xs ) -# 31462 "mlx/parser.ml" +# 31512 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31481,7 +31531,7 @@ module Tables = struct list) = # 979 "mlx/parser.mly" ( [] ) -# 31485 "mlx/parser.ml" +# 31535 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31527,7 +31577,7 @@ module Tables = struct list) = # 981 "mlx/parser.mly" ( x :: xs ) -# 31531 "mlx/parser.ml" +# 31581 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31545,7 +31595,7 @@ module Tables = struct let _v : ((Parsetree.core_type * Parsetree.core_type * Warnings.loc) list) = # 979 "mlx/parser.mly" ( [] ) -# 31549 "mlx/parser.ml" +# 31599 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31604,19 +31654,19 @@ module Tables = struct # 2117 "mlx/parser.mly" ( _1, _3, make_loc _sloc ) -# 31608 "mlx/parser.ml" +# 31658 "mlx/parser.ml" in # 183 "" ( x ) -# 31614 "mlx/parser.ml" +# 31664 "mlx/parser.ml" in # 981 "mlx/parser.mly" ( x :: xs ) -# 31620 "mlx/parser.ml" +# 31670 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31634,7 +31684,7 @@ module Tables = struct let _v : (Parsetree.expression list) = # 979 "mlx/parser.mly" ( [] ) -# 31638 "mlx/parser.ml" +# 31688 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31666,7 +31716,7 @@ module Tables = struct let _v : (Parsetree.expression list) = # 981 "mlx/parser.mly" ( x :: xs ) -# 31670 "mlx/parser.ml" +# 31720 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31691,7 +31741,7 @@ module Tables = struct let _v : ((Lexing.position * Parsetree.functor_parameter) list) = # 993 "mlx/parser.mly" ( [ x ] ) -# 31695 "mlx/parser.ml" +# 31745 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31723,7 +31773,7 @@ module Tables = struct let _v : ((Lexing.position * Parsetree.functor_parameter) list) = # 995 "mlx/parser.mly" ( x :: xs ) -# 31727 "mlx/parser.ml" +# 31777 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31748,7 +31798,7 @@ module Tables = struct let _v : ((Asttypes.arg_label * Parsetree.expression) list) = # 993 "mlx/parser.mly" ( [ x ] ) -# 31752 "mlx/parser.ml" +# 31802 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31780,7 +31830,7 @@ module Tables = struct let _v : ((Asttypes.arg_label * Parsetree.expression) list) = # 995 "mlx/parser.mly" ( x :: xs ) -# 31784 "mlx/parser.ml" +# 31834 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31805,7 +31855,7 @@ module Tables = struct let _v : (string list) = # 993 "mlx/parser.mly" ( [ x ] ) -# 31809 "mlx/parser.ml" +# 31859 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31837,7 +31887,7 @@ module Tables = struct let _v : (string list) = # 995 "mlx/parser.mly" ( x :: xs ) -# 31841 "mlx/parser.ml" +# 31891 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31875,19 +31925,19 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 31879 "mlx/parser.ml" +# 31929 "mlx/parser.ml" in # 3315 "mlx/parser.mly" ( _2 ) -# 31885 "mlx/parser.ml" +# 31935 "mlx/parser.ml" in # 993 "mlx/parser.mly" ( [ x ] ) -# 31891 "mlx/parser.ml" +# 31941 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31932,19 +31982,19 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 31936 "mlx/parser.ml" +# 31986 "mlx/parser.ml" in # 3315 "mlx/parser.mly" ( _2 ) -# 31942 "mlx/parser.ml" +# 31992 "mlx/parser.ml" in # 995 "mlx/parser.mly" ( x :: xs ) -# 31948 "mlx/parser.ml" +# 31998 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31969,12 +32019,12 @@ module Tables = struct let _v : (Parsetree.case list) = let _1 = # 124 "" ( None ) -# 31973 "mlx/parser.ml" +# 32023 "mlx/parser.ml" in # 1084 "mlx/parser.mly" ( [x] ) -# 31978 "mlx/parser.ml" +# 32028 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32008,13 +32058,13 @@ module Tables = struct # 126 "" ( Some x ) -# 32012 "mlx/parser.ml" +# 32062 "mlx/parser.ml" in # 1084 "mlx/parser.mly" ( [x] ) -# 32018 "mlx/parser.ml" +# 32068 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32053,7 +32103,7 @@ module Tables = struct let _v : (Parsetree.case list) = # 1088 "mlx/parser.mly" ( x :: xs ) -# 32057 "mlx/parser.ml" +# 32107 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32079,18 +32129,18 @@ module Tables = struct let x = # 3358 "mlx/parser.mly" ( _1 ) -# 32083 "mlx/parser.ml" +# 32133 "mlx/parser.ml" in # 1019 "mlx/parser.mly" ( [ x ] ) -# 32088 "mlx/parser.ml" +# 32138 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32094 "mlx/parser.ml" +# 32144 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32130,18 +32180,18 @@ module Tables = struct let x = # 3358 "mlx/parser.mly" ( _1 ) -# 32134 "mlx/parser.ml" +# 32184 "mlx/parser.ml" in # 1023 "mlx/parser.mly" ( x :: xs ) -# 32139 "mlx/parser.ml" +# 32189 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32145 "mlx/parser.ml" +# 32195 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32166,12 +32216,12 @@ module Tables = struct let _v : (Parsetree.with_constraint list) = let xs = # 1019 "mlx/parser.mly" ( [ x ] ) -# 32170 "mlx/parser.ml" +# 32220 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32175 "mlx/parser.ml" +# 32225 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32210,12 +32260,12 @@ module Tables = struct let _v : (Parsetree.with_constraint list) = let xs = # 1023 "mlx/parser.mly" ( x :: xs ) -# 32214 "mlx/parser.ml" +# 32264 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32219 "mlx/parser.ml" +# 32269 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32240,12 +32290,12 @@ module Tables = struct let _v : (Parsetree.row_field list) = let xs = # 1019 "mlx/parser.mly" ( [ x ] ) -# 32244 "mlx/parser.ml" +# 32294 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32249 "mlx/parser.ml" +# 32299 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32284,12 +32334,12 @@ module Tables = struct let _v : (Parsetree.row_field list) = let xs = # 1023 "mlx/parser.mly" ( x :: xs ) -# 32288 "mlx/parser.ml" +# 32338 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32293 "mlx/parser.ml" +# 32343 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32314,12 +32364,12 @@ module Tables = struct let _v : (Parsetree.core_type list) = let xs = # 1019 "mlx/parser.mly" ( [ x ] ) -# 32318 "mlx/parser.ml" +# 32368 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32323 "mlx/parser.ml" +# 32373 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32358,12 +32408,12 @@ module Tables = struct let _v : (Parsetree.core_type list) = let xs = # 1023 "mlx/parser.mly" ( x :: xs ) -# 32362 "mlx/parser.ml" +# 32412 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32367 "mlx/parser.ml" +# 32417 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32388,12 +32438,12 @@ module Tables = struct let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = # 1019 "mlx/parser.mly" ( [ x ] ) -# 32392 "mlx/parser.ml" +# 32442 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32397 "mlx/parser.ml" +# 32447 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32432,12 +32482,12 @@ module Tables = struct let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = # 1023 "mlx/parser.mly" ( x :: xs ) -# 32436 "mlx/parser.ml" +# 32486 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32441 "mlx/parser.ml" +# 32491 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32462,12 +32512,12 @@ module Tables = struct let _v : (Parsetree.core_type list) = let xs = # 1019 "mlx/parser.mly" ( [ x ] ) -# 32466 "mlx/parser.ml" +# 32516 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32471 "mlx/parser.ml" +# 32521 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32506,12 +32556,12 @@ module Tables = struct let _v : (Parsetree.core_type list) = let xs = # 1023 "mlx/parser.mly" ( x :: xs ) -# 32510 "mlx/parser.ml" +# 32560 "mlx/parser.ml" in # 1027 "mlx/parser.mly" ( xs ) -# 32515 "mlx/parser.ml" +# 32565 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32550,7 +32600,7 @@ module Tables = struct let _v : (Parsetree.core_type list) = # 1050 "mlx/parser.mly" ( x :: xs ) -# 32554 "mlx/parser.ml" +# 32604 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32589,7 +32639,7 @@ module Tables = struct let _v : (Parsetree.core_type list) = # 1054 "mlx/parser.mly" ( [ x2; x1 ] ) -# 32593 "mlx/parser.ml" +# 32643 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32628,7 +32678,7 @@ module Tables = struct let _v : (Parsetree.expression list) = # 1050 "mlx/parser.mly" ( x :: xs ) -# 32632 "mlx/parser.ml" +# 32682 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32667,7 +32717,7 @@ module Tables = struct let _v : (Parsetree.expression list) = # 1054 "mlx/parser.mly" ( [ x2; x1 ] ) -# 32671 "mlx/parser.ml" +# 32721 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32706,7 +32756,7 @@ module Tables = struct let _v : (Parsetree.core_type list) = # 1050 "mlx/parser.mly" ( x :: xs ) -# 32710 "mlx/parser.ml" +# 32760 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32745,7 +32795,7 @@ module Tables = struct let _v : (Parsetree.core_type list) = # 1054 "mlx/parser.mly" ( [ x2; x1 ] ) -# 32749 "mlx/parser.ml" +# 32799 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32770,7 +32820,7 @@ module Tables = struct let _v : (Parsetree.row_field) = # 3498 "mlx/parser.mly" ( _1 ) -# 32774 "mlx/parser.ml" +# 32824 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32798,7 +32848,7 @@ module Tables = struct # 3500 "mlx/parser.mly" ( Rf.inherit_ ~loc:(make_loc _sloc) _1 ) -# 32802 "mlx/parser.ml" +# 32852 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32823,12 +32873,12 @@ module Tables = struct let _v : (Parsetree.expression list) = let _2 = # 124 "" ( None ) -# 32827 "mlx/parser.ml" +# 32877 "mlx/parser.ml" in # 1071 "mlx/parser.mly" ( [x] ) -# 32832 "mlx/parser.ml" +# 32882 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32862,13 +32912,13 @@ module Tables = struct # 126 "" ( Some x ) -# 32866 "mlx/parser.ml" +# 32916 "mlx/parser.ml" in # 1071 "mlx/parser.mly" ( [x] ) -# 32872 "mlx/parser.ml" +# 32922 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32907,7 +32957,7 @@ module Tables = struct let _v : (Parsetree.expression list) = # 1075 "mlx/parser.mly" ( x :: xs ) -# 32911 "mlx/parser.ml" +# 32961 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32935,7 +32985,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 32939 "mlx/parser.ml" +# 32989 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -32943,14 +32993,14 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 32947 "mlx/parser.ml" +# 32997 "mlx/parser.ml" in let x = let label = let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 32954 "mlx/parser.ml" +# 33004 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -32958,7 +33008,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 32962 "mlx/parser.ml" +# 33012 "mlx/parser.ml" in @@ -32972,13 +33022,13 @@ module Tables = struct label, e in label, e ) -# 32976 "mlx/parser.ml" +# 33026 "mlx/parser.ml" in # 1071 "mlx/parser.mly" ( [x] ) -# 32982 "mlx/parser.ml" +# 33032 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33013,7 +33063,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 33017 "mlx/parser.ml" +# 33067 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -33021,14 +33071,14 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 33025 "mlx/parser.ml" +# 33075 "mlx/parser.ml" in let x = let label = let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 33032 "mlx/parser.ml" +# 33082 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -33036,7 +33086,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 33040 "mlx/parser.ml" +# 33090 "mlx/parser.ml" in @@ -33050,13 +33100,13 @@ module Tables = struct label, e in label, e ) -# 33054 "mlx/parser.ml" +# 33104 "mlx/parser.ml" in # 1071 "mlx/parser.mly" ( [x] ) -# 33060 "mlx/parser.ml" +# 33110 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33098,7 +33148,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 33102 "mlx/parser.ml" +# 33152 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -33108,7 +33158,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 33112 "mlx/parser.ml" +# 33162 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -33116,7 +33166,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 33120 "mlx/parser.ml" +# 33170 "mlx/parser.ml" in @@ -33130,13 +33180,13 @@ module Tables = struct label, e in label, e ) -# 33134 "mlx/parser.ml" +# 33184 "mlx/parser.ml" in # 1075 "mlx/parser.mly" ( x :: xs ) -# 33140 "mlx/parser.ml" +# 33190 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33161,12 +33211,12 @@ module Tables = struct let _v : (Parsetree.pattern list) = let _2 = # 124 "" ( None ) -# 33165 "mlx/parser.ml" +# 33215 "mlx/parser.ml" in # 1071 "mlx/parser.mly" ( [x] ) -# 33170 "mlx/parser.ml" +# 33220 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33200,13 +33250,13 @@ module Tables = struct # 126 "" ( Some x ) -# 33204 "mlx/parser.ml" +# 33254 "mlx/parser.ml" in # 1071 "mlx/parser.mly" ( [x] ) -# 33210 "mlx/parser.ml" +# 33260 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33245,7 +33295,7 @@ module Tables = struct let _v : (Parsetree.pattern list) = # 1075 "mlx/parser.mly" ( x :: xs ) -# 33249 "mlx/parser.ml" +# 33299 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33284,7 +33334,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 33288 "mlx/parser.ml" +# 33338 "mlx/parser.ml" in let x = let label = @@ -33294,7 +33344,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 33298 "mlx/parser.ml" +# 33348 "mlx/parser.ml" in let _startpos_label_ = _startpos__1_ in @@ -33312,13 +33362,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 33316 "mlx/parser.ml" +# 33366 "mlx/parser.ml" in # 1071 "mlx/parser.mly" ( [x] ) -# 33322 "mlx/parser.ml" +# 33372 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33364,7 +33414,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 33368 "mlx/parser.ml" +# 33418 "mlx/parser.ml" in let x = let label = @@ -33374,7 +33424,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 33378 "mlx/parser.ml" +# 33428 "mlx/parser.ml" in let _startpos_label_ = _startpos__1_ in @@ -33392,13 +33442,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 33396 "mlx/parser.ml" +# 33446 "mlx/parser.ml" in # 1071 "mlx/parser.mly" ( [x] ) -# 33402 "mlx/parser.ml" +# 33452 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33456,7 +33506,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 33460 "mlx/parser.ml" +# 33510 "mlx/parser.ml" in let _startpos_label_ = _startpos__1_ in @@ -33474,13 +33524,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 33478 "mlx/parser.ml" +# 33528 "mlx/parser.ml" in # 1075 "mlx/parser.mly" ( x :: xs ) -# 33484 "mlx/parser.ml" +# 33534 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33505,7 +33555,7 @@ module Tables = struct let _v : (Parsetree.expression) = # 2206 "mlx/parser.mly" ( _1 ) -# 33509 "mlx/parser.ml" +# 33559 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33537,7 +33587,7 @@ module Tables = struct let _v : (Parsetree.expression) = # 2207 "mlx/parser.mly" ( _1 ) -# 33541 "mlx/parser.ml" +# 33591 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33577,7 +33627,7 @@ module Tables = struct let _1 = # 2209 "mlx/parser.mly" ( Pexp_sequence(_1, _3) ) -# 33581 "mlx/parser.ml" +# 33631 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in @@ -33586,13 +33636,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 33590 "mlx/parser.ml" +# 33640 "mlx/parser.ml" in # 2210 "mlx/parser.mly" ( _1 ) -# 33596 "mlx/parser.ml" +# 33646 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33650,7 +33700,7 @@ module Tables = struct ( let seq = mkexp ~loc:_sloc (Pexp_sequence (_1, _5)) in let payload = PStr [mkstrexp seq []] in mkexp ~loc:_sloc (Pexp_extension (_4, payload)) ) -# 33654 "mlx/parser.ml" +# 33704 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33706,7 +33756,7 @@ module Tables = struct } = _menhir_stack in let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in - let vars_args_res : (Ast_helper.str list * Parsetree.constructor_arguments * + let vars_args_res : (Dune__exe__Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic vars_args_res in let _1_inlined2 : (string) = Obj.magic _1_inlined2 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -33720,7 +33770,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 33724 "mlx/parser.ml" +# 33774 "mlx/parser.ml" in let _endpos_attrs_ = _endpos__1_inlined4_ in @@ -33729,7 +33779,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 33733 "mlx/parser.ml" +# 33783 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -33741,7 +33791,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 33745 "mlx/parser.ml" +# 33795 "mlx/parser.ml" in let attrs1 = @@ -33749,7 +33799,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 33753 "mlx/parser.ml" +# 33803 "mlx/parser.ml" in let _endpos = _endpos_attrs_ in @@ -33764,7 +33814,7 @@ module Tables = struct Te.mk_exception ~attrs (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) , ext ) -# 33768 "mlx/parser.ml" +# 33818 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33790,7 +33840,7 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 33794 "mlx/parser.ml" +# 33844 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in let _endpos = _endpos__1_ in @@ -33798,13 +33848,13 @@ module Tables = struct # 894 "mlx/parser.mly" ( extra_sig _startpos _endpos _1 ) -# 33802 "mlx/parser.ml" +# 33852 "mlx/parser.ml" in # 1653 "mlx/parser.mly" ( _1 ) -# 33808 "mlx/parser.ml" +# 33858 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33838,7 +33888,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 33842 "mlx/parser.ml" +# 33892 "mlx/parser.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -33849,7 +33899,7 @@ module Tables = struct # 1668 "mlx/parser.mly" ( let docs = symbol_docs _sloc in mksig ~loc:_sloc (Psig_extension (_1, (add_docs_attrs docs _2))) ) -# 33853 "mlx/parser.ml" +# 33903 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33875,7 +33925,7 @@ module Tables = struct let _1 = # 1672 "mlx/parser.mly" ( Psig_attribute _1 ) -# 33879 "mlx/parser.ml" +# 33929 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -33883,13 +33933,13 @@ module Tables = struct # 942 "mlx/parser.mly" ( mksig ~loc:_sloc _1 ) -# 33887 "mlx/parser.ml" +# 33937 "mlx/parser.ml" in # 1674 "mlx/parser.mly" ( _1 ) -# 33893 "mlx/parser.ml" +# 33943 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33915,7 +33965,7 @@ module Tables = struct let _1 = # 1677 "mlx/parser.mly" ( psig_value _1 ) -# 33919 "mlx/parser.ml" +# 33969 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -33923,13 +33973,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33927 "mlx/parser.ml" +# 33977 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 33933 "mlx/parser.ml" +# 33983 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33955,7 +34005,7 @@ module Tables = struct let _1 = # 1679 "mlx/parser.mly" ( psig_value _1 ) -# 33959 "mlx/parser.ml" +# 34009 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -33963,13 +34013,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33967 "mlx/parser.ml" +# 34017 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 33973 "mlx/parser.ml" +# 34023 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34006,24 +34056,24 @@ module Tables = struct let _1 = # 1132 "mlx/parser.mly" ( let (x, b) = a in x, b :: bs ) -# 34010 "mlx/parser.ml" +# 34060 "mlx/parser.ml" in # 2991 "mlx/parser.mly" ( _1 ) -# 34015 "mlx/parser.ml" +# 34065 "mlx/parser.ml" in # 2974 "mlx/parser.mly" ( _1 ) -# 34021 "mlx/parser.ml" +# 34071 "mlx/parser.ml" in # 1681 "mlx/parser.mly" ( psig_type _1 ) -# 34027 "mlx/parser.ml" +# 34077 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -34033,13 +34083,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34037 "mlx/parser.ml" +# 34087 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 34043 "mlx/parser.ml" +# 34093 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34076,24 +34126,24 @@ module Tables = struct let _1 = # 1132 "mlx/parser.mly" ( let (x, b) = a in x, b :: bs ) -# 34080 "mlx/parser.ml" +# 34130 "mlx/parser.ml" in # 2991 "mlx/parser.mly" ( _1 ) -# 34085 "mlx/parser.ml" +# 34135 "mlx/parser.ml" in # 2979 "mlx/parser.mly" ( _1 ) -# 34091 "mlx/parser.ml" +# 34141 "mlx/parser.ml" in # 1683 "mlx/parser.mly" ( psig_typesubst _1 ) -# 34097 "mlx/parser.ml" +# 34147 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -34103,13 +34153,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34107 "mlx/parser.ml" +# 34157 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 34113 "mlx/parser.ml" +# 34163 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34196,14 +34246,14 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 34200 "mlx/parser.ml" +# 34250 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = # 1124 "mlx/parser.mly" ( List.rev xs ) -# 34207 "mlx/parser.ml" +# 34257 "mlx/parser.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -34213,20 +34263,20 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 34217 "mlx/parser.ml" +# 34267 "mlx/parser.ml" in let _4 = # 3763 "mlx/parser.mly" ( Recursive ) -# 34223 "mlx/parser.ml" +# 34273 "mlx/parser.ml" in let attrs1 = let _1 = _1_inlined1 in # 3922 "mlx/parser.mly" ( _1 ) -# 34230 "mlx/parser.ml" +# 34280 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -34238,19 +34288,19 @@ module Tables = struct let attrs = attrs1 @ attrs2 in Te.mk tid cs ~params ~priv ~attrs ~docs, ext ) -# 34242 "mlx/parser.ml" +# 34292 "mlx/parser.ml" in # 3231 "mlx/parser.mly" ( _1 ) -# 34248 "mlx/parser.ml" +# 34298 "mlx/parser.ml" in # 1685 "mlx/parser.mly" ( psig_typext _1 ) -# 34254 "mlx/parser.ml" +# 34304 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -34260,13 +34310,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34264 "mlx/parser.ml" +# 34314 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 34270 "mlx/parser.ml" +# 34320 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34360,14 +34410,14 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 34364 "mlx/parser.ml" +# 34414 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = # 1124 "mlx/parser.mly" ( List.rev xs ) -# 34371 "mlx/parser.ml" +# 34421 "mlx/parser.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -34377,18 +34427,18 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 34381 "mlx/parser.ml" +# 34431 "mlx/parser.ml" in let _4 = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos__1_inlined2_) in + let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in # 3765 "mlx/parser.mly" ( not_expecting _loc "nonrec flag" ) -# 34392 "mlx/parser.ml" +# 34442 "mlx/parser.ml" in let attrs1 = @@ -34396,7 +34446,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 34400 "mlx/parser.ml" +# 34450 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -34408,19 +34458,19 @@ module Tables = struct let attrs = attrs1 @ attrs2 in Te.mk tid cs ~params ~priv ~attrs ~docs, ext ) -# 34412 "mlx/parser.ml" +# 34462 "mlx/parser.ml" in # 3231 "mlx/parser.mly" ( _1 ) -# 34418 "mlx/parser.ml" +# 34468 "mlx/parser.ml" in # 1685 "mlx/parser.mly" ( psig_typext _1 ) -# 34424 "mlx/parser.ml" +# 34474 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -34430,13 +34480,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34434 "mlx/parser.ml" +# 34484 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 34440 "mlx/parser.ml" +# 34490 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34462,7 +34512,7 @@ module Tables = struct let _1 = # 1687 "mlx/parser.mly" ( psig_exception _1 ) -# 34466 "mlx/parser.ml" +# 34516 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -34470,13 +34520,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34474 "mlx/parser.ml" +# 34524 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 34480 "mlx/parser.ml" +# 34530 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34541,7 +34591,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 34545 "mlx/parser.ml" +# 34595 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -34553,7 +34603,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 34557 "mlx/parser.ml" +# 34607 "mlx/parser.ml" in let attrs1 = @@ -34561,7 +34611,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 34565 "mlx/parser.ml" +# 34615 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -34575,13 +34625,13 @@ module Tables = struct let docs = symbol_docs _sloc in Md.mk name body ~attrs ~loc ~docs, ext ) -# 34579 "mlx/parser.ml" +# 34629 "mlx/parser.ml" in # 1689 "mlx/parser.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 34585 "mlx/parser.ml" +# 34635 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -34591,13 +34641,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34595 "mlx/parser.ml" +# 34645 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 34601 "mlx/parser.ml" +# 34651 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34669,7 +34719,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 34673 "mlx/parser.ml" +# 34723 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -34682,7 +34732,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 34686 "mlx/parser.ml" +# 34736 "mlx/parser.ml" in let (_endpos_id_, _startpos_id_) = (_endpos__1_, _startpos__1_) in @@ -34692,7 +34742,7 @@ module Tables = struct # 1757 "mlx/parser.mly" ( Mty.alias ~loc:(make_loc _sloc) id ) -# 34696 "mlx/parser.ml" +# 34746 "mlx/parser.ml" in let name = @@ -34703,7 +34753,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 34707 "mlx/parser.ml" +# 34757 "mlx/parser.ml" in let attrs1 = @@ -34711,7 +34761,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 34715 "mlx/parser.ml" +# 34765 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -34725,13 +34775,13 @@ module Tables = struct let docs = symbol_docs _sloc in Md.mk name body ~attrs ~loc ~docs, ext ) -# 34729 "mlx/parser.ml" +# 34779 "mlx/parser.ml" in # 1691 "mlx/parser.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 34735 "mlx/parser.ml" +# 34785 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -34741,13 +34791,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34745 "mlx/parser.ml" +# 34795 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 34751 "mlx/parser.ml" +# 34801 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34773,7 +34823,7 @@ module Tables = struct let _1 = # 1693 "mlx/parser.mly" ( let (body, ext) = _1 in (Psig_modsubst body, ext) ) -# 34777 "mlx/parser.ml" +# 34827 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -34781,13 +34831,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34785 "mlx/parser.ml" +# 34835 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 34791 "mlx/parser.ml" +# 34841 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34875,7 +34925,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 34879 "mlx/parser.ml" +# 34929 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -34887,7 +34937,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 34891 "mlx/parser.ml" +# 34941 "mlx/parser.ml" in let attrs1 = @@ -34895,7 +34945,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 34899 "mlx/parser.ml" +# 34949 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -34909,25 +34959,25 @@ module Tables = struct let docs = symbol_docs _sloc in ext, Md.mk name mty ~attrs ~loc ~docs ) -# 34913 "mlx/parser.ml" +# 34963 "mlx/parser.ml" in # 1132 "mlx/parser.mly" ( let (x, b) = a in x, b :: bs ) -# 34919 "mlx/parser.ml" +# 34969 "mlx/parser.ml" in # 1780 "mlx/parser.mly" ( _1 ) -# 34925 "mlx/parser.ml" +# 34975 "mlx/parser.ml" in # 1695 "mlx/parser.mly" ( let (ext, l) = _1 in (Psig_recmodule l, ext) ) -# 34931 "mlx/parser.ml" +# 34981 "mlx/parser.ml" in let _endpos__1_ = _endpos_bs_ in @@ -34937,13 +34987,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34941 "mlx/parser.ml" +# 34991 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 34947 "mlx/parser.ml" +# 34997 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34969,7 +35019,7 @@ module Tables = struct let _1 = # 1697 "mlx/parser.mly" ( let (body, ext) = _1 in (Psig_modtype body, ext) ) -# 34973 "mlx/parser.ml" +# 35023 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -34977,13 +35027,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34981 "mlx/parser.ml" +# 35031 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 34987 "mlx/parser.ml" +# 35037 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35009,7 +35059,7 @@ module Tables = struct let _1 = # 1699 "mlx/parser.mly" ( let (body, ext) = _1 in (Psig_modtypesubst body, ext) ) -# 35013 "mlx/parser.ml" +# 35063 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -35017,13 +35067,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 35021 "mlx/parser.ml" +# 35071 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 35027 "mlx/parser.ml" +# 35077 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35041,7 +35091,7 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let _1 : (Parsetree.open_description * string Location.loc option) = Obj.magic _1 in + let _1 : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in @@ -35049,7 +35099,7 @@ module Tables = struct let _1 = # 1701 "mlx/parser.mly" ( let (body, ext) = _1 in (Psig_open body, ext) ) -# 35053 "mlx/parser.ml" +# 35103 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -35057,13 +35107,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 35061 "mlx/parser.ml" +# 35111 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 35067 "mlx/parser.ml" +# 35117 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35121,7 +35171,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 35125 "mlx/parser.ml" +# 35175 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in @@ -35130,7 +35180,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 35134 "mlx/parser.ml" +# 35184 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -35144,13 +35194,13 @@ module Tables = struct let docs = symbol_docs _sloc in Incl.mk thing ~attrs ~loc ~docs, ext ) -# 35148 "mlx/parser.ml" +# 35198 "mlx/parser.ml" in # 1703 "mlx/parser.mly" ( psig_include _1 ) -# 35154 "mlx/parser.ml" +# 35204 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -35160,13 +35210,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 35164 "mlx/parser.ml" +# 35214 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 35170 "mlx/parser.ml" +# 35220 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35238,14 +35288,14 @@ module Tables = struct }; }; } = _menhir_stack in - let bs : (Parsetree.class_description list) = Obj.magic bs in + let bs : (Parsetree.class_type Parsetree.class_infos list) = Obj.magic bs in let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let cty : (Parsetree.class_type) = Obj.magic cty in let _7 : unit = Obj.magic _7 in let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 35249 "mlx/parser.ml" +# 35299 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -35265,7 +35315,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 35269 "mlx/parser.ml" +# 35319 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -35277,7 +35327,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 35281 "mlx/parser.ml" +# 35331 "mlx/parser.ml" in let attrs1 = @@ -35285,7 +35335,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 35289 "mlx/parser.ml" +# 35339 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -35300,25 +35350,25 @@ module Tables = struct ext, Ci.mk id cty ~virt ~params ~attrs ~loc ~docs ) -# 35304 "mlx/parser.ml" +# 35354 "mlx/parser.ml" in # 1132 "mlx/parser.mly" ( let (x, b) = a in x, b :: bs ) -# 35310 "mlx/parser.ml" +# 35360 "mlx/parser.ml" in # 2126 "mlx/parser.mly" ( _1 ) -# 35316 "mlx/parser.ml" +# 35366 "mlx/parser.ml" in # 1705 "mlx/parser.mly" ( let (ext, l) = _1 in (Psig_class l, ext) ) -# 35322 "mlx/parser.ml" +# 35372 "mlx/parser.ml" in let _endpos__1_ = _endpos_bs_ in @@ -35328,13 +35378,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 35332 "mlx/parser.ml" +# 35382 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 35338 "mlx/parser.ml" +# 35388 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35360,7 +35410,7 @@ module Tables = struct let _1 = # 1707 "mlx/parser.mly" ( let (ext, l) = _1 in (Psig_class_type l, ext) ) -# 35364 "mlx/parser.ml" +# 35414 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -35368,13 +35418,13 @@ module Tables = struct # 959 "mlx/parser.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 35372 "mlx/parser.ml" +# 35422 "mlx/parser.ml" in # 1709 "mlx/parser.mly" ( _1 ) -# 35378 "mlx/parser.ml" +# 35428 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35399,7 +35449,7 @@ module Tables = struct let _v : (Parsetree.constant) = # 3574 "mlx/parser.mly" ( _1 ) -# 35403 "mlx/parser.ml" +# 35453 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35426,7 +35476,7 @@ module Tables = struct let _2 : ( # 699 "mlx/parser.mly" (string * char option) -# 35430 "mlx/parser.ml" +# 35480 "mlx/parser.ml" ) = Obj.magic _2 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -35435,7 +35485,7 @@ module Tables = struct let _v : (Parsetree.constant) = # 3575 "mlx/parser.mly" ( let (n, m) = _2 in Pconst_integer("-" ^ n, m) ) -# 35439 "mlx/parser.ml" +# 35489 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35462,7 +35512,7 @@ module Tables = struct let _2 : ( # 677 "mlx/parser.mly" (string * char option) -# 35466 "mlx/parser.ml" +# 35516 "mlx/parser.ml" ) = Obj.magic _2 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -35471,7 +35521,7 @@ module Tables = struct let _v : (Parsetree.constant) = # 3576 "mlx/parser.mly" ( let (f, m) = _2 in Pconst_float("-" ^ f, m) ) -# 35475 "mlx/parser.ml" +# 35525 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35498,7 +35548,7 @@ module Tables = struct let _2 : ( # 699 "mlx/parser.mly" (string * char option) -# 35502 "mlx/parser.ml" +# 35552 "mlx/parser.ml" ) = Obj.magic _2 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -35507,7 +35557,7 @@ module Tables = struct let _v : (Parsetree.constant) = # 3577 "mlx/parser.mly" ( let (n, m) = _2 in Pconst_integer (n, m) ) -# 35511 "mlx/parser.ml" +# 35561 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35534,7 +35584,7 @@ module Tables = struct let _2 : ( # 677 "mlx/parser.mly" (string * char option) -# 35538 "mlx/parser.ml" +# 35588 "mlx/parser.ml" ) = Obj.magic _2 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -35543,7 +35593,7 @@ module Tables = struct let _v : (Parsetree.constant) = # 3578 "mlx/parser.mly" ( let (f, m) = _2 in Pconst_float(f, m) ) -# 35547 "mlx/parser.ml" +# 35597 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35588,14 +35638,14 @@ module Tables = struct ( let fields, closed = _1 in let closed = match closed with Some () -> Open | None -> Closed in fields, closed ) -# 35592 "mlx/parser.ml" +# 35642 "mlx/parser.ml" in # 2874 "mlx/parser.mly" ( let (fields, closed) = _2 in Ppat_record(fields, closed) ) -# 35599 "mlx/parser.ml" +# 35649 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -35605,13 +35655,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 35609 "mlx/parser.ml" +# 35659 "mlx/parser.ml" in # 2888 "mlx/parser.mly" ( _1 ) -# 35615 "mlx/parser.ml" +# 35665 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35656,7 +35706,7 @@ module Tables = struct ( let fields, closed = _1 in let closed = match closed with Some () -> Open | None -> Closed in fields, closed ) -# 35660 "mlx/parser.ml" +# 35710 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in @@ -35664,7 +35714,7 @@ module Tables = struct # 2877 "mlx/parser.mly" ( unclosed "{" _loc__1_ "}" _loc__3_ ) -# 35668 "mlx/parser.ml" +# 35718 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -35674,13 +35724,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 35678 "mlx/parser.ml" +# 35728 "mlx/parser.ml" in # 2888 "mlx/parser.mly" ( _1 ) -# 35684 "mlx/parser.ml" +# 35734 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35721,13 +35771,13 @@ module Tables = struct let _2 = # 2897 "mlx/parser.mly" ( ps ) -# 35725 "mlx/parser.ml" +# 35775 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in # 2879 "mlx/parser.mly" ( fst (mktailpat _loc__3_ _2) ) -# 35731 "mlx/parser.ml" +# 35781 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -35737,13 +35787,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 35741 "mlx/parser.ml" +# 35791 "mlx/parser.ml" in # 2888 "mlx/parser.mly" ( _1 ) -# 35747 "mlx/parser.ml" +# 35797 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35784,14 +35834,14 @@ module Tables = struct let _2 = # 2897 "mlx/parser.mly" ( ps ) -# 35788 "mlx/parser.ml" +# 35838 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in let _loc__1_ = (_startpos__1_, _endpos__1_) in # 2881 "mlx/parser.mly" ( unclosed "[" _loc__1_ "]" _loc__3_ ) -# 35795 "mlx/parser.ml" +# 35845 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -35801,13 +35851,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 35805 "mlx/parser.ml" +# 35855 "mlx/parser.ml" in # 2888 "mlx/parser.mly" ( _1 ) -# 35811 "mlx/parser.ml" +# 35861 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35848,12 +35898,12 @@ module Tables = struct let _2 = # 2897 "mlx/parser.mly" ( ps ) -# 35852 "mlx/parser.ml" +# 35902 "mlx/parser.ml" in # 2883 "mlx/parser.mly" ( Ppat_array _2 ) -# 35857 "mlx/parser.ml" +# 35907 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -35863,13 +35913,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 35867 "mlx/parser.ml" +# 35917 "mlx/parser.ml" in # 2888 "mlx/parser.mly" ( _1 ) -# 35873 "mlx/parser.ml" +# 35923 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35902,7 +35952,7 @@ module Tables = struct let _1 = # 2885 "mlx/parser.mly" ( Ppat_array [] ) -# 35906 "mlx/parser.ml" +# 35956 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in @@ -35911,13 +35961,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 35915 "mlx/parser.ml" +# 35965 "mlx/parser.ml" in # 2888 "mlx/parser.mly" ( _1 ) -# 35921 "mlx/parser.ml" +# 35971 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35958,14 +36008,14 @@ module Tables = struct let _2 = # 2897 "mlx/parser.mly" ( ps ) -# 35962 "mlx/parser.ml" +# 36012 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in let _loc__1_ = (_startpos__1_, _endpos__1_) in # 2887 "mlx/parser.mly" ( unclosed "[|" _loc__1_ "|]" _loc__3_ ) -# 35969 "mlx/parser.ml" +# 36019 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -35975,13 +36025,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 35979 "mlx/parser.ml" +# 36029 "mlx/parser.ml" in # 2888 "mlx/parser.mly" ( _1 ) -# 35985 "mlx/parser.ml" +# 36035 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36023,7 +36073,7 @@ module Tables = struct # 2380 "mlx/parser.mly" ( reloc_exp ~loc:_sloc _2 ) -# 36027 "mlx/parser.ml" +# 36077 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36064,7 +36114,7 @@ module Tables = struct # 2382 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__3_ ) -# 36068 "mlx/parser.ml" +# 36118 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36113,7 +36163,7 @@ module Tables = struct # 2384 "mlx/parser.mly" ( mkexp_constraint ~loc:_sloc _2 _3 ) -# 36117 "mlx/parser.ml" +# 36167 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36167,12 +36217,12 @@ module Tables = struct let r = # 2385 "mlx/parser.mly" ( None ) -# 36171 "mlx/parser.ml" +# 36221 "mlx/parser.ml" in # 2268 "mlx/parser.mly" ( array, d, Paren, i, r ) -# 36176 "mlx/parser.ml" +# 36226 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -36182,7 +36232,7 @@ module Tables = struct # 2386 "mlx/parser.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 36186 "mlx/parser.ml" +# 36236 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36236,12 +36286,12 @@ module Tables = struct let r = # 2385 "mlx/parser.mly" ( None ) -# 36240 "mlx/parser.ml" +# 36290 "mlx/parser.ml" in # 2270 "mlx/parser.mly" ( array, d, Brace, i, r ) -# 36245 "mlx/parser.ml" +# 36295 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -36251,7 +36301,7 @@ module Tables = struct # 2386 "mlx/parser.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 36255 "mlx/parser.ml" +# 36305 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36305,12 +36355,12 @@ module Tables = struct let r = # 2385 "mlx/parser.mly" ( None ) -# 36309 "mlx/parser.ml" +# 36359 "mlx/parser.ml" in # 2272 "mlx/parser.mly" ( array, d, Bracket, i, r ) -# 36314 "mlx/parser.ml" +# 36364 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -36320,7 +36370,7 @@ module Tables = struct # 2386 "mlx/parser.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 36324 "mlx/parser.ml" +# 36374 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36368,7 +36418,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 36372 "mlx/parser.ml" +# 36422 "mlx/parser.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -36378,29 +36428,29 @@ module Tables = struct let r = # 2387 "mlx/parser.mly" ( None ) -# 36382 "mlx/parser.ml" +# 36432 "mlx/parser.ml" in let i = # 2729 "mlx/parser.mly" ( es ) -# 36387 "mlx/parser.ml" +# 36437 "mlx/parser.ml" in let d = let _1 = # 124 "" ( None ) -# 36393 "mlx/parser.ml" +# 36443 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 36398 "mlx/parser.ml" +# 36448 "mlx/parser.ml" in # 2268 "mlx/parser.mly" ( array, d, Paren, i, r ) -# 36404 "mlx/parser.ml" +# 36454 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -36410,7 +36460,7 @@ module Tables = struct # 2388 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 36414 "mlx/parser.ml" +# 36464 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36470,7 +36520,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 36474 "mlx/parser.ml" +# 36524 "mlx/parser.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -36482,12 +36532,12 @@ module Tables = struct let r = # 2387 "mlx/parser.mly" ( None ) -# 36486 "mlx/parser.ml" +# 36536 "mlx/parser.ml" in let i = # 2729 "mlx/parser.mly" ( es ) -# 36491 "mlx/parser.ml" +# 36541 "mlx/parser.ml" in let d = let _1 = @@ -36495,24 +36545,24 @@ module Tables = struct let x = # 2284 "mlx/parser.mly" (_2) -# 36499 "mlx/parser.ml" +# 36549 "mlx/parser.ml" in # 126 "" ( Some x ) -# 36504 "mlx/parser.ml" +# 36554 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 36510 "mlx/parser.ml" +# 36560 "mlx/parser.ml" in # 2268 "mlx/parser.mly" ( array, d, Paren, i, r ) -# 36516 "mlx/parser.ml" +# 36566 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -36522,7 +36572,7 @@ module Tables = struct # 2388 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 36526 "mlx/parser.ml" +# 36576 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36570,7 +36620,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 36574 "mlx/parser.ml" +# 36624 "mlx/parser.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -36580,29 +36630,29 @@ module Tables = struct let r = # 2387 "mlx/parser.mly" ( None ) -# 36584 "mlx/parser.ml" +# 36634 "mlx/parser.ml" in let i = # 2729 "mlx/parser.mly" ( es ) -# 36589 "mlx/parser.ml" +# 36639 "mlx/parser.ml" in let d = let _1 = # 124 "" ( None ) -# 36595 "mlx/parser.ml" +# 36645 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 36600 "mlx/parser.ml" +# 36650 "mlx/parser.ml" in # 2270 "mlx/parser.mly" ( array, d, Brace, i, r ) -# 36606 "mlx/parser.ml" +# 36656 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -36612,7 +36662,7 @@ module Tables = struct # 2388 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 36616 "mlx/parser.ml" +# 36666 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36672,7 +36722,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 36676 "mlx/parser.ml" +# 36726 "mlx/parser.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -36684,12 +36734,12 @@ module Tables = struct let r = # 2387 "mlx/parser.mly" ( None ) -# 36688 "mlx/parser.ml" +# 36738 "mlx/parser.ml" in let i = # 2729 "mlx/parser.mly" ( es ) -# 36693 "mlx/parser.ml" +# 36743 "mlx/parser.ml" in let d = let _1 = @@ -36697,24 +36747,24 @@ module Tables = struct let x = # 2284 "mlx/parser.mly" (_2) -# 36701 "mlx/parser.ml" +# 36751 "mlx/parser.ml" in # 126 "" ( Some x ) -# 36706 "mlx/parser.ml" +# 36756 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 36712 "mlx/parser.ml" +# 36762 "mlx/parser.ml" in # 2270 "mlx/parser.mly" ( array, d, Brace, i, r ) -# 36718 "mlx/parser.ml" +# 36768 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -36724,7 +36774,7 @@ module Tables = struct # 2388 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 36728 "mlx/parser.ml" +# 36778 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36772,7 +36822,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 36776 "mlx/parser.ml" +# 36826 "mlx/parser.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -36782,29 +36832,29 @@ module Tables = struct let r = # 2387 "mlx/parser.mly" ( None ) -# 36786 "mlx/parser.ml" +# 36836 "mlx/parser.ml" in let i = # 2729 "mlx/parser.mly" ( es ) -# 36791 "mlx/parser.ml" +# 36841 "mlx/parser.ml" in let d = let _1 = # 124 "" ( None ) -# 36797 "mlx/parser.ml" +# 36847 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 36802 "mlx/parser.ml" +# 36852 "mlx/parser.ml" in # 2272 "mlx/parser.mly" ( array, d, Bracket, i, r ) -# 36808 "mlx/parser.ml" +# 36858 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -36814,7 +36864,7 @@ module Tables = struct # 2388 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 36818 "mlx/parser.ml" +# 36868 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36874,7 +36924,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 36878 "mlx/parser.ml" +# 36928 "mlx/parser.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -36886,12 +36936,12 @@ module Tables = struct let r = # 2387 "mlx/parser.mly" ( None ) -# 36890 "mlx/parser.ml" +# 36940 "mlx/parser.ml" in let i = # 2729 "mlx/parser.mly" ( es ) -# 36895 "mlx/parser.ml" +# 36945 "mlx/parser.ml" in let d = let _1 = @@ -36899,24 +36949,24 @@ module Tables = struct let x = # 2284 "mlx/parser.mly" (_2) -# 36903 "mlx/parser.ml" +# 36953 "mlx/parser.ml" in # 126 "" ( Some x ) -# 36908 "mlx/parser.ml" +# 36958 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 36914 "mlx/parser.ml" +# 36964 "mlx/parser.ml" in # 2272 "mlx/parser.mly" ( array, d, Bracket, i, r ) -# 36920 "mlx/parser.ml" +# 36970 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -36926,7 +36976,7 @@ module Tables = struct # 2388 "mlx/parser.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 36930 "mlx/parser.ml" +# 36980 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36982,13 +37032,13 @@ module Tables = struct # 2277 "mlx/parser.mly" ( indexop_unclosed_error _loc__p_ Paren _loc__e_ ) -# 36986 "mlx/parser.ml" +# 37036 "mlx/parser.ml" in # 2389 "mlx/parser.mly" ( _1 ) -# 36992 "mlx/parser.ml" +# 37042 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37044,13 +37094,13 @@ module Tables = struct # 2279 "mlx/parser.mly" ( indexop_unclosed_error _loc__p_ Brace _loc__e_ ) -# 37048 "mlx/parser.ml" +# 37098 "mlx/parser.ml" in # 2389 "mlx/parser.mly" ( _1 ) -# 37054 "mlx/parser.ml" +# 37104 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37106,13 +37156,13 @@ module Tables = struct # 2281 "mlx/parser.mly" ( indexop_unclosed_error _loc__p_ Bracket _loc__e_ ) -# 37110 "mlx/parser.ml" +# 37160 "mlx/parser.ml" in # 2389 "mlx/parser.mly" ( _1 ) -# 37116 "mlx/parser.ml" +# 37166 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37160,7 +37210,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 37164 "mlx/parser.ml" +# 37214 "mlx/parser.ml" ) = Obj.magic _2 in let _1 : (Parsetree.expression) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -37170,18 +37220,18 @@ module Tables = struct let _4 = # 2729 "mlx/parser.mly" ( es ) -# 37174 "mlx/parser.ml" +# 37224 "mlx/parser.ml" in let _2 = let _1 = # 124 "" ( None ) -# 37180 "mlx/parser.ml" +# 37230 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 37185 "mlx/parser.ml" +# 37235 "mlx/parser.ml" in let _loc__p_ = (_startpos__p_, _endpos__p_) in @@ -37189,13 +37239,13 @@ module Tables = struct # 2277 "mlx/parser.mly" ( indexop_unclosed_error _loc__p_ Paren _loc__e_ ) -# 37193 "mlx/parser.ml" +# 37243 "mlx/parser.ml" in # 2390 "mlx/parser.mly" ( _1 ) -# 37199 "mlx/parser.ml" +# 37249 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37255,7 +37305,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 37259 "mlx/parser.ml" +# 37309 "mlx/parser.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1_inlined1 : unit = Obj.magic _1_inlined1 in @@ -37267,26 +37317,27 @@ module Tables = struct let _4 = # 2729 "mlx/parser.mly" ( es ) -# 37271 "mlx/parser.ml" +# 37321 "mlx/parser.ml" in let _2 = + let _1 = _1_inlined1 in let _1 = let _2 = _2_inlined1 in let x = # 2284 "mlx/parser.mly" (_2) -# 37279 "mlx/parser.ml" +# 37330 "mlx/parser.ml" in # 126 "" ( Some x ) -# 37284 "mlx/parser.ml" +# 37335 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 37290 "mlx/parser.ml" +# 37341 "mlx/parser.ml" in let _loc__p_ = (_startpos__p_, _endpos__p_) in @@ -37294,13 +37345,13 @@ module Tables = struct # 2277 "mlx/parser.mly" ( indexop_unclosed_error _loc__p_ Paren _loc__e_ ) -# 37298 "mlx/parser.ml" +# 37349 "mlx/parser.ml" in # 2390 "mlx/parser.mly" ( _1 ) -# 37304 "mlx/parser.ml" +# 37355 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37348,7 +37399,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 37352 "mlx/parser.ml" +# 37403 "mlx/parser.ml" ) = Obj.magic _2 in let _1 : (Parsetree.expression) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -37358,18 +37409,18 @@ module Tables = struct let _4 = # 2729 "mlx/parser.mly" ( es ) -# 37362 "mlx/parser.ml" +# 37413 "mlx/parser.ml" in let _2 = let _1 = # 124 "" ( None ) -# 37368 "mlx/parser.ml" +# 37419 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 37373 "mlx/parser.ml" +# 37424 "mlx/parser.ml" in let _loc__p_ = (_startpos__p_, _endpos__p_) in @@ -37377,13 +37428,13 @@ module Tables = struct # 2279 "mlx/parser.mly" ( indexop_unclosed_error _loc__p_ Brace _loc__e_ ) -# 37381 "mlx/parser.ml" +# 37432 "mlx/parser.ml" in # 2390 "mlx/parser.mly" ( _1 ) -# 37387 "mlx/parser.ml" +# 37438 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37443,7 +37494,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 37447 "mlx/parser.ml" +# 37498 "mlx/parser.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1_inlined1 : unit = Obj.magic _1_inlined1 in @@ -37455,26 +37506,27 @@ module Tables = struct let _4 = # 2729 "mlx/parser.mly" ( es ) -# 37459 "mlx/parser.ml" +# 37510 "mlx/parser.ml" in let _2 = + let _1 = _1_inlined1 in let _1 = let _2 = _2_inlined1 in let x = # 2284 "mlx/parser.mly" (_2) -# 37467 "mlx/parser.ml" +# 37519 "mlx/parser.ml" in # 126 "" ( Some x ) -# 37472 "mlx/parser.ml" +# 37524 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 37478 "mlx/parser.ml" +# 37530 "mlx/parser.ml" in let _loc__p_ = (_startpos__p_, _endpos__p_) in @@ -37482,13 +37534,13 @@ module Tables = struct # 2279 "mlx/parser.mly" ( indexop_unclosed_error _loc__p_ Brace _loc__e_ ) -# 37486 "mlx/parser.ml" +# 37538 "mlx/parser.ml" in # 2390 "mlx/parser.mly" ( _1 ) -# 37492 "mlx/parser.ml" +# 37544 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37536,7 +37588,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 37540 "mlx/parser.ml" +# 37592 "mlx/parser.ml" ) = Obj.magic _2 in let _1 : (Parsetree.expression) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -37546,18 +37598,18 @@ module Tables = struct let _4 = # 2729 "mlx/parser.mly" ( es ) -# 37550 "mlx/parser.ml" +# 37602 "mlx/parser.ml" in let _2 = let _1 = # 124 "" ( None ) -# 37556 "mlx/parser.ml" +# 37608 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 37561 "mlx/parser.ml" +# 37613 "mlx/parser.ml" in let _loc__p_ = (_startpos__p_, _endpos__p_) in @@ -37565,13 +37617,13 @@ module Tables = struct # 2281 "mlx/parser.mly" ( indexop_unclosed_error _loc__p_ Bracket _loc__e_ ) -# 37569 "mlx/parser.ml" +# 37621 "mlx/parser.ml" in # 2390 "mlx/parser.mly" ( _1 ) -# 37575 "mlx/parser.ml" +# 37627 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37631,7 +37683,7 @@ module Tables = struct let _2 : ( # 694 "mlx/parser.mly" (string) -# 37635 "mlx/parser.ml" +# 37687 "mlx/parser.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1_inlined1 : unit = Obj.magic _1_inlined1 in @@ -37643,26 +37695,27 @@ module Tables = struct let _4 = # 2729 "mlx/parser.mly" ( es ) -# 37647 "mlx/parser.ml" +# 37699 "mlx/parser.ml" in let _2 = + let _1 = _1_inlined1 in let _1 = let _2 = _2_inlined1 in let x = # 2284 "mlx/parser.mly" (_2) -# 37655 "mlx/parser.ml" +# 37708 "mlx/parser.ml" in # 126 "" ( Some x ) -# 37660 "mlx/parser.ml" +# 37713 "mlx/parser.ml" in # 2284 "mlx/parser.mly" ( _1, _2 ) -# 37666 "mlx/parser.ml" +# 37719 "mlx/parser.ml" in let _loc__p_ = (_startpos__p_, _endpos__p_) in @@ -37670,13 +37723,13 @@ module Tables = struct # 2281 "mlx/parser.mly" ( indexop_unclosed_error _loc__p_ Bracket _loc__e_ ) -# 37674 "mlx/parser.ml" +# 37727 "mlx/parser.ml" in # 2390 "mlx/parser.mly" ( _1 ) -# 37680 "mlx/parser.ml" +# 37733 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37732,13 +37785,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 37736 "mlx/parser.ml" +# 37789 "mlx/parser.ml" in # 2400 "mlx/parser.mly" ( e.pexp_desc, (ext, attrs @ e.pexp_attributes) ) -# 37742 "mlx/parser.ml" +# 37795 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -37749,7 +37802,7 @@ module Tables = struct # 2392 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 37753 "mlx/parser.ml" +# 37806 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37800,13 +37853,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 37804 "mlx/parser.ml" +# 37857 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 37810 "mlx/parser.ml" +# 37863 "mlx/parser.ml" in let _endpos = _endpos__3_ in @@ -37815,7 +37868,7 @@ module Tables = struct # 2402 "mlx/parser.mly" ( Pexp_construct (mkloc (Lident "()") (make_loc _sloc), None), _2 ) -# 37819 "mlx/parser.ml" +# 37872 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -37826,7 +37879,7 @@ module Tables = struct # 2392 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 37830 "mlx/parser.ml" +# 37883 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37884,13 +37937,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 37888 "mlx/parser.ml" +# 37941 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 37894 "mlx/parser.ml" +# 37947 "mlx/parser.ml" in let _loc__4_ = (_startpos__4_, _endpos__4_) in @@ -37898,7 +37951,7 @@ module Tables = struct # 2404 "mlx/parser.mly" ( unclosed "begin" _loc__1_ "end" _loc__4_ ) -# 37902 "mlx/parser.ml" +# 37955 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in @@ -37909,7 +37962,7 @@ module Tables = struct # 2392 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 37913 "mlx/parser.ml" +# 37966 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37961,7 +38014,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 37965 "mlx/parser.ml" +# 38018 "mlx/parser.ml" in let _2 = @@ -37971,19 +38024,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 37975 "mlx/parser.ml" +# 38028 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 37981 "mlx/parser.ml" +# 38034 "mlx/parser.ml" in # 2406 "mlx/parser.mly" ( Pexp_new(_3), _2 ) -# 37987 "mlx/parser.ml" +# 38040 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -37994,7 +38047,7 @@ module Tables = struct # 2392 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 37998 "mlx/parser.ml" +# 38051 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38059,19 +38112,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 38063 "mlx/parser.ml" +# 38116 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 38069 "mlx/parser.ml" +# 38122 "mlx/parser.ml" in # 2408 "mlx/parser.mly" ( Pexp_pack _4, _3 ) -# 38075 "mlx/parser.ml" +# 38128 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -38082,7 +38135,7 @@ module Tables = struct # 2392 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 38086 "mlx/parser.ml" +# 38139 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38164,7 +38217,7 @@ module Tables = struct ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 38168 "mlx/parser.ml" +# 38221 "mlx/parser.ml" in let _3 = @@ -38174,13 +38227,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 38178 "mlx/parser.ml" +# 38231 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 38184 "mlx/parser.ml" +# 38237 "mlx/parser.ml" in let _endpos = _endpos__7_ in @@ -38189,7 +38242,7 @@ module Tables = struct # 2410 "mlx/parser.mly" ( Pexp_constraint (ghexp ~loc:_sloc (Pexp_pack _4), _6), _3 ) -# 38193 "mlx/parser.ml" +# 38246 "mlx/parser.ml" in let _endpos__1_ = _endpos__7_ in @@ -38200,7 +38253,7 @@ module Tables = struct # 2392 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 38204 "mlx/parser.ml" +# 38257 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38272,13 +38325,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 38276 "mlx/parser.ml" +# 38329 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 38282 "mlx/parser.ml" +# 38335 "mlx/parser.ml" in let _loc__6_ = (_startpos__6_, _endpos__6_) in @@ -38286,7 +38339,7 @@ module Tables = struct # 2412 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__6_ ) -# 38290 "mlx/parser.ml" +# 38343 "mlx/parser.ml" in let _endpos__1_ = _endpos__6_ in @@ -38297,7 +38350,7 @@ module Tables = struct # 2392 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 38301 "mlx/parser.ml" +# 38354 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38362,12 +38415,12 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 38366 "mlx/parser.ml" +# 38419 "mlx/parser.ml" in # 1954 "mlx/parser.mly" ( _1 ) -# 38371 "mlx/parser.ml" +# 38424 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in @@ -38376,13 +38429,13 @@ module Tables = struct # 895 "mlx/parser.mly" ( extra_cstr _startpos _endpos _1 ) -# 38380 "mlx/parser.ml" +# 38433 "mlx/parser.ml" in # 1941 "mlx/parser.mly" ( Cstr.mk _1 _2 ) -# 38386 "mlx/parser.ml" +# 38439 "mlx/parser.ml" in let _2 = @@ -38392,19 +38445,19 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 38396 "mlx/parser.ml" +# 38449 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 38402 "mlx/parser.ml" +# 38455 "mlx/parser.ml" in # 2414 "mlx/parser.mly" ( Pexp_object _3, _2 ) -# 38408 "mlx/parser.ml" +# 38461 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in @@ -38415,7 +38468,7 @@ module Tables = struct # 2392 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 38419 "mlx/parser.ml" +# 38472 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38480,12 +38533,12 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 38484 "mlx/parser.ml" +# 38537 "mlx/parser.ml" in # 1954 "mlx/parser.mly" ( _1 ) -# 38489 "mlx/parser.ml" +# 38542 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in @@ -38494,13 +38547,13 @@ module Tables = struct # 895 "mlx/parser.mly" ( extra_cstr _startpos _endpos _1 ) -# 38498 "mlx/parser.ml" +# 38551 "mlx/parser.ml" in # 1941 "mlx/parser.mly" ( Cstr.mk _1 _2 ) -# 38504 "mlx/parser.ml" +# 38557 "mlx/parser.ml" in let _2 = @@ -38510,13 +38563,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 38514 "mlx/parser.ml" +# 38567 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 38520 "mlx/parser.ml" +# 38573 "mlx/parser.ml" in let _loc__4_ = (_startpos__4_, _endpos__4_) in @@ -38524,7 +38577,7 @@ module Tables = struct # 2416 "mlx/parser.mly" ( unclosed "object" _loc__1_ "end" _loc__4_ ) -# 38528 "mlx/parser.ml" +# 38581 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in @@ -38535,7 +38588,7 @@ module Tables = struct # 2392 "mlx/parser.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 38539 "mlx/parser.ml" +# 38592 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38561,7 +38614,7 @@ module Tables = struct # 2394 "mlx/parser.mly" ( Jsx_helper.mkjsxexp ~loc:_loc_e_ e ) -# 38565 "mlx/parser.ml" +# 38618 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38592,13 +38645,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 38596 "mlx/parser.ml" +# 38649 "mlx/parser.ml" in # 2420 "mlx/parser.mly" ( Pexp_ident (_1) ) -# 38602 "mlx/parser.ml" +# 38655 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -38607,13 +38660,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 38611 "mlx/parser.ml" +# 38664 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 38617 "mlx/parser.ml" +# 38670 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38639,7 +38692,7 @@ module Tables = struct let _1 = # 2422 "mlx/parser.mly" ( Pexp_constant _1 ) -# 38643 "mlx/parser.ml" +# 38696 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -38647,13 +38700,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 38651 "mlx/parser.ml" +# 38704 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 38657 "mlx/parser.ml" +# 38710 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38684,13 +38737,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 38688 "mlx/parser.ml" +# 38741 "mlx/parser.ml" in # 2424 "mlx/parser.mly" ( Pexp_construct(_1, None) ) -# 38694 "mlx/parser.ml" +# 38747 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -38699,13 +38752,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 38703 "mlx/parser.ml" +# 38756 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 38709 "mlx/parser.ml" +# 38762 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38731,7 +38784,7 @@ module Tables = struct let _1 = # 2426 "mlx/parser.mly" ( Pexp_variant(_1, None) ) -# 38735 "mlx/parser.ml" +# 38788 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -38739,13 +38792,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 38743 "mlx/parser.ml" +# 38796 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 38749 "mlx/parser.ml" +# 38802 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38773,7 +38826,7 @@ module Tables = struct let _1 : ( # 740 "mlx/parser.mly" (string) -# 38777 "mlx/parser.ml" +# 38830 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -38787,13 +38840,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 38791 "mlx/parser.ml" +# 38844 "mlx/parser.ml" in # 2428 "mlx/parser.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 38797 "mlx/parser.ml" +# 38850 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in @@ -38803,13 +38856,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 38807 "mlx/parser.ml" +# 38860 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 38813 "mlx/parser.ml" +# 38866 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38844,7 +38897,7 @@ module Tables = struct let _1 = # 2429 "mlx/parser.mly" ("!") -# 38848 "mlx/parser.ml" +# 38901 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -38852,13 +38905,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 38856 "mlx/parser.ml" +# 38909 "mlx/parser.ml" in # 2430 "mlx/parser.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 38862 "mlx/parser.ml" +# 38915 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in @@ -38868,13 +38921,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 38872 "mlx/parser.ml" +# 38925 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 38878 "mlx/parser.ml" +# 38931 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38915,12 +38968,12 @@ module Tables = struct let _2 = # 2712 "mlx/parser.mly" ( xs ) -# 38919 "mlx/parser.ml" +# 38972 "mlx/parser.ml" in # 2432 "mlx/parser.mly" ( Pexp_override _2 ) -# 38924 "mlx/parser.ml" +# 38977 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -38930,13 +38983,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 38934 "mlx/parser.ml" +# 38987 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 38940 "mlx/parser.ml" +# 38993 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38977,14 +39030,14 @@ module Tables = struct let _2 = # 2712 "mlx/parser.mly" ( xs ) -# 38981 "mlx/parser.ml" +# 39034 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in let _loc__1_ = (_startpos__1_, _endpos__1_) in # 2434 "mlx/parser.mly" ( unclosed "{<" _loc__1_ ">}" _loc__3_ ) -# 38988 "mlx/parser.ml" +# 39041 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -38994,13 +39047,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 38998 "mlx/parser.ml" +# 39051 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39004 "mlx/parser.ml" +# 39057 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39033,7 +39086,7 @@ module Tables = struct let _1 = # 2436 "mlx/parser.mly" ( Pexp_override [] ) -# 39037 "mlx/parser.ml" +# 39090 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in @@ -39042,13 +39095,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39046 "mlx/parser.ml" +# 39099 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39052 "mlx/parser.ml" +# 39105 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39094,13 +39147,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 39098 "mlx/parser.ml" +# 39151 "mlx/parser.ml" in # 2438 "mlx/parser.mly" ( Pexp_field(_1, _3) ) -# 39104 "mlx/parser.ml" +# 39157 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -39110,13 +39163,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39114 "mlx/parser.ml" +# 39167 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39120 "mlx/parser.ml" +# 39173 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39176,7 +39229,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 39180 "mlx/parser.ml" +# 39233 "mlx/parser.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in @@ -39185,13 +39238,13 @@ module Tables = struct ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 39189 "mlx/parser.ml" +# 39242 "mlx/parser.ml" in # 2440 "mlx/parser.mly" ( Pexp_open(od, _4) ) -# 39195 "mlx/parser.ml" +# 39248 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -39201,13 +39254,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39205 "mlx/parser.ml" +# 39258 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39211 "mlx/parser.ml" +# 39264 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39262,7 +39315,7 @@ module Tables = struct let _4 = # 2712 "mlx/parser.mly" ( xs ) -# 39266 "mlx/parser.ml" +# 39319 "mlx/parser.ml" in let od = let _1 = @@ -39272,7 +39325,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 39276 "mlx/parser.ml" +# 39329 "mlx/parser.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in @@ -39281,7 +39334,7 @@ module Tables = struct ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 39285 "mlx/parser.ml" +# 39338 "mlx/parser.ml" in let _startpos_od_ = _startpos__1_ in @@ -39292,7 +39345,7 @@ module Tables = struct # 2442 "mlx/parser.mly" ( (* TODO: review the location of Pexp_override *) Pexp_open(od, mkexp ~loc:_sloc (Pexp_override _4)) ) -# 39296 "mlx/parser.ml" +# 39349 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -39302,13 +39355,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39306 "mlx/parser.ml" +# 39359 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39312 "mlx/parser.ml" +# 39365 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39363,14 +39416,14 @@ module Tables = struct let _4 = # 2712 "mlx/parser.mly" ( xs ) -# 39367 "mlx/parser.ml" +# 39420 "mlx/parser.ml" in let _loc__5_ = (_startpos__5_, _endpos__5_) in let _loc__3_ = (_startpos__3_, _endpos__3_) in # 2445 "mlx/parser.mly" ( unclosed "{<" _loc__3_ ">}" _loc__5_ ) -# 39374 "mlx/parser.ml" +# 39427 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -39380,13 +39433,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39384 "mlx/parser.ml" +# 39437 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39390 "mlx/parser.ml" +# 39443 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39419,7 +39472,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 39423 "mlx/parser.ml" +# 39476 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : (Parsetree.expression) = Obj.magic _1 in @@ -39433,7 +39486,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 39437 "mlx/parser.ml" +# 39490 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -39441,13 +39494,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 39445 "mlx/parser.ml" +# 39498 "mlx/parser.ml" in # 2447 "mlx/parser.mly" ( Pexp_send(_1, _3) ) -# 39451 "mlx/parser.ml" +# 39504 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -39457,13 +39510,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39461 "mlx/parser.ml" +# 39514 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39467 "mlx/parser.ml" +# 39520 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39497,7 +39550,7 @@ module Tables = struct let _1_inlined1 : ( # 751 "mlx/parser.mly" (string) -# 39501 "mlx/parser.ml" +# 39554 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _1 : (Parsetree.expression) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -39513,13 +39566,13 @@ module Tables = struct # 928 "mlx/parser.mly" ( mkoperator ~loc:_sloc _1 ) -# 39517 "mlx/parser.ml" +# 39570 "mlx/parser.ml" in # 2449 "mlx/parser.mly" ( mkinfix _1 _2 _3 ) -# 39523 "mlx/parser.ml" +# 39576 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -39529,13 +39582,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39533 "mlx/parser.ml" +# 39586 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39539 "mlx/parser.ml" +# 39592 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39561,7 +39614,7 @@ module Tables = struct let _1 = # 2451 "mlx/parser.mly" ( Pexp_extension _1 ) -# 39565 "mlx/parser.ml" +# 39618 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -39569,13 +39622,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39573 "mlx/parser.ml" +# 39626 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39579 "mlx/parser.ml" +# 39632 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39621,11 +39674,11 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _3 = - let (_endpos__2_, _startpos__1_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in + let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = # 2452 "mlx/parser.mly" (Lident "()") -# 39629 "mlx/parser.ml" +# 39682 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in @@ -39634,7 +39687,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 39638 "mlx/parser.ml" +# 39691 "mlx/parser.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -39646,7 +39699,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 39650 "mlx/parser.ml" +# 39703 "mlx/parser.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in @@ -39655,14 +39708,14 @@ module Tables = struct ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 39659 "mlx/parser.ml" +# 39712 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in # 2453 "mlx/parser.mly" ( Pexp_open(od, mkexp ~loc:(_loc__3_) (Pexp_construct(_3, None))) ) -# 39666 "mlx/parser.ml" +# 39719 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -39672,13 +39725,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39676 "mlx/parser.ml" +# 39729 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39682 "mlx/parser.ml" +# 39735 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39735,7 +39788,7 @@ module Tables = struct # 2455 "mlx/parser.mly" ( unclosed "(" _loc__3_ ")" _loc__5_ ) -# 39739 "mlx/parser.ml" +# 39792 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -39745,13 +39798,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39749 "mlx/parser.ml" +# 39802 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39755 "mlx/parser.ml" +# 39808 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39793,7 +39846,7 @@ module Tables = struct # 2457 "mlx/parser.mly" ( let (exten, fields) = _2 in Pexp_record(fields, exten) ) -# 39797 "mlx/parser.ml" +# 39850 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in @@ -39802,13 +39855,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39806 "mlx/parser.ml" +# 39859 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39812 "mlx/parser.ml" +# 39865 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39852,7 +39905,7 @@ module Tables = struct # 2460 "mlx/parser.mly" ( unclosed "{" _loc__1_ "}" _loc__3_ ) -# 39856 "mlx/parser.ml" +# 39909 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -39862,13 +39915,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39866 "mlx/parser.ml" +# 39919 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39872 "mlx/parser.ml" +# 39925 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39929,7 +39982,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 39933 "mlx/parser.ml" +# 39986 "mlx/parser.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in @@ -39938,7 +39991,7 @@ module Tables = struct ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 39942 "mlx/parser.ml" +# 39995 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -39947,7 +40000,7 @@ module Tables = struct ( let (exten, fields) = _4 in Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_record(fields, exten))) ) -# 39951 "mlx/parser.ml" +# 40004 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -39957,13 +40010,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 39961 "mlx/parser.ml" +# 40014 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 39967 "mlx/parser.ml" +# 40020 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40021,7 +40074,7 @@ module Tables = struct # 2466 "mlx/parser.mly" ( unclosed "{" _loc__3_ "}" _loc__5_ ) -# 40025 "mlx/parser.ml" +# 40078 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -40031,13 +40084,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40035 "mlx/parser.ml" +# 40088 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40041 "mlx/parser.ml" +# 40094 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40078,12 +40131,12 @@ module Tables = struct let _2 = # 2729 "mlx/parser.mly" ( es ) -# 40082 "mlx/parser.ml" +# 40135 "mlx/parser.ml" in # 2468 "mlx/parser.mly" ( Pexp_array(_2) ) -# 40087 "mlx/parser.ml" +# 40140 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -40093,13 +40146,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40097 "mlx/parser.ml" +# 40150 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40103 "mlx/parser.ml" +# 40156 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40140,14 +40193,14 @@ module Tables = struct let _2 = # 2729 "mlx/parser.mly" ( es ) -# 40144 "mlx/parser.ml" +# 40197 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in let _loc__1_ = (_startpos__1_, _endpos__1_) in # 2470 "mlx/parser.mly" ( unclosed "[|" _loc__1_ "|]" _loc__3_ ) -# 40151 "mlx/parser.ml" +# 40204 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -40157,13 +40210,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40161 "mlx/parser.ml" +# 40214 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40167 "mlx/parser.ml" +# 40220 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40196,7 +40249,7 @@ module Tables = struct let _1 = # 2472 "mlx/parser.mly" ( Pexp_array [] ) -# 40200 "mlx/parser.ml" +# 40253 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in @@ -40205,13 +40258,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40209 "mlx/parser.ml" +# 40262 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40215 "mlx/parser.ml" +# 40268 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40266,7 +40319,7 @@ module Tables = struct let _4 = # 2729 "mlx/parser.mly" ( es ) -# 40270 "mlx/parser.ml" +# 40323 "mlx/parser.ml" in let od = let _1 = @@ -40276,7 +40329,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 40280 "mlx/parser.ml" +# 40333 "mlx/parser.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in @@ -40285,14 +40338,14 @@ module Tables = struct ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 40289 "mlx/parser.ml" +# 40342 "mlx/parser.ml" in let _endpos = _endpos__5_ in # 2474 "mlx/parser.mly" ( Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array(_4))) ) -# 40296 "mlx/parser.ml" +# 40349 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -40302,13 +40355,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40306 "mlx/parser.ml" +# 40359 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40312 "mlx/parser.ml" +# 40365 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40361,7 +40414,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 40365 "mlx/parser.ml" +# 40418 "mlx/parser.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in @@ -40370,7 +40423,7 @@ module Tables = struct ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 40374 "mlx/parser.ml" +# 40427 "mlx/parser.ml" in let _endpos = _endpos__4_ in @@ -40378,7 +40431,7 @@ module Tables = struct # 2476 "mlx/parser.mly" ( (* TODO: review the location of Pexp_array *) Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array [])) ) -# 40382 "mlx/parser.ml" +# 40435 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in @@ -40388,13 +40441,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40392 "mlx/parser.ml" +# 40445 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40398 "mlx/parser.ml" +# 40451 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40449,14 +40502,14 @@ module Tables = struct let _4 = # 2729 "mlx/parser.mly" ( es ) -# 40453 "mlx/parser.ml" +# 40506 "mlx/parser.ml" in let _loc__5_ = (_startpos__5_, _endpos__5_) in let _loc__3_ = (_startpos__3_, _endpos__3_) in # 2480 "mlx/parser.mly" ( unclosed "[|" _loc__3_ "|]" _loc__5_ ) -# 40460 "mlx/parser.ml" +# 40513 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -40466,13 +40519,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40470 "mlx/parser.ml" +# 40523 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40476 "mlx/parser.ml" +# 40529 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40513,13 +40566,13 @@ module Tables = struct let _2 = # 2729 "mlx/parser.mly" ( es ) -# 40517 "mlx/parser.ml" +# 40570 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in # 2482 "mlx/parser.mly" ( fst (mktailexp _loc__3_ _2) ) -# 40523 "mlx/parser.ml" +# 40576 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -40529,13 +40582,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40533 "mlx/parser.ml" +# 40586 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40539 "mlx/parser.ml" +# 40592 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40576,14 +40629,14 @@ module Tables = struct let _2 = # 2729 "mlx/parser.mly" ( es ) -# 40580 "mlx/parser.ml" +# 40633 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in let _loc__1_ = (_startpos__1_, _endpos__1_) in # 2484 "mlx/parser.mly" ( unclosed "[" _loc__1_ "]" _loc__3_ ) -# 40587 "mlx/parser.ml" +# 40640 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -40593,13 +40646,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40597 "mlx/parser.ml" +# 40650 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40603 "mlx/parser.ml" +# 40656 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40654,7 +40707,7 @@ module Tables = struct let _4 = # 2729 "mlx/parser.mly" ( es ) -# 40658 "mlx/parser.ml" +# 40711 "mlx/parser.ml" in let od = let _1 = @@ -40664,7 +40717,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 40668 "mlx/parser.ml" +# 40721 "mlx/parser.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in @@ -40673,7 +40726,7 @@ module Tables = struct ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 40677 "mlx/parser.ml" +# 40730 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -40685,7 +40738,7 @@ module Tables = struct let tail_exp, _tail_loc = mktailexp _loc__5_ _4 in mkexp ~loc:(_startpos__3_, _endpos) tail_exp in Pexp_open(od, list_exp) ) -# 40689 "mlx/parser.ml" +# 40742 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -40695,13 +40748,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40699 "mlx/parser.ml" +# 40752 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40705 "mlx/parser.ml" +# 40758 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40747,11 +40800,11 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _3 = - let (_endpos__2_, _startpos__1_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in + let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = # 2491 "mlx/parser.mly" (Lident "[]") -# 40755 "mlx/parser.ml" +# 40808 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in @@ -40760,7 +40813,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 40764 "mlx/parser.ml" +# 40817 "mlx/parser.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -40772,7 +40825,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 40776 "mlx/parser.ml" +# 40829 "mlx/parser.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in @@ -40781,14 +40834,14 @@ module Tables = struct ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 40785 "mlx/parser.ml" +# 40838 "mlx/parser.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in # 2492 "mlx/parser.mly" ( Pexp_open(od, mkexp ~loc:_loc__3_ (Pexp_construct(_3, None))) ) -# 40792 "mlx/parser.ml" +# 40845 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -40798,13 +40851,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40802 "mlx/parser.ml" +# 40855 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40808 "mlx/parser.ml" +# 40861 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40859,14 +40912,14 @@ module Tables = struct let _4 = # 2729 "mlx/parser.mly" ( es ) -# 40863 "mlx/parser.ml" +# 40916 "mlx/parser.ml" in let _loc__5_ = (_startpos__5_, _endpos__5_) in let _loc__3_ = (_startpos__3_, _endpos__3_) in # 2495 "mlx/parser.mly" ( unclosed "[" _loc__3_ "]" _loc__5_ ) -# 40870 "mlx/parser.ml" +# 40923 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -40876,13 +40929,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 40880 "mlx/parser.ml" +# 40933 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 40886 "mlx/parser.ml" +# 40939 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40979,7 +41032,7 @@ module Tables = struct ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 40983 "mlx/parser.ml" +# 41036 "mlx/parser.ml" in let _5 = @@ -40989,13 +41042,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 40993 "mlx/parser.ml" +# 41046 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 40999 "mlx/parser.ml" +# 41052 "mlx/parser.ml" in let od = @@ -41006,7 +41059,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 41010 "mlx/parser.ml" +# 41063 "mlx/parser.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in @@ -41015,7 +41068,7 @@ module Tables = struct ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 41019 "mlx/parser.ml" +# 41072 "mlx/parser.ml" in let _startpos_od_ = _startpos__1_ in @@ -41028,7 +41081,7 @@ module Tables = struct mkexp_attrs ~loc:(_startpos__3_, _endpos) (Pexp_constraint (ghexp ~loc:_sloc (Pexp_pack _6), _8)) _5 in Pexp_open(od, modexp) ) -# 41032 "mlx/parser.ml" +# 41085 "mlx/parser.ml" in let _endpos__1_ = _endpos__9_ in @@ -41038,13 +41091,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 41042 "mlx/parser.ml" +# 41095 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 41048 "mlx/parser.ml" +# 41101 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41131,13 +41184,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 41135 "mlx/parser.ml" +# 41188 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 41141 "mlx/parser.ml" +# 41194 "mlx/parser.ml" in let _loc__8_ = (_startpos__8_, _endpos__8_) in @@ -41145,7 +41198,7 @@ module Tables = struct # 2504 "mlx/parser.mly" ( unclosed "(" _loc__3_ ")" _loc__8_ ) -# 41149 "mlx/parser.ml" +# 41202 "mlx/parser.ml" in let _endpos__1_ = _endpos__8_ in @@ -41155,13 +41208,13 @@ module Tables = struct # 934 "mlx/parser.mly" ( mkexp ~loc:_sloc _1 ) -# 41159 "mlx/parser.ml" +# 41212 "mlx/parser.ml" in # 2396 "mlx/parser.mly" ( _1 ) -# 41165 "mlx/parser.ml" +# 41218 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41192,13 +41245,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 41196 "mlx/parser.ml" +# 41249 "mlx/parser.ml" in # 2812 "mlx/parser.mly" ( Ppat_var (_1) ) -# 41202 "mlx/parser.ml" +# 41255 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -41207,13 +41260,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 41211 "mlx/parser.ml" +# 41264 "mlx/parser.ml" in # 2813 "mlx/parser.mly" ( _1 ) -# 41217 "mlx/parser.ml" +# 41270 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41238,7 +41291,7 @@ module Tables = struct let _v : (Parsetree.pattern) = # 2814 "mlx/parser.mly" ( _1 ) -# 41242 "mlx/parser.ml" +# 41295 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41280,7 +41333,7 @@ module Tables = struct # 2819 "mlx/parser.mly" ( reloc_pat ~loc:_sloc _2 ) -# 41284 "mlx/parser.ml" +# 41337 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41305,7 +41358,7 @@ module Tables = struct let _v : (Parsetree.pattern) = # 2821 "mlx/parser.mly" ( _1 ) -# 41309 "mlx/parser.ml" +# 41362 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41370,7 +41423,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 41374 "mlx/parser.ml" +# 41427 "mlx/parser.ml" in let _3 = @@ -41380,13 +41433,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 41384 "mlx/parser.ml" +# 41437 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 41390 "mlx/parser.ml" +# 41443 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -41395,7 +41448,7 @@ module Tables = struct # 2823 "mlx/parser.mly" ( mkpat_attrs ~loc:_sloc (Ppat_unpack _4) _3 ) -# 41399 "mlx/parser.ml" +# 41452 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41476,7 +41529,7 @@ module Tables = struct ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 41480 "mlx/parser.ml" +# 41533 "mlx/parser.ml" in let _4 = @@ -41487,7 +41540,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 41491 "mlx/parser.ml" +# 41544 "mlx/parser.ml" in let (_endpos__4_, _startpos__4_) = (_endpos__1_inlined3_, _startpos__1_inlined3_) in @@ -41498,13 +41551,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 41502 "mlx/parser.ml" +# 41555 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 41508 "mlx/parser.ml" +# 41561 "mlx/parser.ml" in let _endpos = _endpos__7_ in @@ -41516,7 +41569,7 @@ module Tables = struct ( mkpat_attrs ~loc:_sloc (Ppat_constraint(mkpat ~loc:_loc__4_ (Ppat_unpack _4), _6)) _3 ) -# 41520 "mlx/parser.ml" +# 41573 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41542,7 +41595,7 @@ module Tables = struct let _1 = # 2833 "mlx/parser.mly" ( Ppat_any ) -# 41546 "mlx/parser.ml" +# 41599 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -41550,13 +41603,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 41554 "mlx/parser.ml" +# 41607 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 41560 "mlx/parser.ml" +# 41613 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41582,7 +41635,7 @@ module Tables = struct let _1 = # 2835 "mlx/parser.mly" ( Ppat_constant _1 ) -# 41586 "mlx/parser.ml" +# 41639 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -41590,13 +41643,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 41594 "mlx/parser.ml" +# 41647 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 41600 "mlx/parser.ml" +# 41653 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41636,7 +41689,7 @@ module Tables = struct let _1 = # 2837 "mlx/parser.mly" ( Ppat_interval (_1, _3) ) -# 41640 "mlx/parser.ml" +# 41693 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in @@ -41645,13 +41698,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 41649 "mlx/parser.ml" +# 41702 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 41655 "mlx/parser.ml" +# 41708 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41682,13 +41735,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 41686 "mlx/parser.ml" +# 41739 "mlx/parser.ml" in # 2839 "mlx/parser.mly" ( Ppat_construct(_1, None) ) -# 41692 "mlx/parser.ml" +# 41745 "mlx/parser.ml" in let _endpos = _endpos__1_ in @@ -41697,13 +41750,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 41701 "mlx/parser.ml" +# 41754 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 41707 "mlx/parser.ml" +# 41760 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41729,7 +41782,7 @@ module Tables = struct let _1 = # 2841 "mlx/parser.mly" ( Ppat_variant(_1, None) ) -# 41733 "mlx/parser.ml" +# 41786 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -41737,13 +41790,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 41741 "mlx/parser.ml" +# 41794 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 41747 "mlx/parser.ml" +# 41800 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41782,13 +41835,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 41786 "mlx/parser.ml" +# 41839 "mlx/parser.ml" in # 2843 "mlx/parser.mly" ( Ppat_type (_2) ) -# 41792 "mlx/parser.ml" +# 41845 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -41798,13 +41851,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 41802 "mlx/parser.ml" +# 41855 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 41808 "mlx/parser.ml" +# 41861 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41849,13 +41902,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 41853 "mlx/parser.ml" +# 41906 "mlx/parser.ml" in # 2845 "mlx/parser.mly" ( Ppat_open(_1, _3) ) -# 41859 "mlx/parser.ml" +# 41912 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -41865,13 +41918,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 41869 "mlx/parser.ml" +# 41922 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 41875 "mlx/parser.ml" +# 41928 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41917,11 +41970,11 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _3 = - let (_endpos__2_, _startpos__1_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in + let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = # 2846 "mlx/parser.mly" (Lident "[]") -# 41925 "mlx/parser.ml" +# 41978 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in @@ -41930,7 +41983,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 41934 "mlx/parser.ml" +# 41987 "mlx/parser.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -41941,7 +41994,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 41945 "mlx/parser.ml" +# 41998 "mlx/parser.ml" in let _endpos = _endpos__3_ in @@ -41950,7 +42003,7 @@ module Tables = struct # 2847 "mlx/parser.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 41954 "mlx/parser.ml" +# 42007 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -41960,13 +42013,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 41964 "mlx/parser.ml" +# 42017 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 41970 "mlx/parser.ml" +# 42023 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42012,11 +42065,11 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _3 = - let (_endpos__2_, _startpos__1_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in + let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = # 2848 "mlx/parser.mly" (Lident "()") -# 42020 "mlx/parser.ml" +# 42073 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in @@ -42025,7 +42078,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 42029 "mlx/parser.ml" +# 42082 "mlx/parser.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -42036,7 +42089,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 42040 "mlx/parser.ml" +# 42093 "mlx/parser.ml" in let _endpos = _endpos__3_ in @@ -42045,7 +42098,7 @@ module Tables = struct # 2849 "mlx/parser.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 42049 "mlx/parser.ml" +# 42102 "mlx/parser.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -42055,13 +42108,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 42059 "mlx/parser.ml" +# 42112 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 42065 "mlx/parser.ml" +# 42118 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42120,13 +42173,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 42124 "mlx/parser.ml" +# 42177 "mlx/parser.ml" in # 2851 "mlx/parser.mly" ( Ppat_open (_1, _4) ) -# 42130 "mlx/parser.ml" +# 42183 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -42136,13 +42189,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 42140 "mlx/parser.ml" +# 42193 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 42146 "mlx/parser.ml" +# 42199 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42199,7 +42252,7 @@ module Tables = struct # 2853 "mlx/parser.mly" ( unclosed "(" _loc__3_ ")" _loc__5_ ) -# 42203 "mlx/parser.ml" +# 42256 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -42209,13 +42262,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 42213 "mlx/parser.ml" +# 42266 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 42219 "mlx/parser.ml" +# 42272 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42264,7 +42317,7 @@ module Tables = struct # 2855 "mlx/parser.mly" ( expecting _loc__4_ "pattern" ) -# 42268 "mlx/parser.ml" +# 42321 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in @@ -42274,13 +42327,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 42278 "mlx/parser.ml" +# 42331 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 42284 "mlx/parser.ml" +# 42337 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42323,7 +42376,7 @@ module Tables = struct # 2857 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__3_ ) -# 42327 "mlx/parser.ml" +# 42380 "mlx/parser.ml" in let _endpos__1_ = _endpos__3_ in @@ -42333,13 +42386,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 42337 "mlx/parser.ml" +# 42390 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 42343 "mlx/parser.ml" +# 42396 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42393,7 +42446,7 @@ module Tables = struct let _1 = # 2859 "mlx/parser.mly" ( Ppat_constraint(_2, _4) ) -# 42397 "mlx/parser.ml" +# 42450 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in let _endpos = _endpos__1_ in @@ -42402,13 +42455,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 42406 "mlx/parser.ml" +# 42459 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 42412 "mlx/parser.ml" +# 42465 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42465,7 +42518,7 @@ module Tables = struct # 2861 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__5_ ) -# 42469 "mlx/parser.ml" +# 42522 "mlx/parser.ml" in let _endpos__1_ = _endpos__5_ in @@ -42475,13 +42528,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 42479 "mlx/parser.ml" +# 42532 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 42485 "mlx/parser.ml" +# 42538 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42530,7 +42583,7 @@ module Tables = struct # 2863 "mlx/parser.mly" ( expecting _loc__4_ "type" ) -# 42534 "mlx/parser.ml" +# 42587 "mlx/parser.ml" in let _endpos__1_ = _endpos__4_ in @@ -42540,13 +42593,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 42544 "mlx/parser.ml" +# 42597 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 42550 "mlx/parser.ml" +# 42603 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42629,7 +42682,7 @@ module Tables = struct ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 42633 "mlx/parser.ml" +# 42686 "mlx/parser.ml" in let _3 = @@ -42639,13 +42692,13 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 42643 "mlx/parser.ml" +# 42696 "mlx/parser.ml" in # 3935 "mlx/parser.mly" ( _1, _2 ) -# 42649 "mlx/parser.ml" +# 42702 "mlx/parser.ml" in let _loc__7_ = (_startpos__7_, _endpos__7_) in @@ -42653,7 +42706,7 @@ module Tables = struct # 2866 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__7_ ) -# 42657 "mlx/parser.ml" +# 42710 "mlx/parser.ml" in let _endpos__1_ = _endpos__7_ in @@ -42663,13 +42716,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 42667 "mlx/parser.ml" +# 42720 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 42673 "mlx/parser.ml" +# 42726 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42695,7 +42748,7 @@ module Tables = struct let _1 = # 2868 "mlx/parser.mly" ( Ppat_extension _1 ) -# 42699 "mlx/parser.ml" +# 42752 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -42703,13 +42756,13 @@ module Tables = struct # 936 "mlx/parser.mly" ( mkpat ~loc:_sloc _1 ) -# 42707 "mlx/parser.ml" +# 42760 "mlx/parser.ml" in # 2829 "mlx/parser.mly" ( _1 ) -# 42713 "mlx/parser.ml" +# 42766 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42730,7 +42783,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 42734 "mlx/parser.ml" +# 42787 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -42738,7 +42791,7 @@ module Tables = struct let _v : (string) = # 3843 "mlx/parser.mly" ( _1 ) -# 42742 "mlx/parser.ml" +# 42795 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42759,7 +42812,7 @@ module Tables = struct let _1 : ( # 767 "mlx/parser.mly" (string) -# 42763 "mlx/parser.ml" +# 42816 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -42767,7 +42820,7 @@ module Tables = struct let _v : (string) = # 3844 "mlx/parser.mly" ( _1 ) -# 42771 "mlx/parser.ml" +# 42824 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42792,7 +42845,7 @@ module Tables = struct let _v : (string) = # 3845 "mlx/parser.mly" ( "and" ) -# 42796 "mlx/parser.ml" +# 42849 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42817,7 +42870,7 @@ module Tables = struct let _v : (string) = # 3846 "mlx/parser.mly" ( "as" ) -# 42821 "mlx/parser.ml" +# 42874 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42842,7 +42895,7 @@ module Tables = struct let _v : (string) = # 3847 "mlx/parser.mly" ( "assert" ) -# 42846 "mlx/parser.ml" +# 42899 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42867,7 +42920,7 @@ module Tables = struct let _v : (string) = # 3848 "mlx/parser.mly" ( "begin" ) -# 42871 "mlx/parser.ml" +# 42924 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42892,7 +42945,7 @@ module Tables = struct let _v : (string) = # 3849 "mlx/parser.mly" ( "class" ) -# 42896 "mlx/parser.ml" +# 42949 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42917,7 +42970,7 @@ module Tables = struct let _v : (string) = # 3850 "mlx/parser.mly" ( "constraint" ) -# 42921 "mlx/parser.ml" +# 42974 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42942,7 +42995,7 @@ module Tables = struct let _v : (string) = # 3851 "mlx/parser.mly" ( "do" ) -# 42946 "mlx/parser.ml" +# 42999 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42967,7 +43020,7 @@ module Tables = struct let _v : (string) = # 3852 "mlx/parser.mly" ( "done" ) -# 42971 "mlx/parser.ml" +# 43024 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42992,7 +43045,7 @@ module Tables = struct let _v : (string) = # 3853 "mlx/parser.mly" ( "downto" ) -# 42996 "mlx/parser.ml" +# 43049 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43017,7 +43070,7 @@ module Tables = struct let _v : (string) = # 3854 "mlx/parser.mly" ( "else" ) -# 43021 "mlx/parser.ml" +# 43074 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43042,7 +43095,7 @@ module Tables = struct let _v : (string) = # 3855 "mlx/parser.mly" ( "end" ) -# 43046 "mlx/parser.ml" +# 43099 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43067,7 +43120,7 @@ module Tables = struct let _v : (string) = # 3856 "mlx/parser.mly" ( "exception" ) -# 43071 "mlx/parser.ml" +# 43124 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43092,7 +43145,7 @@ module Tables = struct let _v : (string) = # 3857 "mlx/parser.mly" ( "external" ) -# 43096 "mlx/parser.ml" +# 43149 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43117,7 +43170,7 @@ module Tables = struct let _v : (string) = # 3858 "mlx/parser.mly" ( "false" ) -# 43121 "mlx/parser.ml" +# 43174 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43142,7 +43195,7 @@ module Tables = struct let _v : (string) = # 3859 "mlx/parser.mly" ( "for" ) -# 43146 "mlx/parser.ml" +# 43199 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43167,7 +43220,7 @@ module Tables = struct let _v : (string) = # 3860 "mlx/parser.mly" ( "fun" ) -# 43171 "mlx/parser.ml" +# 43224 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43192,7 +43245,7 @@ module Tables = struct let _v : (string) = # 3861 "mlx/parser.mly" ( "function" ) -# 43196 "mlx/parser.ml" +# 43249 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43217,7 +43270,7 @@ module Tables = struct let _v : (string) = # 3862 "mlx/parser.mly" ( "functor" ) -# 43221 "mlx/parser.ml" +# 43274 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43242,7 +43295,7 @@ module Tables = struct let _v : (string) = # 3863 "mlx/parser.mly" ( "if" ) -# 43246 "mlx/parser.ml" +# 43299 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43267,7 +43320,7 @@ module Tables = struct let _v : (string) = # 3864 "mlx/parser.mly" ( "in" ) -# 43271 "mlx/parser.ml" +# 43324 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43292,7 +43345,7 @@ module Tables = struct let _v : (string) = # 3865 "mlx/parser.mly" ( "include" ) -# 43296 "mlx/parser.ml" +# 43349 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43317,7 +43370,7 @@ module Tables = struct let _v : (string) = # 3866 "mlx/parser.mly" ( "inherit" ) -# 43321 "mlx/parser.ml" +# 43374 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43342,7 +43395,7 @@ module Tables = struct let _v : (string) = # 3867 "mlx/parser.mly" ( "initializer" ) -# 43346 "mlx/parser.ml" +# 43399 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43367,7 +43420,7 @@ module Tables = struct let _v : (string) = # 3868 "mlx/parser.mly" ( "lazy" ) -# 43371 "mlx/parser.ml" +# 43424 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43392,7 +43445,7 @@ module Tables = struct let _v : (string) = # 3869 "mlx/parser.mly" ( "let" ) -# 43396 "mlx/parser.ml" +# 43449 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43417,7 +43470,7 @@ module Tables = struct let _v : (string) = # 3870 "mlx/parser.mly" ( "match" ) -# 43421 "mlx/parser.ml" +# 43474 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43442,7 +43495,7 @@ module Tables = struct let _v : (string) = # 3871 "mlx/parser.mly" ( "method" ) -# 43446 "mlx/parser.ml" +# 43499 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43467,7 +43520,7 @@ module Tables = struct let _v : (string) = # 3872 "mlx/parser.mly" ( "module" ) -# 43471 "mlx/parser.ml" +# 43524 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43492,7 +43545,7 @@ module Tables = struct let _v : (string) = # 3873 "mlx/parser.mly" ( "mutable" ) -# 43496 "mlx/parser.ml" +# 43549 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43517,7 +43570,7 @@ module Tables = struct let _v : (string) = # 3874 "mlx/parser.mly" ( "new" ) -# 43521 "mlx/parser.ml" +# 43574 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43542,7 +43595,7 @@ module Tables = struct let _v : (string) = # 3875 "mlx/parser.mly" ( "nonrec" ) -# 43546 "mlx/parser.ml" +# 43599 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43567,7 +43620,7 @@ module Tables = struct let _v : (string) = # 3876 "mlx/parser.mly" ( "object" ) -# 43571 "mlx/parser.ml" +# 43624 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43592,7 +43645,7 @@ module Tables = struct let _v : (string) = # 3877 "mlx/parser.mly" ( "of" ) -# 43596 "mlx/parser.ml" +# 43649 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43617,7 +43670,7 @@ module Tables = struct let _v : (string) = # 3878 "mlx/parser.mly" ( "open" ) -# 43621 "mlx/parser.ml" +# 43674 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43642,7 +43695,7 @@ module Tables = struct let _v : (string) = # 3879 "mlx/parser.mly" ( "or" ) -# 43646 "mlx/parser.ml" +# 43699 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43667,7 +43720,7 @@ module Tables = struct let _v : (string) = # 3880 "mlx/parser.mly" ( "private" ) -# 43671 "mlx/parser.ml" +# 43724 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43692,7 +43745,7 @@ module Tables = struct let _v : (string) = # 3881 "mlx/parser.mly" ( "rec" ) -# 43696 "mlx/parser.ml" +# 43749 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43717,7 +43770,7 @@ module Tables = struct let _v : (string) = # 3882 "mlx/parser.mly" ( "sig" ) -# 43721 "mlx/parser.ml" +# 43774 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43742,7 +43795,7 @@ module Tables = struct let _v : (string) = # 3883 "mlx/parser.mly" ( "struct" ) -# 43746 "mlx/parser.ml" +# 43799 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43767,7 +43820,7 @@ module Tables = struct let _v : (string) = # 3884 "mlx/parser.mly" ( "then" ) -# 43771 "mlx/parser.ml" +# 43824 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43792,7 +43845,7 @@ module Tables = struct let _v : (string) = # 3885 "mlx/parser.mly" ( "to" ) -# 43796 "mlx/parser.ml" +# 43849 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43817,7 +43870,7 @@ module Tables = struct let _v : (string) = # 3886 "mlx/parser.mly" ( "true" ) -# 43821 "mlx/parser.ml" +# 43874 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43842,7 +43895,7 @@ module Tables = struct let _v : (string) = # 3887 "mlx/parser.mly" ( "try" ) -# 43846 "mlx/parser.ml" +# 43899 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43867,7 +43920,7 @@ module Tables = struct let _v : (string) = # 3888 "mlx/parser.mly" ( "type" ) -# 43871 "mlx/parser.ml" +# 43924 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43892,7 +43945,7 @@ module Tables = struct let _v : (string) = # 3889 "mlx/parser.mly" ( "val" ) -# 43896 "mlx/parser.ml" +# 43949 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43917,7 +43970,7 @@ module Tables = struct let _v : (string) = # 3890 "mlx/parser.mly" ( "virtual" ) -# 43921 "mlx/parser.ml" +# 43974 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43942,7 +43995,7 @@ module Tables = struct let _v : (string) = # 3891 "mlx/parser.mly" ( "when" ) -# 43946 "mlx/parser.ml" +# 43999 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43967,7 +44020,7 @@ module Tables = struct let _v : (string) = # 3892 "mlx/parser.mly" ( "while" ) -# 43971 "mlx/parser.ml" +# 44024 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43992,7 +44045,7 @@ module Tables = struct let _v : (string) = # 3893 "mlx/parser.mly" ( "with" ) -# 43996 "mlx/parser.ml" +# 44049 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44017,7 +44070,7 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = # 3147 "mlx/parser.mly" ( _1 ) -# 44021 "mlx/parser.ml" +# 44074 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44093,7 +44146,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 44097 "mlx/parser.ml" +# 44150 "mlx/parser.ml" in let _endpos_attrs_ = _endpos__1_inlined5_ in @@ -44102,7 +44155,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 44106 "mlx/parser.ml" +# 44159 "mlx/parser.ml" in let lid = @@ -44113,7 +44166,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 44117 "mlx/parser.ml" +# 44170 "mlx/parser.ml" in let id = @@ -44124,7 +44177,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 44128 "mlx/parser.ml" +# 44181 "mlx/parser.ml" in let attrs1 = @@ -44132,7 +44185,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 44136 "mlx/parser.ml" +# 44189 "mlx/parser.ml" in let _endpos = _endpos_attrs_ in @@ -44145,7 +44198,7 @@ module Tables = struct Te.mk_exception ~attrs (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs) , ext ) -# 44149 "mlx/parser.ml" +# 44202 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44177,7 +44230,7 @@ module Tables = struct let _v : (Parsetree.expression) = # 2654 "mlx/parser.mly" ( _2 ) -# 44181 "mlx/parser.ml" +# 44234 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44212,7 +44265,7 @@ module Tables = struct # 2656 "mlx/parser.mly" ( let (l, o, p) = _1 in ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) ) -# 44216 "mlx/parser.ml" +# 44269 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44265,7 +44318,7 @@ module Tables = struct let _v : (Parsetree.expression) = let _3 = # 2549 "mlx/parser.mly" ( xs ) -# 44269 "mlx/parser.ml" +# 44322 "mlx/parser.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in @@ -44273,7 +44326,7 @@ module Tables = struct # 2658 "mlx/parser.mly" ( mk_newtypes ~loc:_sloc _3 _5 ) -# 44277 "mlx/parser.ml" +# 44330 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44300,24 +44353,24 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 44304 "mlx/parser.ml" +# 44357 "mlx/parser.ml" in let xs = let items = # 971 "mlx/parser.mly" ( [] ) -# 44310 "mlx/parser.ml" +# 44363 "mlx/parser.ml" in # 1401 "mlx/parser.mly" ( items ) -# 44315 "mlx/parser.ml" +# 44368 "mlx/parser.ml" in # 267 "" ( xs @ ys ) -# 44321 "mlx/parser.ml" +# 44374 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in @@ -44326,13 +44379,13 @@ module Tables = struct # 893 "mlx/parser.mly" ( extra_str _startpos _endpos _1 ) -# 44330 "mlx/parser.ml" +# 44383 "mlx/parser.ml" in # 1394 "mlx/parser.mly" ( _1 ) -# 44336 "mlx/parser.ml" +# 44389 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44373,7 +44426,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 44377 "mlx/parser.ml" +# 44430 "mlx/parser.ml" in let xs = let items = @@ -44383,12 +44436,12 @@ module Tables = struct let attrs = # 3918 "mlx/parser.mly" ( _1 ) -# 44387 "mlx/parser.ml" +# 44440 "mlx/parser.ml" in # 1408 "mlx/parser.mly" ( mkstrexp e attrs ) -# 44392 "mlx/parser.ml" +# 44445 "mlx/parser.ml" in let _startpos__1_ = _startpos_e_ in @@ -44396,7 +44449,7 @@ module Tables = struct # 905 "mlx/parser.mly" ( text_str _startpos @ [_1] ) -# 44400 "mlx/parser.ml" +# 44453 "mlx/parser.ml" in let _startpos__1_ = _startpos_e_ in @@ -44406,25 +44459,25 @@ module Tables = struct # 924 "mlx/parser.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 44410 "mlx/parser.ml" +# 44463 "mlx/parser.ml" in # 973 "mlx/parser.mly" ( x ) -# 44416 "mlx/parser.ml" +# 44469 "mlx/parser.ml" in # 1401 "mlx/parser.mly" ( items ) -# 44422 "mlx/parser.ml" +# 44475 "mlx/parser.ml" in # 267 "" ( xs @ ys ) -# 44428 "mlx/parser.ml" +# 44481 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_e_) in @@ -44433,13 +44486,13 @@ module Tables = struct # 893 "mlx/parser.mly" ( extra_str _startpos _endpos _1 ) -# 44437 "mlx/parser.ml" +# 44490 "mlx/parser.ml" in # 1394 "mlx/parser.mly" ( _1 ) -# 44443 "mlx/parser.ml" +# 44496 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44467,7 +44520,7 @@ module Tables = struct # 1423 "mlx/parser.mly" ( val_of_let_bindings ~loc:_sloc _1 ) -# 44471 "mlx/parser.ml" +# 44524 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44503,7 +44556,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 44507 "mlx/parser.ml" +# 44560 "mlx/parser.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -44514,7 +44567,7 @@ module Tables = struct # 1426 "mlx/parser.mly" ( let docs = symbol_docs _sloc in Pstr_extension (_1, add_docs_attrs docs _2) ) -# 44518 "mlx/parser.ml" +# 44571 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -44524,13 +44577,13 @@ module Tables = struct # 940 "mlx/parser.mly" ( mkstr ~loc:_sloc _1 ) -# 44528 "mlx/parser.ml" +# 44581 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 44534 "mlx/parser.ml" +# 44587 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44556,7 +44609,7 @@ module Tables = struct let _1 = # 1429 "mlx/parser.mly" ( Pstr_attribute _1 ) -# 44560 "mlx/parser.ml" +# 44613 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -44564,13 +44617,13 @@ module Tables = struct # 940 "mlx/parser.mly" ( mkstr ~loc:_sloc _1 ) -# 44568 "mlx/parser.ml" +# 44621 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 44574 "mlx/parser.ml" +# 44627 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44596,7 +44649,7 @@ module Tables = struct let _1 = # 1433 "mlx/parser.mly" ( pstr_primitive _1 ) -# 44600 "mlx/parser.ml" +# 44653 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -44604,13 +44657,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 44608 "mlx/parser.ml" +# 44661 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 44614 "mlx/parser.ml" +# 44667 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44636,7 +44689,7 @@ module Tables = struct let _1 = # 1435 "mlx/parser.mly" ( pstr_primitive _1 ) -# 44640 "mlx/parser.ml" +# 44693 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -44644,13 +44697,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 44648 "mlx/parser.ml" +# 44701 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 44654 "mlx/parser.ml" +# 44707 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44687,24 +44740,24 @@ module Tables = struct let _1 = # 1132 "mlx/parser.mly" ( let (x, b) = a in x, b :: bs ) -# 44691 "mlx/parser.ml" +# 44744 "mlx/parser.ml" in # 2991 "mlx/parser.mly" ( _1 ) -# 44696 "mlx/parser.ml" +# 44749 "mlx/parser.ml" in # 2974 "mlx/parser.mly" ( _1 ) -# 44702 "mlx/parser.ml" +# 44755 "mlx/parser.ml" in # 1437 "mlx/parser.mly" ( pstr_type _1 ) -# 44708 "mlx/parser.ml" +# 44761 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -44714,13 +44767,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 44718 "mlx/parser.ml" +# 44771 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 44724 "mlx/parser.ml" +# 44777 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44807,14 +44860,14 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 44811 "mlx/parser.ml" +# 44864 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = # 1124 "mlx/parser.mly" ( List.rev xs ) -# 44818 "mlx/parser.ml" +# 44871 "mlx/parser.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -44824,20 +44877,20 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 44828 "mlx/parser.ml" +# 44881 "mlx/parser.ml" in let _4 = # 3763 "mlx/parser.mly" ( Recursive ) -# 44834 "mlx/parser.ml" +# 44887 "mlx/parser.ml" in let attrs1 = let _1 = _1_inlined1 in # 3922 "mlx/parser.mly" ( _1 ) -# 44841 "mlx/parser.ml" +# 44894 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -44849,19 +44902,19 @@ module Tables = struct let attrs = attrs1 @ attrs2 in Te.mk tid cs ~params ~priv ~attrs ~docs, ext ) -# 44853 "mlx/parser.ml" +# 44906 "mlx/parser.ml" in # 3227 "mlx/parser.mly" ( _1 ) -# 44859 "mlx/parser.ml" +# 44912 "mlx/parser.ml" in # 1439 "mlx/parser.mly" ( pstr_typext _1 ) -# 44865 "mlx/parser.ml" +# 44918 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -44871,13 +44924,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 44875 "mlx/parser.ml" +# 44928 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 44881 "mlx/parser.ml" +# 44934 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44971,14 +45024,14 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 44975 "mlx/parser.ml" +# 45028 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = # 1124 "mlx/parser.mly" ( List.rev xs ) -# 44982 "mlx/parser.ml" +# 45035 "mlx/parser.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -44988,18 +45041,18 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 44992 "mlx/parser.ml" +# 45045 "mlx/parser.ml" in let _4 = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos__1_inlined2_) in + let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in # 3765 "mlx/parser.mly" ( not_expecting _loc "nonrec flag" ) -# 45003 "mlx/parser.ml" +# 45056 "mlx/parser.ml" in let attrs1 = @@ -45007,7 +45060,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 45011 "mlx/parser.ml" +# 45064 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -45019,19 +45072,19 @@ module Tables = struct let attrs = attrs1 @ attrs2 in Te.mk tid cs ~params ~priv ~attrs ~docs, ext ) -# 45023 "mlx/parser.ml" +# 45076 "mlx/parser.ml" in # 3227 "mlx/parser.mly" ( _1 ) -# 45029 "mlx/parser.ml" +# 45082 "mlx/parser.ml" in # 1439 "mlx/parser.mly" ( pstr_typext _1 ) -# 45035 "mlx/parser.ml" +# 45088 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -45041,13 +45094,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 45045 "mlx/parser.ml" +# 45098 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 45051 "mlx/parser.ml" +# 45104 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45073,7 +45126,7 @@ module Tables = struct let _1 = # 1441 "mlx/parser.mly" ( pstr_exception _1 ) -# 45077 "mlx/parser.ml" +# 45130 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -45081,13 +45134,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 45085 "mlx/parser.ml" +# 45138 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 45091 "mlx/parser.ml" +# 45144 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45152,7 +45205,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 45156 "mlx/parser.ml" +# 45209 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -45164,7 +45217,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 45168 "mlx/parser.ml" +# 45221 "mlx/parser.ml" in let attrs1 = @@ -45172,7 +45225,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 45176 "mlx/parser.ml" +# 45229 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -45185,13 +45238,13 @@ module Tables = struct let attrs = attrs1 @ attrs2 in let body = Mb.mk name body ~attrs ~loc ~docs in Pstr_module body, ext ) -# 45189 "mlx/parser.ml" +# 45242 "mlx/parser.ml" in # 1443 "mlx/parser.mly" ( _1 ) -# 45195 "mlx/parser.ml" +# 45248 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -45201,13 +45254,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 45205 "mlx/parser.ml" +# 45258 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 45211 "mlx/parser.ml" +# 45264 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45288,7 +45341,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 45292 "mlx/parser.ml" +# 45345 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -45300,7 +45353,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 45304 "mlx/parser.ml" +# 45357 "mlx/parser.ml" in let attrs1 = @@ -45308,7 +45361,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 45312 "mlx/parser.ml" +# 45365 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -45323,25 +45376,25 @@ module Tables = struct ext, Mb.mk name body ~attrs ~loc ~docs ) -# 45327 "mlx/parser.ml" +# 45380 "mlx/parser.ml" in # 1132 "mlx/parser.mly" ( let (x, b) = a in x, b :: bs ) -# 45333 "mlx/parser.ml" +# 45386 "mlx/parser.ml" in # 1492 "mlx/parser.mly" ( _1 ) -# 45339 "mlx/parser.ml" +# 45392 "mlx/parser.ml" in # 1445 "mlx/parser.mly" ( pstr_recmodule _1 ) -# 45345 "mlx/parser.ml" +# 45398 "mlx/parser.ml" in let _endpos__1_ = _endpos_bs_ in @@ -45351,13 +45404,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 45355 "mlx/parser.ml" +# 45408 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 45361 "mlx/parser.ml" +# 45414 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45383,7 +45436,7 @@ module Tables = struct let _1 = # 1447 "mlx/parser.mly" ( let (body, ext) = _1 in (Pstr_modtype body, ext) ) -# 45387 "mlx/parser.ml" +# 45440 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -45391,13 +45444,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 45395 "mlx/parser.ml" +# 45448 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 45401 "mlx/parser.ml" +# 45454 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45415,7 +45468,7 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let _1 : (Parsetree.open_declaration * string Location.loc option) = Obj.magic _1 in + let _1 : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in @@ -45423,7 +45476,7 @@ module Tables = struct let _1 = # 1449 "mlx/parser.mly" ( let (body, ext) = _1 in (Pstr_open body, ext) ) -# 45427 "mlx/parser.ml" +# 45480 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -45431,13 +45484,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 45435 "mlx/parser.ml" +# 45488 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 45441 "mlx/parser.ml" +# 45494 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45503,13 +45556,13 @@ module Tables = struct }; }; } = _menhir_stack in - let bs : (Parsetree.class_declaration list) = Obj.magic bs in + let bs : (Parsetree.class_expr Parsetree.class_infos list) = Obj.magic bs in let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 45513 "mlx/parser.ml" +# 45566 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -45529,7 +45582,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 45533 "mlx/parser.ml" +# 45586 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -45541,7 +45594,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 45545 "mlx/parser.ml" +# 45598 "mlx/parser.ml" in let attrs1 = @@ -45549,7 +45602,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 45553 "mlx/parser.ml" +# 45606 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -45564,25 +45617,25 @@ module Tables = struct ext, Ci.mk id body ~virt ~params ~attrs ~loc ~docs ) -# 45568 "mlx/parser.ml" +# 45621 "mlx/parser.ml" in # 1132 "mlx/parser.mly" ( let (x, b) = a in x, b :: bs ) -# 45574 "mlx/parser.ml" +# 45627 "mlx/parser.ml" in # 1837 "mlx/parser.mly" ( _1 ) -# 45580 "mlx/parser.ml" +# 45633 "mlx/parser.ml" in # 1451 "mlx/parser.mly" ( let (ext, l) = _1 in (Pstr_class l, ext) ) -# 45586 "mlx/parser.ml" +# 45639 "mlx/parser.ml" in let _endpos__1_ = _endpos_bs_ in @@ -45592,13 +45645,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 45596 "mlx/parser.ml" +# 45649 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 45602 "mlx/parser.ml" +# 45655 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45624,7 +45677,7 @@ module Tables = struct let _1 = # 1453 "mlx/parser.mly" ( let (ext, l) = _1 in (Pstr_class_type l, ext) ) -# 45628 "mlx/parser.ml" +# 45681 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -45632,13 +45685,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 45636 "mlx/parser.ml" +# 45689 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 45642 "mlx/parser.ml" +# 45695 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45696,7 +45749,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 45700 "mlx/parser.ml" +# 45753 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in @@ -45705,7 +45758,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 45709 "mlx/parser.ml" +# 45762 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -45719,13 +45772,13 @@ module Tables = struct let docs = symbol_docs _sloc in Incl.mk thing ~attrs ~loc ~docs, ext ) -# 45723 "mlx/parser.ml" +# 45776 "mlx/parser.ml" in # 1455 "mlx/parser.mly" ( pstr_include _1 ) -# 45729 "mlx/parser.ml" +# 45782 "mlx/parser.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -45735,13 +45788,13 @@ module Tables = struct # 957 "mlx/parser.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 45739 "mlx/parser.ml" +# 45792 "mlx/parser.ml" in # 1457 "mlx/parser.mly" ( _1 ) -# 45745 "mlx/parser.ml" +# 45798 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45766,7 +45819,7 @@ module Tables = struct let _v : (string) = # 3828 "mlx/parser.mly" ( "-" ) -# 45770 "mlx/parser.ml" +# 45823 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45791,7 +45844,7 @@ module Tables = struct let _v : (string) = # 3829 "mlx/parser.mly" ( "-." ) -# 45795 "mlx/parser.ml" +# 45848 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45846,7 +45899,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 45850 "mlx/parser.ml" +# 45903 "mlx/parser.ml" in let _endpos__5_ = _endpos__1_inlined1_ in @@ -45855,18 +45908,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 45859 "mlx/parser.ml" +# 45912 "mlx/parser.ml" in # 1035 "mlx/parser.mly" ( xs ) -# 45864 "mlx/parser.ml" +# 45917 "mlx/parser.ml" in # 3518 "mlx/parser.mly" ( _1 ) -# 45870 "mlx/parser.ml" +# 45923 "mlx/parser.ml" in let _1 = @@ -45876,7 +45929,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 45880 "mlx/parser.ml" +# 45933 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -45887,7 +45940,7 @@ module Tables = struct ( let info = symbol_info _endpos in let attrs = add_info_attrs info _5 in Rf.tag ~loc:(make_loc _sloc) ~attrs _1 _3 _4 ) -# 45891 "mlx/parser.ml" +# 45944 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45921,7 +45974,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 45925 "mlx/parser.ml" +# 45978 "mlx/parser.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -45932,7 +45985,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 45936 "mlx/parser.ml" +# 45989 "mlx/parser.ml" in let _endpos = _endpos__2_ in @@ -45943,7 +45996,7 @@ module Tables = struct ( let info = symbol_info _endpos in let attrs = add_info_attrs info _2 in Rf.tag ~loc:(make_loc _sloc) ~attrs _1 true [] ) -# 45947 "mlx/parser.ml" +# 46000 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45975,7 +46028,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase) = let arg = # 124 "" ( None ) -# 45979 "mlx/parser.ml" +# 46032 "mlx/parser.ml" in let _endpos_arg_ = _endpos__1_inlined1_ in let dir = @@ -45986,7 +46039,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 45990 "mlx/parser.ml" +# 46043 "mlx/parser.ml" in let _endpos = _endpos_arg_ in @@ -45995,7 +46048,7 @@ module Tables = struct # 3726 "mlx/parser.mly" ( mk_directive ~loc:_sloc dir arg ) -# 45999 "mlx/parser.ml" +# 46052 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46028,7 +46081,7 @@ module Tables = struct let _1_inlined2 : ( # 754 "mlx/parser.mly" (string * Location.t * string option) -# 46032 "mlx/parser.ml" +# 46085 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let _1_inlined1 : (string) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in @@ -46041,7 +46094,7 @@ module Tables = struct let _1 = # 3730 "mlx/parser.mly" ( let (s, _, _) = _1 in Pdir_string s ) -# 46045 "mlx/parser.ml" +# 46098 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -46049,13 +46102,13 @@ module Tables = struct # 962 "mlx/parser.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 46053 "mlx/parser.ml" +# 46106 "mlx/parser.ml" in # 126 "" ( Some x ) -# 46059 "mlx/parser.ml" +# 46112 "mlx/parser.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -46067,7 +46120,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 46071 "mlx/parser.ml" +# 46124 "mlx/parser.ml" in let _endpos = _endpos_arg_ in @@ -46076,7 +46129,7 @@ module Tables = struct # 3726 "mlx/parser.mly" ( mk_directive ~loc:_sloc dir arg ) -# 46080 "mlx/parser.ml" +# 46133 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46109,7 +46162,7 @@ module Tables = struct let _1_inlined2 : ( # 699 "mlx/parser.mly" (string * char option) -# 46113 "mlx/parser.ml" +# 46166 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let _1_inlined1 : (string) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in @@ -46122,7 +46175,7 @@ module Tables = struct let _1 = # 3731 "mlx/parser.mly" ( let (n, m) = _1 in Pdir_int (n ,m) ) -# 46126 "mlx/parser.ml" +# 46179 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -46130,13 +46183,13 @@ module Tables = struct # 962 "mlx/parser.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 46134 "mlx/parser.ml" +# 46187 "mlx/parser.ml" in # 126 "" ( Some x ) -# 46140 "mlx/parser.ml" +# 46193 "mlx/parser.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -46148,7 +46201,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 46152 "mlx/parser.ml" +# 46205 "mlx/parser.ml" in let _endpos = _endpos_arg_ in @@ -46157,7 +46210,7 @@ module Tables = struct # 3726 "mlx/parser.mly" ( mk_directive ~loc:_sloc dir arg ) -# 46161 "mlx/parser.ml" +# 46214 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46199,7 +46252,7 @@ module Tables = struct let _1 = # 3732 "mlx/parser.mly" ( Pdir_ident _1 ) -# 46203 "mlx/parser.ml" +# 46256 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -46207,13 +46260,13 @@ module Tables = struct # 962 "mlx/parser.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 46211 "mlx/parser.ml" +# 46264 "mlx/parser.ml" in # 126 "" ( Some x ) -# 46217 "mlx/parser.ml" +# 46270 "mlx/parser.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -46225,7 +46278,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 46229 "mlx/parser.ml" +# 46282 "mlx/parser.ml" in let _endpos = _endpos_arg_ in @@ -46234,7 +46287,7 @@ module Tables = struct # 3726 "mlx/parser.mly" ( mk_directive ~loc:_sloc dir arg ) -# 46238 "mlx/parser.ml" +# 46291 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46276,7 +46329,7 @@ module Tables = struct let _1 = # 3733 "mlx/parser.mly" ( Pdir_ident _1 ) -# 46280 "mlx/parser.ml" +# 46333 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -46284,13 +46337,13 @@ module Tables = struct # 962 "mlx/parser.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 46288 "mlx/parser.ml" +# 46341 "mlx/parser.ml" in # 126 "" ( Some x ) -# 46294 "mlx/parser.ml" +# 46347 "mlx/parser.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -46302,7 +46355,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 46306 "mlx/parser.ml" +# 46359 "mlx/parser.ml" in let _endpos = _endpos_arg_ in @@ -46311,7 +46364,7 @@ module Tables = struct # 3726 "mlx/parser.mly" ( mk_directive ~loc:_sloc dir arg ) -# 46315 "mlx/parser.ml" +# 46368 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46348,12 +46401,12 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined2_ in let _v : (Parsetree.toplevel_phrase) = let arg = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos__1_inlined2_) in + let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = # 3734 "mlx/parser.mly" ( Pdir_bool false ) -# 46357 "mlx/parser.ml" +# 46410 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -46361,13 +46414,13 @@ module Tables = struct # 962 "mlx/parser.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 46365 "mlx/parser.ml" +# 46418 "mlx/parser.ml" in # 126 "" ( Some x ) -# 46371 "mlx/parser.ml" +# 46424 "mlx/parser.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -46379,7 +46432,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 46383 "mlx/parser.ml" +# 46436 "mlx/parser.ml" in let _endpos = _endpos_arg_ in @@ -46388,7 +46441,7 @@ module Tables = struct # 3726 "mlx/parser.mly" ( mk_directive ~loc:_sloc dir arg ) -# 46392 "mlx/parser.ml" +# 46445 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46425,12 +46478,12 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined2_ in let _v : (Parsetree.toplevel_phrase) = let arg = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos__1_inlined2_) in + let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = # 3735 "mlx/parser.mly" ( Pdir_bool true ) -# 46434 "mlx/parser.ml" +# 46487 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -46438,13 +46491,13 @@ module Tables = struct # 962 "mlx/parser.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 46442 "mlx/parser.ml" +# 46495 "mlx/parser.ml" in # 126 "" ( Some x ) -# 46448 "mlx/parser.ml" +# 46501 "mlx/parser.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -46456,7 +46509,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 46460 "mlx/parser.ml" +# 46513 "mlx/parser.ml" in let _endpos = _endpos_arg_ in @@ -46465,7 +46518,7 @@ module Tables = struct # 3726 "mlx/parser.mly" ( mk_directive ~loc:_sloc dir arg ) -# 46469 "mlx/parser.ml" +# 46522 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46507,12 +46560,12 @@ module Tables = struct let attrs = # 3918 "mlx/parser.mly" ( _1 ) -# 46511 "mlx/parser.ml" +# 46564 "mlx/parser.ml" in # 1408 "mlx/parser.mly" ( mkstrexp e attrs ) -# 46516 "mlx/parser.ml" +# 46569 "mlx/parser.ml" in let _startpos__1_ = _startpos_e_ in @@ -46520,7 +46573,7 @@ module Tables = struct # 905 "mlx/parser.mly" ( text_str _startpos @ [_1] ) -# 46524 "mlx/parser.ml" +# 46577 "mlx/parser.ml" in let _startpos__1_ = _startpos_e_ in @@ -46529,13 +46582,13 @@ module Tables = struct # 893 "mlx/parser.mly" ( extra_str _startpos _endpos _1 ) -# 46533 "mlx/parser.ml" +# 46586 "mlx/parser.ml" in # 1172 "mlx/parser.mly" ( Ptop_def _1 ) -# 46539 "mlx/parser.ml" +# 46592 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46568,7 +46621,7 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 46572 "mlx/parser.ml" +# 46625 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in let _endpos = _endpos__1_ in @@ -46576,13 +46629,13 @@ module Tables = struct # 893 "mlx/parser.mly" ( extra_str _startpos _endpos _1 ) -# 46580 "mlx/parser.ml" +# 46633 "mlx/parser.ml" in # 1176 "mlx/parser.mly" ( Ptop_def _1 ) -# 46586 "mlx/parser.ml" +# 46639 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46614,7 +46667,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase) = # 1180 "mlx/parser.mly" ( _1 ) -# 46618 "mlx/parser.ml" +# 46671 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46639,7 +46692,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase) = # 1183 "mlx/parser.mly" ( raise End_of_file ) -# 46643 "mlx/parser.ml" +# 46696 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46664,7 +46717,7 @@ module Tables = struct let _v : (Parsetree.core_type) = # 3410 "mlx/parser.mly" ( ty ) -# 46668 "mlx/parser.ml" +# 46721 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46692,18 +46745,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 46696 "mlx/parser.ml" +# 46749 "mlx/parser.ml" in # 1063 "mlx/parser.mly" ( xs ) -# 46701 "mlx/parser.ml" +# 46754 "mlx/parser.ml" in # 3413 "mlx/parser.mly" ( Ptyp_tuple tys ) -# 46707 "mlx/parser.ml" +# 46760 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -46713,13 +46766,13 @@ module Tables = struct # 938 "mlx/parser.mly" ( mktyp ~loc:_sloc _1 ) -# 46717 "mlx/parser.ml" +# 46770 "mlx/parser.ml" in # 3415 "mlx/parser.mly" ( _1 ) -# 46723 "mlx/parser.ml" +# 46776 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46751,7 +46804,7 @@ module Tables = struct let _v : (Parsetree.core_type option * Parsetree.core_type option) = # 2732 "mlx/parser.mly" ( (Some _2, None) ) -# 46755 "mlx/parser.ml" +# 46808 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46797,7 +46850,7 @@ module Tables = struct let _v : (Parsetree.core_type option * Parsetree.core_type option) = # 2733 "mlx/parser.mly" ( (Some _2, Some _4) ) -# 46801 "mlx/parser.ml" +# 46854 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46829,7 +46882,7 @@ module Tables = struct let _v : (Parsetree.core_type option * Parsetree.core_type option) = # 2734 "mlx/parser.mly" ( (None, Some _2) ) -# 46833 "mlx/parser.ml" +# 46886 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46861,7 +46914,7 @@ module Tables = struct let _v : (Parsetree.core_type option * Parsetree.core_type option) = # 2735 "mlx/parser.mly" ( syntax_error() ) -# 46865 "mlx/parser.ml" +# 46918 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46893,7 +46946,7 @@ module Tables = struct let _v : (Parsetree.core_type option * Parsetree.core_type option) = # 2736 "mlx/parser.mly" ( syntax_error() ) -# 46897 "mlx/parser.ml" +# 46950 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46911,7 +46964,7 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = # 3065 "mlx/parser.mly" ( (Ptype_abstract, Public, None) ) -# 46915 "mlx/parser.ml" +# 46968 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46943,7 +46996,7 @@ module Tables = struct let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = # 3067 "mlx/parser.mly" ( _2 ) -# 46947 "mlx/parser.ml" +# 47000 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -46968,7 +47021,7 @@ module Tables = struct let _v : (Longident.t) = # 3687 "mlx/parser.mly" ( _1 ) -# 46972 "mlx/parser.ml" +# 47025 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47000,7 +47053,7 @@ module Tables = struct let _v : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) = # 3082 "mlx/parser.mly" ( _2, _1 ) -# 47004 "mlx/parser.ml" +# 47057 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47018,7 +47071,7 @@ module Tables = struct let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = # 3075 "mlx/parser.mly" ( [] ) -# 47022 "mlx/parser.ml" +# 47075 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47043,7 +47096,7 @@ module Tables = struct let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = # 3077 "mlx/parser.mly" ( [p] ) -# 47047 "mlx/parser.ml" +# 47100 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47083,18 +47136,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 47087 "mlx/parser.ml" +# 47140 "mlx/parser.ml" in # 1035 "mlx/parser.mly" ( xs ) -# 47092 "mlx/parser.ml" +# 47145 "mlx/parser.ml" in # 3079 "mlx/parser.mly" ( ps ) -# 47098 "mlx/parser.ml" +# 47151 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47127,7 +47180,7 @@ module Tables = struct let _1 = # 3087 "mlx/parser.mly" ( Ptyp_var tyvar ) -# 47131 "mlx/parser.ml" +# 47184 "mlx/parser.ml" in let _endpos__1_ = _endpos_tyvar_ in let _endpos = _endpos__1_ in @@ -47136,13 +47189,13 @@ module Tables = struct # 938 "mlx/parser.mly" ( mktyp ~loc:_sloc _1 ) -# 47140 "mlx/parser.ml" +# 47193 "mlx/parser.ml" in # 3090 "mlx/parser.mly" ( _1 ) -# 47146 "mlx/parser.ml" +# 47199 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47168,7 +47221,7 @@ module Tables = struct let _1 = # 3089 "mlx/parser.mly" ( Ptyp_any ) -# 47172 "mlx/parser.ml" +# 47225 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -47176,13 +47229,13 @@ module Tables = struct # 938 "mlx/parser.mly" ( mktyp ~loc:_sloc _1 ) -# 47180 "mlx/parser.ml" +# 47233 "mlx/parser.ml" in # 3090 "mlx/parser.mly" ( _1 ) -# 47186 "mlx/parser.ml" +# 47239 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47200,7 +47253,7 @@ module Tables = struct let _v : (Asttypes.variance * Asttypes.injectivity) = # 3094 "mlx/parser.mly" ( NoVariance, NoInjectivity ) -# 47204 "mlx/parser.ml" +# 47257 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47225,7 +47278,7 @@ module Tables = struct let _v : (Asttypes.variance * Asttypes.injectivity) = # 3095 "mlx/parser.mly" ( Covariant, NoInjectivity ) -# 47229 "mlx/parser.ml" +# 47282 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47250,7 +47303,7 @@ module Tables = struct let _v : (Asttypes.variance * Asttypes.injectivity) = # 3096 "mlx/parser.mly" ( Contravariant, NoInjectivity ) -# 47254 "mlx/parser.ml" +# 47307 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47275,7 +47328,7 @@ module Tables = struct let _v : (Asttypes.variance * Asttypes.injectivity) = # 3097 "mlx/parser.mly" ( NoVariance, Injective ) -# 47279 "mlx/parser.ml" +# 47332 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47307,7 +47360,7 @@ module Tables = struct let _v : (Asttypes.variance * Asttypes.injectivity) = # 3098 "mlx/parser.mly" ( Covariant, Injective ) -# 47311 "mlx/parser.ml" +# 47364 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47339,7 +47392,7 @@ module Tables = struct let _v : (Asttypes.variance * Asttypes.injectivity) = # 3098 "mlx/parser.mly" ( Covariant, Injective ) -# 47343 "mlx/parser.ml" +# 47396 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47371,7 +47424,7 @@ module Tables = struct let _v : (Asttypes.variance * Asttypes.injectivity) = # 3099 "mlx/parser.mly" ( Contravariant, Injective ) -# 47375 "mlx/parser.ml" +# 47428 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47403,7 +47456,7 @@ module Tables = struct let _v : (Asttypes.variance * Asttypes.injectivity) = # 3099 "mlx/parser.mly" ( Contravariant, Injective ) -# 47407 "mlx/parser.ml" +# 47460 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47424,7 +47477,7 @@ module Tables = struct let _1 : ( # 691 "mlx/parser.mly" (string) -# 47428 "mlx/parser.ml" +# 47481 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -47435,7 +47488,7 @@ module Tables = struct ( if _1 = "+!" then Covariant, Injective else if _1 = "-!" then Contravariant, Injective else expecting _loc__1_ "type_variance" ) -# 47439 "mlx/parser.ml" +# 47492 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47456,7 +47509,7 @@ module Tables = struct let _1 : ( # 740 "mlx/parser.mly" (string) -# 47460 "mlx/parser.ml" +# 47513 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -47467,7 +47520,7 @@ module Tables = struct ( if _1 = "!+" then Covariant, Injective else if _1 = "!-" then Contravariant, Injective else expecting _loc__1_ "type_variance" ) -# 47471 "mlx/parser.ml" +# 47524 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47501,24 +47554,24 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 47505 "mlx/parser.ml" +# 47558 "mlx/parser.ml" in let xs = let _1 = # 971 "mlx/parser.mly" ( [] ) -# 47511 "mlx/parser.ml" +# 47564 "mlx/parser.ml" in # 1203 "mlx/parser.mly" ( _1 ) -# 47516 "mlx/parser.ml" +# 47569 "mlx/parser.ml" in # 267 "" ( xs @ ys ) -# 47522 "mlx/parser.ml" +# 47575 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in @@ -47527,13 +47580,13 @@ module Tables = struct # 897 "mlx/parser.mly" ( extra_def _startpos _endpos _1 ) -# 47531 "mlx/parser.ml" +# 47584 "mlx/parser.ml" in # 1196 "mlx/parser.mly" ( _1 ) -# 47537 "mlx/parser.ml" +# 47590 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47581,7 +47634,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 47585 "mlx/parser.ml" +# 47638 "mlx/parser.ml" in let xs = let _1 = @@ -47591,18 +47644,18 @@ module Tables = struct let attrs = # 3918 "mlx/parser.mly" ( _1 ) -# 47595 "mlx/parser.ml" +# 47648 "mlx/parser.ml" in # 1408 "mlx/parser.mly" ( mkstrexp e attrs ) -# 47600 "mlx/parser.ml" +# 47653 "mlx/parser.ml" in # 915 "mlx/parser.mly" ( Ptop_def [_1] ) -# 47606 "mlx/parser.ml" +# 47659 "mlx/parser.ml" in let _startpos__1_ = _startpos_e_ in @@ -47610,25 +47663,25 @@ module Tables = struct # 913 "mlx/parser.mly" ( text_def _startpos @ [_1] ) -# 47614 "mlx/parser.ml" +# 47667 "mlx/parser.ml" in # 973 "mlx/parser.mly" ( x ) -# 47620 "mlx/parser.ml" +# 47673 "mlx/parser.ml" in # 1203 "mlx/parser.mly" ( _1 ) -# 47626 "mlx/parser.ml" +# 47679 "mlx/parser.ml" in # 267 "" ( xs @ ys ) -# 47632 "mlx/parser.ml" +# 47685 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_e_) in @@ -47637,13 +47690,13 @@ module Tables = struct # 897 "mlx/parser.mly" ( extra_def _startpos _endpos _1 ) -# 47641 "mlx/parser.ml" +# 47694 "mlx/parser.ml" in # 1196 "mlx/parser.mly" ( _1 ) -# 47647 "mlx/parser.ml" +# 47700 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47682,7 +47735,7 @@ module Tables = struct let _v : (string) = # 3588 "mlx/parser.mly" ( _2 ) -# 47686 "mlx/parser.ml" +# 47739 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47723,7 +47776,7 @@ module Tables = struct # 3589 "mlx/parser.mly" ( unclosed "(" _loc__1_ ")" _loc__3_ ) -# 47727 "mlx/parser.ml" +# 47780 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47756,7 +47809,7 @@ module Tables = struct # 3590 "mlx/parser.mly" ( expecting _loc__2_ "operator" ) -# 47760 "mlx/parser.ml" +# 47813 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47796,7 +47849,7 @@ module Tables = struct # 3591 "mlx/parser.mly" ( expecting _loc__3_ "module-expr" ) -# 47800 "mlx/parser.ml" +# 47853 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47817,7 +47870,7 @@ module Tables = struct let _1 : ( # 714 "mlx/parser.mly" (string) -# 47821 "mlx/parser.ml" +# 47874 "mlx/parser.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -47825,7 +47878,7 @@ module Tables = struct let _v : (string) = # 3594 "mlx/parser.mly" ( _1 ) -# 47829 "mlx/parser.ml" +# 47882 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47850,7 +47903,7 @@ module Tables = struct let _v : (string) = # 3595 "mlx/parser.mly" ( _1 ) -# 47854 "mlx/parser.ml" +# 47907 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47875,7 +47928,7 @@ module Tables = struct let _v : (Longident.t) = # 3681 "mlx/parser.mly" ( _1 ) -# 47879 "mlx/parser.ml" +# 47932 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -47922,7 +47975,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 47926 "mlx/parser.ml" +# 47979 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let mutable_ : (Asttypes.mutable_flag) = Obj.magic mutable_ in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -47935,7 +47988,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 47939 "mlx/parser.ml" +# 47992 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -47943,23 +47996,23 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 47947 "mlx/parser.ml" +# 48000 "mlx/parser.ml" in let attrs = # 3922 "mlx/parser.mly" ( _1 ) -# 47953 "mlx/parser.ml" +# 48006 "mlx/parser.ml" in let _1 = # 3821 "mlx/parser.mly" ( Fresh ) -# 47958 "mlx/parser.ml" +# 48011 "mlx/parser.ml" in # 1988 "mlx/parser.mly" ( (label, mutable_, Cfk_virtual ty), attrs ) -# 47963 "mlx/parser.ml" +# 48016 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48006,7 +48059,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 48010 "mlx/parser.ml" +# 48063 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -48019,7 +48072,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 48023 "mlx/parser.ml" +# 48076 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -48027,23 +48080,23 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 48031 "mlx/parser.ml" +# 48084 "mlx/parser.ml" in let _2 = # 3922 "mlx/parser.mly" ( _1 ) -# 48037 "mlx/parser.ml" +# 48090 "mlx/parser.ml" in let _1 = # 3824 "mlx/parser.mly" ( Fresh ) -# 48042 "mlx/parser.ml" +# 48095 "mlx/parser.ml" in # 1990 "mlx/parser.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 48047 "mlx/parser.ml" +# 48100 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48096,7 +48149,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 48100 "mlx/parser.ml" +# 48153 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -48110,7 +48163,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 48114 "mlx/parser.ml" +# 48167 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -48118,7 +48171,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 48122 "mlx/parser.ml" +# 48175 "mlx/parser.ml" in let _2 = @@ -48126,18 +48179,18 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 48130 "mlx/parser.ml" +# 48183 "mlx/parser.ml" in let _1 = # 3825 "mlx/parser.mly" ( Override ) -# 48136 "mlx/parser.ml" +# 48189 "mlx/parser.ml" in # 1990 "mlx/parser.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 48141 "mlx/parser.ml" +# 48194 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48191,7 +48244,7 @@ module Tables = struct let _1_inlined1 : ( # 714 "mlx/parser.mly" (string) -# 48195 "mlx/parser.ml" +# 48248 "mlx/parser.ml" ) = Obj.magic _1_inlined1 in let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -48204,7 +48257,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 48208 "mlx/parser.ml" +# 48261 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -48212,20 +48265,20 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 48216 "mlx/parser.ml" +# 48269 "mlx/parser.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = # 3922 "mlx/parser.mly" ( _1 ) -# 48223 "mlx/parser.ml" +# 48276 "mlx/parser.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = # 3824 "mlx/parser.mly" ( Fresh ) -# 48229 "mlx/parser.ml" +# 48282 "mlx/parser.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__7_ in @@ -48245,7 +48298,7 @@ module Tables = struct ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 48249 "mlx/parser.ml" +# 48302 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48305,7 +48358,7 @@ module Tables = struct let _1_inlined2 : ( # 714 "mlx/parser.mly" (string) -# 48309 "mlx/parser.ml" +# 48362 "mlx/parser.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -48319,7 +48372,7 @@ module Tables = struct let _1 = # 3562 "mlx/parser.mly" ( _1 ) -# 48323 "mlx/parser.ml" +# 48376 "mlx/parser.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in @@ -48327,7 +48380,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 48331 "mlx/parser.ml" +# 48384 "mlx/parser.ml" in let _startpos__4_ = _startpos__1_inlined2_ in @@ -48336,14 +48389,14 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 48340 "mlx/parser.ml" +# 48393 "mlx/parser.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = # 3825 "mlx/parser.mly" ( Override ) -# 48347 "mlx/parser.ml" +# 48400 "mlx/parser.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -48362,7 +48415,7 @@ module Tables = struct ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 48366 "mlx/parser.ml" +# 48419 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48431,7 +48484,7 @@ module Tables = struct # 3918 "mlx/parser.mly" ( _1 ) -# 48435 "mlx/parser.ml" +# 48488 "mlx/parser.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -48443,7 +48496,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 48447 "mlx/parser.ml" +# 48500 "mlx/parser.ml" in let attrs1 = @@ -48451,7 +48504,7 @@ module Tables = struct # 3922 "mlx/parser.mly" ( _1 ) -# 48455 "mlx/parser.ml" +# 48508 "mlx/parser.ml" in let _endpos = _endpos_attrs2_ in @@ -48464,7 +48517,7 @@ module Tables = struct let docs = symbol_docs _sloc in Val.mk id ty ~attrs ~loc ~docs, ext ) -# 48468 "mlx/parser.ml" +# 48521 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48482,7 +48535,7 @@ module Tables = struct let _v : (Asttypes.virtual_flag) = # 3785 "mlx/parser.mly" ( Concrete ) -# 48486 "mlx/parser.ml" +# 48539 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48507,7 +48560,7 @@ module Tables = struct let _v : (Asttypes.virtual_flag) = # 3786 "mlx/parser.mly" ( Virtual ) -# 48511 "mlx/parser.ml" +# 48564 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48532,7 +48585,7 @@ module Tables = struct let _v : (Asttypes.mutable_flag) = # 3809 "mlx/parser.mly" ( Immutable ) -# 48536 "mlx/parser.ml" +# 48589 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48564,7 +48617,7 @@ module Tables = struct let _v : (Asttypes.mutable_flag) = # 3810 "mlx/parser.mly" ( Mutable ) -# 48568 "mlx/parser.ml" +# 48621 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48596,7 +48649,7 @@ module Tables = struct let _v : (Asttypes.mutable_flag) = # 3811 "mlx/parser.mly" ( Mutable ) -# 48600 "mlx/parser.ml" +# 48653 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48621,7 +48674,7 @@ module Tables = struct let _v : (Asttypes.private_flag) = # 3816 "mlx/parser.mly" ( Public ) -# 48625 "mlx/parser.ml" +# 48678 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48653,7 +48706,7 @@ module Tables = struct let _v : (Asttypes.private_flag) = # 3817 "mlx/parser.mly" ( Private ) -# 48657 "mlx/parser.ml" +# 48710 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48685,7 +48738,7 @@ module Tables = struct let _v : (Asttypes.private_flag) = # 3818 "mlx/parser.mly" ( Private ) -# 48689 "mlx/parser.ml" +# 48742 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48747,18 +48800,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 48751 "mlx/parser.ml" +# 48804 "mlx/parser.ml" in # 985 "mlx/parser.mly" ( xs ) -# 48756 "mlx/parser.ml" +# 48809 "mlx/parser.ml" in # 3036 "mlx/parser.mly" ( _1 ) -# 48762 "mlx/parser.ml" +# 48815 "mlx/parser.ml" in let _endpos__6_ = _endpos_xs_ in @@ -48767,7 +48820,7 @@ module Tables = struct # 3358 "mlx/parser.mly" ( _1 ) -# 48771 "mlx/parser.ml" +# 48824 "mlx/parser.ml" in let _3 = @@ -48778,7 +48831,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 48782 "mlx/parser.ml" +# 48835 "mlx/parser.ml" in let _endpos = _endpos__6_ in @@ -48795,7 +48848,7 @@ module Tables = struct ~manifest:_5 ~priv:_4 ~loc:(make_loc _sloc))) ) -# 48799 "mlx/parser.ml" +# 48852 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48850,7 +48903,7 @@ module Tables = struct # 3358 "mlx/parser.mly" ( _1 ) -# 48854 "mlx/parser.ml" +# 48907 "mlx/parser.ml" in let _endpos__5_ = _endpos__1_inlined2_ in @@ -48862,7 +48915,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 48866 "mlx/parser.ml" +# 48919 "mlx/parser.ml" in let _endpos = _endpos__5_ in @@ -48877,7 +48930,7 @@ module Tables = struct ~params:_2 ~manifest:_5 ~loc:(make_loc _sloc))) ) -# 48881 "mlx/parser.ml" +# 48934 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48928,7 +48981,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 48932 "mlx/parser.ml" +# 48985 "mlx/parser.ml" in let _2 = @@ -48939,13 +48992,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 48943 "mlx/parser.ml" +# 48996 "mlx/parser.ml" in # 3298 "mlx/parser.mly" ( Pwith_module (_2, _4) ) -# 48949 "mlx/parser.ml" +# 49002 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -48996,7 +49049,7 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 49000 "mlx/parser.ml" +# 49053 "mlx/parser.ml" in let _2 = @@ -49007,13 +49060,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 49011 "mlx/parser.ml" +# 49064 "mlx/parser.ml" in # 3300 "mlx/parser.mly" ( Pwith_modsubst (_2, _4) ) -# 49017 "mlx/parser.ml" +# 49070 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -49071,13 +49124,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 49075 "mlx/parser.ml" +# 49128 "mlx/parser.ml" in # 3302 "mlx/parser.mly" ( Pwith_modtype (l, rhs) ) -# 49081 "mlx/parser.ml" +# 49134 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -49135,13 +49188,13 @@ module Tables = struct # 901 "mlx/parser.mly" ( mkrhs _1 _sloc ) -# 49139 "mlx/parser.ml" +# 49192 "mlx/parser.ml" in # 3304 "mlx/parser.mly" ( Pwith_modtypesubst (l, rhs) ) -# 49145 "mlx/parser.ml" +# 49198 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -49166,7 +49219,7 @@ module Tables = struct let _v : (Asttypes.private_flag) = # 3307 "mlx/parser.mly" ( Public ) -# 49170 "mlx/parser.ml" +# 49223 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -49198,7 +49251,7 @@ module Tables = struct let _v : (Asttypes.private_flag) = # 3308 "mlx/parser.mly" ( Private ) -# 49202 "mlx/parser.ml" +# 49255 "mlx/parser.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -49351,9 +49404,9 @@ end # 3954 "mlx/parser.mly" -# 49355 "mlx/parser.ml" +# 49408 "mlx/parser.ml" # 269 "" -# 49360 "mlx/parser.ml" +# 49413 "mlx/parser.ml" diff --git a/mlx/pp.ml b/mlx/pp.ml index 0267556..81fc498 100644 --- a/mlx/pp.ml +++ b/mlx/pp.ml @@ -2,7 +2,10 @@ let print_ml = ref false let input = ref None let speclist = [ "-print-ml", Arg.Set print_ml, "Print .ml syntax" ] -module Conv = Ppxlib_ast.Convert(Ppxlib_ast__Versions.OCaml_501)(Ppxlib_ast.Compiler_version) +module Conv = + Ppxlib_ast.Convert + (Ppxlib_ast__Versions.OCaml_501) + (Ppxlib_ast.Compiler_version) let () = Arg.parse speclist @@ -29,7 +32,8 @@ let () = if !print_ml then Format.printf "%a@." Pprintast.structure str else let oc = stdout in - output_string oc Config.ast_impl_magic_number; + output_string oc + Ppxlib_ast.Compiler_version.Ast.Config.ast_impl_magic_number; output_value oc fname; output_value oc str | Error `Already_displayed -> exit 1 diff --git a/ocamlmerlin-mlx.opam b/ocamlmerlin-mlx.opam index 45f59fa..42acc2e 100644 --- a/ocamlmerlin-mlx.opam +++ b/ocamlmerlin-mlx.opam @@ -13,7 +13,7 @@ depends: [ "merlin-lib" "csexp" {with-dev-setup} "cppo" - "menhir" {= "20210419" & with-dev-setup} + "menhir" {= "20201216" & with-dev-setup} "odoc" {with-doc} ] build: [ diff --git a/ocamlmerlin_mlx/dune b/ocamlmerlin_mlx/dune index 4b5153f..57d7287 100644 --- a/ocamlmerlin_mlx/dune +++ b/ocamlmerlin_mlx/dune @@ -3,12 +3,15 @@ (package ocamlmerlin-mlx) (public_name ocamlmerlin-mlx) (modules ocamlmerlin_mlx) - (libraries mlx_preprocess mlx_kernel)) - -(rule - (targets extend_helper.ml) - (deps extend_helper.cppo.ml) - (action - (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) - -(copy_files# ../merlin-extend/*[!extend_helper].{ml,mli}) + (flags + :standard + -open=Mlx_utils + -open=Mlx_kernel + -open=Mlx_ocaml_preprocess) + (libraries + mlx_ocaml_preprocess + mlx_kernel + merlin-lib.extend + merlin-lib.kernel + ppxlib + compiler-libs.common)) diff --git a/ocamlmerlin_mlx/extend/dune b/ocamlmerlin_mlx/extend/dune new file mode 100644 index 0000000..88173a1 --- /dev/null +++ b/ocamlmerlin_mlx/extend/dune @@ -0,0 +1,20 @@ +(library + (name mlx_extend) + (package ocamlmerlin-mlx) + (modules + (:standard \ extend_helper)) + (flags + :standard + -open + Mlx_ocaml_utils + -open + Mlx_ocaml_parsing + -open + Mlx_ocaml_typing) + (libraries mlx_ocaml_parsing mlx_ocaml_typing unix mlx_ocaml_utils)) + +(copy_files# + (enabled_if + (<> %{profile} "release")) + (mode promote) + (files %{project_root}/merlin/src/extend/*.{ml,mli})) diff --git a/ocamlmerlin_mlx/extend/extend_driver.ml b/ocamlmerlin_mlx/extend/extend_driver.ml new file mode 100644 index 0000000..27cfe3c --- /dev/null +++ b/ocamlmerlin_mlx/extend/extend_driver.ml @@ -0,0 +1,67 @@ +# 1 "merlin/src/extend/extend_driver.ml" +module P = Extend_protocol + +(** Helper for the driver (Merlin) *) + +type t = { + name: string; + capabilities: P.capabilities; + stdin: out_channel; + stdout: in_channel; + mutable pid: int; + + notify: string -> unit; + debug: string -> unit; +} + +exception Extension of string * string * string + +let run ?(notify=ignore) ?(debug=ignore) name = + let pstdin, stdin = Unix.pipe () in + let stdout, pstdout = Unix.pipe () in + Unix.set_close_on_exec pstdin; + Unix.set_close_on_exec stdin; + Unix.set_close_on_exec pstdout; + Unix.set_close_on_exec stdout; + let pid = + Unix.create_process + ("ocamlmerlin-" ^ name) [||] + pstdin pstdout Unix.stderr + in + Unix.close pstdout; + Unix.close pstdin; + let stdin = Unix.out_channel_of_descr stdin in + let stdout = Unix.in_channel_of_descr stdout in + match Extend_main.Handshake.negotiate_driver name stdout stdin with + | capabilities -> {name; capabilities; stdin; stdout; pid; notify; debug} + | exception exn -> + close_out_noerr stdin; + close_in_noerr stdout; + raise exn + +let stop t = + close_out_noerr t.stdin; + close_in_noerr t.stdout; + if t.pid <> -1 then ( + let _, _ = Unix.waitpid [] t.pid in + t.pid <- -1; + ) + +let capabilities t = t.capabilities + +let reader t request = + if t.pid = -1 then + invalid_arg "Extend_main.Driver.reader: extension is closed"; + output_value t.stdin (P.Reader_request request); + flush t.stdin; + let rec aux () = + match input_value t.stdout with + | P.Notify str -> t.notify str; aux () + | P.Debug str -> t.debug str; aux () + | P.Exception (kind, msg) -> + stop t; + raise (Extension (t.name, kind, msg)) + | P.Reader_response response -> + response + in + aux () diff --git a/ocamlmerlin_mlx/extend/extend_driver.mli b/ocamlmerlin_mlx/extend/extend_driver.mli new file mode 100644 index 0000000..955b445 --- /dev/null +++ b/ocamlmerlin_mlx/extend/extend_driver.mli @@ -0,0 +1,17 @@ +# 1 "merlin/src/extend/extend_driver.mli" +(** Helper for the driver (Merlin) *) +open Extend_protocol + +type t + +exception Extension of string * string * string + +val run : ?notify:(string -> unit) -> ?debug:(string -> unit) -> string -> t + +val stop : t -> unit + +val capabilities : t -> capabilities + +val reader : t -> + Reader.request -> + Reader.response diff --git a/ocamlmerlin_mlx/extend/extend_helper.ml b/ocamlmerlin_mlx/extend/extend_helper.ml new file mode 100644 index 0000000..27f227a --- /dev/null +++ b/ocamlmerlin_mlx/extend/extend_helper.ml @@ -0,0 +1,103 @@ +# 1 "merlin/src/extend/extend_helper.ml" +open Parsetree + +(** Generate an extension node that will be reported as a syntax error by + Merlin. *) +let syntax_error msg loc : extension = + let str = Location.mkloc "merlin.syntax-error" loc in + let payload = PStr [{ + pstr_loc = Location.none; + pstr_desc = Pstr_eval ( + Ast_helper.(Exp.constant (const_string msg)), [] + ); + }] + in + (str, payload) +;; + + +(** Physical locations might be too precise for some features. + + For instance in: + let x = f in y + ^1 ^2 + + Merlin cannot distinguish position ^1 from ^2 in the normal AST, + because IN doesn't appear in abstract syntax. This is a problem when + completing, because a different environment should be selected for both + positions. + + One can add relaxed_location attributes to make some locations closer to + the concrete syntax. + + Here is the same line annotated with physical and relaxed locations: + let x = f in y + [ ] [ ] -- physical locations for f and y nodes + [ ][ ] -- relaxed locations for f and y nodes +*) +let relaxed_location loc : attribute = + let str = Location.mkloc "merlin.relaxed-location" loc in + Ast_helper.Attr.mk str (PStr []) +;; + + +(** If some code should be ignored by merlin when reporting information to + the user, put a hide_node attribute. + + This is useful for generated/desugared code which doesn't correspond to + anything in concrete syntax (example use-case: encoding of some + js_of_ocaml constructs). +*) +let hide_node : attribute = + Ast_helper.Attr.mk (Location.mknoloc "merlin.hide") (PStr []) + +(** The converse: when merlin should focus on a specific node of the AST. + The main use case is also for js_of_ocaml. + + Assuming is translated to: + + let module M = struct + let prolog = ... (* boilerplate *) + + let code = + + let epilog = ... (* boilerplate *) + end + in M.boilerplate + + To make merlin focus on [M.code] and ignore the boilerplate ([M.prolog] + and [M.epilog]), add a [focus_node] attribute to the [M.code] item. +*) +let focus_node : attribute = + Ast_helper.Attr.mk (Location.mknoloc "merlin.focus") (PStr []) + +(* Projections for merlin attributes and extensions *) + +let classify_extension (id, _ : extension) : [`Other | `Syntax_error] = + match id.Location.txt with + | "merlin.syntax-error" -> `Syntax_error + | _ -> `Other + +let classify_attribute attr : [`Other | `Relaxed_location | `Hide | `Focus] = + let id, _ = Ast_helper.Attr.as_tuple attr in + match id.Location.txt with + | "merlin.relaxed-location" -> `Relaxed_location + | "merlin.hide" -> `Hide + | "merlin.focus" -> `Focus + | _ -> `Other + +let extract_syntax_error (id, payload : extension) : string * Location.t = + if id.Location.txt <> "merlin.syntax-error" then + invalid_arg "Merlin_extend.Reader_helper.extract_syntax_error"; + let invalid_msg = + "Warning: extension produced an incorrect syntax-error node" in + let msg = match Ast_helper.extract_str_payload payload with + | Some (msg, _loc) -> msg + | None -> invalid_msg + in + msg, id.Location.loc + +let extract_relaxed_location attr : Location.t = + match Ast_helper.Attr.as_tuple attr with + | ({Location. txt = "merlin.relaxed-location"; loc} , _) -> loc + | _ -> invalid_arg "Merlin_extend.Reader_helper.extract_relaxed_location" diff --git a/ocamlmerlin_mlx/extend/extend_helper.mli b/ocamlmerlin_mlx/extend/extend_helper.mli new file mode 100644 index 0000000..68ff619 --- /dev/null +++ b/ocamlmerlin_mlx/extend/extend_helper.mli @@ -0,0 +1,67 @@ +# 1 "merlin/src/extend/extend_helper.mli" +open Parsetree + +(** Generate an extension node that will be reported as a syntax error by + Merlin. *) +val syntax_error : string -> Location.t -> extension + +(** Physical locations might be too precise for some features. + + For instance in: + let x = f in y + ^1 ^2 + + Merlin cannot distinguish position ^1 from ^2 in the normal AST, + because IN doesn't appear in abstract syntax. This is a problem when + completing, because a different environment should be selected for both + positions. + + One can add relaxed_location attributes to make some locations closer to + the concrete syntax. + + Here is the same line annotated with physical and relaxed locations: + let x = f in y + [ ] [ ] -- physical locations for f and y nodes + [ ][ ] -- relaxed locations for f and y nodes +*) +val relaxed_location : Location.t -> attribute + +(** If some code should be ignored by merlin when reporting information to + the user, put a hide_node attribute. + + This is useful for generated/desugared code which doesn't correspond to + anything in concrete syntax (example use-case: encoding of some + js_of_ocaml constructs). +*) +val hide_node : attribute + +(** The converse: when merlin should focus on a specific node of the AST. + The main use case is also for js_of_ocaml. + + Assuming is translated to: + + let module M = struct + let prolog = ... (* boilerplate *) + + let code = + + let epilog = ... (* boilerplate *) + end + in M.boilerplate + + To make merlin focus on [M.code] and ignore the boilerplate ([M.prolog] + and [M.epilog]), add a [focus_node] attribute to the [M.code] item. +*) +val focus_node : attribute + +(* Projections for merlin attributes and extensions *) + +val classify_extension : extension -> + [`Other | `Syntax_error] + +val extract_syntax_error : extension -> string * Location.t + +val classify_attribute : attribute -> + [`Other | `Relaxed_location | `Hide | `Focus] + +val extract_relaxed_location : attribute -> Location.t diff --git a/ocamlmerlin_mlx/extend/extend_main.ml b/ocamlmerlin_mlx/extend/extend_main.ml new file mode 100644 index 0000000..1b8df10 --- /dev/null +++ b/ocamlmerlin_mlx/extend/extend_main.ml @@ -0,0 +1,187 @@ +# 1 "merlin/src/extend/extend_main.ml" +module P = Extend_protocol +module R = P.Reader + +module Description = struct + type t = P.description + + let make_v0 ~name ~version = { P. name; version } +end + +module Reader = struct + type t = (module R.V0) + let make_v0 (x : (module R.V0)) : t = x + + module Make (V : R.V0) = struct + + open P.Reader + + let buffer = ref None + + let get_buffer () = + match !buffer with + | None -> invalid_arg "No buffer loaded" + | Some buffer -> buffer + + let exec = function + | Req_load buf -> + buffer := Some (V.load buf); + Res_loaded + | Req_parse -> + Res_parse (V.parse (get_buffer ())) + | Req_parse_line (pos, str) -> + Res_parse (V.parse_line (get_buffer ()) pos str) + | Req_parse_for_completion pos -> + let info, tree = V.for_completion (get_buffer ()) pos in + Res_parse_for_completion (info, tree) + | Req_get_ident_at pos -> + Res_get_ident_at (V.ident_at (get_buffer ()) pos) + | Req_print_outcome trees -> + let print t = + V.print_outcome Format.str_formatter t; + Format.flush_str_formatter () + in + let trees = List.rev_map print trees in + Res_print_outcome (List.rev trees) + | Req_pretty_print p -> + V.pretty_print Format.str_formatter p; + Res_pretty_print (Format.flush_str_formatter ()) + + end +end + +module Utils = struct + + (* Postpone messages until ready *) + let send, set_ready = + let is_ready = ref false in + let postponed = ref [] in + let really_send msg = output_value stdout msg in + let set_ready () = + is_ready := true; + let postponed' = List.rev !postponed in + postponed := []; + List.iter really_send postponed' + in + let send msg = + if !is_ready then + really_send msg + else + postponed := msg :: !postponed + in + send, set_ready + + let notify msg = send (P.Notify msg) + let debug msg = send (P.Debug msg) +end + +module Handshake = struct + let magic_number : string = "MERLINEXTEND002" + + type versions = { + ast_impl_magic_number : string; + ast_intf_magic_number : string; + cmi_magic_number : string; + cmt_magic_number : string; + } + + let versions = Config.({ + ast_impl_magic_number; + ast_intf_magic_number; + cmi_magic_number; + cmt_magic_number; + }) + + let negotiate (capabilities : P.capabilities) = + output_string stdout magic_number; + output_value stdout versions; + output_value stdout capabilities; + flush stdout; + Utils.set_ready (); + match input_value stdin with + | exception End_of_file -> exit 0 + | P.Start_communication -> () + | _ -> + prerr_endline "Unexpected value after handshake."; + exit 1 + + exception Error of string + + let () = + Printexc.register_printer (function + | Error msg -> + Some (Printf.sprintf "Extend_main.Handshake.Error %S" msg) + | _ -> None + ) + + let negotiate_driver ext_name i o = + let magic' = really_input_string i (String.length magic_number) in + if magic' <> magic_number then ( + let msg = Printf.sprintf + "Extension %s has incompatible protocol version %S (expected %S)" + ext_name magic' magic_number + in + raise (Error msg) + ); + let versions' : versions = input_value i in + let check_v prj name = + if prj versions <> prj versions' then + let msg = Printf.sprintf + "Extension %s %s has incompatible version %S (expected %S)" + ext_name name (prj versions') (prj versions) + in + raise (Error msg) + in + check_v (fun x -> x.ast_impl_magic_number) "implementation AST"; + check_v (fun x -> x.ast_intf_magic_number) "interface AST"; + check_v (fun x -> x.cmi_magic_number) "compiled interface (CMI)"; + check_v (fun x -> x.cmt_magic_number) "typedtree (CMT)"; + output_value o P.Start_communication; + flush o; + let capabilities : P.capabilities = + input_value i + in + capabilities +end + +(** The main entry point of an extension. *) +let extension_main ?reader desc = + (* Check if invoked from Merlin *) + begin match Sys.getenv "__MERLIN_MASTER_PID" with + | exception Not_found -> + Printf.eprintf "This is %s merlin extension, version %s.\n\ + This binary should be invoked from merlin and \ + cannot be used directly.\n%!" + desc.P.name + desc.P.version; + exit 1; + | _ -> () + end; + (* Communication happens on stdin/stdout. *) + Handshake.negotiate {P. reader = reader <> None}; + let reader = match reader with + | None -> (fun _ -> failwith "No reader") + | Some (module R : R.V0) -> + let module M = Reader.Make(R) in + M.exec + in + let respond f = + match f () with + | (r : P.response) -> Utils.send r + | exception exn -> + let name = Printexc.exn_slot_name exn in + let desc = Printexc.to_string exn in + Utils.send (P.Exception (name, desc)) + in + let rec loop () = + flush stdout; + match input_value stdin with + | exception End_of_file -> exit 0 + | P.Start_communication -> + prerr_endline "Unexpected message."; + exit 2 + | P.Reader_request request -> + respond (fun () -> P.Reader_response (reader request)); + loop () + in + loop () diff --git a/ocamlmerlin_mlx/extend/extend_main.mli b/ocamlmerlin_mlx/extend/extend_main.mli new file mode 100644 index 0000000..e22dd04 --- /dev/null +++ b/ocamlmerlin_mlx/extend/extend_main.mli @@ -0,0 +1,37 @@ +# 1 "merlin/src/extend/extend_main.mli" +open Extend_protocol + +module Description : sig + type t + val make_v0 : name:string -> version:string -> t +end + +module Utils : sig + val notify : string -> unit + val debug : string -> unit +end + +module Reader : sig + type t + val make_v0 : (module Reader.V0) -> t +end + +module Handshake : sig + val magic_number : string + + type versions = { + ast_impl_magic_number : string; + ast_intf_magic_number : string; + cmi_magic_number : string; + cmt_magic_number : string; + } + + exception Error of string + + val versions : versions + + val negotiate_driver : string -> in_channel -> out_channel -> capabilities +end + +(** The main entry point of an extension. *) +val extension_main : ?reader:Reader.t -> Description.t -> 'a diff --git a/ocamlmerlin_mlx/extend/extend_protocol.ml b/ocamlmerlin_mlx/extend/extend_protocol.ml new file mode 100644 index 0000000..8d849bd --- /dev/null +++ b/ocamlmerlin_mlx/extend/extend_protocol.ml @@ -0,0 +1,153 @@ +# 1 "merlin/src/extend/extend_protocol.ml" +module Reader = struct + + (** Description of a buffer managed by Merlin *) + type buffer = { + + path : string; + (** Path of the buffer in the editor. + The path is absolute if it is backed by a file, although it might not yet + have been saved in the editor. + The path is relative if it is a temporary buffer. *) + + flags : string list; + (** Any flag that has been passed to the reader in .merlin file *) + + text : string; + (** Content of the buffer *) + } + + (** ASTs exchanged with Merlin *) + type parsetree = + + | Structure of Parsetree.structure + (** An implementation, usually coming from a .ml file *) + + | Signature of Parsetree.signature + (** An interface, usually coming from a .mli file *) + + (** Printing in error messages or completion items *) + type outcometree = + | Out_value of Outcometree.out_value + | Out_type of Outcometree.out_type + | Out_class_type of Outcometree.out_class_type + | Out_module_type of Outcometree.out_module_type + | Out_sig_item of Outcometree.out_sig_item + | Out_signature of Outcometree.out_sig_item list + | Out_type_extension of Outcometree.out_type_extension + | Out_phrase of Outcometree.out_phrase + + (** Printing in case destruction *) + type pretty_parsetree = + | Pretty_toplevel_phrase of Parsetree.toplevel_phrase + | Pretty_expression of Parsetree.expression + | Pretty_core_type of Parsetree.core_type + | Pretty_pattern of Parsetree.pattern + | Pretty_signature of Parsetree.signature + | Pretty_structure of Parsetree.structure + | Pretty_case_list of Parsetree.case list + + (** Additional information useful for guiding completion *) + type complete_info = { + complete_labels : bool; + (** True if it is appropriate to suggest labels for this completion. *) + } + + module type V0 = sig + (** Internal representation of a buffer for the extension. + Extension should avoid global state, cached information should be stored + in values of this type. *) + type t + + (** Turns a merlin-buffer into an internal buffer. + + This function should be total, an exception at this point is a + fatal-error. + + Simplest implementation is identity, with type t = buffer. + *) + val load : buffer -> t + + (** Get the main parsetree from the buffer. + This should return the AST corresponding to [buffer.source]. + *) + val parse : t -> parsetree + + (** Give the opportunity to optimize the parsetree when completing from a + specific position. + + The simplest implementation is: + + let for_completion t _ = ({complete_labels = true}, (tree t)) + + But it might be worthwhile to specialize the parsetree for a better + completion. + *) + val for_completion : t -> Lexing.position -> complete_info * parsetree + + (** Parse a separate user-input in the context of this buffer. + Used when the user manually enters an expression and ask for its type or location. + *) + val parse_line : t -> Lexing.position -> string -> parsetree + + (** Given a buffer and a position, return the components of the identifier + (actually the qualified path) under the cursor. + + This should return the raw identifier names -- operators should not be + surrounded by parentheses. + + An empty list is a valid result if no identifiers are under the cursor. + *) + val ident_at : t -> Lexing.position -> string Location.loc list + + (** Opposite direction: pretty-print a tree. + This works on outcometree and is used for displaying answers to queries. + (type errors, signatures of modules in environment, completion candidates, etc). + *) + val print_outcome : Format.formatter -> outcometree -> unit + + (* This one works on parsetree and is used for case destruction + (merlin-destruct) *) + val pretty_print : Format.formatter -> pretty_parsetree -> unit + end + + type request = + | Req_load of buffer + | Req_parse + | Req_parse_line of Lexing.position * string + | Req_parse_for_completion of Lexing.position + | Req_get_ident_at of Lexing.position + | Req_print_outcome of outcometree list + | Req_pretty_print of pretty_parsetree + + type response = + | Res_loaded + | Res_parse of parsetree + | Res_parse_for_completion of complete_info * parsetree + | Res_get_ident_at of string Location.loc list + | Res_print_outcome of string list + | Res_pretty_print of string + +end + +(* Name of the extension *) +type description = { + name : string; + version : string; +} + +(* Services an extension can provide *) +type capabilities = { + reader: bool; +} + +(* Main protocol *) +type request = + | Start_communication + | Reader_request of Reader.request + +type response = + | Notify of string + | Debug of string + | Exception of string * string + | Reader_response of Reader.response diff --git a/ocamlmerlin_mlx/kernel/dune b/ocamlmerlin_mlx/kernel/dune index ae049ed..670ff02 100644 --- a/ocamlmerlin_mlx/kernel/dune +++ b/ocamlmerlin_mlx/kernel/dune @@ -4,53 +4,22 @@ (flags :standard -w=-9-67-69 - -open=Ocaml_parsing - -open=Mlx_preprocess - -open=Ocaml_utils - -open=Ocaml_typing - -open=Merlin_utils - -open=Merlin_extend - -open=Merlin_specific - -open=Merlin_kernel) + -open=Mlx_utils + -open=Mlx_ocaml_utils + -open=Mlx_ocaml_parsing + -open=Mlx_ocaml_preprocess + -open=Mlx_ocaml_typing + -open=Mlx_extend) (libraries - compiler-libs.common - mlx_preprocess - merlin-lib.ocaml_parsing - merlin-lib.extend - merlin-lib.kernel)) + mlx_utils + mlx_ocaml_utils + mlx_ocaml_parsing + mlx_ocaml_preprocess + mlx_ocaml_typing + mlx_extend + merlin-lib.os_ipc + merlin-lib.dot_protocol)) (copy_files# - (enabled_if - (<> %{profile} "release")) - (mode promote) - (files ../../merlin/src/kernel/extension.{ml,mli})) - -(copy_files# - (enabled_if - (<> %{profile} "release")) - (mode promote) - (files ../../merlin/src/kernel/mreader.{ml,mli})) - -(copy_files# - (enabled_if - (<> %{profile} "release")) - (mode promote) - (files ../../merlin/src/kernel/mreader_explain.{ml,mli})) - -(copy_files# - (enabled_if - (<> %{profile} "release")) - (mode promote) - (files ../../merlin/src/kernel/mreader_lexer.{ml,mli})) - -(copy_files# - (enabled_if - (<> %{profile} "release")) - (mode promote) - (files ../../merlin/src/kernel/mreader_parser.{ml,mli})) - -(copy_files# - (enabled_if - (<> %{profile} "release")) - (mode promote) - (files ../../merlin/src/kernel/mreader_recover.{ml,mli})) + (files + %{project_root}/merlin/src/kernel/{msource,mconfig_dot,mconfig,mreader,mreader_parser,mreader_lexer,msupport,mreader_recover,mreader_explain,extension,mreader_extend,mocaml}.{ml,mli})) diff --git a/ocamlmerlin_mlx/kernel/extension.ml b/ocamlmerlin_mlx/kernel/extension.ml deleted file mode 100644 index 281e709..0000000 --- a/ocamlmerlin_mlx/kernel/extension.ml +++ /dev/null @@ -1,195 +0,0 @@ -# 1 "merlin/src/kernel/extension.ml" -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std -open Parser_raw - -exception Unknown - -type t = { - name : string; - private_def : string list; - public_def : string list; - packages : string list; - keywords : (string * Parser_raw.token) list; -} - -type set = string list - -(* Private definitions are put in a fake module named "_" with the following - * ident. Use it to test or find private definitions. *) -let ident = Ident.create_persistent "_" - -(** Definition of each extension *) -let ext_lwt = { - name = "lwt"; - private_def = [ - "module Lwt : sig - val un_lwt : 'a Lwt.t -> 'a - val in_lwt : 'a Lwt.t -> 'a Lwt.t - val to_lwt : 'a -> 'a Lwt.t - val finally' : 'a Lwt.t -> unit Lwt.t -> 'a Lwt.t - val un_stream : 'a Lwt_stream.t -> 'a - val unit_lwt : unit Lwt.t -> unit Lwt.t - end" - ]; - public_def = [ - "val (>>) : unit Lwt.t -> 'a Lwt.t -> 'a Lwt.t - val raise_lwt : exn -> 'a Lwt.t - val assert_lwt : bool -> unit Lwt.t" - ]; - keywords = [ - "lwt", LET_LWT; - "try_lwt", TRY_LWT; - "match_lwt", MATCH_LWT; - "finally", FINALLY_LWT; - "for_lwt", FOR_LWT; - "while_lwt", WHILE_LWT; - ]; - packages = ["lwt.syntax"]; -} - -let ext_nonrec = { - name = "nonrec"; - private_def = []; - public_def = []; - keywords = [ - "nonrec", NONREC; - ]; - packages = []; -} - -let ext_meta = { - name = "meta"; - private_def = [ - "module Meta : sig - val code : 'a -> 'a code - val uncode : 'a code -> 'a - end" - ]; - public_def = []; - keywords = [ - ">.", GREATERDOT; - ]; - packages = []; -} - -(* Known extensions *) -let registry = [ext_lwt;ext_meta] -let registry = - List.fold_left registry ~init:String.Map.empty - ~f:(fun map ext -> String.Map.add map ~key:ext.name ~data:ext) - -let all = String.Map.keys registry - -let lookup s = - try Some (String.Map.find s registry) - with Not_found -> None - -let empty = [] - -(* Compute set of extensions from package names (used to enable support for - "lwt" if "lwt.syntax" is loaded by user. *) -let from ~extensions ~packages = - String.Map.fold registry ~init:[] ~f:(fun ~key:name ~data:ext set -> - if List.mem name ~set:extensions || - List.exists ~f:(List.mem ~set:ext.packages) packages - then name :: set - else set - ) - -(* Merlin expects a few extensions to be always enabled, otherwise error - recovery may fail arbitrarily *) -let default = match Merlin_config.ocamlversion with - | `OCaml_4_02_2 | `OCaml_4_03_0 -> [ext_nonrec] - | _ -> [] - -let default_kw = List.concat_map ~f:(fun ext -> ext.keywords) default - -(* Lexer keywords needed by extensions *) -let keywords set = - let add_kw kws ext = - match lookup ext with - | None -> kws - | Some def -> def.keywords @ kws - in - let all = List.fold_left set ~init:default_kw ~f:add_kw in - Lexer_raw.keywords all - -(* Register extensions in typing environment *) -let parse_sig = - let keywords = Lexer_raw.keywords [] in fun str -> - let lexbuf = Lexing.from_string str in - let state = Lexer_raw.make keywords in - let rec lexer = function - | Lexer_raw.Fail _ -> assert false - | Lexer_raw.Return x -> x - | Lexer_raw.Refill k -> lexer (k ()) - in - let lexer lexbuf = lexer (Lexer_raw.token_without_comments state lexbuf) in - (Parser_raw.interface lexer lexbuf : Parsetree.signature) - -let type_sig env sg = - let sg = Typemod.transl_signature env sg in - sg.Typedtree.sig_type - -(* -let add_hidden_signature env sign = - let add_item env comp = - match comp with - | Types.Sig_value(id, decl) -> Env.add_value (Ident.hide id) decl env - | Types.Sig_type(id, decl, _) -> Env.add_type ~check:false (Ident.hide id) decl env - | Types.Sig_typext(id, decl, _) -> Env.add_extension ~check:false (Ident.hide id) decl env - | Types.Sig_module(id, mty, _) -> Env.add_module (Ident.hide id) mty.Types.md_type env - | Types.Sig_modtype(id, decl) -> Env.add_modtype (Ident.hide id) decl env - | Types.Sig_class(id, decl, _) -> Env.add_class (Ident.hide id) decl env - | Types.Sig_class_type(id, decl, _) -> Env.add_cltype (Ident.hide id) decl env - in - List.fold_left ~f:add_item ~init:env sign -*) - -let register exts env = - (* Log errors ? *) - let try_type sg' = try type_sig env sg' with _exn -> [] in - let exts = List.filter_dup exts in - let exts = List.filter_map ~f:(fun ext -> - match String.Map.find ext registry with - | ext -> Some ext - | exception Not_found -> None - ) exts - in - let process_ext e = - let prv = List.concat_map ~f:parse_sig e.private_def in - let pub = List.concat_map ~f:parse_sig e.public_def in - try_type prv, try_type pub - in - let fakes, tops = List.split (List.map ~f:process_ext exts) in - let env = Env.add_signature (List.concat tops) env in - Env.add_merlin_extension_module ident - (Types.Mty_signature (List.concat fakes)) env diff --git a/ocamlmerlin_mlx/kernel/extension.mli b/ocamlmerlin_mlx/kernel/extension.mli deleted file mode 100644 index 7ae48c8..0000000 --- a/ocamlmerlin_mlx/kernel/extension.mli +++ /dev/null @@ -1,76 +0,0 @@ -# 1 "merlin/src/kernel/extension.mli" -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -exception Unknown - -(* Adjust typing environment for syntax extensions. - * See [Fake] for AST part *) - -(* Extension environment is composed of two part: - * - private definitions, not exposed to user but accessed by AST rewriters, - * - public definitions, those are made available to user in default scope, - * like the Pervasives module. - * See [Typer.initial_env] for initial environment generation. - *) - -(** Definition of an extension (as seen from Lexer and Typer) *) -type t = { - name : string; - private_def : string list; - public_def : string list; - packages : string list; - keywords : (string * Parser_raw.token) list; -} - -(* Private definitions are put in a fake module named "_" with the following - * ident. Use it to test or find private definitions. *) -val ident : Ident.t - -(** Set of extension name *) -type set = string list - -(* Lexer keywords needed by extensions *) -val keywords : set -> Lexer_raw.keywords -(* Register extensions in typing environment *) -val register : set -> Env.t -> Env.t - -(* Known extensions *) -val all : set -val registry : t String.Map.t -val lookup : string -> t option - -(* Compute set of extensions from package names (used to enable support for - "lwt" if "lwt.syntax" package is loaded by user. *) -val from : extensions:string list -> packages:string list -> set - -(* Merlin expects a few extensions to be always enabled, otherwise error - recovery may fail arbitrarily *) -val empty : set diff --git a/ocamlmerlin_mlx/kernel/mlx_kernel.ml b/ocamlmerlin_mlx/kernel/mlx_kernel.ml deleted file mode 100644 index 0dbf7d9..0000000 --- a/ocamlmerlin_mlx/kernel/mlx_kernel.ml +++ /dev/null @@ -1,10 +0,0 @@ -module This = struct - module Extension = Extension - module Mreader = Mreader - module Mreader_recover = Mreader_recover - module Mreader_explain = Mreader_explain - module Mreader_lexer = Mreader_lexer - module Mreader_parser = Mreader_parser -end -include Merlin_kernel -include This diff --git a/ocamlmerlin_mlx/kernel/mreader.ml b/ocamlmerlin_mlx/kernel/mreader.ml deleted file mode 100644 index 3a17df2..0000000 --- a/ocamlmerlin_mlx/kernel/mreader.ml +++ /dev/null @@ -1,181 +0,0 @@ -# 1 "merlin/src/kernel/mreader.ml" -open Std - -type parsetree = [ - | `Interface of Parsetree.signature - | `Implementation of Parsetree.structure -] - -type comment = (string * Location.t) - -type result = { - lexer_keywords: string list; - lexer_errors : exn list; - parser_errors : exn list; - comments : comment list; - parsetree : parsetree; - no_labels_for_completion : bool; -} - -(* Normal entry point *) - -let normal_parse ?for_completion config source = - let kind = - let filename = Mconfig.(config.query.filename) in - let extension = - match String.rindex filename '.' with - | exception Not_found -> "" - | pos -> String.sub ~pos ~len:(String.length filename - pos) filename - in - Logger.log ~section:"Mreader" ~title:"run" - "extension(%S) = %S" filename extension; - if List.exists ~f:(fun (_impl,intf) -> intf = extension) - Mconfig.(config.merlin.suffixes) - then Mreader_parser.MLI - else Mreader_parser.ML - in - let lexer = - let keywords = Extension.keywords Mconfig.(config.merlin.extensions) in - Mreader_lexer.make Mconfig.(config.ocaml.warnings) keywords config source - in - let no_labels_for_completion, lexer = match for_completion with - | None -> false, lexer - | Some pos -> - let pos = Msource.get_lexing_pos source - ~filename:(Mconfig.filename config) pos - in - Mreader_lexer.for_completion lexer pos - in - let parser = Mreader_parser.make Mconfig.(config.ocaml.warnings) lexer kind in - let lexer_keywords = Mreader_lexer.keywords lexer - and lexer_errors = Mreader_lexer.errors lexer - and parser_errors = Mreader_parser.errors parser - and parsetree = Mreader_parser.result parser - and comments = Mreader_lexer.comments lexer - in - { lexer_keywords; lexer_errors; parser_errors; comments; parsetree; - no_labels_for_completion; } - -(* Pretty-printing *) - -type pretty_parsetree = Extend_protocol.Reader.pretty_parsetree -type outcometree = Extend_protocol.Reader.outcometree - -let ambient_reader = ref None - -let instantiate_reader spec config source = match spec with - | [] -> ((lazy None), ignore) - | name :: args -> - let reader = lazy (Mreader_extend.start name args config source) in - (reader, (fun () -> - if Lazy.is_val reader then - match Lazy.force reader with - | None -> () - | Some reader -> Mreader_extend.stop reader)) - -let get_reader config = - let rec find_reader assocsuffixes = - match assocsuffixes with - | [] -> [] - | (suffix,reader)::t -> - if Filename.check_suffix Mconfig.(config.query.filename) suffix then [reader] else find_reader t - in - match Mconfig.(config.merlin.reader) with - (* if a reader flag exists then this is explicitly used disregarding suffix association *) - | [] -> find_reader Mconfig.(config.merlin.extension_to_reader) - | x -> x - -let mocaml_printer reader ppf otree = - let str = match reader with - | lazy (Some reader) -> Mreader_extend.print_outcome otree reader - | _ -> None - in - match str with - | Some str -> Format.pp_print_string ppf str - | None -> Mocaml.default_printer ppf otree - -let with_ambient_reader config source f = - let ambient_reader' = !ambient_reader in - let reader_spec = get_reader config in - let reader, stop = instantiate_reader reader_spec config source in - ambient_reader := Some (reader, reader_spec, source); - Misc.try_finally - (fun () -> Mocaml.with_printer (mocaml_printer reader) f) - ~always:(fun () -> ambient_reader := ambient_reader'; stop ()) - -let try_with_reader config source f = - let reader_spec = get_reader config in - let lazy reader, stop = - match !ambient_reader with - | Some (reader, reader_spec', source') - when compare reader_spec reader_spec' = 0 && - compare source source' = 0 -> reader, ignore - | _ -> instantiate_reader reader_spec config source - in - match reader with - | None -> stop (); None - | Some reader -> - Misc.try_finally (fun () -> f reader) ~always:stop - -let print_pretty config source tree = - match try_with_reader config source - (Mreader_extend.print_pretty tree) with - | Some result -> result - | None -> - let ppf, to_string = Std.Format.to_string () in - let open Extend_protocol.Reader in - begin match tree with - | Pretty_case_list x -> Pprintast.case_list ppf x - | Pretty_core_type x -> Pprintast.core_type ppf x - | Pretty_expression x -> Pprintast.expression ppf x - | Pretty_pattern x -> Pprintast.pattern ppf x - | Pretty_signature x -> Pprintast.signature ppf x - | Pretty_structure x -> Pprintast.structure ppf x - | Pretty_toplevel_phrase x -> Pprintast.toplevel_phrase ppf x - end; - to_string () - -let default_print_outcome tree = - Mocaml.default_printer Format.str_formatter tree; - Format.flush_str_formatter () - -let print_outcome config source tree = - match try_with_reader config source - (Mreader_extend.print_outcome tree) with - | Some result -> result - | None -> default_print_outcome tree - -let print_batch_outcome config source tree = - match try_with_reader config source - (Mreader_extend.print_outcomes tree) with - | Some result -> result - | None -> List.map ~f:default_print_outcome tree - -let reconstruct_identifier config source pos = - match - try_with_reader config source - (Mreader_extend.reconstruct_identifier pos) - with - | None | Some [] -> Mreader_lexer.reconstruct_identifier config source pos - | Some result -> result - -(* Entry point *) - -let parse ?for_completion config = function - | (source, None) -> - begin match - try_with_reader config source - (Mreader_extend.parse ?for_completion) - with - | Some (`No_labels no_labels_for_completion, parsetree) -> - let (lexer_errors, parser_errors, comments) = ([], [], []) in - let lexer_keywords = [] (* TODO? *) in - { lexer_keywords; lexer_errors; parser_errors; comments; - parsetree; no_labels_for_completion; } - | None -> normal_parse ?for_completion config source - end - | (_, Some parsetree) -> - let (lexer_errors, parser_errors, comments) = ([], [], []) in - let lexer_keywords = [] in - { lexer_keywords; lexer_errors; parser_errors; comments; parsetree; - no_labels_for_completion = false; } diff --git a/ocamlmerlin_mlx/kernel/mreader.mli b/ocamlmerlin_mlx/kernel/mreader.mli deleted file mode 100644 index 62729b6..0000000 --- a/ocamlmerlin_mlx/kernel/mreader.mli +++ /dev/null @@ -1,44 +0,0 @@ -# 1 "merlin/src/kernel/mreader.mli" -type parsetree = [ - | `Interface of Parsetree.signature - | `Implementation of Parsetree.structure -] - -type comment = (string * Location.t) - -type result = { - lexer_keywords: string list; - lexer_errors : exn list; - parser_errors : exn list; - comments : comment list; - parsetree : parsetree; - no_labels_for_completion : bool; -} - -type pretty_parsetree = Extend_protocol.Reader.pretty_parsetree -type outcometree = Extend_protocol.Reader.outcometree - -(* Ambient reader. - - Some actions need to interact with an external process. - `with_ambient_reader' will setup this process to speed up later calls. -*) - -val with_ambient_reader : Mconfig.t -> Msource.t -> (unit -> 'a) -> 'a - -(* Main functions *) - -val parse : - ?for_completion:Msource.position -> Mconfig.t -> Msource.t * parsetree option -> result - -val print_pretty : - Mconfig.t -> Msource.t -> pretty_parsetree -> string - -val print_outcome : - Mconfig.t -> Msource.t -> outcometree -> string - -val print_batch_outcome : - Mconfig.t -> Msource.t -> outcometree list -> string list - -val reconstruct_identifier: - Mconfig.t -> Msource.t -> Lexing.position -> string Location.loc list diff --git a/ocamlmerlin_mlx/kernel/mreader_explain.ml b/ocamlmerlin_mlx/kernel/mreader_explain.ml deleted file mode 100644 index 6c3034e..0000000 --- a/ocamlmerlin_mlx/kernel/mreader_explain.ml +++ /dev/null @@ -1,105 +0,0 @@ -# 1 "merlin/src/kernel/mreader_explain.ml" -open Parser_raw -open MenhirInterpreter - -let opening (type a) : a terminal -> string option = function - | T_STRUCT -> Some "struct" - | T_SIG -> Some "sig" - | T_OBJECT -> Some "object" - | T_BEGIN -> Some "begin" - | T_LPAREN -> Some "(" - | T_LBRACKET -> Some "[" - | T_LBRACE -> Some "{" - | T_LBRACKETBAR -> Some "[|" - | T_LBRACKETLESS -> Some "[<" - | T_LBRACELESS -> Some "{<" - | _ -> None - -let opening_st st = - match incoming_symbol st with - | T term -> opening term - | _ -> None - -let closing (type a) : a terminal -> bool = function - | T_END -> true - | T_RPAREN -> true - | T_RBRACKET -> true - | T_RBRACE -> true - | T_BARRBRACKET -> true - | T_GREATERRBRACE -> true - | T_GREATERRBRACKET -> true - | _ -> false - -let closing_st st = - match incoming_symbol st with - | T term -> closing term - | _ -> false - -type explanation = { - item: (string * Location.t) option; - unclosed: (string * Location.t) option; - location: Location.t; - popped: MenhirInterpreter.xsymbol list; - shifted: MenhirInterpreter.xsymbol option; - unexpected: MenhirInterpreter.token; -} - -let explain env (unexpected, startp, endp) popped shifted = - let mkloc s e = {Location. loc_start = s; loc_end = e; loc_ghost = false} in - let open MenhirInterpreter in - let location = mkloc startp endp in - let closed = ref 0 in - let unclosed = ref None in - let return item = - { item; unclosed = !unclosed; location; popped; shifted; unexpected } - in - let rec process env = match top env with - | None -> return None - | Some (Element (st, _, startp, endp)) -> - if closing_st st then incr closed; - begin match opening_st st with - | None -> () - | Some st -> - if !closed = 0 && !unclosed = None then - unclosed := Some (st, mkloc startp endp) - else - decr closed - end; - match Parser_explain.named_item_at (number st) with - | name -> return (Some (name, mkloc startp endp)) - | exception Not_found -> - match pop env with - | None -> return None - | Some env -> process env - in - process env - -let to_error { item; unclosed; location; popped; shifted; unexpected = _ } = - let inside = match item with - | None -> "" - | Some (name, _) -> " inside `" ^ name ^ "'" in - let after = match unclosed with - | None -> "" - | Some (name, _) -> " after unclosed " ^ name in - let friendly_name sym = match sym with - | X (T _) -> "`" ^ Parser_printer.print_symbol sym ^ "'" - | X (N _) -> Parser_printer.print_symbol sym - in - let popped = String.concat " " (List.rev_map friendly_name popped) in - let expecting = match shifted with - | None -> if popped = "" then "" else ", maybe remove " ^ popped - | Some (X (T T_EOF)) -> "" - | Some sym -> - if popped = "" then ", expecting " ^ (friendly_name sym) - else ", maybe replace " ^ popped ^ " by " ^ (friendly_name sym) - in - let msg = Printf.sprintf "Syntax error%s%s%s" inside after expecting in - Location.error ~loc:location ~source:Location.Parser msg - -exception Syntax_explanation of explanation - -let syntax_explanation = function - | Syntax_explanation explanation -> Some (to_error explanation) - | _ -> None - -let () = Location.register_error_of_exn syntax_explanation diff --git a/ocamlmerlin_mlx/kernel/mreader_lexer.ml b/ocamlmerlin_mlx/kernel/mreader_lexer.ml deleted file mode 100644 index e5d3d00..0000000 --- a/ocamlmerlin_mlx/kernel/mreader_lexer.ml +++ /dev/null @@ -1,367 +0,0 @@ -# 1 "merlin/src/kernel/mreader_lexer.ml" -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -type keywords = Lexer_raw.keywords - -type triple = Parser_raw.token * Lexing.position * Lexing.position - -type item = - | Triple of triple - | Comment of (string * Location.t) - | Error of Lexer_raw.error * Location.t - -type t = { - keywords: keywords; - config: Mconfig.t; - source: Msource.t; - items: item list; -} - -let get_tokens keywords pos text = - let state = Lexer_raw.make keywords in - let lexbuf = Lexing.from_string text in - Lexing.move lexbuf pos; - let rec aux items = function - | Lexer_raw.Return (Parser_raw.COMMENT comment) -> - continue (Comment comment :: items) - | Lexer_raw.Refill k -> aux items (k ()) - | Lexer_raw.Return t -> - let triple = (t, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p) in - let items = Triple triple :: items in - if t = Parser_raw.EOF - then items - else continue items - | Lexer_raw.Fail (err, loc) -> - continue (Error (err, loc) :: items) - - and continue items = - aux items (Lexer_raw.token state lexbuf) - - in - function - | [] -> - (* First line: skip #! ... *) - aux [] (Lexer_raw.skip_sharp_bang state lexbuf) - | items -> - (* Resume *) - continue items - -let initial_position config = - { Lexing. - pos_fname = (Mconfig.filename config); - pos_lnum = 1; - pos_bol = 0; - pos_cnum = 0; - } - -let make warnings keywords config source = - Msupport.catch_errors warnings (ref []) @@ fun () -> - let items = - get_tokens keywords - (initial_position config) - (Msource.text source) - [] - in - { keywords; items; config; source } - -let item_start = function - | Triple (_,s,_) -> s - | Comment (_, l) | Error (_, l) -> - l.Location.loc_start - -let item_end = function - | Triple (_,_,e) -> e - | Comment (_, l) | Error (_, l) -> - l.Location.loc_end - -let initial_position t = - initial_position t.config - -let rev_filter_map ~f lst = - let rec aux acc = function - | [] -> acc - | x :: xs -> - let acc = - match f x with - | Some x' -> x' :: acc - | None -> acc - in - aux acc xs - in - aux [] lst - -let tokens t = - rev_filter_map t.items - ~f:(function Triple t -> Some t | _ -> None) - -let keywords t = - Lexer_raw.list_keywords t.keywords - -let errors t = - rev_filter_map t.items - ~f:(function Error (err, loc) -> Some (Lexer_raw.Error (err, loc)) - | _ -> None) - -let comments t = - rev_filter_map t.items - ~f:(function Comment t -> Some t | _ -> None) - -open Parser_raw - -let is_operator = function - | PREFIXOP s - | LETOP s | ANDOP s - | INFIXOP0 s | INFIXOP1 s | INFIXOP2 s | INFIXOP3 s | INFIXOP4 s -> Some s - | BANG -> Some "!" - | PERCENT -> Some "%" - | PLUS -> Some "+" | PLUSDOT -> Some "+." - | MINUS -> Some "-" | MINUSDOT -> Some "-." - | STAR -> Some "*" | EQUAL -> Some "=" - | LESS -> Some "<" | GREATER -> Some ">" - | OR -> Some "or" | BARBAR -> Some "||" - | AMPERSAND -> Some "&" | AMPERAMPER -> Some "&&" - | COLONEQUAL -> Some ":=" | PLUSEQ -> Some "+=" - | _ -> None - -(* [reconstruct_identifier] is impossible to read at the moment, here is a - pseudo code version of the function: - (many thanks to Gabriel for this contribution) - - 00| let h = parse (focus h) with - 01| | . { h+1 } - 02| | _ { h } - 03| in - 04| parse h with - 05| | BOF x=operator { [x] } - 06| | ¬( x=operator { [x] } - 07| | ' x=ident { [] } - 08| | _ { - 09| let acc, h = parse (h ! tail h) with - 10| | x=ident ! { [x], h } - 11| | ( ! x=operator ) { [x], h } - 12| | ( x=operator ! ) { [x], h - 1 } - 13| | ( x=operator ) ! { [x], h - 2 } - 14| | _ { [], h } - 15| in - 16| let h = h - 1 in - 17| let rec head acc = parse (h !) with - 18| | tl x=ident . ! { head (x :: acc) tl } - 19| | x=ident . ! { ident :: acc } - 20| | _ { acc } - 21| in head acc - 22| } - - Now for the explanations: - line 0-3: if we're on a dot, skip it and move to the right - - line 5,6: if we're on an operator not preceded by an opening parenthesis, - just return that. - - line 7: if we're on a type variable, don't return anything. - reconstruct_identifier is called when locating and getting the - type of an expression, in both cases there's nothing we can do - with a type variable. - See #317 - - line 8-22: two step approach: - - line 9-15: retrieve the identifier - OR retrieve the parenthesized operator and move before the - opening parenthesis - - - line 16-21: retrieve the "path" prefix of the identifier/operator we - got in the previous step. - - - Additionally, the message of commit fc0b152 explains what we consider is an - identifier: - - « - Interpreting an OCaml identifier out of context is a bit ambiguous. - - A prefix of the form (UIDENT DOT)* is the module path, - A UIDENT suffix is either a module name, a module type name (in case the - whole path is a module path), or a value constructor. - A LIDENT suffix is either a value name, a type constructor or a module - type name. - A LPAREN OPERATOR RPAREN suffix is a value name (and soon, maybe a - value constructor if beginning by ':' ?!) . - - In the middle, LIDENT DOT (UIDENT DOT)* is projection of the field of a - record. In this case, merlin will drop everything up to the first - UIDENT and complete in the scope of the (UIDENT DOT)* interpreted as a - module path. - Soon, the last UIDENT might also be the type of an inline record. - (Module2.f.Module1.A <- type of the record of the value constructor named A of - type f, defined in Module1 and aliased in Module2, pfffff). - » -*) - -let reconstruct_identifier_from_tokens tokens pos = - let rec look_for_component acc = function - - (* Skip 'a and `A *) - | ((LIDENT _ | UIDENT _), _, _) :: - ((BACKQUOTE | QUOTE), _, _) :: items -> - check acc items - - (* UIDENT is a regular a component *) - | (UIDENT _, _, _) as item :: items -> - look_for_dot (item :: acc) items - - (* LIDENT always begin a new identifier *) - | (LIDENT _, _, _) as item :: items -> - if acc = [] - then look_for_dot [item] items - else check acc (item :: items) - - (* Reified operators behave like LIDENT *) - | (RPAREN, _, _) :: (token, _, _ as item) :: (LPAREN, _, _) :: items - when is_operator token <> None && acc = [] -> - look_for_dot [item] items - - (* An operator alone is an identifier on its own *) - | (token, _, _ as item) :: items - when is_operator token <> None && acc = [] -> - check [item] items - - (* Otherwise, check current accumulator and scan the rest of the input *) - | _ :: items -> - check acc items - - | [] -> raise Not_found - - and look_for_dot acc = function - | (DOT,_,_) :: items -> look_for_component acc items - | items -> check acc items - - and check acc items = - if acc <> [] && - (let startp = match acc with - | (_, startp, _) :: _ -> startp - | _ -> assert false in - Lexing.compare_pos startp pos <= 0) && - (let endp = match List.last acc with - | Some ((_, _, endp)) -> endp - | _ -> assert false in - Lexing.compare_pos pos endp <= 0) - then acc - else match items with - | [] -> raise Not_found - | (_, _, endp) :: _ when Lexing.compare_pos endp pos < 0 -> - raise Not_found - | _ -> look_for_component [] items - - in - match look_for_component [] tokens with - | exception Not_found -> [] - | acc -> - let fmt (token, loc_start, loc_end) = - let id = - match token with - | UIDENT s | LIDENT s -> s - | _ -> match is_operator token with - | Some t -> t - | None -> assert false - in - Location.mkloc id {Location. loc_start; loc_end; loc_ghost = false} - in - let before_pos = function - | (_, s, _) -> - Lexing.compare_pos s pos <= 0 - in - List.map ~f:fmt (List.filter ~f:before_pos acc) - -let reconstruct_identifier config source pos = - let rec lex acc lexbuf = - let token = Lexer_ident.token lexbuf in - let item = (token, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p) in - match token with - | EOF -> (item :: acc) - | EOL when Lexing.compare_pos lexbuf.Lexing.lex_curr_p pos > 0 -> - (item :: acc) - | EOL -> lex [] lexbuf - | _ -> lex (item :: acc) lexbuf - in - let lexbuf = Lexing.from_string (Msource.text source) in - Location.init lexbuf (Mconfig.filename config); - let tokens = lex [] lexbuf in - reconstruct_identifier_from_tokens tokens pos - -let is_uppercase {Location. txt = x; _} = - x <> "" && Char.is_uppercase x.[0] - -let rec drop_lowercase acc = function - | [x] -> List.rev (x :: acc) - | x :: xs when not (is_uppercase x) -> drop_lowercase [] xs - | x :: xs -> drop_lowercase (x :: acc) xs - | [] -> List.rev acc - -let for_completion t pos = - let no_labels = ref false in - let check_label = function - | Triple ((LABEL _ | OPTLABEL _), _, _) -> no_labels := true - | _ -> () - in - let rec aux acc = function - (* Cursor is before item: continue *) - | item :: items when Lexing.compare_pos (item_start item) pos >= 0 -> - aux (item :: acc) items - - (* Cursor is in the middle of item: stop *) - | item :: _ when Lexing.compare_pos (item_end item) pos > 0 -> - check_label item; - raise Exit - - (* Cursor is at the end *) - | ((Triple (token, _, loc_end) as item) :: _) as items - when Lexing.compare_pos pos loc_end = 0 -> - check_label item; - begin match token with - (* Already on identifier, no need to introduce *) - | UIDENT _ | LIDENT _ -> raise Exit - | _ -> acc, items - end - - | items -> acc, items - in - let t = - match aux [] t.items with - | exception Exit -> t - | acc, items -> - {t with items = - List.rev_append acc (Triple (LIDENT "", pos, pos) :: items)} - in - (!no_labels, t) - -let identifier_suffix ident = - match List.last ident with - | Some x when is_uppercase x -> drop_lowercase [] ident - | _ -> ident diff --git a/ocamlmerlin_mlx/kernel/mreader_parser.ml b/ocamlmerlin_mlx/kernel/mreader_parser.ml deleted file mode 100644 index d4c8c2d..0000000 --- a/ocamlmerlin_mlx/kernel/mreader_parser.ml +++ /dev/null @@ -1,212 +0,0 @@ -# 1 "merlin/src/kernel/mreader_parser.ml" -(* {{{ COPYING *( - - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan - - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. - -)* }}} *) - -open Std - -module I = Parser_raw.MenhirInterpreter - -type kind = - | ML - | MLI - (*| MLL | MLY*) - -module Dump = struct - let symbol () = Parser_printer.print_symbol -end - -module R = Mreader_recover.Make - (I) - (struct - include Parser_recover - - let default_value loc x = - Default.default_loc := loc; - default_value x - - let guide (type a) : a I.symbol -> bool = function - | I.T I.T_BEGIN -> true - | _ -> false - - let token_of_terminal = Parser_printer.token_of_terminal - - let nullable = Parser_explain.nullable - end) - (Dump) - -type 'a step = - | Correct of 'a I.checkpoint - | Recovering of 'a R.candidates - -type tree = [ - | `Interface of Parsetree.signature - | `Implementation of Parsetree.structure -] - -type steps =[ - | `Signature of (Parsetree.signature step * Mreader_lexer.triple) list - | `Structure of (Parsetree.structure step * Mreader_lexer.triple) list -] - -type t = { - kind: kind; - tree: tree; - steps: steps; - errors: exn list; - lexer: Mreader_lexer.t; -} - -let eof_token = (Parser_raw.EOF, Lexing.dummy_pos, Lexing.dummy_pos) - -let errors_ref = ref [] - -let resume_parse = - let rec normal acc tokens = function - | I.InputNeeded env as checkpoint -> - let token, tokens = match tokens with - | token :: tokens -> token, tokens - | [] -> eof_token, [] - in - check_for_error acc token tokens env (I.offer checkpoint token) - - | I.Shifting (_,env,_) | I.AboutToReduce (env,_) as checkpoint -> - begin match I.resume checkpoint with - | checkpoint' -> normal acc tokens checkpoint' - | exception exn -> - Msupport.raise_error exn; - let token = match acc with - | [] -> assert false - (* Parser raised error before parsing anything *) - | (_, token) :: _ -> token - in - enter_error acc token tokens env - end - - | I.Accepted v -> acc, v - - | I.Rejected | I.HandlingError _ -> - assert false - - and check_for_error acc token tokens env = function - | I.HandlingError _ -> - enter_error acc token tokens env - - | I.Shifting _ | I.AboutToReduce _ as checkpoint -> - begin match I.resume checkpoint with - | checkpoint' -> check_for_error acc token tokens env checkpoint' - | exception exn -> - Msupport.raise_error exn; - enter_error acc token tokens env - end - - | checkpoint -> - normal ((Correct checkpoint, token) :: acc) tokens checkpoint - - and enter_error acc token tokens env = - let candidates = R.generate env in - let explanation = - Mreader_explain.explain env token - candidates.R.popped candidates.R.shifted - in - errors_ref := Mreader_explain.Syntax_explanation explanation :: !errors_ref; - recover acc (token :: tokens) candidates - - and recover acc tokens candidates = - let token, tokens = match tokens with - | token :: tokens -> token, tokens - | [] -> eof_token, [] - in - let acc' = ((Recovering candidates, token) :: acc) in - match R.attempt candidates token with - | `Fail -> - if tokens = [] then - match candidates.R.final with - | None -> failwith "Empty file" - | Some v -> acc', v - else - recover acc tokens candidates - | `Accept v -> acc', v - | `Ok (checkpoint, _) -> - normal ((Correct checkpoint, token) :: acc) tokens checkpoint - in - fun acc tokens -> function - | Correct checkpoint -> normal acc tokens checkpoint - | Recovering candidates -> recover acc tokens candidates - -let seek_step steps tokens = - let rec aux acc = function - | (step :: steps), (token :: tokens) when snd step = token -> - aux (step :: acc) (steps, tokens) - | _, tokens -> acc, tokens - in - aux [] (steps, tokens) - -let parse initial steps tokens initial_pos = - let acc, tokens = seek_step steps tokens in - let step = - match acc with - | (step, _) :: _ -> step - | [] -> Correct (initial initial_pos) - in - let acc, result = resume_parse acc tokens step in - List.rev acc, result - -let run_parser warnings lexer previous kind = - Msupport.catch_errors warnings errors_ref @@ fun () -> - let tokens = Mreader_lexer.tokens lexer in - let initial_pos = Mreader_lexer.initial_position lexer in - match kind with - | ML -> - let steps = match previous with - | `Structure steps -> steps - | _ -> [] - in - let steps, result = - let state = Parser_raw.Incremental.implementation in - parse state steps tokens initial_pos in - `Structure steps, `Implementation result - | MLI -> - let steps = match previous with - | `Signature steps -> steps - | _ -> [] - in - let steps, result = - let state = Parser_raw.Incremental.interface in - parse state steps tokens initial_pos in - `Signature steps, `Interface result - -let make warnings lexer kind = - errors_ref := []; - let steps, tree = run_parser warnings lexer `None kind in - let errors = !errors_ref in - errors_ref := []; - {kind; steps; tree; errors; lexer} - -let result t = t.tree - -let errors t = t.errors diff --git a/ocamlmerlin_mlx/kernel/mreader_recover.ml b/ocamlmerlin_mlx/kernel/mreader_recover.ml deleted file mode 100644 index bf5cae6..0000000 --- a/ocamlmerlin_mlx/kernel/mreader_recover.ml +++ /dev/null @@ -1,284 +0,0 @@ -# 1 "merlin/src/kernel/mreader_recover.ml" -open Std - -let {Logger. log} = Logger.for_section "Mreader_recover" - -module Make - (Parser : MenhirLib.IncrementalEngine.EVERYTHING) - (Recovery : sig - val default_value : Location.t -> 'a Parser.symbol -> 'a - - type action = - | Abort - | R of int - | S : 'a Parser.symbol -> action - | Sub of action list - - type decision = - | Nothing - | One of action list - | Select of (int -> action list) - - val depth : int array - - val recover : int -> decision - - val guide : 'a Parser.symbol -> bool - - val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token - - val nullable : 'a Parser.nonterminal -> bool - end) - (Dump : sig - val symbol : unit -> Parser.xsymbol -> string - end) = -struct - - type 'a candidate = { - line: int; - min_col: int; - max_col: int; - env: 'a Parser.env; - } - - type 'a candidates = { - popped: Parser.xsymbol list; - shifted: Parser.xsymbol option; - final: 'a option; - candidates: 'a candidate list; - } - - module T = struct - (* FIXME: this is a bit ugly. We should ask for the type to be exported - publicly by MenhirLib. *) - - [@@@ocaml.warning "-37"] - - type 'a checkpoint = - | InputNeeded of 'a Parser.env - | Shifting of 'a Parser.env * 'a Parser.env * bool - | AboutToReduce of 'a Parser.env * Parser.production - | HandlingError of 'a Parser.env - | Accepted of 'a - | Rejected - external inj : 'a checkpoint -> 'a Parser.checkpoint = "%identity" - end - - (*let env_state env = - match Parser.top env with - | None -> -1 - | Some (Parser.Element (state, _, _, _)) -> - Parser.number state*) - - let feed_token ~allow_reduction token env = - let rec aux allow_reduction = function - | Parser.HandlingError _ | Parser.Rejected -> `Fail - | Parser.AboutToReduce _ when not allow_reduction -> `Fail - | Parser.Accepted v -> `Accept v - | Parser.Shifting _ | Parser.AboutToReduce _ as checkpoint -> - aux true (Parser.resume checkpoint) - | Parser.InputNeeded env as checkpoint -> `Recovered (checkpoint, env) - in - aux allow_reduction (Parser.offer (T.inj (T.InputNeeded env)) token) - - let rec follow_guide col env = match Parser.top env with - | None -> col - | Some (Parser.Element (state, _, pos, _)) -> - if Recovery.guide (Parser.incoming_symbol state) then - match Parser.pop env with - | None -> col - | Some env -> follow_guide (snd (Lexing.split_pos pos)) env - else - col - - let candidate env = - let line, min_col, max_col = - match Parser.top env with - | None -> 1, 0, 0 - | Some (Parser.Element (state, _, pos, _)) -> - let depth = Recovery.depth.(Parser.number state) in - let line, col = Lexing.split_pos pos in - if depth = 0 then - line, col, col - else - let col' = match Parser.pop_many depth env with - | None -> max_int - | Some env -> - match Parser.top env with - | None -> max_int - | Some (Parser.Element (_, _, pos, _)) -> - follow_guide (snd (Lexing.split_pos pos)) env - in - line, min col col', max col col' - in - { line; min_col; max_col; env } - - let attempt r token = - let _, startp, _ = token in - let line, col = Lexing.split_pos startp in - let more_indented candidate = - line <> candidate.line && candidate.min_col > col in - let recoveries = List.drop_while ~f:more_indented r.candidates in - let same_indented candidate = - line = candidate.line || - (candidate.min_col <= col && col <= candidate.max_col) - in - let recoveries = List.take_while ~f:same_indented recoveries in - let rec aux = function - | [] -> `Fail - | x :: xs -> match feed_token ~allow_reduction:true token x.env with - | `Fail -> - (*if not (is_closed k) then - printf k "Couldn't resume %d with %S.\n" - (env_state x.env) (let (t,_,_) = token in Dump.token t);*) - aux xs - | `Recovered (checkpoint, _) -> `Ok (checkpoint, x.env) - | `Accept v -> - begin match aux xs with - | `Fail -> `Accept v - | x -> x - end - in - aux recoveries - - let decide env = - let rec nth_state env n = - if n = 0 then - match Parser.top env with - | None -> -1 (*allow giving up recovery on empty files*) - | Some (Parser.Element (state, _, _, _)) -> Parser.number state - else - match Parser.pop env with - | None -> assert (n = 1); -1 - | Some env -> nth_state env (n - 1) - in - let st = nth_state env 0 in - match Recovery.recover st with - | Recovery.Nothing -> [] - | Recovery.One actions -> actions - | Recovery.Select f -> f (nth_state env Recovery.depth.(st)) - - let generate (type a) (env : a Parser.env) = - let module E = struct - exception Result of a - end in - let shifted = ref None in - let rec aux acc env = - match Parser.top env with - | None -> None, acc - | Some (Parser.Element (state, _, _startp, endp)) -> - (*Dump.element k elt;*) - log ~title:"decide state" "%d" (Parser.number state); - let actions = decide env in - let candidate0 = candidate env in - let rec eval (env : a Parser.env) : Recovery.action -> a Parser.env = function - | Recovery.Abort -> - log ~title:"eval Abort" ""; - raise Not_found - | Recovery.R prod -> - log ~title:"eval Reduce" ""; - let prod = Parser.find_production prod in - Parser.force_reduction prod env - | Recovery.S (Parser.N n as sym) -> - let xsym = Parser.X sym in - if !shifted = None && not (Recovery.nullable n) then - shifted := Some xsym; - log ~title:"eval Shift N" "%a" Dump.symbol xsym; - (* FIXME: if this is correct remove the fixme, otherwise use - [startp] *) - let loc = {Location. loc_start = endp; loc_end = endp; loc_ghost = true} in - let v = Recovery.default_value loc sym in - Parser.feed sym endp v endp env - | Recovery.S (Parser.T t as sym) -> - let xsym = Parser.X sym in - if !shifted = None then shifted := Some xsym; - log ~title:"eval Shift T" "%a" Dump.symbol xsym; - let loc = {Location. loc_start = endp; loc_end = endp; loc_ghost = true} in - let v = Recovery.default_value loc sym in - let token = (Recovery.token_of_terminal t v, endp, endp) in - begin match feed_token ~allow_reduction:true token env with - | `Fail -> assert false - | `Accept v -> raise (E.Result v) - | `Recovered (_,env) -> env - end - | Recovery.Sub actions -> - log ~title:"enter Sub" ""; - let env = List.fold_left ~f:eval ~init:env actions in - log ~title:"leave Sub" ""; - env - in - match - List.rev_scan_left [] ~f:eval ~init:env actions - |> List.map ~f:(fun env -> {candidate0 with env}) - with - | exception Not_found -> None, acc - | exception (E.Result v) -> Some v, acc - | [] -> None, acc - | (candidate :: _) as candidates -> - aux (candidates @ acc) candidate.env - in - let popped = ref [] in - (*let should_pop stack = - let Parser.Element (state, _, _, _) = Parser.stack_element stack in - match Parser.incoming_symbol state with - | (Parser.T term) as t1 when Recovery.can_pop term -> - log "Pop" "pop %s" - (Dump.symbol (Parser.X t1)); - begin match Parser.stack_next stack with - | None -> false - | Some stack' -> - let rec check_next = function - | Recovery.S (Parser.T term' as t2) :: _ - when Parser.X t1 = Parser.X t2 -> - false - | Recovery.S sym :: _ -> - log "Pop" "then push %s" - (Dump.symbol (Parser.X sym)); - popped := Parser.X t1 :: !popped; - true - | Recovery.Sub xs :: _ -> - check_next xs - | _ -> - popped := Parser.X t1 :: !popped; - true - in - check_next (decide stack') - end - | _ -> false - in*) - let final, candidates = aux [] env in - (List.rev !popped, !shifted, final, candidates) - - let generate env = - let popped, shifted, final, candidates = generate env in - let candidates = List.rev_filter candidates - ~f:(fun t -> not (Parser.env_has_default_reduction t.env)) - in - { popped; shifted; final; candidates = (candidate env) :: candidates } - - (*let dump {Nav. nav; body; _} ~wrong:(t,s,_ as token) ~rest:tokens env = - if not (is_closed body) then ( - let l, c = Lexing.split_pos s in - printf body "Unexpected %S at %d:%d, " (Dump.token t) l c; - link body "see recoveries" - (fun _ -> Nav.push nav "Recoveries" @@ fun {Nav. body; _} -> - let r = generate body env in - let rec aux = function - | [] -> () - | token :: tokens -> - match attempt body r token with - | `Fail -> aux tokens - | `Accept _ -> - text body "\nCouldn't resume, generated final AST.\n" - | `Ok (_, recovered_from) -> - printf body "\nResumed with %S from:\n" - (let (t,_,_) = token in Dump.token t); - Dump.env body recovered_from - in - aux (token :: tokens) - ); - text body ".\n"; - Dump.env body env; - text body "\n" - )*) -end diff --git a/ocamlmerlin_mlx/kernel/mreader_recover.mli b/ocamlmerlin_mlx/kernel/mreader_recover.mli deleted file mode 100644 index e17f632..0000000 --- a/ocamlmerlin_mlx/kernel/mreader_recover.mli +++ /dev/null @@ -1,57 +0,0 @@ -# 1 "merlin/src/kernel/mreader_recover.mli" -module Make - (Parser : MenhirLib.IncrementalEngine.EVERYTHING) - (Recovery : sig - val default_value : Location.t -> 'a Parser.symbol -> 'a - - type action = - | Abort - | R of int - | S : 'a Parser.symbol -> action - | Sub of action list - - type decision = - | Nothing - | One of action list - | Select of (int -> action list) - - val depth : int array - - val can_pop : 'a Parser.terminal -> bool - - val recover : int -> decision - - val guide : 'a Parser.symbol -> bool - - val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token - - val nullable : 'a Parser.nonterminal -> bool - end) - (Dump : sig - val symbol : unit -> Parser.xsymbol -> string - end) : -sig - - type 'a candidate = { - line: int; - min_col: int; - max_col: int; - env: 'a Parser.env; - } - - type 'a candidates = { - popped: Parser.xsymbol list; - shifted: Parser.xsymbol option; - final: 'a option; - candidates: 'a candidate list; - } - - val attempt : 'a candidates -> - Parser.token * Lexing.position * Lexing.position -> - [> `Accept of 'a - | `Fail - | `Ok of 'a Parser.checkpoint * 'a Parser.env ] - - val generate : 'a Parser.env -> 'a candidates - -end diff --git a/ocamlmerlin_mlx/kernel/standard_library.ml b/ocamlmerlin_mlx/kernel/standard_library.ml new file mode 100644 index 0000000..481564d --- /dev/null +++ b/ocamlmerlin_mlx/kernel/standard_library.ml @@ -0,0 +1 @@ +let path = "/tmp" diff --git a/ocamlmerlin_mlx/ocaml/compression/dune b/ocamlmerlin_mlx/ocaml/compression/dune new file mode 100644 index 0000000..cd73e95 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/compression/dune @@ -0,0 +1,11 @@ +(library + (name mlx_ocaml_compression) + (package ocamlmerlin-mlx) + (libraries compiler-libs.common)) + +(rule + (targets ocaml_compression.ml) + (deps ocaml_compression.cppo.ml) + (action + (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) + diff --git a/ocamlmerlin_mlx/ocaml/compression/ocaml_compression.cppo.ml b/ocamlmerlin_mlx/ocaml/compression/ocaml_compression.cppo.ml new file mode 100644 index 0000000..a1724cd --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/compression/ocaml_compression.cppo.ml @@ -0,0 +1,6 @@ +#if OCAML_VERSION < (5, 1, 0) +let input_value ic = Marshal.from_channel ic +let output_value oc v = Marshal.to_channel oc v [] +#else +include Compression +#endif diff --git a/ocamlmerlin_mlx/ocaml/parsing/ast_helper.ml b/ocamlmerlin_mlx/ocaml/parsing/ast_helper.ml new file mode 100644 index 0000000..ce4c272 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/ast_helper.ml @@ -0,0 +1,695 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Helpers to produce Parsetree fragments *) + +open Asttypes +open Parsetree +open Docstrings +open Msupport_parsing + +type 'a with_loc = 'a Location.loc +type loc = Location.t + +type lid = Longident.t with_loc +type str = string with_loc +type str_opt = string option with_loc +type attrs = attribute list + +let default_loc = ref Location.none + +let const_string s = Pconst_string (s, !default_loc, None) + +let with_default_loc l f = + Misc.protect_refs [Misc.R (default_loc, l)] f + +module Const = struct + let integer ?suffix i = Pconst_integer (i, suffix) + let int ?suffix i = integer ?suffix (Int.to_string i) + let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) + let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) + let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) + let float ?suffix f = Pconst_float (f, suffix) + let char c = Pconst_char c + let string ?quotation_delimiter ?(loc= !default_loc) s = + Pconst_string (s, loc, quotation_delimiter) +end + +module Attr = struct + let mk ?(loc= !default_loc) name payload = + { attr_name = name; + attr_payload = payload; + attr_loc = loc } + + let as_tuple { attr_name; attr_payload; _ } = (attr_name, attr_payload) +end + +module Typ = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ptyp_desc = d; + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = attrs} + + let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} + + let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any + let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) + let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) + let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) + let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) + let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) + let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) + let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) + let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) + + let force_poly t = + match t.ptyp_desc with + | Ptyp_poly _ -> t + | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) + + let varify_constructors var_names t = + let check_variable vl loc v = + if List.mem v vl then + raise_error Syntaxerr.(Error(Variable_in_scope(loc,v))) in + let var_names = List.map (fun v -> v.txt) var_names in + let rec loop t = + let desc = + match t.ptyp_desc with + | Ptyp_any -> Ptyp_any + | Ptyp_var x -> + check_variable var_names t.ptyp_loc x; + Ptyp_var x + | Ptyp_arrow (label,core_type,core_type') -> + Ptyp_arrow(label, loop core_type, loop core_type') + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr( { txt = Longident.Lident s }, []) + when List.mem s var_names -> + Ptyp_var s + | Ptyp_constr(longident, lst) -> + Ptyp_constr(longident, List.map loop lst) + | Ptyp_object (lst, o) -> + Ptyp_object (List.map loop_object_field lst, o) + | Ptyp_class (longident, lst) -> + Ptyp_class (longident, List.map loop lst) + | Ptyp_alias(core_type, string) -> + check_variable var_names t.ptyp_loc string; + Ptyp_alias(loop core_type, string) + | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> + Ptyp_variant(List.map loop_row_field row_field_list, + flag, lbl_lst_option) + | Ptyp_poly(string_lst, core_type) -> + List.iter (fun v -> + check_variable var_names t.ptyp_loc v.txt) string_lst; + Ptyp_poly(string_lst, loop core_type) + | Ptyp_package(longident,lst) -> + Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) + | Ptyp_extension (s, arg) -> + Ptyp_extension (s, arg) + in + {t with ptyp_desc = desc} + and loop_row_field field = + let prf_desc = match field.prf_desc with + | Rtag(label,flag,lst) -> + Rtag(label,flag,List.map loop lst) + | Rinherit t -> + Rinherit (loop t) + in + { field with prf_desc; } + and loop_object_field field = + let pof_desc = match field.pof_desc with + | Otag(label, t) -> + Otag(label, loop t) + | Oinherit t -> + Oinherit (loop t) + in + { field with pof_desc; } + in + loop t + +end + +module Pat = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ppat_desc = d; + ppat_loc = loc; + ppat_loc_stack = []; + ppat_attributes = attrs} + let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} + + let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any + let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) + let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) + let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) + let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) + let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) + let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) + let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) + let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) + let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) +end + +(* Merlin's holes *) +let hole_txt = "merlin.hole" + +module Exp = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pexp_desc = d; + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = attrs} + let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) + let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) + let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) + let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) + let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) + let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) + let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) + let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) + let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) + let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) + let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) + let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) + let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) + let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) + let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) + let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) + let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) + let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) + let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) + let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) + let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) + let letmodule_no_opt ?loc ?attrs s b c= + let a = Location.mknoloc (Some s) in + mk ?loc ?attrs (Pexp_letmodule (a, b, c)) + let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) + let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) + let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) + let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) + let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) + let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) + let letop ?loc ?attrs let_ ands body = + mk ?loc ?attrs (Pexp_letop {let_; ands; body}) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) + let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable + let hole ?(loc = !default_loc) ?attrs () = + let id = Location.mkloc hole_txt loc in + mk ~loc ?attrs @@ Pexp_extension (id, PStr []) + + let case lhs ?guard rhs = + { + pc_lhs = lhs; + pc_guard = guard; + pc_rhs = rhs; + } + + let binding_op op pat exp loc = + { + pbop_op = op; + pbop_pat = pat; + pbop_exp = exp; + pbop_loc = loc; + } +end + +module Mty = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} + let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) + let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) + let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) + let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) + let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) + let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) +end + +module Mod = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} + let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} + + let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) + let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) + let functor_ ?loc ?attrs arg body = + mk ?loc ?attrs (Pmod_functor (arg, body)) + let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) + let apply_unit ?loc ?attrs m1 = mk ?loc ?attrs (Pmod_apply_unit m1) + let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) + let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) + let hole ?(loc = !default_loc) ?attrs () = + let id = Location.mkloc hole_txt loc in + mk ~loc ?attrs @@ Pmod_extension (id, PStr []) +end + +module Sig = struct + let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} + + let value ?loc a = mk ?loc (Psig_value a) + let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) + let type_subst ?loc a = mk ?loc (Psig_typesubst a) + let type_extension ?loc a = mk ?loc (Psig_typext a) + let exception_ ?loc a = mk ?loc (Psig_exception a) + let module_ ?loc a = mk ?loc (Psig_module a) + let mod_subst ?loc a = mk ?loc (Psig_modsubst a) + let rec_module ?loc a = mk ?loc (Psig_recmodule a) + let modtype ?loc a = mk ?loc (Psig_modtype a) + let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a) + let open_ ?loc a = mk ?loc (Psig_open a) + let include_ ?loc a = mk ?loc (Psig_include a) + let class_ ?loc a = mk ?loc (Psig_class a) + let class_type ?loc a = mk ?loc (Psig_class_type a) + let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) + let attribute ?loc a = mk ?loc (Psig_attribute a) + let text txt = + let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + f_txt +end + +module Str = struct + let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} + + let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) + let value ?loc a b = mk ?loc (Pstr_value (a, b)) + let primitive ?loc a = mk ?loc (Pstr_primitive a) + let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) + let type_extension ?loc a = mk ?loc (Pstr_typext a) + let exception_ ?loc a = mk ?loc (Pstr_exception a) + let module_ ?loc a = mk ?loc (Pstr_module a) + let rec_module ?loc a = mk ?loc (Pstr_recmodule a) + let modtype ?loc a = mk ?loc (Pstr_modtype a) + let open_ ?loc a = mk ?loc (Pstr_open a) + let class_ ?loc a = mk ?loc (Pstr_class a) + let class_type ?loc a = mk ?loc (Pstr_class_type a) + let include_ ?loc a = mk ?loc (Pstr_include a) + let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) + let attribute ?loc a = mk ?loc (Pstr_attribute a) + let text txt = + let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + f_txt +end + +module Cl = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { + pcl_desc = d; + pcl_loc = loc; + pcl_attributes = attrs; + } + let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} + + let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) + let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) + let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) + let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) +end + +module Cty = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + { + pcty_desc = d; + pcty_loc = loc; + pcty_attributes = attrs; + } + let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} + + let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) + let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) + let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) +end + +module Ctf = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) d = + { + pctf_desc = d; + pctf_loc = loc; + pctf_attributes = add_docs_attrs docs attrs; + } + + let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) + let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) + let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) + let attribute ?loc a = mk ?loc (Pctf_attribute a) + let text txt = + let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + f_txt + + let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} + +end + +module Cf = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) d = + { + pcf_desc = d; + pcf_loc = loc; + pcf_attributes = add_docs_attrs docs attrs; + } + + let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) + let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) + let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) + let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) + let attribute ?loc a = mk ?loc (Pcf_attribute a) + let text txt = + let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + f_txt + + let virtual_ ct = Cfk_virtual ct + let concrete o e = Cfk_concrete (o, e) + + let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} + +end + +module Val = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(prim = []) name typ = + { + pval_name = name; + pval_type = typ; + pval_attributes = add_docs_attrs docs attrs; + pval_loc = loc; + pval_prim = prim; + } +end + +module Md = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) name typ = + { + pmd_name = name; + pmd_type = typ; + pmd_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pmd_loc = loc; + } +end + +module Ms = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) name syn = + { + pms_name = name; + pms_manifest = syn; + pms_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pms_loc = loc; + } +end + +module Mtd = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) ?typ name = + { + pmtd_name = name; + pmtd_type = typ; + pmtd_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pmtd_loc = loc; + } +end + +module Mb = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) name expr = + { + pmb_name = name; + pmb_expr = expr; + pmb_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pmb_loc = loc; + } +end + +module Opn = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(override = Fresh) expr = + { + popen_expr = expr; + popen_override = override; + popen_loc = loc; + popen_attributes = add_docs_attrs docs attrs; + } +end + +module Incl = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = + { + pincl_mod = mexpr; + pincl_loc = loc; + pincl_attributes = add_docs_attrs docs attrs; + } + +end + +module Vb = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(text = []) ?value_constraint pat expr = + { + pvb_pat = pat; + pvb_expr = expr; + pvb_constraint=value_constraint; + pvb_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pvb_loc = loc; + } +end + +module Ci = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) + ?(virt = Concrete) ?(params = []) name expr = + { + pci_virt = virt; + pci_params = params; + pci_name = name; + pci_expr = expr; + pci_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + pci_loc = loc; + } +end + +module Type = struct + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) + ?(params = []) + ?(cstrs = []) + ?(kind = Ptype_abstract) + ?(priv = Public) + ?manifest + name = + { + ptype_name = name; + ptype_params = params; + ptype_cstrs = cstrs; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = manifest; + ptype_attributes = + add_text_attrs text (add_docs_attrs docs attrs); + ptype_loc = loc; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) + ?(vars = []) ?(args = Pcstr_tuple []) ?res name = + { + pcd_name = name; + pcd_vars = vars; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = add_info_attrs info attrs; + } + + let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) + ?(mut = Immutable) name typ = + { + pld_name = name; + pld_mutable = mut; + pld_type = typ; + pld_loc = loc; + pld_attributes = add_info_attrs info attrs; + } + +end + +(** Type extensions *) +module Te = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(params = []) ?(priv = Public) path constructors = + { + ptyext_path = path; + ptyext_params = params; + ptyext_constructors = constructors; + ptyext_private = priv; + ptyext_loc = loc; + ptyext_attributes = add_docs_attrs docs attrs; + } + + let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + constructor = + { + ptyexn_constructor = constructor; + ptyexn_loc = loc; + ptyexn_attributes = add_docs_attrs docs attrs; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(info = empty_info) name kind = + { + pext_name = name; + pext_kind = kind; + pext_loc = loc; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); + } + + let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(info = empty_info) ?(vars = []) ?(args = Pcstr_tuple []) ?res name = + { + pext_name = name; + pext_kind = Pext_decl(vars, args, res); + pext_loc = loc; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); + } + + let rebind ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(info = empty_info) name lid = + { + pext_name = name; + pext_kind = Pext_rebind lid; + pext_loc = loc; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); + } + +end + +module Csig = struct + let mk self fields = + { + pcsig_self = self; + pcsig_fields = fields; + } +end + +module Cstr = struct + let mk self fields = + { + pcstr_self = self; + pcstr_fields = fields; + } +end + +(** Row fields *) +module Rf = struct + let mk ?(loc = !default_loc) ?(attrs = []) desc = { + prf_desc = desc; + prf_loc = loc; + prf_attributes = attrs; + } + let tag ?loc ?attrs label const tys = + mk ?loc ?attrs (Rtag (label, const, tys)) + let inherit_?loc ty = + mk ?loc (Rinherit ty) +end + +(** Object fields *) +module Of = struct + let mk ?(loc = !default_loc) ?(attrs=[]) desc = { + pof_desc = desc; + pof_loc = loc; + pof_attributes = attrs; + } + let tag ?loc ?attrs label ty = + mk ?loc ?attrs (Otag (label, ty)) + let inherit_ ?loc ty = + mk ?loc (Oinherit ty) +end + +(** merlin: refactored out of Parser *) + +type let_binding = + { lb_pattern: pattern; + lb_expression: expression; + lb_constraint: value_constraint option; + lb_is_pun: bool; + lb_attributes: attributes; + lb_docs: docs Lazy.t; + lb_text: text Lazy.t; + lb_loc: Location.t; } + +type let_bindings = + { lbs_bindings: let_binding list; + lbs_rec: rec_flag; + lbs_extension: string Asttypes.loc option } + + +(* merlin specific *) + +let no_label = Nolabel + +(* Can't be put in Raw_compat because that module depends on library "parsing", + but we need that function in this library *) +let extract_str_payload = function + | PStr [{ pstr_desc = Pstr_eval ( + {Parsetree. pexp_loc; pexp_desc = + Parsetree.Pexp_constant (Parsetree.Pconst_string (msg, _, _)) ; _ }, _ + ); _ }] -> + Some (msg, pexp_loc) + | _ -> None diff --git a/ocamlmerlin_mlx/ocaml/parsing/ast_helper.mli b/ocamlmerlin_mlx/ocaml/parsing/ast_helper.mli new file mode 100644 index 0000000..8ac40ed --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/ast_helper.mli @@ -0,0 +1,529 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Helpers to produce Parsetree fragments + + {b Warning} This module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Asttypes +open Docstrings +open Parsetree + +type 'a with_loc = 'a Location.loc +type loc = Location.t + +type lid = Longident.t with_loc +type str = string with_loc +type str_opt = string option with_loc +type attrs = attribute list + +val const_string : string -> constant + +(** {1 Default locations} *) + +val default_loc: loc ref + (** Default value for all optional location arguments. *) + +val with_default_loc: loc -> (unit -> 'a) -> 'a + (** Set the [default_loc] within the scope of the execution + of the provided function. *) + +(** {1 Constants} *) + +module Const : sig + val char : char -> constant + val string : + ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant + val integer : ?suffix:char -> string -> constant + val int : ?suffix:char -> int -> constant + val int32 : ?suffix:char -> int32 -> constant + val int64 : ?suffix:char -> int64 -> constant + val nativeint : ?suffix:char -> nativeint -> constant + val float : ?suffix:char -> string -> constant +end + +(** {1 Attributes} *) +module Attr : sig + val mk: ?loc:loc -> str -> payload -> attribute + + val as_tuple : attribute -> str * payload +end + +(** {1 Core language} *) + +(** Type expressions *) +module Typ : + sig + val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type + val attr: core_type -> attribute -> core_type + + val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type + val var: ?loc:loc -> ?attrs:attrs -> string -> core_type + val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type + -> core_type + val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type + val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type + val object_: ?loc:loc -> ?attrs:attrs -> object_field list + -> closed_flag -> core_type + val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type + val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type + val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag + -> label list option -> core_type + val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type + val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list + -> core_type + val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type + + val force_poly: core_type -> core_type + + val varify_constructors: str list -> core_type -> core_type + (** [varify_constructors newtypes te] is type expression [te], of which + any of nullary type constructor [tc] is replaced by type variable of + the same name, if [tc]'s name appears in [newtypes]. + Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] + appears in [newtypes]. + @since 4.05 + *) + end + +(** Patterns *) +module Pat: + sig + val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern + val attr:pattern -> attribute -> pattern + + val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern + val var: ?loc:loc -> ?attrs:attrs -> str -> pattern + val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern + val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern + val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern + val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + val construct: ?loc:loc -> ?attrs:attrs -> + lid -> (str list * pattern) option -> pattern + val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern + val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag + -> pattern + val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern + val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern + val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern + val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern + val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern + val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern + val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern + val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern + end + +(** Expressions *) +module Exp: + sig + val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression + val attr: expression -> attribute -> expression + + val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression + val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression + val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list + -> expression -> expression + val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option + -> pattern -> expression -> expression + val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression + val apply: ?loc:loc -> ?attrs:attrs -> expression + -> (arg_label * expression) list -> expression + val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list + -> expression + val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression + val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option + -> expression + val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option + -> expression + val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list + -> expression option -> expression + val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression + val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression + -> expression + val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression + val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression + -> expression option -> expression + val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression + -> expression + val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression + -> expression + val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression + -> direction_flag -> expression -> expression + val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option + -> core_type -> expression + val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type + -> expression + val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression + val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression + val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list + -> expression + val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr + -> expression -> expression + val letmodule_no_opt: ?loc:loc -> ?attrs:attrs -> label -> module_expr + -> expression -> expression + val letexception: + ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression + -> expression + val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression + val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression + val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option + -> expression + val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression + val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression + val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression + -> expression + val letop: ?loc:loc -> ?attrs:attrs -> binding_op + -> binding_op list -> expression -> expression + val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression + val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression + + val case: pattern -> ?guard:expression -> expression -> case + val binding_op: str -> pattern -> expression -> loc -> binding_op + val hole: ?loc:loc -> ?attrs:attrs -> unit -> expression + end + +(** Value declarations *) +module Val: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + ?prim:string list -> str -> core_type -> value_description + end + +(** Type declarations *) +module Type: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?params:(core_type * (variance * injectivity)) list -> + ?cstrs:(core_type * core_type * loc) list -> + ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> + type_declaration + + val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> + ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> + str -> + constructor_declaration + val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> + ?mut:mutable_flag -> str -> core_type -> label_declaration + end + +(** Type extensions *) +module Te: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + ?params:(core_type * (variance * injectivity)) list -> + ?priv:private_flag -> lid -> extension_constructor list -> type_extension + + val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + extension_constructor -> type_exception + + val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + str -> extension_constructor_kind -> extension_constructor + + val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> + str -> + extension_constructor + val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + str -> lid -> extension_constructor + end + +(** {1 Module language} *) + +(** Module type expressions *) +module Mty: + sig + val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type + val attr: module_type -> attribute -> module_type + + val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type + val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type + val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type + val functor_: ?loc:loc -> ?attrs:attrs -> + functor_parameter -> module_type -> module_type + val with_: ?loc:loc -> ?attrs:attrs -> module_type -> + with_constraint list -> module_type + val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type + val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type + end + +(** Module expressions *) +module Mod: + sig + val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr + val attr: module_expr -> attribute -> module_expr + + val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr + val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr + val functor_: ?loc:loc -> ?attrs:attrs -> + functor_parameter -> module_expr -> module_expr + val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> + module_expr + val apply_unit: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr + val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> + module_expr + val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr + val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr + val hole: ?loc:loc -> ?attrs:attrs -> unit -> module_expr + end + +(** Signature items *) +module Sig: + sig + val mk: ?loc:loc -> signature_item_desc -> signature_item + + val value: ?loc:loc -> value_description -> signature_item + val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item + val type_subst: ?loc:loc -> type_declaration list -> signature_item + val type_extension: ?loc:loc -> type_extension -> signature_item + val exception_: ?loc:loc -> type_exception -> signature_item + val module_: ?loc:loc -> module_declaration -> signature_item + val mod_subst: ?loc:loc -> module_substitution -> signature_item + val rec_module: ?loc:loc -> module_declaration list -> signature_item + val modtype: ?loc:loc -> module_type_declaration -> signature_item + val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item + val open_: ?loc:loc -> open_description -> signature_item + val include_: ?loc:loc -> include_description -> signature_item + val class_: ?loc:loc -> class_description list -> signature_item + val class_type: ?loc:loc -> class_type_declaration list -> signature_item + val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item + val attribute: ?loc:loc -> attribute -> signature_item + val text: text -> signature_item list + end + +(** Structure items *) +module Str: + sig + val mk: ?loc:loc -> structure_item_desc -> structure_item + + val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item + val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item + val primitive: ?loc:loc -> value_description -> structure_item + val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item + val type_extension: ?loc:loc -> type_extension -> structure_item + val exception_: ?loc:loc -> type_exception -> structure_item + val module_: ?loc:loc -> module_binding -> structure_item + val rec_module: ?loc:loc -> module_binding list -> structure_item + val modtype: ?loc:loc -> module_type_declaration -> structure_item + val open_: ?loc:loc -> open_declaration -> structure_item + val class_: ?loc:loc -> class_declaration list -> structure_item + val class_type: ?loc:loc -> class_type_declaration list -> structure_item + val include_: ?loc:loc -> include_declaration -> structure_item + val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item + val attribute: ?loc:loc -> attribute -> structure_item + val text: text -> structure_item list + end + +(** Module declarations *) +module Md: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + str_opt -> module_type -> module_declaration + end + +(** Module substitutions *) +module Ms: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + str -> lid -> module_substitution + end + +(** Module type declarations *) +module Mtd: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?typ:module_type -> str -> module_type_declaration + end + +(** Module bindings *) +module Mb: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + str_opt -> module_expr -> module_binding + end + +(** Opens *) +module Opn: + sig + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> + ?override:override_flag -> 'a -> 'a open_infos + end + +(** Includes *) +module Incl: + sig + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos + end + +(** Value bindings *) +module Vb: + sig + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?value_constraint:value_constraint -> pattern -> expression -> + value_binding + end + + +(** {1 Class language} *) + +(** Class type expressions *) +module Cty: + sig + val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type + val attr: class_type -> attribute -> class_type + + val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type + val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type + val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> + class_type -> class_type + val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type + val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type + -> class_type + end + +(** Class type fields *) +module Ctf: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + class_type_field_desc -> class_type_field + val attr: class_type_field -> attribute -> class_type_field + + val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field + val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> + virtual_flag -> core_type -> class_type_field + val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> + virtual_flag -> core_type -> class_type_field + val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> + class_type_field + val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field + val attribute: ?loc:loc -> attribute -> class_type_field + val text: text -> class_type_field list + end + +(** Class expressions *) +module Cl: + sig + val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr + val attr: class_expr -> attribute -> class_expr + + val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr + val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr + val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> + pattern -> class_expr -> class_expr + val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> + (arg_label * expression) list -> class_expr + val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> + class_expr -> class_expr + val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> + class_expr + val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr + val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr + -> class_expr + end + +(** Class fields *) +module Cf: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> + class_field + val attr: class_field -> attribute -> class_field + + val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> + str option -> class_field + val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> + class_field_kind -> class_field + val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> + class_field_kind -> class_field + val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> + class_field + val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field + val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field + val attribute: ?loc:loc -> attribute -> class_field + val text: text -> class_field list + + val virtual_: core_type -> class_field_kind + val concrete: override_flag -> expression -> class_field_kind + + end + +(** Classes *) +module Ci: + sig + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?virt:virtual_flag -> + ?params:(core_type * (variance * injectivity)) list -> + str -> 'a -> 'a class_infos + end + +(** Class signatures *) +module Csig: + sig + val mk: core_type -> class_type_field list -> class_signature + end + +(** Class structures *) +module Cstr: + sig + val mk: pattern -> class_field list -> class_structure + end + +(** Row fields *) +module Rf: + sig + val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field + val tag: ?loc:loc -> ?attrs:attrs -> + label with_loc -> bool -> core_type list -> row_field + val inherit_: ?loc:loc -> core_type -> row_field + end + +(** Object fields *) +module Of: + sig + val mk: ?loc:loc -> ?attrs:attrs -> + object_field_desc -> object_field + val tag: ?loc:loc -> ?attrs:attrs -> + label with_loc -> core_type -> object_field + val inherit_: ?loc:loc -> core_type -> object_field + end + +(** merlin: refactored out of Parser *) + +type let_binding = + { lb_pattern: pattern; + lb_expression: expression; + lb_constraint: value_constraint option; + lb_is_pun: bool; + lb_attributes: attributes; + lb_docs: docs Lazy.t; + lb_text: text Lazy.t; + lb_loc: Location.t; } + +type let_bindings = + { lbs_bindings: let_binding list; + lbs_rec: rec_flag; + lbs_extension: string Asttypes.loc option } + + +(* merlin specific *) + +val no_label : arg_label +val extract_str_payload : payload -> (string * Location.t) option +val hole_txt : string diff --git a/ocamlmerlin_mlx/ocaml/parsing/ast_iterator.ml b/ocamlmerlin_mlx/ocaml/parsing/ast_iterator.ml new file mode 100644 index 0000000..2398e77 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/ast_iterator.ml @@ -0,0 +1,697 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@ocaml.warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + + +open Parsetree +open Location + +type iterator = { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attribute list -> unit; + binding_op: iterator -> binding_op -> unit; + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + class_declaration: iterator -> class_declaration -> unit; + class_description: iterator -> class_description -> unit; + class_expr: iterator -> class_expr -> unit; + class_field: iterator -> class_field -> unit; + class_signature: iterator -> class_signature -> unit; + class_structure: iterator -> class_structure -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + constructor_declaration: iterator -> constructor_declaration -> unit; + expr: iterator -> expression -> unit; + extension: iterator -> extension -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + include_declaration: iterator -> include_declaration -> unit; + include_description: iterator -> include_description -> unit; + label_declaration: iterator -> label_declaration -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_substitution: iterator -> module_substitution -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + open_declaration: iterator -> open_declaration -> unit; + open_description: iterator -> open_description -> unit; + pat: iterator -> pattern -> unit; + payload: iterator -> payload -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; +} +(** A [iterator] record implements one "method" per syntactic category, + using an open recursion style: each method takes as its first + argument the iterator to be applied to children in the syntax + tree. *) + +let iter_fst f (x, _) = f x +let iter_snd f (_, y) = f y +let iter_tuple f1 f2 (x, y) = f1 x; f2 y +let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z +let iter_opt f = function None -> () | Some x -> f x + +let iter_loc sub {loc; txt = _} = sub.location sub loc + +module T = struct + (* Type expressions for the core language *) + + let row_field sub { + prf_desc; + prf_loc; + prf_attributes; + } = + sub.location sub prf_loc; + sub.attributes sub prf_attributes; + match prf_desc with + | Rtag (_, _, tl) -> List.iter (sub.typ sub) tl + | Rinherit t -> sub.typ sub t + + let object_field sub { + pof_desc; + pof_loc; + pof_attributes; + } = + sub.location sub pof_loc; + sub.attributes sub pof_attributes; + match pof_desc with + | Otag (_, t) -> sub.typ sub t + | Oinherit t -> sub.typ sub t + + let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Ptyp_any + | Ptyp_var _ -> () + | Ptyp_arrow (_lab, t1, t2) -> + sub.typ sub t1; sub.typ sub t2 + | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl + | Ptyp_constr (lid, tl) -> + iter_loc sub lid; List.iter (sub.typ sub) tl + | Ptyp_object (ol, _o) -> + List.iter (object_field sub) ol + | Ptyp_class (lid, tl) -> + iter_loc sub lid; List.iter (sub.typ sub) tl + | Ptyp_alias (t, _) -> sub.typ sub t + | Ptyp_variant (rl, _b, _ll) -> + List.iter (row_field sub) rl + | Ptyp_poly (_, t) -> sub.typ sub t + | Ptyp_package (lid, l) -> + iter_loc sub lid; + List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l + | Ptyp_extension x -> sub.extension sub x + + let iter_type_declaration sub + {ptype_name; ptype_params; ptype_cstrs; + ptype_kind; + ptype_private = _; + ptype_manifest; + ptype_attributes; + ptype_loc} = + iter_loc sub ptype_name; + List.iter (iter_fst (sub.typ sub)) ptype_params; + List.iter + (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs; + sub.type_kind sub ptype_kind; + iter_opt (sub.typ sub) ptype_manifest; + sub.location sub ptype_loc; + sub.attributes sub ptype_attributes + + let iter_type_kind sub = function + | Ptype_abstract -> () + | Ptype_variant l -> + List.iter (sub.constructor_declaration sub) l + | Ptype_record l -> List.iter (sub.label_declaration sub) l + | Ptype_open -> () + + let iter_constructor_arguments sub = function + | Pcstr_tuple l -> List.iter (sub.typ sub) l + | Pcstr_record l -> + List.iter (sub.label_declaration sub) l + + let iter_type_extension sub + {ptyext_path; ptyext_params; + ptyext_constructors; + ptyext_private = _; + ptyext_loc; + ptyext_attributes} = + iter_loc sub ptyext_path; + List.iter (sub.extension_constructor sub) ptyext_constructors; + List.iter (iter_fst (sub.typ sub)) ptyext_params; + sub.location sub ptyext_loc; + sub.attributes sub ptyext_attributes + + let iter_type_exception sub + {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = + sub.extension_constructor sub ptyexn_constructor; + sub.location sub ptyexn_loc; + sub.attributes sub ptyexn_attributes + + let iter_extension_constructor_kind sub = function + Pext_decl(vars, ctl, cto) -> + List.iter (iter_loc sub) vars; + iter_constructor_arguments sub ctl; + iter_opt (sub.typ sub) cto + | Pext_rebind li -> + iter_loc sub li + + let iter_extension_constructor sub + {pext_name; + pext_kind; + pext_loc; + pext_attributes} = + iter_loc sub pext_name; + iter_extension_constructor_kind sub pext_kind; + sub.location sub pext_loc; + sub.attributes sub pext_attributes + +end + +module CT = struct + (* Type expressions for the class language *) + + let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pcty_constr (lid, tys) -> + iter_loc sub lid; List.iter (sub.typ sub) tys + | Pcty_signature x -> sub.class_signature sub x + | Pcty_arrow (_lab, t, ct) -> + sub.typ sub t; sub.class_type sub ct + | Pcty_extension x -> sub.extension sub x + | Pcty_open (o, e) -> + sub.open_description sub o; sub.class_type sub e + + let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} + = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pctf_inherit ct -> sub.class_type sub ct + | Pctf_val (_s, _m, _v, t) -> sub.typ sub t + | Pctf_method (_s, _p, _v, t) -> sub.typ sub t + | Pctf_constraint (t1, t2) -> + sub.typ sub t1; sub.typ sub t2 + | Pctf_attribute x -> sub.attribute sub x + | Pctf_extension x -> sub.extension sub x + + let iter_signature sub {pcsig_self; pcsig_fields} = + sub.typ sub pcsig_self; + List.iter (sub.class_type_field sub) pcsig_fields +end + +let iter_functor_param sub = function + | Unit -> () + | Named (name, mty) -> + iter_loc sub name; + sub.module_type sub mty + +module MT = struct + (* Type expressions for the module language *) + + let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pmty_ident s -> iter_loc sub s + | Pmty_alias s -> iter_loc sub s + | Pmty_signature sg -> sub.signature sub sg + | Pmty_functor (param, mt2) -> + iter_functor_param sub param; + sub.module_type sub mt2 + | Pmty_with (mt, l) -> + sub.module_type sub mt; + List.iter (sub.with_constraint sub) l + | Pmty_typeof me -> sub.module_expr sub me + | Pmty_extension x -> sub.extension sub x + + let iter_with_constraint sub = function + | Pwith_type (lid, d) -> + iter_loc sub lid; sub.type_declaration sub d + | Pwith_module (lid, lid2) -> + iter_loc sub lid; iter_loc sub lid2 + | Pwith_modtype (lid, mty) -> + iter_loc sub lid; sub.module_type sub mty + | Pwith_typesubst (lid, d) -> + iter_loc sub lid; sub.type_declaration sub d + | Pwith_modsubst (s, lid) -> + iter_loc sub s; iter_loc sub lid + | Pwith_modtypesubst (lid, mty) -> + iter_loc sub lid; sub.module_type sub mty + + let iter_signature_item sub {psig_desc = desc; psig_loc = loc} = + sub.location sub loc; + match desc with + | Psig_value vd -> sub.value_description sub vd + | Psig_type (_, l) + | Psig_typesubst l -> + List.iter (sub.type_declaration sub) l + | Psig_typext te -> sub.type_extension sub te + | Psig_exception ed -> sub.type_exception sub ed + | Psig_module x -> sub.module_declaration sub x + | Psig_modsubst x -> sub.module_substitution sub x + | Psig_recmodule l -> + List.iter (sub.module_declaration sub) l + | Psig_modtype x | Psig_modtypesubst x -> sub.module_type_declaration sub x + | Psig_open x -> sub.open_description sub x + | Psig_include x -> sub.include_description sub x + | Psig_class l -> List.iter (sub.class_description sub) l + | Psig_class_type l -> + List.iter (sub.class_type_declaration sub) l + | Psig_extension (x, attrs) -> + sub.attributes sub attrs; + sub.extension sub x + | Psig_attribute x -> sub.attribute sub x +end + + +module M = struct + (* Value expressions for the module language *) + + let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pmod_ident x -> iter_loc sub x + | Pmod_structure str -> sub.structure sub str + | Pmod_functor (param, body) -> + iter_functor_param sub param; + sub.module_expr sub body + | Pmod_apply (m1, m2) -> + sub.module_expr sub m1; + sub.module_expr sub m2 + | Pmod_apply_unit m1 -> + sub.module_expr sub m1 + | Pmod_constraint (m, mty) -> + sub.module_expr sub m; sub.module_type sub mty + | Pmod_unpack e -> sub.expr sub e + | Pmod_extension x -> sub.extension sub x + + let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + sub.location sub loc; + match desc with + | Pstr_eval (x, attrs) -> + sub.attributes sub attrs; sub.expr sub x + | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs + | Pstr_primitive vd -> sub.value_description sub vd + | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l + | Pstr_typext te -> sub.type_extension sub te + | Pstr_exception ed -> sub.type_exception sub ed + | Pstr_module x -> sub.module_binding sub x + | Pstr_recmodule l -> List.iter (sub.module_binding sub) l + | Pstr_modtype x -> sub.module_type_declaration sub x + | Pstr_open x -> sub.open_declaration sub x + | Pstr_class l -> List.iter (sub.class_declaration sub) l + | Pstr_class_type l -> + List.iter (sub.class_type_declaration sub) l + | Pstr_include x -> sub.include_declaration sub x + | Pstr_extension (x, attrs) -> + sub.attributes sub attrs; sub.extension sub x + | Pstr_attribute x -> sub.attribute sub x +end + +module E = struct + (* Value expressions for the core language *) + + let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pexp_ident x -> iter_loc sub x + | Pexp_constant _ -> () + | Pexp_let (_r, vbs, e) -> + List.iter (sub.value_binding sub) vbs; + sub.expr sub e + | Pexp_fun (_lab, def, p, e) -> + iter_opt (sub.expr sub) def; + sub.pat sub p; + sub.expr sub e + | Pexp_function pel -> sub.cases sub pel + | Pexp_apply (e, l) -> + sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l + | Pexp_match (e, pel) -> + sub.expr sub e; sub.cases sub pel + | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel + | Pexp_tuple el -> List.iter (sub.expr sub) el + | Pexp_construct (lid, arg) -> + iter_loc sub lid; iter_opt (sub.expr sub) arg + | Pexp_variant (_lab, eo) -> + iter_opt (sub.expr sub) eo + | Pexp_record (l, eo) -> + List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; + iter_opt (sub.expr sub) eo + | Pexp_field (e, lid) -> + sub.expr sub e; iter_loc sub lid + | Pexp_setfield (e1, lid, e2) -> + sub.expr sub e1; iter_loc sub lid; + sub.expr sub e2 + | Pexp_array el -> List.iter (sub.expr sub) el + | Pexp_ifthenelse (e1, e2, e3) -> + sub.expr sub e1; sub.expr sub e2; + iter_opt (sub.expr sub) e3 + | Pexp_sequence (e1, e2) -> + sub.expr sub e1; sub.expr sub e2 + | Pexp_while (e1, e2) -> + sub.expr sub e1; sub.expr sub e2 + | Pexp_for (p, e1, e2, _d, e3) -> + sub.pat sub p; sub.expr sub e1; sub.expr sub e2; + sub.expr sub e3 + | Pexp_coerce (e, t1, t2) -> + sub.expr sub e; iter_opt (sub.typ sub) t1; + sub.typ sub t2 + | Pexp_constraint (e, t) -> + sub.expr sub e; sub.typ sub t + | Pexp_send (e, _s) -> sub.expr sub e + | Pexp_new lid -> iter_loc sub lid + | Pexp_setinstvar (s, e) -> + iter_loc sub s; sub.expr sub e + | Pexp_override sel -> + List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel + | Pexp_letmodule (s, me, e) -> + iter_loc sub s; sub.module_expr sub me; + sub.expr sub e + | Pexp_letexception (cd, e) -> + sub.extension_constructor sub cd; + sub.expr sub e + | Pexp_assert e -> sub.expr sub e + | Pexp_lazy e -> sub.expr sub e + | Pexp_poly (e, t) -> + sub.expr sub e; iter_opt (sub.typ sub) t + | Pexp_object cls -> sub.class_structure sub cls + | Pexp_newtype (_s, e) -> sub.expr sub e + | Pexp_pack me -> sub.module_expr sub me + | Pexp_open (o, e) -> + sub.open_declaration sub o; sub.expr sub e + | Pexp_letop {let_; ands; body} -> + sub.binding_op sub let_; + List.iter (sub.binding_op sub) ands; + sub.expr sub body + | Pexp_extension x -> sub.extension sub x + | Pexp_unreachable -> () + + let iter_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = + iter_loc sub pbop_op; + sub.pat sub pbop_pat; + sub.expr sub pbop_exp; + sub.location sub pbop_loc + +end + +module P = struct + (* Patterns *) + + let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Ppat_any -> () + | Ppat_var s -> iter_loc sub s + | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s + | Ppat_constant _ -> () + | Ppat_interval _ -> () + | Ppat_tuple pl -> List.iter (sub.pat sub) pl + | Ppat_construct (l, p) -> + iter_loc sub l; + iter_opt + (fun (vl,p) -> + List.iter (iter_loc sub) vl; + sub.pat sub p) + p + | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p + | Ppat_record (lpl, _cf) -> + List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl + | Ppat_array pl -> List.iter (sub.pat sub) pl + | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 + | Ppat_constraint (p, t) -> + sub.pat sub p; sub.typ sub t + | Ppat_type s -> iter_loc sub s + | Ppat_lazy p -> sub.pat sub p + | Ppat_unpack s -> iter_loc sub s + | Ppat_exception p -> sub.pat sub p + | Ppat_extension x -> sub.extension sub x + | Ppat_open (lid, p) -> + iter_loc sub lid; sub.pat sub p + +end + +module CE = struct + (* Value expressions for the class language *) + + let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pcl_constr (lid, tys) -> + iter_loc sub lid; List.iter (sub.typ sub) tys + | Pcl_structure s -> + sub.class_structure sub s + | Pcl_fun (_lab, e, p, ce) -> + iter_opt (sub.expr sub) e; + sub.pat sub p; + sub.class_expr sub ce + | Pcl_apply (ce, l) -> + sub.class_expr sub ce; + List.iter (iter_snd (sub.expr sub)) l + | Pcl_let (_r, vbs, ce) -> + List.iter (sub.value_binding sub) vbs; + sub.class_expr sub ce + | Pcl_constraint (ce, ct) -> + sub.class_expr sub ce; sub.class_type sub ct + | Pcl_extension x -> sub.extension sub x + | Pcl_open (o, e) -> + sub.open_description sub o; sub.class_expr sub e + + let iter_kind sub = function + | Cfk_concrete (_o, e) -> sub.expr sub e + | Cfk_virtual t -> sub.typ sub t + + let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce + | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k + | Pcf_method (s, _p, k) -> + iter_loc sub s; iter_kind sub k + | Pcf_constraint (t1, t2) -> + sub.typ sub t1; sub.typ sub t2 + | Pcf_initializer e -> sub.expr sub e + | Pcf_attribute x -> sub.attribute sub x + | Pcf_extension x -> sub.extension sub x + + let iter_structure sub {pcstr_self; pcstr_fields} = + sub.pat sub pcstr_self; + List.iter (sub.class_field sub) pcstr_fields + + let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr; + pci_loc; pci_attributes} = + List.iter (iter_fst (sub.typ sub)) pl; + iter_loc sub pci_name; + f pci_expr; + sub.location sub pci_loc; + sub.attributes sub pci_attributes +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_iterator = + { + structure = (fun this l -> List.iter (this.structure_item this) l); + structure_item = M.iter_structure_item; + module_expr = M.iter; + signature = (fun this l -> List.iter (this.signature_item this) l); + signature_item = MT.iter_signature_item; + module_type = MT.iter; + with_constraint = MT.iter_with_constraint; + class_declaration = + (fun this -> CE.class_infos this (this.class_expr this)); + class_expr = CE.iter; + class_field = CE.iter_field; + class_structure = CE.iter_structure; + class_type = CT.iter; + class_type_field = CT.iter_field; + class_signature = CT.iter_signature; + class_type_declaration = + (fun this -> CE.class_infos this (this.class_type this)); + class_description = + (fun this -> CE.class_infos this (this.class_type this)); + type_declaration = T.iter_type_declaration; + type_kind = T.iter_type_kind; + typ = T.iter; + row_field = T.row_field; + object_field = T.object_field; + type_extension = T.iter_type_extension; + type_exception = T.iter_type_exception; + extension_constructor = T.iter_extension_constructor; + value_description = + (fun this {pval_name; pval_type; pval_prim = _; pval_loc; + pval_attributes} -> + iter_loc this pval_name; + this.typ this pval_type; + this.location this pval_loc; + this.attributes this pval_attributes; + ); + + pat = P.iter; + expr = E.iter; + binding_op = E.iter_binding_op; + + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + iter_loc this pmd_name; + this.module_type this pmd_type; + this.location this pmd_loc; + this.attributes this pmd_attributes; + ); + + module_substitution = + (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> + iter_loc this pms_name; + iter_loc this pms_manifest; + this.location this pms_loc; + this.attributes this pms_attributes; + ); + + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + iter_loc this pmtd_name; + iter_opt (this.module_type this) pmtd_type; + this.location this pmtd_loc; + this.attributes this pmtd_attributes; + ); + + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + iter_loc this pmb_name; this.module_expr this pmb_expr; + this.location this pmb_loc; + this.attributes this pmb_attributes; + ); + + open_declaration = + (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> + this.module_expr this popen_expr; + this.location this popen_loc; + this.attributes this popen_attributes + ); + + open_description = + (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> + iter_loc this popen_expr; + this.location this popen_loc; + this.attributes this popen_attributes + ); + + + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + this.module_type this pincl_mod; + this.location this pincl_loc; + this.attributes this pincl_attributes + ); + + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + this.module_expr this pincl_mod; + this.location this pincl_loc; + this.attributes this pincl_attributes + ); + + + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc; pvb_constraint} -> + this.pat this pvb_pat; + this.expr this pvb_expr; + Option.iter (function + | Parsetree.Pvc_constraint {locally_abstract_univars=vars; typ} -> + List.iter (iter_loc this) vars; + this.typ this typ + | Pvc_coercion { ground; coercion } -> + Option.iter (this.typ this) ground; + this.typ this coercion; + ) pvb_constraint; + this.location this pvb_loc; + this.attributes this pvb_attributes + ); + + + constructor_declaration = + (fun this {pcd_name; pcd_vars; pcd_args; + pcd_res; pcd_loc; pcd_attributes} -> + iter_loc this pcd_name; + List.iter (iter_loc this) pcd_vars; + T.iter_constructor_arguments this pcd_args; + iter_opt (this.typ this) pcd_res; + this.location this pcd_loc; + this.attributes this pcd_attributes + ); + + label_declaration = + (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}-> + iter_loc this pld_name; + this.typ this pld_type; + this.location this pld_loc; + this.attributes this pld_attributes + ); + + cases = (fun this l -> List.iter (this.case this) l); + case = + (fun this {pc_lhs; pc_guard; pc_rhs} -> + this.pat this pc_lhs; + iter_opt (this.expr this) pc_guard; + this.expr this pc_rhs + ); + + location = (fun _this _l -> ()); + + extension = (fun this (s, e) -> iter_loc this s; this.payload this e); + attribute = (fun this a -> + iter_loc this a.attr_name; + this.payload this a.attr_payload; + this.location this a.attr_loc + ); + attributes = (fun this l -> List.iter (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> this.structure this x + | PSig x -> this.signature this x + | PTyp x -> this.typ this x + | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g + ); + } diff --git a/ocamlmerlin_mlx/ocaml/parsing/ast_iterator.mli b/ocamlmerlin_mlx/ocaml/parsing/ast_iterator.mli new file mode 100644 index 0000000..638ac5e --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/ast_iterator.mli @@ -0,0 +1,84 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** {!Ast_iterator.iterator} enables AST inspection using open recursion. A + typical mapper would be based on {!Ast_iterator.default_iterator}, a + trivial iterator, and will fall back on it for handling the syntax it does + not modify. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Parsetree + +(** {1 A generic Parsetree iterator} *) + +type iterator = { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attribute list -> unit; + binding_op: iterator -> binding_op -> unit; + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + class_declaration: iterator -> class_declaration -> unit; + class_description: iterator -> class_description -> unit; + class_expr: iterator -> class_expr -> unit; + class_field: iterator -> class_field -> unit; + class_signature: iterator -> class_signature -> unit; + class_structure: iterator -> class_structure -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + constructor_declaration: iterator -> constructor_declaration -> unit; + expr: iterator -> expression -> unit; + extension: iterator -> extension -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + include_declaration: iterator -> include_declaration -> unit; + include_description: iterator -> include_description -> unit; + label_declaration: iterator -> label_declaration -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_substitution: iterator -> module_substitution -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + open_declaration: iterator -> open_declaration -> unit; + open_description: iterator -> open_description -> unit; + pat: iterator -> pattern -> unit; + payload: iterator -> payload -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; +} +(** A [iterator] record implements one "method" per syntactic category, + using an open recursion style: each method takes as its first + argument the iterator to be applied to children in the syntax + tree. *) + +val default_iterator: iterator +(** A default iterator, which implements a "do not do anything" mapping. *) diff --git a/ocamlmerlin_mlx/ocaml/parsing/ast_mapper.ml b/ocamlmerlin_mlx/ocaml/parsing/ast_mapper.ml new file mode 100644 index 0000000..12d9018 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/ast_mapper.ml @@ -0,0 +1,1106 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@ocaml.warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + +open Parsetree +open Ast_helper +open Location + +module String = Misc.String + +type mapper = { + attribute: mapper -> attribute -> attribute; + attributes: mapper -> attribute list -> attribute list; + binding_op: mapper -> binding_op -> binding_op; + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + class_declaration: mapper -> class_declaration -> class_declaration; + class_description: mapper -> class_description -> class_description; + class_expr: mapper -> class_expr -> class_expr; + class_field: mapper -> class_field -> class_field; + class_signature: mapper -> class_signature -> class_signature; + class_structure: mapper -> class_structure -> class_structure; + class_type: mapper -> class_type -> class_type; + class_type_declaration: mapper -> class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> class_type_field -> class_type_field; + constant: mapper -> constant -> constant; + constructor_declaration: mapper -> constructor_declaration + -> constructor_declaration; + expr: mapper -> expression -> expression; + extension: mapper -> extension -> extension; + extension_constructor: mapper -> extension_constructor + -> extension_constructor; + include_declaration: mapper -> include_declaration -> include_declaration; + include_description: mapper -> include_description -> include_description; + label_declaration: mapper -> label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> module_binding; + module_declaration: mapper -> module_declaration -> module_declaration; + module_substitution: mapper -> module_substitution -> module_substitution; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: mapper -> module_type_declaration + -> module_type_declaration; + open_declaration: mapper -> open_declaration -> open_declaration; + open_description: mapper -> open_description -> open_description; + pat: mapper -> pattern -> pattern; + payload: mapper -> payload -> payload; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_extension: mapper -> type_extension -> type_extension; + type_exception: mapper -> type_exception -> type_exception; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; +} + +let map_fst f (x, y) = (f x, y) +let map_snd f (x, y) = (x, f y) +let map_tuple f1 f2 (x, y) = (f1 x, f2 y) +let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let map_opt f = function None -> None | Some x -> Some (f x) + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +module C = struct + (* Constants *) + + let map sub c = match c with + | Pconst_integer _ + | Pconst_char _ + | Pconst_float _ + -> c + | Pconst_string (s, loc, quotation_delimiter) -> + let loc = sub.location sub loc in + Const.string ~loc ?quotation_delimiter s +end + +module T = struct + (* Type expressions for the core language *) + + let row_field sub { + prf_desc; + prf_loc; + prf_attributes; + } = + let loc = sub.location sub prf_loc in + let attrs = sub.attributes sub prf_attributes in + let desc = match prf_desc with + | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) + | Rinherit t -> Rinherit (sub.typ sub t) + in + Rf.mk ~loc ~attrs desc + + let object_field sub { + pof_desc; + pof_loc; + pof_attributes; + } = + let loc = sub.location sub pof_loc in + let attrs = sub.attributes sub pof_attributes in + let desc = match pof_desc with + | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) + | Oinherit t -> Oinherit (sub.typ sub t) + in + Of.mk ~loc ~attrs desc + + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + let open Typ in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Ptyp_any -> any ~loc ~attrs () + | Ptyp_var s -> var ~loc ~attrs s + | Ptyp_arrow (lab, t1, t2) -> + arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) + | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) + | Ptyp_constr (lid, tl) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + | Ptyp_object (l, o) -> + object_ ~loc ~attrs (List.map (object_field sub) l) o + | Ptyp_class (lid, tl) -> + class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s + | Ptyp_variant (rl, b, ll) -> + variant ~loc ~attrs (List.map (row_field sub) rl) b ll + | Ptyp_poly (sl, t) -> poly ~loc ~attrs + (List.map (map_loc sub) sl) (sub.typ sub t) + | Ptyp_package (lid, l) -> + package ~loc ~attrs (map_loc sub lid) + (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_type_declaration sub + {ptype_name; ptype_params; ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc} = + let loc = sub.location sub ptype_loc in + let attrs = sub.attributes sub ptype_attributes in + Type.mk ~loc ~attrs (map_loc sub ptype_name) + ~params:(List.map (map_fst (sub.typ sub)) ptype_params) + ~priv:ptype_private + ~cstrs:(List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs) + ~kind:(sub.type_kind sub ptype_kind) + ?manifest:(map_opt (sub.typ sub) ptype_manifest) + + let map_type_kind sub = function + | Ptype_abstract -> Ptype_abstract + | Ptype_variant l -> + Ptype_variant (List.map (sub.constructor_declaration sub) l) + | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) + | Ptype_open -> Ptype_open + + let map_constructor_arguments sub = function + | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_record l -> + Pcstr_record (List.map (sub.label_declaration sub) l) + + let map_type_extension sub + {ptyext_path; ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes} = + let loc = sub.location sub ptyext_loc in + let attrs = sub.attributes sub ptyext_attributes in + Te.mk ~loc ~attrs + (map_loc sub ptyext_path) + (List.map (sub.extension_constructor sub) ptyext_constructors) + ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) + ~priv:ptyext_private + + let map_type_exception sub + {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = + let loc = sub.location sub ptyexn_loc in + let attrs = sub.attributes sub ptyexn_attributes in + Te.mk_exception ~loc ~attrs + (sub.extension_constructor sub ptyexn_constructor) + + let map_extension_constructor_kind sub = function + Pext_decl(vars, ctl, cto) -> + Pext_decl(List.map (map_loc sub) vars, + map_constructor_arguments sub ctl, + map_opt (sub.typ sub) cto) + | Pext_rebind li -> + Pext_rebind (map_loc sub li) + + let map_extension_constructor sub + {pext_name; + pext_kind; + pext_loc; + pext_attributes} = + let loc = sub.location sub pext_loc in + let attrs = sub.attributes sub pext_attributes in + Te.constructor ~loc ~attrs + (map_loc sub pext_name) + (map_extension_constructor_kind sub pext_kind) + +end + +module CT = struct + (* Type expressions for the class language *) + + let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = + let open Cty in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pcty_constr (lid, tys) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) + | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) + | Pcty_arrow (lab, t, ct) -> + arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) + | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pcty_open (o, ct) -> + open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) + + let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} + = + let open Ctf in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) + | Pctf_val (s, m, v, t) -> + val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) + | Pctf_method (s, p, v, t) -> + method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) + | Pctf_constraint (t1, t2) -> + constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) + | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) + | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_signature sub {pcsig_self; pcsig_fields} = + Csig.mk + (sub.typ sub pcsig_self) + (List.map (sub.class_type_field sub) pcsig_fields) +end + +let map_functor_param sub = function + | Unit -> Unit + | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) + +module MT = struct + (* Type expressions for the module language *) + + let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + let open Mty in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) + | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) + | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) + | Pmty_functor (param, mt) -> + functor_ ~loc ~attrs + (map_functor_param sub param) + (sub.module_type sub mt) + | Pmty_with (mt, l) -> + with_ ~loc ~attrs (sub.module_type sub mt) + (List.map (sub.with_constraint sub) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) + | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_with_constraint sub = function + | Pwith_type (lid, d) -> + Pwith_type (map_loc sub lid, sub.type_declaration sub d) + | Pwith_module (lid, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Pwith_modtype (lid, mty) -> + Pwith_modtype (map_loc sub lid, sub.module_type sub mty) + | Pwith_typesubst (lid, d) -> + Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) + | Pwith_modsubst (s, lid) -> + Pwith_modsubst (map_loc sub s, map_loc sub lid) + | Pwith_modtypesubst (lid, mty) -> + Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty) + + let map_signature_item sub {psig_desc = desc; psig_loc = loc} = + let open Sig in + let loc = sub.location sub loc in + match desc with + | Psig_value vd -> value ~loc (sub.value_description sub vd) + | Psig_type (rf, l) -> + type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Psig_typesubst l -> + type_subst ~loc (List.map (sub.type_declaration sub) l) + | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) + | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) + | Psig_module x -> module_ ~loc (sub.module_declaration sub x) + | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) + | Psig_recmodule l -> + rec_module ~loc (List.map (sub.module_declaration sub) l) + | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Psig_modtypesubst x -> + modtype_subst ~loc (sub.module_type_declaration sub x) + | Psig_open x -> open_ ~loc (sub.open_description sub x) + | Psig_include x -> include_ ~loc (sub.include_description sub x) + | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) + | Psig_class_type l -> + class_type ~loc (List.map (sub.class_type_declaration sub) l) + | Psig_extension (x, attrs) -> + let attrs = sub.attributes sub attrs in + extension ~loc ~attrs (sub.extension sub x) + | Psig_attribute x -> attribute ~loc (sub.attribute sub x) +end + + +module M = struct + (* Value expressions for the module language *) + + let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + let open Mod in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) + | Pmod_functor (param, body) -> + functor_ ~loc ~attrs + (map_functor_param sub param) + (sub.module_expr sub body) + | Pmod_apply (m1, m2) -> + apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) + | Pmod_apply_unit m1 -> + apply_unit ~loc ~attrs (sub.module_expr sub m1) + | Pmod_constraint (m, mty) -> + constraint_ ~loc ~attrs (sub.module_expr sub m) + (sub.module_type sub mty) + | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) + | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let open Str in + let loc = sub.location sub loc in + match desc with + | Pstr_eval (x, attrs) -> + let attrs = sub.attributes sub attrs in + eval ~loc ~attrs (sub.expr sub x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) + | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) + | Pstr_module x -> module_ ~loc (sub.module_binding sub x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) + | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) + | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) + | Pstr_class_type l -> + class_type ~loc (List.map (sub.class_type_declaration sub) l) + | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) + | Pstr_extension (x, attrs) -> + let attrs = sub.attributes sub attrs in + extension ~loc ~attrs (sub.extension sub x) + | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) +end + +module E = struct + (* Value expressions for the core language *) + + let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + let open Exp in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) + | Pexp_let (r, vbs, e) -> + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) + (sub.expr sub e) + | Pexp_fun (lab, def, p, e) -> + fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) + (sub.expr sub e) + | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) + | Pexp_apply (e, l) -> + apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) + | Pexp_match (e, pel) -> + match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_construct (lid, arg) -> + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) + | Pexp_variant (lab, eo) -> + variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + | Pexp_record (l, eo) -> + record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (map_opt (sub.expr sub) eo) + | Pexp_field (e, lid) -> + field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + | Pexp_setfield (e1, lid, e2) -> + setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) + (sub.expr sub e2) + | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_ifthenelse (e1, e2, e3) -> + ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + (map_opt (sub.expr sub) e3) + | Pexp_sequence (e1, e2) -> + sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_while (e1, e2) -> + while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_for (p, e1, e2, d, e3) -> + for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d + (sub.expr sub e3) + | Pexp_coerce (e, t1, t2) -> + coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) + (sub.typ sub t2) + | Pexp_constraint (e, t) -> + constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) + | Pexp_send (e, s) -> + send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) + | Pexp_setinstvar (s, e) -> + setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_override sel -> + override ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) + | Pexp_letmodule (s, me, e) -> + letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) + (sub.expr sub e) + | Pexp_letexception (cd, e) -> + letexception ~loc ~attrs + (sub.extension_constructor sub cd) + (sub.expr sub e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) + | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) + | Pexp_poly (e, t) -> + poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) + | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) + | Pexp_newtype (s, e) -> + newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) + | Pexp_open (o, e) -> + open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) + | Pexp_letop {let_; ands; body} -> + letop ~loc ~attrs (sub.binding_op sub let_) + (List.map (sub.binding_op sub) ands) (sub.expr sub body) + | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pexp_unreachable -> unreachable ~loc ~attrs () + + let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = + let open Exp in + let op = map_loc sub pbop_op in + let pat = sub.pat sub pbop_pat in + let exp = sub.expr sub pbop_exp in + let loc = sub.location sub pbop_loc in + binding_op op pat exp loc + +end + +module P = struct + (* Patterns *) + + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + let open Pat in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Ppat_any -> any ~loc ~attrs () + | Ppat_var s -> var ~loc ~attrs (map_loc sub s) + | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) + | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c) + | Ppat_interval (c1, c2) -> + interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2) + | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_construct (l, p) -> + construct ~loc ~attrs (map_loc sub l) + (map_opt + (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p) + p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) + | Ppat_record (lpl, cf) -> + record ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf + | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) + | Ppat_constraint (p, t) -> + constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) + | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) + | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) + | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) + | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) + | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) + | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) +end + +module CE = struct + (* Value expressions for the class language *) + + let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = + let open Cl in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pcl_constr (lid, tys) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) + | Pcl_structure s -> + structure ~loc ~attrs (sub.class_structure sub s) + | Pcl_fun (lab, e, p, ce) -> + fun_ ~loc ~attrs lab + (map_opt (sub.expr sub) e) + (sub.pat sub p) + (sub.class_expr sub ce) + | Pcl_apply (ce, l) -> + apply ~loc ~attrs (sub.class_expr sub ce) + (List.map (map_snd (sub.expr sub)) l) + | Pcl_let (r, vbs, ce) -> + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) + (sub.class_expr sub ce) + | Pcl_constraint (ce, ct) -> + constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) + | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pcl_open (o, ce) -> + open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) + + let map_kind sub = function + | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) + | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) + + let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = + let open Cf in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pcf_inherit (o, ce, s) -> + inherit_ ~loc ~attrs o (sub.class_expr sub ce) + (map_opt (map_loc sub) s) + | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) + | Pcf_method (s, p, k) -> + method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) + | Pcf_constraint (t1, t2) -> + constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) + | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) + | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) + | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_structure sub {pcstr_self; pcstr_fields} = + { + pcstr_self = sub.pat sub pcstr_self; + pcstr_fields = List.map (sub.class_field sub) pcstr_fields; + } + + let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; + pci_loc; pci_attributes} = + let loc = sub.location sub pci_loc in + let attrs = sub.attributes sub pci_attributes in + Ci.mk ~loc ~attrs + ~virt:pci_virt + ~params:(List.map (map_fst (sub.typ sub)) pl) + (map_loc sub pci_name) + (f pci_expr) +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_mapper = + { + constant = C.map; + structure = (fun this l -> List.map (this.structure_item this) l); + structure_item = M.map_structure_item; + module_expr = M.map; + signature = (fun this l -> List.map (this.signature_item this) l); + signature_item = MT.map_signature_item; + module_type = MT.map; + with_constraint = MT.map_with_constraint; + class_declaration = + (fun this -> CE.class_infos this (this.class_expr this)); + class_expr = CE.map; + class_field = CE.map_field; + class_structure = CE.map_structure; + class_type = CT.map; + class_type_field = CT.map_field; + class_signature = CT.map_signature; + class_type_declaration = + (fun this -> CE.class_infos this (this.class_type this)); + class_description = + (fun this -> CE.class_infos this (this.class_type this)); + type_declaration = T.map_type_declaration; + type_kind = T.map_type_kind; + typ = T.map; + type_extension = T.map_type_extension; + type_exception = T.map_type_exception; + extension_constructor = T.map_extension_constructor; + value_description = + (fun this {pval_name; pval_type; pval_prim; pval_loc; + pval_attributes} -> + Val.mk + (map_loc this pval_name) + (this.typ this pval_type) + ~attrs:(this.attributes this pval_attributes) + ~loc:(this.location this pval_loc) + ~prim:pval_prim + ); + + pat = P.map; + expr = E.map; + binding_op = E.map_binding_op; + + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + Md.mk + (map_loc this pmd_name) + (this.module_type this pmd_type) + ~attrs:(this.attributes this pmd_attributes) + ~loc:(this.location this pmd_loc) + ); + + module_substitution = + (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> + Ms.mk + (map_loc this pms_name) + (map_loc this pms_manifest) + ~attrs:(this.attributes this pms_attributes) + ~loc:(this.location this pms_loc) + ); + + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + Mtd.mk + (map_loc this pmtd_name) + ?typ:(map_opt (this.module_type this) pmtd_type) + ~attrs:(this.attributes this pmtd_attributes) + ~loc:(this.location this pmtd_loc) + ); + + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) + ~attrs:(this.attributes this pmb_attributes) + ~loc:(this.location this pmb_loc) + ); + + + open_declaration = + (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> + Opn.mk (this.module_expr this popen_expr) + ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes) + ); + + open_description = + (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> + Opn.mk (map_loc this popen_expr) + ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes) + ); + + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk (this.module_type this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes) + ); + + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk (this.module_expr this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes) + ); + + + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc} -> + let map_ct (ct:Parsetree.value_constraint) = match ct with + | Pvc_constraint {locally_abstract_univars=vars; typ} -> + Pvc_constraint + { locally_abstract_univars = List.map (map_loc this) vars; + typ = this.typ this typ + } + | Pvc_coercion { ground; coercion } -> + Pvc_coercion { + ground = Option.map (this.typ this) ground; + coercion = this.typ this coercion + } + in + Vb.mk + (this.pat this pvb_pat) + (this.expr this pvb_expr) + ?value_constraint:(Option.map map_ct pvb_constraint) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes) + ); + + + constructor_declaration = + (fun this {pcd_name; pcd_vars; pcd_args; + pcd_res; pcd_loc; pcd_attributes} -> + Type.constructor + (map_loc this pcd_name) + ~vars:(List.map (map_loc this) pcd_vars) + ~args:(T.map_constructor_arguments this pcd_args) + ?res:(map_opt (this.typ this) pcd_res) + ~loc:(this.location this pcd_loc) + ~attrs:(this.attributes this pcd_attributes) + ); + + label_declaration = + (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> + Type.field + (map_loc this pld_name) + (this.typ this pld_type) + ~mut:pld_mutable + ~loc:(this.location this pld_loc) + ~attrs:(this.attributes this pld_attributes) + ); + + cases = (fun this l -> List.map (this.case this) l); + case = + (fun this {pc_lhs; pc_guard; pc_rhs} -> + { + pc_lhs = this.pat this pc_lhs; + pc_guard = map_opt (this.expr this) pc_guard; + pc_rhs = this.expr this pc_rhs; + } + ); + + + + location = (fun _this l -> l); + + extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attribute = (fun this a -> + { + attr_name = map_loc this a.attr_name; + attr_payload = this.payload this a.attr_payload; + attr_loc = this.location this a.attr_loc + } + ); + attributes = (fun this l -> List.map (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> PStr (this.structure this x) + | PSig x -> PSig (this.signature this x) + | PTyp x -> PTyp (this.typ this x) + | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) + ); + } + +let extension_of_error {kind; main; sub} = + if kind <> Location.Report_error then + raise (Invalid_argument "extension_of_error: expected kind Report_error"); + let str_of_pp pp_msg = Format.asprintf "%t" pp_msg in + let extension_of_sub sub = + { loc = sub.loc; txt = "ocaml.error" }, + PStr ([Str.eval (Exp.constant + (Pconst_string (str_of_pp sub.txt, sub.loc, None)))]) + in + { loc = main.loc; txt = "ocaml.error" }, + PStr (Str.eval (Exp.constant + (Pconst_string (str_of_pp main.txt, main.loc, None))) :: + List.map (fun msg -> Str.extension (extension_of_sub msg)) sub) + +let attribute_of_warning loc s = + Attr.mk + {loc; txt = "ocaml.ppwarning" } + (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))])) + +let cookies = ref String.Map.empty + +let get_cookie k = + try Some (String.Map.find k !cookies) + with Not_found -> None + +let set_cookie k v = + cookies := String.Map.add k v !cookies + +let tool_name_ref = ref "_none_" + +let tool_name () = !tool_name_ref + + +module PpxContext = struct + open Longident + open Asttypes + open Ast_helper + + let lid name = { txt = Lident name; loc = Location.none } + + let make_string s = Exp.constant (Const.string s) + + let make_bool x = + if x + then Exp.construct (lid "true") None + else Exp.construct (lid "false") None + + let rec make_list f lst = + match lst with + | x :: rest -> + Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) + | [] -> + Exp.construct (lid "[]") None + + let make_pair f1 f2 (x1, x2) = + Exp.tuple [f1 x1; f2 x2] + + let make_option f opt = + match opt with + | Some x -> Exp.construct (lid "Some") (Some (f x)) + | None -> Exp.construct (lid "None") None + + let get_cookies () = + lid "cookies", + make_list (make_pair make_string (fun x -> x)) + (String.Map.bindings !cookies) + + let mk fields = + { + attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; + attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; + attr_loc = Location.none + } + + let make ~tool_name () = + let fields = + [ + lid "tool_name", make_string tool_name; + lid "include_dirs", make_list make_string !Clflags.include_dirs; + lid "load_path", make_list make_string (Load_path.get_paths ()); + lid "open_modules", make_list make_string !Clflags.open_modules; + lid "for_package", make_option make_string !Clflags.for_package; + lid "debug", make_bool !Clflags.debug; + lid "use_threads", make_bool false; + lid "use_vmthreads", make_bool false; + lid "recursive_types", make_bool !Clflags.recursive_types; + lid "principal", make_bool !Clflags.principal; + lid "transparent_modules", make_bool !Clflags.transparent_modules; + lid "unboxed_types", make_bool !Clflags.unboxed_types; + lid "unsafe_string", make_bool false; (* kept for compatibility *) + get_cookies () + ] + in + mk fields + + let get_fields = function + | PStr [{pstr_desc = Pstr_eval + ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> + fields + | _ -> + raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" + + let restore fields = + let field name payload = + let rec get_string = function + | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] string syntax" name + and get_bool pexp = + match pexp with + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, + None)} -> + true + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, + None)} -> + false + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] bool syntax" name + and get_list elem = function + | {pexp_desc = + Pexp_construct ({txt = Longident.Lident "::"}, + Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> + elem exp :: get_list elem rest + | {pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> + [] + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] list syntax" name + and get_pair f1 f2 = function + | {pexp_desc = Pexp_tuple [e1; e2]} -> + (f1 e1, f2 e2) + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] pair syntax" name + and get_option elem = function + | { pexp_desc = + Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> + Some (elem exp) + | { pexp_desc = + Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> + None + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ + { %s }] option syntax" name + in + match name with + | "tool_name" -> + tool_name_ref := get_string payload + | "include_dirs" -> + Clflags.include_dirs := get_list get_string payload + | "load_path" -> + (* Duplicates Compmisc.auto_include, since we can't reference Compmisc + from this module. *) + (* let auto_include find_in_dir fn = + if !Clflags.no_std_include then + raise Not_found + else + let alert = Location.auto_include_alert in + Load_path.auto_include_otherlibs alert find_in_dir fn + in *) + Load_path.(init + ~auto_include:no_auto_include (get_list get_string payload)) + | "open_modules" -> + Clflags.open_modules := get_list get_string payload + | "for_package" -> + Clflags.for_package := get_option get_string payload + | "debug" -> + Clflags.debug := get_bool payload + (*| "use_threads" -> + Clflags.use_threads := get_bool payload + | "use_vmthreads" -> + if get_bool payload then + raise_errorf "Internal error: vmthreads not supported after 4.09.0" + *) + | "recursive_types" -> + Clflags.recursive_types := get_bool payload + | "principal" -> + Clflags.principal := get_bool payload + | "transparent_modules" -> + Clflags.transparent_modules := get_bool payload + | "unboxed_types" -> + Clflags.unboxed_types := get_bool payload + | "cookies" -> + let l = get_list (get_pair get_string (fun x -> x)) payload in + cookies := + List.fold_left + (fun s (k, v) -> String.Map.add k v s) String.Map.empty + l + | _ -> + () + in + List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields + + let update_cookies fields = + let fields = + List.filter + (function ({txt=Lident "cookies"}, _) -> false | _ -> true) + fields + in + fields @ [get_cookies ()] +end + +let ppx_context = PpxContext.make + +let extension_of_exn exn = + match error_of_exn exn with + | Some (`Ok error) -> extension_of_error error + | Some `Already_displayed -> + { loc = Location.none; txt = "ocaml.error" }, PStr [] + | None -> raise exn + + +let apply_lazy ~source ~target mapper = + let implem ast = + let fields, ast = + match ast with + | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"}; + attr_payload = x})} :: l -> + PpxContext.get_fields x, l + | _ -> [], ast + in + PpxContext.restore fields; + let ast = + try + let mapper = mapper () in + mapper.structure mapper ast + with exn -> + [{pstr_desc = Pstr_extension (extension_of_exn exn, []); + pstr_loc = Location.none}] + in + let fields = PpxContext.update_cookies fields in + Str.attribute (PpxContext.mk fields) :: ast + in + let iface ast = + let fields, ast = + match ast with + | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"}; + attr_payload = x; + attr_loc = _})} :: l -> + PpxContext.get_fields x, l + | _ -> [], ast + in + PpxContext.restore fields; + let ast = + try + let mapper = mapper () in + mapper.signature mapper ast + with exn -> + [{psig_desc = Psig_extension (extension_of_exn exn, []); + psig_loc = Location.none}] + in + let fields = PpxContext.update_cookies fields in + Sig.attribute (PpxContext.mk fields) :: ast + in + + let ic = open_in_bin source in + let magic = + really_input_string ic (String.length Config.ast_impl_magic_number) + in + + let rewrite transform = + Location.input_name := input_value ic; + let ast = input_value ic in + close_in ic; + let ast = transform ast in + let oc = open_out_bin target in + output_string oc magic; + output_value oc !Location.input_name; + output_value oc ast; + close_out oc + and fail () = + close_in ic; + failwith "Ast_mapper: OCaml version mismatch or malformed input"; + in + + if magic = Config.ast_impl_magic_number then + rewrite (implem : structure -> structure) + else if magic = Config.ast_intf_magic_number then + rewrite (iface : signature -> signature) + else fail () + +let drop_ppx_context_str ~restore = function + | {pstr_desc = Pstr_attribute + {attr_name = {Location.txt = "ocaml.ppx.context"}; + attr_payload = a; + attr_loc = _}} + :: items -> + if restore then + PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let drop_ppx_context_sig ~restore = function + | {psig_desc = Psig_attribute + {attr_name = {Location.txt = "ocaml.ppx.context"}; + attr_payload = a; + attr_loc = _}} + :: items -> + if restore then + PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let add_ppx_context_str ~tool_name ast = + Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast + +let add_ppx_context_sig ~tool_name ast = + Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast + + +let apply ~source ~target mapper = + apply_lazy ~source ~target (fun () -> mapper) + +let run_main mapper = + try + let a = Sys.argv in + let n = Array.length a in + if n > 2 then + let mapper () = + try mapper (Array.to_list (Array.sub a 1 (n - 3))) + with exn -> + (* PR#6463 *) + let f _ _ = raise exn in + {default_mapper with structure = f; signature = f} + in + apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper + else begin + Printf.eprintf "Usage: %s [extra_args] \n%!" + Sys.executable_name; + exit 2 + end + with exn -> + prerr_endline (Printexc.to_string exn); + exit 2 + +let register_function = ref (fun _name f -> run_main f) +let register name f = !register_function name f diff --git a/ocamlmerlin_mlx/ocaml/parsing/ast_mapper.mli b/ocamlmerlin_mlx/ocaml/parsing/ast_mapper.mli new file mode 100644 index 0000000..69f6b01 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/ast_mapper.mli @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** The interface of a -ppx rewriter + + A -ppx rewriter is a program that accepts a serialized abstract syntax + tree and outputs another, possibly modified, abstract syntax tree. + This module encapsulates the interface between the compiler and + the -ppx rewriters, handling such details as the serialization format, + forwarding of command-line flags, and storing state. + + {!mapper} enables AST rewriting using open recursion. + A typical mapper would be based on {!default_mapper}, a deep + identity mapper, and will fall back on it for handling the syntax it + does not modify. For example: + + {[ +open Asttypes +open Parsetree +open Ast_mapper + +let test_mapper argv = + { default_mapper with + expr = fun mapper expr -> + match expr with + | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> + Ast_helper.Exp.constant (Const_int 42) + | other -> default_mapper.expr mapper other; } + +let () = + register "ppx_test" test_mapper]} + + This -ppx rewriter, which replaces [[%test]] in expressions with + the constant [42], can be compiled using + [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + + *) + +open Parsetree + +(** {1 A generic Parsetree mapper} *) + +type mapper = { + attribute: mapper -> attribute -> attribute; + attributes: mapper -> attribute list -> attribute list; + binding_op: mapper -> binding_op -> binding_op; + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + class_declaration: mapper -> class_declaration -> class_declaration; + class_description: mapper -> class_description -> class_description; + class_expr: mapper -> class_expr -> class_expr; + class_field: mapper -> class_field -> class_field; + class_signature: mapper -> class_signature -> class_signature; + class_structure: mapper -> class_structure -> class_structure; + class_type: mapper -> class_type -> class_type; + class_type_declaration: mapper -> class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> class_type_field -> class_type_field; + constant: mapper -> constant -> constant; + constructor_declaration: mapper -> constructor_declaration + -> constructor_declaration; + expr: mapper -> expression -> expression; + extension: mapper -> extension -> extension; + extension_constructor: mapper -> extension_constructor + -> extension_constructor; + include_declaration: mapper -> include_declaration -> include_declaration; + include_description: mapper -> include_description -> include_description; + label_declaration: mapper -> label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> module_binding; + module_declaration: mapper -> module_declaration -> module_declaration; + module_substitution: mapper -> module_substitution -> module_substitution; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: mapper -> module_type_declaration + -> module_type_declaration; + open_declaration: mapper -> open_declaration -> open_declaration; + open_description: mapper -> open_description -> open_description; + pat: mapper -> pattern -> pattern; + payload: mapper -> payload -> payload; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_extension: mapper -> type_extension -> type_extension; + type_exception: mapper -> type_exception -> type_exception; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; +} +(** A mapper record implements one "method" per syntactic category, + using an open recursion style: each method takes as its first + argument the mapper to be applied to children in the syntax + tree. *) + +val default_mapper: mapper +(** A default mapper, which implements a "deep identity" mapping. *) + +(** {1 Apply mappers to compilation units} *) + +val tool_name: unit -> string +(** Can be used within a ppx preprocessor to know which tool is + calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], + ["ocaml"], ... Some global variables that reflect command-line + options are automatically synchronized between the calling tool + and the ppx preprocessor: {!Clflags.include_dirs}, + {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, + {!Clflags.debug}. *) + + +val apply: source:string -> target:string -> mapper -> unit +(** Apply a mapper (parametrized by the unit name) to a dumped + parsetree found in the [source] file and put the result in the + [target] file. The [structure] or [signature] field of the mapper + is applied to the implementation or interface. *) + +val run_main: (string list -> mapper) -> unit +(** Entry point to call to implement a standalone -ppx rewriter from a + mapper, parametrized by the command line arguments. The current + unit name can be obtained from {!Location.input_name}. This + function implements proper error reporting for uncaught + exceptions. *) + +(** {1 Registration API} *) + +val register_function: (string -> (string list -> mapper) -> unit) ref + +val register: string -> (string list -> mapper) -> unit +(** Apply the [register_function]. The default behavior is to run the + mapper immediately, taking arguments from the process command + line. This is to support a scenario where a mapper is linked as a + stand-alone executable. + + It is possible to overwrite the [register_function] to define + "-ppx drivers", which combine several mappers in a single process. + Typically, a driver starts by defining [register_function] to a + custom implementation, then lets ppx rewriters (linked statically + or dynamically) register themselves, and then run all or some of + them. It is also possible to have -ppx drivers apply rewriters to + only specific parts of an AST. + + The first argument to [register] is a symbolic name to be used by + the ppx driver. *) + + +(** {1 Convenience functions to write mappers} *) + +val map_opt: ('a -> 'b) -> 'a option -> 'b option + +val extension_of_error: Location.error -> extension +(** Encode an error into an 'ocaml.error' extension node which can be + inserted in a generated Parsetree. The compiler will be + responsible for reporting the error. *) + +val attribute_of_warning: Location.t -> string -> attribute +(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be + inserted in a generated Parsetree. The compiler will be + responsible for reporting the warning. *) + +(** {1 Helper functions to call external mappers} *) + +val add_ppx_context_str: + tool_name:string -> Parsetree.structure -> Parsetree.structure +(** Extract information from the current environment and encode it + into an attribute which is prepended to the list of structure + items in order to pass the information to an external + processor. *) + +val add_ppx_context_sig: + tool_name:string -> Parsetree.signature -> Parsetree.signature +(** Same as [add_ppx_context_str], but for signatures. *) + +val drop_ppx_context_str: + restore:bool -> Parsetree.structure -> Parsetree.structure +(** Drop the ocaml.ppx.context attribute from a structure. If + [restore] is true, also restore the associated data in the current + process. *) + +val drop_ppx_context_sig: + restore:bool -> Parsetree.signature -> Parsetree.signature +(** Same as [drop_ppx_context_str], but for signatures. *) + +(** {1 Cookies} *) + +(** Cookies are used to pass information from a ppx processor to + a further invocation of itself, when called from the OCaml + toplevel (or other tools that support cookies). *) + +val set_cookie: string -> Parsetree.expression -> unit +val get_cookie: string -> Parsetree.expression option diff --git a/ocamlmerlin_mlx/ocaml/parsing/asttypes.mli b/ocamlmerlin_mlx/ocaml/parsing/asttypes.mli new file mode 100644 index 0000000..7a4f1c1 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/asttypes.mli @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Auxiliary AST types used by parsetree and typedtree. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type constant = + Const_int of int + | Const_char of char + | Const_string of string * Location.t * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint + +type rec_flag = Nonrecursive | Recursive + +type direction_flag = Upto | Downto + +(* Order matters, used in polymorphic comparison *) +type private_flag = Private | Public + +type mutable_flag = Immutable | Mutable + +type virtual_flag = Virtual | Concrete + +type override_flag = Override | Fresh + +type closed_flag = Closed | Open + +type label = string + +type arg_label = + Nolabel + | Labelled of string (** [label:T -> ...] *) + | Optional of string (** [?label:T -> ...] *) + +type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; +} + + +type variance = + | Covariant + | Contravariant + | NoVariance + +type injectivity = + | Injective + | NoInjectivity diff --git a/ocamlmerlin_mlx/ocaml/parsing/attr_helper.ml b/ocamlmerlin_mlx/ocaml/parsing/attr_helper.ml new file mode 100644 index 0000000..0a616cd --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/attr_helper.ml @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Parsetree + +type error = + | Multiple_attributes of string + | No_payload_expected of string + +exception Error of Location.t * error + +let get_no_payload_attribute alt_names attrs = + match List.filter (fun a -> List.mem a.attr_name.txt alt_names) attrs with + | [] -> None + | [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name + | [ {attr_name = name; _} ] -> + raise (Error (name.loc, No_payload_expected name.txt)) + | _ :: {attr_name = name; _} :: _ -> + raise (Error (name.loc, Multiple_attributes name.txt)) + +let has_no_payload_attribute alt_names attrs = + match get_no_payload_attribute alt_names attrs with + | None -> false + | Some _ -> true + +open Format + +let report_error ppf = function + | Multiple_attributes name -> + fprintf ppf "Too many `%s' attributes" name + | No_payload_expected name -> + fprintf ppf "Attribute `%s' does not accept a payload" name + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error err) + | _ -> + None + ) diff --git a/ocamlmerlin_mlx/ocaml/parsing/attr_helper.mli b/ocamlmerlin_mlx/ocaml/parsing/attr_helper.mli new file mode 100644 index 0000000..a3ddc0c --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/attr_helper.mli @@ -0,0 +1,41 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Helpers for attributes + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Asttypes +open Parsetree + +type error = + | Multiple_attributes of string + | No_payload_expected of string + +(** The [string list] argument of the following functions is a list of + alternative names for the attribute we are looking for. For instance: + + {[ + ["foo"; "ocaml.foo"] + ]} *) +val get_no_payload_attribute : string list -> attributes -> string loc option +val has_no_payload_attribute : string list -> attributes -> bool + +exception Error of Location.t * error + +val report_error: Format.formatter -> error -> unit diff --git a/ocamlmerlin_mlx/ocaml/parsing/builtin_attributes.ml b/ocamlmerlin_mlx/ocaml/parsing/builtin_attributes.ml new file mode 100644 index 0000000..0db2133 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/builtin_attributes.ml @@ -0,0 +1,289 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Parsetree + +let string_of_cst = function + | Pconst_string(s, _, _) -> Some s + | _ -> None + +let string_of_payload = function + | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] -> + string_of_cst c + | _ -> None + +let string_of_opt_payload p = + match string_of_payload p with + | Some s -> s + | None -> "" + +let error_of_extension ext = + let submessage_from main_loc main_txt = function + | {pstr_desc=Pstr_extension + (({txt = ("ocaml.error"|"error"); loc}, p), _)} -> + begin match p with + | PStr([{pstr_desc=Pstr_eval + ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)} + ]) -> + { Location.loc; txt = fun ppf -> Format.pp_print_text ppf msg } + | _ -> + { Location.loc; txt = fun ppf -> + Format.fprintf ppf + "Invalid syntax for sub-message of extension '%s'." main_txt } + end + | {pstr_desc=Pstr_extension (({txt; loc}, _), _)} -> + { Location.loc; txt = fun ppf -> + Format.fprintf ppf "Uninterpreted extension '%s'." txt } + | _ -> + { Location.loc = main_loc; txt = fun ppf -> + Format.fprintf ppf + "Invalid syntax for sub-message of extension '%s'." main_txt } + in + match ext with + | ({txt = ("ocaml.error"|"error") as txt; loc}, p) -> + begin match p with + | PStr [] -> raise Location.Already_displayed_error + | PStr({pstr_desc=Pstr_eval + ({pexp_desc=Pexp_constant(Pconst_string(msg,_,_))}, _)}:: + inner) -> + let sub = List.map (submessage_from loc txt) inner in + Location.error_of_printer ~loc ~sub Format.pp_print_text msg + | _ -> + Location.errorf ~loc "Invalid syntax for extension '%s'." txt + end + | ({txt; loc}, _) -> + Location.errorf ~loc "Uninterpreted extension '%s'." txt + +let kind_and_message = function + | PStr[ + {pstr_desc= + Pstr_eval + ({pexp_desc=Pexp_apply + ({pexp_desc=Pexp_ident{txt=Longident.Lident id}}, + [Nolabel,{pexp_desc=Pexp_constant (Pconst_string(s,_,_))}]) + },_)}] -> + Some (id, s) + | PStr[ + {pstr_desc= + Pstr_eval + ({pexp_desc=Pexp_ident{txt=Longident.Lident id}},_)}] -> + Some (id, "") + | _ -> None + +let cat s1 s2 = + if s2 = "" then s1 else s1 ^ "\n" ^ s2 + +let alert_attr x = + match x.attr_name.txt with + | "ocaml.deprecated"|"deprecated" -> + Some (x, "deprecated", string_of_opt_payload x.attr_payload) + | "ocaml.alert"|"alert" -> + begin match kind_and_message x.attr_payload with + | Some (kind, message) -> Some (x, kind, message) + | None -> None (* note: bad payloads detected by warning_attribute *) + end + | _ -> None + +let alert_attrs l = + List.filter_map alert_attr l + +let alerts_of_attrs l = + List.fold_left + (fun acc (_, kind, message) -> + let upd = function + | None | Some "" -> Some message + | Some s -> Some (cat s message) + in + Misc.String.Map.update kind upd acc + ) + Misc.String.Map.empty + (alert_attrs l) + +let check_alerts loc attrs s = + Misc.String.Map.iter + (fun kind message -> Location.alert loc ~kind (cat s message)) + (alerts_of_attrs attrs) + +let check_alerts_inclusion ~def ~use loc attrs1 attrs2 s = + let m2 = alerts_of_attrs attrs2 in + Misc.String.Map.iter + (fun kind msg -> + if not (Misc.String.Map.mem kind m2) then + Location.alert ~def ~use ~kind loc (cat s msg) + ) + (alerts_of_attrs attrs1) + +let rec deprecated_mutable_of_attrs = function + | [] -> None + | {attr_name = {txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _}; + attr_payload = p} :: _ -> + Some (string_of_opt_payload p) + | _ :: tl -> deprecated_mutable_of_attrs tl + +let check_deprecated_mutable loc attrs s = + match deprecated_mutable_of_attrs attrs with + | None -> () + | Some txt -> + Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt)) + +let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s = + match deprecated_mutable_of_attrs attrs1, + deprecated_mutable_of_attrs attrs2 + with + | None, _ | Some _, Some _ -> () + | Some txt, None -> + Location.deprecated ~def ~use loc + (Printf.sprintf "mutating field %s" (cat s txt)) + +let rec attrs_of_sig = function + | {psig_desc = Psig_attribute a} :: tl -> + a :: attrs_of_sig tl + | _ -> + [] + +let alerts_of_sig sg = alerts_of_attrs (attrs_of_sig sg) + +let rec attrs_of_str = function + | {pstr_desc = Pstr_attribute a} :: tl -> + a :: attrs_of_str tl + | _ -> + [] + +let alerts_of_str str = alerts_of_attrs (attrs_of_str str) + +let check_no_alert attrs = + List.iter + (fun (a, _, _) -> + Location.prerr_warning a.attr_loc + (Warnings.Misplaced_attribute a.attr_name.txt) + ) + (alert_attrs attrs) + +let warn_payload loc txt msg = + Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)) + +let warning_attribute ?(ppwarning = true) = + let process loc txt errflag payload = + match string_of_payload payload with + | Some s -> + begin try + Option.iter (Location.prerr_alert loc) + (Warnings.parse_options errflag s) + with Arg.Bad msg -> warn_payload loc txt msg + end + | None -> + warn_payload loc txt "A single string literal is expected" + in + let process_alert loc txt = function + | PStr[{pstr_desc= + Pstr_eval( + {pexp_desc=Pexp_constant(Pconst_string(s,_,_))}, + _) + }] -> + begin try Warnings.parse_alert_option s + with Arg.Bad msg -> warn_payload loc txt msg + end + | k -> + match kind_and_message k with + | Some ("all", _) -> + warn_payload loc txt "The alert name 'all' is reserved" + | Some _ -> () + | None -> warn_payload loc txt "Invalid payload" + in + function + | {attr_name = {txt = ("ocaml.warning"|"warning") as txt; _}; + attr_loc; + attr_payload; + } -> + process attr_loc txt false attr_payload + | {attr_name = {txt = ("ocaml.warnerror"|"warnerror") as txt; _}; + attr_loc; + attr_payload + } -> + process attr_loc txt true attr_payload + | {attr_name = {txt="ocaml.ppwarning"|"ppwarning"; _}; + attr_loc = _; + attr_payload = + PStr [ + { pstr_desc= + Pstr_eval({pexp_desc=Pexp_constant (Pconst_string (s, _, _))},_); + pstr_loc } + ]; + } when ppwarning -> + Location.prerr_warning pstr_loc (Warnings.Preprocessor s) + | {attr_name = {txt = ("ocaml.alert"|"alert") as txt; _}; + attr_loc; + attr_payload; + } -> + process_alert attr_loc txt attr_payload + | _ -> + () + +let warning_scope ?ppwarning attrs f = + let prev = Warnings.backup () in + try + List.iter (warning_attribute ?ppwarning) (List.rev attrs); + let ret = f () in + Warnings.restore prev; + ret + with exn -> + Warnings.restore prev; + raise exn + + +let warn_on_literal_pattern = + List.exists + (fun a -> match a.attr_name.txt with + | "ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern" -> true + | _ -> false + ) + +let explicit_arity = + List.exists + (fun a -> match a.attr_name.txt with + | "ocaml.explicit_arity"|"explicit_arity" -> true + | _ -> false + ) + +let immediate = + List.exists + (fun a -> match a.attr_name.txt with + | "ocaml.immediate"|"immediate" -> true + | _ -> false + ) + +let immediate64 = + List.exists + (fun a -> match a.attr_name.txt with + | "ocaml.immediate64"|"immediate64" -> true + | _ -> false + ) + +(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" + attributes cannot be input by the user, they are added by the + compiler when applying the default setting. This is done to record + in the .cmi the default used by the compiler when compiling the + source file because the default can change between compiler + invocations. *) + +let check l a = List.mem a.attr_name.txt l + +let has_unboxed attr = + List.exists (check ["ocaml.unboxed"; "unboxed"]) + attr + +let has_boxed attr = + List.exists (check ["ocaml.boxed"; "boxed"]) attr diff --git a/ocamlmerlin_mlx/ocaml/parsing/builtin_attributes.mli b/ocamlmerlin_mlx/ocaml/parsing/builtin_attributes.mli new file mode 100644 index 0000000..6200fd7 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/builtin_attributes.mli @@ -0,0 +1,84 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Support for some of the builtin attributes + + - ocaml.deprecated + - ocaml.alert + - ocaml.error + - ocaml.ppwarning + - ocaml.warning + - ocaml.warnerror + - ocaml.explicit_arity (for camlp4/camlp5) + - ocaml.warn_on_literal_pattern + - ocaml.deprecated_mutable + - ocaml.immediate + - ocaml.immediate64 + - ocaml.boxed / ocaml.unboxed + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +val check_alerts: Location.t -> Parsetree.attributes -> string -> unit +val check_alerts_inclusion: + def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> + Parsetree.attributes -> string -> unit +val alerts_of_attrs: Parsetree.attributes -> Misc.alerts +val alerts_of_sig: Parsetree.signature -> Misc.alerts +val alerts_of_str: Parsetree.structure -> Misc.alerts + +val check_deprecated_mutable: + Location.t -> Parsetree.attributes -> string -> unit +val check_deprecated_mutable_inclusion: + def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> + Parsetree.attributes -> string -> unit + +val check_no_alert: Parsetree.attributes -> unit + +val error_of_extension: Parsetree.extension -> Location.error + +val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit + (** Apply warning settings from the specified attribute. + "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix) + are processed and other attributes are ignored. + + Also implement ocaml.ppwarning (unless ~ppwarning:false is + passed). + *) + +val warning_scope: + ?ppwarning:bool -> + Parsetree.attributes -> (unit -> 'a) -> 'a + (** Execute a function in a new scope for warning settings. This + means that the effect of any call to [warning_attribute] during + the execution of this function will be discarded after + execution. + + The function also takes a list of attributes which are processed + with [warning_attribute] in the fresh scope before the function + is executed. + *) + +val warn_on_literal_pattern: Parsetree.attributes -> bool +val explicit_arity: Parsetree.attributes -> bool + + +val immediate: Parsetree.attributes -> bool +val immediate64: Parsetree.attributes -> bool + +val has_unboxed: Parsetree.attributes -> bool +val has_boxed: Parsetree.attributes -> bool diff --git a/ocamlmerlin_mlx/ocaml/parsing/docstrings.ml b/ocamlmerlin_mlx/ocaml/parsing/docstrings.ml new file mode 100644 index 0000000..a39f75d --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/docstrings.ml @@ -0,0 +1,425 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Leo White *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Location + +(* Docstrings *) + +(* A docstring is "attached" if it has been inserted in the AST. This + is used for generating unexpected docstring warnings. *) +type ds_attached = + | Unattached (* Not yet attached anything.*) + | Info (* Attached to a field or constructor. *) + | Docs (* Attached to an item or as floating text. *) + +(* A docstring is "associated" with an item if there are no blank lines between + them. This is used for generating docstring ambiguity warnings. *) +type ds_associated = + | Zero (* Not associated with an item *) + | One (* Associated with one item *) + | Many (* Associated with multiple items (ambiguity) *) + +type docstring = + { ds_body: string; + ds_loc: Location.t; + mutable ds_attached: ds_attached; + mutable ds_associated: ds_associated; } + +(* List of docstrings *) + +let docstrings : docstring list ref = ref [] + +(* Warn for unused and ambiguous docstrings *) + +let warn_bad_docstrings () = + if Warnings.is_active (Warnings.Unexpected_docstring true) then begin + List.iter + (fun ds -> + match ds.ds_attached with + | Info -> () + | Unattached -> + prerr_warning ds.ds_loc (Warnings.Unexpected_docstring true) + | Docs -> + match ds.ds_associated with + | Zero | One -> () + | Many -> + prerr_warning ds.ds_loc (Warnings.Unexpected_docstring false)) + (List.rev !docstrings) +end + +(* Docstring constructors and destructors *) + +let docstring body loc = + let ds = + { ds_body = body; + ds_loc = loc; + ds_attached = Unattached; + ds_associated = Zero; } + in + ds + +let register ds = + docstrings := ds :: !docstrings + +let docstring_body ds = ds.ds_body + +let docstring_loc ds = ds.ds_loc + +(* Docstrings attached to items *) + +type docs = + { docs_pre: docstring option; + docs_post: docstring option; } + +let empty_docs = { docs_pre = None; docs_post = None } + +let doc_loc = {txt = "ocaml.doc"; loc = Location.none} + +let docs_attr ds = + let open Parsetree in + let body = ds.ds_body in + let loc = ds.ds_loc in + let exp = + { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = []; } + in + let item = + { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } + in + { attr_name = doc_loc; + attr_payload = PStr [item]; + attr_loc = loc } + +let add_docs_attrs docs attrs = + let attrs = + match docs.docs_pre with + | None | Some { ds_body=""; _ } -> attrs + | Some ds -> docs_attr ds :: attrs + in + let attrs = + match docs.docs_post with + | None | Some { ds_body=""; _ } -> attrs + | Some ds -> attrs @ [docs_attr ds] + in + attrs + +(* Docstrings attached to constructors or fields *) + +type info = docstring option + +let empty_info = None + +let info_attr = docs_attr + +let add_info_attrs info attrs = + match info with + | None | Some {ds_body=""; _} -> attrs + | Some ds -> attrs @ [info_attr ds] + +(* Docstrings not attached to a specific item *) + +type text = docstring list + +let empty_text = [] +let empty_text_lazy = lazy [] + +let text_loc = {txt = "ocaml.text"; loc = Location.none} + +let text_attr ds = + let open Parsetree in + let body = ds.ds_body in + let loc = ds.ds_loc in + let exp = + { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = []; } + in + let item = + { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } + in + { attr_name = text_loc; + attr_payload = PStr [item]; + attr_loc = loc } + +let add_text_attrs dsl attrs = + let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in + (List.map text_attr fdsl) @ attrs + +(* Find the first non-info docstring in a list, attach it and return it *) +let get_docstring ~info dsl = + let rec loop = function + | [] -> None + | {ds_attached = Info; _} :: rest -> loop rest + | ds :: _ -> + ds.ds_attached <- if info then Info else Docs; + Some ds + in + loop dsl + +(* Find all the non-info docstrings in a list, attach them and return them *) +let get_docstrings dsl = + let rec loop acc = function + | [] -> List.rev acc + | {ds_attached = Info; _} :: rest -> loop acc rest + | ds :: rest -> + ds.ds_attached <- Docs; + loop (ds :: acc) rest + in + loop [] dsl + +(* "Associate" all the docstrings in a list *) +let associate_docstrings dsl = + List.iter + (fun ds -> + match ds.ds_associated with + | Zero -> ds.ds_associated <- One + | (One | Many) -> ds.ds_associated <- Many) + dsl + +(* Map from positions to pre docstrings *) + +let pre_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_pre_docstrings pos dsl = + if dsl <> [] then Hashtbl.add pre_table pos dsl + +let get_pre_docs pos = + try + let dsl = Hashtbl.find pre_table pos in + associate_docstrings dsl; + get_docstring ~info:false dsl + with Not_found -> None + +let mark_pre_docs pos = + try + let dsl = Hashtbl.find pre_table pos in + associate_docstrings dsl + with Not_found -> () + +(* Map from positions to post docstrings *) + +let post_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_post_docstrings pos dsl = + if dsl <> [] then Hashtbl.add post_table pos dsl + +let get_post_docs pos = + try + let dsl = Hashtbl.find post_table pos in + associate_docstrings dsl; + get_docstring ~info:false dsl + with Not_found -> None + +let mark_post_docs pos = + try + let dsl = Hashtbl.find post_table pos in + associate_docstrings dsl + with Not_found -> () + +let get_info pos = + try + let dsl = Hashtbl.find post_table pos in + get_docstring ~info:true dsl + with Not_found -> None + +(* Map from positions to floating docstrings *) + +let floating_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_floating_docstrings pos dsl = + if dsl <> [] then Hashtbl.add floating_table pos dsl + +let get_text pos = + try + let dsl = Hashtbl.find floating_table pos in + get_docstrings dsl + with Not_found -> [] + +let get_post_text pos = + try + let dsl = Hashtbl.find post_table pos in + get_docstrings dsl + with Not_found -> [] + +(* Maps from positions to extra docstrings *) + +let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_pre_extra_docstrings pos dsl = + if dsl <> [] then Hashtbl.add pre_extra_table pos dsl + +let get_pre_extra_text pos = + try + let dsl = Hashtbl.find pre_extra_table pos in + get_docstrings dsl + with Not_found -> [] + +let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_post_extra_docstrings pos dsl = + if dsl <> [] then Hashtbl.add post_extra_table pos dsl + +let get_post_extra_text pos = + try + let dsl = Hashtbl.find post_extra_table pos in + get_docstrings dsl + with Not_found -> [] + +(* Docstrings from parser actions *) +module WithParsing = struct +let symbol_docs () = + { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); + docs_post = get_post_docs (Parsing.symbol_end_pos ()); } + +let symbol_docs_lazy () = + let p1 = Parsing.symbol_start_pos () in + let p2 = Parsing.symbol_end_pos () in + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let rhs_docs pos1 pos2 = + { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); + docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } + +let rhs_docs_lazy pos1 pos2 = + let p1 = Parsing.rhs_start_pos pos1 in + let p2 = Parsing.rhs_end_pos pos2 in + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let mark_symbol_docs () = + mark_pre_docs (Parsing.symbol_start_pos ()); + mark_post_docs (Parsing.symbol_end_pos ()) + +let mark_rhs_docs pos1 pos2 = + mark_pre_docs (Parsing.rhs_start_pos pos1); + mark_post_docs (Parsing.rhs_end_pos pos2) + +let symbol_info () = + get_info (Parsing.symbol_end_pos ()) + +let rhs_info pos = + get_info (Parsing.rhs_end_pos pos) + +let symbol_text () = + get_text (Parsing.symbol_start_pos ()) + +let symbol_text_lazy () = + let pos = Parsing.symbol_start_pos () in + lazy (get_text pos) + +let rhs_text pos = + get_text (Parsing.rhs_start_pos pos) + +let rhs_post_text pos = + get_post_text (Parsing.rhs_end_pos pos) + +let rhs_text_lazy pos = + let pos = Parsing.rhs_start_pos pos in + lazy (get_text pos) + +let symbol_pre_extra_text () = + get_pre_extra_text (Parsing.symbol_start_pos ()) + +let symbol_post_extra_text () = + get_post_extra_text (Parsing.symbol_end_pos ()) + +let rhs_pre_extra_text pos = + get_pre_extra_text (Parsing.rhs_start_pos pos) + +let rhs_post_extra_text pos = + get_post_extra_text (Parsing.rhs_end_pos pos) +end + +include WithParsing + +module WithMenhir = struct +let symbol_docs (startpos, endpos) = + { docs_pre = get_pre_docs startpos; + docs_post = get_post_docs endpos; } + +let symbol_docs_lazy (p1, p2) = + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let rhs_docs pos1 pos2 = + { docs_pre = get_pre_docs pos1; + docs_post = get_post_docs pos2; } + +let rhs_docs_lazy p1 p2 = + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let mark_symbol_docs (startpos, endpos) = + mark_pre_docs startpos; + mark_post_docs endpos; + () + +let mark_rhs_docs pos1 pos2 = + mark_pre_docs pos1; + mark_post_docs pos2; + () + +let symbol_info endpos = + get_info endpos + +let rhs_info endpos = + get_info endpos + +let symbol_text startpos = + get_text startpos + +let symbol_text_lazy startpos = + lazy (get_text startpos) + +let rhs_text pos = + get_text pos + +let rhs_post_text pos = + get_post_text pos + +let rhs_text_lazy pos = + lazy (get_text pos) + +let symbol_pre_extra_text startpos = + get_pre_extra_text startpos + +let symbol_post_extra_text endpos = + get_post_extra_text endpos + +let rhs_pre_extra_text pos = + get_pre_extra_text pos + +let rhs_post_extra_text pos = + get_post_extra_text pos +end + +(* (Re)Initialise all comment state *) + +let init () = + docstrings := []; + Hashtbl.reset pre_table; + Hashtbl.reset post_table; + Hashtbl.reset floating_table; + Hashtbl.reset pre_extra_table; + Hashtbl.reset post_extra_table diff --git a/ocamlmerlin_mlx/ocaml/parsing/docstrings.mli b/ocamlmerlin_mlx/ocaml/parsing/docstrings.mli new file mode 100644 index 0000000..bf2508f --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/docstrings.mli @@ -0,0 +1,223 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Leo White *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Documentation comments + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +(** (Re)Initialise all docstring state *) +val init : unit -> unit + +(** Emit warnings for unattached and ambiguous docstrings *) +val warn_bad_docstrings : unit -> unit + +(** {2 Docstrings} *) + +(** Documentation comments *) +type docstring + +(** Create a docstring *) +val docstring : string -> Location.t -> docstring + +(** Register a docstring *) +val register : docstring -> unit + +(** Get the text of a docstring *) +val docstring_body : docstring -> string + +(** Get the location of a docstring *) +val docstring_loc : docstring -> Location.t + +(** {2 Set functions} + + These functions are used by the lexer to associate docstrings to + the locations of tokens. *) + +(** Docstrings immediately preceding a token *) +val set_pre_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately following a token *) +val set_post_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings not immediately adjacent to a token *) +val set_floating_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately following the token which precedes this one *) +val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately preceding the token which follows this one *) +val set_post_extra_docstrings : Lexing.position -> docstring list -> unit + +(** {2 Items} + + The {!docs} type represents documentation attached to an item. *) + +type docs = + { docs_pre: docstring option; + docs_post: docstring option; } + +val empty_docs : docs + +val docs_attr : docstring -> Parsetree.attribute + +(** Convert item documentation to attributes and add them to an + attribute list *) +val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the item documentation for the current symbol. This also + marks this documentation (for ambiguity warnings). *) +val symbol_docs : unit -> docs +val symbol_docs_lazy : unit -> docs Lazy.t + +(** Fetch the item documentation for the symbols between two + positions. This also marks this documentation (for ambiguity + warnings). *) +val rhs_docs : int -> int -> docs +val rhs_docs_lazy : int -> int -> docs Lazy.t + +(** Mark the item documentation for the current symbol (for ambiguity + warnings). *) +val mark_symbol_docs : unit -> unit + +(** Mark as associated the item documentation for the symbols between + two positions (for ambiguity warnings) *) +val mark_rhs_docs : int -> int -> unit + +(** {2 Fields and constructors} + + The {!info} type represents documentation attached to a field or + constructor. *) + +type info = docstring option + +val empty_info : info + +val info_attr : docstring -> Parsetree.attribute + +(** Convert field info to attributes and add them to an + attribute list *) +val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the field info for the current symbol. *) +val symbol_info : unit -> info + +(** Fetch the field info following the symbol at a given position. *) +val rhs_info : int -> info + +(** {2 Unattached comments} + + The {!text} type represents documentation which is not attached to + anything. *) + +type text = docstring list + +val empty_text : text +val empty_text_lazy : text Lazy.t + +val text_attr : docstring -> Parsetree.attribute + +(** Convert text to attributes and add them to an attribute list *) +val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the text preceding the current symbol. *) +val symbol_text : unit -> text +val symbol_text_lazy : unit -> text Lazy.t + +(** Fetch the text preceding the symbol at the given position. *) +val rhs_text : int -> text +val rhs_text_lazy : int -> text Lazy.t + +(** {2 Extra text} + + There may be additional text attached to the delimiters of a block + (e.g. [struct] and [end]). This is fetched by the following + functions, which are applied to the contents of the block rather + than the delimiters. *) + +(** Fetch additional text preceding the current symbol *) +val symbol_pre_extra_text : unit -> text + +(** Fetch additional text following the current symbol *) +val symbol_post_extra_text : unit -> text + +(** Fetch additional text preceding the symbol at the given position *) +val rhs_pre_extra_text : int -> text + +(** Fetch additional text following the symbol at the given position *) +val rhs_post_extra_text : int -> text + +(** Fetch text following the symbol at the given position *) +val rhs_post_text : int -> text + +module WithMenhir: sig +(** Fetch the item documentation for the current symbol. This also + marks this documentation (for ambiguity warnings). *) +val symbol_docs : Lexing.position * Lexing.position -> docs +val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t + +(** Fetch the item documentation for the symbols between two + positions. This also marks this documentation (for ambiguity + warnings). *) +val rhs_docs : Lexing.position -> Lexing.position -> docs +val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t + +(** Mark the item documentation for the current symbol (for ambiguity + warnings). *) +val mark_symbol_docs : Lexing.position * Lexing.position -> unit + +(** Mark as associated the item documentation for the symbols between + two positions (for ambiguity warnings) *) +val mark_rhs_docs : Lexing.position -> Lexing.position -> unit + +(** Fetch the field info for the current symbol. *) +val symbol_info : Lexing.position -> info + +(** Fetch the field info following the symbol at a given position. *) +val rhs_info : Lexing.position -> info + +(** Fetch the text preceding the current symbol. *) +val symbol_text : Lexing.position -> text +val symbol_text_lazy : Lexing.position -> text Lazy.t + +(** Fetch the text preceding the symbol at the given position. *) +val rhs_text : Lexing.position -> text +val rhs_text_lazy : Lexing.position -> text Lazy.t + +(** {3 Extra text} + + There may be additional text attached to the delimiters of a block + (e.g. [struct] and [end]). This is fetched by the following + functions, which are applied to the contents of the block rather + than the delimiters. *) + +(** Fetch additional text preceding the current symbol *) +val symbol_pre_extra_text : Lexing.position -> text + +(** Fetch additional text following the current symbol *) +val symbol_post_extra_text : Lexing.position -> text + +(** Fetch additional text preceding the symbol at the given position *) +val rhs_pre_extra_text : Lexing.position -> text + +(** Fetch additional text following the symbol at the given position *) +val rhs_post_extra_text : Lexing.position -> text + +(** Fetch text following the symbol at the given position *) +val rhs_post_text : Lexing.position -> text + +end diff --git a/ocamlmerlin_mlx/ocaml/parsing/dune b/ocamlmerlin_mlx/ocaml/parsing/dune new file mode 100644 index 0000000..82309d5 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/dune @@ -0,0 +1,22 @@ +(library + (name mlx_ocaml_parsing) + (package ocamlmerlin-mlx) + (flags + -open=Mlx_utils + -open=Mlx_ocaml_utils + -open=Astlib.Ast_501 + (:standard -w -9)) + (modules_without_implementation asttypes parsetree) + (libraries ppxlib mlx_utils mlx_ocaml_utils)) + +(copy_files + (enabled_if + (<> %{profile} "release")) + (mode promote) + (files %{project_root}/merlin/src/ocaml/parsing/*.{ml,mli})) + +(copy_files + (enabled_if + (<> %{profile} "release")) + (mode promote) + (files %{project_root}/merlin/extend_helper.{ml,mli})) diff --git a/ocamlmerlin_mlx/ocaml/parsing/fake.ml b/ocamlmerlin_mlx/ocaml/parsing/fake.ml new file mode 100644 index 0000000..19716c3 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/fake.ml @@ -0,0 +1,74 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +open Parsetree + +let app a b = + let loc = + if a.pexp_loc.Location.loc_ghost + then {b.pexp_loc with Location.loc_ghost = true} + else b.pexp_loc + in + Ast_helper.Exp.apply ~loc a [Ast_helper.no_label, b] + +let pat_app f (pat,expr) = pat, app f expr + +let prim_ident prim = Longident.parse ("_." ^ prim) +let prim ?(ghost=true) prim = + let open Location in + let ident = mknoloc (prim_ident prim) in + let ident = if ghost + then ident + else {ident with loc = {ident.loc with loc_ghost = false}} + in + Ast_helper.Exp.ident ~loc:ident.loc ident + +(* Lwt extension *) +module Lwt = struct + let un_lwt = prim "Lwt.un_lwt" + let to_lwt = prim "Lwt.to_lwt" + let in_lwt = prim "Lwt.in_lwt" + let unit_lwt = prim "Lwt.unit_lwt" + let un_stream = prim "Lwt.un_stream" + let finally_ = prim "Lwt.finally'" + let raise_lwt_ = prim_ident "Lwt.raise_lwt'" +end + +(* MetaOCaml support *) +module Meta = struct + let prim_code = prim "Meta.code" + let prim_uncode = prim "Meta.uncode" + + let code loc_start loc_end expr = + let loc = {expr.pexp_loc with Location. loc_start; loc_end} in + Ast_helper.Exp.apply ~loc prim_code [Ast_helper.no_label, expr] + + let uncode loc_start loc_end expr = + let loc = {expr.pexp_loc with Location. loc_start; loc_end} in + Ast_helper.Exp.apply ~loc prim_uncode [Ast_helper.no_label, expr] +end diff --git a/ocamlmerlin_mlx/ocaml/parsing/fake.mli b/ocamlmerlin_mlx/ocaml/parsing/fake.mli new file mode 100644 index 0000000..3dbbc19 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/fake.mli @@ -0,0 +1,55 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +(* Definitions to help generating or rewriting pieces of AST, + * used to simulate some CamlP4 extensions. *) + +(* Generate AST faking value application *) +val app : Parsetree.expression -> + Parsetree.expression -> Parsetree.expression +val pat_app : Parsetree.expression -> + ('a * Parsetree.expression) -> ('a * Parsetree.expression ) + +(* Lwt extension *) +module Lwt : sig + val un_lwt : Parsetree.expression + val to_lwt : Parsetree.expression + val in_lwt : Parsetree.expression + val unit_lwt : Parsetree.expression + val un_stream : Parsetree.expression + val finally_ : Parsetree.expression + val raise_lwt_ : Longident.t +end + +(* MetaOCaml support *) +module Meta : sig + val code : Lexing.position -> Lexing.position -> + Parsetree.expression -> Parsetree.expression + val uncode : Lexing.position -> Lexing.position -> + Parsetree.expression -> Parsetree.expression +end diff --git a/ocamlmerlin_mlx/ocaml/parsing/location.ml b/ocamlmerlin_mlx/ocaml/parsing/location.ml new file mode 100644 index 0000000..1b8b5f1 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/location.ml @@ -0,0 +1,1020 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Lexing + +type t = Warnings.loc = + { loc_start: position; loc_end: position; loc_ghost: bool } + +let in_file = Warnings.ghost_loc_in_file + +let none = in_file "_none_" +let is_none l = (l = none) + +let curr lexbuf = { + loc_start = lexbuf.lex_start_p; + loc_end = lexbuf.lex_curr_p; + loc_ghost = false +} + +let init lexbuf fname = + lexbuf.lex_curr_p <- { + pos_fname = fname; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = 0; + } + + +let symbol_rloc () = { + loc_start = Parsing.symbol_start_pos (); + loc_end = Parsing.symbol_end_pos (); + loc_ghost = false; +} + +let symbol_gloc () = { + loc_start = Parsing.symbol_start_pos (); + loc_end = Parsing.symbol_end_pos (); + loc_ghost = true; +} + +let rhs_loc n = { + loc_start = Parsing.rhs_start_pos n; + loc_end = Parsing.rhs_end_pos n; + loc_ghost = false; +} + +let rhs_interval m n = { + loc_start = Parsing.rhs_start_pos m; + loc_end = Parsing.rhs_end_pos n; + loc_ghost = false; +} + +(* return file, line, char from the given position *) +let get_pos_info pos = + (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) + + +type 'a loc = { + txt : 'a; + loc : t; +} + +let mkloc txt loc = { txt ; loc } +let mknoloc txt = mkloc txt none + +(******************************************************************************) +(* Input info *) + +let input_name = ref "_none_" +let input_lexbuf = ref (None : lexbuf option) +let input_phrase_buffer = ref (None : Buffer.t option) + +(******************************************************************************) +(* Terminal info *) + +(* +let status = ref Terminfo.Uninitialised + +let setup_terminal () = + if !status = Terminfo.Uninitialised then + status := Terminfo.setup stdout +*) + +(* The number of lines already printed after input. + + This is used by [highlight_terminfo] to identify the current position of the + input in the terminal. This would not be possible without this information, + since printing several warnings/errors adds text between the user input and + the bottom of the terminal. + + We also use for {!is_first_report}, see below. +*) +let num_loc_lines = ref 0 + +(* We use [num_loc_lines] to determine if the report about to be + printed is the first or a follow-up report of the current + "batch" -- contiguous reports without user input in between, for + example for the current toplevel phrase. We use this to print + a blank line between messages of the same batch. +*) +let is_first_message () = + !num_loc_lines = 0 + +(* This is used by the toplevel to reset [num_loc_lines] before each phrase *) +let reset () = + num_loc_lines := 0 + +(* This is used by the toplevel *) +let echo_eof () = + print_newline (); + incr num_loc_lines + +(* This is used by the toplevel and the report printers below. *) +let separate_new_message ppf = + if not (is_first_message ()) then begin + Format.pp_print_newline ppf (); + incr num_loc_lines + end + +(* Code printing errors and warnings must be wrapped using this function, in + order to update [num_loc_lines]. + + [print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf + arg], and additionally updates [num_loc_lines]. *) +let print_updating_num_loc_lines ppf f arg = + let open Format in + let out_functions = pp_get_formatter_out_functions ppf () in + let out_string str start len = + let rec count i c = + if i = start + len then c + else if String.get str i = '\n' then count (succ i) (succ c) + else count (succ i) c in + num_loc_lines := !num_loc_lines + count start 0 ; + out_functions.out_string str start len in + pp_set_formatter_out_functions ppf + { out_functions with out_string } ; + f ppf arg ; + pp_print_flush ppf (); + pp_set_formatter_out_functions ppf out_functions + +(******************************************************************************) +(* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *) + +let rewrite_absolute_path path = + (* + match Misc.get_build_path_prefix_map () with + | None -> path + | Some map -> Build_path_prefix_map.rewrite map path + *) + path + +(* +let rewrite_find_first_existing path = + match Misc.get_build_path_prefix_map () with + | None -> + if Sys.file_exists path then Some path + else None + | Some prefix_map -> + match Build_path_prefix_map.rewrite_all prefix_map path with + | [] -> + if Sys.file_exists path then Some path + else None + | matches -> + Some (List.find Sys.file_exists matches) + +let rewrite_find_all_existing_dirs path = + let ok path = Sys.file_exists path && Sys.is_directory path in + match Misc.get_build_path_prefix_map () with + | None -> + if ok path then [path] + else [] + | Some prefix_map -> + match Build_path_prefix_map.rewrite_all prefix_map path with + | [] -> + if ok path then [path] + else [] + | matches -> + match (List.filter ok matches) with + | [] -> raise Not_found + | results -> results *) + +let absolute_path s = (* This function could go into Filename *) + let open Filename in + let s = if (is_relative s) then (concat (Sys.getcwd ()) s) else s in + let s = rewrite_absolute_path s in + (* Now simplify . and .. components *) + let rec aux s = + let base = basename s in + let dir = dirname s in + if dir = s then dir + else if base = current_dir_name then aux dir + else if base = parent_dir_name then dirname (aux dir) + else concat (aux dir) base + in + aux s + +let show_filename file = + (* if !Clflags.absname then absolute_path file else *) file + +let print_filename ppf file = + Format.pp_print_string ppf (show_filename file) + +(* Best-effort printing of the text describing a location, of the form + 'File "foo.ml", line 3, characters 10-12'. + + Some of the information (filename, line number or characters numbers) in the + location might be invalid; in which case we do not print it. + *) +let print_loc ppf loc = + let file_valid = function + | "_none_" -> + (* This is a dummy placeholder, but we print it anyway to please editors + that parse locations in error messages (e.g. Emacs). *) + true + | "" | "//toplevel//" -> false + | _ -> true + in + let line_valid line = line > 0 in + let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in + + let file = + (* According to the comment in location.mli, if [pos_fname] is "", we must + use [!input_name]. *) + if loc.loc_start.pos_fname = "" then !input_name + else loc.loc_start.pos_fname + in + let line = loc.loc_start.pos_lnum in + let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in + let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in + + let first = ref true in + let capitalize s = + if !first then (first := false; String.capitalize_ascii s) + else s in + let comma () = + if !first then () else Format.fprintf ppf ", " in + + Format.fprintf ppf "@{"; + + if file_valid file then + Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file; + + (* Print "line 1" in the case of a dummy line number. This is to please the + existing setup of editors that parse locations in error messages (e.g. + Emacs). *) + comma (); + Format.fprintf ppf "%s %i" (capitalize "line") + (if line_valid line then line else 1); + + if chars_valid ~startchar ~endchar then ( + comma (); + Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar + ); + + Format.fprintf ppf "@}" + +(* Print a comma-separated list of locations *) +let print_locs ppf locs = + Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") + print_loc ppf locs + +(******************************************************************************) +(* An interval set structure; additionally, it stores user-provided information + at interval boundaries. + + The implementation provided here is naive and assumes the number of intervals + to be small, but the interface would allow for a more efficient + implementation if needed. + + Note: the structure only stores maximal intervals (that therefore do not + overlap). +*) + +(* +module ISet : sig + type 'a bound = 'a * int + type 'a t + (* bounds are included *) + val of_intervals : ('a bound * 'a bound) list -> 'a t + + val mem : 'a t -> pos:int -> bool + val find_bound_in : 'a t -> range:(int * int) -> 'a bound option + + val is_start : 'a t -> pos:int -> 'a option + val is_end : 'a t -> pos:int -> 'a option + + val extrema : 'a t -> ('a bound * 'a bound) option +end += +struct + type 'a bound = 'a * int + + (* non overlapping intervals *) + type 'a t = ('a bound * 'a bound) list + + let of_intervals intervals = + let pos = + List.map (fun ((a, x), (b, y)) -> + if x > y then [] else [((a, x), `S); ((b, y), `E)] + ) intervals + |> List.flatten + |> List.sort (fun ((_, x), k) ((_, y), k') -> + (* Make `S come before `E so that consecutive intervals get merged + together in the fold below *) + let kn = function `S -> 0 | `E -> 1 in + compare (x, kn k) (y, kn k')) + in + let nesting, acc = + List.fold_left (fun (nesting, acc) (a, kind) -> + match kind, nesting with + | `S, `Outside -> `Inside (a, 0), acc + | `S, `Inside (s, n) -> `Inside (s, n+1), acc + | `E, `Outside -> assert false + | `E, `Inside (s, 0) -> `Outside, ((s, a) :: acc) + | `E, `Inside (s, n) -> `Inside (s, n-1), acc + ) (`Outside, []) pos in + assert (nesting = `Outside); + List.rev acc + + let mem iset ~pos = + List.exists (fun ((_, s), (_, e)) -> s <= pos && pos <= e) iset + + let find_bound_in iset ~range:(start, end_) = + try Some ( + List.find_map ~f:(fun ((a, x), (b, y)) -> + if start <= x && x <= end_ then Some (a, x) + else if start <= y && y <= end_ then Some (b, y) + else None + ) iset + ) with Not_found -> None + + let is_start iset ~pos = + try Some ( + List.find_map ~f:(fun ((a, x), _) -> + if pos = x then Some a else None + ) iset + ) with Not_found -> None + + let is_end iset ~pos = + try Some ( + List.find_map ~f:(fun (_, (b, y)) -> + if pos = y then Some b else None + ) iset + ) with Not_found -> None + + let extrema iset = + if iset = [] then None + else Some (fst (List.hd iset), snd (List.hd (List.rev iset))) +end +*) + + +(* Highlight the location by printing it again. + + There are two different styles for highlighting errors in "dumb" mode, + depending if the error fits on a single line or spans across several lines. + + For single-line errors, + + foo the_error bar + + gets displayed as follows, where X is the line number: + + X | foo the_error bar + ^^^^^^^^^ + + + For multi-line errors, + + foo the_ + error bar + + gets displayed as: + + X1 | ....the_ + X2 | error.... + + An ellipsis hides the middle lines of the multi-line error if it has more + than [max_lines] lines. + + If [locs] is empty then this function is a no-op. +*) + +(* +type input_line = { + text : string; + start_pos : int; +} +*) + +(* Takes a list of lines with possibly missing line numbers. + + If the line numbers that are present are consistent with the number of lines + between them, then infer the intermediate line numbers. + + This is not always the case, typically if lexer line directives are + involved... *) +(* +let infer_line_numbers + (lines: (int option * input_line) list): + (int option * input_line) list + = + let (_, offset, consistent) = + List.fold_left (fun (i, offset, consistent) (lnum, _) -> + match lnum, offset with + | None, _ -> (i+1, offset, consistent) + | Some n, None -> (i+1, Some (n - i), consistent) + | Some n, Some m -> (i+1, offset, consistent && n = m + i) + ) (0, None, true) lines + in + match offset, consistent with + | Some m, true -> + List.mapi (fun i (_, line) -> (Some (m + i), line)) lines + | _, _ -> + lines +*) +(* [get_lines] must return the lines to highlight, given starting and ending + positions. + + See [lines_around_from_current_input] below for an instantiation of + [get_lines] that reads from the current input. +*) +(* +let highlight_quote ppf + ~(get_lines: start_pos:position -> end_pos:position -> input_line list) + ?(max_lines = 10) + highlight_tag + locs + = + let iset = ISet.of_intervals @@ List.filter_map (fun loc -> + let s, e = loc.loc_start, loc.loc_end in + if s.pos_cnum = -1 || e.pos_cnum = -1 then None + else Some ((s, s.pos_cnum), (e, e.pos_cnum - 1)) + ) locs in + match ISet.extrema iset with + | None -> () + | Some ((leftmost, _), (rightmost, _)) -> + let lines = + get_lines ~start_pos:leftmost ~end_pos:rightmost + |> List.map (fun ({ text; start_pos } as line) -> + let end_pos = start_pos + String.length text - 1 in + let line_nb = + match ISet.find_bound_in iset ~range:(start_pos, end_pos) with + | None -> None + | Some (p, _) -> Some p.pos_lnum + in + (line_nb, line)) + |> infer_line_numbers + |> List.map (fun (lnum, { text; start_pos }) -> + (text, + Option.fold ~some:Int.to_string ~none:"" lnum, + start_pos)) + in + Format.fprintf ppf "@["; + begin match lines with + | [] | [("", _, _)] -> () + | [(line, line_nb, line_start_cnum)] -> + (* Single-line error *) + Format.fprintf ppf "%s | %s@," line_nb line; + Format.fprintf ppf "%*s " (String.length line_nb) ""; + (* Iterate up to [rightmost], which can be larger than the length of + the line because we may point to a location after the end of the + last token on the line, for instance: + {[ + token + ^ + Did you forget ... + ]} *) + for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do + let pos = line_start_cnum + i in + if ISet.is_start iset ~pos <> None then + Format.fprintf ppf "@{<%s>" highlight_tag; + if ISet.mem iset ~pos then Format.pp_print_char ppf '^' + else if i < String.length line then begin + (* For alignment purposes, align using a tab for each tab in the + source code *) + if line.[i] = '\t' then Format.pp_print_char ppf '\t' + else Format.pp_print_char ppf ' ' + end; + if ISet.is_end iset ~pos <> None then + Format.fprintf ppf "@}" + done; + Format.fprintf ppf "@}@," + | _ -> + (* Multi-line error *) + Misc.pp_two_columns ~sep:"|" ~max_lines ppf + @@ List.map (fun (line, line_nb, line_start_cnum) -> + let line = String.mapi (fun i car -> + if ISet.mem iset ~pos:(line_start_cnum + i) then car else '.' + ) line in + (line_nb, line) + ) lines + end; + Format.fprintf ppf "@]" +*) + + + +(* +let lines_around + ~(start_pos: position) ~(end_pos: position) + ~(seek: int -> unit) + ~(read_char: unit -> char option): + input_line list + = + seek start_pos.pos_bol; + let lines = ref [] in + let bol = ref start_pos.pos_bol in + let cur = ref start_pos.pos_bol in + let b = Buffer.create 80 in + let add_line () = + if !bol < !cur then begin + let text = Buffer.contents b in + Buffer.clear b; + lines := { text; start_pos = !bol } :: !lines; + bol := !cur + end + in + let rec loop () = + if !bol >= end_pos.pos_cnum then () + else begin + match read_char () with + | None -> + (* end of input *) + add_line () + | Some c -> + incr cur; + match c with + | '\r' -> loop () + | '\n' -> add_line (); loop () + | _ -> Buffer.add_char b c; loop () + end + in + loop (); + List.rev !lines +*) + +(* +(* Try to get lines from a lexbuf *) +let lines_around_from_lexbuf + ~(start_pos: position) ~(end_pos: position) + (lb: lexbuf): + input_line list + = + (* Converts a global position to one that is relative to the lexing buffer *) + let rel n = n - lb.lex_abs_pos in + if rel start_pos.pos_bol < 0 then begin + (* Do nothing if the buffer does not contain the input (because it has been + refilled while lexing it) *) + [] + end else begin + let pos = ref 0 in (* relative position *) + let seek n = pos := rel n in + let read_char () = + if !pos >= lb.lex_buffer_len then (* end of buffer *) None + else + let c = Bytes.get lb.lex_buffer !pos in + incr pos; Some c + in + lines_around ~start_pos ~end_pos ~seek ~read_char + end +*) + +(* +(* Attempt to get lines from the phrase buffer *) +let lines_around_from_phrasebuf + ~(start_pos: position) ~(end_pos: position) + (pb: Buffer.t): + input_line list + = + let pos = ref 0 in + let seek n = pos := n in + let read_char () = + if !pos >= Buffer.length pb then None + else begin + let c = Buffer.nth pb !pos in + incr pos; Some c + end + in + lines_around ~start_pos ~end_pos ~seek ~read_char +*) + +(* +(* Get lines from a file *) +let lines_around_from_file + ~(start_pos: position) ~(end_pos: position) + (filename: string): + input_line list + = + try + let cin = open_in_bin filename in + let read_char () = + try Some (input_char cin) with End_of_file -> None + in + let lines = + lines_around ~start_pos ~end_pos ~seek:(seek_in cin) ~read_char + in + close_in cin; + lines + with Sys_error _ -> [] +*) + +(* +(* A [get_lines] function for [highlight_quote] that reads from the current + input. + + It first tries to read from [!input_lexbuf], then if that fails (because the + lexbuf no longer contains the input we want), it reads from [!input_name] + directly *) +let lines_around_from_current_input ~start_pos ~end_pos = + (* Be a bit defensive, and do not try to open one of the possible + [!input_name] values that we know do not denote valid filenames. *) + let file_valid = function + | "//toplevel//" | "_none_" | "" -> false + | _ -> true + in + let from_file () = + if file_valid !input_name then + lines_around_from_file !input_name ~start_pos ~end_pos + else + [] + in + match !input_lexbuf with + | Some lb -> + begin match lines_around_from_lexbuf lb ~start_pos ~end_pos with + | [] -> (* The input is likely not in the lexbuf anymore *) + from_file () + | lines -> + lines + end + | None -> + from_file () +*) + +(******************************************************************************) +(* Reporting errors and warnings *) + +type msg = (Format.formatter -> unit) loc + +let msg ?(loc = none) fmt = + Format.kdprintf (fun txt -> { loc; txt }) fmt + +type report_kind = + | Report_error + | Report_warning of string + | Report_warning_as_error of string + | Report_alert of string + | Report_alert_as_error of string + +type error_source = Lexer | Parser | Typer | Warning | Unknown | Env | Config + +type report = { + kind : report_kind; + main : msg; + sub : msg list; + source : error_source; +} + +let loc_of_report { main; _ } = main.loc +let print_msg fmt msg = msg.txt fmt +let print_main fmt { main; _ } = print_msg fmt main +let print_sub_msg = print_msg + + +type report_printer = { + (* The entry point *) + pp : report_printer -> + Format.formatter -> report -> unit; + + pp_report_kind : report_printer -> report -> + Format.formatter -> report_kind -> unit; + pp_main_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_main_txt : report_printer -> report -> + Format.formatter -> (Format.formatter -> unit) -> unit; + pp_submsgs : report_printer -> report -> + Format.formatter -> msg list -> unit; + pp_submsg : report_printer -> report -> + Format.formatter -> msg -> unit; + pp_submsg_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_submsg_txt : report_printer -> report -> + Format.formatter -> (Format.formatter -> unit) -> unit; +} + +(* +let is_dummy_loc loc = + (* Fixme: this should be just [loc.loc_ghost] and the function should be + inlined below. However, currently, the compiler emits in some places ghost + locations with valid ranges that should still be printed. These locations + should be made non-ghost -- in the meantime we just check if the ranges are + valid. *) + loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1 +*) + +(* It only makes sense to highlight (i.e. quote or underline the corresponding + source code) locations that originate from the current input. + + As of now, this should only happen in the following cases: + + - if dummy locs or ghost locs leak out of the compiler or a buggy ppx; + + - more generally, if some code uses the compiler-libs API and feeds it + locations that do not match the current values of [!Location.input_name], + [!Location.input_lexbuf]; + + - when calling the compiler on a .ml file that contains lexer line directives + indicating an other file. This should happen relatively rarely in practice -- + in particular this is not what happens when using -pp or -ppx or a ppx + driver. +*) + (* +let is_quotable_loc loc = + not (is_dummy_loc loc) + && loc.loc_start.pos_fname = !input_name + && loc.loc_end.pos_fname = !input_name + +let error_style () = + let open Misc.Error_style in + match !Clflags.error_style with + | Some Contextual | None -> Contextual + | Some Short -> Short + *) + +let batch_mode_printer : report_printer = + let pp_loc _self _report _ppf _loc = + (* + let tag = match report.kind with + | Report_warning_as_error _ + | Report_alert_as_error _ + | Report_error -> "error" + | Report_warning _ + | Report_alert _ -> "warning" + in + let highlight ppf loc = + match error_style () with + | Misc.Error_style.Contextual -> + if is_quotable_loc loc then + highlight_quote ppf + ~get_lines:lines_around_from_current_input + tag [loc] + | Misc.Error_style.Short -> + () + in + Format.fprintf ppf "@[%a:@ %a@]" print_loc loc highlight loc + *) + () + in + let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in + let pp self ppf report = + separate_new_message ppf; + (* Make sure we keep [num_loc_lines] updated. + The tabulation box is here to give submessage the option + to be aligned with the main message box + *) + print_updating_num_loc_lines ppf (fun ppf () -> + Format.fprintf ppf "@[%a%a%a: %a%a%a%a@]@." + Format.pp_open_tbox () + (self.pp_main_loc self report) report.main.loc + (self.pp_report_kind self report) report.kind + Format.pp_set_tab () + (self.pp_main_txt self report) report.main.txt + (self.pp_submsgs self report) report.sub + Format.pp_close_tbox () + ) () + in + let pp_report_kind _self _ ppf = function + | Report_error -> Format.fprintf ppf "@{Error@}" + | Report_warning w -> Format.fprintf ppf "@{Warning@} %s" w + | Report_warning_as_error w -> + Format.fprintf ppf "@{Error@} (warning %s)" w + | Report_alert w -> Format.fprintf ppf "@{Alert@} %s" w + | Report_alert_as_error w -> + Format.fprintf ppf "@{Error@} (alert %s)" w + in + let pp_main_loc self report ppf loc = + pp_loc self report ppf loc + in + let pp_main_txt _self _ ppf txt = + pp_txt ppf txt + in + let pp_submsgs self report ppf msgs = + List.iter (fun msg -> + Format.fprintf ppf "@,%a" (self.pp_submsg self report) msg + ) msgs + in + let pp_submsg self report ppf { loc; txt } = + Format.fprintf ppf "@[%a %a@]" + (self.pp_submsg_loc self report) loc + (self.pp_submsg_txt self report) txt + in + let pp_submsg_loc self report ppf loc = + if not loc.loc_ghost then + pp_loc self report ppf loc + in + let pp_submsg_txt _self _ ppf loc = + pp_txt ppf loc + in + { pp; pp_report_kind; pp_main_loc; pp_main_txt; + pp_submsgs; pp_submsg; pp_submsg_loc; pp_submsg_txt } + +(* +let terminfo_toplevel_printer (lb: lexbuf): report_printer = + let pp self ppf err = + setup_colors (); + (* Highlight all toplevel locations of the report, instead of displaying + the main location. Do it now instead of in [pp_main_loc], to avoid + messing with Format boxes. *) + let sub_locs = List.map (fun { loc; _ } -> loc) err.sub in + let all_locs = err.main.loc :: sub_locs in + let locs_highlighted = List.filter is_quotable_loc all_locs in + highlight_terminfo lb ppf locs_highlighted; + batch_mode_printer.pp self ppf err + in + let pp_main_loc _ _ _ _ = () in + let pp_submsg_loc _ _ ppf loc = + if not loc.loc_ghost then + Format.fprintf ppf "%a:@ " print_loc loc in + { batch_mode_printer with pp; pp_main_loc; pp_submsg_loc } + +let best_toplevel_printer () = + setup_terminal (); + match !status, !input_lexbuf with + | Terminfo.Good_term, Some lb -> + terminfo_toplevel_printer lb + | _, _ -> + batch_mode_printer +*) + +(* Creates a printer for the current input *) +let default_report_printer () : report_printer = + batch_mode_printer + +let report_printer = ref default_report_printer + +let print_report ppf report = + let printer = !report_printer () in + printer.pp printer ppf report + +(******************************************************************************) +(* Reporting errors *) + +type error = report + +let report_error ppf err = + print_report ppf err + +let mkerror loc sub txt source = + { kind = Report_error; main = { loc; txt }; sub; source } + +let errorf ?(loc = none) ?(sub = []) ?(source=Typer) = + Format.kdprintf (fun msg -> mkerror loc sub msg source) + +let error ?(loc = none) ?(sub = []) ?(source=Typer) msg_str = + mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str) source + +let error_of_printer ?(loc = none) ?(sub = []) ?(source=Typer) pp x = + mkerror loc sub (fun ppf -> pp ppf x) source + +let error_of_printer_file ?source print x = + error_of_printer ?source ~loc:(in_file !input_name) print x + +(******************************************************************************) +(* Reporting warnings: generating a report from a warning number using the + information in [Warnings] + convenience functions. *) + +let default_warning_alert_reporter ?(source = Typer) report mk (loc: t) w : report option = + match report w with + | `Inactive -> None + | `Active { Warnings.id; message; is_error; sub_locs } -> + let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in + let kind = mk is_error id in + let main = { loc; txt = msg_of_str message } in + let sub = List.map (fun (loc, sub_message) -> + { loc; txt = msg_of_str sub_message } + ) sub_locs in + Some { kind; main; sub; source } + + +let default_warning_reporter = + default_warning_alert_reporter + Warnings.report + (fun is_error id -> + if is_error then Report_warning_as_error id + else Report_warning id + ) + +let warning_reporter = ref default_warning_reporter +let report_warning loc w = !warning_reporter loc w + +let formatter_for_warnings = ref Format.err_formatter + +let print_warning loc ppf w = + match report_warning loc w with + | None -> () + | Some report -> print_report ppf report + +let prerr_warning_ref = + ref (fun loc w -> print_warning loc !formatter_for_warnings w) +let prerr_warning loc w = !prerr_warning_ref loc w + +let default_alert_reporter = + default_warning_alert_reporter + Warnings.report_alert + (fun is_error id -> + if is_error then Report_alert_as_error id + else Report_alert id + ) + +let alert_reporter = ref default_alert_reporter +let report_alert loc w = !alert_reporter loc w + +let print_alert loc ppf w = + match report_alert loc w with + | None -> () + | Some report -> print_report ppf report + +let prerr_alert_ref = + ref (fun loc w -> print_alert loc !formatter_for_warnings w) + +let prerr_alert loc w = !prerr_alert_ref loc w + +let alert ?(def = none) ?(use = none) ~kind loc message = + prerr_alert loc {Warnings.kind; message; def; use} + +let deprecated ?def ?use loc message = + alert ?def ?use ~kind:"deprecated" loc message + + +let auto_include_alert lib = + let message = Printf.sprintf "\ + OCaml's lib directory layout changed in 5.0. The %s subdirectory has been \ + automatically added to the search path, but you should add -I +%s to the \ + command-line to silence this alert (e.g. by adding %s to the list of \ + libraries in your dune file, or adding use_%s to your _tags file for \ + ocamlbuild, or using -package %s for ocamlfind)." lib lib lib lib lib in + let alert = + {Warnings.kind="ocaml_deprecated_auto_include"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + +let deprecated_script_alert program = + let message = Printf.sprintf "\ + Running %s where the first argument is an implicit basename with no \ + extension (e.g. %s script-file) is deprecated. Either rename the script \ + (%s script-file.ml) or qualify the basename (%s ./script-file)" + program program program program + in + let alert = + {Warnings.kind="ocaml_deprecated_cli"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + +(******************************************************************************) +(* Reporting errors on exceptions *) + +let error_of_exn : (exn -> error option) list ref = ref [] + +let register_error_of_exn f = error_of_exn := f :: !error_of_exn + +exception Already_displayed_error = Warnings.Errors + +let error_of_exn exn = + match exn with + | Already_displayed_error -> Some `Already_displayed + | _ -> + let rec loop = function + | [] -> None + | f :: rest -> + match f exn with + | Some error -> Some (`Ok error) + | None -> loop rest + in + loop !error_of_exn + +let () = + register_error_of_exn + (function + | Sys_error msg -> + Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg) + | _ -> None + ) + +external reraise : exn -> 'a = "%reraise" + +let report_exception ppf exn = + let rec loop n exn = + match error_of_exn exn with + | None -> reraise exn + | Some `Already_displayed -> () + | Some (`Ok err) -> report_error ppf err + | exception exn when n > 0 -> loop (n-1) exn + in + loop 5 exn + +exception Error of error + +let () = + register_error_of_exn + (function + | Error e -> Some e + | _ -> None + ) + +let raise_errorf ?(loc = none) ?(sub = []) ?(source = Typer)= + Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt source))) diff --git a/ocamlmerlin_mlx/ocaml/parsing/location.mli b/ocamlmerlin_mlx/ocaml/parsing/location.mli new file mode 100644 index 0000000..6681309 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/location.mli @@ -0,0 +1,374 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Source code locations (ranges of positions), used in parsetree. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Format + +type t = Warnings.loc = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +(** Note on the use of Lexing.position in this module. + If [pos_fname = ""], then use [!input_name] instead. + If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and + re-parse the file to get the line and character numbers. + Else all fields are correct. +*) + +val none : t +(** An arbitrary value of type [t]; describes an empty ghost range. *) + +val is_none : t -> bool +(** True for [Location.none], false any other location *) + +val in_file : string -> t +(** Return an empty ghost range located in a given file. *) + +val init : Lexing.lexbuf -> string -> unit +(** Set the file name and line number of the [lexbuf] to be the start + of the named file. *) + +val curr : Lexing.lexbuf -> t +(** Get the location of the current token from the [lexbuf]. *) + +val symbol_rloc: unit -> t +val symbol_gloc: unit -> t + +(** [rhs_loc n] returns the location of the symbol at position [n], starting + at 1, in the current parser rule. *) +val rhs_loc: int -> t + +val rhs_interval: int -> int -> t + +val get_pos_info: Lexing.position -> string * int * int +(** file, line, char *) + +type 'a loc = { + txt : 'a; + loc : t; +} + +val mknoloc : 'a -> 'a loc +val mkloc : 'a -> t -> 'a loc + + +(** {1 Input info} *) + +val input_name: string ref +val input_lexbuf: Lexing.lexbuf option ref + +(* This is used for reporting errors coming from the toplevel. + + When running a toplevel session (i.e. when [!input_name] is "//toplevel//"), + [!input_phrase_buffer] should be [Some buf] where [buf] contains the last + toplevel phrase. *) +val input_phrase_buffer: Buffer.t option ref + +(** {1 Toplevel-specific functions} *) + +val echo_eof: unit -> unit +val separate_new_message: formatter -> unit +val reset: unit -> unit + + +(** {1 Rewriting path } *) + +val rewrite_absolute_path: string -> string +(** [rewrite_absolute_path path] rewrites [path] to honor the + BUILD_PATH_PREFIX_MAP variable + if it is set. It does not check whether [path] is absolute or not. + The result is as follows: + - If BUILD_PATH_PREFIX_MAP is not set, just return [path]. + - otherwise, rewrite using the mapping (and if there are no + matching prefixes that will just return [path]). + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +(* +val rewrite_find_first_existing: string -> string option +*) +(** [rewrite_find_first_existing path] uses a BUILD_PATH_PREFIX_MAP mapping + and tries to find a source in mapping + that maps to a result that exists in the file system. + There are the following return values: + - [None], means either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [path] does not exists, or} + {- no source prefixes of [path] in the mapping were found,}} + - [Some target], means [target] exists and either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [target] = [path], or} + {- [target] is the first file (in priority + order) that [path] mapped to that exists in the file system.}} + - [Not_found] raised, means some source prefixes in the map + were found that matched [path], but none of them existed + in the file system. The caller should catch this and issue + an appropriate error message. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +(* +val rewrite_find_all_existing_dirs: string -> string list +*) +(** [rewrite_find_all_existing_dirs dir] accumulates a list of existing + directories, [dirs], that are the result of mapping a potentially + abstract directory, [dir], over all the mapping pairs in the + BUILD_PATH_PREFIX_MAP environment variable, if any. The list [dirs] + will be in priority order (head as highest priority). + + The possible results are: + - [[]], means either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [dir] is not an existing + directory, or} + {- if set, then there were no matching prefixes of [dir].}} + - [Some dirs], means dirs are the directories found. Either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [dirs = [dir]], or} + {- it was set and [dirs] are the mapped existing directories.}} + - Not_found raised, means some source prefixes in the map + were found that matched [dir], but none of mapping results + were existing directories (possibly due to misconfiguration). + The caller should catch this and issue an appropriate error + message. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +val absolute_path: string -> string + (** [absolute_path path] first makes an absolute path, [s] from [path], + prepending the current working directory if [path] was relative. + Then [s] is rewritten using [rewrite_absolute_path]. + Finally the result is normalized by eliminating instances of + ['.'] or ['..']. *) + +(** {1 Printing locations} *) + +val show_filename: string -> string + (** In -absname mode, return the absolute path for this filename. + Otherwise, returns the filename unchanged. *) + +val print_filename: formatter -> string -> unit + +val print_loc: formatter -> t -> unit +val print_locs: formatter -> t list -> unit + +(** {1 Toplevel-specific location highlighting} *) +(* +val highlight_terminfo: + Lexing.lexbuf -> formatter -> t list -> unit +*) + +(** {1 Reporting errors and warnings} *) + +(** {2 The type of reports and report printers} *) + +type msg = (Format.formatter -> unit) loc + +val msg: ?loc:t -> ('a, Format.formatter, unit, msg) format4 -> 'a + +type report_kind = + | Report_error + | Report_warning of string + | Report_warning_as_error of string + | Report_alert of string + | Report_alert_as_error of string + +type error_source = Lexer | Parser | Typer | Warning | Unknown | Env | Config + +type report = { + kind : report_kind; + main : msg; + sub : msg list; + source : error_source; +} + +(* Exposed for Merlin *) +val loc_of_report: report -> t +val print_main : formatter -> report -> unit +val print_sub_msg : formatter -> msg -> unit + +type report_printer = { + (* The entry point *) + pp : report_printer -> + Format.formatter -> report -> unit; + + pp_report_kind : report_printer -> report -> + Format.formatter -> report_kind -> unit; + pp_main_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_main_txt : report_printer -> report -> + Format.formatter -> (Format.formatter -> unit) -> unit; + pp_submsgs : report_printer -> report -> + Format.formatter -> msg list -> unit; + pp_submsg : report_printer -> report -> + Format.formatter -> msg -> unit; + pp_submsg_loc : report_printer -> report -> + Format.formatter -> t -> unit; + pp_submsg_txt : report_printer -> report -> + Format.formatter -> (Format.formatter -> unit) -> unit; +} +(** A printer for [report]s, defined using open-recursion. + The goal is to make it easy to define new printers by re-using code from + existing ones. +*) + +(** {2 Report printers used in the compiler} *) + +val batch_mode_printer: report_printer +(* +val terminfo_toplevel_printer: Lexing.lexbuf -> report_printer + +val best_toplevel_printer: unit -> report_printer +(** Detects the terminal capabilities and selects an adequate printer *) +*) + +(** {2 Printing a [report]} *) + +val print_report: formatter -> report -> unit +(** Display an error or warning report. *) + +val report_printer: (unit -> report_printer) ref +(** Hook for redefining the printer of reports. + + The hook is a [unit -> report_printer] and not simply a [report_printer]: + this is useful so that it can detect the type of the output (a file, a + terminal, ...) and select a printer accordingly. *) + +val default_report_printer: unit -> report_printer +(** Original report printer for use in hooks. *) + + +(** {1 Reporting warnings} *) + +(** {2 Converting a [Warnings.t] into a [report]} *) + +val report_warning: t -> Warnings.t -> report option +(** [report_warning loc w] produces a report for the given warning [w], or + [None] if the warning is not to be printed. *) + +val warning_reporter: (t -> Warnings.t -> report option) ref +(** Hook for intercepting warnings. *) + +val default_warning_reporter: t -> Warnings.t -> report option +(** Original warning reporter for use in hooks. *) + +(** {2 Printing warnings} *) + +val formatter_for_warnings : formatter ref + +val print_warning: t -> formatter -> Warnings.t -> unit +(** Prints a warning. This is simply the composition of [report_warning] and + [print_report]. *) + +val prerr_warning_ref: (t -> Warnings.t -> unit) ref + +val prerr_warning: t -> Warnings.t -> unit +(** Same as [print_warning], but uses [!formatter_for_warnings] as output + formatter. *) + +(** {1 Reporting alerts} *) + +(** {2 Converting an [Alert.t] into a [report]} *) + +val report_alert: t -> Warnings.alert -> report option +(** [report_alert loc w] produces a report for the given alert [w], or + [None] if the alert is not to be printed. *) + +val alert_reporter: (t -> Warnings.alert -> report option) ref +(** Hook for intercepting alerts. *) + +val default_alert_reporter: t -> Warnings.alert -> report option +(** Original alert reporter for use in hooks. *) + +(** {2 Printing alerts} *) + +val print_alert: t -> formatter -> Warnings.alert -> unit +(** Prints an alert. This is simply the composition of [report_alert] and + [print_report]. *) + +val prerr_alert_ref: (t -> Warnings.alert -> unit) ref + +val prerr_alert: t -> Warnings.alert -> unit +(** Same as [print_alert], but uses [!formatter_for_warnings] as output + formatter. *) + +val deprecated: ?def:t -> ?use:t -> t -> string -> unit +(** Prints a deprecation alert. *) + +val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit +(** Prints an arbitrary alert. *) + +val auto_include_alert: string -> unit +(** Prints an alert that -I +lib has been automatically added to the load + path *) + +val deprecated_script_alert: string -> unit +(** [deprecated_script_alert command] prints an alert that [command foo] has + been deprecated in favour of [command ./foo] *) + +(** {1 Reporting errors} *) + +type error = report +(** An [error] is a [report] which [report_kind] must be [Report_error]. *) + +val error: ?loc:t -> ?sub:msg list -> ?source:error_source -> string -> error + +val errorf: ?loc:t -> ?sub:msg list -> ?source:error_source -> + ('a, Format.formatter, unit, error) format4 -> 'a + +val error_of_printer: ?loc:t -> ?sub:msg list -> ?source:error_source -> + (formatter -> 'a -> unit) -> 'a -> error + +val error_of_printer_file: ?source:error_source -> (formatter -> 'a -> unit) -> 'a -> error + + +(** {1 Automatically reporting errors for raised exceptions} *) + +val register_error_of_exn: (exn -> error option) -> unit +(** Each compiler module which defines a custom type of exception + which can surface as a user-visible error should register + a "printer" for this exception using [register_error_of_exn]. + The result of the printer is an [error] value containing + a location, a message, and optionally sub-messages (each of them + being located as well). *) + +val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option + +exception Error of error +(** Raising [Error e] signals an error [e]; the exception will be caught and the + error will be printed. *) + +exception Already_displayed_error +(** Raising [Already_displayed_error] signals an error which has already been + printed. The exception will be caught, but nothing will be printed *) + +val raise_errorf: ?loc:t -> ?sub:msg list -> ?source:error_source -> + ('a, Format.formatter, unit, 'b) format4 -> 'a + +val report_exception: formatter -> exn -> unit +(** Reraise the exception if it is unknown. *) diff --git a/ocamlmerlin_mlx/ocaml/parsing/location_aux.ml b/ocamlmerlin_mlx/ocaml/parsing/location_aux.ml new file mode 100644 index 0000000..966ebdd --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/location_aux.ml @@ -0,0 +1,94 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +open Std + +type t + = Location.t + = { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool } + +let compare (l1: t) (l2: t) = + match Lexing.compare_pos l1.loc_start l2.loc_start with + | (-1 | 1) as r -> r + | 0 -> Lexing.compare_pos l1.loc_end l2.loc_end + | _ -> assert false + +let compare_pos pos loc = + if Lexing.compare_pos pos loc.Location.loc_start < 0 then + -1 + else if Lexing.compare_pos pos loc.Location.loc_end > 0 then + 1 + else + 0 + +let union l1 l2 = + if l1 = Location.none then l2 + else if l2 = Location.none then l1 + else { + Location. + loc_start = Lexing.min_pos l1.Location.loc_start l2.Location.loc_start; + loc_end = Lexing.max_pos l1.Location.loc_end l2.Location.loc_end; + loc_ghost = l1.Location.loc_ghost && l2.Location.loc_ghost; + } + +let extend l1 l2 = + if l1 = Location.none then l2 + else if l2 = Location.none then l1 + else { + Location. + loc_start = Lexing.min_pos l1.Location.loc_start l2.Location.loc_start; + loc_end = Lexing.max_pos l1.Location.loc_end l2.Location.loc_end; + loc_ghost = l1.Location.loc_ghost; + } + +(** Filter valid errors, log invalid ones *) +let prepare_errors exns = + List.filter_map exns + ~f:(fun exn -> + match Location.error_of_exn exn with + | None -> + Logger.log ~section:"Mreader" ~title:"errors" + "Location.error_of_exn (%a) = None" + (fun () -> Printexc.to_string) exn; + None + | Some `Already_displayed -> None + | Some (`Ok err) -> Some err + ) + +let print () {Location. loc_start; loc_end; loc_ghost} = + let l1, c1 = Lexing.split_pos loc_start in + let l2, c2 = Lexing.split_pos loc_end in + sprintf "%d:%d-%d:%d%s" + l1 c1 l2 c2 (if loc_ghost then "{ghost}" else "") + +let print_loc f () {Location. txt; loc} = + sprintf "%a@%a" f txt print loc + +let is_relaxed_location = function + | { Location. txt = "merlin.relaxed-location" | "merlin.loc"; _ } -> true + | _ -> false diff --git a/ocamlmerlin_mlx/ocaml/parsing/location_aux.mli b/ocamlmerlin_mlx/ocaml/parsing/location_aux.mli new file mode 100644 index 0000000..7d99d36 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/location_aux.mli @@ -0,0 +1,53 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +type t + = Location.t + = { loc_start: Lexing.position; loc_end: Lexing.position; loc_ghost: bool } + +(** [compare l1 l2] compares start positions, if equal compares end positions *) +val compare : t -> t -> int + +val compare_pos: Lexing.position -> t -> int + +(** Return the smallest location covered by both arguments, + ghost if both are ghosts *) +val union : t -> t -> t + +(** Like location_union, but keep loc_ghost'ness of first argument *) +val extend : t -> t -> t + +(** Filter valid errors, log invalid ones *) +val prepare_errors : exn list -> Location.error list + +(** {1 Dump} *) + +val print : unit -> t -> string +val print_loc : (unit -> 'a -> string) -> unit -> 'a Location.loc -> string + +val is_relaxed_location : string Location.loc -> bool diff --git a/ocamlmerlin_mlx/ocaml/parsing/longident.ml b/ocamlmerlin_mlx/ocaml/parsing/longident.ml new file mode 100644 index 0000000..837c6a9 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/longident.ml @@ -0,0 +1,80 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + Lident of string + | Ldot of t * string + | Lapply of t * t + +let rec flat accu = function + Lident s -> s :: accu + | Ldot(lid, s) -> flat (s :: accu) lid + | Lapply(_, _) -> Misc.fatal_error "Longident.flat" + +let flatten lid = flat [] lid + +let rec head = function + Lident s -> s + | Ldot(lid, _) -> head lid + | Lapply(_, _) -> assert false + +let last = function + Lident s -> s + | Ldot(_, s) -> s + | Lapply(_, _) -> Misc.fatal_error "Longident.last" + + +let rec split_at_dots s pos = + try + let dot = String.index_from s pos '.' in + String.sub s pos (dot - pos) :: split_at_dots s (dot + 1) + with Not_found -> + [String.sub s pos (String.length s - pos)] + +let unflatten l = + match l with + | [] -> None + | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl) + +let parse s = + match unflatten (split_at_dots s 0) with + | None -> Lident "" (* should not happen, but don't put assert false + so as not to crash the toplevel (see Genprintval) *) + | Some v -> v + +let keep_suffix = + let rec aux = function + | Lident str -> + if String.uncapitalize_ascii str <> str then + Some (Lident str, false) + else + None + | Ldot (t, str) -> + if String.uncapitalize_ascii str <> str then + match aux t with + | None -> Some (Lident str, true) + | Some (t, is_label) -> Some (Ldot (t, str), is_label) + else + None + | t -> Some (t, false) (* Can be improved... *) + in + function + | Lident s -> Lident s, false + | Ldot (t, s) -> + begin match aux t with + | None -> Lident s, true + | Some (t, is_label) -> Ldot (t, s), is_label + end + | otherwise -> otherwise, false diff --git a/ocamlmerlin_mlx/ocaml/parsing/longident.mli b/ocamlmerlin_mlx/ocaml/parsing/longident.mli new file mode 100644 index 0000000..72c5964 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/longident.mli @@ -0,0 +1,74 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Long identifiers, used in parsetree. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + + To print a longident, see {!Pprintast.longident}, using + {!Format.asprintf} to convert to a string. + +*) + +type t = + Lident of string + | Ldot of t * string + | Lapply of t * t + +val flatten: t -> string list +val unflatten: string list -> t option +(** For a non-empty list [l], [unflatten l] is [Some lid] where [lid] is + the long identifier created by concatenating the elements of [l] + with [Ldot]. + [unflatten []] is [None]. +*) + +(** [head lid] returns the leftmost part of [lid], e.g., + given [String.Map.empty], returns [String]. + + @raise Assert_failure if encounters [Lapply] *) +val head: t -> string +val last: t -> string +val parse: string -> t + (* (* disabled in merlin. *) +[@@deprecated "this function may misparse its input,\n\ +use \"Parse.longident\" or \"Longident.unflatten\""] + *) +(** + + This function is broken on identifiers that are not just "Word.Word.word"; + for example, it returns incorrect results on infix operators + and extended module paths. + + If you want to generate long identifiers that are a list of + dot-separated identifiers, the function {!unflatten} is safer and faster. + {!unflatten} is available since OCaml 4.06.0. + + If you want to parse any identifier correctly, use the long-identifiers + functions from the {!Parse} module, in particular {!Parse.longident}. + They are available since OCaml 4.11, and also provide proper + input-location support. + +*) + +(* Merlin specific. *) + +val keep_suffix : t -> t * bool +(** if [li', b = keep_suffix li] then: + - the prefix of [li'] is a module path + - [b = false] iff [li' = li]. + Corollary: [b = true] if [li] is a label access + (i.e. [li = X.Y.z.Foo.Bar...]) *) diff --git a/ocamlmerlin_mlx/ocaml/parsing/msupport_parsing.ml b/ocamlmerlin_mlx/ocaml/parsing/msupport_parsing.ml new file mode 100644 index 0000000..567e5e2 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/msupport_parsing.ml @@ -0,0 +1,6 @@ +(* Filled in from Msupport. *) +let msupport_raise_error : (exn -> unit) ref = + ref raise + +let raise_error exn = + !msupport_raise_error exn diff --git a/ocamlmerlin_mlx/ocaml/parsing/parsetree.mli b/ocamlmerlin_mlx/ocaml/parsing/parsetree.mli new file mode 100644 index 0000000..7bb1313 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/parsetree.mli @@ -0,0 +1,1067 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Abstract syntax tree produced by parsing + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Asttypes + +type constant = + | Pconst_integer of string * char option + (** Integer constants such as [3] [3l] [3L] [3n]. + + Suffixes [[g-z][G-Z]] are accepted by the parser. + Suffixes except ['l'], ['L'] and ['n'] are rejected by the typechecker + *) + | Pconst_char of char (** Character such as ['c']. *) + | Pconst_string of string * Location.t * string option + (** Constant string such as ["constant"] or + [{delim|other constant|delim}]. + + The location span the content of the string, without the delimiters. + *) + | Pconst_float of string * char option + (** Float constant such as [3.4], [2e5] or [1.4e-4]. + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. + *) + +type location_stack = Location.t list + +(** {1 Extension points} *) + +type attribute = { + attr_name : string loc; + attr_payload : payload; + attr_loc : Location.t; + } +(** Attributes such as [[\@id ARG]] and [[\@\@id ARG]]. + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + +and extension = string loc * payload +(** Extension points such as [[%id ARG] and [%%id ARG]]. + + Sub-language placeholder -- rejected by the typechecker. + *) + +and attributes = attribute list + +and payload = + | PStr of structure + | PSig of signature (** [: SIG] in an attribute or an extension point *) + | PTyp of core_type (** [: T] in an attribute or an extension point *) + | PPat of pattern * expression option + (** [? P] or [? P when E], in an attribute or an extension point *) + +(** {1 Core language} *) +(** {2 Type expressions} *) + +and core_type = + { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_loc_stack: location_stack; + ptyp_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and core_type_desc = + | Ptyp_any (** [_] *) + | Ptyp_var of string (** A type variable such as ['a] *) + | Ptyp_arrow of arg_label * core_type * core_type + (** [Ptyp_arrow(lbl, T1, T2)] represents: + - [T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Labelled}[Labelled]}, + - [?l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Optional}[Optional]}. + *) + | Ptyp_tuple of core_type list + (** [Ptyp_tuple([T1 ; ... ; Tn])] + represents a product type [T1 * ... * Tn]. + + Invariant: [n >= 2]. + *) + | Ptyp_constr of Longident.t loc * core_type list + (** [Ptyp_constr(lident, l)] represents: + - [tconstr] when [l=[]], + - [T tconstr] when [l=[T]], + - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. + *) + | Ptyp_object of object_field list * closed_flag + (** [Ptyp_object([ l1:T1; ...; ln:Tn ], flag)] represents: + - [< l1:T1; ...; ln:Tn >] when [flag] is + {{!Asttypes.closed_flag.Closed}[Closed]}, + - [< l1:T1; ...; ln:Tn; .. >] when [flag] is + {{!Asttypes.closed_flag.Open}[Open]}. + *) + | Ptyp_class of Longident.t loc * core_type list + (** [Ptyp_class(tconstr, l)] represents: + - [#tconstr] when [l=[]], + - [T #tconstr] when [l=[T]], + - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. + *) + | Ptyp_alias of core_type * string (** [T as 'a]. *) + | Ptyp_variant of row_field list * closed_flag * label list option + (** [Ptyp_variant([`A;`B], flag, labels)] represents: + - [[ `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [None], + - [[> `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]}, + and [labels] is [None], + - [[< `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some []], + - [[< `A|`B > `X `Y ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some ["X";"Y"]]. + *) + | Ptyp_poly of string loc list * core_type + (** ['a1 ... 'an. T] + + Can only appear in the following context: + + - As the {!core_type} of a + {{!pattern_desc.Ppat_constraint}[Ppat_constraint]} node corresponding + to a constraint on a let-binding: + {[let x : 'a1 ... 'an. T = e ...]} + + - Under {{!class_field_kind.Cfk_virtual}[Cfk_virtual]} for methods + (not values). + + - As the {!core_type} of a + {{!class_type_field_desc.Pctf_method}[Pctf_method]} node. + + - As the {!core_type} of a {{!expression_desc.Pexp_poly}[Pexp_poly]} + node. + + - As the {{!label_declaration.pld_type}[pld_type]} field of a + {!label_declaration}. + + - As a {!core_type} of a {{!core_type_desc.Ptyp_object}[Ptyp_object]} + node. + + - As the {{!value_description.pval_type}[pval_type]} field of a + {!value_description}. + *) + | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_extension of extension (** [[%id]]. *) + +and package_type = Longident.t loc * (Longident.t loc * core_type) list +(** As {!package_type} typed values: + - [(S, [])] represents [(module S)], + - [(S, [(t1, T1) ; ... ; (tn, Tn)])] + represents [(module S with type t1 = T1 and ... and tn = Tn)]. + *) + +and row_field = { + prf_desc : row_field_desc; + prf_loc : Location.t; + prf_attributes : attributes; +} + +and row_field_desc = + | Rtag of label loc * bool * core_type list + (** [Rtag(`A, b, l)] represents: + - [`A] when [b] is [true] and [l] is [[]], + - [`A of T] when [b] is [false] and [l] is [[T]], + - [`A of T1 & .. & Tn] when [b] is [false] and [l] is [[T1;...Tn]], + - [`A of & T1 & .. & Tn] when [b] is [true] and [l] is [[T1;...Tn]]. + + - The [bool] field is true if the tag contains a + constant (empty) constructor. + - [&] occurs when several types are used for the same constructor + (see 4.2 in the manual) + *) + | Rinherit of core_type (** [[ | t ]] *) + +and object_field = { + pof_desc : object_field_desc; + pof_loc : Location.t; + pof_attributes : attributes; +} + +and object_field_desc = + | Otag of label loc * core_type + | Oinherit of core_type + +(** {2 Patterns} *) + +and pattern = + { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_loc_stack: location_stack; + ppat_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and pattern_desc = + | Ppat_any (** The pattern [_]. *) + | Ppat_var of string loc (** A variable pattern such as [x] *) + | Ppat_alias of pattern * string loc + (** An alias pattern such as [P as 'a] *) + | Ppat_constant of constant + (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) + | Ppat_interval of constant * constant + (** Patterns such as ['a'..'z']. + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (** Patterns [(P1, ..., Pn)]. + + Invariant: [n >= 2] + *) + | Ppat_construct of Longident.t loc * (string loc list * pattern) option + (** [Ppat_construct(C, args)] represents: + - [C] when [args] is [None], + - [C P] when [args] is [Some ([], P)] + - [C (P1, ..., Pn)] when [args] is + [Some ([], Ppat_tuple [P1; ...; Pn])] + - [C (type a b) P] when [args] is [Some ([a; b], P)] + *) + | Ppat_variant of label * pattern option + (** [Ppat_variant(`A, pat)] represents: + - [`A] when [pat] is [None], + - [`A P] when [pat] is [Some P] + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (** [Ppat_record([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: + - [{ l1=P1; ...; ln=Pn }] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]} + - [{ l1=P1; ...; ln=Pn; _}] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]} + + Invariant: [n > 0] + *) + | Ppat_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) + | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) + | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) + | Ppat_type of Longident.t loc (** Pattern [#tconst] *) + | Ppat_lazy of pattern (** Pattern [lazy P] *) + | Ppat_unpack of string option loc + (** [Ppat_unpack(s)] represents: + - [(module P)] when [s] is [Some "P"] + - [(module _)] when [s] is [None] + + Note: [(module P : S)] is represented as + [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] + *) + | Ppat_exception of pattern (** Pattern [exception P] *) + | Ppat_extension of extension (** Pattern [[%id]] *) + | Ppat_open of Longident.t loc * pattern (** Pattern [M.(P)] *) + +(** {2 Value expressions} *) + +and expression = + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_loc_stack: location_stack; + pexp_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and expression_desc = + | Pexp_ident of Longident.t loc + (** Identifiers such as [x] and [M.x] + *) + | Pexp_constant of constant + (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], + [1L], [1n] *) + | Pexp_let of rec_flag * value_binding list * expression + (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: + - [let P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pexp_function of case list (** [function P1 -> E1 | ... | Pn -> En] *) + | Pexp_fun of arg_label * expression option * pattern * expression + (** [Pexp_fun(lbl, exp0, P, E1)] represents: + - [fun P -> E1] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [fun ~l:P -> E1] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [fun ?l:P -> E1] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [fun ?l:(P = E0) -> E1] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Notes: + - If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + - [fun P1 P2 .. Pn -> E1] is represented as nested + {{!expression_desc.Pexp_fun}[Pexp_fun]}. + - [let f P = E] is represented using + {{!expression_desc.Pexp_fun}[Pexp_fun]}. + *) + | Pexp_apply of expression * (arg_label * expression) list + (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] + represents [E0 ~l1:E1 ... ~ln:En] + + [li] can be + {{!Asttypes.arg_label.Nolabel}[Nolabel]} (non labeled argument), + {{!Asttypes.arg_label.Labelled}[Labelled]} (labelled arguments) or + {{!Asttypes.arg_label.Optional}[Optional]} (optional argument). + + Invariant: [n > 0] + *) + | Pexp_match of expression * case list + (** [match E0 with P1 -> E1 | ... | Pn -> En] *) + | Pexp_try of expression * case list + (** [try E0 with P1 -> E1 | ... | Pn -> En] *) + | Pexp_tuple of expression list + (** Expressions [(E1, ..., En)] + + Invariant: [n >= 2] + *) + | Pexp_construct of Longident.t loc * expression option + (** [Pexp_construct(C, exp)] represents: + - [C] when [exp] is [None], + - [C E] when [exp] is [Some E], + - [C (E1, ..., En)] when [exp] is [Some (Pexp_tuple[E1;...;En])] + *) + | Pexp_variant of label * expression option + (** [Pexp_variant(`A, exp)] represents + - [`A] when [exp] is [None] + - [`A E] when [exp] is [Some E] + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (** [Pexp_record([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents + - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] + - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] + + Invariant: [n > 0] + *) + | Pexp_field of expression * Longident.t loc (** [E.l] *) + | Pexp_setfield of expression * Longident.t loc * expression + (** [E1.l <- E2] *) + | Pexp_array of expression list (** [[| E1; ...; En |]] *) + | Pexp_ifthenelse of expression * expression * expression option + (** [if E1 then E2 else E3] *) + | Pexp_sequence of expression * expression (** [E1; E2] *) + | Pexp_while of expression * expression (** [while E1 do E2 done] *) + | Pexp_for of pattern * expression * expression * direction_flag * expression + (** [Pexp_for(i, E1, E2, direction, E3)] represents: + - [for i = E1 to E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Upto}[Upto]} + - [for i = E1 downto E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} + *) + | Pexp_constraint of expression * core_type (** [(E : T)] *) + | Pexp_coerce of expression * core_type option * core_type + (** [Pexp_coerce(E, from, T)] represents + - [(E :> T)] when [from] is [None], + - [(E : T0 :> T)] when [from] is [Some T0]. + *) + | Pexp_send of expression * label loc (** [E # m] *) + | Pexp_new of Longident.t loc (** [new M.c] *) + | Pexp_setinstvar of label loc * expression (** [x <- 2] *) + | Pexp_override of (label loc * expression) list + (** [{< x1 = E1; ...; xn = En >}] *) + | Pexp_letmodule of string option loc * module_expr * expression + (** [let module M = ME in E] *) + | Pexp_letexception of extension_constructor * expression + (** [let exception C in E] *) + | Pexp_assert of expression + (** [assert E]. + + Note: [assert false] is treated in a special way by the + type-checker. *) + | Pexp_lazy of expression (** [lazy E] *) + | Pexp_poly of expression * core_type option + (** Used for method bodies. + + Can only be used as the expression under + {{!class_field_kind.Cfk_concrete}[Cfk_concrete]} for methods (not + values). *) + | Pexp_object of class_structure (** [object ... end] *) + | Pexp_newtype of string loc * expression (** [fun (type t) -> E] *) + | Pexp_pack of module_expr + (** [(module ME)]. + + [(module ME : S)] is represented as + [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *) + | Pexp_open of open_declaration * expression + (** - [M.(E)] + - [let open M in E] + - [let open! M in E] *) + | Pexp_letop of letop + (** - [let* P = E0 in E1] + - [let* P0 = E00 and* P1 = E01 in E1] *) + | Pexp_extension of extension (** [[%id]] *) + | Pexp_unreachable (** [.] *) + +and case = + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } +(** Values of type {!case} represents [(P -> E)] or [(P when E0 -> E)] *) + +and letop = + { + let_ : binding_op; + ands : binding_op list; + body : expression; + } + +and binding_op = + { + pbop_op : string loc; + pbop_pat : pattern; + pbop_exp : expression; + pbop_loc : Location.t; + } + +(** {2 Value descriptions} *) + +and value_description = + { + pval_name: string loc; + pval_type: core_type; + pval_prim: string list; + pval_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pval_loc: Location.t; + } +(** Values of type {!value_description} represents: + - [val x: T], + when {{!value_description.pval_prim}[pval_prim]} is [[]] + - [external x: T = "s1" ... "sn"] + when {{!value_description.pval_prim}[pval_prim]} is [["s1";..."sn"]] +*) + +(** {2 Type declarations} *) + +and type_declaration = + { + ptype_name: string loc; + ptype_params: (core_type * (variance * injectivity)) list; + (** [('a1,...'an) t] *) + ptype_cstrs: (core_type * core_type * Location.t) list; + (** [... constraint T1=T1' ... constraint Tn=Tn'] *) + ptype_kind: type_kind; + ptype_private: private_flag; (** for [= private ...] *) + ptype_manifest: core_type option; (** represents [= T] *) + ptype_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + ptype_loc: Location.t; + } +(** + Here are type declarations and their representation, + for various {{!type_declaration.ptype_kind}[ptype_kind]} + and {{!type_declaration.ptype_manifest}[ptype_manifest]} values: + - [type t] when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [None], + - [type t = T0] + when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [Some T0], + - [type t = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [None], + - [type t = T0 = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [Some T0], + - [type t = {l: T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [None], + - [type t = T0 = {l : T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [Some T0], + - [type t = ..] + when [type_kind] is {{!type_kind.Ptype_open}[Ptype_open]}, + and [manifest] is [None]. +*) + +and type_kind = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + | Ptype_record of label_declaration list (** Invariant: non-empty list *) + | Ptype_open + +and label_declaration = + { + pld_name: string loc; + pld_mutable: mutable_flag; + pld_type: core_type; + pld_loc: Location.t; + pld_attributes: attributes; (** [l : T [\@id1] [\@id2]] *) + } +(** + - [{ ...; l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Immutable}[Immutable]}, + - [{ ...; mutable l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Mutable}[Mutable]}. + + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. +*) + +and constructor_declaration = + { + pcd_name: string loc; + pcd_vars: string loc list; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) + } + +and constructor_arguments = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + (** Values of type {!constructor_declaration} + represents the constructor arguments of: + - [C of T1 * ... * Tn] when [res = None], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C: T0] when [res = Some T0], + and [args = Pcstr_tuple []], + - [C: T1 * ... * Tn -> T0] when [res = Some T0], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C of {...}] when [res = None], + and [args = Pcstr_record [...]], + - [C: {...} -> T0] when [res = Some T0], + and [args = Pcstr_record [...]]. +*) + +and type_extension = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * (variance * injectivity)) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_loc: Location.t; + ptyext_attributes: attributes; (** ... [\@\@id1] [\@\@id2] *) + } +(** + Definition of new extensions constructors for the extensive sum type [t] + ([type t += ...]). +*) + +and extension_constructor = + { + pext_name: string loc; + pext_kind: extension_constructor_kind; + pext_loc: Location.t; + pext_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) + } + +and type_exception = + { + ptyexn_constructor : extension_constructor; + ptyexn_loc : Location.t; + ptyexn_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) + } +(** Definition of a new exception ([exception E]). *) + +and extension_constructor_kind = + | Pext_decl of string loc list * constructor_arguments * core_type option + (** [Pext_decl(existentials, c_args, t_opt)] + describes a new extension constructor. It can be: + - [C of T1 * ... * Tn] when: + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [None]}.} + - [C: T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[]],} + {- [t_opt] is [Some T0].}} + - [C: T1 * ... * Tn -> T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [Some T0].}} + - [C: 'a... . T1 * ... * Tn -> T0] when + {ul {- [existentials] is [['a;...]],} + {- [c_args] is [[T1; ... ; Tn]],} + {- [t_opt] is [Some T0].}} + *) + | Pext_rebind of Longident.t loc + (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) + +(** {1 Class language} *) +(** {2 Type expressions for the class language} *) + +and class_type = + { + pcty_desc: class_type_desc; + pcty_loc: Location.t; + pcty_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and class_type_desc = + | Pcty_constr of Longident.t loc * core_type list + (** - [c] + - [['a1, ..., 'an] c] *) + | Pcty_signature of class_signature (** [object ... end] *) + | Pcty_arrow of arg_label * core_type * class_type + (** [Pcty_arrow(lbl, T, CT)] represents: + - [T -> CT] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]}, + - [?l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}. + *) + | Pcty_extension of extension (** [%id] *) + | Pcty_open of open_description * class_type (** [let open M in CT] *) + +and class_signature = + { + pcsig_self: core_type; + pcsig_fields: class_type_field list; + } +(** Values of type [class_signature] represents: + - [object('selfpat) ... end] + - [object ... end] when {{!class_signature.pcsig_self}[pcsig_self]} + is {{!core_type_desc.Ptyp_any}[Ptyp_any]} +*) + +and class_type_field = + { + pctf_desc: class_type_field_desc; + pctf_loc: Location.t; + pctf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + } + +and class_type_field_desc = + | Pctf_inherit of class_type (** [inherit CT] *) + | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) + (** [val x: T] *) + | Pctf_method of (label loc * private_flag * virtual_flag * core_type) + (** [method x: T] + + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. + *) + | Pctf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) + | Pctf_attribute of attribute (** [[\@\@\@id]] *) + | Pctf_extension of extension (** [[%%id]] *) + +and 'a class_infos = + { + pci_virt: virtual_flag; + pci_params: (core_type * (variance * injectivity)) list; + pci_name: string loc; + pci_expr: 'a; + pci_loc: Location.t; + pci_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + } +(** Values of type [class_expr class_infos] represents: + - [class c = ...] + - [class ['a1,...,'an] c = ...] + - [class virtual c = ...] + + They are also used for "class type" declaration. +*) + +and class_description = class_type class_infos + +and class_type_declaration = class_type class_infos + +(** {2 Value expressions for the class language} *) + +and class_expr = + { + pcl_desc: class_expr_desc; + pcl_loc: Location.t; + pcl_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and class_expr_desc = + | Pcl_constr of Longident.t loc * core_type list + (** [c] and [['a1, ..., 'an] c] *) + | Pcl_structure of class_structure (** [object ... end] *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (** [Pcl_fun(lbl, exp0, P, CE)] represents: + - [fun P -> CE] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None], + - [fun ~l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None], + - [fun ?l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None], + - [fun ?l:(P = E0) -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0]. + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (** [Pcl_apply(CE, [(l1,E1) ; ... ; (ln,En)])] + represents [CE ~l1:E1 ... ~ln:En]. + [li] can be empty (non labeled argument) or start with [?] + (optional argument). + + Invariant: [n > 0] + *) + | Pcl_let of rec_flag * value_binding list * class_expr + (** [Pcl_let(rec, [(P1, E1); ... ; (Pn, En)], CE)] represents: + - [let P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pcl_constraint of class_expr * class_type (** [(CE : CT)] *) + | Pcl_extension of extension (** [[%id]] *) + | Pcl_open of open_description * class_expr (** [let open M in CE] *) + +and class_structure = + { + pcstr_self: pattern; + pcstr_fields: class_field list; + } +(** Values of type {!class_structure} represents: + - [object(selfpat) ... end] + - [object ... end] when {{!class_structure.pcstr_self}[pcstr_self]} + is {{!pattern_desc.Ppat_any}[Ppat_any]} +*) + +and class_field = + { + pcf_desc: class_field_desc; + pcf_loc: Location.t; + pcf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + } + +and class_field_desc = + | Pcf_inherit of override_flag * class_expr * string loc option + (** [Pcf_inherit(flag, CE, s)] represents: + - [inherit CE] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [None], + - [inherit CE as x] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [Some x], + - [inherit! CE] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [None], + - [inherit! CE as x] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [Some x] + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (** [Pcf_val(x,flag, kind)] represents: + - [val x = E] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + - [val mutable x = E] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val mutable virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (** - [method x = E] + ([E] can be a {{!expression_desc.Pexp_poly}[Pexp_poly]}) + - [method virtual x: T] + ([T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}) + *) + | Pcf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) + | Pcf_initializer of expression (** [initializer E] *) + | Pcf_attribute of attribute (** [[\@\@\@id]] *) + | Pcf_extension of extension (** [[%%id]] *) + +and class_field_kind = + | Cfk_virtual of core_type + | Cfk_concrete of override_flag * expression + +and class_declaration = class_expr class_infos + +(** {1 Module language} *) +(** {2 Type expressions for the module language} *) + +and module_type = + { + pmty_desc: module_type_desc; + pmty_loc: Location.t; + pmty_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and module_type_desc = + | Pmty_ident of Longident.t loc (** [Pmty_ident(S)] represents [S] *) + | Pmty_signature of signature (** [sig ... end] *) + | Pmty_functor of functor_parameter * module_type + (** [functor(X : MT1) -> MT2] *) + | Pmty_with of module_type * with_constraint list (** [MT with ...] *) + | Pmty_typeof of module_expr (** [module type of ME] *) + | Pmty_extension of extension (** [[%id]] *) + | Pmty_alias of Longident.t loc (** [(module M)] *) + +and functor_parameter = + | Unit (** [()] *) + | Named of string option loc * module_type + (** [Named(name, MT)] represents: + - [(X : MT)] when [name] is [Some X], + - [(_ : MT)] when [name] is [None] *) + +and signature = signature_item list + +and signature_item = + { + psig_desc: signature_item_desc; + psig_loc: Location.t; + } + +and signature_item_desc = + | Psig_value of value_description + (** - [val x: T] + - [external x: T = "s1" ... "sn"] + *) + | Psig_type of rec_flag * type_declaration list + (** [type t1 = ... and ... and tn = ...] *) + | Psig_typesubst of type_declaration list + (** [type t1 := ... and ... and tn := ...] *) + | Psig_typext of type_extension (** [type t1 += ...] *) + | Psig_exception of type_exception (** [exception C of T] *) + | Psig_module of module_declaration (** [module X = M] and [module X : MT] *) + | Psig_modsubst of module_substitution (** [module X := M] *) + | Psig_recmodule of module_declaration list + (** [module rec X1 : MT1 and ... and Xn : MTn] *) + | Psig_modtype of module_type_declaration + (** [module type S = MT] and [module type S] *) + | Psig_modtypesubst of module_type_declaration + (** [module type S := ...] *) + | Psig_open of open_description (** [open X] *) + | Psig_include of include_description (** [include MT] *) + | Psig_class of class_description list + (** [class c1 : ... and ... and cn : ...] *) + | Psig_class_type of class_type_declaration list + (** [class type ct1 = ... and ... and ctn = ...] *) + | Psig_attribute of attribute (** [[\@\@\@id]] *) + | Psig_extension of extension * attributes (** [[%%id]] *) + +and module_declaration = + { + pmd_name: string option loc; + pmd_type: module_type; + pmd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pmd_loc: Location.t; + } +(** Values of type [module_declaration] represents [S : MT] *) + +and module_substitution = + { + pms_name: string loc; + pms_manifest: Longident.t loc; + pms_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pms_loc: Location.t; + } +(** Values of type [module_substitution] represents [S := M] *) + +and module_type_declaration = + { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pmtd_loc: Location.t; + } +(** Values of type [module_type_declaration] represents: + - [S = MT], + - [S] for abstract module type declaration, + when {{!module_type_declaration.pmtd_type}[pmtd_type]} is [None]. +*) + +and 'a open_infos = + { + popen_expr: 'a; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } +(** Values of type ['a open_infos] represents: + - [open! X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Override}[Override]} + (silences the "used identifier shadowing" warning) + - [open X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Fresh}[Fresh]} +*) + +and open_description = Longident.t loc open_infos +(** Values of type [open_description] represents: + - [open M.N] + - [open M(N).O] *) + +and open_declaration = module_expr open_infos +(** Values of type [open_declaration] represents: + - [open M.N] + - [open M(N).O] + - [open struct ... end] *) + +and 'a include_infos = + { + pincl_mod: 'a; + pincl_loc: Location.t; + pincl_attributes: attributes; + } + +and include_description = module_type include_infos +(** Values of type [include_description] represents [include MT] *) + +and include_declaration = module_expr include_infos +(** Values of type [include_declaration] represents [include ME] *) + +and with_constraint = + | Pwith_type of Longident.t loc * type_declaration + (** [with type X.t = ...] + + Note: the last component of the longident must match + the name of the type_declaration. *) + | Pwith_module of Longident.t loc * Longident.t loc + (** [with module X.Y = Z] *) + | Pwith_modtype of Longident.t loc * module_type + (** [with module type X.Y = Z] *) + | Pwith_modtypesubst of Longident.t loc * module_type + (** [with module type X.Y := sig end] *) + | Pwith_typesubst of Longident.t loc * type_declaration + (** [with type X.t := ..., same format as [Pwith_type]] *) + | Pwith_modsubst of Longident.t loc * Longident.t loc + (** [with module X.Y := Z] *) + +(** {2 Value expressions for the module language} *) + +and module_expr = + { + pmod_desc: module_expr_desc; + pmod_loc: Location.t; + pmod_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } + +and module_expr_desc = + | Pmod_ident of Longident.t loc (** [X] *) + | Pmod_structure of structure (** [struct ... end] *) + | Pmod_functor of functor_parameter * module_expr + (** [functor(X : MT1) -> ME] *) + | Pmod_apply of module_expr * module_expr (** [ME1(ME2)] *) + | Pmod_apply_unit of module_expr (** [ME1()] *) + | Pmod_constraint of module_expr * module_type (** [(ME : MT)] *) + | Pmod_unpack of expression (** [(val E)] *) + | Pmod_extension of extension (** [[%id]] *) + +and structure = structure_item list + +and structure_item = + { + pstr_desc: structure_item_desc; + pstr_loc: Location.t; + } + +and structure_item_desc = + | Pstr_eval of expression * attributes (** [E] *) + | Pstr_value of rec_flag * value_binding list + (** [Pstr_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: + - [let P1 = E1 and ... and Pn = EN] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN ] + when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pstr_primitive of value_description + (** - [val x: T] + - [external x: T = "s1" ... "sn" ]*) + | Pstr_type of rec_flag * type_declaration list + (** [type t1 = ... and ... and tn = ...] *) + | Pstr_typext of type_extension (** [type t1 += ...] *) + | Pstr_exception of type_exception + (** - [exception C of T] + - [exception C = M.X] *) + | Pstr_module of module_binding (** [module X = ME] *) + | Pstr_recmodule of module_binding list + (** [module rec X1 = ME1 and ... and Xn = MEn] *) + | Pstr_modtype of module_type_declaration (** [module type S = MT] *) + | Pstr_open of open_declaration (** [open X] *) + | Pstr_class of class_declaration list + (** [class c1 = ... and ... and cn = ...] *) + | Pstr_class_type of class_type_declaration list + (** [class type ct1 = ... and ... and ctn = ...] *) + | Pstr_include of include_declaration (** [include ME] *) + | Pstr_attribute of attribute (** [[\@\@\@id]] *) + | Pstr_extension of extension * attributes (** [[%%id]] *) + +and value_constraint = + | Pvc_constraint of { + locally_abstract_univars:string loc list; + typ:core_type; + } + | Pvc_coercion of {ground:core_type option; coercion:core_type } + (** + - [Pvc_constraint { locally_abstract_univars=[]; typ}] + is a simple type constraint on a value binding: [ let x : typ] + - More generally, in [Pvc_constraint { locally_abstract_univars; typ}] + [locally_abstract_univars] is the list of locally abstract type + variables in [ let x: type a ... . typ ] + - [Pvc_coercion { ground=None; coercion }] represents [let x :> typ] + - [Pvc_coercion { ground=Some g; coercion }] represents [let x : g :> typ] + *) + +and value_binding = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_constraint: value_constraint option; + pvb_attributes: attributes; + pvb_loc: Location.t; + }(** [let pat : type_constraint = exp] *) + +and module_binding = + { + pmb_name: string option loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } +(** Values of type [module_binding] represents [module X = ME] *) + +(** {1 Toplevel} *) + +(** {2 Toplevel phrases} *) + +type toplevel_phrase = + | Ptop_def of structure + | Ptop_dir of toplevel_directive (** [#use], [#load] ... *) + +and toplevel_directive = + { + pdir_name: string loc; + pdir_arg: directive_argument option; + pdir_loc: Location.t; + } + +and directive_argument = + { + pdira_desc: directive_argument_desc; + pdira_loc: Location.t; + } + +and directive_argument_desc = + | Pdir_string of string + | Pdir_int of string * char option + | Pdir_ident of Longident.t + | Pdir_bool of bool diff --git a/ocamlmerlin_mlx/ocaml/parsing/pprintast.ml b/ocamlmerlin_mlx/ocaml/parsing/pprintast.ml new file mode 100644 index 0000000..ce6fc4f --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/pprintast.ml @@ -0,0 +1,1739 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire, OCamlPro *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* Hongbo Zhang, University of Pennsylvania *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) +(* Printing code expressions *) +(* Authors: Ed Pizzi, Fabrice Le Fessant *) +(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) +(* TODO more fine-grained precedence pretty-printing *) + +open Asttypes +open Format +open Location +open Longident +open Parsetree + +let prefix_symbols = [ '!'; '?'; '~' ] +let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; + '$'; '%'; '#' ] + +(* type fixity = Infix| Prefix *) +let special_infix_strings = + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] + +let letop s = + String.length s > 3 + && s.[0] = 'l' + && s.[1] = 'e' + && s.[2] = 't' + && List.mem s.[3] infix_symbols + +let andop s = + String.length s > 3 + && s.[0] = 'a' + && s.[1] = 'n' + && s.[2] = 'd' + && List.mem s.[3] infix_symbols + +(* determines if the string is an infix string. + checks backwards, first allowing a renaming postfix ("_102") which + may have resulted from Pexp -> Texp -> Pexp translation, then checking + if all the characters in the beginning of the string are valid infix + characters. *) +let fixity_of_string = function + | "" -> `Normal + | s when List.mem s special_infix_strings -> `Infix s + | s when List.mem s.[0] infix_symbols -> `Infix s + | s when List.mem s.[0] prefix_symbols -> `Prefix s + | s when s.[0] = '.' -> `Mixfix s + | s when letop s -> `Letop s + | s when andop s -> `Andop s + | _ -> `Normal + +let view_fixity_of_exp = function + | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> + fixity_of_string l + | _ -> `Normal + +let is_infix = function `Infix _ -> true | _ -> false +let is_mixfix = function `Mixfix _ -> true | _ -> false +let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false + +let first_is c str = + str <> "" && str.[0] = c +let last_is c str = + str <> "" && str.[String.length str - 1] = c + +let first_is_in cs str = + str <> "" && List.mem str.[0] cs + +(* which identifiers are in fact operators needing parentheses *) +let needs_parens txt = + let fix = fixity_of_string txt in + is_infix fix + || is_mixfix fix + || is_kwdop fix + || first_is_in prefix_symbols txt + +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) +let needs_spaces txt = + first_is '*' txt || last_is '*' txt + +let string_loc ppf x = fprintf ppf "%s" x.txt + +(* add parentheses to binders when they are in fact infix or prefix operators *) +let protect_ident ppf txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in fprintf ppf format txt + +let protect_longident ppf print_longident longprefix txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%a.%s" + else if needs_spaces txt then "%a.(@;%s@;)" + else "%a.(%s)" in + fprintf ppf format print_longident longprefix txt + +type space_formatter = (unit, Format.formatter, unit) format + +let override = function + | Override -> "!" + | Fresh -> "" + +(* variance encoding: need to sync up with the [parser.mly] *) +let type_variance = function + | NoVariance -> "" + | Covariant -> "+" + | Contravariant -> "-" + +let type_injectivity = function + | NoInjectivity -> "" + | Injective -> "!" + +type construct = + [ `cons of expression list + | `list of expression list + | `nil + | `normal + | `simple of Longident.t + | `tuple ] + +let view_expr x = + match x.pexp_desc with + | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple + | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil + | Pexp_construct ( {txt= Lident"::";_},Some _) -> + let rec loop exp acc = match exp with + | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); + pexp_attributes = []} -> + (List.rev acc,true) + | {pexp_desc= + Pexp_construct ({txt=Lident "::";_}, + Some ({pexp_desc= Pexp_tuple([e1;e2]); + pexp_attributes = []})); + pexp_attributes = []} + -> + loop e2 (e1::acc) + | e -> (List.rev (e::acc),false) in + let (ls,b) = loop x [] in + if b then + `list ls + else `cons ls + | Pexp_construct (x,None) -> `simple (x.txt) + | _ -> `normal + +let is_simple_construct :construct -> bool = function + | `nil | `tuple | `list _ | `simple _ -> true + | `cons _ | `normal -> false + +let pp = fprintf + +type ctxt = { + pipe : bool; + semi : bool; + ifthenelse : bool; +} + +let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } +let under_pipe ctxt = { ctxt with pipe=true } +let under_semi ctxt = { ctxt with semi=true } +let under_ifthenelse ctxt = { ctxt with ifthenelse=true } +(* +let reset_semi ctxt = { ctxt with semi=false } +let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } +let reset_pipe ctxt = { ctxt with pipe=false } +*) + +let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> + ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> + Format.formatter -> 'a list -> unit + = fun ?sep ?first ?last fu f xs -> + let first = match first with Some x -> x |None -> ("": _ format6) + and last = match last with Some x -> x |None -> ("": _ format6) + and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in + let aux f = function + | [] -> () + | [x] -> fu f x + | xs -> + let rec loop f = function + | [x] -> fu f x + | x::xs -> fu f x; pp f sep; loop f xs; + | _ -> assert false in begin + pp f first; loop f xs; pp f last; + end in + aux f xs + +let option : 'a. ?first:space_formatter -> ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit + = fun ?first ?last fu f a -> + let first = match first with Some x -> x | None -> ("": _ format6) + and last = match last with Some x -> x | None -> ("": _ format6) in + match a with + | None -> () + | Some x -> pp f first; fu f x; pp f last + +let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> + bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit + = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> + if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") + else fu f x + +let rec longident f = function + | Lident s -> protect_ident f s + | Ldot(y,s) -> protect_longident f longident y s + | Lapply (y,s) -> + pp f "%a(%a)" longident y longident s + +let longident_loc f x = pp f "%a" longident x.txt + +let constant f = function + | Pconst_char i -> + pp f "%C" i + | Pconst_string (i, _, None) -> + pp f "%S" i + | Pconst_string (i, _, Some delim) -> + pp f "{%s|%s|%s}" delim i delim + | Pconst_integer (i, None) -> + paren (first_is '-' i) (fun f -> pp f "%s") f i + | Pconst_integer (i, Some m) -> + paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m) + | Pconst_float (i, None) -> + paren (first_is '-' i) (fun f -> pp f "%s") f i + | Pconst_float (i, Some m) -> + paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m) + +(* trailing space*) +let mutable_flag f = function + | Immutable -> () + | Mutable -> pp f "mutable@;" +let virtual_flag f = function + | Concrete -> () + | Virtual -> pp f "virtual@;" + +(* trailing space added *) +let rec_flag f rf = + match rf with + | Nonrecursive -> () + | Recursive -> pp f "rec " +let nonrec_flag f rf = + match rf with + | Nonrecursive -> pp f "nonrec " + | Recursive -> () +let direction_flag f = function + | Upto -> pp f "to@ " + | Downto -> pp f "downto@ " +let private_flag f = function + | Public -> () + | Private -> pp f "private@ " + +let iter_loc f ctxt {txt; loc = _} = f ctxt txt + +let constant_string f s = pp f "%S" s + +let tyvar ppf s = + if String.length s >= 2 && s.[1] = '\'' then + (* without the space, this would be parsed as + a character literal *) + Format.fprintf ppf "' %s" s + else + Format.fprintf ppf "'%s" s + +let tyvar_loc f str = tyvar f str.txt +let string_quot f x = pp f "`%s" x + +(* c ['a,'b] *) +let rec class_params_def ctxt f = function + | [] -> () + | l -> + pp f "[%a] " (* space *) + (list (type_param ctxt) ~sep:",") l + +and type_with_label ctxt f (label, c) = + match label with + | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) + | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c + | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c + +and core_type ctxt f x = + if x.ptyp_attributes <> [] then begin + pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} + (attributes ctxt) x.ptyp_attributes + end + else match x.ptyp_desc with + | Ptyp_arrow (l, ct1, ct2) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 + | Ptyp_alias (ct, s) -> + pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s + | Ptyp_poly ([], ct) -> + core_type ctxt f ct + | Ptyp_poly (sl, ct) -> + pp f "@[<2>%a%a@]" + (fun f l -> match l with + | [] -> () + | _ -> + pp f "%a@;.@;" + (list tyvar_loc ~sep:"@;") l) + sl (core_type ctxt) ct + | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x + +and core_type1 ctxt f x = + if x.ptyp_attributes <> [] then core_type ctxt f x + else match x.ptyp_desc with + | Ptyp_any -> pp f "_"; + | Ptyp_var s -> tyvar f s; + | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Ptyp_constr (li, l) -> + pp f (* "%a%a@;" *) "%a%a" + (fun f l -> match l with + |[] -> () + |[x]-> pp f "%a@;" (core_type1 ctxt) x + | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) + l longident_loc li + | Ptyp_variant (l, closed, low) -> + let first_is_inherit = match l with + | {Parsetree.prf_desc = Rinherit _}::_ -> true + | _ -> false in + let type_variant_helper f x = + match x.prf_desc with + | Rtag (l, _, ctl) -> + pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l + (fun f l -> match l with + |[] -> () + | _ -> pp f "@;of@;%a" + (list (core_type ctxt) ~sep:"&") ctl) ctl + (attributes ctxt) x.prf_attributes + | Rinherit ct -> core_type ctxt f ct in + pp f "@[<2>[%a%a]@]" + (fun f l -> + match l, closed with + | [], Closed -> () + | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) + | _ -> + pp f "%s@;%a" + (match (closed,low) with + | (Closed,None) -> if first_is_inherit then " |" else "" + | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) + | (Open,_) -> ">") + (list type_variant_helper ~sep:"@;<1 -2>| ") l) l + (fun f low -> match low with + |Some [] |None -> () + |Some xs -> + pp f ">@ %a" + (list string_quot) xs) low + | Ptyp_object (l, o) -> + let core_field_type f x = match x.pof_desc with + | Otag (l, ct) -> + (* Cf #7200 *) + pp f "@[%s: %a@ %a@ @]" l.txt + (core_type ctxt) ct (attributes ctxt) x.pof_attributes + | Oinherit ct -> + pp f "@[%a@ @]" (core_type ctxt) ct + in + let field_var f = function + | Asttypes.Closed -> () + | Asttypes.Open -> + match l with + | [] -> pp f ".." + | _ -> pp f " ;.." + in + pp f "@[<@ %a%a@ > @]" + (list core_field_type ~sep:";") l + field_var o (* Cf #7200 *) + | Ptyp_class (li, l) -> (*FIXME*) + pp f "@[%a#%a@]" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l + longident_loc li + | Ptyp_package (lid, cstrs) -> + let aux f (s, ct) = + pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in + (match cstrs with + |[] -> pp f "@[(module@ %a)@]" longident_loc lid + |_ -> + pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid + (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_extension e -> extension ctxt f e + | _ -> paren true (core_type ctxt) f x + +(********************pattern********************) +(* be cautious when use [pattern], [pattern1] is preferred *) +and pattern ctxt f x = + if x.ppat_attributes <> [] then begin + pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} + (attributes ctxt) x.ppat_attributes + end + else match x.ppat_desc with + | Ppat_alias (p, s) -> + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt + | _ -> pattern_or ctxt f x + +and pattern_or ctxt f x = + let rec left_associative x acc = match x with + | {ppat_desc=Ppat_or (p1,p2); ppat_attributes = []} -> + left_associative p1 (p2 :: acc) + | x -> x :: acc + in + match left_associative x [] with + | [] -> assert false + | [x] -> pattern1 ctxt f x + | orpats -> + pp f "@[%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats + +and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = + let rec pattern_list_helper f = function + | {ppat_desc = + Ppat_construct + ({ txt = Lident("::") ;_}, + Some ([], {ppat_desc = Ppat_tuple([pat1; pat2]);_})); + ppat_attributes = []} + + -> + pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) + | p -> pattern1 ctxt f p + in + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_variant (l, Some p) -> + pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p + | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> + simple_pattern ctxt f x + | Ppat_construct (({txt;_} as li), po) -> + (* FIXME The third field always false *) + if txt = Lident "::" then + pp f "%a" pattern_list_helper x + else + (match po with + | Some ([], x) -> + pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | Some (vl, x) -> + pp f "%a@ (type %a)@;%a" longident_loc li + (list ~sep:"@ " string_loc) vl + (simple_pattern ctxt) x + | None -> pp f "%a" longident_loc li) + | _ -> simple_pattern ctxt f x + +and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), None) -> + pp f "%s" x + | Ppat_any -> pp f "_"; + | Ppat_var ({txt = txt;_}) -> protect_ident f txt + | Ppat_array l -> + pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l + | Ppat_unpack { txt = None } -> + pp f "(module@ _)@ " + | Ppat_unpack { txt = Some s } -> + pp f "(module@ %s)@ " s + | Ppat_type li -> + pp f "#%a" longident_loc li + | Ppat_record (l, closed) -> + let longident_x_pattern f (li, p) = + match (li,p) with + | ({txt=Lident s;_ }, + {ppat_desc=Ppat_var {txt;_}; + ppat_attributes=[]; _}) + when s = txt -> + pp f "@[<2>%a@]" longident_loc li + | _ -> + pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + in + begin match closed with + | Closed -> + pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | _ -> + pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l + end + | Ppat_tuple l -> + pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) + | Ppat_constant (c) -> pp f "%a" constant c + | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 + | Ppat_variant (l,None) -> pp f "`%s" l + | Ppat_constraint (p, ct) -> + pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct + | Ppat_lazy p -> + pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p + | Ppat_exception p -> + pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p + | Ppat_extension e -> extension ctxt f e + | Ppat_open (lid, p) -> + let with_paren = + match p.ppat_desc with + | Ppat_array _ | Ppat_record _ + | Ppat_construct (({txt=Lident ("()"|"[]");_}), None) -> false + | _ -> true in + pp f "@[<2>%a.%a @]" longident_loc lid + (paren with_paren @@ pattern1 ctxt) p + | _ -> paren true (pattern ctxt) f x + +and label_exp ctxt f (l,opt,p) = + match l with + | Nolabel -> + (* single case pattern parens needed here *) + pp f "%a@ " (simple_pattern ctxt) p + | Optional rest -> + begin match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = rest -> + (match opt with + | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o + | None -> pp f "?%s@ " rest) + | _ -> + (match opt with + | Some o -> + pp f "?%s:(%a=@;%a)@;" + rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) + end + | Labelled l -> match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = l -> + pp f "~%s@;" l + | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p + +and sugar_expr ctxt f e = + if e.pexp_attributes <> [] then false + else match e.pexp_desc with + | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; + pexp_attributes=[]; _}, args) + when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin + let print_indexop a path_prefix assign left sep right print_index indices + rem_args = + let print_path ppf = function + | None -> () + | Some m -> pp ppf ".%a" longident m in + match assign, rem_args with + | false, [] -> + pp f "@[%a%a%s%a%s@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep print_index) indices right; true + | true, [v] -> + pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep print_index) indices right + (simple_expr ctxt) v; true + | _ -> false in + match id, List.map snd args with + | Lident "!", [e] -> + pp f "@[!%a@]" (simple_expr ctxt) e; true + | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin + let assign = func = "set" in + let print = print_indexop a None assign in + match path, other_args with + | Lident "Array", i :: rest -> + print ".(" "" ")" (expression ctxt) [i] rest + | Lident "String", i :: rest -> + print ".[" "" "]" (expression ctxt) [i] rest + | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + print ".{" "," "}" (simple_expr ctxt) [i1] rest + | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + print ".{" "," "}" (simple_expr ctxt) [i1; i2] rest + | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + print ".{" "," "}" (simple_expr ctxt) [i1; i2; i3] rest + | Ldot (Lident "Bigarray", "Genarray"), + {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> + print ".{" "," "}" (simple_expr ctxt) indexes rest + | _ -> false + end + | (Lident s | Ldot(_,s)) , a :: i :: rest + when first_is '.' s -> + (* extract operator: + assignment operators end with [right_bracket ^ "<-"], + access operators end with [right_bracket] directly + *) + let multi_indices = String.contains s ';' in + let i = + match i.pexp_desc with + | Pexp_array l when multi_indices -> l + | _ -> [ i ] in + let assign = last_is '-' s in + let kind = + (* extract the right end bracket *) + let n = String.length s in + if assign then s.[n - 3] else s.[n - 1] in + let left, right = match kind with + | ')' -> '(', ")" + | ']' -> '[', "]" + | '}' -> '{', "}" + | _ -> assert false in + let path_prefix = match id with + | Ldot(m,_) -> Some m + | _ -> None in + let left = String.sub s 0 (1+String.index s left) in + print_indexop a path_prefix assign left ";" right + (if multi_indices then expression ctxt else simple_expr ctxt) + i rest + | _ -> false + end + | _ -> false + +and uncurry params e = + match e.pexp_desc with + | Pexp_fun (l, e0, p, e) -> + uncurry ((l, e0, p) :: params) e + | _ -> List.rev params, e + +and expression ctxt f x = + if x.pexp_attributes <> [] then + pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} + (attributes ctxt) x.pexp_attributes + else match x.pexp_desc with + | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + | Pexp_newtype _ + when ctxt.pipe || ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> + paren true (expression reset_ctxt) f x + | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ + | Pexp_letexception _ | Pexp_letop _ + when ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_fun (l, e0, p, e) -> + let params, body = uncurry [l, e0, p] e in + pp f "@[<2>fun@;%a->@;%a@]" + (pp_print_list (label_exp ctxt)) params + (expression ctxt) body + | Pexp_newtype (lid, e) -> + pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt + (expression ctxt) e + | Pexp_function l -> + pp f "@[function%a@]" (case_list ctxt) l + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + (expression reset_ctxt) e (case_list ctxt) l + + | Pexp_try (e, l) -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + (* "try@;@[<2>%a@]@\nwith@\n%a"*) + (expression reset_ctxt) e (case_list ctxt) l + | Pexp_let (rf, l, e) -> + (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" + (*no indentation here, a new line*) *) + (* rec_flag rf *) + pp f "@[<2>%a in@;<1 -2>%a@]" + (bindings reset_ctxt) (rf,l) + (expression ctxt) e + | Pexp_apply (e, l) -> + begin if not (sugar_expr ctxt f x) then + match view_fixity_of_exp e with + | `Infix s -> + begin match l with + | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> + (* FIXME associativity label_x_expression_param *) + pp f "@[<2>%a@;%s@;%a@]" + (label_x_expression_param reset_ctxt) arg1 s + (label_x_expression_param ctxt) arg2 + | _ -> + pp f "@[<2>%a %a@]" + (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | `Prefix s -> + let s = + if List.mem s ["~+";"~-";"~+.";"~-."] && + (match l with + (* See #7200: avoid turning (~- 1) into (- 1) which is + parsed as an int literal *) + |[(_,{pexp_desc=Pexp_constant _})] -> false + | _ -> true) + then String.sub s 1 (String.length s -1) + else s in + begin match l with + | [(Nolabel, x)] -> + pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | _ -> + pp f "@[%a@]" begin fun f (e,l) -> + pp f "%a@ %a" (expression2 ctxt) e + (list (label_x_expression_param reset_ctxt)) l + (* reset here only because [function,match,try,sequence] + are lower priority *) + end (e,l) + end + + | Pexp_construct (li, Some eo) + when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) + (match view_expr x with + | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" + | `normal -> + pp f "@[<2>%a@;%a@]" longident_loc li + (simple_expr ctxt) eo + | _ -> assert false) + | Pexp_setfield (e1, li, e2) -> + pp f "@[<2>%a.%a@ <-@ %a@]" + (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 + | Pexp_ifthenelse (e1, e2, eo) -> + (* @;@[<2>else@ %a@]@] *) + let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in + let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in + pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 + (fun f eo -> match eo with + | Some x -> + pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x + | None -> () (* pp f "()" *)) eo + | Pexp_sequence _ -> + let rec sequence_helper acc = function + | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> + sequence_helper (e1::acc) e2 + | v -> List.rev (v::acc) in + let lst = sequence_helper [] x in + pp f "@[%a@]" + (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new (li) -> + pp f "@[new@ %a@]" longident_loc li; + | Pexp_setinstvar (s, e) -> + pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e + | Pexp_override l -> (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in + pp f "@[{<%a>}@]" + (list string_x_expression ~sep:";" ) l; + | Pexp_letmodule (s, me, e) -> + pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" + (Option.value s.txt ~default:"_") + (module_expr reset_ctxt) me (expression ctxt) e + | Pexp_letexception (cd, e) -> + pp f "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) cd + (expression ctxt) e + | Pexp_assert e -> + pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy (e) -> + pp f "@[lazy@ %a@]" (simple_expr ctxt) e + (* Pexp_poly: impossible but we should print it anyway, rather than + assert false *) + | Pexp_poly (e, None) -> + pp f "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!poly!@ %a@ : %a)@]" + (simple_expr ctxt) e (core_type ctxt) ct + | Pexp_open (o, e) -> + pp f "@[<2>let open%s %a in@;%a@]" + (override o.popen_override) (module_expr ctxt) o.popen_expr + (expression ctxt) e + | Pexp_variant (l,Some eo) -> + pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo + | Pexp_letop {let_; ands; body} -> + pp f "@[<2>@[%a@,%a@] in@;<1 -2>%a@]" + (binding_op ctxt) let_ + (list ~sep:"@," (binding_op ctxt)) ands + (expression ctxt) body + | Pexp_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt -> + pp f "%a" (simple_expr ctxt) x + | Pexp_extension e -> extension ctxt f e + | Pexp_unreachable -> pp f "." + | _ -> expression1 ctxt f x + +and expression1 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs + | _ -> expression2 ctxt f x +(* used in [Pexp_apply] *) + +and expression2 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_field (e, li) -> + pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt + + | _ -> simple_expr ctxt f x + +and simple_expr ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_construct _ when is_simple_construct (view_expr x) -> + (match view_expr x with + | `nil -> pp f "[]" + | `tuple -> pp f "()" + | `list xs -> + pp f "@[[%a]@]" + (list (expression (under_semi ctxt)) ~sep:";@;") xs + | `simple x -> longident f x + | _ -> assert false) + | Pexp_ident li -> + longident_loc f li + (* (match view_fixity_of_exp x with *) + (* |`Normal -> longident_loc f li *) + (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) + | Pexp_constant c -> constant f c; + | Pexp_pack me -> + pp f "(module@;%a)" (module_expr ctxt) me + | Pexp_tuple l -> + pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l + | Pexp_constraint (e, ct) -> + pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct + | Pexp_coerce (e, cto1, ct) -> + pp f "(%a%a :> %a)" (expression ctxt) e + (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) + (core_type ctxt) ct + | Pexp_variant (l, None) -> pp f "`%s" l + | Pexp_record (l, eo) -> + let longident_x_expression f ( li, e) = + match e with + | {pexp_desc=Pexp_ident {txt;_}; + pexp_attributes=[]; _} when li.txt = txt -> + pp f "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) + (option ~last:" with@;" (simple_expr ctxt)) eo + (list longident_x_expression ~sep:";@;") l + | Pexp_array (l) -> + pp f "@[<0>@[<2>[|%a|]@]@]" + (list (simple_expr (under_semi ctxt)) ~sep:";") l + | Pexp_while (e1, e2) -> + let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in + pp f fmt (expression ctxt) e1 (expression ctxt) e2 + | Pexp_for (s, e1, e2, df, e3) -> + let fmt:(_,_,_)format = + "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in + let expression = expression ctxt in + pp f fmt (pattern ctxt) s expression e1 direction_flag + df expression e2 expression e3 + | Pexp_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt -> + pp f "_" + | _ -> paren true (expression ctxt) f x + +and attributes ctxt f l = + List.iter (attribute ctxt f) l + +and item_attributes ctxt f l = + List.iter (item_attribute ctxt f) l + +and attribute ctxt f a = + pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload + +and item_attribute ctxt f a = + pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload + +and floating_attribute ctxt f a = + pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload + +and value_description ctxt f x = + (* note: value_description has an attribute field, + but they're already printed by the callers this method *) + pp f "@[%a%a@]" (core_type ctxt) x.pval_type + (fun f x -> + if x.pval_prim <> [] + then pp f "@ =@ %a" (list constant_string) x.pval_prim + ) x + +and extension ctxt f (s, e) = + pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e + +and item_extension ctxt f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e + +and exception_declaration ctxt f x = + pp f "@[exception@ %a@]%a" + (extension_constructor ctxt) x.ptyexn_constructor + (item_attributes ctxt) x.ptyexn_attributes + +and class_type_field ctxt f x = + match x.pctf_desc with + | Pctf_inherit (ct) -> + pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_val (s, mf, vf, ct) -> + pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" + mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_method (s, pf, vf, ct) -> + pp f "@[<2>method %a %a%s :@;%a@]%a" + private_flag pf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_constraint (ct1, ct2) -> + pp f "@[<2>constraint@ %a@ =@ %a@]%a" + (core_type ctxt) ct1 (core_type ctxt) ct2 + (item_attributes ctxt) x.pctf_attributes + | Pctf_attribute a -> floating_attribute ctxt f a + | Pctf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pctf_attributes + +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = + pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" + (fun f -> function + {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () + | ct -> pp f " (%a)" (core_type ctxt) ct) ct + (list (class_type_field ctxt) ~sep:"@;") l + +(* call [class_signature] called by [class_signature] *) +and class_type ctxt f x = + match x.pcty_desc with + | Pcty_signature cs -> + class_signature ctxt f cs; + attributes ctxt f x.pcty_attributes + | Pcty_constr (li, l) -> + pp f "%a%a%a" + (fun f l -> match l with + | [] -> () + | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l + longident_loc li + (attributes ctxt) x.pcty_attributes + | Pcty_arrow (l, co, cl) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,co) + (class_type ctxt) cl + | Pcty_extension e -> + extension ctxt f e; + attributes ctxt f x.pcty_attributes + | Pcty_open (o, e) -> + pp f "@[<2>let open%s %a in@;%a@]" + (override o.popen_override) longident_loc o.popen_expr + (class_type ctxt) e + +(* [class type a = object end] *) +and class_type_declaration_list ctxt f l = + let class_type_declaration kwd f x = + let { pci_params=ls; pci_name={ txt; _ }; _ } = x in + pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in + match l with + | [] -> () + | [x] -> class_type_declaration "class type" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_type_declaration "class type") x + (list ~sep:"@," (class_type_declaration "and")) xs + +and class_field ctxt f x = + match x.pcf_desc with + | Pcf_inherit (ovf, ce, so) -> + pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf) + (class_expr ctxt) ce + (fun f so -> match so with + | None -> (); + | Some (s) -> pp f "@ as %s" s.txt ) so + (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> + pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) + mutable_flag mf s.txt + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_virtual ct) -> + pp f "@[<2>method virtual %a %s :@;%a@]%a" + private_flag pf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_virtual ct) -> + pp f "@[<2>val virtual %a%s :@ %a@]%a" + mutable_flag mf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> + let bind e = + binding ctxt f + {pvb_pat= + {ppat_desc=Ppat_var s; + ppat_loc=Location.none; + ppat_loc_stack=[]; + ppat_attributes=[]}; + pvb_expr=e; + pvb_constraint=None; + pvb_attributes=[]; + pvb_loc=Location.none; + } + in + pp f "@[<2>method%s %a%a@]%a" + (override ovf) + private_flag pf + (fun f -> function + | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> + pp f "%s :@;%a=@;%a" + s.txt (core_type ctxt) ct (expression ctxt) e + | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> + bind e + | _ -> bind e) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_constraint (ct1, ct2) -> + pp f "@[<2>constraint %a =@;%a@]%a" + (core_type ctxt) ct1 + (core_type ctxt) ct2 + (item_attributes ctxt) x.pcf_attributes + | Pcf_initializer (e) -> + pp f "@[<2>initializer@ %a@]%a" + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_attribute a -> floating_attribute ctxt f a + | Pcf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pcf_attributes + +and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = + pp f "@[@[object%a@;%a@]@;end@]" + (fun f p -> match p.ppat_desc with + | Ppat_any -> () + | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p + | _ -> pp f " (%a)" (pattern ctxt) p) p + (list (class_field ctxt)) l + +and class_expr ctxt f x = + if x.pcl_attributes <> [] then begin + pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]} + (attributes ctxt) x.pcl_attributes + end else + match x.pcl_desc with + | Pcl_structure (cs) -> class_structure ctxt f cs + | Pcl_fun (l, eo, p, e) -> + pp f "fun@ %a@ ->@ %a" + (label_exp ctxt) (l,eo,p) + (class_expr ctxt) e + | Pcl_let (rf, l, ce) -> + pp f "%a@ in@ %a" + (bindings ctxt) (rf,l) + (class_expr ctxt) ce + | Pcl_apply (ce, l) -> + pp f "((%a)@ %a)" (* Cf: #7200 *) + (class_expr ctxt) ce + (list (label_x_expression_param ctxt)) l + | Pcl_constr (li, l) -> + pp f "%a%a" + (fun f l-> if l <>[] then + pp f "[%a]@ " + (list (core_type ctxt) ~sep:",") l) l + longident_loc li + | Pcl_constraint (ce, ct) -> + pp f "(%a@ :@ %a)" + (class_expr ctxt) ce + (class_type ctxt) ct + | Pcl_extension e -> extension ctxt f e + | Pcl_open (o, e) -> + pp f "@[<2>let open%s %a in@;%a@]" + (override o.popen_override) longident_loc o.popen_expr + (class_expr ctxt) e + +and module_type ctxt f x = + if x.pmty_attributes <> [] then begin + pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} + (attributes ctxt) x.pmty_attributes + end else + match x.pmty_desc with + | Pmty_functor (Unit, mt2) -> + pp f "@[() ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (Named (s, mt1), mt2) -> + begin match s.txt with + | None -> + pp f "@[%a@ ->@ %a@]" + (module_type1 ctxt) mt1 (module_type ctxt) mt2 + | Some name -> + pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" name + (module_type ctxt) mt1 (module_type ctxt) mt2 + end + | Pmty_with (mt, []) -> module_type ctxt f mt + | Pmty_with (mt, l) -> + pp f "@[%a@ with@ %a@]" + (module_type1 ctxt) mt + (list (with_constraint ctxt) ~sep:"@ and@ ") l + | _ -> module_type1 ctxt f x + +and with_constraint ctxt f = function + | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> + pp f "type@ %a %a =@ %a" + (type_params ctxt) ls + longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2; + | Pwith_modtype (li, mty) -> + pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty; + | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> + pp f "type@ %a %a :=@ %a" + (type_params ctxt) ls + longident_loc li + (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 + | Pwith_modtypesubst (li, mty) -> + pp f "module type %a :=@ %a" longident_loc li (module_type ctxt) mty; + + +and module_type1 ctxt f x = + if x.pmty_attributes <> [] then module_type ctxt f x + else match x.pmty_desc with + | Pmty_ident li -> + pp f "%a" longident_loc li; + | Pmty_alias li -> + pp f "(module %a)" longident_loc li; + | Pmty_signature (s) -> + pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) s (* FIXME wrong indentation*) + | Pmty_typeof me -> + pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me + | Pmty_extension e -> extension ctxt f e + | _ -> paren true (module_type ctxt) f x + +and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x + +and signature_item ctxt f x : unit = + match x.psig_desc with + | Psig_type (rf, l) -> + type_def_list ctxt f (rf, true, l) + | Psig_typesubst l -> + (* Psig_typesubst is never recursive, but we specify [Recursive] here to + avoid printing a [nonrec] flag, which would be rejected by the parser. + *) + type_def_list ctxt f (Recursive, false, l) + | Psig_value vd -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Psig_typext te -> + type_extension ctxt f te + | Psig_exception ed -> + exception_declaration ctxt f ed + | Psig_class l -> + let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = + pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in begin + match l with + | [] -> () + | [x] -> class_description "class" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_description "class") x + (list ~sep:"@," (class_description "and")) xs + end + | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; + pmty_attributes=[]; _};_} as pmd) -> + pp f "@[module@ %s@ =@ %a@]%a" + (Option.value pmd.pmd_name.txt ~default:"_") + longident_loc alias + (item_attributes ctxt) pmd.pmd_attributes + | Psig_module pmd -> + pp f "@[module@ %s@ :@ %a@]%a" + (Option.value pmd.pmd_name.txt ~default:"_") + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + | Psig_modsubst pms -> + pp f "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt + longident_loc pms.pms_manifest + (item_attributes ctxt) pms.pms_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_expr + (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[include@ %a@]%a" + (module_type ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Psig_modtypesubst {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + let md = match md with + | None -> assert false (* ast invariant *) + | Some mt -> mt in + pp f "@[module@ type@ %s@ :=@ %a@]%a" + s.txt (module_type ctxt) md + (item_attributes ctxt) attrs + | Psig_class_type (l) -> class_type_declaration_list ctxt f l + | Psig_recmodule decls -> + let rec string_x_module_type_list f ?(first=true) l = + match l with + | [] -> () ; + | pmd :: tl -> + if not first then + pp f "@ @[and@ %s:@ %a@]%a" + (Option.value pmd.pmd_name.txt ~default:"_") + (module_type1 ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + else + pp f "@[module@ rec@ %s:@ %a@]%a" + (Option.value pmd.pmd_name.txt ~default:"_") + (module_type1 ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> floating_attribute ctxt f a + | Psig_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and module_expr ctxt f x = + if x.pmod_attributes <> [] then + pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} + (attributes ctxt) x.pmod_attributes + else match x.pmod_desc with + | Pmod_structure (s) -> + pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") s; + | Pmod_constraint (me, mt) -> + pp f "@[(%a@ :@ %a)@]" + (module_expr ctxt) me + (module_type ctxt) mt + | Pmod_ident (li) -> + pp f "%a" longident_loc li; + | Pmod_functor (Unit, me) -> + pp f "functor ()@;->@;%a" (module_expr ctxt) me + | Pmod_functor (Named (s, mt), me) -> + pp f "functor@ (%s@ :@ %a)@;->@;%a" + (Option.value s.txt ~default:"_") + (module_type ctxt) mt (module_expr ctxt) me + | Pmod_apply (me1, me2) -> + pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 + (* Cf: #7200 *) + | Pmod_apply_unit me1 -> + pp f "(%a)()" (module_expr ctxt) me1 + | Pmod_unpack e -> + pp f "(val@ %a)" (expression ctxt) e + | Pmod_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt -> + pp f "_" + | Pmod_extension e -> extension ctxt f e + +and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x + +and payload ctxt f = function + | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> + pp f "@[<2>%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | PStr x -> structure ctxt f x + | PTyp x -> pp f ":@ "; core_type ctxt f x + | PSig x -> pp f ":@ "; signature ctxt f x + | PPat (x, None) -> pp f "?"; pattern ctxt f x + | PPat (x, Some e) -> + pp f "?@ "; pattern ctxt f x; + pp f " when "; expression ctxt f e + +(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) +and binding ctxt f {pvb_pat=p; pvb_expr=x; pvb_constraint = ct; _} = + (* .pvb_attributes have already been printed by the caller, #bindings *) + let rec pp_print_pexp_function f x = + if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x + else match x.pexp_desc with + | Pexp_fun (label, eo, p, e) -> + if label=Nolabel then + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e + else + pp f "%a@ %a" + (label_exp ctxt) (label,eo,p) pp_print_pexp_function e + | Pexp_newtype (str,e) -> + pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e + | _ -> pp f "=@;%a" (expression ctxt) x + in + match ct with + | Some (Pvc_constraint { locally_abstract_univars = []; typ }) -> + pp f "%a@;:@;%a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) typ (expression ctxt) x + | Some (Pvc_constraint { locally_abstract_univars = vars; typ }) -> + pp f "%a@;: type@;%a.@;%a@;=@;%a" + (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") + (List.map (fun x -> x.txt) vars) + (core_type ctxt) typ (expression ctxt) x + | Some (Pvc_coercion {ground=None; coercion }) -> + pp f "%a@;:>@;%a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) coercion (expression ctxt) x + | Some (Pvc_coercion {ground=Some ground; coercion }) -> + pp f "%a@;:%a@;:>@;%a@;=@;%a" + (simple_pattern ctxt) p + (core_type ctxt) ground + (core_type ctxt) coercion + (expression ctxt) x + | None -> begin + match p with + | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x + | _ -> + pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x + end + +(* [in] is not printed *) +and bindings ctxt f (rf,l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf + (binding ctxt) x (item_attributes ctxt) x.pvb_attributes + in + match l with + | [] -> () + | [x] -> binding "let" rf f x + | x::xs -> + pp f "@[%a@,%a@]" + (binding "let" rf) x + (list ~sep:"@," (binding "and" Nonrecursive)) xs + +and binding_op ctxt f x = + match x.pbop_pat, x.pbop_exp with + | {ppat_desc = Ppat_var { txt=pvar; _ }; ppat_attributes = []; _}, + {pexp_desc = Pexp_ident { txt=Lident evar; _}; pexp_attributes = []; _} + when pvar = evar -> + pp f "@[<2>%s %s@]" x.pbop_op.txt evar + | pat, exp -> + pp f "@[<2>%s %a@;=@;%a@]" + x.pbop_op.txt (pattern ctxt) pat (expression ctxt) exp + +and structure_item ctxt f x = + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + pp f "@[;;%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | Pstr_type (_, []) -> assert false + | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l) + | Pstr_value (rf, l) -> + (* pp f "@[let %a%a@]" rec_flag rf bindings l *) + pp f "@[<2>%a@]" (bindings ctxt) (rf,l) + | Pstr_typext te -> type_extension ctxt f te + | Pstr_exception ed -> exception_declaration ctxt f ed + | Pstr_module x -> + let rec module_helper = function + | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} -> + begin match arg_opt with + | Unit -> pp f "()" + | Named (s, mt) -> + pp f "(%s:%a)" (Option.value s.txt ~default:"_") + (module_type ctxt) mt + end; + module_helper me' + | me -> me + in + pp f "@[module %s%a@]%a" + (Option.value x.pmb_name.txt ~default:"_") + (fun f me -> + let me = module_helper me in + match me with + | {pmod_desc= + Pmod_constraint + (me', + ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_));_} as mt)); + pmod_attributes = []} -> + pp f " :@;%a@;=@;%a@;" + (module_type ctxt) mt (module_expr ctxt) me' + | _ -> pp f " =@ %a" (module_expr ctxt) me + ) x.pmb_expr + (item_attributes ctxt) x.pmb_attributes + | Pstr_open od -> + pp f "@[<2>open%s@;%a@]%a" + (override od.popen_override) + (module_expr ctxt) od.popen_expr + (item_attributes ctxt) od.popen_attributes + | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Pstr_class l -> + let extract_class_args cl = + let rec loop acc = function + | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} -> + loop ((l,eo,p) :: acc) cl' + | cl -> List.rev acc, cl + in + let args, cl = loop [] cl in + let constr, cl = + match cl with + | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} -> + Some ct, cl' + | _ -> None, cl + in + args, constr, cl + in + let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in + let class_declaration kwd f + ({pci_params=ls; pci_name={txt;_}; _} as x) = + let args, constr, cl = extract_class_args x.pci_expr in + pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (list (label_exp ctxt)) args + (option class_constraint) constr + (class_expr ctxt) cl + (item_attributes ctxt) x.pci_attributes + in begin + match l with + | [] -> () + | [x] -> class_declaration "class" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_declaration "class") x + (list ~sep:"@," (class_declaration "and")) xs + end + | Pstr_class_type l -> class_type_declaration_list ctxt f l + | Pstr_primitive vd -> + pp f "@[external@ %a@ :@ %a@]%a" + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Pstr_include incl -> + pp f "@[include@ %a@]%a" + (module_expr ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Pstr_recmodule decls -> (* 3.07 *) + let aux f = function + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> + pp f "@[@ and@ %s:%a@ =@ %a@]%a" + (Option.value pmb.pmb_name.txt ~default:"_") + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + | pmb -> + pp f "@[@ and@ %s@ =@ %a@]%a" + (Option.value pmb.pmb_name.txt ~default:"_") + (module_expr ctxt) pmb.pmb_expr + (item_attributes ctxt) pmb.pmb_attributes + in + begin match decls with + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> + pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" + (Option.value pmb.pmb_name.txt ~default:"_") + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) l2 + | pmb :: l2 -> + pp f "@[@[module@ rec@ %s@ =@ %a@]%a@ %a@]" + (Option.value pmb.pmb_name.txt ~default:"_") + (module_expr ctxt) pmb.pmb_expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) l2 + | _ -> assert false + end + | Pstr_attribute a -> floating_attribute ctxt f a + | Pstr_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and type_param ctxt f (ct, (a,b)) = + pp f "%s%s%a" (type_variance a) (type_injectivity b) (core_type ctxt) ct + +and type_params ctxt f = function + | [] -> () + | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l + +and type_def_list ctxt f (rf, exported, l) = + let type_decl kwd rf f x = + let eq = + if (x.ptype_kind = Ptype_abstract) + && (x.ptype_manifest = None) then "" + else if exported then " =" + else " :=" + in + pp f "@[<2>%s %a%a%s%s%a@]%a" kwd + nonrec_flag rf + (type_params ctxt) x.ptype_params + x.ptype_name.txt eq + (type_declaration ctxt) x + (item_attributes ctxt) x.ptype_attributes + in + match l with + | [] -> assert false + | [x] -> type_decl "type" rf f x + | x :: xs -> pp f "@[%a@,%a@]" + (type_decl "type" rf) x + (list ~sep:"@," (type_decl "and" Recursive)) xs + +and record_declaration ctxt f lbls = + let type_record_field f pld = + pp f "@[<2>%a%s:@;%a@;%a@]" + mutable_flag pld.pld_mutable + pld.pld_name.txt + (core_type ctxt) pld.pld_type + (attributes ctxt) pld.pld_attributes + in + pp f "{@\n%a}" + (list type_record_field ~sep:";@\n" ) lbls + +and type_declaration ctxt f x = + (* type_declaration has an attribute field, + but it's been printed by the caller of this method *) + let priv f = + match x.ptype_private with + | Public -> () + | Private -> pp f "@;private" + in + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> + if x.ptype_kind = Ptype_abstract then + pp f "%t@;%a" priv (core_type ctxt) y + else + pp f "@;%a" (core_type ctxt) y + in + let constructor_declaration f pcd = + pp f "|@;"; + constructor_declaration ctxt f + (pcd.pcd_name.txt, pcd.pcd_vars, + pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + in + let repr f = + let intro f = + if x.ptype_manifest = None then () + else pp f "@;=" + in + match x.ptype_kind with + | Ptype_variant xs -> + let variants fmt xs = + if xs = [] then pp fmt " |" else + pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs + in pp f "%t%t%a" intro priv variants xs + | Ptype_abstract -> () + | Ptype_record l -> + pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + | Ptype_open -> pp f "%t%t@;.." intro priv + in + let constraints f = + List.iter + (fun (ct1,ct2,_) -> + pp f "@[@ constraint@ %a@ =@ %a@]" + (core_type ctxt) ct1 (core_type ctxt) ct2) + x.ptype_cstrs + in + pp f "%t%t%t" manifest repr constraints + +and type_extension ctxt f x = + let extension_constructor f x = + pp f "@\n|@;%a" (extension_constructor ctxt) x + in + pp f "@[<2>type %a%a += %a@ %a@]%a" + (fun f -> function + | [] -> () + | l -> + pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) + x.ptyext_params + longident_loc x.ptyext_path + private_flag x.ptyext_private (* Cf: #7200 *) + (list ~sep:"" extension_constructor) + x.ptyext_constructors + (item_attributes ctxt) x.ptyext_attributes + +and constructor_declaration ctxt f (name, vars, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s in + let pp_vars f vs = + match vs with + | [] -> () + | vs -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") vs in + match res with + | None -> + pp f "%s%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> + pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l + ) args + (attributes ctxt) attrs + | Some r -> + pp f "%s:@;%a%a@;%a" name + pp_vars vars + (fun f -> function + | Pcstr_tuple [] -> core_type1 ctxt f r + | Pcstr_tuple l -> pp f "%a@;->@;%a" + (list (core_type1 ctxt) ~sep:"@;*@;") l + (core_type1 ctxt) r + | Pcstr_record l -> + pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r + ) + args + (attributes ctxt) attrs + +and extension_constructor ctxt f x = + (* Cf: #7200 *) + match x.pext_kind with + | Pext_decl(v, l, r) -> + constructor_declaration ctxt f + (x.pext_name.txt, v, l, r, x.pext_attributes) + | Pext_rebind li -> + pp f "%s@;=@;%a%a" x.pext_name.txt + longident_loc li + (attributes ctxt) x.pext_attributes + +and case_list ctxt f l : unit = + let aux f {pc_lhs; pc_guard; pc_rhs} = + pp f "@;| @[<2>%a%a@;->@;%a@]" + (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") + pc_guard (expression (under_pipe ctxt)) pc_rhs + in + list aux f l ~sep:"" + +and label_x_expression_param ctxt f (l,e) = + let simple_name = match e with + | {pexp_desc=Pexp_ident {txt=Lident l;_}; + pexp_attributes=[]} -> Some l + | _ -> None + in match l with + | Nolabel -> expression2 ctxt f e (* level 2*) + | Optional str -> + if Some str = simple_name then + pp f "?%s" str + else + pp f "?%s:%a" str (simple_expr ctxt) e + | Labelled lbl -> + if Some lbl = simple_name then + pp f "~%s" lbl + else + pp f "~%s:%a" lbl (simple_expr ctxt) e + +and directive_argument f x = + match x.pdira_desc with + | Pdir_string (s) -> pp f "@ %S" s + | Pdir_int (n, None) -> pp f "@ %s" n + | Pdir_int (n, Some m) -> pp f "@ %s%c" n m + | Pdir_ident (li) -> pp f "@ %a" longident li + | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) + +let toplevel_phrase f x = + match x with + | Ptop_def (s) ->pp f "@[%a@]" (list (structure_item reset_ctxt)) s + (* pp_open_hvbox f 0; *) + (* pp_print_list structure_item f s ; *) + (* pp_close_box f (); *) + | Ptop_dir {pdir_name; pdir_arg = None; _} -> + pp f "@[#%s@]" pdir_name.txt + | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} -> + pp f "@[#%s@ %a@]" pdir_name.txt directive_argument pdir_arg + +let expression f x = + pp f "@[%a@]" (expression reset_ctxt) x + +let string_of_expression x = + ignore (flush_str_formatter ()) ; + let f = str_formatter in + expression f x; + flush_str_formatter () + +let string_of_structure x = + ignore (flush_str_formatter ()); + let f = str_formatter in + structure reset_ctxt f x; + flush_str_formatter () + +let top_phrase f x = + pp_print_newline f (); + toplevel_phrase f x; + pp f ";;"; + pp_print_newline f () + +let core_type = core_type reset_ctxt +let pattern = pattern reset_ctxt +let signature = signature reset_ctxt +let structure = structure reset_ctxt +let module_expr = module_expr reset_ctxt +let module_type = module_type reset_ctxt +let class_field = class_field reset_ctxt +let class_type_field = class_type_field reset_ctxt +let class_expr = class_expr reset_ctxt +let class_type = class_type reset_ctxt +let structure_item = structure_item reset_ctxt +let signature_item = signature_item reset_ctxt +let binding = binding reset_ctxt +let payload = payload reset_ctxt +let case_list = case_list reset_ctxt + +let prepare_error err = + let source = Location.Parser in + let open Syntaxerr in + match err with + | Unclosed(opening_loc, opening, closing_loc, closing) -> + Location.errorf + ~source + ~loc:closing_loc + ~sub:[ + Location.msg ~loc:opening_loc + "This '%s' might be unmatched" opening + ] + "Syntax error: '%s' expected" closing + + | Expecting (loc, nonterm) -> + Location.errorf ~source ~loc "Syntax error: %s expected." nonterm + | Not_expecting (loc, nonterm) -> + Location.errorf ~source ~loc "Syntax error: %s not expected." nonterm + | Applicative_path loc -> + Location.errorf ~source ~loc + "Syntax error: applicative paths of the form F(X).t \ + are not supported when the option -no-app-func is set." + | Variable_in_scope (loc, var) -> + Location.errorf ~source ~loc + "In this scoped type, variable %a \ + is reserved for the local type %s." + tyvar var var + | Other loc -> + Location.errorf ~source ~loc "Syntax error" + | Ill_formed_ast (loc, s) -> + Location.errorf ~loc + "broken invariant in parsetree: %s" s + | Invalid_package_type (loc, s) -> + Location.errorf ~source ~loc "invalid package type: %s" s + | Removed_string_set loc -> + Location.errorf ~loc + "Syntax error: strings are immutable, there is no assignment \ + syntax for them.\n\ + Hint: Mutable sequences of bytes are available in the Bytes module.\n\ + Hint: Did you mean to use 'Bytes.set'?" + +let () = + Location.register_error_of_exn + (function + | Syntaxerr.Error err -> Some (prepare_error err) + | _ -> None + ) diff --git a/ocamlmerlin_mlx/ocaml/parsing/pprintast.mli b/ocamlmerlin_mlx/ocaml/parsing/pprintast.mli new file mode 100644 index 0000000..4ceb5bb --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/pprintast.mli @@ -0,0 +1,59 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Hongbo Zhang (University of Pennsylvania) *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +(** Pretty-printers for {!Parsetree} + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type space_formatter = (unit, Format.formatter, unit) format + +val longident : Format.formatter -> Longident.t -> unit +val expression : Format.formatter -> Parsetree.expression -> unit +val string_of_expression : Parsetree.expression -> string + +val pattern: Format.formatter -> Parsetree.pattern -> unit + +val core_type: Format.formatter -> Parsetree.core_type -> unit + +val signature: Format.formatter -> Parsetree.signature -> unit +val structure: Format.formatter -> Parsetree.structure -> unit +val string_of_structure: Parsetree.structure -> string + +val module_expr: Format.formatter -> Parsetree.module_expr -> unit + +val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit +val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit + +val class_field: Format.formatter -> Parsetree.class_field -> unit +val class_type_field: Format.formatter -> Parsetree.class_type_field -> unit +val class_expr: Format.formatter -> Parsetree.class_expr -> unit +val class_type: Format.formatter -> Parsetree.class_type -> unit +val module_type: Format.formatter -> Parsetree.module_type -> unit +val structure_item: Format.formatter -> Parsetree.structure_item -> unit +val signature_item: Format.formatter -> Parsetree.signature_item -> unit +val binding: Format.formatter -> Parsetree.value_binding -> unit +val payload: Format.formatter -> Parsetree.payload -> unit + +val tyvar: Format.formatter -> string -> unit + (** Print a type variable name, taking care of the special treatment + required for the single quote character in second position. *) + +(* merlin *) +val case_list : Format.formatter -> Parsetree.case list -> unit +val protect_ident : Format.formatter -> string -> unit diff --git a/ocamlmerlin_mlx/ocaml/parsing/printast.ml b/ocamlmerlin_mlx/ocaml/parsing/printast.ml new file mode 100644 index 0000000..4b5612e --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/printast.ml @@ -0,0 +1,985 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Format +open Lexing +open Location +open Parsetree + +let fmt_position with_name f l = + let fname = if with_name then l.pos_fname else "" in + if l.pos_lnum = -1 + then fprintf f "%s[%d]" fname l.pos_cnum + else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) + + +let fmt_location f loc = + if not !Clflags.locations then () + else begin + let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in + fprintf f "(%a..%a)" (fmt_position true) loc.loc_start + (fmt_position p_2nd_name) loc.loc_end; + if loc.loc_ghost then fprintf f " ghost"; + end + + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident (s) -> fprintf f "%s" s + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z + +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x + +let fmt_longident_loc f (x : Longident.t loc) = + fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc + +let fmt_string_loc f (x : string loc) = + fprintf f "\"%s\" %a" x.txt fmt_location x.loc + +let fmt_str_opt_loc f (x : string option loc) = + fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc + +let fmt_char_option f = function + | None -> fprintf f "None" + | Some c -> fprintf f "Some %c" c + +let fmt_constant f x = + match x with + | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; + | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c) + | Pconst_string (s, strloc, None) -> + fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc + | Pconst_string (s, strloc, Some delim) -> + fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim + | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable" + | Mutable -> fprintf f "Mutable" + +let fmt_virtual_flag f x = + match x with + | Virtual -> fprintf f "Virtual" + | Concrete -> fprintf f "Concrete" + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override" + | Fresh -> fprintf f "Fresh" + +let fmt_closed_flag f x = + match x with + | Closed -> fprintf f "Closed" + | Open -> fprintf f "Open" + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec" + | Recursive -> fprintf f "Rec" + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up" + | Downto -> fprintf f "Down" + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public" + | Private -> fprintf f "Private" + +let line i f s (*...*) = + fprintf f "%s" (String.make ((2*i) mod 72) ' '); + fprintf f s (*...*) + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n" + | _ :: _ -> + line i ppf "[\n"; + List.iter (f (i+1) ppf) l; + line i ppf "]\n" + +let option i f ppf x = + match x with + | None -> line i ppf "None\n" + | Some x -> + line i ppf "Some\n"; + f (i+1) ppf x + +let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li +let string i ppf s = line i ppf "\"%s\"\n" s +let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s +let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s +let arg_label i ppf = function + | Nolabel -> line i ppf "Nolabel\n" + | Optional s -> line i ppf "Optional \"%s\"\n" s + | Labelled s -> line i ppf "Labelled \"%s\"\n" s + + +let typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ptyp_loc; + attributes i ppf x.ptyp_attributes; + let i = i+1 in + match x.ptyp_desc with + | Ptyp_any -> line i ppf "Ptyp_any\n"; + | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; + | Ptyp_arrow (l, ct1, ct2) -> + line i ppf "Ptyp_arrow\n"; + arg_label i ppf l; + core_type i ppf ct1; + core_type i ppf ct2; + | Ptyp_tuple l -> + line i ppf "Ptyp_tuple\n"; + list i core_type ppf l; + | Ptyp_constr (li, l) -> + line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Ptyp_variant (l, closed, low) -> + line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ptyp_object (l, c) -> + line i ppf "Ptyp_object %a\n" fmt_closed_flag c; + let i = i + 1 in + List.iter (fun field -> + match field.pof_desc with + | Otag (l, t) -> + line i ppf "method %s\n" l.txt; + attributes i ppf field.pof_attributes; + core_type (i + 1) ppf t + | Oinherit ct -> + line i ppf "Oinherit\n"; + core_type (i + 1) ppf ct + ) l + | Ptyp_class (li, l) -> + line i ppf "Ptyp_class %a\n" fmt_longident_loc li; + list i core_type ppf l + | Ptyp_alias (ct, s) -> + line i ppf "Ptyp_alias \"%s\"\n" s; + core_type i ppf ct; + | Ptyp_poly (sl, ct) -> + line i ppf "Ptyp_poly%a\n" typevars sl; + core_type i ppf ct; + | Ptyp_package (s, l) -> + line i ppf "Ptyp_package %a\n" fmt_longident_loc s; + list i package_with ppf l; + | Ptyp_extension (s, arg) -> + line i ppf "Ptyp_extension \"%s\"\n" s.txt; + payload i ppf arg + +and package_with i ppf (s, t) = + line i ppf "with type %a\n" fmt_longident_loc s; + core_type i ppf t + +and pattern i ppf x = + line i ppf "pattern %a\n" fmt_location x.ppat_loc; + attributes i ppf x.ppat_attributes; + let i = i+1 in + match x.ppat_desc with + | Ppat_any -> line i ppf "Ppat_any\n"; + | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s; + | Ppat_alias (p, s) -> + line i ppf "Ppat_alias %a\n" fmt_string_loc s; + pattern i ppf p; + | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; + | Ppat_interval (c1, c2) -> + line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; + | Ppat_tuple (l) -> + line i ppf "Ppat_tuple\n"; + list i pattern ppf l; + | Ppat_construct (li, po) -> + line i ppf "Ppat_construct %a\n" fmt_longident_loc li; + option i + (fun i ppf (vl, p) -> + list i string_loc ppf vl; + pattern i ppf p) + ppf po + | Ppat_variant (l, po) -> + line i ppf "Ppat_variant \"%s\"\n" l; + option i pattern ppf po; + | Ppat_record (l, c) -> + line i ppf "Ppat_record %a\n" fmt_closed_flag c; + list i longident_x_pattern ppf l; + | Ppat_array (l) -> + line i ppf "Ppat_array\n"; + list i pattern ppf l; + | Ppat_or (p1, p2) -> + line i ppf "Ppat_or\n"; + pattern i ppf p1; + pattern i ppf p2; + | Ppat_lazy p -> + line i ppf "Ppat_lazy\n"; + pattern i ppf p; + | Ppat_constraint (p, ct) -> + line i ppf "Ppat_constraint\n"; + pattern i ppf p; + core_type i ppf ct; + | Ppat_type (li) -> + line i ppf "Ppat_type\n"; + longident_loc i ppf li + | Ppat_unpack s -> + line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s; + | Ppat_exception p -> + line i ppf "Ppat_exception\n"; + pattern i ppf p + | Ppat_open (m,p) -> + line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; + pattern i ppf p + | Ppat_extension (s, arg) -> + line i ppf "Ppat_extension \"%s\"\n" s.txt; + payload i ppf arg + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.pexp_loc; + attributes i ppf x.pexp_attributes; + let i = i+1 in + match x.pexp_desc with + | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; + | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; + | Pexp_let (rf, l, e) -> + line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + expression i ppf e; + | Pexp_function l -> + line i ppf "Pexp_function\n"; + list i case ppf l; + | Pexp_fun (l, eo, p, e) -> + line i ppf "Pexp_fun\n"; + arg_label i ppf l; + option i expression ppf eo; + pattern i ppf p; + expression i ppf e; + | Pexp_apply (e, l) -> + line i ppf "Pexp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; + | Pexp_match (e, l) -> + line i ppf "Pexp_match\n"; + expression i ppf e; + list i case ppf l; + | Pexp_try (e, l) -> + line i ppf "Pexp_try\n"; + expression i ppf e; + list i case ppf l; + | Pexp_tuple (l) -> + line i ppf "Pexp_tuple\n"; + list i expression ppf l; + | Pexp_construct (li, eo) -> + line i ppf "Pexp_construct %a\n" fmt_longident_loc li; + option i expression ppf eo; + | Pexp_variant (l, eo) -> + line i ppf "Pexp_variant \"%s\"\n" l; + option i expression ppf eo; + | Pexp_record (l, eo) -> + line i ppf "Pexp_record\n"; + list i longident_x_expression ppf l; + option i expression ppf eo; + | Pexp_field (e, li) -> + line i ppf "Pexp_field\n"; + expression i ppf e; + longident_loc i ppf li; + | Pexp_setfield (e1, li, e2) -> + line i ppf "Pexp_setfield\n"; + expression i ppf e1; + longident_loc i ppf li; + expression i ppf e2; + | Pexp_array (l) -> + line i ppf "Pexp_array\n"; + list i expression ppf l; + | Pexp_ifthenelse (e1, e2, eo) -> + line i ppf "Pexp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo; + | Pexp_sequence (e1, e2) -> + line i ppf "Pexp_sequence\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_while (e1, e2) -> + line i ppf "Pexp_while\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_for (p, e1, e2, df, e3) -> + line i ppf "Pexp_for %a\n" fmt_direction_flag df; + pattern i ppf p; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3; + | Pexp_constraint (e, ct) -> + line i ppf "Pexp_constraint\n"; + expression i ppf e; + core_type i ppf ct; + | Pexp_coerce (e, cto1, cto2) -> + line i ppf "Pexp_coerce\n"; + expression i ppf e; + option i core_type ppf cto1; + core_type i ppf cto2; + | Pexp_send (e, s) -> + line i ppf "Pexp_send \"%s\"\n" s.txt; + expression i ppf e; + | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; + | Pexp_setinstvar (s, e) -> + line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; + expression i ppf e; + | Pexp_override (l) -> + line i ppf "Pexp_override\n"; + list i string_x_expression ppf l; + | Pexp_letmodule (s, me, e) -> + line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s; + module_expr i ppf me; + expression i ppf e; + | Pexp_letexception (cd, e) -> + line i ppf "Pexp_letexception\n"; + extension_constructor i ppf cd; + expression i ppf e; + | Pexp_assert (e) -> + line i ppf "Pexp_assert\n"; + expression i ppf e; + | Pexp_lazy (e) -> + line i ppf "Pexp_lazy\n"; + expression i ppf e; + | Pexp_poly (e, cto) -> + line i ppf "Pexp_poly\n"; + expression i ppf e; + option i core_type ppf cto; + | Pexp_object s -> + line i ppf "Pexp_object\n"; + class_structure i ppf s + | Pexp_newtype (s, e) -> + line i ppf "Pexp_newtype \"%s\"\n" s.txt; + expression i ppf e + | Pexp_pack me -> + line i ppf "Pexp_pack\n"; + module_expr i ppf me + | Pexp_open (o, e) -> + line i ppf "Pexp_open %a\n" fmt_override_flag o.popen_override; + module_expr i ppf o.popen_expr; + expression i ppf e + | Pexp_letop {let_; ands; body} -> + line i ppf "Pexp_letop\n"; + binding_op i ppf let_; + list i binding_op ppf ands; + expression i ppf body + | Pexp_extension (s, arg) -> + line i ppf "Pexp_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pexp_unreachable -> + line i ppf "Pexp_unreachable" + +and value_description i ppf x = + line i ppf "value_description %a %a\n" fmt_string_loc + x.pval_name fmt_location x.pval_loc; + attributes i ppf x.pval_attributes; + core_type (i+1) ppf x.pval_type; + list (i+1) string ppf x.pval_prim + +and type_parameter i ppf (x, _variance) = core_type i ppf x + +and type_declaration i ppf x = + line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name + fmt_location x.ptype_loc; + attributes i ppf x.ptype_attributes; + let i = i+1 in + line i ppf "ptype_params =\n"; + list (i+1) type_parameter ppf x.ptype_params; + line i ppf "ptype_cstrs =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i+1) ppf x.ptype_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; + line i ppf "ptype_manifest =\n"; + option (i+1) core_type ppf x.ptype_manifest + +and attribute i ppf k a = + line i ppf "%s \"%s\"\n" k a.attr_name.txt; + payload i ppf a.attr_payload; + +and attributes i ppf l = + let i = i + 1 in + List.iter (fun a -> + line i ppf "attribute \"%s\"\n" a.attr_name.txt; + payload (i + 1) ppf a.attr_payload; + ) l; + +and payload i ppf = function + | PStr x -> structure i ppf x + | PSig x -> signature i ppf x + | PTyp x -> core_type i ppf x + | PPat (x, None) -> pattern i ppf x + | PPat (x, Some g) -> + pattern i ppf x; + line i ppf "\n"; + expression (i + 1) ppf g + + +and type_kind i ppf x = + match x with + | Ptype_abstract -> + line i ppf "Ptype_abstract\n" + | Ptype_variant l -> + line i ppf "Ptype_variant\n"; + list (i+1) constructor_decl ppf l; + | Ptype_record l -> + line i ppf "Ptype_record\n"; + list (i+1) label_decl ppf l; + | Ptype_open -> + line i ppf "Ptype_open\n"; + +and type_extension i ppf x = + line i ppf "type_extension\n"; + attributes i ppf x.ptyext_attributes; + let i = i+1 in + line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path; + line i ppf "ptyext_params =\n"; + list (i+1) type_parameter ppf x.ptyext_params; + line i ppf "ptyext_constructors =\n"; + list (i+1) extension_constructor ppf x.ptyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private; + +and type_exception i ppf x = + line i ppf "type_exception\n"; + attributes i ppf x.ptyexn_attributes; + let i = i+1 in + line i ppf "ptyext_constructor =\n"; + let i = i+1 in + extension_constructor i ppf x.ptyexn_constructor + +and extension_constructor i ppf x = + line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; + attributes i ppf x.pext_attributes; + let i = i + 1 in + line i ppf "pext_name = \"%s\"\n" x.pext_name.txt; + line i ppf "pext_kind =\n"; + extension_constructor_kind (i + 1) ppf x.pext_kind; + +and extension_constructor_kind i ppf x = + match x with + Pext_decl(v, a, r) -> + line i ppf "Pext_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; + constructor_arguments (i+1) ppf a; + option (i+1) core_type ppf r; + | Pext_rebind li -> + line i ppf "Pext_rebind\n"; + line (i+1) ppf "%a\n" fmt_longident_loc li; + +and class_type i ppf x = + line i ppf "class_type %a\n" fmt_location x.pcty_loc; + attributes i ppf x.pcty_attributes; + let i = i+1 in + match x.pcty_desc with + | Pcty_constr (li, l) -> + line i ppf "Pcty_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Pcty_signature (cs) -> + line i ppf "Pcty_signature\n"; + class_signature i ppf cs; + | Pcty_arrow (l, co, cl) -> + line i ppf "Pcty_arrow\n"; + arg_label i ppf l; + core_type i ppf co; + class_type i ppf cl; + | Pcty_extension (s, arg) -> + line i ppf "Pcty_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pcty_open (o, e) -> + line i ppf "Pcty_open %a %a\n" fmt_override_flag o.popen_override + fmt_longident_loc o.popen_expr; + class_type i ppf e + +and class_signature i ppf cs = + line i ppf "class_signature\n"; + core_type (i+1) ppf cs.pcsig_self; + list (i+1) class_type_field ppf cs.pcsig_fields; + +and class_type_field i ppf x = + line i ppf "class_type_field %a\n" fmt_location x.pctf_loc; + let i = i+1 in + attributes i ppf x.pctf_attributes; + match x.pctf_desc with + | Pctf_inherit (ct) -> + line i ppf "Pctf_inherit\n"; + class_type i ppf ct; + | Pctf_val (s, mf, vf, ct) -> + line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Pctf_method (s, pf, vf, ct) -> + line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Pctf_constraint (ct1, ct2) -> + line i ppf "Pctf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Pctf_attribute a -> + attribute i ppf "Pctf_attribute" a + | Pctf_extension (s, arg) -> + line i ppf "Pctf_extension \"%s\"\n" s.txt; + payload i ppf arg + +and class_description i ppf x = + line i ppf "class_description %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.pci_expr; + +and class_type_declaration i ppf x = + line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.pci_expr; + +and class_expr i ppf x = + line i ppf "class_expr %a\n" fmt_location x.pcl_loc; + attributes i ppf x.pcl_attributes; + let i = i+1 in + match x.pcl_desc with + | Pcl_constr (li, l) -> + line i ppf "Pcl_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Pcl_structure (cs) -> + line i ppf "Pcl_structure\n"; + class_structure i ppf cs; + | Pcl_fun (l, eo, p, e) -> + line i ppf "Pcl_fun\n"; + arg_label i ppf l; + option i expression ppf eo; + pattern i ppf p; + class_expr i ppf e; + | Pcl_apply (ce, l) -> + line i ppf "Pcl_apply\n"; + class_expr i ppf ce; + list i label_x_expression ppf l; + | Pcl_let (rf, l, ce) -> + line i ppf "Pcl_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + class_expr i ppf ce; + | Pcl_constraint (ce, ct) -> + line i ppf "Pcl_constraint\n"; + class_expr i ppf ce; + class_type i ppf ct; + | Pcl_extension (s, arg) -> + line i ppf "Pcl_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pcl_open (o, e) -> + line i ppf "Pcl_open %a %a\n" fmt_override_flag o.popen_override + fmt_longident_loc o.popen_expr; + class_expr i ppf e + +and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = + line i ppf "class_structure\n"; + pattern (i+1) ppf p; + list (i+1) class_field ppf l; + +and class_field i ppf x = + line i ppf "class_field %a\n" fmt_location x.pcf_loc; + let i = i + 1 in + attributes i ppf x.pcf_attributes; + match x.pcf_desc with + | Pcf_inherit (ovf, ce, so) -> + line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf; + class_expr (i+1) ppf ce; + option (i+1) string_loc ppf so; + | Pcf_val (s, mf, k) -> + line i ppf "Pcf_val %a\n" fmt_mutable_flag mf; + line (i+1) ppf "%a\n" fmt_string_loc s; + class_field_kind (i+1) ppf k + | Pcf_method (s, pf, k) -> + line i ppf "Pcf_method %a\n" fmt_private_flag pf; + line (i+1) ppf "%a\n" fmt_string_loc s; + class_field_kind (i+1) ppf k + | Pcf_constraint (ct1, ct2) -> + line i ppf "Pcf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Pcf_initializer (e) -> + line i ppf "Pcf_initializer\n"; + expression (i+1) ppf e; + | Pcf_attribute a -> + attribute i ppf "Pcf_attribute" a + | Pcf_extension (s, arg) -> + line i ppf "Pcf_extension \"%s\"\n" s.txt; + payload i ppf arg + +and class_field_kind i ppf = function + | Cfk_concrete (o, e) -> + line i ppf "Concrete %a\n" fmt_override_flag o; + expression i ppf e + | Cfk_virtual t -> + line i ppf "Virtual\n"; + core_type i ppf t + +and class_declaration i ppf x = + line i ppf "class_declaration %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_expr (i+1) ppf x.pci_expr; + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.pmty_loc; + attributes i ppf x.pmty_attributes; + let i = i+1 in + match x.pmty_desc with + | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li; + | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li; + | Pmty_signature (s) -> + line i ppf "Pmty_signature\n"; + signature i ppf s; + | Pmty_functor (Unit, mt2) -> + line i ppf "Pmty_functor ()\n"; + module_type i ppf mt2; + | Pmty_functor (Named (s, mt1), mt2) -> + line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s; + module_type i ppf mt1; + module_type i ppf mt2; + | Pmty_with (mt, l) -> + line i ppf "Pmty_with\n"; + module_type i ppf mt; + list i with_constraint ppf l; + | Pmty_typeof m -> + line i ppf "Pmty_typeof\n"; + module_expr i ppf m; + | Pmty_extension (s, arg) -> + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg + +and signature i ppf x = list i signature_item ppf x + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.psig_loc; + let i = i+1 in + match x.psig_desc with + | Psig_value vd -> + line i ppf "Psig_value\n"; + value_description i ppf vd; + | Psig_type (rf, l) -> + line i ppf "Psig_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Psig_typesubst l -> + line i ppf "Psig_typesubst\n"; + list i type_declaration ppf l; + | Psig_typext te -> + line i ppf "Psig_typext\n"; + type_extension i ppf te + | Psig_exception te -> + line i ppf "Psig_exception\n"; + type_exception i ppf te + | Psig_module pmd -> + line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type i ppf pmd.pmd_type + | Psig_modsubst pms -> + line i ppf "Psig_modsubst %a = %a\n" + fmt_string_loc pms.pms_name + fmt_longident_loc pms.pms_manifest; + attributes i ppf pms.pms_attributes; + | Psig_recmodule decls -> + line i ppf "Psig_recmodule\n"; + list i module_declaration ppf decls; + | Psig_modtype x -> + line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Psig_modtypesubst x -> + line i ppf "Psig_modtypesubst %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Psig_open od -> + line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override + fmt_longident_loc od.popen_expr; + attributes i ppf od.popen_attributes + | Psig_include incl -> + line i ppf "Psig_include\n"; + module_type i ppf incl.pincl_mod; + attributes i ppf incl.pincl_attributes + | Psig_class (l) -> + line i ppf "Psig_class\n"; + list i class_description ppf l; + | Psig_class_type (l) -> + line i ppf "Psig_class_type\n"; + list i class_type_declaration ppf l; + | Psig_extension ((s, arg), attrs) -> + line i ppf "Psig_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg + | Psig_attribute a -> + attribute i ppf "Psig_attribute" a + +and modtype_declaration i ppf = function + | None -> line i ppf "#abstract" + | Some mt -> module_type (i+1) ppf mt + +and with_constraint i ppf x = + match x with + | Pwith_type (lid, td) -> + line i ppf "Pwith_type %a\n" fmt_longident_loc lid; + type_declaration (i+1) ppf td; + | Pwith_typesubst (lid, td) -> + line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid; + type_declaration (i+1) ppf td; + | Pwith_module (lid1, lid2) -> + line i ppf "Pwith_module %a = %a\n" + fmt_longident_loc lid1 + fmt_longident_loc lid2; + | Pwith_modsubst (lid1, lid2) -> + line i ppf "Pwith_modsubst %a = %a\n" + fmt_longident_loc lid1 + fmt_longident_loc lid2; + | Pwith_modtype (lid1, mty) -> + line i ppf "Pwith_modtype %a\n" + fmt_longident_loc lid1; + module_type (i+1) ppf mty + | Pwith_modtypesubst (lid1, mty) -> + line i ppf "Pwith_modtypesubst %a\n" + fmt_longident_loc lid1; + module_type (i+1) ppf mty + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.pmod_loc; + attributes i ppf x.pmod_attributes; + let i = i+1 in + match x.pmod_desc with + | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li; + | Pmod_structure (s) -> + line i ppf "Pmod_structure\n"; + structure i ppf s; + | Pmod_functor (Unit, me) -> + line i ppf "Pmod_functor ()\n"; + module_expr i ppf me; + | Pmod_functor (Named (s, mt), me) -> + line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s; + module_type i ppf mt; + module_expr i ppf me; + | Pmod_apply (me1, me2) -> + line i ppf "Pmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2; + | Pmod_apply_unit me1 -> + line i ppf "Pmod_apply_unit\n"; + module_expr i ppf me1 + | Pmod_constraint (me, mt) -> + line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; + | Pmod_unpack (e) -> + line i ppf "Pmod_unpack\n"; + expression i ppf e; + | Pmod_extension (s, arg) -> + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg + +and structure i ppf x = list i structure_item ppf x + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.pstr_loc; + let i = i+1 in + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + line i ppf "Pstr_eval\n"; + attributes i ppf attrs; + expression i ppf e; + | Pstr_value (rf, l) -> + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + | Pstr_primitive vd -> + line i ppf "Pstr_primitive\n"; + value_description i ppf vd; + | Pstr_type (rf, l) -> + line i ppf "Pstr_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Pstr_typext te -> + line i ppf "Pstr_typext\n"; + type_extension i ppf te + | Pstr_exception te -> + line i ppf "Pstr_exception\n"; + type_exception i ppf te + | Pstr_module x -> + line i ppf "Pstr_module\n"; + module_binding i ppf x + | Pstr_recmodule bindings -> + line i ppf "Pstr_recmodule\n"; + list i module_binding ppf bindings; + | Pstr_modtype x -> + line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Pstr_open od -> + line i ppf "Pstr_open %a\n" fmt_override_flag od.popen_override; + module_expr i ppf od.popen_expr; + attributes i ppf od.popen_attributes + | Pstr_class (l) -> + line i ppf "Pstr_class\n"; + list i class_declaration ppf l; + | Pstr_class_type (l) -> + line i ppf "Pstr_class_type\n"; + list i class_type_declaration ppf l; + | Pstr_include incl -> + line i ppf "Pstr_include"; + attributes i ppf incl.pincl_attributes; + module_expr i ppf incl.pincl_mod + | Pstr_extension ((s, arg), attrs) -> + line i ppf "Pstr_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg + | Pstr_attribute a -> + attribute i ppf "Pstr_attribute" a + +and module_declaration i ppf pmd = + str_opt_loc i ppf pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type (i+1) ppf pmd.pmd_type; + +and module_binding i ppf x = + str_opt_loc i ppf x.pmb_name; + attributes i ppf x.pmb_attributes; + module_expr (i+1) ppf x.pmb_expr + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf " %a\n" fmt_location l; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + +and constructor_decl i ppf + {pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes} = + line i ppf "%a\n" fmt_location pcd_loc; + line (i+1) ppf "%a\n" fmt_string_loc pcd_name; + if pcd_vars <> [] then line (i+1) ppf "pcd_vars =%a\n" typevars pcd_vars; + attributes i ppf pcd_attributes; + constructor_arguments (i+1) ppf pcd_args; + option (i+1) core_type ppf pcd_res + +and constructor_arguments i ppf = function + | Pcstr_tuple l -> list i core_type ppf l + | Pcstr_record l -> list i label_decl ppf l + +and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= + line i ppf "%a\n" fmt_location pld_loc; + attributes i ppf pld_attributes; + line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; + line (i+1) ppf "%a" fmt_string_loc pld_name; + core_type (i+1) ppf pld_type + +and longident_x_pattern i ppf (li, p) = + line i ppf "%a\n" fmt_longident_loc li; + pattern (i+1) ppf p; + +and case i ppf {pc_lhs; pc_guard; pc_rhs} = + line i ppf "\n"; + pattern (i+1) ppf pc_lhs; + begin match pc_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf pc_rhs; + +and value_binding i ppf x = + line i ppf "\n"; + attributes (i+1) ppf x.pvb_attributes; + pattern (i+1) ppf x.pvb_pat; + Option.iter (value_constraint (i+1) ppf) x.pvb_constraint; + expression (i+1) ppf x.pvb_expr + +and value_constraint i ppf x = + let pp_sep ppf () = Format.fprintf ppf "@ "; in + let pp_newtypes = Format.pp_print_list fmt_string_loc ~pp_sep in + match x with + | Pvc_constraint { locally_abstract_univars = []; typ } -> + core_type i ppf typ + | Pvc_constraint { locally_abstract_univars=newtypes; typ} -> + line i ppf " %a.\n" pp_newtypes newtypes; + core_type i ppf typ + | Pvc_coercion { ground; coercion} -> + line i ppf "\n"; + option i core_type ppf ground; + core_type i ppf coercion; + +and binding_op i ppf x = + line i ppf " %a %a" + fmt_string_loc x.pbop_op fmt_location x.pbop_loc; + pattern (i+1) ppf x.pbop_pat; + expression (i+1) ppf x.pbop_exp; + +and string_x_expression i ppf (s, e) = + line i ppf " %a\n" fmt_string_loc s; + expression (i+1) ppf e; + +and longident_x_expression i ppf (li, e) = + line i ppf "%a\n" fmt_longident_loc li; + expression (i+1) ppf e; + +and label_x_expression i ppf (l,e) = + line i ppf "\n"; + arg_label i ppf l; + expression (i+1) ppf e; + +and label_x_bool_x_core_type_list i ppf x = + match x.prf_desc with + Rtag (l, b, ctl) -> + line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); + attributes (i+1) ppf x.prf_attributes; + list (i+1) core_type ppf ctl + | Rinherit (ct) -> + line i ppf "Rinherit\n"; + core_type (i+1) ppf ct + + +let rec toplevel_phrase i ppf x = + match x with + | Ptop_def (s) -> + line i ppf "Ptop_def\n"; + structure (i+1) ppf s; + | Ptop_dir {pdir_name; pdir_arg; _} -> + line i ppf "Ptop_dir \"%s\"\n" pdir_name.txt; + match pdir_arg with + | None -> () + | Some da -> directive_argument i ppf da; + +and directive_argument i ppf x = + match x.pdira_desc with + | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s + | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n + | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m + | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li + | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b) + +let interface ppf x = list 0 signature_item ppf x + +let implementation ppf x = list 0 structure_item ppf x + +let top_phrase ppf x = toplevel_phrase 0 ppf x diff --git a/ocamlmerlin_mlx/ocaml/parsing/printast.mli b/ocamlmerlin_mlx/ocaml/parsing/printast.mli new file mode 100644 index 0000000..5bc4961 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/printast.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Raw printer for {!Parsetree} + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Parsetree +open Format + +val interface : formatter -> signature_item list -> unit +val implementation : formatter -> structure_item list -> unit +val top_phrase : formatter -> toplevel_phrase -> unit + +val expression: int -> formatter -> expression -> unit +val structure: int -> formatter -> structure -> unit +val payload: int -> formatter -> payload -> unit diff --git a/ocamlmerlin_mlx/ocaml/parsing/syntaxerr.ml b/ocamlmerlin_mlx/ocaml/parsing/syntaxerr.ml new file mode 100644 index 0000000..df7b8a0 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/syntaxerr.ml @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Auxiliary type for reporting syntax errors *) + +type error = + Unclosed of Location.t * string * Location.t * string + | Expecting of Location.t * string + | Not_expecting of Location.t * string + | Applicative_path of Location.t + | Variable_in_scope of Location.t * string + | Other of Location.t + | Ill_formed_ast of Location.t * string + | Invalid_package_type of Location.t * string + | Removed_string_set of Location.t + +exception Error of error +exception Escape_error + +let location_of_error = function + | Unclosed(l,_,_,_) + | Applicative_path l + | Variable_in_scope(l,_) + | Other l + | Not_expecting (l, _) + | Ill_formed_ast (l, _) + | Invalid_package_type (l, _) + | Expecting (l, _) + | Removed_string_set l -> l + + +let ill_formed_ast loc s = + raise (Error (Ill_formed_ast (loc, s))) diff --git a/ocamlmerlin_mlx/ocaml/parsing/syntaxerr.mli b/ocamlmerlin_mlx/ocaml/parsing/syntaxerr.mli new file mode 100644 index 0000000..577d536 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/parsing/syntaxerr.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Auxiliary type for reporting syntax errors + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type error = + Unclosed of Location.t * string * Location.t * string + | Expecting of Location.t * string + | Not_expecting of Location.t * string + | Applicative_path of Location.t + | Variable_in_scope of Location.t * string + | Other of Location.t + | Ill_formed_ast of Location.t * string + | Invalid_package_type of Location.t * string + | Removed_string_set of Location.t + +exception Error of error +exception Escape_error + +val location_of_error: error -> Location.t +val ill_formed_ast: Location.t -> string -> 'a diff --git a/ocamlmerlin_mlx/preprocess/.ocamlformat-ignore b/ocamlmerlin_mlx/ocaml/preprocess/.ocamlformat-ignore similarity index 100% rename from ocamlmerlin_mlx/preprocess/.ocamlformat-ignore rename to ocamlmerlin_mlx/ocaml/preprocess/.ocamlformat-ignore diff --git a/ocamlmerlin_mlx/preprocess/dune b/ocamlmerlin_mlx/ocaml/preprocess/dune similarity index 57% rename from ocamlmerlin_mlx/preprocess/dune rename to ocamlmerlin_mlx/ocaml/preprocess/dune index 1f9f17b..cece808 100644 --- a/ocamlmerlin_mlx/preprocess/dune +++ b/ocamlmerlin_mlx/ocaml/preprocess/dune @@ -1,37 +1,37 @@ (library - (name mlx_preprocess) + (name mlx_ocaml_preprocess) (package ocamlmerlin-mlx) (flags :standard -w=-9-67-69 - -open=Ocaml_utils - -open=Ocaml_parsing - -open=Merlin_utils) - (libraries - compiler-libs.common - merlin-lib.ocaml_preprocess - merlin-lib.ocaml_parsing)) + -open=Mlx_utils + -open=Mlx_ocaml_utils + -open=Mlx_ocaml_parsing) + (libraries mlx_utils mlx_ocaml_utils mlx_ocaml_parsing)) (copy_files# (enabled_if (<> %{profile} "release")) (mode promote) - (files ../../merlin/src/ocaml/preprocess/parser_explain.ml)) + (files %{project_root}/merlin/src/ocaml/preprocess/parser_explain.ml)) (copy_files# (enabled_if (<> %{profile} "release")) (mode promote) - (files ../../merlin/src/ocaml/preprocess/lexer_ident.{mll,mli})) + (files %{project_root}/merlin/src/ocaml/preprocess/lexer_ident.{mll,mli})) (copy_files# (enabled_if (<> %{profile} "release")) (mode promote) - (files ../../merlin/src/ocaml/preprocess/menhirLib.{ml,mli})) + (files %{project_root}/merlin/src/ocaml/preprocess/menhirLib.{ml,mli})) (copy_files# - (files ../../mlx/jsx_helper.ml)) + (enabled_if + (<> %{profile} "release")) + (mode promote) + (files %{project_root}/mlx/jsx_helper.ml)) (ocamllex lexer_ident lexer_raw) @@ -51,9 +51,7 @@ (action (with-stdout-to %{targets} - (run - %{exe:../../merlin/src/ocaml/preprocess/recover/gen_recover.exe} - %{deps})))) + (run %{exe:./recover/gen_recover.exe} %{deps})))) (rule (targets parser_printer.ml) @@ -64,6 +62,4 @@ (action (with-stdout-to %{targets} - (run - %{exe:../../merlin/src/ocaml/preprocess/printer/gen_printer.exe} - %{deps})))) + (run %{exe:./printer/gen_printer.exe} %{deps})))) diff --git a/ocamlmerlin_mlx/ocaml/preprocess/jsx_helper.ml b/ocamlmerlin_mlx/ocaml/preprocess/jsx_helper.ml new file mode 100644 index 0000000..4927f78 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/jsx_helper.ml @@ -0,0 +1,83 @@ +# 1 "mlx/jsx_helper.ml" +open Printf +open Asttypes +open Longident +open Parsetree +open Ast_helper + +let make_loc (startpos, endpos) = + { + Location.loc_start = startpos; + Location.loc_end = endpos; + Location.loc_ghost = false; + } + +let mkloc = Location.mkloc +let mkexp ~loc d = Exp.mk ~loc:(make_loc loc) d + +let mkjsxexp ~loc:loc' e = + let e = mkexp ~loc:loc' e in + let loc = make_loc loc' in + let pexp_attributes = [ Attr.mk ~loc { txt = "JSX"; loc } (PStr []) ] in + { e with pexp_attributes } + +let rec equal_longindent a b = + match a, b with + | Longident.Lident a, Longident.Lident b -> String.equal a b + | Ldot (pa, a), Ldot (pb, b) -> + String.equal a b && equal_longindent pa pb + | Lapply _, _ | _, Lapply _ -> assert false + | _ -> false + +let make_jsx_element ~raise ~loc:_ ~tag ~end_tag ~props ~children () = + let () = + match end_tag with + | None -> () + | Some (end_tag, (_, end_loc_e)) -> + let eq = + match tag, end_tag with + | (`Module, _, s), (`Module, _, e) -> equal_longindent s e + | (`Value, _, s), (`Value, _, e) -> equal_longindent s e + | _ -> false + in + if not eq then + let _, (end_loc_s, _), _ = end_tag in + let end_loc = end_loc_s, end_loc_e in + let _, start_loc, tag = tag in + let tag = Longident.flatten tag |> String.concat "." in + raise + Syntaxerr.( + Error + (Unclosed + ( make_loc start_loc, + sprintf "<%s>" tag, + make_loc end_loc, + sprintf "" tag ))) + in + let tag = + match tag with + | `Value, loc, txt -> + mkexp ~loc (Pexp_ident { loc = make_loc loc; txt }) + | `Module, loc, txt -> + let txt = Longident.Ldot (txt, "createElement") in + mkexp ~loc (Pexp_ident { loc = make_loc loc; txt }) + in + let props = + let prop_exp ~loc name = + let id = mkloc (Lident name) (make_loc loc) in + mkexp ~loc (Pexp_ident id) + in + List.map + (function + | loc, `Prop_punned name -> Labelled name, prop_exp ~loc name + | loc, `Prop_opt_punned name -> Optional name, prop_exp ~loc name + | _loc, `Prop (name, expr) -> Labelled name, expr + | _loc, `Prop_opt (name, expr) -> Optional name, expr) + props + in + let unit = + Exp.mk ~loc:Location.none + (Pexp_construct ({ txt = Lident "()"; loc = Location.none }, None)) + in + let props = (Labelled "children", children) :: props in + Pexp_apply (tag, (Nolabel, unit) :: props) diff --git a/ocamlmerlin_mlx/preprocess/lexer_ident.mli b/ocamlmerlin_mlx/ocaml/preprocess/lexer_ident.mli similarity index 100% rename from ocamlmerlin_mlx/preprocess/lexer_ident.mli rename to ocamlmerlin_mlx/ocaml/preprocess/lexer_ident.mli diff --git a/ocamlmerlin_mlx/preprocess/lexer_ident.mll b/ocamlmerlin_mlx/ocaml/preprocess/lexer_ident.mll similarity index 100% rename from ocamlmerlin_mlx/preprocess/lexer_ident.mll rename to ocamlmerlin_mlx/ocaml/preprocess/lexer_ident.mll diff --git a/ocamlmerlin_mlx/preprocess/lexer_raw.mli b/ocamlmerlin_mlx/ocaml/preprocess/lexer_raw.mli similarity index 100% rename from ocamlmerlin_mlx/preprocess/lexer_raw.mli rename to ocamlmerlin_mlx/ocaml/preprocess/lexer_raw.mli diff --git a/ocamlmerlin_mlx/preprocess/lexer_raw.mll b/ocamlmerlin_mlx/ocaml/preprocess/lexer_raw.mll similarity index 100% rename from ocamlmerlin_mlx/preprocess/lexer_raw.mll rename to ocamlmerlin_mlx/ocaml/preprocess/lexer_raw.mll diff --git a/ocamlmerlin_mlx/preprocess/menhirLib.ml b/ocamlmerlin_mlx/ocaml/preprocess/menhirLib.ml similarity index 99% rename from ocamlmerlin_mlx/preprocess/menhirLib.ml rename to ocamlmerlin_mlx/ocaml/preprocess/menhirLib.ml index c45163c..4eff237 100644 --- a/ocamlmerlin_mlx/preprocess/menhirLib.ml +++ b/ocamlmerlin_mlx/ocaml/preprocess/menhirLib.ml @@ -1510,7 +1510,8 @@ module Make (T : TABLE) = struct (* In the legacy strategy, we call [reduce] instead of [announce_reduce], apparently in an attempt to hide the reduction steps performed during - error handling. In the simplified strategy, all reductions steps are + error handling. This seems inconsistent, as the default reduction steps + are still announced. In the simplified strategy, all reductions are announced. *) match strategy with @@ -1546,15 +1547,7 @@ module Make (T : TABLE) = struct else begin (* The stack is nonempty. Pop a cell, updating the current state - to the state [cell.state] found in the popped cell, and continue - error handling there. *) - - (* I note that if the new state [cell.state] has a default reduction, - then it is ignored. It is unclear whether this is intentional. It - could be a good thing, as it avoids a scenario where the parser - diverges by repeatedly popping, performing a default reduction of - an epsilon production, popping, etc. Still, the question of whether - to obey default reductions while error handling seems obscure. *) + with that found in the popped cell, and try again. *) let env = { env with stack = next; @@ -3793,5 +3786,5 @@ module MakeEngineTable (T : TableFormat.TABLES) = struct end end module StaticVersion = struct -let require_20210419 = () +let require_20201216 = () end diff --git a/ocamlmerlin_mlx/preprocess/menhirLib.mli b/ocamlmerlin_mlx/ocaml/preprocess/menhirLib.mli similarity index 99% rename from ocamlmerlin_mlx/preprocess/menhirLib.mli rename to ocamlmerlin_mlx/ocaml/preprocess/menhirLib.mli index dbaf8f2..5c72917 100644 --- a/ocamlmerlin_mlx/preprocess/menhirLib.mli +++ b/ocamlmerlin_mlx/ocaml/preprocess/menhirLib.mli @@ -1804,5 +1804,5 @@ module MakeEngineTable and type nonterminal = int end module StaticVersion : sig -val require_20210419: unit +val require_20201216: unit end diff --git a/ocamlmerlin_mlx/preprocess/mlx_preprocess.ml b/ocamlmerlin_mlx/ocaml/preprocess/mlx_preprocess.ml similarity index 90% rename from ocamlmerlin_mlx/preprocess/mlx_preprocess.ml rename to ocamlmerlin_mlx/ocaml/preprocess/mlx_preprocess.ml index 4654cea..21c06cf 100644 --- a/ocamlmerlin_mlx/preprocess/mlx_preprocess.ml +++ b/ocamlmerlin_mlx/ocaml/preprocess/mlx_preprocess.ml @@ -8,5 +8,5 @@ module This = struct module Lexer_ident = Lexer_ident end -include Ocaml_preprocess +(*include Ocaml_preprocess*) include This diff --git a/ocamlmerlin_mlx/preprocess/parser_explain.ml b/ocamlmerlin_mlx/ocaml/preprocess/parser_explain.ml similarity index 100% rename from ocamlmerlin_mlx/preprocess/parser_explain.ml rename to ocamlmerlin_mlx/ocaml/preprocess/parser_explain.ml diff --git a/ocamlmerlin_mlx/preprocess/parser_printer.ml b/ocamlmerlin_mlx/ocaml/preprocess/parser_printer.ml similarity index 100% rename from ocamlmerlin_mlx/preprocess/parser_printer.ml rename to ocamlmerlin_mlx/ocaml/preprocess/parser_printer.ml diff --git a/ocamlmerlin_mlx/preprocess/parser_raw.cmly b/ocamlmerlin_mlx/ocaml/preprocess/parser_raw.cmly similarity index 97% rename from ocamlmerlin_mlx/preprocess/parser_raw.cmly rename to ocamlmerlin_mlx/ocaml/preprocess/parser_raw.cmly index faf9e84..9a6e514 100644 Binary files a/ocamlmerlin_mlx/preprocess/parser_raw.cmly and b/ocamlmerlin_mlx/ocaml/preprocess/parser_raw.cmly differ diff --git a/ocamlmerlin_mlx/preprocess/parser_raw.ml b/ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml similarity index 88% rename from ocamlmerlin_mlx/preprocess/parser_raw.ml rename to ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml index c2497df..9d229ef 100644 --- a/ocamlmerlin_mlx/preprocess/parser_raw.ml +++ b/ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml @@ -2,7 +2,7 @@ (* This generated code requires the following version of MenhirLib: *) let () = - MenhirLib.StaticVersion.require_20210419 + MenhirLib.StaticVersion.require_20201216 module MenhirBasics = struct @@ -17,9 +17,9 @@ module MenhirBasics = struct | VAL | UNDERSCORE | UIDENT of ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 23 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | TYPE | TRY_LWT @@ -30,9 +30,9 @@ module MenhirBasics = struct | THEN | STRUCT | STRING of ( -# 842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 36 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | STAR | SLASHGREATER @@ -44,22 +44,22 @@ module MenhirBasics = struct | RBRACKET | RBRACE | QUOTED_STRING_ITEM of ( -# 847 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 847 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 50 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 50 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | QUOTED_STRING_EXPR of ( -# 844 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 844 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 55 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 55 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | QUOTE | QUESTION | PRIVATE | PREFIXOP of ( -# 828 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 828 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 63 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 63 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | PLUSEQ | PLUSDOT @@ -67,9 +67,9 @@ module MenhirBasics = struct | PERCENT | OR | OPTLABEL of ( -# 821 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 821 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 73 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 73 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | OPEN | OF @@ -86,15 +86,15 @@ module MenhirBasics = struct | MATCH | LPAREN | LIDENT of ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 92 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 92 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | LET_LWT | LETOP of ( -# 783 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 783 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 98 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 98 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | LET | LESSSLASH @@ -113,69 +113,69 @@ module MenhirBasics = struct | LBRACE | LAZY | LABEL of ( -# 788 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 788 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 119 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 119 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | JSX_UIDENT_E of ( -# 858 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 858 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 124 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 124 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | JSX_UIDENT of ( -# 857 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 857 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 129 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 129 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | JSX_LIDENT_E of ( -# 804 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 804 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 134 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 134 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | JSX_LIDENT of ( -# 803 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 139 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 139 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | INT of ( -# 787 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 787 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 144 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 144 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | INITIALIZER | INHERIT | INFIXOP4 of ( -# 781 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 781 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 151 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 151 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | INFIXOP3 of ( -# 780 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 780 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 156 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 156 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | INFIXOP2 of ( -# 779 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 779 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 161 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 161 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | INFIXOP1 of ( -# 778 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 778 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 166 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | INFIXOP0 of ( -# 777 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 777 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 171 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 171 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | INCLUDE | IN | IF | HASHOP of ( -# 839 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 839 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 179 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 179 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | HASH | GREATERRBRACKET @@ -188,9 +188,9 @@ module MenhirBasics = struct | FOR_LWT | FOR | FLOAT of ( -# 765 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 765 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 194 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 194 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | FINALLY_LWT | FALSE @@ -204,25 +204,25 @@ module MenhirBasics = struct | DOWNTO | DOTTILDE | DOTOP of ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 210 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 210 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | DOTLESS | DOTDOT | DOT | DONE | DOCSTRING of ( -# 866 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 866 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Docstrings.docstring) -# 219 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 219 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | DO | CONSTRAINT | COMMENT of ( -# 865 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 865 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t) -# 226 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 226 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | COMMA | COLONGREATER @@ -231,9 +231,9 @@ module MenhirBasics = struct | COLON | CLASS | CHAR of ( -# 745 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 745 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (char) -# 237 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 237 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | BEGIN | BARRBRACKET @@ -244,9 +244,9 @@ module MenhirBasics = struct | ASSERT | AS | ANDOP of ( -# 784 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 784 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 250 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 250 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) | AND | AMPERSAND @@ -259,7 +259,7 @@ include MenhirBasics let _eRR = MenhirBasics.Error -# 25 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 25 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" [@@@ocaml.warning "-9"] @@ -923,7 +923,7 @@ let expr_of_lwt_bindings ~loc lbs body = (lbs.lbs_extension, [])) -# 927 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 927 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" module Tables = struct @@ -1526,9 +1526,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4017 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4017 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "+" ) -# 1532 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1532 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1551,9 +1551,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4018 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4018 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "+." ) -# 1557 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1557 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1576,9 +1576,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3548 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3548 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1582 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1582 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1623,24 +1623,24 @@ module Tables = struct let _endpos = _endpos_tyvar_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3551 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3551 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_alias(ty, tyvar) ) -# 1629 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1629 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_tyvar_, _startpos_ty_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1638 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1638 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3553 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3553 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1644 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1644 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1687,30 +1687,30 @@ module Tables = struct let _v : (Ast_helper.let_binding) = let attrs2 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1693 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1693 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1702 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1702 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklb ~loc:_sloc false body attrs ) -# 1714 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1714 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1733,9 +1733,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3901 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3901 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1739 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1739 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1758,9 +1758,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3902 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3902 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 1764 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1764 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1797,9 +1797,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = -# 3609 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3609 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 1803 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1862,11 +1862,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3669 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 1870 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1870 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -1874,24 +1874,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1880 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1880 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 1886 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1886 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3611 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3611 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_typ_attrs ~loc:_sloc (reloc_typ ~loc:_sloc _4) _3 ) -# 1895 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1895 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1922,24 +1922,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3614 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3614 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_var _2 ) -# 1928 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1928 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1937 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1943 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1943 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1963,23 +1963,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3616 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3616 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 1969 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1969 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1977 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1977 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1983 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 1983 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2008,35 +2008,35 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2014 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2014 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tys = -# 3661 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3661 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 2020 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2020 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3619 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3619 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr(tid, tys) ) -# 2025 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2025 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2034 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2034 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2040 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2040 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2072,20 +2072,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2078 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2078 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tys = -# 3663 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3663 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ty] ) -# 2084 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2084 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3619 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3619 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr(tid, tys) ) -# 2089 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2089 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_ty_ in @@ -2093,15 +2093,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2099 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2099 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2105 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2105 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2152,9 +2152,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2158 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2158 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tys = @@ -2162,24 +2162,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2166 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1166 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2171 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2171 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3665 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3665 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( tys ) -# 2177 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2177 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3619 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3619 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr(tid, tys) ) -# 2183 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2183 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -2187,15 +2187,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2193 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2193 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2199 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2199 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2233,24 +2233,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3621 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3621 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (f, c) = _2 in Ptyp_object (f, c) ) -# 2239 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2239 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2248 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2248 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2254 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2254 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2281,24 +2281,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3623 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3623 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_object ([], Closed) ) -# 2287 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2287 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2296 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2296 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2302 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2302 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2334,20 +2334,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2340 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2340 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tys = -# 3661 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3661 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 2346 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2346 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3627 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3627 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_class(cid, tys) ) -# 2351 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2351 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos__2_ in @@ -2355,15 +2355,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2361 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2361 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2367 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2367 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2406,20 +2406,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2412 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2412 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tys = -# 3663 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3663 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ty] ) -# 2418 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2418 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3627 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3627 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_class(cid, tys) ) -# 2423 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2423 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_ty_ in @@ -2427,15 +2427,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2433 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2433 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2439 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2439 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2493,9 +2493,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2499 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2499 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tys = @@ -2503,24 +2503,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2507 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2507 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1166 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2512 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2512 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3665 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3665 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( tys ) -# 2518 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3627 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3627 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_class(cid, tys) ) -# 2524 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2524 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -2528,15 +2528,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2534 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2534 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2574,24 +2574,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3630 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3630 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant([_2], Closed, None) ) -# 2580 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2580 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2589 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2589 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2595 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2595 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2641,24 +2641,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2645 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2645 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2650 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2650 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3675 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3675 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2656 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2656 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3632 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3632 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Closed, None) ) -# 2662 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2662 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -2666,15 +2666,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2672 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2672 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2678 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2678 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2731,24 +2731,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2735 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2735 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2740 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2740 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3675 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3675 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2746 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2746 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3634 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3634 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_2 :: _4, Closed, None) ) -# 2752 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2752 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -2756,15 +2756,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2762 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2762 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2768 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2768 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2814,24 +2814,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2818 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2818 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2823 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2823 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3675 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3675 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2829 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2829 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3636 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3636 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Open, None) ) -# 2835 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -2839,15 +2839,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2845 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2845 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2851 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2851 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2878,24 +2878,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3638 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3638 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant([], Open, None) ) -# 2884 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2884 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2893 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2893 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2899 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2899 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2945,24 +2945,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2949 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2949 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2954 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2954 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3675 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3675 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2960 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2960 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3640 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3640 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Closed, Some []) ) -# 2966 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2966 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -2970,15 +2970,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2976 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2976 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2982 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 2982 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3043,18 +3043,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 3047 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1106 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1106 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 3052 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3052 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3703 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3703 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3058 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3058 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -3062,24 +3062,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 3066 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3066 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 3071 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3071 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3675 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3675 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3077 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3077 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3642 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3642 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Closed, Some _5) ) -# 3083 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3083 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -3087,15 +3087,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 3093 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3093 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3099 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3099 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3119,23 +3119,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3644 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3644 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_extension _1 ) -# 3125 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3125 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 3133 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3133 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3646 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3139 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3139 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3159,23 +3159,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (string Location.loc) = let _1 = let _1 = -# 4084 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4084 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3165 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3165 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1034 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1034 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkloc _1 (make_loc _sloc) ) -# 3173 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3173 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4086 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4086 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3179 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3179 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3213,24 +3213,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (string Location.loc) = let _1 = let _1 = -# 4085 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4085 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ^ "." ^ _3.txt ) -# 3219 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3219 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1034 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1034 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkloc _1 (make_loc _sloc) ) -# 3228 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3228 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4086 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4086 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3234 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3234 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3277,9 +3277,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4090 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4090 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 3283 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3283 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3302,9 +3302,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.class_expr) = -# 2025 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2025 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3308 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3308 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3343,18 +3343,18 @@ module Tables = struct let _v : (Parsetree.class_expr) = let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3349 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3349 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2027 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2027 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_class_attrs ~loc:_sloc _3 _2 ) -# 3358 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3358 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3394,9 +3394,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2029 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2029 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( class_of_let_bindings ~loc:_sloc _1 _3 ) -# 3400 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3400 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3459,34 +3459,34 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 3465 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3465 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in let _4 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3474 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3474 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _3 = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 3480 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3480 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = (_startpos__2_, _endpos__5_) in let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in mkclass ~loc:_sloc ~attrs:_4 (Pcl_open(od, _7)) ) -# 3490 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3490 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3556,34 +3556,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 3562 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3562 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3571 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3571 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in - let _3 = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let _3 = + let _1 = _1_inlined1 in + +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 3577 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 3579 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = (_startpos__2_, _endpos__5_) in let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in mkclass ~loc:_sloc ~attrs:_4 (Pcl_open(od, _7)) ) -# 3587 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3590 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3613,9 +3616,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = -# 2035 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2035 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Cl.attr _1 _2 ) -# 3619 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3622 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3650,18 +3653,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 3654 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3657 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1106 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1106 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 3659 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3662 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2038 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2038 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcl_apply(_1, _2) ) -# 3665 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3668 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -3669,15 +3672,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3675 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3678 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3681 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3684 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3701,23 +3704,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2040 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2040 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcl_extension _1 ) -# 3707 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3710 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3715 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3718 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3721 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3724 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3770,33 +3773,33 @@ module Tables = struct let _v : (Parsetree.class_field) = let _6 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3776 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3779 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3785 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3788 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 3791 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3794 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2096 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2096 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3800 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3856,33 +3859,36 @@ module Tables = struct let _v : (Parsetree.class_field) = let _6 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3862 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3865 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _3 = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3871 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3874 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in - let _2 = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let _2 = + let _1 = _1_inlined1 in + +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 3877 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 3882 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2096 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2096 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3886 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3892 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3922,9 +3928,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _3 = let _1 = _1_inlined1 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3928 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3934 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3932,11 +3938,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2099 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2099 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let v, attrs = _2 in let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_val v) ~attrs:(attrs@_3) ~docs ) -# 3940 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3946 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3976,9 +3982,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _3 = let _1 = _1_inlined1 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3982 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 3988 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3986,11 +3992,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let meth, attrs = _2 in let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_method meth) ~attrs:(attrs@_3) ~docs ) -# 3994 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4000 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4036,28 +4042,28 @@ module Tables = struct let _v : (Parsetree.class_field) = let _4 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4042 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4048 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4051 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 4061 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4067 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4103,28 +4109,28 @@ module Tables = struct let _v : (Parsetree.class_field) = let _4 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4109 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4115 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4118 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4124 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2110 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2110 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_initializer _3) ~attrs:(_2@_4) ~docs ) -# 4128 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4134 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4156,9 +4162,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _2 = let _1 = _1_inlined1 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4162 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4168 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -4166,10 +4172,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2113 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2113 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_extension _1) ~attrs:_2 ~docs ) -# 4173 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4179 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4193,23 +4199,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_field) = let _1 = let _1 = -# 2116 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2116 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcf_attribute _1 ) -# 4199 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4205 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1055 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1055 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkcf ~loc:_sloc _1 ) -# 4207 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4213 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2117 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2117 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4213 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4219 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4239,9 +4245,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = -# 2005 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2005 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 4245 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4251 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4286,24 +4292,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2008 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2008 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcl_constraint(_4, _2) ) -# 4292 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4298 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4301 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4307 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2011 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2011 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4307 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4313 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4334,24 +4340,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, _2) ) -# 4340 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4346 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4349 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4355 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2011 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2011 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4355 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4361 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4389,24 +4395,24 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2072 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2072 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 4395 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4401 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_e_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4404 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2073 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2073 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4410 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4416 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4437,24 +4443,24 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2072 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2072 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 4443 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4449 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_e_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4452 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4458 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2073 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2073 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4458 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4464 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4477,9 +4483,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3891 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3891 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4483 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4489 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4519,9 +4525,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2081 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2081 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( reloc_pat ~loc:_sloc _2 ) -# 4525 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4531 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4573,24 +4579,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2083 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2083 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_2, _4) ) -# 4579 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4585 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 4588 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4594 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2084 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2084 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4594 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4600 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4609,9 +4615,9 @@ module Tables = struct let _symbolstartpos = _endpos in let _sloc = (_symbolstartpos, _endpos) in -# 2086 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2086 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ghpat ~loc:_sloc Ppat_any ) -# 4615 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4621 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4648,9 +4654,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = -# 2213 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2213 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 4654 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4660 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4667,24 +4673,24 @@ module Tables = struct let _endpos = _startpos in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 2214 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2214 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 4673 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4679 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__0_ in let _endpos = _endpos__1_ in let _symbolstartpos = _endpos in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 4682 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4688 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2215 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4688 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4694 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4730,28 +4736,28 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4736 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4742 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4745 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4751 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2223 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2223 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_inherit _3) ~attrs:(_2@_4) ~docs ) -# 4755 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4761 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4809,9 +4815,9 @@ module Tables = struct let ty : (Parsetree.core_type) = Obj.magic ty in let _3 : unit = Obj.magic _3 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 4815 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4821 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let flags : (Asttypes.mutable_flag * Asttypes.virtual_flag) = Obj.magic flags in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -4822,9 +4828,9 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4828 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4834 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined3_ in @@ -4832,44 +4838,44 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let label = let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4838 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4844 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4846 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4852 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2248 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2248 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let mut, virt = flags in label, mut, virt, ty ) -# 4855 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4861 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4863 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4869 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2226 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2226 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_val _3) ~attrs:(_2@_4) ~docs ) -# 4873 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4879 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4927,9 +4933,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 4933 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4939 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.private_flag * Asttypes.virtual_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -4940,53 +4946,53 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _7 = let _1 = _1_inlined4 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4946 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4952 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__7_ = _endpos__1_inlined4_ in let _6 = let _1 = _1_inlined3 in -# 3514 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3514 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4955 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4961 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4963 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4969 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4971 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4977 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4979 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4985 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2230 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2230 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (p, v) = _3 in let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_method (_4, p, v, _6)) ~attrs:(_2@_7) ~docs ) -# 4990 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 4996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5032,28 +5038,28 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5038 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5044 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5047 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5053 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2234 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2234 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 5057 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5063 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5085,9 +5091,9 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _2 = let _1 = _1_inlined1 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5091 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5097 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -5095,10 +5101,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2237 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2237 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_extension _1) ~attrs:_2 ~docs ) -# 5102 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5108 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5122,23 +5128,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_type_field) = let _1 = let _1 = -# 2240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pctf_attribute _1 ) -# 5128 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5134 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1053 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1053 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkctf ~loc:_sloc _1 ) -# 5136 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5142 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2241 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2241 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5142 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5148 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5167,42 +5173,42 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5173 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5179 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tys = let tys = -# 2199 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2199 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 5180 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5186 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2205 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2205 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5185 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5191 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2180 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2180 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcty_constr (cid, tys) ) -# 5191 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5197 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5200 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5206 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2183 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2183 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5206 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5212 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5253,9 +5259,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5259 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5265 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tys = @@ -5264,30 +5270,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5268 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5274 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 5273 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5279 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2201 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2201 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( params ) -# 5279 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5285 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2205 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2205 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5285 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5291 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2180 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2180 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcty_constr (cid, tys) ) -# 5291 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5297 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5295,15 +5301,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5301 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5307 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2183 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2183 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5307 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5313 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5327,23 +5333,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_type) = let _1 = let _1 = -# 2182 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2182 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcty_extension _1 ) -# 5333 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5339 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5341 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5347 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2183 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2183 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5347 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5353 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5400,44 +5406,44 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5404 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2219 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2219 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5409 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5415 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 999 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 999 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_csig _startpos _endpos _1 ) -# 5418 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5424 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2209 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2209 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Csig.mk _1 _2 ) -# 5424 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5430 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5432 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2185 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2185 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc ~attrs:_2 (Pcty_signature _3) ) -# 5441 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5447 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5467,9 +5473,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_type) = -# 2191 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2191 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Cty.attr _1 _2 ) -# 5473 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5479 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5532,34 +5538,34 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5538 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5544 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in let _4 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5547 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5553 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _3 = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 5553 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5559 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2193 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2193 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = (_startpos__2_, _endpos__5_) in let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in mkcty ~loc:_sloc ~attrs:_4 (Pcty_open(od, _7)) ) -# 5563 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5569 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5629,34 +5635,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5635 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5641 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5644 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5650 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in - let _3 = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let _3 = + let _1 = _1_inlined1 in + +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 5650 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 5658 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2193 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2193 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = (_startpos__2_, _endpos__5_) in let od = Opn.mk ~override:_3 ~loc:(make_loc loc) _5 in mkcty ~loc:_sloc ~attrs:_4 (Pcty_open(od, _7)) ) -# 5660 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5693,9 +5702,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.class_expr) = -# 2045 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2045 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 5699 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5708 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5724,42 +5733,42 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5730 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5739 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tys = let tys = -# 2199 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2199 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 5737 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5746 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2205 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2205 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5742 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5751 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2052 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2052 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcl_constr(cid, tys) ) -# 5748 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5757 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5757 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5766 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2063 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2063 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5763 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5772 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5810,9 +5819,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5816 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5825 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tys = @@ -5821,30 +5830,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5825 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5834 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 5830 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5839 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2201 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2201 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( params ) -# 5836 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5845 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2205 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2205 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5842 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5851 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2052 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2052 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcl_constr(cid, tys) ) -# 5848 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5857 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5852,15 +5861,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5858 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5867 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2063 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2063 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5864 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5873 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5912,24 +5921,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2058 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2058 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcl_constraint(_2, _4) ) -# 5918 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5927 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5927 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5936 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2063 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2063 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5933 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5942 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5986,44 +5995,44 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5990 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 5999 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2090 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2090 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5995 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 998 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 998 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_cstr _startpos _endpos _1 ) -# 6004 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6013 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2077 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2077 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Cstr.mk _1 _2 ) -# 6010 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6019 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6018 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6027 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2065 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc ~attrs:_2 (Pcl_structure _3) ) -# 6027 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6036 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6046,9 +6055,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.class_type) = -# 2168 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2168 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6052 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6061 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6094,14 +6103,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3577 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3577 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Optional label ) -# 6100 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6109 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6105 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6114 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -6109,15 +6118,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6115 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6124 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2175 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2175 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6121 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6164,9 +6173,9 @@ module Tables = struct let domain : (Parsetree.core_type) = Obj.magic domain in let _2 : unit = Obj.magic _2 in let label : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 6170 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6179 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -6174,14 +6183,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3579 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3579 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Labelled label ) -# 6180 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6189 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6185 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6194 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -6189,15 +6198,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6195 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6204 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2175 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2175 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6201 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6210 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6236,14 +6245,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3581 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3581 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Nolabel ) -# 6242 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6251 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6247 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6256 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_domain_) in @@ -6251,15 +6260,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6257 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6266 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2175 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2175 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6263 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6272 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6342,9 +6351,9 @@ module Tables = struct let csig : (Parsetree.class_type) = Obj.magic csig in let _8 : unit = Obj.magic _8 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 6348 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6357 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -6360,9 +6369,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6366 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6375 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -6372,24 +6381,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 6378 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6387 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6386 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6395 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2315 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2315 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -6397,19 +6406,19 @@ module Tables = struct ext, Ci.mk id csig ~virt ~params ~attrs ~loc ~docs ) -# 6401 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1235 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1235 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 6407 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6416 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2303 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2303 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6413 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6432,9 +6441,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3888 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3888 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6438 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6447 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6453,17 +6462,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 787 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 787 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 6459 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6468 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constant) = -# 3749 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3749 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _1 in Pconst_integer (n, m) ) -# 6467 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6476 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6482,17 +6491,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 745 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 745 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (char) -# 6488 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6497 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constant) = -# 3750 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3750 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pconst_char _1 ) -# 6496 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6505 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6511,17 +6520,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 6517 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6526 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constant) = -# 3751 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3751 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (s, strloc, d) = _1 in Pconst_string (s, strloc, d) ) -# 6525 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6534 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6540,17 +6549,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 765 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 765 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 6546 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6555 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constant) = -# 3752 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3752 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _1 in Pconst_float (f, m) ) -# 6554 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6563 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6580,9 +6589,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3825 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3825 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "[]" ) -# 6586 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6595 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6612,9 +6621,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3826 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3826 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "()" ) -# 6618 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6627 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6637,9 +6646,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3827 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3827 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "false" ) -# 6643 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6652 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6662,9 +6671,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3828 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3828 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "true" ) -# 6668 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6677 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6683,17 +6692,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 6689 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6698 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3831 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3831 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6697 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6706 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6730,14 +6739,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = let _1 = -# 3822 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3822 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6736 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6745 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3832 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3832 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6741 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6750 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6760,9 +6769,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3833 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3833 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6766 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6775 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6785,9 +6794,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3836 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6791 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6800 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6837,15 +6846,18 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in - let _v : (Longident.t) = let _3 = -# 3822 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let _v : (Longident.t) = let _3 = + let (_2, _1) = (_2_inlined1, _1_inlined1) in + +# 3822 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6844 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 6855 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in -# 3837 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3837 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 6849 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6861 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6882,14 +6894,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = let _1 = -# 3822 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3822 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6888 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6900 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3838 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3838 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 6893 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6905 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6912,9 +6924,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3839 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3839 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 6918 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6930 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6951,9 +6963,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type * Parsetree.core_type) = -# 2259 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2259 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _3 ) -# 6957 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6969 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6978,26 +6990,26 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = let tys = let xs = let xs = -# 1122 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1122 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 6984 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 6996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 253 "" ( List.rev xs ) -# 6989 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7001 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1142 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1142 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 6995 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7007 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3380 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3380 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcstr_tuple tys ) -# 7001 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7013 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7036,26 +7048,26 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = let tys = let xs = let xs = -# 1126 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 7042 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7054 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 253 "" ( List.rev xs ) -# 7047 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7059 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1142 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1142 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7053 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3380 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3380 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcstr_tuple tys ) -# 7059 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7071 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7092,9 +7104,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.constructor_arguments) = -# 3382 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3382 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pcstr_record _2 ) -# 7098 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7110 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7117,9 +7129,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constructor_declaration list) = -# 3296 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3296 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 7123 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7135 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7142,14 +7154,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.constructor_declaration list) = let cs = -# 1227 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1227 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 7148 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7160 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3298 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3298 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( cs ) -# 7153 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7165 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7172,14 +7184,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = -# 3539 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7178 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7190 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3529 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7183 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7195 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7209,9 +7221,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = -# 3531 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3531 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Typ.attr _1 _2 ) -# 7215 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7227 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7234,9 +7246,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.direction_flag) = -# 3954 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3954 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Upto ) -# 7240 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7252 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7259,9 +7271,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.direction_flag) = -# 3955 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3955 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Downto ) -# 7265 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7277 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7301,9 +7313,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4164 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4164 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( expr_of_lwt_bindings ~loc:_loc _1 (merloc _endpos__2_ _3) ) -# 7307 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7319 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7365,18 +7377,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7369 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7381 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1199 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1199 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7374 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7386 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2836 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7380 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7392 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos_xs_ in @@ -7385,26 +7397,26 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7391 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7403 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7397 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7409 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4166 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let expr = mkexp_attrs ~loc:_loc (Pexp_match(Fake.app Fake.Lwt.un_lwt _3, List.rev _5)) _2 in Fake.app Fake.Lwt.in_lwt expr ) -# 7408 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7420 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7452,24 +7464,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7458 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7470 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7464 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7476 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4170 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4170 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( reloc_exp ~loc:_loc (Fake.app Fake.Lwt.in_lwt _3) ) -# 7473 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7485 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7531,18 +7543,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7535 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7547 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1199 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1199 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7540 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7552 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2836 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7546 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7558 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos_xs_ in @@ -7551,25 +7563,25 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7557 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7569 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7563 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4172 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4172 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp_attrs ~loc:_loc (Pexp_try(Fake.app Fake.Lwt.in_lwt _3, List.rev _5)) _2 ) -# 7573 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7585 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7631,21 +7643,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7637 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7649 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7643 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7655 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4175 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4175 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fake.app (Fake.app Fake.Lwt.finally_ _3) _5 ) -# 7649 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7661 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7721,18 +7733,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7725 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7737 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1199 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1199 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7730 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7742 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2836 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7736 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7748 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -7740,26 +7752,26 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7746 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7758 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7752 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7764 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4177 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4177 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let expr = mkexp_attrs ~loc:_loc (Pexp_try (Fake.app Fake.Lwt.in_lwt _3, List.rev _5)) _2 in Fake.app (Fake.app Fake.Lwt.finally_ expr) _7 ) -# 7763 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7775 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7828,25 +7840,25 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7834 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7846 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7840 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7852 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4181 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4181 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let expr = Pexp_while (_3, Fake.(app Lwt.un_lwt _5)) in Fake.(app Lwt.to_lwt (mkexp_attrs ~loc:_loc expr _2)) ) -# 7850 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7862 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7943,25 +7955,25 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7949 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7961 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7955 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__10_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4184 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4184 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let expr = Pexp_for (_3, _5, _7, _6, Fake.(app Lwt.un_lwt _9)) in Fake.(app Lwt.to_lwt (mkexp_attrs ~loc:_loc expr _2)) ) -# 7965 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 7977 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8044,28 +8056,28 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8050 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8056 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8068 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__8_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4187 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4187 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp_attrs ~loc:_loc (Pexp_let (Nonrecursive, [Vb.mk _3 (Fake.(app Lwt.un_stream _5))], Fake.(app Lwt.unit_lwt _7))) _2 ) -# 8069 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8081 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8088,9 +8100,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2426 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2426 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8094 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8106 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8168,9 +8180,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 8174 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8186 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -8178,21 +8190,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8184 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8196 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8190 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8202 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2461 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2461 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_letmodule(_4, _5, (merloc _endpos__6_ _7)), _3 ) -# 8196 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8208 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8200,10 +8212,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8207 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8219 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8272,7 +8284,7 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in - let _2_inlined1 : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + let _2_inlined1 : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic _2_inlined1 in let _1_inlined3 : (string) = Obj.magic _1_inlined3 in let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in @@ -8288,9 +8300,9 @@ module Tables = struct let _3 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8294 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8306 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -8299,19 +8311,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 8305 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8317 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3360 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3360 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = _2 in Te.decl _1 ~vars ~args ?res ~attrs:_3 ~loc:(make_loc _sloc) ) -# 8315 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8327 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -8319,21 +8331,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8325 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8337 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8331 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8343 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2463 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2463 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_letexception(_4, _6), _3 ) -# 8337 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8349 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -8341,10 +8353,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8348 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8360 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8414,28 +8426,28 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8420 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8432 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8426 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _3 = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 8432 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8444 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2465 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2465 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let open_loc = make_loc (_startpos__2_, _endpos__5_) in let od = Opn.mk _5 ~override:_3 ~loc:open_loc in Pexp_open(od, (merloc _endpos__6_ _7)), _4 ) -# 8439 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8451 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8443,10 +8455,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8450 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8462 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8523,28 +8535,31 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8529 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8541 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8535 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8547 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in - let _3 = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let _3 = + let _1 = _1_inlined1 in + +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 8541 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 8555 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in -# 2465 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2465 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let open_loc = make_loc (_startpos__2_, _endpos__5_) in let od = Opn.mk _5 ~override:_3 ~loc:open_loc in Pexp_open(od, (merloc _endpos__6_ _7)), _4 ) -# 8548 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8563 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8552,10 +8567,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8559 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8574 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8604,18 +8619,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8608 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8623 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1199 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1199 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8613 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8628 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2836 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8619 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8634 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -8623,21 +8638,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8629 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8644 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8635 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8650 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2469 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2469 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_function _3, _2 ) -# 8641 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8656 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -8645,10 +8660,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8652 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8667 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8704,22 +8719,22 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8710 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8725 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8716 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8731 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2471 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2471 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _3 in Pexp_fun(l, o, p, _4), _2 ) -# 8723 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8738 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -8727,10 +8742,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8734 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8749 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8803,33 +8818,33 @@ module Tables = struct let _endpos = _endpos__7_ in let _v : (Parsetree.expression) = let _1 = let _5 = -# 2723 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2723 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8809 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8824 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8818 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8833 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8824 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8839 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2474 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2474 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (mk_newtypes ~loc:_sloc _5 _7).pexp_desc, _2 ) -# 8833 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8848 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8837,10 +8852,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8844 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8859 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8903,18 +8918,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8907 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8922 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1199 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1199 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8912 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8927 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2836 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8918 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8933 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -8922,21 +8937,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8928 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8943 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8934 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8949 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2476 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2476 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_match(_3, _5), _2 ) -# 8940 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8955 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -8944,10 +8959,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8951 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 8966 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9010,18 +9025,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9014 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9029 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1199 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1199 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 9019 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9034 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2836 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 9025 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9040 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -9029,21 +9044,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9035 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9050 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9041 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9056 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2478 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2478 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_try(_3, _5), _2 ) -# 9047 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -9051,10 +9066,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9058 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9073 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9131,21 +9146,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9152 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9143 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9158 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2484 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2484 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), Some (merloc _endpos__6_ _7)), _2 ) -# 9149 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9164 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -9153,10 +9168,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9160 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9175 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9219,21 +9234,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9225 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9231 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9246 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2486 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2486 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), None), _2 ) -# 9237 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9252 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -9241,10 +9256,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9248 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9263 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9314,21 +9329,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9320 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9335 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9326 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9341 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2488 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2488 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_while(_3, (merloc _endpos__4_ _5)), _2 ) -# 9332 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9347 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -9336,10 +9351,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9343 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9358 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9437,21 +9452,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9443 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9458 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9449 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9464 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2495 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2495 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_for(_3, (merloc _endpos__4_ _5), (merloc _endpos__6_ _7), _6, (merloc _endpos__8_ _9)), _2 ) -# 9455 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9470 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__10_ in @@ -9459,10 +9474,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9466 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9481 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9511,21 +9526,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9517 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9532 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9523 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9538 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2497 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2497 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_assert _3, _2 ) -# 9529 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9544 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -9533,10 +9548,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9540 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9555 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9585,21 +9600,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9591 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9606 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9597 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9612 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2499 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2499 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_lazy _3, _2 ) -# 9603 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9618 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -9607,10 +9622,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2428 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9614 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9629 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9645,18 +9660,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9649 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9664 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1106 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1106 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 9654 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2503 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2503 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, _2) ) -# 9660 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9675 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -9664,15 +9679,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9670 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9685 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9676 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9691 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9701,24 +9716,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9705 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1166 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 9710 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9725 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2864 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2864 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 9716 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9731 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2505 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2505 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_tuple(_1) ) -# 9722 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9737 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -9726,15 +9741,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9732 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9747 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9738 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9753 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9770,15 +9785,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 9776 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9791 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2507 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2507 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_construct(_1, Some _2) ) -# 9782 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9797 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -9786,15 +9801,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9792 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9807 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9798 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9813 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9825,24 +9840,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2509 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2509 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_variant(_1, Some _2) ) -# 9831 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9846 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9840 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9855 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9846 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9861 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9874,9 +9889,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 777 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 777 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 9880 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9895 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic op in let e1 : (Parsetree.expression) = Obj.magic e1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -9886,24 +9901,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3795 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3795 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( op ) -# 9892 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9907 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 9901 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9916 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 9907 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9922 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9911,15 +9926,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9917 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9932 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9923 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9938 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9951,9 +9966,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 778 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 778 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 9957 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9972 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic op in let e1 : (Parsetree.expression) = Obj.magic e1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -9963,24 +9978,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3796 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3796 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( op ) -# 9969 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9984 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 9978 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9993 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 9984 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 9999 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9988,15 +10003,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9994 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10000 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10015 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10028,9 +10043,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 779 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 779 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 10034 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10049 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic op in let e1 : (Parsetree.expression) = Obj.magic e1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -10040,24 +10055,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3797 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3797 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( op ) -# 10046 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10061 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10055 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10070 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10061 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10065,15 +10080,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10071 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10086 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10077 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10092 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10105,9 +10120,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 780 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 780 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 10111 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic op in let e1 : (Parsetree.expression) = Obj.magic e1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -10117,24 +10132,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3798 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3798 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( op ) -# 10123 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10132 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10147 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10138 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10153 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10142,15 +10157,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10148 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10163 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10154 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10169 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10182,9 +10197,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 781 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 781 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 10188 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10203 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic op in let e1 : (Parsetree.expression) = Obj.magic e1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -10194,24 +10209,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3799 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3799 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( op ) -# 10200 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_op_, _startpos_op_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10209 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10224 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10215 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10230 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10219,15 +10234,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10225 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10231 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10246 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10267,23 +10282,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3800 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3800 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("+") -# 10273 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10288 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10281 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10296 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10287 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10302 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10291,15 +10306,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10297 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10312 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10303 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10318 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10339,23 +10354,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3801 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3801 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("+.") -# 10345 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10360 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10353 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10368 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10359 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10374 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10363,15 +10378,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10369 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10384 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10375 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10390 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10411,23 +10426,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("+=") -# 10417 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10432 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10425 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10440 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10431 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10446 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10435,15 +10450,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10441 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10456 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10447 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10462 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10483,23 +10498,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3803 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("-") -# 10489 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10504 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10497 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10512 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10503 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10507,15 +10522,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10513 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10528 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10519 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10534 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10555,23 +10570,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3804 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3804 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("-.") -# 10561 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10576 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10569 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10584 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10575 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10590 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10579,15 +10594,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10585 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10600 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10591 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10606 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10627,23 +10642,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3805 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3805 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("*") -# 10633 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10648 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10641 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10656 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10647 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10662 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10651,15 +10666,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10657 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10672 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10663 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10678 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10699,23 +10714,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3806 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3806 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("%") -# 10705 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10713 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10728 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10719 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10734 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10723,15 +10738,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10729 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10744 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10735 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10750 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10771,23 +10786,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3807 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3807 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("=") -# 10777 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10785 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10800 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10791 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10806 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10795,15 +10810,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10801 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10816 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10807 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10822 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10843,23 +10858,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3808 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3808 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("<") -# 10849 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10864 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10857 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10872 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10863 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10878 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10867,15 +10882,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10873 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10888 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10879 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10894 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10915,23 +10930,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3809 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3809 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (">") -# 10921 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10936 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10929 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10944 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10935 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10950 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10939,15 +10954,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10945 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10960 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10951 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 10966 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10987,23 +11002,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3810 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3810 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("or") -# 10993 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11008 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11001 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11007 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11022 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11011,15 +11026,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11017 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11032 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11023 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11038 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11059,23 +11074,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3811 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3811 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("||") -# 11065 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11080 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11073 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11079 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11094 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11083,15 +11098,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11089 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11104 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11095 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11110 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11131,23 +11146,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3812 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3812 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("&") -# 11137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11152 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11145 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11160 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11151 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11155,15 +11170,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11161 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11176 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11167 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11182 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11203,23 +11218,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3813 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3813 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("&&") -# 11209 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11224 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11217 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11232 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11223 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11238 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11227,15 +11242,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11233 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11248 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11239 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11254 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11275,23 +11290,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3814 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3814 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (":=") -# 11281 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11296 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11289 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11304 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2511 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11295 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11310 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11299,15 +11314,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11305 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11320 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11311 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11326 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11340,9 +11355,9 @@ module Tables = struct let _1 = let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 2513 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2513 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkuminus ~oploc:_loc__1_ _1 _2 ) -# 11346 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11361 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -11350,15 +11365,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11356 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11371 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11362 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11377 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11391,9 +11406,9 @@ module Tables = struct let _1 = let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 2515 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2515 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkuplus ~oploc:_loc__1_ _1 _2 ) -# 11397 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11412 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -11401,15 +11416,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11407 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2431 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2431 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11413 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11449,9 +11464,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2433 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2433 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( expr_of_let_bindings ~loc:_sloc _1 (merloc _endpos__2_ _3) ) -# 11455 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11470 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11491,9 +11506,9 @@ module Tables = struct let _3 : unit = Obj.magic _3 in let bindings : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = Obj.magic bindings in let _1 : ( -# 783 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 783 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 11497 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11512 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -11503,9 +11518,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11509 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11524 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_pbop_op_ = _startpos__1_ in @@ -11513,13 +11528,13 @@ module Tables = struct let _symbolstartpos = _startpos_pbop_op_ in let _sloc = (_symbolstartpos, _endpos) in -# 2435 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2435 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (pbop_pat, pbop_exp, rev_ands) = bindings in let ands = List.rev rev_ands in let pbop_loc = make_loc _sloc in let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in mkexp ~loc:_sloc (Pexp_letop{ let_; ands; body}) ) -# 11523 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11538 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11560,9 +11575,9 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2441 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2441 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp_cons ~loc:_sloc _loc__2_ (ghexp ~loc:_sloc (Pexp_tuple[_1;(merloc _endpos__2_ _3)])) ) -# 11566 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11581 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11595,35 +11610,35 @@ module Tables = struct let _3 : (Parsetree.expression) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 11601 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11616 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11610 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11625 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11618 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11633 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2443 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2443 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc (Pexp_setinstvar(_1, _3)) ) -# 11627 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11642 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11679,18 +11694,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11685 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11700 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2445 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2445 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc (Pexp_setfield(_1, _3, _5)) ) -# 11694 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11709 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11756,14 +11771,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2446 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2446 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Some v) -# 11762 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11777 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2406 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2406 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 11767 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11771,9 +11786,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2447 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2447 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11777 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11839,14 +11854,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2446 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2446 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Some v) -# 11845 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11860 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2408 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2408 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 11850 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11865 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11854,9 +11869,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2447 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2447 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11860 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11875 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11922,14 +11937,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2446 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2446 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Some v) -# 11928 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11943 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2410 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 11933 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11948 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11937,9 +11952,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2447 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2447 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11943 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 11958 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11999,9 +12014,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 12005 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12020 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -12009,31 +12024,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2448 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2448 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Some v) -# 12015 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12030 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 12020 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12035 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12026 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12031 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12046 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2406 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2406 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 12037 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12052 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12041,9 +12056,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2449 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2449 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12047 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12115,9 +12130,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 12121 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12136 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -12126,40 +12141,43 @@ module Tables = struct let _startpos = _startpos_array_ in let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = - let r = -# 2448 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let r = + let _1 = _1_inlined1 in + +# 2448 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Some v) -# 12133 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 12150 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 12138 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12156 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (_2) -# 12146 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12164 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12151 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12169 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12157 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12175 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2406 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2406 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 12163 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12181 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12167,9 +12185,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2449 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2449 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12173 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12191 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12229,9 +12247,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 12235 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12253 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -12239,31 +12257,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2448 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2448 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Some v) -# 12245 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12263 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 12250 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12268 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12256 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12274 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12261 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12279 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2408 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2408 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 12267 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12285 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12271,9 +12289,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2449 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2449 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12277 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12295 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12345,9 +12363,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 12351 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12369 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -12356,40 +12374,43 @@ module Tables = struct let _startpos = _startpos_array_ in let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = - let r = -# 2448 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let r = + let _1 = _1_inlined1 in + +# 2448 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Some v) -# 12363 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 12383 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 12368 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12389 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (_2) -# 12376 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12397 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12381 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12402 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12387 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12408 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2408 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2408 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 12393 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12414 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12397,9 +12418,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2449 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2449 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12403 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12424 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12459,9 +12480,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 12465 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12486 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -12469,31 +12490,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2448 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2448 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Some v) -# 12475 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12496 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 12480 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12501 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12486 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12507 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12491 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12512 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2410 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 12497 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12501,9 +12522,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2449 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2449 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12507 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12528 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12575,9 +12596,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 12581 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12602 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -12586,40 +12607,43 @@ module Tables = struct let _startpos = _startpos_array_ in let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = - let r = -# 2448 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let r = + let _1 = _1_inlined1 in + +# 2448 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Some v) -# 12593 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 12616 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 12598 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12622 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (_2) -# 12606 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12630 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12611 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12635 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12617 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12641 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2410 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 12623 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12647 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12627,9 +12651,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2449 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2449 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12633 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12657 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12659,9 +12683,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2451 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2451 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Exp.attr _1 _2 ) -# 12665 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12689 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12677,9 +12701,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (string Location.loc option) = -# 4110 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4110 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 12683 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12707 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12709,9 +12733,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string Location.loc option) = -# 4111 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4111 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Some _2 ) -# 12715 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12739 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12755,9 +12779,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.extension) = -# 4123 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4123 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_2, _3) ) -# 12761 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12785 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12776,9 +12800,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 844 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 844 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 12782 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12806 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -12787,9 +12811,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4125 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4125 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_quotedext ~loc:_sloc _1 ) -# 12793 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12817 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12842,9 +12866,9 @@ module Tables = struct let _v : (Parsetree.extension_constructor) = let attrs = let _1 = _1_inlined3 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 12848 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12872 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined3_ in @@ -12854,9 +12878,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12860 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12884 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let cid = @@ -12865,19 +12889,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12871 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12895 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3449 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3449 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let info = symbol_info _endpos in Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 12881 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12905 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12923,9 +12947,9 @@ module Tables = struct let _v : (Parsetree.extension_constructor) = let attrs = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 12929 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12953 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined2_ in @@ -12935,9 +12959,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12941 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12965 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let cid = @@ -12945,25 +12969,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12951 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12975 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_cid_ = _startpos__1_ in let _1 = -# 3928 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3928 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( () ) -# 12958 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12982 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos_cid_ in let _sloc = (_symbolstartpos, _endpos) in -# 3449 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3449 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let info = symbol_info _endpos in Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 12967 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 12991 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13010,10 +13034,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4098 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4098 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mark_symbol_docs _sloc; Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 13017 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13029,14 +13053,14 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let params = -# 2199 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2199 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 13035 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13059 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2016 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( params ) -# 13040 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13064 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13077,24 +13101,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 13081 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13105 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13086 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13110 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2201 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2201 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( params ) -# 13092 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13116 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2016 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( params ) -# 13098 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13122 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13117,9 +13141,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2822 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2822 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13123 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13147 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13159,9 +13183,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2824 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2824 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp_constraint ~loc:_sloc _3 _1 ) -# 13165 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13189 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13191,9 +13215,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2849 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2849 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (merloc _endpos__1_ _2) ) -# 13197 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13221 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13238,24 +13262,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2851 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2851 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_constraint ((merloc _endpos__3_ _4), _2) ) -# 13244 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13268 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 13253 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13277 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2852 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2852 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13259 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13283 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13288,12 +13312,12 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2855 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2855 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) ) -# 13297 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13321 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13344,17 +13368,17 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _3 = -# 2723 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2723 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13350 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13374 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2860 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2860 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_newtypes ~loc:_sloc _3 _5 ) -# 13358 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13382 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13377,9 +13401,9 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.core_type) = -# 3565 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3565 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ty ) -# 13383 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13407 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13425,19 +13449,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 1002 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1002 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13431 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13455 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let label = -# 3577 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3577 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Optional label ) -# 13436 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13460 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3571 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3571 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13441 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13465 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13445,15 +13469,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13451 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13475 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3573 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3573 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13457 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13481 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13500,9 +13524,9 @@ module Tables = struct let _1 : (Parsetree.core_type) = Obj.magic _1 in let _2 : unit = Obj.magic _2 in let label : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 13506 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13530 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -13510,19 +13534,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 1002 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1002 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13516 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let label = -# 3579 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3579 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Labelled label ) -# 13521 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13545 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3571 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3571 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13526 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13550 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13530,15 +13554,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13536 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13560 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3573 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3573 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13542 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13566 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13577,19 +13601,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 1002 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1002 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13583 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13607 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let label = -# 3581 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3581 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Nolabel ) -# 13588 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13612 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3571 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3571 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13593 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13617 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_codomain_ in @@ -13597,15 +13621,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13603 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13627 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3573 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3573 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13609 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13633 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13636,9 +13660,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Lexing.position * Parsetree.functor_parameter) = let _startpos = _startpos__1_ in -# 1393 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1393 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _startpos, Unit ) -# 13642 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13666 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13694,16 +13718,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 13700 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13724 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1396 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1396 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _startpos, Named (x, mty) ) -# 13707 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13731 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13726,9 +13750,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1385 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1385 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13732 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13756 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13743,11 +13767,11 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in - let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3364 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3364 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ([],Pcstr_tuple [],None) ) -# 13751 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13775 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13776,11 +13800,11 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in - let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3365 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3365 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ([],_2,None) ) -# 13784 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13808 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13823,11 +13847,11 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in - let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3367 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3367 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ([],_2,Some _4) ) -# 13831 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13855 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13884,30 +13908,30 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__6_ in - let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = let _2 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 13894 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13918 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1106 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1106 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13899 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13923 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3500 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3500 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13905 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13929 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3370 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3370 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_2,_4,Some _6) ) -# 13911 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13935 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13936,11 +13960,11 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in - let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3372 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3372 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ([],Pcstr_tuple [],Some _2) ) -# 13944 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 13968 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13983,30 +14007,30 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in - let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + let _v : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = let _2 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 13993 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14017 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1106 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1106 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13998 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14022 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3500 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3500 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14004 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14028 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3374 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3374 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_2,Pcstr_tuple [],Some _4) ) -# 14010 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14034 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14043,21 +14067,21 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : (Parsetree.attributes) = Obj.magic _1_inlined2 in - let vars_args_res : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + let vars_args_res : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic vars_args_res in let _1_inlined1 : (string) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined2_ in - let _v : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let _v : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = let attrs = + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = let attrs = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14061 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14085 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined2_ in @@ -14067,23 +14091,23 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14073 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14097 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3312 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3312 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let info = symbol_info _endpos in let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 14087 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14111 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14114,20 +14138,20 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in - let vars_args_res : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + let vars_args_res : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic vars_args_res in let _1 : (string) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined1_ in - let _v : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let _v : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = let attrs = + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = let attrs = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14131 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14155 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined1_ in @@ -14136,29 +14160,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14142 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_cid_ = _startpos__1_ in let _1 = -# 3928 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3928 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( () ) -# 14149 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14173 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos_cid_ in let _sloc = (_symbolstartpos, _endpos) in -# 3312 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3312 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let info = symbol_info _endpos in let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 14162 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14186 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14229,9 +14253,9 @@ module Tables = struct let _2 : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic _2 in let _1_inlined3 : unit = Obj.magic _1_inlined3 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 14235 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14259 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -14244,9 +14268,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined4 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14250 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14274 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14255,54 +14279,57 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14259 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14283 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1088 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14264 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14288 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3215 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14270 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14294 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in - let kind_priv_manifest = -# 3250 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let kind_priv_manifest = + let _1 = _1_inlined3 in + +# 3250 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 14276 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 14302 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let id = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14286 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14313 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let flag = -# 3948 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3948 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 14292 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14319 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14299 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14326 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3187 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3187 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14311,7 +14338,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14315 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14342 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14388,9 +14415,9 @@ module Tables = struct let _2 : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic _2 in let _1_inlined4 : unit = Obj.magic _1_inlined4 in let _1_inlined3 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 14394 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14421 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined3 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined2 : unit = Obj.magic _1_inlined2 in @@ -14404,9 +14431,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined5 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14410 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14437 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined5_ in @@ -14415,60 +14442,63 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14419 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14446 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1088 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14424 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14451 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3215 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14430 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14457 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in - let kind_priv_manifest = -# 3250 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let kind_priv_manifest = + let _1 = _1_inlined4 in + +# 3250 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 14436 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 14465 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let id = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14446 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14476 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let flag = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos__1_inlined2_) in + let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3950 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3950 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 14457 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14487 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14465 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14495 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3187 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3187 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14477,7 +14507,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14481 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14541,9 +14571,9 @@ module Tables = struct let xs : ((Parsetree.core_type * Parsetree.core_type * Warnings.loc) list) = Obj.magic xs in let kind_priv_manifest : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic kind_priv_manifest in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 14547 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14577 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -14556,9 +14586,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14562 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14592 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -14567,18 +14597,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14571 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14601 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1088 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14576 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14606 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3215 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14582 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14612 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let id = @@ -14587,29 +14617,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14593 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14623 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let flag = -# 3944 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3944 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 14599 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14629 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14606 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14636 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3187 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3187 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14618,7 +14648,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14622 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14652 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14688,9 +14718,9 @@ module Tables = struct let xs : ((Parsetree.core_type * Parsetree.core_type * Warnings.loc) list) = Obj.magic xs in let kind_priv_manifest : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic kind_priv_manifest in let _1_inlined3 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 14694 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14724 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined3 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined2 : unit = Obj.magic _1_inlined2 in @@ -14704,9 +14734,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined4 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14710 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14740 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14715,18 +14745,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14719 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14749 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1088 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14724 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14754 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3215 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14730 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14760 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let id = @@ -14735,29 +14765,32 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14741 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14771 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in - let flag = -# 3945 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let flag = + let _1 = _1_inlined2 in + +# 3945 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Nonrecursive ) -# 14747 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 14779 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14754 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14787 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3187 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3187 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14766,7 +14799,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14770 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14785,17 +14818,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 14791 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14824 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3765 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3765 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14799 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14832 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14814,17 +14847,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 14820 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14853 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3766 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3766 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14828 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14861 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14854,9 +14887,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.structure) = -# 1259 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1259 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14860 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14893 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14872,9 +14905,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (string) = -# 3817 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3817 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "" ) -# 14878 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14904,9 +14937,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3818 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3818 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ";.." ) -# 14910 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14943 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14936,9 +14969,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.signature) = -# 1266 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1266 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14942 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 14975 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14982,9 +15015,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.extension) = -# 4128 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4128 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_2, _3) ) -# 14988 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15021 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15003,9 +15036,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 847 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 847 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 15009 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15042 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15014,9 +15047,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_quotedext ~loc:_sloc _1 ) -# 15020 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15053 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15061,17 +15094,17 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 15065 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15098 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1088 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 15070 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc_tag_ = (_startpos_tag_, _endpos_tag_) in -# 2680 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2680 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let children = let children, loc = mktailexp _loc_tag_ [] in @@ -15079,7 +15112,7 @@ module Tables = struct in Jsx_helper.make_jsx_element () ~raise:raise_error ~loc:_loc_tag_ ~tag ~end_tag:None ~props ~children ) -# 15083 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15116 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15146,12 +15179,12 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 15150 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15183 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1088 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 15155 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15188 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos_children_, _startpos_children_) = (_endpos_xs_inlined1_, _startpos_xs_inlined1_) in @@ -15159,19 +15192,19 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 15163 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15196 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1088 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 15168 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15201 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc_tag_ = (_startpos_tag_, _endpos_tag_) in let _loc_end_tag__ = (_startpos_end_tag__, _endpos_end_tag__) in let _loc_children_ = (_startpos_children_, _endpos_children_) in -# 2688 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2688 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let children = let children, loc = mktailexp _loc_children_ children in @@ -15181,7 +15214,7 @@ module Tables = struct Jsx_helper.make_jsx_element () ~raise:raise_error ~loc:_loc_tag_ ~tag ~end_tag:(Some (end_tag, _loc_end_tag__)) ~props ~children ) -# 15185 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15218 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15200,9 +15233,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let id : ( -# 857 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 857 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15206 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15239 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic id in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_id_ in @@ -15211,9 +15244,9 @@ module Tables = struct let _symbolstartpos = _startpos_id_ in let _sloc = (_symbolstartpos, _endpos) in -# 3849 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3849 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( `Module, _sloc, Lident id ) -# 15217 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15250 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15232,9 +15265,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let id : ( -# 803 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15238 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15271 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic id in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_id_ in @@ -15243,9 +15276,9 @@ module Tables = struct let _symbolstartpos = _startpos_id_ in let _sloc = (_symbolstartpos, _endpos) in -# 3850 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3850 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( `Value, _sloc, Lident id ) -# 15249 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15282 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15278,9 +15311,9 @@ module Tables = struct let id : (Longident.t) = Obj.magic id in let _2 : unit = Obj.magic _2 in let prefix : ( -# 857 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 857 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15284 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15317 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic prefix in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_prefix_ in @@ -15289,7 +15322,7 @@ module Tables = struct let _symbolstartpos = _startpos_prefix_ in let _sloc = (_symbolstartpos, _endpos) in -# 3851 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3851 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let rec rebase = function | Lident id -> Ldot (Lident prefix, id) @@ -15297,7 +15330,7 @@ module Tables = struct | Lapply _ -> assert false in `Module, _sloc, rebase id ) -# 15301 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15334 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15330,9 +15363,9 @@ module Tables = struct let id : (Longident.t) = Obj.magic id in let _2 : unit = Obj.magic _2 in let prefix : ( -# 857 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 857 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15336 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15369 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic prefix in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_prefix_ in @@ -15341,7 +15374,7 @@ module Tables = struct let _symbolstartpos = _startpos_prefix_ in let _sloc = (_symbolstartpos, _endpos) in -# 3858 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3858 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let rec rebase = function | Lident id -> Ldot (Lident prefix, id) @@ -15349,7 +15382,7 @@ module Tables = struct | Lapply _ -> assert false in `Value, _sloc, rebase id ) -# 15353 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15386 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15368,9 +15401,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let id : ( -# 858 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 858 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15374 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15407 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic id in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_id_ in @@ -15379,9 +15412,9 @@ module Tables = struct let _symbolstartpos = _startpos_id_ in let _sloc = (_symbolstartpos, _endpos) in -# 3849 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3849 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( `Module, _sloc, Lident id ) -# 15385 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15418 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15400,9 +15433,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let id : ( -# 804 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 804 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15406 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15439 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic id in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_id_ in @@ -15411,9 +15444,9 @@ module Tables = struct let _symbolstartpos = _startpos_id_ in let _sloc = (_symbolstartpos, _endpos) in -# 3850 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3850 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( `Value, _sloc, Lident id ) -# 15417 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15450 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15446,9 +15479,9 @@ module Tables = struct let id : (Longident.t) = Obj.magic id in let _2 : unit = Obj.magic _2 in let prefix : ( -# 858 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 858 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15452 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15485 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic prefix in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_prefix_ in @@ -15457,7 +15490,7 @@ module Tables = struct let _symbolstartpos = _startpos_prefix_ in let _sloc = (_symbolstartpos, _endpos) in -# 3851 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3851 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let rec rebase = function | Lident id -> Ldot (Lident prefix, id) @@ -15465,7 +15498,7 @@ module Tables = struct | Lapply _ -> assert false in `Module, _sloc, rebase id ) -# 15469 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15502 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15498,9 +15531,9 @@ module Tables = struct let id : (Longident.t) = Obj.magic id in let _2 : unit = Obj.magic _2 in let prefix : ( -# 858 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 858 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15504 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15537 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic prefix in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_prefix_ in @@ -15509,7 +15542,7 @@ module Tables = struct let _symbolstartpos = _startpos_prefix_ in let _sloc = (_symbolstartpos, _endpos) in -# 3858 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3858 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let rec rebase = function | Lident id -> Ldot (Lident prefix, id) @@ -15517,7 +15550,7 @@ module Tables = struct | Lapply _ -> assert false in `Value, _sloc, rebase id ) -# 15521 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15554 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15536,9 +15569,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let name : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15542 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic name in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_name_ in @@ -15549,9 +15582,9 @@ module Tables = struct | `Prop_opt_punned of string | `Prop_punned of string ]) = let _loc_name_ = (_startpos_name_, _endpos_name_) in -# 2699 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2699 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _loc_name_, `Prop_punned name ) -# 15555 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15588 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15576,9 +15609,9 @@ module Tables = struct }; } = _menhir_stack in let name : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15582 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15615 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic name in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -15590,9 +15623,9 @@ module Tables = struct | `Prop_opt_punned of string | `Prop_punned of string ]) = let _loc_name_ = (_startpos_name_, _endpos_name_) in -# 2700 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2700 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _loc_name_, `Prop_opt_punned name ) -# 15596 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15629 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15625,9 +15658,9 @@ module Tables = struct let expr : (Parsetree.expression) = Obj.magic expr in let _2 : unit = Obj.magic _2 in let name : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15631 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15664 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic name in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_name_ in @@ -15638,9 +15671,9 @@ module Tables = struct | `Prop_opt_punned of string | `Prop_punned of string ]) = let _loc_name_ = (_startpos_name_, _endpos_name_) in -# 2701 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2701 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _loc_name_, `Prop (name, expr) ) -# 15644 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15677 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15679,9 +15712,9 @@ module Tables = struct let expr : (Parsetree.expression) = Obj.magic expr in let _3 : unit = Obj.magic _3 in let name : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15685 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15718 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic name in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -15693,9 +15726,9 @@ module Tables = struct | `Prop_opt_punned of string | `Prop_punned of string ]) = let _loc_name_ = (_startpos_name_, _endpos_name_) in -# 2702 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2702 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _loc_name_, `Prop_opt (name, expr) ) -# 15699 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15732 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15741,9 +15774,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _3 : unit = Obj.magic _3 in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15747 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15780 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _1 : (Asttypes.mutable_flag) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -15752,34 +15785,34 @@ module Tables = struct let _v : (Parsetree.label_declaration) = let _5 = let _1 = _1_inlined3 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15758 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15791 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 3518 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15767 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15800 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15775 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15808 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15783 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15816 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15790,10 +15823,10 @@ module Tables = struct _startpos__2_ in let _sloc = (_symbolstartpos, _endpos) in -# 3391 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3391 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let info = symbol_info _endpos in Type.field _2 _4 ~mut:_1 ~attrs:_5 ~loc:(make_loc _sloc) ~info ) -# 15797 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15830 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15853,9 +15886,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _3 : unit = Obj.magic _3 in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 15859 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15892 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _1 : (Asttypes.mutable_flag) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -15864,43 +15897,43 @@ module Tables = struct let _v : (Parsetree.label_declaration) = let _7 = let _1 = _1_inlined4 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15870 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15903 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__7_ = _endpos__1_inlined4_ in let _5 = let _1 = _1_inlined3 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15879 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15912 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 3518 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15888 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15921 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15896 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15929 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15904 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15911,14 +15944,14 @@ module Tables = struct _startpos__2_ in let _sloc = (_symbolstartpos, _endpos) in -# 3396 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3396 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__5_ with | Some _ as info_before_semi -> info_before_semi | None -> symbol_info _endpos in Type.field _2 _4 ~mut:_1 ~attrs:(_5 @ _7) ~loc:(make_loc _sloc) ~info ) -# 15922 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15955 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15941,9 +15974,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.label_declaration list) = -# 3385 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3385 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [_1] ) -# 15947 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 15980 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15966,9 +15999,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.label_declaration list) = -# 3386 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3386 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [_1] ) -# 15972 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16005 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15998,9 +16031,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.label_declaration list) = -# 3387 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3387 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 :: _2 ) -# 16004 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16019,9 +16052,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16025 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16058 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -16032,24 +16065,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 16038 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16071 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2394 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2394 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 16047 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16080 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2386 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2386 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x ) -# 16053 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16086 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16082,9 +16115,9 @@ module Tables = struct let cty : (Parsetree.core_type) = Obj.magic cty in let _2 : unit = Obj.magic _2 in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16088 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16121 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -16095,18 +16128,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 16101 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16134 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2394 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2394 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 16110 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16143 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_x_ = _startpos__1_ in @@ -16114,11 +16147,11 @@ module Tables = struct let _symbolstartpos = _startpos_x_ in let _sloc = (_symbolstartpos, _endpos) in -# 2388 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2388 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let lab, pat = x in lab, mkpat ~loc:_sloc (Ppat_constraint (pat, cty)) ) -# 16122 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16155 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16141,9 +16174,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3867 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3867 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16147 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16180 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16166,9 +16199,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.arg_label * Parsetree.expression) = -# 2706 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2706 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Nolabel, _1) ) -# 16172 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16205 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16194,17 +16227,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 788 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 788 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16200 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16233 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.arg_label * Parsetree.expression) = -# 2708 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2708 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Labelled _1, _2) ) -# 16208 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16241 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16229,9 +16262,9 @@ module Tables = struct }; } = _menhir_stack in let label : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16235 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16268 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -16239,10 +16272,10 @@ module Tables = struct let _endpos = _endpos_label_ in let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2710 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2710 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = _loc_label_ in (Labelled label, mkexpvar ~loc label) ) -# 16246 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16279 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16287,9 +16320,9 @@ module Tables = struct let _5 : unit = Obj.magic _5 in let ty : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic ty in let label : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16293 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16326 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _2 : unit = Obj.magic _2 in let _1 : unit = Obj.magic _1 in @@ -16299,10 +16332,10 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression) = let _endpos = _endpos__5_ in let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2713 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2713 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Labelled label, mkexp_constraint ~loc:(_startpos__2_, _endpos) (mkexpvar ~loc:_loc_label_ label) ty) ) -# 16306 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16339 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16327,9 +16360,9 @@ module Tables = struct }; } = _menhir_stack in let label : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16333 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16366 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -16337,10 +16370,10 @@ module Tables = struct let _endpos = _endpos_label_ in let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2716 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2716 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = _loc_label_ in (Optional label, mkexpvar ~loc label) ) -# 16344 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16377 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16366,17 +16399,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 821 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 821 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16372 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16405 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.arg_label * Parsetree.expression) = -# 2719 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2719 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Optional _1, _2) ) -# 16380 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16413 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16429,15 +16462,15 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 = let _1 = _1_inlined1 in -# 2382 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2382 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16435 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16468 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2356 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2356 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Optional (fst _3), _4, snd _3) ) -# 16441 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16474 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16462,9 +16495,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16468 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16501 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -16477,24 +16510,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 16483 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16516 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2394 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2394 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 16492 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16525 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2358 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2358 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Optional (fst _2), None, snd _2) ) -# 16498 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16531 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16541,9 +16574,9 @@ module Tables = struct let _3 : (Parsetree.pattern) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 821 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 821 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16547 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16580 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -16551,15 +16584,15 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 = let _1 = _1_inlined1 in -# 2382 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2382 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16557 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16590 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2360 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2360 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Optional _1, _4, _3) ) -# 16563 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16596 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16585,17 +16618,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.pattern) = Obj.magic _2 in let _1 : ( -# 821 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 821 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16591 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16624 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2362 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2362 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Optional _1, None, _2) ) -# 16599 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16632 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16639,9 +16672,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2364 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2364 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Labelled (fst _3), None, snd _3) ) -# 16645 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16678 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16666,9 +16699,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16672 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16705 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -16681,24 +16714,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 16687 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2394 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2394 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 16696 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16729 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2366 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2366 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Labelled (fst _2), None, snd _2) ) -# 16702 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16735 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16724,17 +16757,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.pattern) = Obj.magic _2 in let _1 : ( -# 788 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 788 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 16730 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16763 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2368 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2368 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Labelled _1, None, _2) ) -# 16738 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16771 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16757,9 +16790,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2370 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2370 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Nolabel, None, _1) ) -# 16763 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16796 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16784,9 +16817,9 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option * bool) = -# 2759 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2759 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let p,e,c = _1 in (p,e,c,false) ) -# 16790 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16823 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16813,9 +16846,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2762 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2762 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1, None, true) ) -# 16819 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16852 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16850,15 +16883,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2726 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2726 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16856 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16889 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2730 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2730 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_1, _2, None) ) -# 16862 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16895 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16907,13 +16940,13 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2726 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2726 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16913 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16946 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2732 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2732 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let v = _1 in (* PR#7344 *) let t = match _2 with @@ -16924,7 +16957,7 @@ module Tables = struct in (v, _4, Some t) ) -# 16928 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 16961 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16990,29 +17023,30 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = let _3 = + let _2 = _2_inlined1 in let _1 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 16999 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17033 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1106 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1106 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 17004 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17038 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3500 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3500 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17010 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17044 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3504 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3504 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 17016 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17050 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__3_ = _startpos_xs_ in @@ -17021,19 +17055,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2726 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2726 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 17027 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17061 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let t = ghtyp ~loc:(_loc__3_) _3 in (_1, _5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) ) -# 17037 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17071 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17106,27 +17140,27 @@ module Tables = struct let _endpos = _endpos__8_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = let _4 = -# 2723 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2723 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 17112 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17146 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2726 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2726 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 17121 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17155 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2748 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2748 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let constraint' = Pvc_constraint { locally_abstract_univars=_4; typ = _6} in (_1, _8, Some constraint') ) -# 17130 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17164 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17164,9 +17198,9 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = -# 2753 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2753 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_1, _3, None) ) -# 17170 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17204 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17218,9 +17252,9 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = -# 2755 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2755 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_1, _5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=_3 })) ) -# 17224 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17258 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17282,36 +17316,36 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17288 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17322 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17297 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17331 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 17309 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17343 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2772 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2772 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17315 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17349 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17341,9 +17375,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 2773 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2773 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 17347 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17381 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17398,41 +17432,41 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17404 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17413 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17447 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let ext = -# 4114 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4114 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 17419 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17453 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 17430 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17464 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2772 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2772 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17436 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17470 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17501,47 +17535,47 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17507 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17541 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let attrs1 = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17516 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17550 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let ext = - let _startpos__1_ = _startpos__1_inlined1_ in + let (_startpos__1_, _1) = (_startpos__1_inlined1_, _1_inlined1) in let _endpos = _endpos__2_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4116 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4116 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "extension"; None ) -# 17527 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17561 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 17539 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17573 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2772 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2772 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17545 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17579 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17571,9 +17605,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 2773 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2773 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 17577 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17611 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17596,9 +17630,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2398 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2398 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17602 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17636 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17636,24 +17670,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2400 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2400 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_1, _3) ) -# 17642 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17676 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 17651 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17685 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2401 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2401 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17657 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17691 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17687,15 +17721,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2726 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2726 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 17693 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17727 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2799 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2799 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (pat, exp) ) -# 17699 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17733 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17721,9 +17755,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1) ) -# 17727 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17761 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17774,10 +17808,10 @@ module Tables = struct let _startpos = _startpos_pat_ in let _endpos = _endpos_exp_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2804 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2804 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = (_startpos_pat_, _endpos_typ_) in (ghpat ~loc (Ppat_constraint(pat, typ)), exp) ) -# 17781 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17815 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17814,9 +17848,9 @@ module Tables = struct let _startpos = _startpos_pat_ in let _endpos = _endpos_exp_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2807 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2807 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (pat, exp) ) -# 17820 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17854 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17839,10 +17873,10 @@ module Tables = struct let _startpos = _startpos_body_ in let _endpos = _endpos_body_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = -# 2811 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2811 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let let_pat, let_exp = body in let_pat, let_exp, [] ) -# 17846 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17880 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17874,9 +17908,9 @@ module Tables = struct } = _menhir_stack in let body : (Parsetree.pattern * Parsetree.expression) = Obj.magic body in let _1 : ( -# 784 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 784 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 17880 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17914 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let bindings : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = Obj.magic bindings in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -17887,22 +17921,22 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17893 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17927 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_body_ in let _symbolstartpos = _startpos_bindings_ in let _sloc = (_symbolstartpos, _endpos) in -# 2814 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2814 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let let_pat, let_exp, rev_ands = bindings in let pbop_pat, pbop_exp = body in let pbop_loc = make_loc _sloc in let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_loc} in let_pat, let_exp, and_ :: rev_ands ) -# 17906 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17940 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17920,7 +17954,7 @@ module Tables = struct let _v : (Parsetree.class_expr Parsetree.class_infos list) = # 211 "" ( [] ) -# 17924 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 17958 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17984,9 +18018,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 17990 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18024 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -17999,9 +18033,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18005 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18011,24 +18045,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18017 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18025 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18059 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1994 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1994 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -18036,13 +18070,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs ) -# 18040 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18074 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18046 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18080 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18060,7 +18094,7 @@ module Tables = struct let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 18064 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18098 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18131,9 +18165,9 @@ module Tables = struct let cty : (Parsetree.class_type) = Obj.magic cty in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 18137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18171 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -18146,9 +18180,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18152 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18186 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18158,24 +18192,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18164 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18198 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18172 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18206 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2293 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2293 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -18183,13 +18217,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs ) -# 18187 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18221 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18193 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18227 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18207,7 +18241,7 @@ module Tables = struct let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 18211 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18245 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18278,9 +18312,9 @@ module Tables = struct let csig : (Parsetree.class_type) = Obj.magic csig in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 18284 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18318 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -18293,9 +18327,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18299 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18333 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18305,24 +18339,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18311 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18345 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18319 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18353 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2332 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2332 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -18330,13 +18364,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs ) -# 18334 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18368 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18340 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18374 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18354,7 +18388,7 @@ module Tables = struct let _v : (Parsetree.module_binding list) = # 211 "" ( [] ) -# 18358 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18392 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18415,9 +18449,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18421 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18455 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18427,24 +18461,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18433 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18467 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18441 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18475 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1640 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1640 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in @@ -18452,13 +18486,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Mb.mk name body ~attrs ~loc ~text ~docs ) -# 18456 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18490 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18462 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18496 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18476,7 +18510,7 @@ module Tables = struct let _v : (Parsetree.module_declaration list) = # 211 "" ( [] ) -# 18480 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18514 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18544,9 +18578,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18550 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18584 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18556,24 +18590,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18562 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18596 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18570 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18604 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1935 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1935 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let docs = symbol_docs _sloc in @@ -18581,13 +18615,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Md.mk name mty ~attrs ~loc ~text ~docs ) -# 18585 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18619 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18591 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18625 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18605,7 +18639,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 18609 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18643 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18637,7 +18671,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 18641 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18675 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18655,7 +18689,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 18659 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18693 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18720,9 +18754,9 @@ module Tables = struct let xs_inlined1 : ((Parsetree.core_type * Parsetree.core_type * Warnings.loc) list) = Obj.magic xs_inlined1 in let kind_priv_manifest : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic kind_priv_manifest in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 18726 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18760 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -18735,9 +18769,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18741 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18775 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18746,18 +18780,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18750 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18784 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1088 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 18755 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18789 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3215 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18761 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18795 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let id = @@ -18766,24 +18800,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18772 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18806 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18780 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18814 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3204 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3204 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -18792,13 +18826,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18796 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18830 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18802 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18816,7 +18850,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 18820 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18854 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18888,9 +18922,9 @@ module Tables = struct let _2 : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = Obj.magic _2 in let _1_inlined3 : unit = Obj.magic _1_inlined3 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 18894 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18928 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -18903,9 +18937,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18909 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18943 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -18914,49 +18948,52 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18918 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18952 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1088 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 18923 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18957 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3215 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18929 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in - let kind_priv_manifest = -# 3250 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let kind_priv_manifest = + let _1 = _1_inlined3 in + +# 3250 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 18935 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 18971 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let id = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18945 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18982 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18953 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 18990 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3204 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3204 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -18965,13 +19002,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18969 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19006 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18975 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19012 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18989,7 +19026,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 18993 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19030 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19021,7 +19058,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 19025 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19039,7 +19076,7 @@ module Tables = struct let _v : (Parsetree.signature_item list list) = # 211 "" ( [] ) -# 19043 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19080 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19072,21 +19109,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1014 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1014 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_sig _startpos ) -# 19078 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19115 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1788 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1788 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19084 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19121 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19090 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19127 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19119,21 +19156,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1012 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1012 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_sig _startpos @ [_1] ) -# 19125 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19162 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1788 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1788 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19131 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19168 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19151,7 +19188,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 19155 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19192 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19184,40 +19221,40 @@ module Tables = struct let _1 = let ys = let items = -# 1074 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1074 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 19190 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19227 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1519 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1519 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( items ) -# 19195 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19232 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let xs = let _startpos = _startpos__1_ in -# 1010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_str _startpos ) -# 19203 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 19209 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19246 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1535 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1535 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19215 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19252 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19221 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19258 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19269,70 +19306,70 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19275 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19312 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1526 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1526 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 19280 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19317 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1008 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1008 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 19288 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19325 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1027 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1027 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 19298 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19335 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1076 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x ) -# 19304 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19341 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1519 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1519 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( items ) -# 19310 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19347 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let xs = let _startpos = _startpos__1_ in -# 1010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_str _startpos ) -# 19318 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19355 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 19324 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19361 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1535 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1535 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19330 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19367 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19336 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19373 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19365,21 +19402,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1008 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1008 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 19371 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19408 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1535 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1535 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19377 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19414 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19383 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19420 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19397,7 +19434,7 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = # 211 "" ( [] ) -# 19401 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19429,15 +19466,15 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = let x = let _startpos = _startpos__1_ in -# 1022 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1022 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_csig _startpos @ [_1] ) -# 19435 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19472 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19441 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19478 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19455,7 +19492,7 @@ module Tables = struct let _v : (Parsetree.class_field list list) = # 211 "" ( [] ) -# 19459 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19496 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19487,15 +19524,15 @@ module Tables = struct let _v : (Parsetree.class_field list list) = let x = let _startpos = _startpos__1_ in -# 1020 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1020 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_cstr _startpos @ [_1] ) -# 19493 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19530 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19499 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19536 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19513,7 +19550,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 19517 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19554 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19545,15 +19582,15 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = let x = let _startpos = _startpos__1_ in -# 1008 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1008 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 19551 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19588 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19557 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19594 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19571,7 +19608,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = # 211 "" ( [] ) -# 19575 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19612 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19604,32 +19641,32 @@ module Tables = struct let _1 = let x = let _1 = -# 1074 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1074 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 19610 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19647 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1306 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1306 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19615 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19652 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 19621 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19658 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1318 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1318 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19627 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19664 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19633 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19670 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19681,58 +19718,58 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19687 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19724 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1526 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1526 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 19692 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19729 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1018 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1018 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 19698 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19735 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1016 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19706 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1076 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x ) -# 19712 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19749 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1306 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1306 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19718 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19755 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 19724 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19761 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1318 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1318 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19730 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19767 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19736 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19773 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19764,27 +19801,27 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = let x = let _1 = let _1 = -# 1018 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1018 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 19770 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19807 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1016 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19776 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19813 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1318 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1318 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19782 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19819 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19788 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19825 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19819,29 +19856,29 @@ module Tables = struct let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1027 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1027 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 19826 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19863 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1016 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19833 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19870 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1318 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1318 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19839 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19876 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19845 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19882 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19880,7 +19917,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 124 "" ( None ) -# 19884 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19921 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -19888,9 +19925,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19894 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19931 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19898,7 +19935,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3090 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3090 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19912,13 +19949,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19916 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19953 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1243 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1243 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x], None ) -# 19922 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 19959 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19964,7 +20001,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 126 "" ( Some x ) -# 19968 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20005 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -19972,9 +20009,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19978 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20015 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19982,7 +20019,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3090 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3090 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19996,13 +20033,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 20000 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1243 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1243 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x], None ) -# 20006 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20043 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20065,9 +20102,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20071 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20108 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -20075,7 +20112,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3090 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3090 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -20089,13 +20126,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 20093 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1245 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1245 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x], Some y ) -# 20099 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20136 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20151,9 +20188,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20157 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20194 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -20161,7 +20198,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3090 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3090 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -20175,14 +20212,14 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 20179 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20216 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1249 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1249 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let xs, y = tail in x :: xs, y ) -# 20186 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20223 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20243,9 +20280,9 @@ module Tables = struct let _v : (Ast_helper.let_bindings) = let _5 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20249 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20286 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -20253,23 +20290,23 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20259 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20296 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 20265 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20302 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__4_ = (_startpos__4_, _endpos__4_) in -# 4154 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4154 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (ext, attr) = _2 in mklbs ext _3 (mklb ~loc:_loc__4_ true _4 (attr@_5)) ) -# 20273 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20310 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20292,9 +20329,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Ast_helper.let_bindings) = -# 4158 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4158 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20298 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20335 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20324,9 +20361,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 4159 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4159 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 20330 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20367 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20363,9 +20400,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.case) = -# 2840 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2840 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 (merloc _endpos__2_ _3) ) -# 20369 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20406 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20416,9 +20453,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.case) = -# 2842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 ~guard:(merloc _endpos__2_ _3) (merloc _endpos__4_ _5) ) -# 20422 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20459 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20456,10 +20493,10 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.case) = let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2844 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2844 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 (merloc _endpos__2_ (Exp.unreachable ~loc:(make_loc _loc__3_) ())) ) -# 20463 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20500 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20520,9 +20557,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 20526 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20563 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20531,49 +20568,49 @@ module Tables = struct let _6 = let _1 = _1_inlined3 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20537 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20574 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20546 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20583 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3518 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20555 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20592 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20562 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20599 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20570 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20607 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3728 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3728 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__4_ with | Some _ as info_before_semi -> info_before_semi @@ -20581,13 +20618,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20585 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20622 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3709 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3709 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (f, c) = tail in (head :: f, c) ) -# 20591 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20628 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20628,15 +20665,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3739 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3739 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20634 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20671 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3709 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3709 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (f, c) = tail in (head :: f, c) ) -# 20640 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20677 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20690,9 +20727,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 20696 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20733 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20701,49 +20738,49 @@ module Tables = struct let _6 = let _1 = _1_inlined3 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20707 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20744 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20716 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20753 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3518 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20725 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20762 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20732 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20769 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20740 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20777 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3728 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3728 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__4_ with | Some _ as info_before_semi -> info_before_semi @@ -20751,13 +20788,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20755 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3712 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3712 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20761 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20798 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20791,15 +20828,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3739 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3739 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20797 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20834 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3712 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3712 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20803 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20840 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20839,9 +20876,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 20845 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20882 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20850,50 +20887,50 @@ module Tables = struct let _4 = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20856 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20893 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3518 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20865 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20902 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20872 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20909 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20880 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20917 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3721 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3721 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let info = symbol_info _endpos in let attrs = add_info_attrs info _4 in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20891 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20928 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3715 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3715 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20897 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20934 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20920,15 +20957,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3739 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3739 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20926 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3715 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3715 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20932 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20969 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20951,9 +20988,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.object_field list * Asttypes.closed_flag) = -# 3717 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3717 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [], Open ) -# 20957 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 20994 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20998,9 +21035,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21004 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let private_ : (Asttypes.private_flag) = Obj.magic private_ in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -21011,41 +21048,41 @@ module Tables = struct Parsetree.attributes) = let ty = let _1 = _1_inlined2 in -# 3514 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3514 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21017 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21054 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let label = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21025 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21033 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21070 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs = -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21039 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4006 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4006 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 21044 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21081 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (label, private_, Cfk_virtual ty), attrs ) -# 21049 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21086 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21083,9 +21120,9 @@ module Tables = struct } = _menhir_stack in let _5 : (Parsetree.expression) = Obj.magic _5 in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21089 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -21096,36 +21133,36 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21102 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21139 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21110 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21147 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21116 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21153 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 21121 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21158 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2140 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2140 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let e = _5 in let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in (_4, _3, Cfk_concrete (_1, ghexp ~loc (Pexp_poly (e, None)))), _2 ) -# 21129 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21169,9 +21206,9 @@ module Tables = struct } = _menhir_stack in let _5 : (Parsetree.expression) = Obj.magic _5 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21175 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21212 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -21183,39 +21220,39 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21189 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21226 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21197 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21234 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21205 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21242 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 21211 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21248 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2140 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2140 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let e = _5 in let loc = Location.(e.pexp_loc.loc_start, e.pexp_loc.loc_end) in (_4, _3, Cfk_concrete (_1, ghexp ~loc (Pexp_poly (e, None)))), _2 ) -# 21219 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21256 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21274,9 +21311,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21280 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21317 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -21287,45 +21324,45 @@ module Tables = struct Parsetree.attributes) = let _6 = let _1 = _1_inlined2 in -# 3514 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3514 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21293 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21330 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__6_ = _startpos__1_inlined2_ in let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21302 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21339 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21310 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21347 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21316 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21353 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 21321 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21358 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2146 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2146 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let poly_exp = let loc = (_startpos__6_, _endpos__8_) in ghexp ~loc (Pexp_poly(_8, Some _6)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21329 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21366 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21390,9 +21427,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21396 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21433 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -21404,48 +21441,48 @@ module Tables = struct Parsetree.attributes) = let _6 = let _1 = _1_inlined3 in -# 3514 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3514 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21410 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21447 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__6_ = _startpos__1_inlined3_ in let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21419 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21456 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21427 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21464 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21435 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21472 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 21441 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21478 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2146 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2146 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let poly_exp = let loc = (_startpos__6_, _endpos__8_) in ghexp ~loc (Pexp_poly(_8, Some _6)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21449 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21486 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21525,9 +21562,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21531 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21568 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -21536,38 +21573,38 @@ module Tables = struct let _endpos = _endpos__11_ in let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) * Parsetree.attributes) = let _7 = -# 2723 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2723 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 21542 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21579 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__7_ = _startpos_xs_ in let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21550 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21587 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21558 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21595 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21565 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21602 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 21571 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21608 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__11_ in @@ -21583,7 +21620,7 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2152 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2152 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in let poly_exp = let exp, poly = @@ -21594,7 +21631,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21598 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21635 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21680,9 +21717,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21686 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21723 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.private_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -21692,41 +21729,41 @@ module Tables = struct let _endpos = _endpos__11_ in let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) * Parsetree.attributes) = let _7 = -# 2723 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2723 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 21698 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21735 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__7_ = _startpos_xs_ in let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21706 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21714 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21751 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21723 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21760 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 21730 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21767 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__11_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -21741,7 +21778,7 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2152 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2152 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in let poly_exp = let exp, poly = @@ -21752,7 +21789,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21756 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21793 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21771,17 +21808,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21777 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21814 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21785 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21822 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21812,9 +21849,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21818 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21855 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : (Longident.t) = Obj.magic _1 in @@ -21822,9 +21859,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3843 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3843 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21828 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21865 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21843,17 +21880,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21849 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21886 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21857 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21894 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21884,9 +21921,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 21890 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21927 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : (Longident.t) = Obj.magic _1 in @@ -21894,9 +21931,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3843 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3843 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21900 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21919,14 +21956,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = let _1 = -# 3900 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3900 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21925 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21930 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 21967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21964,20 +22001,20 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Longident.t) = let _1 = let _1 = -# 3822 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3822 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 21970 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22007 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3900 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3900 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21975 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22012 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21981 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22018 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22000,14 +22037,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = let _1 = -# 3900 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3900 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22006 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22043 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 22011 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22048 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22046,15 +22083,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let _1 = _1_inlined1 in -# 3900 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3900 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22052 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22089 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3843 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3843 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 22058 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22095 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22105,21 +22142,22 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = let _3 = + let (_2, _1) = (_2_inlined1, _1_inlined1) in let _1 = -# 3822 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3822 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 22112 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22150 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3900 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3900 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22117 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22155 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3843 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3843 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 22123 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22161 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22158,15 +22196,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let _1 = _1_inlined1 in -# 3900 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3900 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22164 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22202 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3843 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3843 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 22170 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22208 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22189,9 +22227,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 22195 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22233 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22228,9 +22266,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3843 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3843 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 22234 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22272 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22249,17 +22287,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 22255 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22293 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 22263 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22301 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22290,9 +22328,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 22296 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22334 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : (Longident.t) = Obj.magic _1 in @@ -22300,9 +22338,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3843 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3843 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 22306 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22344 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22321,17 +22359,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 22327 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22365 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 22335 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22373 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22362,9 +22400,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 22368 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22406 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : (Longident.t) = Obj.magic _1 in @@ -22372,9 +22410,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3843 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3843 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 22378 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22416 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22397,9 +22435,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 22403 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22441 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22436,9 +22474,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3843 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3843 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 22442 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22480 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22461,9 +22499,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3876 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3876 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22467 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22505 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22510,9 +22548,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3878 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3878 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( lapply ~loc:_sloc _1 _3 ) -# 22516 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22554 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22535,9 +22573,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3873 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3873 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22541 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22579 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22567,9 +22605,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = -# 1595 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1595 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( me ) -# 22573 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22611 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22614,24 +22652,24 @@ module Tables = struct let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1602 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1602 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pmod_constraint(me, mty) ) -# 22620 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22658 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_me_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22629 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22667 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1606 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1606 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22635 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22673 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22662,25 +22700,25 @@ module Tables = struct let _endpos = _endpos_body_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1604 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1604 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (_, arg) = arg_and_pos in Pmod_functor(arg, body) ) -# 22669 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22707 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_body_, _startpos_arg_and_pos_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22678 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22716 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1606 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1606 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22684 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22722 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22710,9 +22748,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_mty_ in let _v : (Parsetree.module_type) = -# 1855 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1855 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mty ) -# 22716 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22754 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22743,25 +22781,25 @@ module Tables = struct let _endpos = _endpos_body_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1862 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1862 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (_, arg) = arg_and_pos in Pmty_functor(arg, body) ) -# 22750 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22788 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_body_, _startpos_arg_and_pos_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1049 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1049 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 22759 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22797 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1865 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1865 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22765 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22807,18 +22845,18 @@ module Tables = struct let _v : (Parsetree.module_expr) = let attrs = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22813 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22851 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1419 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1419 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_structure s) ) -# 22822 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22860 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22871,22 +22909,22 @@ module Tables = struct let _v : (Parsetree.module_expr) = let attrs = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22877 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22915 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_me_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1429 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1429 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mod_attrs ~loc:_sloc attrs ( List.fold_left (fun acc (startpos, arg) -> mkmod ~loc:(startpos, _endpos) (Pmod_functor (arg, acc)) ) me args ) ) -# 22890 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22928 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22909,9 +22947,9 @@ module Tables = struct let _startpos = _startpos_me_ in let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = -# 1435 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1435 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( me ) -# 22915 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22953 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22941,9 +22979,9 @@ module Tables = struct let _startpos = _startpos_me_ in let _endpos = _endpos_attr_ in let _v : (Parsetree.module_expr) = -# 1437 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1437 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Mod.attr me attr ) -# 22947 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 22985 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22972,30 +23010,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22978 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1441 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1441 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pmod_ident x ) -# 22984 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23022 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22993 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1456 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1456 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22999 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23026,24 +23064,24 @@ module Tables = struct let _endpos = _endpos_me2_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1444 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1444 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pmod_apply(me1, me2) ) -# 23032 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23070 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_me2_, _startpos_me1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 23041 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23079 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1456 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1456 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23047 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23085 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23081,24 +23119,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1447 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1447 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pmod_apply_unit me ) -# 23087 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23125 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_me_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 23096 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23134 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1456 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1456 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23102 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23140 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23122,24 +23160,24 @@ module Tables = struct let _endpos = _endpos_ex_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1450 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1450 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pmod_extension ex ) -# 23128 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_ex_, _startpos_ex_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 23137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23175 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1456 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1456 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23143 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23181 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23167,25 +23205,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 1453 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1453 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let id = mkrhs Ast_helper.hole_txt _loc in Pmod_extension (id, PStr []) ) -# 23174 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23212 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 23183 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23221 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1456 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1456 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23189 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23227 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23204,17 +23242,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let x : ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 23210 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23248 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic x in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (string option) = -# 1402 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1402 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Some x ) -# 23218 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23256 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23237,9 +23275,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string option) = -# 1405 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1405 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 23243 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23281 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23297,9 +23335,9 @@ module Tables = struct let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 23303 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23341 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in let ext : (string Location.loc option) = Obj.magic ext in @@ -23310,9 +23348,9 @@ module Tables = struct let _v : (Parsetree.module_substitution * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23316 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23354 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -23322,9 +23360,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23328 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23366 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let uid = @@ -23333,31 +23371,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23339 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23377 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23347 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23385 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1895 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1895 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Ms.mk uid body ~attrs ~loc ~docs, ext ) -# 23361 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23399 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23403,18 +23441,18 @@ module Tables = struct let _v : (Parsetree.module_type) = let attrs = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23409 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23447 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1731 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1731 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc ~attrs (Pmty_signature s) ) -# 23418 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23456 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23467,22 +23505,22 @@ module Tables = struct let _v : (Parsetree.module_type) = let attrs = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23473 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_mty_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mty_attrs ~loc:_sloc attrs ( List.fold_left (fun acc (startpos, arg) -> mkmty ~loc:(startpos, _endpos) (Pmty_functor (arg, acc)) ) mty args ) ) -# 23486 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23524 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23535,18 +23573,18 @@ module Tables = struct let _v : (Parsetree.module_type) = let _4 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23541 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23579 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1749 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1749 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc ~attrs:_4 (Pmty_typeof _5) ) -# 23550 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23588 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23583,9 +23621,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.module_type) = -# 1751 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1751 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 23589 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23627 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23615,9 +23653,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_type) = -# 1757 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1757 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Mty.attr _1 _2 ) -# 23621 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23659 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23646,30 +23684,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23652 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23690 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1760 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1760 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pmty_ident _1 ) -# 23658 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23696 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1049 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1049 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23667 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23705 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1773 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1773 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23673 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23711 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23714,24 +23752,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1762 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1762 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pmty_functor(Unit, _4) ) -# 23720 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23758 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1049 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1049 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23729 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23767 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1773 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1773 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23735 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23773 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23769,24 +23807,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1765 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1765 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pmty_functor(Named (mknoloc None, _1), _3) ) -# 23775 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23813 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1049 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1049 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23784 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23822 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1773 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1773 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23790 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23828 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23828,18 +23866,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 23832 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23870 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 23837 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23875 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1767 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1767 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pmty_with(_1, _3) ) -# 23843 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23881 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -23847,15 +23885,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1049 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1049 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23853 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23891 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1773 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1773 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23859 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23897 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23879,23 +23917,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1771 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1771 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pmty_extension _1 ) -# 23885 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23923 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1049 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1049 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23893 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23931 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1773 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1773 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23899 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 23937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23962,9 +24000,9 @@ module Tables = struct let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23968 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24006 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -23974,31 +24012,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23980 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24018 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23988 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24026 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1677 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1677 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Mtd.mk id ?typ ~attrs ~loc ~docs, ext ) -# 24002 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24040 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24072,9 +24110,9 @@ module Tables = struct let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24078 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24116 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -24084,31 +24122,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 24090 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24128 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24098 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24136 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1953 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1953 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Mtd.mk id ~typ ~attrs ~loc ~docs, ext ) -# 24112 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24150 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24131,9 +24169,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3885 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3885 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24175 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24149,9 +24187,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.mutable_flag) = -# 3966 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3966 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Immutable ) -# 24155 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24193 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24174,9 +24212,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag) = -# 3967 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 24180 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24218 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24192,9 +24230,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3975 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3975 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Immutable, Concrete ) -# 24198 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24236 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24217,9 +24255,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3977 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3977 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Mutable, Concrete ) -# 24223 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24261 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24242,9 +24280,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3979 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3979 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Immutable, Virtual ) -# 24248 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24286 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24274,9 +24312,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3982 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3982 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Mutable, Virtual ) -# 24280 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24318 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24306,9 +24344,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3982 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3982 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Mutable, Virtual ) -# 24312 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24350 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24338,9 +24376,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3937 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 24344 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24382 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24359,9 +24397,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 24365 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24403 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -24371,15 +24409,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 24377 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24415 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 221 "" ( [ x ] ) -# 24383 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24421 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24405,9 +24443,9 @@ module Tables = struct } = _menhir_stack in let xs : (string Location.loc list) = Obj.magic xs in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 24411 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24449 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -24417,15 +24455,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 24423 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24461 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 223 "" ( x :: xs ) -# 24429 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24467 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24444,22 +24482,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let s : ( -# 842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 24450 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24488 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic s in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_s_ in let _endpos = _endpos_s_ in let _v : (string list) = let x = -# 3933 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3933 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let body, _, _ = s in body ) -# 24458 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24496 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 221 "" ( [ x ] ) -# 24463 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24501 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24485,22 +24523,22 @@ module Tables = struct } = _menhir_stack in let xs : (string list) = Obj.magic xs in let s : ( -# 842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 24491 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic s in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_s_ in let _endpos = _endpos_xs_ in let _v : (string list) = let x = -# 3933 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3933 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let body, _, _ = s in body ) -# 24499 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24537 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 223 "" ( x :: xs ) -# 24504 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24542 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24523,14 +24561,14 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3962 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24529 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24567 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3224 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3224 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, priv, Some ty) ) -# 24534 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24572 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24560,14 +24598,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3963 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24566 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24604 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3224 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3224 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, priv, Some ty) ) -# 24571 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24609 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24590,26 +24628,26 @@ module Tables = struct let _startpos = _startpos_cs_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3962 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24596 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24634 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24602 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24640 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24607 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24645 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3228 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3228 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24613 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24651 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24639,26 +24677,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3963 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24645 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24683 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24651 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24689 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24656 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24694 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3228 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3228 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24662 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24700 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24695,33 +24733,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3962 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24701 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24739 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24708 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24746 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24713 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24751 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24719 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24757 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3228 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3228 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24725 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24763 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24765,33 +24803,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3963 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24771 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24809 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24778 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24816 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24783 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24821 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24789 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24827 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3228 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3228 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24795 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24833 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24814,26 +24852,26 @@ module Tables = struct let _startpos = _startpos__3_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3962 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24820 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24858 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24826 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24864 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24831 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24869 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3232 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3232 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24837 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24875 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24863,26 +24901,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3963 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24869 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24907 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24875 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24913 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24880 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24918 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3232 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3232 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24886 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24924 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24919,33 +24957,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3962 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24925 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24932 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24970 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24937 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24975 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24943 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24981 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3232 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3232 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24949 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 24987 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24989,33 +25027,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3963 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24995 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25033 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 25002 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25040 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 25007 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25045 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25013 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3232 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3232 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 25019 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25052,26 +25090,26 @@ module Tables = struct let _startpos = _startpos__3_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3962 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public ) -# 25058 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25096 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 25064 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25102 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25069 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3236 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3236 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 25075 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25113 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25115,26 +25153,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3963 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 25121 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25159 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 25127 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25165 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25132 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25170 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3236 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3236 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 25138 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25176 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25185,33 +25223,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3962 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public ) -# 25191 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25229 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 25198 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25236 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 25203 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25241 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25209 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25247 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3236 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3236 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 25215 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25253 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25269,33 +25307,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3963 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 25275 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25313 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 25282 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25320 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 25287 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25325 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3240 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3240 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25293 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25331 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3236 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3236 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 25299 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25337 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25348,37 +25386,37 @@ module Tables = struct let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25354 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25392 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25363 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25401 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let override = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 25369 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25407 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1696 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1696 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Opn.mk me ~override ~attrs ~loc ~docs, ext ) -# 25382 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25420 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25438,37 +25476,40 @@ module Tables = struct let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25444 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25482 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let attrs1 = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25453 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25491 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in - let override = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let override = + let _1 = _1_inlined1 in + +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 25459 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 25499 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1696 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1696 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Opn.mk me ~override ~attrs ~loc ~docs, ext ) -# 25472 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25513 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25521,9 +25562,9 @@ module Tables = struct let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25527 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25568 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -25533,36 +25574,36 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 25539 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25580 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25547 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25588 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let override = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 25553 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25594 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1711 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1711 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Opn.mk id ~override ~attrs ~loc ~docs, ext ) -# 25566 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25607 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25622,9 +25663,9 @@ module Tables = struct let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25628 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -25634,36 +25675,39 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 25640 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25681 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined2 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25648 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25689 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in - let override = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" + let override = + let _1 = _1_inlined1 in + +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 25654 "ocamlmerlin_mlx/preprocess/parser_raw.ml" - in +# 25697 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" + + in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1711 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1711 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Opn.mk id ~override ~attrs ~loc ~docs, ext ) -# 25667 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25711 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25682,17 +25726,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 828 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 828 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 25688 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25732 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3781 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3781 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25696 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25740 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25711,17 +25755,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 783 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 783 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 25717 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25761 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25725 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25769 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25740,17 +25784,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 784 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 784 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 25746 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25790 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3783 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3783 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25754 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25798 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25790,17 +25834,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 25796 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25840 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (string) = -# 3784 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3784 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"(" ^ _3 ^ ")" ) -# 25804 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25848 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25847,17 +25891,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 25853 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25897 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (string) = -# 3785 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3785 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "(" ^ _3 ^ ")<-" ) -# 25861 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25905 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25897,17 +25941,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 25903 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25947 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (string) = -# 3786 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3786 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"[" ^ _3 ^ "]" ) -# 25911 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 25955 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25954,17 +25998,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 25960 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (string) = -# 3787 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3787 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "[" ^ _3 ^ "]<-" ) -# 25968 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26012 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26004,17 +26048,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 26010 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26054 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (string) = -# 3788 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3788 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"{" ^ _3 ^ "}" ) -# 26018 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26061,17 +26105,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 26067 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26111 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (string) = -# 3789 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3789 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "{" ^ _3 ^ "}<-" ) -# 26075 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26119 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26090,17 +26134,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 839 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 839 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 26096 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26140 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3790 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3790 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26104 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26148 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26123,9 +26167,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3791 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3791 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "!" ) -# 26129 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26173 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26144,22 +26188,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 777 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 777 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 26150 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26194 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic op in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_op_ in let _endpos = _endpos_op_ in let _v : (string) = let _1 = -# 3795 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3795 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( op ) -# 26158 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26202 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26163 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26207 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26178,22 +26222,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 778 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 778 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 26184 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26228 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic op in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_op_ in let _endpos = _endpos_op_ in let _v : (string) = let _1 = -# 3796 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3796 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( op ) -# 26192 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26236 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26197 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26241 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26212,22 +26256,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 779 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 779 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 26218 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26262 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic op in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_op_ in let _endpos = _endpos_op_ in let _v : (string) = let _1 = -# 3797 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3797 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( op ) -# 26226 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26270 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26231 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26275 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26246,22 +26290,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 780 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 780 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 26252 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26296 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic op in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_op_ in let _endpos = _endpos_op_ in let _v : (string) = let _1 = -# 3798 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3798 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( op ) -# 26260 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26304 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26265 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26309 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26280,22 +26324,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 781 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 781 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 26286 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26330 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic op in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_op_ in let _endpos = _endpos_op_ in let _v : (string) = let _1 = -# 3799 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3799 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( op ) -# 26294 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26338 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26299 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26343 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26318,14 +26362,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3800 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3800 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("+") -# 26324 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26368 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26329 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26373 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26348,14 +26392,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3801 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3801 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("+.") -# 26354 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26398 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26359 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26403 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26378,14 +26422,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("+=") -# 26384 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26428 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26389 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26433 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26408,14 +26452,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3803 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("-") -# 26414 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26458 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26419 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26463 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26438,14 +26482,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3804 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3804 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("-.") -# 26444 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26488 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26449 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26493 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26468,14 +26512,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3805 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3805 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("*") -# 26474 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26479 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26523 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26498,14 +26542,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3806 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3806 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("%") -# 26504 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26548 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26509 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26553 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26528,14 +26572,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3807 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3807 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("=") -# 26534 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26578 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26539 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26583 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26558,14 +26602,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3808 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3808 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("<") -# 26564 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26608 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26569 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26613 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26588,14 +26632,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3809 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3809 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (">") -# 26594 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26638 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26599 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26643 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26618,14 +26662,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3810 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3810 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("or") -# 26624 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26668 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26629 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26673 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26648,14 +26692,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3811 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3811 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("||") -# 26654 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26698 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26659 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26703 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26678,14 +26722,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3812 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3812 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("&") -# 26684 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26728 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26689 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26733 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26708,14 +26752,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3813 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3813 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("&&") -# 26714 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26758 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26719 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26763 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26738,14 +26782,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3814 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3814 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (":=") -# 26744 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26788 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3792 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26749 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26793 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26768,9 +26812,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (bool) = -# 3694 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3694 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( true ) -# 26774 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26818 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26786,9 +26830,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (bool) = -# 3695 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3695 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( false ) -# 26792 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26806,7 +26850,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26810 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26854 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26831,7 +26875,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26835 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26879 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26849,7 +26893,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26853 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26897 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26874,7 +26918,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26878 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26922 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26892,7 +26936,7 @@ module Tables = struct let _v : (string Location.loc option) = # 114 "" ( None ) -# 26896 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26940 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26917,9 +26961,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 26923 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -26932,21 +26976,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 26938 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26982 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 26944 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26988 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26950 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 26994 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26964,7 +27008,7 @@ module Tables = struct let _v : (Parsetree.core_type option) = # 114 "" ( None ) -# 26968 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27012 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26996,12 +27040,12 @@ module Tables = struct let _v : (Parsetree.core_type option) = let x = # 183 "" ( x ) -# 27000 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27044 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 27005 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27049 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27019,7 +27063,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 27023 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27067 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27051,12 +27095,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 27055 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27099 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 27060 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27104 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27074,7 +27118,7 @@ module Tables = struct let _v : (Parsetree.module_type option) = # 114 "" ( None ) -# 27078 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27122 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27106,12 +27150,12 @@ module Tables = struct let _v : (Parsetree.module_type option) = let x = # 183 "" ( x ) -# 27110 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27154 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 27115 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27159 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27129,7 +27173,7 @@ module Tables = struct let _v : (Parsetree.pattern option) = # 114 "" ( None ) -# 27133 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27177 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27161,12 +27205,12 @@ module Tables = struct let _v : (Parsetree.pattern option) = let x = # 183 "" ( x ) -# 27165 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27209 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 27170 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27214 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27184,7 +27228,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 27188 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27232 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27216,12 +27260,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 27220 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27264 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 27225 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27269 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27239,7 +27283,7 @@ module Tables = struct let _v : ((Parsetree.core_type option * Parsetree.core_type option) option) = # 114 "" ( None ) -# 27243 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27287 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27264,7 +27308,7 @@ module Tables = struct let _v : ((Parsetree.core_type option * Parsetree.core_type option) option) = # 116 "" ( Some x ) -# 27268 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27312 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27283,17 +27327,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 821 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 821 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 27289 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27333 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4021 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4021 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27297 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27341 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27325,18 +27369,18 @@ module Tables = struct } = _menhir_stack in let _3 : unit = Obj.magic _3 in let _2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 27331 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27375 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = -# 4022 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4022 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 27340 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27384 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27390,9 +27434,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1465 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1465 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc (Pmod_constraint(me, mty)) ) -# 27396 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27440 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27429,9 +27473,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.module_expr) = -# 1472 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1472 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( me (* TODO consider reloc *) ) -# 27435 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27479 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27482,25 +27526,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.module_expr) = let e = -# 1495 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1495 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( e ) -# 27488 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27532 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27495 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1480 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1480 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27504 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27548 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27565,17 +27609,17 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.module_expr) = let e = - let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in + let (_endpos__1_, _startpos__1_, _1, _2) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2, _2_inlined1) in let ty = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3669 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 27579 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27623 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_ty_ = _endpos__1_ in @@ -27583,26 +27627,26 @@ module Tables = struct let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1497 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1497 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_constraint (e, ty)) ) -# 27589 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27633 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27597 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27641 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1480 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1480 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27606 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27650 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27681,18 +27725,18 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.module_expr) = let e = - let (_endpos__1_inlined1_, _startpos__1_inlined1_, _endpos__1_, _startpos__1_, _1_inlined1, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined3, _1_inlined2) in + let (_endpos__1_inlined1_, _startpos__1_inlined1_, _endpos__1_, _startpos__1_, _1_inlined1, _1, _2) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined3, _1_inlined2, _2_inlined1) in let ty2 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3669 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 27696 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27740 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_ty2_ = _endpos__1_inlined1_ in @@ -27701,37 +27745,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3669 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 27709 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27753 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_ty2_ in let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1499 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1499 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, Some ty1, ty2)) ) -# 27718 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27762 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27726 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27770 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1480 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1480 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27735 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27779 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27796,17 +27840,17 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.module_expr) = let e = - let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in + let (_endpos__1_, _startpos__1_, _1, _2) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2, _2_inlined1) in let ty2 = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3669 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 27810 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27854 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_ty2_ = _endpos__1_ in @@ -27814,26 +27858,26 @@ module Tables = struct let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1501 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1501 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, None, ty2)) ) -# 27820 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27864 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27828 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27872 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1480 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1480 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27837 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27881 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27863,9 +27907,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1374 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1374 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27869 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27913 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27895,9 +27939,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1359 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1359 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27901 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27945 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27927,9 +27971,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = -# 1334 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1334 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27933 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 27977 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27959,9 +28003,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 1339 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1339 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27965 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27991,9 +28035,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1364 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1364 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27997 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28023,9 +28067,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1369 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1369 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28029 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28073 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28055,9 +28099,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_expr) = -# 1329 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1329 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28061 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28105 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28087,9 +28131,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_type) = -# 1324 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1324 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28093 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28137 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28119,9 +28163,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1349 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1349 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28125 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28169 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28151,9 +28195,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = -# 1344 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1344 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28157 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28201 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28183,9 +28227,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1354 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1354 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28189 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28233 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28227,15 +28271,15 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2949 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2949 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 28233 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28277 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2937 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28239 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28283 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28265,14 +28309,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = -# 2951 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2951 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pat.attr _1 _2 ) -# 28271 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28315 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2937 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28276 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28320 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28295,14 +28339,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = -# 2953 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2953 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28301 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28345 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2937 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28306 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28350 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28347,15 +28391,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28353 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28397 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2956 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2956 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_alias(_1, _3) ) -# 28359 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28403 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -28363,21 +28407,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28369 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28413 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2967 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28375 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28419 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2937 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28381 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28425 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28402,29 +28446,29 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2960 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2960 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_tuple(List.rev _1) ) -# 28408 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28452 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28416 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28460 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2967 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28422 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28466 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2937 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28428 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28472 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28463,30 +28507,30 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2964 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2964 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_or(_1, _3) ) -# 28469 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28513 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28478 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28522 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2967 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28484 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28528 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2937 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28490 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28534 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28534,24 +28578,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28540 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28584 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 28546 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28590 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2939 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2939 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_exception _3) _2) -# 28555 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28599 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28588,9 +28632,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3070 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3070 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _3 :: _1 ) -# 28594 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28638 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28627,9 +28671,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3071 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3071 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [_3; _1] ) -# 28633 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28677 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28666,9 +28710,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3070 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3070 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _3 :: _1 ) -# 28672 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28716 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28705,9 +28749,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3071 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3071 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [_3; _1] ) -# 28711 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28755 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28730,9 +28774,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2972 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2972 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28736 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28780 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28768,15 +28812,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28774 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28818 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2975 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2975 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(_1, Some ([], _2)) ) -# 28780 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28824 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -28784,15 +28828,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28790 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28834 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2981 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2981 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28796 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28840 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28852,24 +28896,24 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let newtypes = -# 2723 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2723 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 28858 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28902 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let constr = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28867 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2978 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2978 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(constr, Some (newtypes, pat)) ) -# 28873 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28917 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_pat_ in @@ -28877,15 +28921,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28883 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28927 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2981 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2981 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28889 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28933 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28916,24 +28960,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2980 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2980 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_variant(_1, Some _2) ) -# 28922 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28966 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28931 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28975 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2981 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2981 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28937 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 28981 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28981,24 +29025,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28987 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 28993 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2983 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2983 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_lazy _3) _2) -# 29002 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29046 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29040,15 +29084,15 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2949 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2949 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 29046 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29090 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2944 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2944 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29052 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29096 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29078,14 +29122,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = -# 2951 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2951 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pat.attr _1 _2 ) -# 29084 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29128 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2944 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2944 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29089 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29133 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29108,14 +29152,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = -# 2953 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2953 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29114 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29158 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2944 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2944 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29119 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29163 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29160,15 +29204,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 29166 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29210 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2956 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2956 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_alias(_1, _3) ) -# 29172 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29216 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -29176,21 +29220,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 29182 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29226 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2967 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29188 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29232 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2944 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2944 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29194 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29238 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29215,29 +29259,29 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2960 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2960 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_tuple(List.rev _1) ) -# 29221 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29265 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 29229 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29273 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2967 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29235 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29279 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2944 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2944 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29241 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29285 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29276,30 +29320,30 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2964 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2964 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_or(_1, _3) ) -# 29282 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29326 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 29291 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29335 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2967 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29297 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29341 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2944 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2944 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29303 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29347 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29318,9 +29362,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 29324 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29368 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -29332,30 +29376,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 29338 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29382 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2375 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2375 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_var _1 ) -# 29344 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29388 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 29353 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29397 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2377 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2377 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29359 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29403 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29379,23 +29423,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2376 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2376 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_any ) -# 29385 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29429 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 29393 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29437 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2377 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2377 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29399 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29443 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29418,9 +29462,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.payload) = -# 4133 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4133 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( PStr _1 ) -# 29424 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29468 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29450,9 +29494,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4134 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4134 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( PSig _2 ) -# 29456 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29500 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29482,9 +29526,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4135 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4135 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( PTyp _2 ) -# 29488 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29532 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29514,9 +29558,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4136 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4136 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( PPat (_2, None) ) -# 29520 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29564 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29560,9 +29604,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.payload) = -# 4137 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4137 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( PPat (_2, Some _4) ) -# 29566 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29610 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29585,9 +29629,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3508 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3508 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29591 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29635 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29630,24 +29674,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 29634 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29678 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1106 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1106 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 29639 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29683 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3500 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3500 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29645 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29689 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3504 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3504 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 29651 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29695 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_xs_) in @@ -29655,15 +29699,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 29661 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29705 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3510 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3510 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29667 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29711 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29686,14 +29730,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = -# 3539 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29692 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29736 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3508 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3508 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29697 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29741 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29732,33 +29776,33 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let _3 = -# 3539 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29738 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 29745 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29789 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1106 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1106 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 29750 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29794 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3500 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3500 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29756 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29800 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3504 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3504 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 29762 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29806 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_xs_ in @@ -29766,15 +29810,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 29772 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29816 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3510 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3510 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29778 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29822 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29821,9 +29865,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4094 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4094 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 29827 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29871 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29904,9 +29948,9 @@ module Tables = struct let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29910 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29954 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -29916,30 +29960,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 29922 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29966 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29930 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29974 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3134 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3134 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Val.mk id ty ~prim ~attrs ~loc ~docs, ext ) -# 29943 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 29987 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29955,14 +29999,14 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.private_flag) = let _1 = -# 3962 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public ) -# 29961 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30005 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3959 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3959 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29966 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29985,14 +30029,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = let _1 = -# 3963 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 29991 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30035 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3959 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3959 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29996 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30040 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30008,9 +30052,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3985 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3985 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public, Concrete ) -# 30014 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30058 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30033,9 +30077,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3986 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3986 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private, Concrete ) -# 30039 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30083 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30058,9 +30102,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3987 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3987 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public, Virtual ) -# 30064 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30108 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30090,9 +30134,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3988 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3988 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private, Virtual ) -# 30096 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30140 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30122,9 +30166,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3989 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3989 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private, Virtual ) -# 30128 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30172 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30140,9 +30184,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.rec_flag) = -# 3940 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3940 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Nonrecursive ) -# 30146 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30190 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30165,9 +30209,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.rec_flag) = -# 3941 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3941 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 30171 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30193,12 +30237,12 @@ module Tables = struct (Longident.t Location.loc * Parsetree.expression) list) = let eo = # 124 "" ( None ) -# 30197 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30241 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2869 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2869 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( eo, fields ) -# 30202 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30246 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30239,18 +30283,18 @@ module Tables = struct let x = # 191 "" ( x ) -# 30243 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30287 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 30248 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30292 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2869 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2869 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( eo, fields ) -# 30254 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30298 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30268,24 +30312,24 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let d : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = Obj.magic d in + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3321 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3321 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30284 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30328 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1216 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1216 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30289 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30333 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30303,24 +30347,24 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let d : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = Obj.magic d in + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3321 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3321 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30319 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30363 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1219 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1219 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30324 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30368 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30344,25 +30388,25 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; }; } = _menhir_stack in - let d : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let d : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = Obj.magic d in + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = Obj.magic d in let xs : (Parsetree.constructor_declaration list) = Obj.magic xs in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3321 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3321 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30361 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30405 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1223 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1223 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30366 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30380,31 +30424,31 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let d : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = Obj.magic d in + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3438 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30397 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30441 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3432 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3432 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30402 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30446 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1216 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1216 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30408 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30452 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30427,14 +30471,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3434 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3434 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30433 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30477 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1216 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1216 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30438 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30482 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30452,31 +30496,31 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let d : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = Obj.magic d in + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3438 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30469 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30513 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3432 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3432 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30474 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1219 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1219 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30480 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30524 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30499,14 +30543,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3434 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3434 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30505 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30549 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1219 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1219 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30510 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30554 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30530,32 +30574,32 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; }; } = _menhir_stack in - let d : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let d : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = Obj.magic d in + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = Obj.magic d in let xs : (Parsetree.extension_constructor list) = Obj.magic xs in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3438 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30548 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30592 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3432 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3432 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30553 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30597 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1223 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1223 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30559 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30603 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30585,14 +30629,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3434 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3434 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30591 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30635 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1223 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1223 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30596 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30640 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30610,24 +30654,24 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let d : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = Obj.magic d in + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3438 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30626 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30670 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1216 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1216 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30631 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30675 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30645,24 +30689,24 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos_d_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let d : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let d : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = Obj.magic d in + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = Obj.magic d in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3438 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30661 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30705 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1219 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1219 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30666 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30710 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30686,25 +30730,25 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; }; } = _menhir_stack in - let d : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + let d : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) = Obj.magic d in + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) = Obj.magic d in let xs : (Parsetree.extension_constructor list) = Obj.magic xs in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3438 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30703 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30747 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1223 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1223 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30708 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30752 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30725,9 +30769,9 @@ module Tables = struct | `Prop_opt_punned of string | `Prop_punned of string ]) list) = -# 1082 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1082 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 30731 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30775 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30771,9 +30815,9 @@ module Tables = struct | `Prop_opt_punned of string | `Prop_punned of string ]) list) = -# 1084 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1084 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30777 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30821 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30789,9 +30833,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * Parsetree.core_type * Warnings.loc) list) = -# 1082 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1082 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 30795 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30839 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30848,21 +30892,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2255 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2255 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _3, make_loc _sloc ) -# 30854 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30898 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 30860 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1084 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1084 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30866 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30910 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30878,9 +30922,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Parsetree.expression list) = -# 1082 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1082 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 30884 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30928 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30910,9 +30954,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.expression list) = -# 1084 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1084 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30916 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30960 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30935,9 +30979,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1096 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1096 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30941 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 30985 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30967,9 +31011,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1098 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1098 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30973 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31017 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30992,9 +31036,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Asttypes.arg_label * Parsetree.expression) list) = -# 1096 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1096 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30998 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31042 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31024,9 +31068,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Asttypes.arg_label * Parsetree.expression) list) = -# 1098 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1098 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31030 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31074 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31049,9 +31093,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (string list) = -# 1096 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1096 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31055 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31099 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31081,9 +31125,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (string list) = -# 1098 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1098 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31087 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31131 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31119,21 +31163,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31125 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31169 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3496 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3496 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 31131 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31175 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1096 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1096 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31181 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31176,21 +31220,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31182 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31226 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3496 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3496 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 31188 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31232 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1098 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1098 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31194 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31238 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31215,12 +31259,12 @@ module Tables = struct let _v : (Parsetree.case list) = let _1 = # 124 "" ( None ) -# 31219 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31263 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1187 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1187 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31224 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31268 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31254,13 +31298,13 @@ module Tables = struct # 126 "" ( Some x ) -# 31258 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31302 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1187 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1187 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31264 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31308 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31297,9 +31341,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.case list) = -# 1191 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1191 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31303 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31347 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31323,20 +31367,20 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type list) = let xs = let x = -# 3539 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31329 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31373 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1122 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1122 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31334 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31378 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31340 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31384 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31374,20 +31418,20 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type list) = let xs = let x = -# 3539 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31380 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31424 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1126 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31385 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31429 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31391 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31435 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31410,14 +31454,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.with_constraint list) = let xs = -# 1122 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1122 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31416 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31460 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31421 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31465 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31454,14 +31498,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.with_constraint list) = let xs = -# 1126 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31460 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31504 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31465 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31509 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31484,14 +31528,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.row_field list) = let xs = -# 1122 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1122 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31490 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31534 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31495 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31528,14 +31572,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.row_field list) = let xs = -# 1126 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31534 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31578 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31539 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31583 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31558,14 +31602,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1122 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1122 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31564 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31608 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31569 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31613 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31602,14 +31646,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1126 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31608 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31652 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31613 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31657 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31632,14 +31676,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = -# 1122 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1122 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31638 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31682 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31643 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31687 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31676,14 +31720,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = -# 1126 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31682 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31726 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31687 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31731 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31706,14 +31750,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1122 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1122 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31712 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31756 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31717 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31761 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31750,14 +31794,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1126 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31756 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31800 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1130 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31761 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31805 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31794,9 +31838,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = -# 1153 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1153 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31800 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31844 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31833,9 +31877,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.core_type list) = -# 1157 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1157 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31839 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31883 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31872,9 +31916,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.expression list) = -# 1153 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1153 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31878 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31922 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31911,9 +31955,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.expression list) = -# 1157 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1157 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31917 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 31961 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31950,9 +31994,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = -# 1153 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1153 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31956 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32000 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31989,9 +32033,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.core_type list) = -# 1157 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1157 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31995 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32014,9 +32058,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.row_field) = -# 3679 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3679 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32020 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32064 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32042,9 +32086,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3681 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3681 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Rf.inherit_ ~loc:(make_loc _sloc) _1 ) -# 32048 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32092 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32069,12 +32113,12 @@ module Tables = struct let _v : (Parsetree.expression list) = let _2 = # 124 "" ( None ) -# 32073 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32117 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32078 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32122 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32108,13 +32152,13 @@ module Tables = struct # 126 "" ( Some x ) -# 32112 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32156 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32118 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32162 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32151,9 +32195,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.expression list) = -# 1178 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1178 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 32157 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32201 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32179,9 +32223,9 @@ module Tables = struct } = _menhir_stack in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 32185 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32229 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -32189,26 +32233,26 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 32193 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32237 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let x = let label = let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32200 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32244 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32208 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32252 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2892 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2892 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -32218,13 +32262,13 @@ module Tables = struct label, e in label, e ) -# 32222 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32266 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32228 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32272 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32257,9 +32301,9 @@ module Tables = struct let x : unit = Obj.magic x in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 32263 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32307 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -32267,26 +32311,26 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 32271 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32315 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let x = let label = let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32278 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32322 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32286 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32330 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2892 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2892 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -32296,13 +32340,13 @@ module Tables = struct label, e in label, e ) -# 32300 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32344 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32306 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32350 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32342,9 +32386,9 @@ module Tables = struct let _2 : unit = Obj.magic _2 in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 32348 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32392 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -32352,21 +32396,21 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let x = let label = let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32358 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32402 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32366 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2892 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2892 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -32376,13 +32420,13 @@ module Tables = struct label, e in label, e ) -# 32380 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32424 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1178 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1178 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 32386 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32430 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32407,12 +32451,12 @@ module Tables = struct let _v : (Parsetree.pattern list) = let _2 = # 124 "" ( None ) -# 32411 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32455 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32416 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32460 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32446,13 +32490,13 @@ module Tables = struct # 126 "" ( Some x ) -# 32450 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32494 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32456 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32500 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32489,9 +32533,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.pattern list) = -# 1178 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1178 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 32495 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32530,7 +32574,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 32534 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32578 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -32538,9 +32582,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32544 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32588 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -32548,7 +32592,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2875 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2875 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -32558,13 +32602,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 32562 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32606 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32568 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32612 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32610,7 +32654,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 32614 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32658 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -32618,9 +32662,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32624 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32668 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -32628,7 +32672,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2875 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2875 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -32638,13 +32682,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 32642 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32686 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1174 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1174 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32648 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32692 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32700,9 +32744,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32706 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32750 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -32710,7 +32754,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2875 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2875 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -32720,13 +32764,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 32724 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32768 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1178 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1178 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 32730 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32774 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32749,9 +32793,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2344 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2344 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32755 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32799 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32781,9 +32825,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2345 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2345 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32787 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32831 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32821,24 +32865,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2347 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2347 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_sequence(_1, _3) ) -# 32827 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32871 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 32836 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32880 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2348 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2348 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32842 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32886 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32892,11 +32936,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2350 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2350 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let seq = mkexp ~loc:_sloc (Pexp_sequence (_1, _5)) in let payload = PStr [mkstrexp seq []] in mkexp ~loc:_sloc (Pexp_extension (_4, payload)) ) -# 32900 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 32944 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32952,7 +32996,7 @@ module Tables = struct } = _menhir_stack in let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in - let vars_args_res : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + let vars_args_res : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = Obj.magic vars_args_res in let _1_inlined2 : (string) = Obj.magic _1_inlined2 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -32964,18 +33008,18 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = let attrs = let _1 = _1_inlined4 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32970 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33014 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined4_ in let attrs2 = let _1 = _1_inlined3 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32979 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33023 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -32985,17 +33029,17 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32991 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33035 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32999 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33043 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in @@ -33003,14 +33047,14 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3351 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3351 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let loc = make_loc (_startpos, _endpos_attrs2_) in let docs = symbol_docs _sloc in Te.mk_exception ~attrs (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) , ext ) -# 33014 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33058 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33036,21 +33080,21 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 33040 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33084 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 997 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 997 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_sig _startpos _endpos _1 ) -# 33048 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33092 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1779 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1779 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33054 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33098 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33082,9 +33126,9 @@ module Tables = struct let _v : (Parsetree.signature_item) = let _2 = let _1 = _1_inlined1 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33088 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33132 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -33092,10 +33136,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1794 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1794 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mksig ~loc:_sloc (Psig_extension (_1, (add_docs_attrs docs _2))) ) -# 33099 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33143 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33119,23 +33163,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1798 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1798 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Psig_attribute _1 ) -# 33125 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33169 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1045 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1045 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mksig ~loc:_sloc _1 ) -# 33133 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33177 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1800 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1800 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33139 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33183 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33159,23 +33203,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1803 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( psig_value _1 ) -# 33165 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33209 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33173 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33217 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33179 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33223 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33199,23 +33243,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1805 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1805 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( psig_value _1 ) -# 33205 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33249 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33213 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33257 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33219 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33263 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33250,26 +33294,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1235 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1235 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 33256 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33300 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3170 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3170 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33261 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33305 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3153 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3153 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33267 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33311 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1807 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1807 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( psig_type _1 ) -# 33273 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33317 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -33277,15 +33321,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33283 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33327 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33289 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33333 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33320,26 +33364,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1235 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1235 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 33326 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33370 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3170 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3170 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33331 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33375 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3158 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3158 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33337 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33381 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1809 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1809 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( psig_typesubst _1 ) -# 33343 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33387 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -33347,15 +33391,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33353 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33397 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33359 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33403 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33440,16 +33484,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33446 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33490 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = -# 1227 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1227 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 33453 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33497 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -33457,46 +33501,46 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33463 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33507 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _4 = -# 3948 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3948 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 33469 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33513 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33476 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33520 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3425 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3425 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in let attrs = attrs1 @ attrs2 in Te.mk tid cs ~params ~priv ~attrs ~docs, ext ) -# 33488 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33532 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3412 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3412 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33494 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33538 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1811 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1811 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( psig_typext _1 ) -# 33500 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33544 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -33504,15 +33548,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33510 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33554 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33516 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33560 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33604,16 +33648,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33610 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33654 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = -# 1227 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1227 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 33617 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33661 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -33621,52 +33665,52 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33627 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33671 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _4 = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos__1_inlined2_) in + let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3950 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3950 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 33638 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33682 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33646 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33690 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3425 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3425 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in let attrs = attrs1 @ attrs2 in Te.mk tid cs ~params ~priv ~attrs ~docs, ext ) -# 33658 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33702 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3412 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3412 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33664 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33708 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1811 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1811 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( psig_typext _1 ) -# 33670 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33714 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -33674,15 +33718,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33680 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33724 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33686 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33730 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33706,23 +33750,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1813 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1813 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( psig_exception _1 ) -# 33712 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33756 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33720 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33764 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33726 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33770 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33785,9 +33829,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33791 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -33797,37 +33841,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33803 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33847 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33811 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33855 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1844 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1844 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Md.mk name body ~attrs ~loc ~docs, ext ) -# 33825 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33869 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1815 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1815 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 33831 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33875 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -33835,15 +33879,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33841 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33885 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33847 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33891 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33913,9 +33957,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33919 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33963 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -33926,9 +33970,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33932 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33976 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos_id_, _startpos_id_) = (_endpos__1_, _startpos__1_) in @@ -33936,9 +33980,9 @@ module Tables = struct let _symbolstartpos = _startpos_id_ in let _sloc = (_symbolstartpos, _endpos) in -# 1885 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1885 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Mty.alias ~loc:(make_loc _sloc) id ) -# 33942 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33986 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let name = @@ -33947,37 +33991,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33953 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 33997 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33961 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34005 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1876 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1876 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Md.mk name body ~attrs ~loc ~docs, ext ) -# 33975 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34019 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1817 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1817 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 33981 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34025 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -33985,15 +34029,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33991 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34035 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33997 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34017,23 +34061,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1819 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1819 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modsubst body, ext) ) -# 34023 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34067 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34031 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34075 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34037 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34081 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34119,9 +34163,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34125 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34169 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -34131,49 +34175,49 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 34137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34181 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34145 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34189 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1921 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1921 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in ext, Md.mk name mty ~attrs ~loc ~docs ) -# 34159 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34203 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1235 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1235 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 34165 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34209 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1910 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1910 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34171 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1821 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1821 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_recmodule l, ext) ) -# 34177 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34221 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -34181,15 +34225,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34187 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34231 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34193 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34237 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34213,23 +34257,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1823 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1823 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modtype body, ext) ) -# 34219 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34263 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34227 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34271 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34233 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34277 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34253,23 +34297,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1825 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1825 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modtypesubst body, ext) ) -# 34259 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34303 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34267 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34311 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34273 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34317 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34293,23 +34337,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1827 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1827 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_open body, ext) ) -# 34299 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34343 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34307 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34351 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34313 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34357 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34365,38 +34409,38 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34371 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34415 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34380 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34424 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1661 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1661 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Incl.mk thing ~attrs ~loc ~docs, ext ) -# 34394 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1829 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1829 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( psig_include _1 ) -# 34400 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34444 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -34404,15 +34448,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34410 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34454 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34416 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34460 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34489,9 +34533,9 @@ module Tables = struct let cty : (Parsetree.class_type) = Obj.magic cty in let _7 : unit = Obj.magic _7 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 34495 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -34509,9 +34553,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34515 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34559 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -34521,24 +34565,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 34527 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34571 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34535 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34579 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2276 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2276 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -34546,25 +34590,25 @@ module Tables = struct ext, Ci.mk id cty ~virt ~params ~attrs ~loc ~docs ) -# 34550 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34594 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1235 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1235 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 34556 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34600 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2264 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2264 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34562 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34606 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1831 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1831 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_class l, ext) ) -# 34568 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34612 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -34572,15 +34616,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34578 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34622 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34584 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34628 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34604,23 +34648,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1833 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1833 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_class_type l, ext) ) -# 34610 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34654 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34618 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34662 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1835 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1835 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34624 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34668 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34643,9 +34687,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constant) = -# 3755 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3755 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34649 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34693 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34670,18 +34714,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 787 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 787 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 34676 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.constant) = -# 3756 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3756 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _2 in Pconst_integer("-" ^ n, m) ) -# 34685 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34729 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34706,18 +34750,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 765 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 765 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 34712 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34756 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.constant) = -# 3757 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3757 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _2 in Pconst_float("-" ^ f, m) ) -# 34721 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34765 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34742,18 +34786,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 787 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 787 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 34748 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34792 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.constant) = -# 3758 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3758 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _2 in Pconst_integer (n, m) ) -# 34757 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34801 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34778,18 +34822,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 765 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 765 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 34784 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34828 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _1 : unit = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.constant) = -# 3759 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3759 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _2 in Pconst_float(f, m) ) -# 34793 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34837 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34830,18 +34874,18 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 3082 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3082 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let fields, closed = _1 in let closed = match closed with Some () -> Open | None -> Closed in fields, closed ) -# 34838 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34882 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3053 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3053 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (fields, closed) = _2 in Ppat_record(fields, closed) ) -# 34845 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34889 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34849,15 +34893,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34855 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34899 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3067 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3067 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34861 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34905 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34896,15 +34940,15 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _2 = -# 3076 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ps ) -# 34902 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34946 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 3058 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3058 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( fst (mktailpat _loc__3_ _2) ) -# 34908 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34952 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34912,15 +34956,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34918 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3067 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3067 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34924 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 34968 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34959,14 +35003,14 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _2 = -# 3076 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ps ) -# 34965 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_array _2 ) -# 34970 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35014 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34974,15 +35018,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34980 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35024 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3067 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3067 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34986 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35030 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35013,24 +35057,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3064 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3064 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_array [] ) -# 35019 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35063 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 35028 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35072 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3067 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3067 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35034 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35078 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35069,9 +35113,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in let _startpos = _startpos__1_ in -# 4142 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4142 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fake.Meta.code _startpos _endpos _2 ) -# 35075 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35119 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35103,9 +35147,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _endpos = _endpos__2_ in let _startpos = _startpos__1_ in -# 4144 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4144 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fake.Meta.uncode _startpos _endpos _2 ) -# 35109 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35153 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35145,9 +35189,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2520 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2520 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( reloc_exp ~loc:_sloc _2 ) -# 35151 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35195 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35194,9 +35238,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2526 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2526 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp_constraint ~loc:_sloc _2 _3 ) -# 35200 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35244 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35248,14 +35292,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2527 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2527 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 35254 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35298 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2406 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2406 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 35259 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35303 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35263,9 +35307,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2528 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2528 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 35269 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35313 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35317,14 +35361,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2527 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2527 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 35323 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35367 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2408 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2408 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 35328 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35372 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35332,9 +35376,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2528 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2528 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 35338 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35382 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35386,14 +35430,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2527 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2527 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 35392 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35436 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2410 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35397 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35441 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35401,9 +35445,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2528 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2528 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 35407 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35451 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35449,9 +35493,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 35455 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35499 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -35459,31 +35503,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2529 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 35465 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35509 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 35470 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35514 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 35476 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35520 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35481 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35525 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2406 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2406 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 35487 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35531 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35491,9 +35535,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2530 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2530 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35497 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35541 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35551,9 +35595,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 35557 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35601 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -35563,39 +35607,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2529 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 35569 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35613 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 35574 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35618 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (_2) -# 35582 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35626 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 35587 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35631 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35593 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35637 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2406 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2406 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 35599 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35643 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35603,9 +35647,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2530 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2530 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35609 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35653 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35651,9 +35695,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 35657 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35701 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -35661,31 +35705,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2529 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 35667 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35711 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 35672 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35716 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 35678 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35722 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35683 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35727 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2408 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2408 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 35689 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35733 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35693,9 +35737,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2530 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2530 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35699 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35753,9 +35797,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 35759 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -35765,39 +35809,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2529 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 35771 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35815 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 35776 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35820 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (_2) -# 35784 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35828 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 35789 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35833 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35795 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35839 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2408 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2408 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 35801 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35845 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35805,9 +35849,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2530 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2530 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35811 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35855 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35853,9 +35897,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 35859 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35903 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let array : (Parsetree.expression) = Obj.magic array in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -35863,31 +35907,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2529 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 35869 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35913 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 35874 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35918 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 35880 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35924 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35885 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35929 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2410 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35891 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35935 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35895,9 +35939,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2530 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2530 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35901 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 35945 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35955,9 +35999,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 35961 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36005 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _2 in let _2_inlined1 : (Longident.t) = Obj.magic _2_inlined1 in let _1 : unit = Obj.magic _1 in @@ -35967,39 +36011,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2529 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( None ) -# 35973 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36017 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let i = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 35978 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36022 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (_2) -# 35986 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36030 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 35991 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36035 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2422 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35997 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2410 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2410 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 36003 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -36007,9 +36051,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2530 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2530 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 36013 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36063,15 +36107,15 @@ module Tables = struct let attrs = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36069 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36113 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2544 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2544 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( e.pexp_desc, (ext, attrs @ e.pexp_attributes) ) -# 36075 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36119 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36079,10 +36123,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2536 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2536 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 36086 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36130 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36131,24 +36175,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36181 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 36143 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36187 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2546 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2546 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_construct (mkloc (Lident "()") (make_loc _sloc), None), _2 ) -# 36152 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36196 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36156,10 +36200,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2536 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2536 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 36163 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36207 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36209,9 +36253,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36215 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36259 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -36219,21 +36263,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36225 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36269 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 36231 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36275 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2552 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2552 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_new(_3), _2 ) -# 36237 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36281 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -36241,10 +36285,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2536 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2536 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 36248 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36292 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36307,21 +36351,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36313 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36357 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 36319 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36363 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2554 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2554 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_pack _4, _3 ) -# 36325 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36369 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36329,10 +36373,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2536 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2536 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 36336 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36380 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36410,11 +36454,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3669 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 36418 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36462 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -36422,24 +36466,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36428 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36472 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 36434 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36478 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2556 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2556 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_constraint (ghexp ~loc:_sloc (Pexp_pack _4), _6), _3 ) -# 36443 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36487 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -36447,10 +36491,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2536 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2536 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 36454 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36498 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36515,27 +36559,27 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 36519 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36563 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2090 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2090 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36524 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36568 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 998 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 998 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_cstr _startpos _endpos _1 ) -# 36533 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36577 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2077 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2077 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Cstr.mk _1 _2 ) -# 36539 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36583 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -36543,21 +36587,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36549 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36593 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 36555 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36599 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2562 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2562 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_object _3, _2 ) -# 36561 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36605 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -36565,10 +36609,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2536 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2536 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 36572 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36616 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36592,9 +36636,9 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.expression) = let _loc_e_ = (_startpos_e_, _endpos_e_) in -# 2538 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2538 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Jsx_helper.mkjsxexp ~loc:_loc_e_ e ) -# 36598 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36642 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36623,30 +36667,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36629 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36673 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2570 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2570 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_ident (_1) ) -# 36635 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36679 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36644 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36688 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36650 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36694 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36670,23 +36714,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2572 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2572 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_constant _1 ) -# 36676 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36684 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36728 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36690 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36734 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36715,30 +36759,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36721 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36765 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2574 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2574 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_construct(_1, None) ) -# 36727 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36771 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36736 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36780 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36742 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36786 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36762,23 +36806,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2576 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2576 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_variant(_1, None) ) -# 36768 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36812 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36776 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36820 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36782 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36826 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36804,9 +36848,9 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 828 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 828 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 36810 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36854 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -36818,15 +36862,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 36824 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36868 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2578 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2578 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 36830 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36874 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -36834,15 +36878,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36840 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36884 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36846 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36890 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36875,23 +36919,23 @@ module Tables = struct let _1 = let _1 = let _1 = -# 2579 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2579 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ("!") -# 36881 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36925 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 36889 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36933 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2580 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2580 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 36895 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36939 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -36899,15 +36943,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36905 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36949 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36911 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36955 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36946,14 +36990,14 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2887 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2887 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 36952 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 36996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2582 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2582 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_override _2 ) -# 36957 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37001 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36961,15 +37005,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36967 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37011 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36973 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37017 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37000,24 +37044,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2588 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2588 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_override [] ) -# 37006 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37050 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37015 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37059 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37021 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37061,15 +37105,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37067 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37111 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2590 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2590 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_field(_1, _3) ) -# 37073 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37117 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -37077,15 +37121,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37083 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37127 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37089 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37133 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37143,24 +37187,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37149 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37193 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1720 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37158 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37202 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2592 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2592 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, _4) ) -# 37164 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37208 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37168,15 +37212,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37174 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37218 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37180 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37224 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37229,9 +37273,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2887 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2887 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 37235 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37279 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -37239,18 +37283,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37245 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37289 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1720 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37254 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37298 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_od_ = _startpos__1_ in @@ -37258,10 +37302,10 @@ module Tables = struct let _symbolstartpos = _startpos_od_ in let _sloc = (_symbolstartpos, _endpos) in -# 2594 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2594 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (* TODO: review the location of Pexp_override *) Pexp_open(od, mkexp ~loc:_sloc (Pexp_override _4)) ) -# 37265 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37309 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37269,15 +37313,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37275 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37319 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37281 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37325 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37308,9 +37352,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 37314 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37358 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : (Parsetree.expression) = Obj.magic _1 in @@ -37322,23 +37366,23 @@ module Tables = struct let _3 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37328 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37372 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37336 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37380 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2601 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2601 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_send(_1, _3) ) -# 37342 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37386 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -37346,15 +37390,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37352 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37396 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37358 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37402 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37386,9 +37430,9 @@ module Tables = struct } = _menhir_stack in let _3 : (Parsetree.expression) = Obj.magic _3 in let _1_inlined1 : ( -# 839 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 839 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 37392 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37436 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _1 : (Parsetree.expression) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in @@ -37402,15 +37446,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 37408 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37452 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2603 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2603 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkinfix _1 _2 _3 ) -# 37414 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37458 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -37418,15 +37462,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37424 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37468 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37430 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37474 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37450,23 +37494,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2605 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2605 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_extension _1 ) -# 37456 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37500 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37464 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37508 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37470 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37514 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37494,25 +37538,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2607 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2607 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let id = mkrhs Ast_helper.hole_txt _loc in Pexp_extension (id, PStr []) ) -# 37501 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37545 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37510 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37554 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37516 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37560 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37558,20 +37602,20 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _3 = - let (_endpos__2_, _startpos__1_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in + let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2609 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2609 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Lident "()") -# 37566 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37610 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37575 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37619 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -37581,25 +37625,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37587 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37631 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1720 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37596 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37640 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2610 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2610 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:(_loc__3_) (Pexp_construct(_3, None))) ) -# 37603 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37647 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -37607,15 +37651,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37613 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37657 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37619 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37663 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37654,25 +37698,25 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2616 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2616 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (exten, fields) = _2 in Pexp_record(fields, exten) ) -# 37661 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37705 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37670 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37714 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37676 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37731,27 +37775,27 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37737 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37781 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1720 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37746 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37790 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in -# 2623 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2623 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (exten, fields) = _4 in Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_record(fields, exten))) ) -# 37755 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37799 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37759,15 +37803,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37765 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37809 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37771 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37815 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37806,14 +37850,14 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 37812 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2631 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2631 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_array(_2) ) -# 37817 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37861 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -37821,15 +37865,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37827 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37871 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37833 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37877 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37860,24 +37904,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2637 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2637 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_array [] ) -# 37866 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37910 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37875 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37919 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37881 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37925 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37930,9 +37974,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 37936 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37980 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -37940,25 +37984,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37946 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37990 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1720 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37955 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 37999 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in -# 2639 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2639 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array(_4))) ) -# 37962 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38006 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37966,15 +38010,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37972 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37978 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38022 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38025,26 +38069,26 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38031 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38075 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1720 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 38040 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38084 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in -# 2641 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2641 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (* TODO: review the location of Pexp_array *) Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array [])) ) -# 38048 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38092 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -38052,15 +38096,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 38058 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38102 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38064 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38108 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38099,15 +38143,15 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 38105 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38149 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2649 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2649 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( fst (mktailexp _loc__3_ _2) ) -# 38111 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38155 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -38115,15 +38159,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 38121 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38165 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38127 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38171 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38176,9 +38220,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2904 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2904 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( es ) -# 38182 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38226 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -38186,30 +38230,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38192 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38236 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1720 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 38201 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38245 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _loc__5_ = (_startpos__5_, _endpos__5_) in -# 2655 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2655 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let list_exp = (* TODO: review the location of list_exp *) let tail_exp, _tail_loc = mktailexp _loc__5_ _4 in mkexp ~loc:(_startpos__3_, _endpos) tail_exp in Pexp_open(od, list_exp) ) -# 38213 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38257 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -38217,15 +38261,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 38223 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38267 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38229 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38273 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38271,20 +38315,20 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _3 = - let (_endpos__2_, _startpos__1_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in + let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2660 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2660 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Lident "[]") -# 38279 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38323 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38288 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38332 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -38294,25 +38338,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38300 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38344 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1720 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 38309 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38353 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2661 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2661 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:_loc__3_ (Pexp_construct(_3, None))) ) -# 38316 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38360 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -38320,15 +38364,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 38326 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38370 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38332 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38376 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38421,11 +38465,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3669 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 38429 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38473 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _5 = @@ -38433,15 +38477,15 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38439 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38483 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 38445 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38489 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let od = @@ -38450,18 +38494,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38456 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38500 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1720 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 38465 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38509 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos_od_ = _startpos__1_ in @@ -38469,12 +38513,12 @@ module Tables = struct let _symbolstartpos = _startpos_od_ in let _sloc = (_symbolstartpos, _endpos) in -# 2669 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let modexp = mkexp_attrs ~loc:(_startpos__3_, _endpos) (Pexp_constraint (ghexp ~loc:_sloc (Pexp_pack _6), _8)) _5 in Pexp_open(od, modexp) ) -# 38478 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38522 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__9_ in @@ -38482,15 +38526,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 38488 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38532 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2540 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2540 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38494 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38538 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38519,30 +38563,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38525 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38569 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2987 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2987 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_var (_1) ) -# 38531 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38540 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38584 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2988 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2988 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38546 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38590 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38565,9 +38609,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2989 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2989 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38571 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38615 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38607,9 +38651,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2994 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2994 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( reloc_pat ~loc:_sloc _2 ) -# 38613 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38657 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38632,9 +38676,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2996 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38638 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38682 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38697,9 +38741,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38703 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38747 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -38707,24 +38751,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38713 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38757 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 38719 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38763 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2998 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2998 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_unpack _4) _3 ) -# 38728 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38772 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38801,11 +38845,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3669 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3669 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (lid, cstrs, attrs) = package_type_of_module_type _1 in let descr = Ptyp_package (lid, cstrs) in mktyp ~loc:_sloc ~attrs descr ) -# 38809 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38853 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -38814,9 +38858,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38820 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38864 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__4_, _startpos__4_) = (_endpos__1_inlined3_, _startpos__1_inlined3_) in @@ -38825,15 +38869,15 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38831 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38875 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 4120 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 38837 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38881 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in @@ -38841,11 +38885,11 @@ module Tables = struct let _loc__4_ = (_startpos__4_, _endpos__4_) in let _sloc = (_symbolstartpos, _endpos) in -# 3000 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3000 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_constraint(mkpat ~loc:_loc__4_ (Ppat_unpack _4), _6)) _3 ) -# 38849 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38893 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38869,23 +38913,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3008 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3008 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_any ) -# 38875 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38919 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38883 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38927 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38889 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38933 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38909,23 +38953,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_constant _1 ) -# 38915 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38959 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38923 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38929 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 38973 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38963,24 +39007,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3012 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3012 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_interval (_1, _3) ) -# 38969 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39013 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38978 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39022 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38984 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39028 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39009,30 +39053,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 39015 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39059 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3014 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3014 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(_1, None) ) -# 39021 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39030 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39074 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39036 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39080 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39056,23 +39100,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3016 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_variant(_1, None) ) -# 39062 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39106 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39070 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39114 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39076 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39120 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39109,15 +39153,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 39115 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39159 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3018 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3018 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_type (_2) ) -# 39121 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39165 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -39125,15 +39169,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39131 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39175 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39181 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39176,15 +39220,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 39182 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39226 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3020 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3020 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, _3) ) -# 39188 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39232 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -39192,15 +39236,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39198 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39242 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39204 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39248 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39246,20 +39290,20 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _3 = - let (_endpos__2_, _startpos__1_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in + let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 3021 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3021 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Lident "[]") -# 39254 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39298 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 39263 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39307 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -39268,18 +39312,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 39274 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39318 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3022 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3022 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 39283 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39327 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -39287,15 +39331,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39293 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39337 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39299 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39343 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39341,20 +39385,20 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _3 = - let (_endpos__2_, _startpos__1_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in + let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 3023 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3023 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Lident "()") -# 39349 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39393 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 39358 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39402 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -39363,18 +39407,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 39369 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39413 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3024 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3024 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 39378 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39422 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -39382,15 +39426,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39388 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39432 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39394 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39438 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39447,15 +39491,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 39453 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39497 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3026 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3026 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_open (_1, _4) ) -# 39459 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39503 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -39463,15 +39507,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39469 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39513 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39475 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39519 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39523,24 +39567,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3036 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3036 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_2, _4) ) -# 39529 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39573 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39538 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39582 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39544 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39588 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39564,23 +39608,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3047 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ppat_extension _1 ) -# 39570 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39614 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39578 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39622 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39584 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39628 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39599,17 +39643,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 39605 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39649 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4028 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4028 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39613 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39657 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39628,17 +39672,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 39634 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39678 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4029 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4029 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39642 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39686 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39661,9 +39705,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4030 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4030 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "and" ) -# 39667 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39711 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39686,9 +39730,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4031 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4031 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "as" ) -# 39692 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39736 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39711,9 +39755,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4032 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4032 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "assert" ) -# 39717 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39761 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39736,9 +39780,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4033 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4033 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "begin" ) -# 39742 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39786 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39761,9 +39805,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4034 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4034 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "class" ) -# 39767 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39811 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39786,9 +39830,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4035 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4035 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "constraint" ) -# 39792 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39811,9 +39855,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4036 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4036 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "do" ) -# 39817 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39861 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39836,9 +39880,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4037 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4037 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "done" ) -# 39842 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39886 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39861,9 +39905,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4038 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4038 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "downto" ) -# 39867 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39886,9 +39930,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4039 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "else" ) -# 39892 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39936 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39911,9 +39955,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4040 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4040 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "end" ) -# 39917 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39961 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39936,9 +39980,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "exception" ) -# 39942 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 39986 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39961,9 +40005,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4042 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4042 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "external" ) -# 39967 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40011 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39986,9 +40030,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4043 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4043 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "false" ) -# 39992 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40036 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40011,9 +40055,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4044 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4044 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "for" ) -# 40017 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40061 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40036,9 +40080,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4045 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4045 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "fun" ) -# 40042 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40086 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40061,9 +40105,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4046 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4046 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "function" ) -# 40067 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40111 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40086,9 +40130,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4047 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "functor" ) -# 40092 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40136 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40111,9 +40155,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4048 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4048 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "if" ) -# 40117 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40161 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40136,9 +40180,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4049 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4049 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "in" ) -# 40142 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40186 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40161,9 +40205,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4050 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4050 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "include" ) -# 40167 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40211 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40186,9 +40230,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4051 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "inherit" ) -# 40192 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40236 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40211,9 +40255,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4052 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4052 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "initializer" ) -# 40217 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40261 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40236,9 +40280,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4053 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4053 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "lazy" ) -# 40242 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40286 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40261,9 +40305,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4054 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4054 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "let" ) -# 40267 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40311 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40286,9 +40330,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4055 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4055 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "match" ) -# 40292 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40336 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40311,9 +40355,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4056 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4056 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "method" ) -# 40317 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40361 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40336,9 +40380,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4057 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "module" ) -# 40342 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40386 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40361,9 +40405,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4058 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4058 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "mutable" ) -# 40367 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40411 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40386,9 +40430,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4059 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4059 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "new" ) -# 40392 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40436 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40411,9 +40455,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "nonrec" ) -# 40417 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40461 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40436,9 +40480,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4061 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4061 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "object" ) -# 40442 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40486 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40461,9 +40505,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4062 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4062 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "of" ) -# 40467 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40486,9 +40530,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4063 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4063 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "open" ) -# 40492 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40536 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40511,9 +40555,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4064 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4064 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "or" ) -# 40517 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40561 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40536,9 +40580,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4065 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "private" ) -# 40542 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40586 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40561,9 +40605,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4066 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4066 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "rec" ) -# 40567 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40611 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40586,9 +40630,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4067 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4067 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "sig" ) -# 40592 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40636 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40611,9 +40655,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4068 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4068 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "struct" ) -# 40617 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40661 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40636,9 +40680,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4069 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4069 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "then" ) -# 40642 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40686 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40661,9 +40705,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4070 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4070 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "to" ) -# 40667 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40711 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40686,9 +40730,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4071 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4071 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "true" ) -# 40692 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40736 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40711,9 +40755,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4072 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4072 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "try" ) -# 40717 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40761 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40736,9 +40780,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4073 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4073 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "type" ) -# 40742 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40786 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40761,9 +40805,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4074 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4074 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "val" ) -# 40767 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40811 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40786,9 +40830,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4075 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4075 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "virtual" ) -# 40792 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40836 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40811,9 +40855,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4076 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "when" ) -# 40817 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40861 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40836,9 +40880,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4077 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4077 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "while" ) -# 40842 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40886 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40861,9 +40905,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4078 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4078 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "with" ) -# 40867 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40886,9 +40930,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.type_exception * string Location.loc option) = -# 3328 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3328 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40892 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 40936 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40962,18 +41006,18 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = let attrs = let _1 = _1_inlined5 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40968 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41012 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined5_ in let attrs2 = let _1 = _1_inlined4 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40977 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41021 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let lid = @@ -40982,9 +41026,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40988 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41032 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let id = @@ -40993,30 +41037,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40999 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41043 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41007 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3337 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3337 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let docs = symbol_docs _sloc in Te.mk_exception ~attrs (Te.rebind id lid ~attrs:(attrs1 @ attrs2) ~loc ~docs) , ext ) -# 41020 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41064 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41046,9 +41090,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2828 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2828 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 41052 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41096 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41081,9 +41125,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2830 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2830 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (l, o, p) = _1 in ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) ) -# 41087 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41131 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41134,17 +41178,17 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _3 = -# 2723 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2723 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 41140 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41184 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2832 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2832 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_newtypes ~loc:_sloc _3 _5 ) -# 41148 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41192 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41171,39 +41215,39 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 41175 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41219 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let xs = let items = -# 1074 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1074 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 41181 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41225 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1519 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1519 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( items ) -# 41186 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41230 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 41192 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41236 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 996 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 41201 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41245 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1512 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1512 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41207 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41251 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41244,7 +41288,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 41248 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41292 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let xs = let items = @@ -41252,65 +41296,65 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41258 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41302 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1526 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1526 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 41263 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41307 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1008 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1008 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 41271 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41315 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1027 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1027 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 41281 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41325 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1076 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x ) -# 41287 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41331 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1519 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1519 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( items ) -# 41293 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41337 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 41299 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41343 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_e_) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 996 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 41308 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41352 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1512 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1512 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41314 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41358 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41336,9 +41380,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4150 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4150 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( val_of_lwt_bindings ~loc:_loc _1 ) -# 41342 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41386 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41364,9 +41408,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1541 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1541 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( val_of_let_bindings ~loc:_sloc _1 ) -# 41370 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41414 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41400,9 +41444,9 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41406 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41450 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -41410,10 +41454,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1544 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1544 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in Pstr_extension (_1, add_docs_attrs docs _2) ) -# 41417 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41461 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -41421,15 +41465,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1043 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkstr ~loc:_sloc _1 ) -# 41427 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41471 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41433 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41477 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41453,23 +41497,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1547 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1547 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pstr_attribute _1 ) -# 41459 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41503 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1043 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkstr ~loc:_sloc _1 ) -# 41467 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41473 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41517 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41493,23 +41537,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1551 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1551 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( pstr_primitive _1 ) -# 41499 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41543 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41507 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41551 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41513 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41557 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41533,23 +41577,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1553 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1553 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( pstr_primitive _1 ) -# 41539 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41583 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41547 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41591 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41553 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41597 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41584,26 +41628,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1235 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1235 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 41590 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41634 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3170 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3170 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41595 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41639 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3153 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3153 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41601 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41645 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1555 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1555 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( pstr_type _1 ) -# 41607 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41651 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -41611,15 +41655,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41617 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41661 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41623 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41667 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41704,16 +41748,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41710 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41754 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = -# 1227 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1227 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 41717 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41761 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -41721,46 +41765,46 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41727 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41771 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _4 = -# 3948 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3948 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 41733 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41777 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41740 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41784 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3425 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3425 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in let attrs = attrs1 @ attrs2 in Te.mk tid cs ~params ~priv ~attrs ~docs, ext ) -# 41752 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41796 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3408 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3408 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41758 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1557 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1557 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( pstr_typext _1 ) -# 41764 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41808 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -41768,15 +41812,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41774 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41818 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41780 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41824 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41868,16 +41912,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41874 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41918 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = -# 1227 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1227 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 41881 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41925 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -41885,52 +41929,52 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41891 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41935 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _4 = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos__1_inlined2_) in + let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3950 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3950 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 41902 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41946 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41910 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41954 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3425 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3425 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in let attrs = attrs1 @ attrs2 in Te.mk tid cs ~params ~priv ~attrs ~docs, ext ) -# 41922 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41966 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3408 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3408 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41928 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41972 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1557 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1557 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( pstr_typext _1 ) -# 41934 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41978 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -41938,15 +41982,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41944 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41988 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41950 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 41994 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41970,23 +42014,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1559 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1559 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( pstr_exception _1 ) -# 41976 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42020 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41984 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42028 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41990 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42034 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42049,9 +42093,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42055 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42099 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -42061,36 +42105,36 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42067 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42111 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42075 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42119 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1585 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1585 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in let body = Mb.mk name body ~attrs ~loc ~docs in Pstr_module body, ext ) -# 42088 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42132 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1561 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1561 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42094 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -42098,15 +42142,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 42104 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42148 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42110 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42154 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42185,9 +42229,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42191 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42235 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -42197,24 +42241,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42203 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42247 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42211 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42255 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1624 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1624 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in @@ -42222,25 +42266,25 @@ module Tables = struct ext, Mb.mk name body ~attrs ~loc ~docs ) -# 42226 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42270 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1235 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1235 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 42232 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42276 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1612 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1612 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42238 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42282 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1563 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1563 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( pstr_recmodule _1 ) -# 42244 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42288 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -42248,15 +42292,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 42254 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42298 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42260 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42304 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42280,23 +42324,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1565 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1565 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Pstr_modtype body, ext) ) -# 42286 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42330 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 42294 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42338 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42300 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42344 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42320,23 +42364,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1567 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1567 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Pstr_open body, ext) ) -# 42326 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42370 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 42334 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42378 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42340 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42384 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42406,9 +42450,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 42412 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42456 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let params : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = Obj.magic params in let virt : (Asttypes.virtual_flag) = Obj.magic virt in @@ -42426,9 +42470,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42432 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42476 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -42438,24 +42482,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42444 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42488 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42452 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42496 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1978 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1978 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -42463,25 +42507,25 @@ module Tables = struct ext, Ci.mk id body ~virt ~params ~attrs ~loc ~docs ) -# 42467 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42511 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1235 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1235 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 42473 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42517 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1967 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1967 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42479 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42523 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1569 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1569 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Pstr_class l, ext) ) -# 42485 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -42489,15 +42533,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 42495 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42501 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42545 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42521,23 +42565,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1571 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1571 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Pstr_class_type l, ext) ) -# 42527 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42571 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 42535 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42579 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42541 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42585 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42593,38 +42637,38 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42599 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42643 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42608 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42652 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1661 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1661 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Incl.mk thing ~attrs ~loc ~docs, ext ) -# 42622 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42666 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1573 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1573 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( pstr_include _1 ) -# 42628 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42672 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -42632,15 +42676,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1060 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1060 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 42638 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42682 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1575 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1575 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42644 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42688 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42663,9 +42707,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4013 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4013 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "-" ) -# 42669 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42713 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42688,9 +42732,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4014 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4014 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( "-." ) -# 42694 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42738 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42743,9 +42787,9 @@ module Tables = struct let _v : (Parsetree.row_field) = let _5 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42749 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42793 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined1_ in @@ -42754,18 +42798,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 42758 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 42763 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42807 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3699 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3699 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42769 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42813 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = @@ -42773,20 +42817,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42779 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42823 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3685 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3685 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let info = symbol_info _endpos in let attrs = add_info_attrs info _5 in Rf.tag ~loc:(make_loc _sloc) ~attrs _1 _3 _4 ) -# 42790 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42834 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42818,9 +42862,9 @@ module Tables = struct let _v : (Parsetree.row_field) = let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42824 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42868 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -42829,20 +42873,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42835 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42879 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3689 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3689 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let info = symbol_info _endpos in let attrs = add_info_attrs info _2 in Rf.tag ~loc:(make_loc _sloc) ~attrs _1 true [] ) -# 42846 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42890 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42874,7 +42918,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase) = let arg = # 124 "" ( None ) -# 42878 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42922 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined1_ in let dir = @@ -42883,18 +42927,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42889 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42933 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3911 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42898 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42942 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42925,9 +42969,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : ( -# 842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 42931 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42975 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let _1_inlined1 : (string) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in @@ -42938,23 +42982,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3915 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3915 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (s, _, _) = _1 in Pdir_string s ) -# 42944 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42988 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1065 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42952 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 42996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42958 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43002 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42964,18 +43008,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42970 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43014 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3911 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42979 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43023 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43006,9 +43050,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : ( -# 787 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 787 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 43012 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43056 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let _1_inlined1 : (string) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in @@ -43019,23 +43063,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3916 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3916 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _1 in Pdir_int (n ,m) ) -# 43025 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43069 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1065 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 43033 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43077 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 43039 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43083 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -43045,18 +43089,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43051 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43095 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3911 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 43060 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43104 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43096,23 +43140,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3917 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3917 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pdir_ident _1 ) -# 43102 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43146 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1065 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 43110 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43154 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 43116 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43160 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -43122,18 +43166,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43128 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43172 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3911 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 43137 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43181 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43173,23 +43217,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3918 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3918 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pdir_ident _1 ) -# 43179 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43223 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1065 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 43187 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43231 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 43193 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43237 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -43199,18 +43243,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43205 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43249 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3911 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 43214 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43258 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43247,26 +43291,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined2_ in let _v : (Parsetree.toplevel_phrase) = let arg = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos__1_inlined2_) in + let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3919 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3919 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pdir_bool false ) -# 43256 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43300 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1065 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 43264 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43308 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 43270 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43314 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -43276,18 +43320,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43282 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43326 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3911 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 43291 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43335 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43324,26 +43368,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_inlined2_ in let _v : (Parsetree.toplevel_phrase) = let arg = - let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos__1_inlined2_) in + let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3920 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3920 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pdir_bool true ) -# 43333 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43377 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1065 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 43341 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43385 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 43347 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43391 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -43353,18 +43397,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43359 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43403 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3911 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3911 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 43368 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43412 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43404,37 +43448,37 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43410 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43454 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1526 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1526 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 43415 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43459 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1008 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1008 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 43423 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43467 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 996 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 43432 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43476 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1275 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1275 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptop_def _1 ) -# 43438 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43482 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43467,21 +43511,21 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 43471 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43515 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 996 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 43479 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43523 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1279 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1279 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptop_def _1 ) -# 43485 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43511,9 +43555,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.toplevel_phrase) = -# 1283 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1283 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43517 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43561 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43536,9 +43580,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.toplevel_phrase) = -# 1286 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1286 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( raise End_of_file ) -# 43542 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43586 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43561,9 +43605,9 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.core_type) = -# 3591 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3591 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ty ) -# 43567 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43611 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43591,18 +43635,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 43595 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43639 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1166 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1166 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 43600 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43644 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3594 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3594 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_tuple tys ) -# 43606 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43650 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -43610,15 +43654,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43616 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43660 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3596 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3596 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43622 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43666 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43648,9 +43692,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type option * Parsetree.core_type option) = -# 2907 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2907 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Some _2, None) ) -# 43654 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43698 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43694,9 +43738,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.core_type option * Parsetree.core_type option) = -# 2908 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2908 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Some _2, Some _4) ) -# 43700 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43744 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43726,9 +43770,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type option * Parsetree.core_type option) = -# 2909 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2909 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (None, Some _2) ) -# 43732 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43776 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43744,9 +43788,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = -# 3244 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3244 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, Public, None) ) -# 43750 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43794 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43776,9 +43820,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = -# 3246 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3246 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 43782 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43826 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43801,9 +43845,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3870 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3870 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43807 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43851 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43833,9 +43877,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) = -# 3261 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3261 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2, _1 ) -# 43839 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43883 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43851,9 +43895,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = -# 3254 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3254 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 43857 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43901 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43876,9 +43920,9 @@ module Tables = struct let _startpos = _startpos_p_ in let _endpos = _endpos_p_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = -# 3256 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3256 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [p] ) -# 43882 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43926 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43918,18 +43962,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 43922 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43966 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1138 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1138 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 43927 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43971 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3258 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3258 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( ps ) -# 43933 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 43977 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43960,24 +44004,24 @@ module Tables = struct let _endpos = _endpos_tyvar_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3266 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3266 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_var tyvar ) -# 43966 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_tyvar_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43975 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44019 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3269 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3269 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43981 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44025 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44001,23 +44045,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3268 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3268 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 44007 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44051 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1041 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 44015 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44059 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3269 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3269 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44021 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44065 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44033,9 +44077,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3273 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3273 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( NoVariance, NoInjectivity ) -# 44039 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44083 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44058,9 +44102,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3274 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3274 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Covariant, NoInjectivity ) -# 44064 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44108 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44083,9 +44127,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3275 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3275 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Contravariant, NoInjectivity ) -# 44089 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44133 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44108,9 +44152,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3276 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3276 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( NoVariance, Injective ) -# 44114 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44158 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44140,9 +44184,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3277 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3277 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Covariant, Injective ) -# 44146 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44190 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44172,9 +44216,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3277 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3277 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Covariant, Injective ) -# 44178 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44222 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44204,9 +44248,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3278 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3278 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Contravariant, Injective ) -# 44210 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44254 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44236,9 +44280,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3278 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3278 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Contravariant, Injective ) -# 44242 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44286 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44257,21 +44301,21 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 779 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 779 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 44263 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44307 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 3280 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3280 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( if _1 = "+!" then Covariant, Injective else if _1 = "-!" then Contravariant, Injective else (expecting _loc__1_ "type_variance"; NoVariance, NoInjectivity) ) -# 44275 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44319 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44290,21 +44334,21 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 828 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 828 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 44296 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44340 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 3285 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3285 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( if _1 = "!+" then Covariant, Injective else if _1 = "!-" then Contravariant, Injective else (expecting _loc__1_ "type_variance"; NoVariance, NoInjectivity) ) -# 44308 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44352 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44338,39 +44382,39 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 44342 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44386 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let xs = let _1 = -# 1074 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1074 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( [] ) -# 44348 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44392 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1306 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1306 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44353 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44397 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 44359 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44403 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_xss_) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1000 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1000 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_def _startpos _endpos _1 ) -# 44368 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44412 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1299 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1299 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44374 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44418 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44418,7 +44462,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 44422 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44466 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let xs = let _1 = @@ -44426,61 +44470,61 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44432 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44476 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1526 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1526 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 44437 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44481 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1018 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1018 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 44443 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44487 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1016 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 44451 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44495 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1076 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( x ) -# 44457 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44501 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1306 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1306 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44463 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44507 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 44469 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44513 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xss_, _startpos_e_) in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1000 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1000 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( extra_def _startpos _endpos _1 ) -# 44478 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44522 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1299 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1299 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44484 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44528 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44517,9 +44561,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = -# 3769 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3769 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 44523 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44567 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44538,17 +44582,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 44544 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44588 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3777 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3777 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44552 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44596 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44571,9 +44615,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3778 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3778 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44577 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44621 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44596,9 +44640,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3846 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3846 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44602 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44646 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44643,9 +44687,9 @@ module Tables = struct let ty : (Parsetree.core_type) = Obj.magic ty in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 44649 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44693 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let mutable_ : (Asttypes.mutable_flag) = Obj.magic mutable_ in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -44656,33 +44700,33 @@ module Tables = struct Parsetree.attributes) = let label = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44662 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44706 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44670 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44714 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs = -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44676 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44720 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4006 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4006 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 44681 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44725 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2124 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2124 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (label, mutable_, Cfk_virtual ty), attrs ) -# 44686 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44730 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44727,9 +44771,9 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 44733 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44777 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -44740,33 +44784,33 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44746 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44790 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44754 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44798 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44760 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44804 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 44765 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44809 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2126 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 44770 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44814 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44817,9 +44861,9 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 44823 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44867 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -44831,36 +44875,36 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44837 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44881 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44845 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44889 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44853 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44897 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 44859 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44903 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 2126 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2126 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 44864 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44908 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44912,9 +44956,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _5 in let _1_inlined1 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 44918 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44962 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined1 in let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in let _1 : (Parsetree.attributes) = Obj.magic _1 in @@ -44925,30 +44969,30 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44931 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44975 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44939 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44983 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44946 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44990 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = -# 4009 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4009 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 44952 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 44996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__7_ in @@ -44964,11 +45008,11 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2129 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2129 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 44972 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45016 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45026,9 +45070,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _5 in let _1_inlined2 : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 45032 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1_inlined2 in let _3 : (Asttypes.mutable_flag) = Obj.magic _3 in let _1_inlined1 : (Parsetree.attributes) = Obj.magic _1_inlined1 in @@ -45040,33 +45084,33 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3743 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3743 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 45046 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45090 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45054 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45098 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 45063 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = -# 4010 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4010 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Override ) -# 45070 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45114 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -45081,11 +45125,11 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2129 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 2129 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 45089 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45133 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45152,9 +45196,9 @@ module Tables = struct let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4103 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 45158 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45202 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -45164,30 +45208,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45170 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45214 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4107 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4107 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 45178 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45222 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3115 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3115 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in let docs = symbol_docs _sloc in Val.mk id ty ~attrs ~loc ~docs, ext ) -# 45191 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45235 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45203,9 +45247,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.virtual_flag) = -# 3970 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3970 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Concrete ) -# 45209 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45253 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45228,9 +45272,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.virtual_flag) = -# 3971 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3971 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Virtual ) -# 45234 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45278 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45253,9 +45297,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag) = -# 3994 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3994 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Immutable ) -# 45259 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45303 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45285,9 +45329,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag) = -# 3995 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3995 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 45291 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45335 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45317,9 +45361,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag) = -# 3996 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3996 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 45323 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45367 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45342,9 +45386,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = -# 4001 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4001 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public ) -# 45348 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45392 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45374,9 +45418,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 4002 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4002 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 45380 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45424 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45406,9 +45450,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 4003 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4003 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 45412 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45456 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45470,27 +45514,27 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 45474 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45518 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 1088 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1088 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( xs ) -# 45479 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45523 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3215 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3215 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 45485 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45529 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos_xs_ in let _5 = let _1 = _1_inlined2 in -# 3539 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 45494 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45538 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -45499,16 +45543,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45505 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45549 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3458 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3458 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let lident = loc_last _3 in Pwith_type (_3, @@ -45518,7 +45562,7 @@ module Tables = struct ~manifest:_5 ~priv:_4 ~loc:(make_loc _sloc))) ) -# 45522 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45566 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45571,9 +45615,9 @@ module Tables = struct let _v : (Parsetree.with_constraint) = let _5 = let _1 = _1_inlined2 in -# 3539 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3539 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 45577 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45621 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in @@ -45583,16 +45627,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45589 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45633 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3471 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3471 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( let lident = loc_last _3 in Pwith_typesubst (_3, @@ -45600,7 +45644,7 @@ module Tables = struct ~params:_2 ~manifest:_5 ~loc:(make_loc _sloc))) ) -# 45604 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45648 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45649,9 +45693,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45655 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45699 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -45660,15 +45704,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45666 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45710 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3479 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3479 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pwith_module (_2, _4) ) -# 45672 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45716 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45717,9 +45761,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45723 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45767 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -45728,15 +45772,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45734 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45778 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3481 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3481 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pwith_modsubst (_2, _4) ) -# 45740 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45784 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45792,15 +45836,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45798 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3483 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3483 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pwith_modtype (l, rhs) ) -# 45804 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45848 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45856,15 +45900,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1004 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 1004 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45862 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45906 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in -# 3485 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3485 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Pwith_modtypesubst (l, rhs) ) -# 45868 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45912 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45887,9 +45931,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = -# 3488 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3488 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Public ) -# 45893 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45937 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45919,9 +45963,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3489 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 3489 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" ( Private ) -# 45925 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 45969 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45957,9 +46001,9 @@ module MenhirInterpreter = struct | T_VAL : unit terminal | T_UNDERSCORE : unit terminal | T_UIDENT : ( -# 856 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 856 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 45963 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46007 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_TYPE : unit terminal | T_TRY_LWT : unit terminal @@ -45970,9 +46014,9 @@ module MenhirInterpreter = struct | T_THEN : unit terminal | T_STRUCT : unit terminal | T_STRING : ( -# 842 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 842 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 45976 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46020 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_STAR : unit terminal | T_SLASHGREATER : unit terminal @@ -45984,22 +46028,22 @@ module MenhirInterpreter = struct | T_RBRACKET : unit terminal | T_RBRACE : unit terminal | T_QUOTED_STRING_ITEM : ( -# 847 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 847 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 45990 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46034 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_QUOTED_STRING_EXPR : ( -# 844 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 844 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 45995 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46039 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_QUOTE : unit terminal | T_QUESTION : unit terminal | T_PRIVATE : unit terminal | T_PREFIXOP : ( -# 828 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 828 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46003 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46047 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_PLUSEQ : unit terminal | T_PLUSDOT : unit terminal @@ -46007,9 +46051,9 @@ module MenhirInterpreter = struct | T_PERCENT : unit terminal | T_OR : unit terminal | T_OPTLABEL : ( -# 821 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 821 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46013 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46057 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_OPEN : unit terminal | T_OF : unit terminal @@ -46026,15 +46070,15 @@ module MenhirInterpreter = struct | T_MATCH : unit terminal | T_LPAREN : unit terminal | T_LIDENT : ( -# 802 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 802 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46032 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46076 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_LET_LWT : unit terminal | T_LETOP : ( -# 783 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 783 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46038 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46082 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_LET : unit terminal | T_LESSSLASH : unit terminal @@ -46053,69 +46097,69 @@ module MenhirInterpreter = struct | T_LBRACE : unit terminal | T_LAZY : unit terminal | T_LABEL : ( -# 788 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 788 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46059 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46103 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_JSX_UIDENT_E : ( -# 858 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 858 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46064 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46108 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_JSX_UIDENT : ( -# 857 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 857 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46069 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46113 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_JSX_LIDENT_E : ( -# 804 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 804 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46074 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46118 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_JSX_LIDENT : ( -# 803 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 803 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46079 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46123 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_INT : ( -# 787 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 787 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 46084 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46128 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_INITIALIZER : unit terminal | T_INHERIT : unit terminal | T_INFIXOP4 : ( -# 781 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 781 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46091 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46135 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP3 : ( -# 780 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 780 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46096 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46140 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP2 : ( -# 779 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 779 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46101 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46145 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP1 : ( -# 778 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 778 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46106 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46150 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP0 : ( -# 777 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 777 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46111 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46155 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_INCLUDE : unit terminal | T_IN : unit terminal | T_IF : unit terminal | T_HASHOP : ( -# 839 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 839 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46119 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46163 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_HASH : unit terminal | T_GREATERRBRACKET : unit terminal @@ -46128,9 +46172,9 @@ module MenhirInterpreter = struct | T_FOR_LWT : unit terminal | T_FOR : unit terminal | T_FLOAT : ( -# 765 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 765 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * char option) -# 46134 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46178 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_FINALLY_LWT : unit terminal | T_FALSE : unit terminal @@ -46144,25 +46188,25 @@ module MenhirInterpreter = struct | T_DOWNTO : unit terminal | T_DOTTILDE : unit terminal | T_DOTOP : ( -# 782 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 782 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46150 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46194 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_DOTLESS : unit terminal | T_DOTDOT : unit terminal | T_DOT : unit terminal | T_DONE : unit terminal | T_DOCSTRING : ( -# 866 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 866 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (Docstrings.docstring) -# 46159 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46203 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_DO : unit terminal | T_CONSTRAINT : unit terminal | T_COMMENT : ( -# 865 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 865 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string * Location.t) -# 46166 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46210 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_COMMA : unit terminal | T_COLONGREATER : unit terminal @@ -46171,9 +46215,9 @@ module MenhirInterpreter = struct | T_COLON : unit terminal | T_CLASS : unit terminal | T_CHAR : ( -# 745 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 745 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (char) -# 46177 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46221 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_BEGIN : unit terminal | T_BARRBRACKET : unit terminal @@ -46184,9 +46228,9 @@ module MenhirInterpreter = struct | T_ASSERT : unit terminal | T_AS : unit terminal | T_ANDOP : ( -# 784 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 784 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" (string) -# 46190 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 46234 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" ) terminal | T_AND : unit terminal | T_AMPERSAND : unit terminal @@ -46382,13 +46426,13 @@ module MenhirInterpreter = struct Parsetree.type_declaration) nonterminal | N_generic_type_declaration_no_nonrec_flag_type_subst_kind_ : ((Asttypes.rec_flag * string Location.loc option) * Parsetree.type_declaration) nonterminal - | N_generic_constructor_declaration_epsilon_ : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + | N_generic_constructor_declaration_epsilon_ : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) nonterminal - | N_generic_constructor_declaration_BAR_ : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) nonterminal + | N_generic_constructor_declaration_BAR_ : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) nonterminal - | N_generalized_constructor_arguments : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) nonterminal + | N_generalized_constructor_arguments : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) nonterminal | N_functor_args : ((Lexing.position * Parsetree.functor_parameter) list) nonterminal | N_functor_arg : (Lexing.position * Parsetree.functor_parameter) nonterminal @@ -47314,12 +47358,12 @@ module Incremental = struct end -# 4194 "ocamlmerlin_mlx/preprocess/parser_raw.mly" +# 4194 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly" -# 47321 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 47365 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" # 269 "" -# 47326 "ocamlmerlin_mlx/preprocess/parser_raw.ml" +# 47370 "ocamlmerlin_mlx/ocaml/preprocess/parser_raw.ml" diff --git a/ocamlmerlin_mlx/preprocess/parser_raw.mli b/ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mli similarity index 98% rename from ocamlmerlin_mlx/preprocess/parser_raw.mli rename to ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mli index af81d5c..e58d951 100644 --- a/ocamlmerlin_mlx/preprocess/parser_raw.mli +++ b/ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mli @@ -519,13 +519,13 @@ module MenhirInterpreter : sig Parsetree.type_declaration) nonterminal | N_generic_type_declaration_no_nonrec_flag_type_subst_kind_ : ((Asttypes.rec_flag * string Location.loc option) * Parsetree.type_declaration) nonterminal - | N_generic_constructor_declaration_epsilon_ : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + | N_generic_constructor_declaration_epsilon_ : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) nonterminal - | N_generic_constructor_declaration_BAR_ : (Ocaml_parsing.Ast_helper.str * Ocaml_parsing.Ast_helper.str list * + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) nonterminal + | N_generic_constructor_declaration_BAR_ : (Mlx_ocaml_parsing.Ast_helper.str * Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option * - Parsetree.attributes * Warnings.loc * Ocaml_parsing.Docstrings.info) nonterminal - | N_generalized_constructor_arguments : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * + Parsetree.attributes * Warnings.loc * Mlx_ocaml_parsing.Docstrings.info) nonterminal + | N_generalized_constructor_arguments : (Mlx_ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) nonterminal | N_functor_args : ((Lexing.position * Parsetree.functor_parameter) list) nonterminal | N_functor_arg : (Lexing.position * Parsetree.functor_parameter) nonterminal diff --git a/ocamlmerlin_mlx/preprocess/parser_raw.mly b/ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly similarity index 100% rename from ocamlmerlin_mlx/preprocess/parser_raw.mly rename to ocamlmerlin_mlx/ocaml/preprocess/parser_raw.mly diff --git a/ocamlmerlin_mlx/preprocess/parser_recover.ml b/ocamlmerlin_mlx/ocaml/preprocess/parser_recover.ml similarity index 100% rename from ocamlmerlin_mlx/preprocess/parser_recover.ml rename to ocamlmerlin_mlx/ocaml/preprocess/parser_recover.ml diff --git a/ocamlmerlin_mlx/ocaml/preprocess/printer/dune b/ocamlmerlin_mlx/ocaml/preprocess/printer/dune new file mode 100644 index 0000000..04537bd --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/printer/dune @@ -0,0 +1,9 @@ +(executable + (name gen_printer) + (libraries unix menhirSdk)) + +(copy_files + (enabled_if + (<> %{profile} "release")) + (mode promote) + (files %{project_root}/merlin/src/ocaml/preprocess/printer/*.{ml,mli})) diff --git a/ocamlmerlin_mlx/ocaml/preprocess/printer/gen_printer.ml b/ocamlmerlin_mlx/ocaml/preprocess/printer/gen_printer.ml new file mode 100644 index 0000000..0f71dea --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/printer/gen_printer.ml @@ -0,0 +1,125 @@ +open MenhirSdk + +include Cmly_read.Read(struct let filename = Sys.argv.(1) end) + +let is_attribute names attr = + List.exists (fun l -> Attribute.has_label l attr) names + +let printf = Printf.printf +let sprintf = Printf.sprintf + +let menhir = "MenhirInterpreter" + +(** Print header, if any *) + +let print_header () = + let name = Filename.chop_extension (Filename.basename Sys.argv.(1)) in + printf "open %s\n" (String.capitalize_ascii name); + List.iter + (fun attr -> + if is_attribute ["header"; "printer.header"] attr then + printf "%s\n" (Attribute.payload attr)) + Grammar.attributes + +(** Printer from attributes *) + +let symbol_printer default attribs = + match List.find (is_attribute ["symbol"]) attribs with + | attr -> Attribute.payload attr + | exception Not_found -> + sprintf "%S" default + +let print_symbol () = + let case_t t = + match Terminal.kind t with + | `REGULAR | `ERROR | `EOF -> + printf " | %s.X (%s.T %s.T_%s) -> %s\n" + menhir menhir menhir + (Terminal.name t) + (symbol_printer (Terminal.name t) (Terminal.attributes t)) + | `PSEUDO -> () + and case_n n = + match Nonterminal.kind n with + | `REGULAR -> + printf " | %s.X (%s.N %s.N_%s) -> %s\n" + menhir menhir menhir + (Nonterminal.mangled_name n) + (symbol_printer (Nonterminal.mangled_name n) (Nonterminal.attributes n)) + | `START -> () + in + printf "let print_symbol = function\n"; + Terminal.iter case_t; + Nonterminal.iter case_n + +let value_printer default attribs = + match List.find (is_attribute ["printer"]) attribs with + | attr -> sprintf "(%s)" (Attribute.payload attr) + | exception Not_found -> + sprintf "(fun _ -> %s)" (symbol_printer default attribs) + +let print_value () = + let case_t t = + match Terminal.kind t with + | `REGULAR | `ERROR | `EOF-> + printf " | %s.T %s.T_%s -> %s\n" + menhir menhir + (Terminal.name t) + (value_printer (Terminal.name t) (Terminal.attributes t)) + | `PSEUDO -> () + and case_n n = + match Nonterminal.kind n with + | `REGULAR -> + printf " | %s.N %s.N_%s -> %s\n" + menhir menhir + (Nonterminal.mangled_name n) + (value_printer (Nonterminal.mangled_name n) (Nonterminal.attributes n)) + | `START -> () + in + printf "let print_value (type a) : a %s.symbol -> a -> string = function\n" + menhir; + Terminal.iter case_t; + Nonterminal.iter case_n + +let print_token () = + let case t = + match Terminal.kind t with + | `REGULAR | `EOF -> + printf " | %s%s -> print_value (%s.T %s.T_%s) %s\n" + (Terminal.name t) + (match Terminal.typ t with | None -> "" | Some _typ -> " v") + menhir menhir + (Terminal.name t) + (match Terminal.typ t with | None -> "()" | Some _typ -> "v") + | `PSEUDO | `ERROR -> () + in + printf "let print_token = function\n"; + Terminal.iter case + +let print_token_of_terminal () = + let case t = + match Terminal.kind t with + | `REGULAR | `EOF -> + printf " | %s.T_%s -> %s%s\n" + menhir (Terminal.name t) + (Terminal.name t) (if Terminal.typ t <> None then " v" else "") + | `ERROR -> + printf " | %s.T_%s -> assert false\n" + menhir (Terminal.name t) + | `PSEUDO -> () + in + printf + "let token_of_terminal (type a) (t : a %s.terminal) (v : a) : token =\n\ + \ match t with\n" + menhir; + Terminal.iter case + +let () = + print_header (); + print_newline (); + print_symbol (); + print_newline (); + print_value (); + print_newline (); + print_token (); + print_newline (); + print_token_of_terminal () diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/compressedBitSet.ml b/ocamlmerlin_mlx/ocaml/preprocess/recover/compressedBitSet.ml new file mode 100644 index 0000000..9a4783d --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/compressedBitSet.ml @@ -0,0 +1,238 @@ +(******************************************************************************) +(* *) +(* Menhir *) +(* *) +(* François Pottier, Inria Paris *) +(* Yann Régis-Gianas, PPS, Université Paris Diderot *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under the *) +(* terms of the GNU General Public License version 2, as described in the *) +(* file LICENSE. *) +(* *) +(******************************************************************************) + +(* A compressed (or should we say sparse?) bit set is a list of pairs + of integers. The first component of every pair is an index, while + the second component is a bit field. The list is sorted by order + of increasing indices. *) + +type t = + | N + | C of int * int * t + +type element = + int + +let word_size = + Sys.word_size - 1 + +let empty = + N + +let is_empty = function + | N -> + true + | C _ -> + false + +let add i s = + let ioffset = i mod word_size in + let iaddr = i - ioffset + and imask = 1 lsl ioffset in + let rec add = function + | N -> + (* Insert at end. *) + C (iaddr, imask, N) + | C (addr, ss, qs) as s -> + if iaddr < addr then + (* Insert in front. *) + C (iaddr, imask, s) + else if iaddr = addr then + (* Found appropriate cell, update bit field. *) + let ss' = ss lor imask in + if ss' = ss then + s + else + C (addr, ss', qs) + else + (* Not there yet, continue. *) + let qs' = add qs in + if qs == qs' then + s + else + C (addr, ss, qs') + in + add s + +let singleton i = + add i N + +let remove i s = + let ioffset = i mod word_size in + let iaddr = i - ioffset + and imask = 1 lsl ioffset in + let rec remove = function + | N -> + N + | C (addr, ss, qs) as s -> + if iaddr < addr then + s + else if iaddr = addr then + (* Found appropriate cell, update bit field. *) + let ss' = ss land (lnot imask) in + if ss' = 0 then + qs + else if ss' = ss then + s + else + C (addr, ss', qs) + else + (* Not there yet, continue. *) + let qs' = remove qs in + if qs == qs' then + s + else + C (addr, ss, qs') + in + remove s + +let rec fold f s accu = + match s with + | N -> + accu + | C (base, ss, qs) -> + loop f qs base ss accu + +and loop f qs i ss accu = + if ss = 0 then + fold f qs accu + else + (* One could in principle check whether [ss land 0x3] is zero and if + so move to [i + 2] and [ss lsr 2], and similarly for various sizes. + In practice, this does not seem to make a measurable difference. *) + loop f qs (i + 1) (ss lsr 1) (if ss land 1 = 1 then f i accu else accu) + +let iter f s = + fold (fun x () -> f x) s () + +let is_singleton s = + match s with + | C (_, ss, N) -> + (* Test whether only one bit is set in [ss]. We do this by turning + off the rightmost bit, then comparing to zero. *) + ss land (ss - 1) = 0 + | C (_, _, C _) + | N -> + false + +let cardinal s = + fold (fun _ m -> m + 1) s 0 + +let elements s = + fold (fun tl hd -> tl :: hd) s [] + +let rec subset s1 s2 = + match s1, s2 with + | N, _ -> + true + | _, N -> + false + | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> + if addr1 < addr2 then + false + else if addr1 = addr2 then + if (ss1 land ss2) <> ss1 then + false + else + subset qs1 qs2 + else + subset s1 qs2 + +let mem i s = + subset (singleton i) s + +let rec union s1 s2 = + match s1, s2 with + | N, s + | s, N -> + s + | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> + if addr1 < addr2 then + C (addr1, ss1, union qs1 s2) + else if addr1 > addr2 then + let s = union s1 qs2 in + if s == qs2 then + s2 + else + C (addr2, ss2, s) + else + let ss = ss1 lor ss2 in + let s = union qs1 qs2 in + if ss == ss2 && s == qs2 then + s2 + else + C (addr1, ss, s) + +let rec inter s1 s2 = + match s1, s2 with + | N, _ + | _, N -> + N + | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> + if addr1 < addr2 then + inter qs1 s2 + else if addr1 > addr2 then + inter s1 qs2 + else + let ss = ss1 land ss2 in + let s = inter qs1 qs2 in + if ss = 0 then + s + else + if (ss = ss1) && (s == qs1) then + s1 + else + C (addr1, ss, s) + +exception Found of int + +let choose s = + try + iter (fun x -> + raise (Found x) + ) s; + raise Not_found + with Found x -> + x + +let rec compare s1 s2 = + match s1, s2 with + N, N -> 0 + | _, N -> 1 + | N, _ -> -1 + | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> + if addr1 < addr2 then -1 + else if addr1 > addr2 then 1 + else if ss1 < ss2 then -1 + else if ss1 > ss2 then 1 + else compare qs1 qs2 + +let equal s1 s2 = + compare s1 s2 = 0 + +let rec disjoint s1 s2 = + match s1, s2 with + | N, _ + | _, N -> + true + | C (addr1, ss1, qs1), C (addr2, ss2, qs2) -> + if addr1 = addr2 then + if (ss1 land ss2) = 0 then + disjoint qs1 qs2 + else + false + else if addr1 < addr2 then + disjoint qs1 s2 + else + disjoint s1 qs2 + diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/compressedBitSet.mli b/ocamlmerlin_mlx/ocaml/preprocess/recover/compressedBitSet.mli new file mode 100644 index 0000000..bfbd47d --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/compressedBitSet.mli @@ -0,0 +1,14 @@ +(******************************************************************************) +(* *) +(* Menhir *) +(* *) +(* François Pottier, Inria Paris *) +(* Yann Régis-Gianas, PPS, Université Paris Diderot *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under the *) +(* terms of the GNU General Public License version 2, as described in the *) +(* file LICENSE. *) +(* *) +(******************************************************************************) + +include GSet.S with type element = int diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/dune b/ocamlmerlin_mlx/ocaml/preprocess/recover/dune new file mode 100644 index 0000000..2459fc3 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/dune @@ -0,0 +1,10 @@ +(executable + (name gen_recover) + (flags :standard -w -67) + (libraries unix menhirSdk)) + +(copy_files + (enabled_if + (<> %{profile} "release")) + (mode promote) + (files %{project_root}/merlin/src/ocaml/preprocess/recover/*.{ml,mli})) diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/emitter.ml b/ocamlmerlin_mlx/ocaml/preprocess/recover/emitter.ml new file mode 100644 index 0000000..2154fee --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/emitter.ml @@ -0,0 +1,301 @@ +open MenhirSdk.Cmly_api +open Utils + +let menhir = "MenhirInterpreter" + +(* Generation scheme doing checks and failing at runtime, or not ... *) +let safe = false + +module Codeconsing (S : Synthesis.S) (R : Recovery.S with module G = S.G) : sig + + (* Step 1: record all definitions *) + val record_item : R.item -> unit + + type instr = + | Nil + | Cons of instr S.paction * instr + | Ref of int ref * instr + + (* Step 2: get prelude maximizing & serialization function *) + val normalize : unit -> instr list * (R.item -> instr) + +end = struct + + open S + + type fixed = A of fixed paction list + + let normalized_actions = Hashtbl.create 113 + + let rec normalize_actions = function + | [] -> [] + | [Var v] -> normalize_actions (S.solution v) + | (x :: xs) as xxs -> + try !(Hashtbl.find normalized_actions xxs) + with Not_found -> + let x' = normalize_action x in + let xs' = normalize_actions xs in + let xxs' = x' :: xs' in + Hashtbl.add normalized_actions xxs (ref xxs'); + xxs' + + and normalize_action = function + | Abort | Reduce _ | Shift _ as a -> a + | Var v -> + match normalize_actions (S.solution v) with + | [x] -> x + | xs -> Var (A xs) + + let item_to_actions (st, prod, pos) = + normalize_actions [Var (Tail (st, prod, pos))] + + let roots : R.item list ref = ref [] + + let record_item root = + roots := root :: !roots + + let share () = + let table = Hashtbl.create 113 in + let rec get = function + | [] -> [] + | (x :: xs) -> + let xxs = (get_one x :: get xs) in + try + let r, v = Hashtbl.find table xxs in + incr r; v + with Not_found -> + Hashtbl.add table xxs (ref 1, xxs); + xxs + and get_one = function + | Var (A v) -> Var (A (get v)) + | x -> x + in + Hashtbl.iter (fun _k v -> v := get !v) normalized_actions; + (* Return counter *) + (fun v -> try !(fst (Hashtbl.find table v)) with Not_found -> 0) + + type instr = + | Nil + | Cons of instr paction * instr + | Ref of int ref * instr + + let emitter () = + let counter = share () in + let table = Hashtbl.create 113 in + let frozen = ref false in + let values = ref [] in + let rec emit = function + | [] -> Nil + | (x :: xs) as xxs -> + try Hashtbl.find table xxs + with Not_found -> + let x = match x with + | Var (A ys) -> Var (emit ys) + | Abort | Reduce _ | Shift _ as a -> a + in + let value = Cons (x, emit xs) in + if counter xxs = 1 then value else ( + assert (not !frozen); + let value = Ref (ref (-1), value) in + values := value :: !values; + Hashtbl.add table xxs value; + value + ) + in + frozen, values, emit + + let normalize () = + let roots = List.map item_to_actions !roots in + let frozen, values, emit = emitter () in + let pass_2 item = ignore (emit item) in + List.iter pass_2 roots; + frozen := true; + !values, (fun item -> emit (item_to_actions item)) +end + +module Make + (G : GRAMMAR) + (A : Recover_attrib.S with module G = G) + (S : Synthesis.S with module G = G) + (R : Recovery.S with module G = G) : +sig + val emit : Format.formatter -> unit +end = struct + + open G + open Format + + let emit_default_value ppf = + fprintf ppf "open %s\n\n" + (String.capitalize_ascii (Filename.basename Grammar.basename)); + fprintf ppf "module Default = struct\n"; + A.default_prelude ppf; + + fprintf ppf " let value (type a) : a %s.symbol -> a = function\n" menhir; + Terminal.iter (fun t -> + match A.default_terminal t with + | None -> () + | Some str -> + fprintf ppf " | %s.T %s.T_%s -> %s\n" menhir menhir (Terminal.name t) str + ); + Nonterminal.iter (fun n -> + match A.default_nonterminal n with + | None -> () + | Some str -> + fprintf ppf " | %s.N %s.N_%s -> %s\n" menhir menhir (Nonterminal.mangled_name n) str + ); + (*fprintf ppf " | _ -> raise Not_found\n"; should be exhaustive*) + fprintf ppf "end\n\n"; + fprintf ppf "let default_value = Default.value\n\n" + + let emit_defs ppf = + fprintf ppf "open %s\n\n" menhir; + fprintf ppf "type action =\n\ + \ | Abort\n\ + \ | R of int\n\ + \ | S : 'a symbol -> action\n\ + \ | Sub of action list\n\n"; + fprintf ppf "type decision =\n\ + \ | Nothing\n\ + \ | One of action list\n\ + \ | Select of (int -> action list)\n\n" + + module C = Codeconsing(S)(R) + + let emit_depth ppf = + let open Format in + fprintf ppf "let depth =\n [|"; + Lr1.iter (fun st -> + let depth, _ = R.recover st in + fprintf ppf "%d;" depth + ); + fprintf ppf "|]\n\n" + + let _code, get_instr, iter_entries = + Lr1.iter (fun st -> + let _depth, cases = R.recover st in + List.iter (fun (_case, items) -> C.record_item (list_last items)) + cases + ); + let code, get_instr = C.normalize () in + let all_instrs = + Lr1.tabulate (fun st -> + let _depth, cases = R.recover st in + List.map (fun (_case, items) -> get_instr (list_last items)) + cases + ) + in + code, get_instr, + (fun f -> Lr1.iter (fun st -> List.iter f (all_instrs st))) + + let emit_can_pop ppf = + Format.fprintf ppf "let can_pop (type a) : a terminal -> bool = function\n"; + G.Terminal.iter (fun t -> + if G.Terminal.kind t = `REGULAR && G.Terminal.typ t = None then + Format.fprintf ppf " | T_%s -> true\n" (G.Terminal.name t)); + Format.fprintf ppf " | _ -> false\n\n" + + let emit_recoveries ppf = + let k = ref 0 in + let instrs = ref [] in + let rec alloc_entry = function + | C.Nil -> () + | C.Cons (act, instr) -> alloc_entry_action act; alloc_entry instr + | C.Ref (r, instr) -> + if (!r = -1) then ( + alloc_entry instr; + r := !k; + instrs := (!k, instr) :: !instrs; + incr k; + ) + and alloc_entry_action = function + | S.Abort | S.Reduce _ | S.Shift _ -> () + | S.Var instr -> alloc_entry instr + in + iter_entries alloc_entry; + let open Format in + + let rec emit_action ppf = function + | S.Abort -> fprintf ppf "Abort" + | S.Reduce prod -> fprintf ppf "R %d" (Production.to_int prod) + | S.Shift (T t) -> fprintf ppf "S (T T_%s)" (Terminal.name t) + | S.Shift (N n) -> fprintf ppf "S (N N_%s)" (Nonterminal.mangled_name n) + | S.Var instr -> fprintf ppf "Sub (%a)" emit_instr instr + and emit_instr ppf = function + | C.Nil -> fprintf ppf "[]" + | C.Cons (act, C.Nil) -> + fprintf ppf "[%a]" emit_action act + | C.Cons (act, instr) -> + fprintf ppf "%a :: %a" emit_action act emit_instr instr + | C.Ref (r, _) -> fprintf ppf "r%d" !r + in + + fprintf ppf "let recover =\n"; + + let emit_shared (k, instr) = + fprintf ppf " let r%d = %a in\n" k emit_instr instr + in + List.iter emit_shared (List.rev !instrs); + + let all_cases = + Lr1.fold (fun st acc -> + let _, cases = R.recover st in + let cases = List.map (fun (st', items) -> + (get_instr (list_last items)), + (match st' with None -> -1 | Some st' -> Lr1.to_int st') + ) cases + in + let cases = match group_assoc cases with + | [] -> `Nothing + | [(instr, _)] -> `One instr + | xs -> `Select xs + in + (cases, (Lr1.to_int st)) :: acc) + [] + in + let all_cases = group_assoc all_cases in + + fprintf ppf " function\n"; + List.iter (fun (cases, states) -> + fprintf ppf " "; + List.iter (fprintf ppf "| %d ") states; + fprintf ppf "-> "; + match cases with + | `Nothing -> fprintf ppf "Nothing\n"; + | `One instr -> fprintf ppf "One (%a)\n" emit_instr instr + | `Select xs -> + fprintf ppf "Select (function\n"; + if safe then ( + List.iter (fun (instr, cases) -> + fprintf ppf " "; + List.iter (fprintf ppf "| %d ") cases; + fprintf ppf "-> %a\n" emit_instr instr; + ) xs; + fprintf ppf " | _ -> raise Not_found)\n" + ) else ( + match List.sort + (fun (_,a) (_,b) -> compare (List.length b) (List.length a)) + xs + with + | (instr, _) :: xs -> + List.iter (fun (instr, cases) -> + fprintf ppf " "; + List.iter (fprintf ppf "| %d ") cases; + fprintf ppf "-> %a\n" emit_instr instr; + ) xs; + fprintf ppf " | _ -> %a)\n" emit_instr instr + | [] -> assert false + ) + ) all_cases; + + fprintf ppf " | _ -> raise Not_found\n" + + + let emit ppf = + emit_default_value ppf; + emit_defs ppf; + emit_depth ppf; + emit_can_pop ppf; + emit_recoveries ppf + +end diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/emitter.mli b/ocamlmerlin_mlx/ocaml/preprocess/recover/emitter.mli new file mode 100644 index 0000000..962dd67 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/emitter.mli @@ -0,0 +1,10 @@ +open MenhirSdk.Cmly_api + +module Make + (G : GRAMMAR) + (A : Recover_attrib.S with module G = G) + (S : Synthesis.S with module G = G) + (R : Recovery.S with module G = G) : +sig + val emit : Format.formatter -> unit +end diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/fix.ml b/ocamlmerlin_mlx/ocaml/preprocess/recover/fix.ml new file mode 100644 index 0000000..36b275b --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/fix.ml @@ -0,0 +1,529 @@ +(******************************************************************************) +(* *) +(* Menhir *) +(* *) +(* François Pottier, Inria Paris *) +(* Yann Régis-Gianas, PPS, Université Paris Diderot *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under the *) +(* terms of the GNU General Public License version 2, as described in the *) +(* file LICENSE. *) +(* *) +(******************************************************************************) + +(* -------------------------------------------------------------------------- *) + +(* Maps. *) + +(* We require imperative maps, that is, maps that can be updated in place. + An implementation of persistent maps, such as the one offered by ocaml's + standard library, can easily be turned into an implementation of imperative + maps, so this is a weak requirement. *) + +module type IMPERATIVE_MAPS = sig + type key + type 'data t + val create: unit -> 'data t + val clear: 'data t -> unit + val add: key -> 'data -> 'data t -> unit + val find: key -> 'data t -> 'data + val iter: (key -> 'data -> unit) -> 'data t -> unit +end + +(* -------------------------------------------------------------------------- *) + +(* Properties. *) + +(* Properties must form a partial order, equipped with a least element, and + must satisfy the ascending chain condition: every monotone sequence + eventually stabilizes. *) + +(* [is_maximal] determines whether a property [p] is maximal with respect to + the partial order. Only a conservative check is required: in any event, it + is permitted for [is_maximal p] to return [false]. If [is_maximal p] + returns [true], then [p] must have no upper bound other than itself. In + particular, if properties form a lattice, then [p] must be the top + element. This feature, not described in the paper, enables a couple of + minor optimizations. *) + +module type PROPERTY = sig + type property + val bottom: property + val equal: property -> property -> bool + val is_maximal: property -> bool +end + +(* -------------------------------------------------------------------------- *) + +(* The dynamic dependency graph. *) + +(* An edge from [node1] to [node2] means that [node1] depends on [node2], or + (equivalently) that [node1] observes [node2]. Then, an update of the + current property at [node2] causes a signal to be sent to [node1]. A node + can observe itself. *) + +(* This module could be placed in a separate file, but is included here in + order to make [Fix] self-contained. *) + +module Graph : sig + + (* This module provides a data structure for maintaining and modifying + a directed graph. Each node is allowed to carry a piece of client + data. There are functions for creating a new node, looking up a + node's data, looking up a node's predecessors, and setting or + clearing a node's successors (all at once). *) + type 'data node + + (* [create data] creates a new node, with no incident edges, with + client information [data]. Time complexity: constant. *) + val create: 'data -> 'data node + + (* [data node] returns the client information associated with + the node [node]. Time complexity: constant. *) + val data: 'data node -> 'data + + (* [predecessors node] returns a list of [node]'s predecessors. + Amortized time complexity: linear in the length of the output + list. *) + val predecessors: 'data node -> 'data node list + + (* [set_successors src dsts] creates an edge from the node [src] to + each of the nodes in the list [dsts]. Duplicate elements in the + list [dsts] are removed, so that no duplicate edges are created. It + is assumed that [src] initially has no successors. Time complexity: + linear in the length of the input list. *) + val set_successors: 'data node -> 'data node list -> unit + + (* [clear_successors node] removes all of [node]'s outgoing edges. + Time complexity: linear in the number of edges that are removed. *) + val clear_successors: 'data node -> unit + + (* That's it. *) +end += struct + + (* Using doubly-linked adjacency lists, one could implement [predecessors] + in worst-case linear time with respect to the length of the output list, + [set_successors] in worst-case linear time with respect to the length of + the input list, and [clear_successors] in worst-case linear time with + respect to the number of edges that are removed. We use a simpler + implementation, based on singly-linked adjacency lists, with deferred + removal of edges. It achieves the same complexity bounds, except + [predecessors] only offers an amortized complexity bound. This is good + enough for our purposes, and, in practice, is more efficient by a + constant factor. This simplification was suggested by Arthur + Charguéraud. *) + + type 'data node = { + + (* The client information associated with this node. *) + + data: 'data; + + (* This node's incoming and outgoing edges. *) + + mutable outgoing: 'data edge list; + mutable incoming: 'data edge list; + + (* A transient mark, always set to [false], except when checking + against duplicate elements in a successor list. *) + + mutable marked: bool; + + } + + and 'data edge = { + + (* This edge's nodes. Edges are symmetric: source and destination + are not distinguished. Thus, an edge appears both in the outgoing + edge list of its source node and in the incoming edge list of its + destination node. This allows edges to be easily marked as + destroyed. *) + + node1: 'data node; + node2: 'data node; + + (* Edges that are destroyed are marked as such, but are not + immediately removed from the adjacency lists. *) + + mutable destroyed: bool; + + } + + let create (data : 'data) : 'data node = { + data = data; + outgoing = []; + incoming = []; + marked = false; + } + + let data (node : 'data node) : 'data = + node.data + + (* [follow src edge] returns the node that is connected to [src] + by [edge]. Time complexity: constant. *) + + let follow src edge = + if edge.node1 == src then + edge.node2 + else begin + assert (edge.node2 == src); + edge.node1 + end + + (* The [predecessors] function removes edges that have been marked + destroyed. The cost of removing these has already been paid for, + so the amortized time complexity of [predecessors] is linear in + the length of the output list. *) + + let predecessors (node : 'data node) : 'data node list = + let predecessors = List.filter (fun edge -> not edge.destroyed) node.incoming in + node.incoming <- predecessors; + List.map (follow node) predecessors + + (* [link src dst] creates a new edge from [src] to [dst], together + with its reverse edge. Time complexity: constant. *) + + let link (src : 'data node) (dst : 'data node) : unit = + let edge = { + node1 = src; + node2 = dst; + destroyed = false; + } in + src.outgoing <- edge :: src.outgoing; + dst.incoming <- edge :: dst.incoming + + let set_successors (src : 'data node) (dsts : 'data node list) : unit = + assert (src.outgoing = []); + let rec loop = function + | [] -> + () + | dst :: dsts -> + if dst.marked then + loop dsts (* skip duplicate elements *) + else begin + dst.marked <- true; + link src dst; + loop dsts; + dst.marked <- false + end + in + loop dsts + + let clear_successors (node : 'data node) : unit = + List.iter (fun edge -> + assert (not edge.destroyed); + edge.destroyed <- true; + ) node.outgoing; + node.outgoing <- [] + +end + +(* -------------------------------------------------------------------------- *) + +(* The code is parametric in an implementation of maps over variables and in + an implementation of properties. *) + +module Make + (M : IMPERATIVE_MAPS) + (P : PROPERTY) += struct + +type variable = + M.key + +type property = + P.property + +type valuation = + variable -> property + +type rhs = + valuation -> property + +type equations = + variable -> rhs + +(* -------------------------------------------------------------------------- *) + +(* Data. *) + +(* Each node in the dependency graph carries information about a fixed + variable [v]. *) + +type node = + data Graph.node + +and data = { + + (* This is the result of the application of [rhs] to the variable [v]. It + must be stored in order to guarantee that this application is performed + at most once. *) + rhs: rhs; + + (* This is the current property at [v]. It evolves monotonically with + time. *) + mutable property: property; + + (* That's it! *) +} + +(* [property node] returns the current property at [node]. *) + +let property node = + (Graph.data node).property + +(* -------------------------------------------------------------------------- *) + +(* Many definitions must be made within the body of the function [lfp]. + For greater syntactic convenience, we place them in a local module. *) + +let lfp (eqs : equations) : valuation = + let module LFP = struct + +(* -------------------------------------------------------------------------- *) + +(* The workset. *) + +(* When the algorithm is inactive, the workset is empty. *) + +(* Our workset is based on a Queue, but it could just as well be based on a + Stack. A textual replacement is possible. It could also be based on a + priority queue, provided a sensible way of assigning priorities could + be found. *) + +module Workset : sig + + (* [insert node] inserts [node] into the workset. [node] must have no + successors. *) + val insert: node -> unit + + (* [repeat f] repeatedly applies [f] to a node extracted out of the + workset, until the workset becomes empty. [f] is allowed to use + [insert]. *) + val repeat: (node -> unit) -> unit + + (* That's it! *) +end += struct + + (* Initialize the workset. *) + + let workset = + Queue.create() + + let insert node = + Queue.push node workset + + let repeat f = + while not (Queue.is_empty workset) do + f (Queue.pop workset) + done + +end + +(* -------------------------------------------------------------------------- *) + +(* Signals. *) + +(* A node in the workset has no successors. (It can have predecessors.) In + other words, a predecessor (an observer) of some node is never in the + workset. Furthermore, a node never appears twice in the workset. *) + +(* When a variable broadcasts a signal, all of its predecessors (observers) + receive the signal. Any variable that receives the signal loses all of its + successors (that is, it ceases to observe anything) and is inserted into + the workset. This preserves the above invariant. *) + +let signal subject = + List.iter (fun observer -> + Graph.clear_successors observer; + Workset.insert observer + ) (Graph.predecessors subject) + (* At this point, [subject] has no predecessors. This plays no role in + the correctness proof, though. *) + +(* -------------------------------------------------------------------------- *) + +(* Tables. *) + +(* The permanent table maps variables that have reached a fixed point + to properties. It persists forever. *) + +let permanent : property M.t = + M.create() + +(* The transient table maps variables that have not yet reached a + fixed point to nodes. (A node contains not only a property, but + also a memoized right-hand side, and carries edges.) At the + beginning of a run, it is empty. It fills up during a run. At the + end of a run, it is copied into the permanent table and cleared. *) + +let transient : node M.t = + M.create() + +(* [freeze()] copies the transient table into the permanent table, and + empties the transient table. This allows all nodes to be reclaimed + by the garbage collector. *) + +let freeze () = + M.iter (fun v node -> + M.add v (property node) permanent + ) transient; + M.clear transient + +(* -------------------------------------------------------------------------- *) + +(* Workset processing. *) + + +(* [solve node] re-evaluates the right-hand side at [node]. If this leads to + a change, then the current property is updated, and [node] emits a signal + towards its observers. *) + +(* When [solve node] is invoked, [node] has no subjects. Indeed, when [solve] + is invoked by [node_for], [node] is newly created; when [solve] is invoked by + [Workset.repeat], [node] has just been extracted out of the workset, and a + node in the workset has no subjects. *) + +(* [node] must not be in the workset. *) + +(* In short, when [solve node] is invoked, [node] is neither awake nor asleep. + When [solve node] finishes, [node] is either awake or asleep again. (Chances + are, it is asleep, unless it is its own observer; then, it is awakened by the + final call to [signal node].) *) + +let rec solve (node : node) : unit = + + (* Retrieve the data record carried by this node. *) + let data = Graph.data node in + + (* Prepare to compute an updated value at this node. This is done by + invoking the client's right-hand side function. *) + + (* The flag [alive] is used to prevent the client from invoking [request] + after this interaction phase is over. In theory, this dynamic check seems + required in order to argue that [request] behaves like a pure function. + In practice, this check is not very useful: only a bizarre client would + store a [request] function and invoke it after it has become stale. *) + let alive = ref true + and subjects = ref [] in + + (* We supply the client with [request], a function that provides access to + the current valuation, and dynamically records dependencies. This yields + a set of dependencies that is correct by construction. *) + let request (v : variable) : property = + assert !alive; + try + M.find v permanent + with Not_found -> + let subject = node_for v in + let p = property subject in + if not (P.is_maximal p) then + subjects := subject :: !subjects; + p + in + + (* Give control to the client. *) + let new_property = data.rhs request in + + (* From now on, prevent any invocation of this instance of [request] + the client. *) + alive := false; + + (* At this point, [node] has no subjects, as noted above. Thus, the + precondition of [set_successors] is met. We can install [data.subjects] + as the new set of subjects for this node. *) + + (* If we have gathered no subjects in the list [data.subjects], then + this node must have stabilized. If [new_property] is maximal, + then this node must have stabilized. *) + + (* If this node has stabilized, then it need not observe any more, so the + call to [set_successors] is skipped. In practice, this seems to be a + minor optimization. In the particular case where every node stabilizes at + the very first call to [rhs], this means that no edges are ever + built. This particular case is unlikely, as it means that we are just + doing memoization, not a true fixed point computation. *) + + (* One could go further and note that, if this node has stabilized, then it + could immediately be taken out of the transient table and copied into the + permanent table. This would have the beneficial effect of allowing the + detection of further nodes that have stabilized. Furthermore, it would + enforce the property that no node in the transient table has a maximal + value, hence the call to [is_maximal] above would become useless. *) + + if not (!subjects = [] || P.is_maximal new_property) then + Graph.set_successors node !subjects; + + (* If the updated value differs from the previous value, record + the updated value and send a signal to all observers of [node]. *) + if not (P.equal data.property new_property) then begin + data.property <- new_property; + signal node + end + (* Note that equality of the two values does not imply that this node has + stabilized forever. *) + +(* -------------------------------------------------------------------------- *) + +(* [node_for v] returns the graph node associated with the variable [v]. It is + assumed that [v] does not appear in the permanent table. If [v] appears in + the transient table, the associated node is returned. Otherwise, [v] is a + newly discovered variable: a new node is created on the fly, and the + transient table is grown. The new node can either be inserted into the + workset (it is then awake) or handled immediately via a recursive call to + [solve] (it is then asleep, unless it observes itself). *) + +(* The recursive call to [solve node] can be replaced, if desired, by a call + to [Workset.insert node]. Using a recursive call to [solve] permits eager + top-down discovery of new nodes. This can save a constant factor, because + it allows new nodes to move directly from [bottom] to a good first + approximation, without sending any signals, since [node] has no observers + when [solve node] is invoked. In fact, if the dependency graph is acyclic, + the algorithm discovers nodes top-down, performs computation on the way + back up, and runs without ever inserting a node into the workset! + Unfortunately, this causes the stack to grow as deep as the longest path in + the dependency graph, which can blow up the stack. *) + +and node_for (v : variable) : node = + try + M.find v transient + with Not_found -> + let node = Graph.create { rhs = eqs v; property = P.bottom } in + (* Adding this node to the transient table prior to calling [solve] + recursively is mandatory, otherwise [solve] might loop, creating + an infinite number of nodes for the same variable. *) + M.add v node transient; + solve node; (* or: Workset.insert node *) + node + +(* -------------------------------------------------------------------------- *) + +(* Invocations of [get] trigger the fixed point computation. *) + +(* The flag [inactive] prevents reentrant calls by the client. *) + +let inactive = + ref true + +let get (v : variable) : property = + try + M.find v permanent + with Not_found -> + assert !inactive; + inactive := false; + let node = node_for v in + Workset.repeat solve; + freeze(); + inactive := true; + property node + +(* -------------------------------------------------------------------------- *) + +(* Close the local module [LFP]. *) + +end +in LFP.get + +end diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/fix.mli b/ocamlmerlin_mlx/ocaml/preprocess/recover/fix.mli new file mode 100644 index 0000000..6e3fb38 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/fix.mli @@ -0,0 +1,97 @@ +(******************************************************************************) +(* *) +(* Menhir *) +(* *) +(* François Pottier, Inria Paris *) +(* Yann Régis-Gianas, PPS, Université Paris Diderot *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under the *) +(* terms of the GNU General Public License version 2, as described in the *) +(* file LICENSE. *) +(* *) +(******************************************************************************) + +(* This code is described in the paper ``Lazy Least Fixed Points in ML''. *) + +(* -------------------------------------------------------------------------- *) + +(* Maps. *) + +(* We require imperative maps, that is, maps that can be updated in place. + An implementation of persistent maps, such as the one offered by ocaml's + standard library, can easily be turned into an implementation of imperative + maps, so this is a weak requirement. *) + +module type IMPERATIVE_MAPS = sig + type key + type 'data t + val create: unit -> 'data t + val clear: 'data t -> unit + val add: key -> 'data -> 'data t -> unit + val find: key -> 'data t -> 'data + val iter: (key -> 'data -> unit) -> 'data t -> unit +end + +(* -------------------------------------------------------------------------- *) + +(* Properties. *) + +(* Properties must form a partial order, equipped with a least element, and + must satisfy the ascending chain condition: every monotone sequence + eventually stabilizes. *) + +(* [is_maximal] determines whether a property [p] is maximal with respect to + the partial order. Only a conservative check is required: in any event, it + is permitted for [is_maximal p] to return [false]. If [is_maximal p] + returns [true], then [p] must have no upper bound other than itself. In + particular, if properties form a lattice, then [p] must be the top + element. This feature, not described in the paper, enables a couple of + minor optimizations. *) + +module type PROPERTY = sig + type property + val bottom: property + val equal: property -> property -> bool + val is_maximal: property -> bool +end + +(* -------------------------------------------------------------------------- *) + +(* The code is parametric in an implementation of maps over variables and in + an implementation of properties. *) + +module Make + (M : IMPERATIVE_MAPS) + (P : PROPERTY) + : sig + type variable = M.key + type property = P.property + + (* A valuation is a mapping of variables to properties. *) + type valuation = variable -> property + + (* A right-hand side, when supplied with a valuation that gives + meaning to its free variables, evaluates to a property. More + precisely, a right-hand side is a monotone function of + valuations to properties. *) + type rhs = valuation -> property + + (* A system of equations is a mapping of variables to right-hand + sides. *) + type equations = variable -> rhs + + (* [lfp eqs] produces the least solution of the system of monotone + equations [eqs]. *) + + (* It is guaranteed that, for each variable [v], the application [eqs v] is + performed at most once (whereas the right-hand side produced by this + application is, in general, evaluated multiple times). This guarantee can + be used to perform costly pre-computation, or memory allocation, when [eqs] + is applied to its first argument. *) + + (* When [lfp] is applied to a system of equations [eqs], it performs no + actual computation. It produces a valuation, [get], which represents + the least solution of the system of equations. The actual fixed point + computation takes place, on demand, when [get] is applied. *) + val lfp: equations -> valuation + end diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/gSet.ml b/ocamlmerlin_mlx/ocaml/preprocess/recover/gSet.ml new file mode 100644 index 0000000..8a2c0c7 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/gSet.ml @@ -0,0 +1,115 @@ +(******************************************************************************) +(* *) +(* Menhir *) +(* *) +(* François Pottier, Inria Paris *) +(* Yann Régis-Gianas, PPS, Université Paris Diderot *) +(* *) +(* Copyright Inria. All rights reserved. This file is distributed under the *) +(* terms of the GNU General Public License version 2, as described in the *) +(* file LICENSE. *) +(* *) +(******************************************************************************) + +(* This is a stripped down version of [GSet] that describes both [Patricia] + and [CompressedBitSet]. The full version of [GSet] is in [AlphaLib]. *) + +module type S = sig + + (* Elements are assumed to have a natural total order. *) + + type element + + (* Sets. *) + + type t + + (* The empty set. *) + + val empty: t + + (* [is_empty s] tells whether [s] is the empty set. *) + + val is_empty: t -> bool + + (* [singleton x] returns a singleton set containing [x] as its only + element. *) + + val singleton: element -> t + + (* [is_singleton s] tests whether [s] is a singleton set. *) + + val is_singleton: t -> bool + + (* [cardinal s] returns the cardinal of [s]. *) + + val cardinal: t -> int + + (* [choose s] returns an arbitrarily chosen element of [s], if [s] + is nonempty, and raises [Not_found] otherwise. *) + + val choose: t -> element + + (* [mem x s] returns [true] if and only if [x] appears in the set + [s]. *) + + val mem: element -> t -> bool + + (* [add x s] returns a set whose elements are all elements of [s], + plus [x]. *) + + val add: element -> t -> t + + (* [remove x s] returns a set whose elements are all elements of + [s], except [x]. *) + + val remove: element -> t -> t + + (* [union s1 s2] returns the union of the sets [s1] and [s2]. *) + + val union: t -> t -> t + + (* [inter s t] returns the set intersection of [s] and [t], that is, + $s\cap t$. *) + + val inter: t -> t -> t + + (* [disjoint s1 s2] returns [true] if and only if the sets [s1] and + [s2] are disjoint, i.e. iff their intersection is empty. *) + + val disjoint: t -> t -> bool + + (* [iter f s] invokes [f x], in turn, for each element [x] of the + set [s]. Elements are presented to [f] in increasing order. *) + + val iter: (element -> unit) -> t -> unit + + (* [fold f s seed] invokes [f x accu], in turn, for each element [x] + of the set [s]. Elements are presented to [f] in increasing + order. The initial value of [accu] is [seed]; then, at each new + call, its value is the value returned by the previous invocation + of [f]. The value returned by [fold] is the final value of + [accu]. In other words, if $s = \{ x_1, x_2, \ldots, x_n \}$, + where $x_1 < x_2 < \ldots < x_n$, then [fold f s seed] computes + $([f]\,x_n\,\ldots\,([f]\,x_2\,([f]\,x_1\,[seed]))\ldots)$. *) + + val fold: (element -> 'b -> 'b) -> t -> 'b -> 'b + + (* [elements s] is a list of all elements in the set [s]. *) + + val elements: t -> element list + + (* [compare] is an ordering over sets. *) + + val compare: t -> t -> int + + (* [equal] implements equality over sets. *) + + val equal: t -> t -> bool + + (* [subset] implements the subset predicate over sets. *) + + val subset: (t -> t -> bool) + +end + diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/gen_recover.ml b/ocamlmerlin_mlx/ocaml/preprocess/recover/gen_recover.ml new file mode 100644 index 0000000..2d0f14f --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/gen_recover.ml @@ -0,0 +1,65 @@ +open MenhirSdk + +let name = ref "" +let verbose = ref false + +let usage () = + Printf.eprintf "Usage: %s [-v] file.cmly\n" + Sys.argv.(0); + exit 1 + +let () = + for i = 1 to Array.length Sys.argv - 1 do + if Sys.argv.(i) = "-v" then + verbose := true + else if !name = "" then + name := Sys.argv.(i) + else + usage () + done; + if !name = "" then + usage () + +module G = Cmly_read.Read (struct let filename = !name end) +module A = Recover_attrib.Make(G) + +let () = + let open Format in + let ppf = Format.err_formatter in + if !verbose then begin + let open G in + Lr1.iter (fun (st : lr1) -> + fprintf ppf "\n# LR(1) state #%d\n\n" (st :> int); + fprintf ppf "Items:\n"; + Print.itemset ppf (Lr0.items (Lr1.lr0 st)); + fprintf ppf "Transitions:\n"; + List.iter (fun (sym,(st' : lr1)) -> + fprintf ppf " - on %a, goto #%d\n" + Print.symbol sym + (st' :> int) + ) (Lr1.transitions st); + fprintf ppf "Reductions:\n"; + List.iter (fun (t,ps) -> + let p : production = List.hd ps in + fprintf ppf " - on %a, reduce %d:\n %a\n" + Print.terminal t + (p :> int) Print.production p + ) (Lr1.reductions st); + ); + Production.iter (fun (p : production) -> + fprintf ppf "\n# Production p%d\n%a" + (p :> int) Print.production p + ); + end + +module S = Synthesis.Make(G)(A) + +let () = if !verbose then S.report Format.err_formatter + +module R = Recovery.Make(G)(S) + +let () = if !verbose then R.report Format.err_formatter + +module E = Emitter.Make(G)(A)(S)(R) + +let () = E.emit Format.std_formatter diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/recover_attrib.ml b/ocamlmerlin_mlx/ocaml/preprocess/recover/recover_attrib.ml new file mode 100644 index 0000000..beb3709 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/recover_attrib.ml @@ -0,0 +1,83 @@ +open MenhirSdk + +module type S = sig + module G : Cmly_api.GRAMMAR + + val cost_of_prod : G.production -> float + val penalty_of_item : G.production * int -> float + val cost_of_symbol : G.symbol -> float + + val default_prelude : Format.formatter -> unit + val default_terminal : G.terminal -> string option + val default_nonterminal : G.nonterminal -> string option +end + +module Make (G : Cmly_api.GRAMMAR) : S with module G = G = struct + module G = G + open G + + let cost_of_attributes prj attrs = + List.fold_left + (fun total attr -> + if Attribute.has_label "cost" attr then + total +. float_of_string (Attribute.payload attr) + else total) + 0. (prj attrs) + + let cost_of_symbol = + let measure ~has_default prj attrs = + if List.exists (Attribute.has_label "recovery") (prj attrs) || has_default + then cost_of_attributes prj attrs + else infinity + in + let ft = Terminal.tabulate + (fun t -> + if Terminal.typ t = None + then measure ~has_default:true Terminal.attributes t + else measure ~has_default:false Terminal.attributes t) + in + let fn = + Nonterminal.tabulate (measure ~has_default:false Nonterminal.attributes) + in + function + | T t -> ft t + | N n -> fn n + + let cost_of_prod = + Production.tabulate (cost_of_attributes Production.attributes) + + let penalty_of_item = + let f = Production.tabulate @@ fun p -> + Array.map (cost_of_attributes (fun (_,_,a) -> a)) + (Production.rhs p) + in + fun (p,i) -> + let costs = f p in + if i < Array.length costs then costs.(i) else cost_of_prod p + + let default_prelude ppf = + List.iter (fun a -> + if Attribute.has_label "header" a || Attribute.has_label "recovery.header" a then + Format.fprintf ppf "%s\n" (Attribute.payload a) + ) Grammar.attributes + + let default_printer ?(fallback="raise Not_found") attrs = + match List.find (Attribute.has_label "recovery") attrs with + | exception Not_found -> fallback + | attr -> Attribute.payload attr + + let default_terminal t = + match Terminal.kind t with + | `REGULAR | `ERROR | `EOF -> + let fallback = match Terminal.typ t with + | None -> Some "()" + | Some _ -> None + in + Some (default_printer ?fallback (Terminal.attributes t)) + | `PSEUDO -> None + + let default_nonterminal n = + match Nonterminal.kind n with + | `REGULAR -> Some (default_printer (Nonterminal.attributes n)) + | `START -> None +end diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/recover_attrib.mli b/ocamlmerlin_mlx/ocaml/preprocess/recover/recover_attrib.mli new file mode 100644 index 0000000..102f9a6 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/recover_attrib.mli @@ -0,0 +1,15 @@ +open MenhirSdk + +module type S = sig + module G : Cmly_api.GRAMMAR + + val cost_of_prod : G.production -> float + val penalty_of_item : G.production * int -> float + val cost_of_symbol : G.symbol -> float + + val default_prelude : Format.formatter -> unit + val default_terminal : G.terminal -> string option + val default_nonterminal : G.nonterminal -> string option +end + +module Make (G : Cmly_api.GRAMMAR) : S with module G = G diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/recovery.ml b/ocamlmerlin_mlx/ocaml/preprocess/recover/recovery.ml new file mode 100644 index 0000000..b8be36b --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/recovery.ml @@ -0,0 +1,201 @@ +open MenhirSdk +open Cmly_api +open Utils + +module type S = sig + module G : GRAMMAR + + type item = G.lr1 * G.production * int + type recovery = G.lr1 -> int * (G.lr1 option * item list) list + + val recover : recovery + val report : Format.formatter -> unit +end + +module Make (G : GRAMMAR) + (S : Synthesis.S with module G = G) : S with module G = G = struct + module G = G + open G + + type item = lr1 * production * int + + type recovery = lr1 -> int * (lr1 option * item list) list + +(* + let item_to_string (st, prod, p) = + Printf.sprintf "(#%d, p%d, %d)" (Lr1.to_int st) (Production.to_int prod) p +*) + + type trace = Trace of float * item list + + module Trace = struct + type t = trace + let min = arg_min_float (fun (Trace (c,_)) -> c) + + let cat (Trace (c1, tr1)) (Trace (c2, tr2)) = + Trace (c1 +. c2, tr1 @ tr2) + +(* + let to_string (Trace (c1, tr)) = + Printf.sprintf "Trace (%f, %s)" + c1 (list_fmt item_to_string tr) +*) + end + + module State = struct + type level = (nonterminal * Trace.t) list + type t = level list + + let rec merge_level l1 l2 : level = match l1, l2 with + | [], l -> l + | l, [] -> l + | ((nt1, c1) :: xs1), (x2 :: xs2) -> + let (nt2, c2) = x2 in + match compare nt1 nt2 with + | 0 -> + let x = (nt1, Trace.min c1 c2) in + x :: merge_level xs1 xs2 + | n when n > 0 -> x2 :: merge_level l1 xs2 + | _ -> (nt1, c1) :: merge_level xs1 l2 + + let rec merge l1 l2 : t = match l1, l2 with + | [], l -> l + | l, [] -> l + | (x1 :: l1), (x2 :: l2) -> + let x' = merge_level x1 x2 in + x' :: merge l1 l2 + +(* + let reduction_to_string (n, tr) = + Printf.sprintf "(%s, %s)" (Nonterminal.name n) (Trace.to_string tr) + + let to_string (t : t) = list_fmt (list_fmt reduction_to_string) t +*) + end + + let synthesize = + let rec add_nt tr nt = function + | [] -> [(nt, tr)] + | x :: xs -> + let c = compare nt (fst x) in + if c = 0 then (nt, Trace.min tr (snd x)) :: xs + else if c < 0 then + (nt, tr) :: xs + else + x :: add_nt tr nt xs + in + let add_item cost item stack = + let (_, prod, pos) = item in + if cost = infinity then stack + else + let stack_hd = function + | [] -> [] + | x :: _ -> x + and stack_tl = function + | [] -> [] + | _ :: xs -> xs + in + let rec aux stack = function + | 0 -> add_nt (Trace (cost, [item])) (Production.lhs prod) + (stack_hd stack) :: stack_tl stack + | n -> stack_hd stack :: aux (stack_tl stack) (n - 1) + in + aux stack pos + in + Lr1.tabulate (fun st -> + List.fold_left (fun acc (prod, pos) -> + if pos = 0 then ( + (*if prod.p_kind = `START then ( *) + (* pos = 0 means we are on an initial state *) + (*report "skipping %s at depth %d\n" prod.p_lhs.n_name pos;*) + acc + ) else ( + (*report "adding %s at depth %d\n" prod.p_lhs.n_name pos;*) + add_item + (S.cost_of (S.Tail (st, prod, pos))) + (st, prod, pos) acc + ) + ) + [] (Lr0.items (Lr1.lr0 st)) + ) + + let step st ntss = + let seen = ref CompressedBitSet.empty in + let rec aux = function + | [] -> [] + | ((nt, tr) :: x) :: xs + when not (CompressedBitSet.mem (Nonterminal.to_int nt) !seen) && + not (Nonterminal.kind nt = `START) -> + seen := CompressedBitSet.add (Nonterminal.to_int nt) !seen; + let st' = List.assoc (N nt) (Lr1.transitions st) in + let xs' = synthesize st' in + let xs' = match xs' with + | [] -> [] + | _ :: xs -> xs + in + let merge_trace (nt,tr') = (nt, Trace.cat tr' tr) in + let xs' = List.map (List.map merge_trace) xs' in + aux (State.merge xs' (x :: xs)) + | (_ :: x) :: xs -> aux (x :: xs) + | [] :: xs -> xs + in + aux ntss + + let init st = ((st, [st]), step st (synthesize st)) + + let expand ((st, sts), nts) = + List.map (fun st' -> ((st', st' :: sts), step st' nts)) (S.pred st) + + let recover st = + (* How big is the known prefix of the stack *) + let pos = + let items = Lr0.items (Lr1.lr0 st) in + List.fold_left (fun pos (_, pos') -> max pos pos') + (snd (List.hd items)) (List.tl items) + in + (* Walk this prefix *) + let traces = + let acc = ref [init st] in + for _i = 1 to pos - 1 do + acc := List.concat (List.map expand !acc) + done; + !acc + in + (* Last step *) + let select_trace traces = + (* Pick a trace with minimal cost, somewhat arbitrary *) + match List.flatten traces with + | [] -> + (* FIXME: for release, empty list means recovery not possible + (not enough annotations) *) + assert false + | (_, trace) :: alternatives -> + List.fold_left + (fun tr1 (_,tr2) -> Trace.min tr1 tr2) + trace alternatives + in + let process_trace trace = + match expand trace with + | [] -> (* Initial state *) + assert (snd trace = []); [] + | states -> + let select_expansion ((st, _sts), trace') = + if trace' = [] then + (* Reached stack bottom *) + (None, select_trace (snd trace)) + else + (Some st, select_trace trace') + in + List.map select_expansion states + in + pos, + List.flatten @@ List.map (fun trace -> + List.map + (fun (st, Trace (_, reductions)) -> st, reductions) + (process_trace trace) + ) traces + + let recover = Lr1.tabulate recover + + let report _ppf = () +end diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/recovery.mli b/ocamlmerlin_mlx/ocaml/preprocess/recover/recovery.mli new file mode 100644 index 0000000..412b6d0 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/recovery.mli @@ -0,0 +1,12 @@ +open MenhirSdk.Cmly_api +module type S = sig + module G : GRAMMAR + + type item = G.lr1 * G.production * int + type recovery = G.lr1 -> int * (G.lr1 option * item list) list + + val recover : recovery + val report : Format.formatter -> unit +end + +module Make (G : GRAMMAR) (S : Synthesis.S with module G = G) : S with module G = G diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/synthesis.ml b/ocamlmerlin_mlx/ocaml/preprocess/recover/synthesis.ml new file mode 100644 index 0000000..70f6f6d --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/synthesis.ml @@ -0,0 +1,261 @@ +open MenhirSdk.Cmly_api +open Utils + +module type S = sig + module G : GRAMMAR + + type variable = + | Head of G.lr1 * G.nonterminal + | Tail of G.lr1 * G.production * int + + val variable_to_string : variable -> string + + type 'a paction = + | Abort + | Reduce of G.production + | Shift of G.symbol + | Var of 'a + + val paction_to_string : ('a -> string) -> 'a paction -> string + + type action = variable paction + + val action_to_string : action -> string + + val pred : G.lr1 -> G.lr1 list + + val cost_of : variable -> float + val cost_of_action : action -> float + val cost_of_actions : action list -> float + val solution : variable -> action list + val report : Format.formatter -> unit +end + +module Make (G : GRAMMAR) (A : Recover_attrib.S with module G = G) + : S with module G = G = +struct + module G = G + open G + + let pred = + (* Compute lr1 predecessor relation *) + let tbl1 = Array.make Lr1.count [] in + let revert_transition s1 (sym,s2) = + assert (match Lr0.incoming (Lr1.lr0 s2) with + | None -> false + | Some sym' -> sym = sym'); + tbl1.(Lr1.to_int s2) <- s1 :: tbl1.(Lr1.to_int s2) + in + Lr1.iter + (fun lr1 -> List.iter (revert_transition lr1) (Lr1.transitions lr1)); + (fun lr1 -> tbl1.(Lr1.to_int lr1)) + + type variable = + | Head of lr1 * nonterminal + | Tail of lr1 * production * int + + let variable_to_string = function + | Head (st, n) -> + Printf.sprintf "Head (#%d, %s)" + (Lr1.to_int st) (Nonterminal.name n) + | Tail (st, prod, pos) -> + Printf.sprintf "Tail (#%d, p%d, %d)" + (Lr1.to_int st) (Production.to_int prod) pos + + type 'a paction = + | Abort + | Reduce of production + | Shift of symbol + | Var of 'a + + let paction_to_string variable_to_string = function + | Abort -> "Abort" + | Reduce prod -> "Reduce p" ^ string_of_int (Production.to_int prod) + | Shift sym -> "Shift " ^ (symbol_name sym) + | Var v -> "Var (" ^ variable_to_string v ^ ")" + + type action = variable paction + + let action_to_string = paction_to_string variable_to_string + + let check_cost r = + assert (r >= 0.); r + + let cost_of_prod p = check_cost (1. +. A.cost_of_prod p) + let cost_of_symbol s = check_cost (1. +. A.cost_of_symbol s) + let penalty_of_item i = check_cost (A.penalty_of_item i) + + let app var v = v var + + let var var = match var with + | Head _ -> app var + | Tail (_,prod,pos) -> + if pos < Array.length (Production.rhs prod) then + app var + else + let cost = cost_of_prod prod in + const cost + +(* + let can_pop prod pos = + pos > 1 && + (match (Production.rhs prod).(pos - 1) with + | T t, _, _ -> Terminal.typ t = None + | _ -> false) +*) + + let cost_of = function + | Head (st, n) -> + let acc = List.fold_left + (fun acc (_sym, st') -> + List.fold_left (fun acc (prod, pos) -> + if pos = 1 && Production.lhs prod = n then + var (Tail (st, prod, 0)) :: acc + else acc + ) acc (Lr0.items (Lr1.lr0 st')) + ) [] (Lr1.transitions st) + in + let cost = List.fold_left + (fun acc (_, prods) -> + List.fold_left (fun acc prod -> + if Production.rhs prod = [||] && Production.lhs prod = n then + min_float (cost_of_prod prod) acc + else acc + ) acc prods + ) infinity (Lr1.reductions st) + in + if cost < infinity || acc <> [] then + (fun v -> List.fold_left (fun cost f -> min_float cost (f v)) cost acc) + else const infinity + + | Tail (st, prod, pos) -> + let penalty = penalty_of_item (prod, pos) in + if penalty = infinity then + const infinity + else + if pos >= Array.length (Production.rhs prod) then + const (cost_of_prod prod) + else + let head = + let sym, _, _ = (Production.rhs prod).(pos) in + let cost = cost_of_symbol sym in + if cost < infinity then const cost + else match sym with + | T _ -> const infinity + | N n -> var (Head (st, n)) + in + let tail = + let sym, _, _ = (Production.rhs prod).(pos) in + match List.assoc sym (Lr1.transitions st) with + | st' -> var (Tail (st', prod, pos + 1)) + | exception Not_found -> + (*report "no transition: #%d (%d,%d)\n" st.lr1_index prod.p_index pos;*) + const infinity + in + (fun v -> head v +. tail v) + + let cost_of = + let module Solver = Fix.Make (struct + type key = variable + type 'a t = (key, 'a) Hashtbl.t + let create () = Hashtbl.create 7 + let find k tbl = Hashtbl.find tbl k + let add k v tbl = Hashtbl.add tbl k v + let iter f tbl = Hashtbl.iter f tbl + let clear = Hashtbl.clear + end) (struct + type property = float + let bottom = infinity + let equal : float -> float -> bool = (=) + let is_maximal f = f = 0.0 + end) + in + Solver.lfp cost_of + + let cost_of_action = function + | Abort -> infinity + | Reduce p -> cost_of_prod p + | Shift s -> cost_of_symbol s + | Var v -> cost_of v + + let select var1 var2 = + arg_min_float cost_of_action var1 var2 + + let cost_of_actions actions = + List.fold_left (fun cost act -> cost +. cost_of_action act) 0.0 actions + + let solution = function + | Head (st, n) -> + let acc = Abort in + let acc = List.fold_left + (fun acc (_sym, st') -> + List.fold_left (fun acc (prod, pos) -> + if pos = 1 && Production.lhs prod = n then + select (Var (Tail (st, prod, 0))) acc + else acc + ) acc (Lr0.items (Lr1.lr0 st')) + ) acc (Lr1.transitions st) + in + let acc = List.fold_left + (fun acc (_, prods) -> + List.fold_left (fun acc prod -> + if Production.rhs prod = [||] && Production.lhs prod = n then + select (Reduce prod) acc + else acc + ) acc prods + ) acc (Lr1.reductions st) + in + [acc] + + | Tail (_st, prod, pos) when pos = Array.length (Production.rhs prod) -> + [Reduce prod] + + | Tail (st, prod, pos) -> + let penalty = penalty_of_item (prod, pos) in + if penalty = infinity then + [Abort] + else + let head = + let sym, _, _ = (Production.rhs prod).(pos) in + let cost = cost_of_symbol sym in + if cost < infinity then + Shift sym + else match sym with + | T _ -> Abort + | N n -> Var (Head (st, n)) + in + let tail = + let sym, _, _ = (Production.rhs prod).(pos) in + match List.assoc sym (Lr1.transitions st) with + | st' -> Var (Tail (st', prod, pos + 1)) + | exception Not_found -> + Abort + in + [head; tail] + + let report ppf = + let open Format in + let solutions = Lr1.fold + (fun st acc -> + match List.fold_left (fun (item, cost) (prod, pos) -> + let cost' = cost_of (Tail (st, prod, pos)) in + let actions = solution (Tail (st, prod, pos)) in + assert (cost' = cost_of_actions actions); + if cost' < cost then (Some (prod, pos), cost') else (item, cost) + ) (None, infinity) (Lr0.items (Lr1.lr0 st)) + with + | None, _ -> + fprintf ppf "no synthesis from %d\n" (Lr1.to_int st); + acc + | Some item, cost -> (item, (cost, st)) :: acc + ) [] + in + List.iter (fun (item, states) -> + fprintf ppf "# Item (%d,%d)\n" (Production.to_int (fst item)) (snd item); + Print.item ppf item; + List.iter (fun (cost, states) -> + fprintf ppf "at cost %f from states %s\n\n" + cost (list_fmt (fun x -> string_of_int (Lr1.to_int x)) states) + ) (group_assoc states) + ) (group_assoc solutions) +end diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/synthesis.mli b/ocamlmerlin_mlx/ocaml/preprocess/recover/synthesis.mli new file mode 100644 index 0000000..5836150 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/synthesis.mli @@ -0,0 +1,33 @@ +open MenhirSdk.Cmly_api + +module type S = sig + module G : GRAMMAR + + type variable = + | Head of G.lr1 * G.nonterminal + | Tail of G.lr1 * G.production * int + + val variable_to_string : variable -> string + + type 'a paction = + | Abort + | Reduce of G.production + | Shift of G.symbol + | Var of 'a + + val paction_to_string : ('a -> string) -> 'a paction -> string + + type action = variable paction + + val action_to_string : action -> string + + val pred : G.lr1 -> G.lr1 list + + val cost_of : variable -> float + val cost_of_action : action -> float + val cost_of_actions : action list -> float + val solution : variable -> action list + val report : Format.formatter -> unit +end + +module Make (G : GRAMMAR) (A : Recover_attrib.S with module G = G) : S with module G = G diff --git a/ocamlmerlin_mlx/ocaml/preprocess/recover/utils.ml b/ocamlmerlin_mlx/ocaml/preprocess/recover/utils.ml new file mode 100644 index 0000000..0492312 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/preprocess/recover/utils.ml @@ -0,0 +1,59 @@ +let const c = fun _ -> c + +let group_assoc l = + let cons k v acc = (k, List.rev v) :: acc in + let rec aux k v vs acc = function + | [] -> List.rev (cons k (v :: vs) acc) + | (k', v') :: xs when compare k k' = 0 -> + if compare v v' = 0 then + aux k v vs acc xs + else + aux k v' (v :: vs) acc xs + | (k', v') :: xs -> + aux k' v' [] (cons k (v :: vs) acc) xs + in + match List.sort compare l with + | [] -> [] + | (k, v) :: xs -> aux k v [] [] xs + +(* negation to put nan as the max *) +let compare_float a b = - compare (-.a) (-.b) + +let min_float a b = + if compare_float a b > 0 then b else a + +let arg_min_float f a b = + if compare_float (f a) (f b) <= 0 then a else b + +exception Found of int +let array_exists arr f = + try + for i = 0 to Array.length arr - 1 do + if f arr.(i) then raise (Found i); + done; + false + with Found _ -> true + +let array_findi arr f = + match + for i = 0 to Array.length arr - 1 do + if f arr.(i) then raise (Found i); + done + with () -> raise Not_found + | exception (Found i) -> i + +let array_find arr f = + arr.(array_findi arr f) + +let array_assoc arr x = + snd (array_find arr (fun (x',_) -> compare x x' = 0)) + +let list_fmt f l = + "[" ^ String.concat "; " (List.map f l) ^ "]" + +let fst3 (x,_,_) = x + +let rec list_last = function + | [x] -> x + | _ :: xs -> list_last xs + | [] -> invalid_arg "list_last" diff --git a/ocamlmerlin_mlx/ocaml/typing/annot.mli b/ocamlmerlin_mlx/ocaml/typing/annot.mli new file mode 100644 index 0000000..bbaade5 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/annot.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Data types for annotations (Stypes.ml) *) + +type call = Tail | Stack | Inline + +type ident = + | Iref_internal of Location.t (* defining occurrence *) + | Iref_external + | Idef of Location.t (* scope *) diff --git a/ocamlmerlin_mlx/ocaml/typing/btype.ml b/ocamlmerlin_mlx/ocaml/typing/btype.ml new file mode 100644 index 0000000..2191cad --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/btype.ml @@ -0,0 +1,772 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Basic operations on core types *) + +open Asttypes +open Types + +open Local_store + +(**** Sets, maps and hashtables of types ****) + +let wrap_repr f ty = f (Transient_expr.repr ty) +let wrap_type_expr f tty = f (Transient_expr.type_expr tty) + +module TransientTypeSet = Set.Make(TransientTypeOps) +module TypeSet = struct + include TransientTypeSet + let add = wrap_repr add + let mem = wrap_repr mem + let singleton = wrap_repr singleton + let exists p = TransientTypeSet.exists (wrap_type_expr p) + let elements set = + List.map Transient_expr.type_expr (TransientTypeSet.elements set) +end +module TransientTypeMap = Map.Make(TransientTypeOps) +module TypeMap = struct + include TransientTypeMap + let add ty = wrap_repr add ty + let find ty = wrap_repr find ty + let singleton ty = wrap_repr singleton ty + let fold f = TransientTypeMap.fold (wrap_type_expr f) +end +module TransientTypeHash = Hashtbl.Make(TransientTypeOps) +module TypeHash = struct + include TransientTypeHash + let add hash = wrap_repr (add hash) + let remove hash = wrap_repr (remove hash) + let find hash = wrap_repr (find hash) + let iter f = TransientTypeHash.iter (wrap_type_expr f) +end +module TransientTypePairs = + Hashtbl.Make (struct + type t = transient_expr * transient_expr + let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') + let hash (t, t') = t.id + 93 * t'.id + end) +module TypePairs = struct + module H = TransientTypePairs + open Transient_expr + + type t = { + set : unit H.t; + mutable elems : (transient_expr * transient_expr) list; + (* elems preserves the (reversed) insertion order of elements *) + } + + let create n = + { elems = []; set = H.create n } + + let clear t = + t.elems <- []; + H.clear t.set + + let repr2 (t1, t2) = (repr t1, repr t2) + + let add t p = + let p = repr2 p in + if H.mem t.set p then () else begin + H.add t.set p (); + t.elems <- p :: t.elems + end + + let mem t p = H.mem t.set (repr2 p) + + let iter f t = + (* iterate in insertion order, not Hashtbl.iter order *) + List.rev t.elems + |> List.iter (fun (t1,t2) -> + f (type_expr t1, type_expr t2)) +end + +(**** Forward declarations ****) + +let print_raw = + ref (fun _ -> assert false : Format.formatter -> type_expr -> unit) + +(**** Type level management ****) + +let generic_level = Ident.highest_scope + +(* Used to mark a type during a traversal. *) +let lowest_level = Ident.lowest_scope +let pivot_level = 2 * lowest_level - 1 + (* pivot_level - lowest_level < lowest_level *) + +(**** Some type creators ****) + +let newgenty desc = newty2 ~level:generic_level desc +let newgenvar ?name () = newgenty (Tvar name) +let newgenstub ~scope = newty3 ~level:generic_level ~scope (Tvar None) + +(* +let newmarkedvar level = + incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id } +let newmarkedgenvar () = + incr new_id; + { desc = Tvar; level = pivot_level - generic_level; id = !new_id } +*) + +(**** Check some types ****) + +let is_Tvar ty = match get_desc ty with Tvar _ -> true | _ -> false +let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false +let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false + +let dummy_method = "*dummy method*" + +(**** Representative of a type ****) + +let merge_fixed_explanation fixed1 fixed2 = + match fixed1, fixed2 with + | Some Univar _ as x, _ | _, (Some Univar _ as x) -> x + | Some Fixed_private as x, _ | _, (Some Fixed_private as x) -> x + | Some Reified _ as x, _ | _, (Some Reified _ as x) -> x + | Some Rigid as x, _ | _, (Some Rigid as x) -> x + | None, None -> None + + +let fixed_explanation row = + match row_fixed row with + | Some _ as x -> x + | None -> + let ty = row_more row in + match get_desc ty with + | Tvar _ | Tnil -> None + | Tunivar _ -> Some (Univar ty) + | Tconstr (p,_,_) -> Some (Reified p) + | _ -> assert false + +let is_fixed row = match row_fixed row with + | None -> false + | Some _ -> true + +let has_fixed_explanation row = fixed_explanation row <> None + +let static_row row = + row_closed row && + List.for_all + (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true) + (row_fields row) + +let hash_variant s = + let accu = ref 0 in + for i = 0 to String.length s - 1 do + accu := 223 * !accu + Char.code s.[i] + done; + (* reduce to 31 bits *) + accu := !accu land (1 lsl 31 - 1); + (* make it signed for 64 bits architectures *) + if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu + +let proxy ty = + match get_desc ty with + | Tvariant row when not (static_row row) -> + row_more row + | Tobject (ty, _) -> + let rec proxy_obj ty = + match get_desc ty with + Tfield (_, _, _, ty) -> proxy_obj ty + | Tvar _ | Tunivar _ | Tconstr _ -> ty + | Tnil -> ty + | _ -> assert false + in proxy_obj ty + | _ -> ty + +(**** Utilities for fixed row private types ****) + +let row_of_type t = + match get_desc t with + Tobject(t,_) -> + let rec get_row t = + match get_desc t with + Tfield(_,_,_,t) -> get_row t + | _ -> t + in get_row t + | Tvariant row -> + row_more row + | _ -> + t + +let has_constr_row t = + not (is_Tconstr t) && is_Tconstr (row_of_type t) + +let is_row_name s = + let l = String.length s in + (* PR#10661: when l=4 and s is "#row", this is not a row name + but the valid #-type name of a class named "row". *) + l > 4 && String.sub s (l-4) 4 = "#row" + +let is_constr_row ~allow_ident t = + match get_desc t with + Tconstr (Path.Pident id, _, _) when allow_ident -> + is_row_name (Ident.name id) + | Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s + | _ -> false + +(* TODO: where should this really be *) +(* Set row_name in Env, cf. GPR#1204/1329 *) +let set_static_row_name decl path = + match decl.type_manifest with + None -> () + | Some ty -> + match get_desc ty with + Tvariant row when static_row row -> + let row = + set_row_name row (Some (path, decl.type_params)) in + set_type_desc ty (Tvariant row) + | _ -> () + + + (**********************************) + (* Utilities for type traversal *) + (**********************************) + +let fold_row f init row = + let result = + List.fold_left + (fun init (_, fi) -> + match row_field_repr fi with + | Rpresent(Some ty) -> f init ty + | Reither(_, tl, _) -> List.fold_left f init tl + | _ -> init) + init + (row_fields row) + in + match get_desc (row_more row) with + | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil -> + begin match + Option.map (fun (_,l) -> List.fold_left f result l) (row_name row) + with + | None -> result + | Some result -> result + end + | _ -> assert false + +let iter_row f row = + fold_row (fun () v -> f v) () row + +let fold_type_expr f init ty = + match get_desc ty with + Tvar _ -> init + | Tarrow (_, ty1, ty2, _) -> + let result = f init ty1 in + f result ty2 + | Ttuple l -> List.fold_left f init l + | Tconstr (_, l, _) -> List.fold_left f init l + | Tobject(ty, {contents = Some (_, p)}) -> + let result = f init ty in + List.fold_left f result p + | Tobject (ty, _) -> f init ty + | Tvariant row -> + let result = fold_row f init row in + f result (row_more row) + | Tfield (_, _, ty1, ty2) -> + let result = f init ty1 in + f result ty2 + | Tnil -> init + | Tlink _ + | Tsubst _ -> assert false + | Tunivar _ -> init + | Tpoly (ty, tyl) -> + let result = f init ty in + List.fold_left f result tyl + | Tpackage (_, fl) -> + List.fold_left (fun result (_n, ty) -> f result ty) init fl + +let iter_type_expr f ty = + fold_type_expr (fun () v -> f v) () ty + +let rec iter_abbrev f = function + Mnil -> () + | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem + | Mlink rem -> iter_abbrev f !rem + +type type_iterators = + { it_signature: type_iterators -> signature -> unit; + it_signature_item: type_iterators -> signature_item -> unit; + it_value_description: type_iterators -> value_description -> unit; + it_type_declaration: type_iterators -> type_declaration -> unit; + it_extension_constructor: type_iterators -> extension_constructor -> unit; + it_module_declaration: type_iterators -> module_declaration -> unit; + it_modtype_declaration: type_iterators -> modtype_declaration -> unit; + it_class_declaration: type_iterators -> class_declaration -> unit; + it_class_type_declaration: type_iterators -> class_type_declaration -> unit; + it_functor_param: type_iterators -> functor_parameter -> unit; + it_module_type: type_iterators -> module_type -> unit; + it_class_type: type_iterators -> class_type -> unit; + it_type_kind: type_iterators -> type_decl_kind -> unit; + it_do_type_expr: type_iterators -> type_expr -> unit; + it_type_expr: type_iterators -> type_expr -> unit; + it_path: Path.t -> unit; } + +let iter_type_expr_cstr_args f = function + | Cstr_tuple tl -> List.iter f tl + | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls + +let map_type_expr_cstr_args f = function + | Cstr_tuple tl -> Cstr_tuple (List.map f tl) + | Cstr_record lbls -> + Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls) + +let iter_type_expr_kind f = function + | Type_abstract -> () + | Type_variant (cstrs, _) -> + List.iter + (fun cd -> + iter_type_expr_cstr_args f cd.cd_args; + Option.iter f cd.cd_res + ) + cstrs + | Type_record(lbls, _) -> + List.iter (fun d -> f d.ld_type) lbls + | Type_open -> + () + + +let type_iterators = + let it_signature it = + List.iter (it.it_signature_item it) + and it_signature_item it = function + Sig_value (_, vd, _) -> it.it_value_description it vd + | Sig_type (_, td, _, _) -> it.it_type_declaration it td + | Sig_typext (_, td, _, _) -> it.it_extension_constructor it td + | Sig_module (_, _, md, _, _) -> it.it_module_declaration it md + | Sig_modtype (_, mtd, _) -> it.it_modtype_declaration it mtd + | Sig_class (_, cd, _, _) -> it.it_class_declaration it cd + | Sig_class_type (_, ctd, _, _) -> it.it_class_type_declaration it ctd + and it_value_description it vd = + it.it_type_expr it vd.val_type + and it_type_declaration it td = + List.iter (it.it_type_expr it) td.type_params; + Option.iter (it.it_type_expr it) td.type_manifest; + it.it_type_kind it td.type_kind + and it_extension_constructor it td = + it.it_path td.ext_type_path; + List.iter (it.it_type_expr it) td.ext_type_params; + iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args; + Option.iter (it.it_type_expr it) td.ext_ret_type + and it_module_declaration it md = + it.it_module_type it md.md_type + and it_modtype_declaration it mtd = + Option.iter (it.it_module_type it) mtd.mtd_type + and it_class_declaration it cd = + List.iter (it.it_type_expr it) cd.cty_params; + it.it_class_type it cd.cty_type; + Option.iter (it.it_type_expr it) cd.cty_new; + it.it_path cd.cty_path + and it_class_type_declaration it ctd = + List.iter (it.it_type_expr it) ctd.clty_params; + it.it_class_type it ctd.clty_type; + it.it_path ctd.clty_path + and it_functor_param it = function + | Unit -> () + | Named (_, mt) -> it.it_module_type it mt + and it_module_type it = function + Mty_ident p + | Mty_alias p -> it.it_path p + | Mty_for_hole -> () + | Mty_signature sg -> it.it_signature it sg + | Mty_functor (p, mt) -> + it.it_functor_param it p; + it.it_module_type it mt + and it_class_type it = function + Cty_constr (p, tyl, cty) -> + it.it_path p; + List.iter (it.it_type_expr it) tyl; + it.it_class_type it cty + | Cty_signature cs -> + it.it_type_expr it cs.csig_self; + it.it_type_expr it cs.csig_self_row; + Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars; + Meths.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_meths + | Cty_arrow (_, ty, cty) -> + it.it_type_expr it ty; + it.it_class_type it cty + and it_type_kind it kind = + iter_type_expr_kind (it.it_type_expr it) kind + and it_do_type_expr it ty = + iter_type_expr (it.it_type_expr it) ty; + match get_desc ty with + Tconstr (p, _, _) + | Tobject (_, {contents=Some (p, _)}) + | Tpackage (p, _) -> + it.it_path p + | Tvariant row -> + Option.iter (fun (p,_) -> it.it_path p) (row_name row) + | _ -> () + and it_path _p = () + in + { it_path; it_type_expr = it_do_type_expr; it_do_type_expr; + it_type_kind; it_class_type; it_functor_param; it_module_type; + it_signature; it_class_type_declaration; it_class_declaration; + it_modtype_declaration; it_module_declaration; it_extension_constructor; + it_type_declaration; it_value_description; it_signature_item; } + +let copy_row f fixed row keep more = + let Row {fields = orig_fields; fixed = orig_fixed; closed; name = orig_name} = + row_repr row in + let fields = List.map + (fun (l, fi) -> l, + match row_field_repr fi with + | Rpresent oty -> rf_present (Option.map f oty) + | Reither(c, tl, m) -> + let use_ext_of = if keep then Some fi else None in + let m = if is_fixed row then fixed else m in + let tl = List.map f tl in + rf_either tl ?use_ext_of ~no_arg:c ~matched:m + | Rabsent -> rf_absent) + orig_fields in + let name = + match orig_name with + | None -> None + | Some (path, tl) -> Some (path, List.map f tl) in + let fixed = if fixed then orig_fixed else None in + create_row ~fields ~more ~fixed ~closed ~name + +let copy_commu c = if is_commu_ok c then commu_ok else commu_var () + +let rec copy_type_desc ?(keep_names=false) f = function + Tvar _ as ty -> if keep_names then ty else Tvar None + | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c) + | Ttuple l -> Ttuple (List.map f l) + | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) + | Tobject(ty, {contents = Some (p, tl)}) + -> Tobject (f ty, ref (Some(p, List.map f tl))) + | Tobject (ty, _) -> Tobject (f ty, ref None) + | Tvariant _ -> assert false (* too ambiguous *) + | Tfield (p, k, ty1, ty2) -> + Tfield (p, field_kind_internal_repr k, f ty1, f ty2) + (* the kind is kept shared, with indirections removed for performance *) + | Tnil -> Tnil + | Tlink ty -> copy_type_desc f (get_desc ty) + | Tsubst _ -> assert false + | Tunivar _ as ty -> ty (* always keep the name *) + | Tpoly (ty, tyl) -> + let tyl = List.map f tyl in + Tpoly (f ty, tyl) + | Tpackage (p, fl) -> Tpackage (p, List.map (fun (n, ty) -> (n, f ty)) fl) + +(* Utilities for copying *) + +module For_copy : sig + type copy_scope + + val redirect_desc: copy_scope -> type_expr -> type_desc -> unit + + val with_scope: (copy_scope -> 'a) -> 'a +end = struct + type copy_scope = { + mutable saved_desc : (transient_expr * type_desc) list; + (* Save association of generic nodes with their description. *) + } + + let redirect_desc copy_scope ty desc = + let ty = Transient_expr.repr ty in + copy_scope.saved_desc <- (ty, ty.desc) :: copy_scope.saved_desc; + Transient_expr.set_desc ty desc + + (* Restore type descriptions. *) + let cleanup { saved_desc; _ } = + List.iter (fun (ty, desc) -> Transient_expr.set_desc ty desc) saved_desc + + let with_scope f = + let scope = { saved_desc = [] } in + let res = f scope in + cleanup scope; + res +end + + (*******************************************) + (* Memorization of abbreviation expansion *) + (*******************************************) + +(* Search whether the expansion has been memorized. *) + +let lte_public p1 p2 = (* Private <= Public *) + match p1, p2 with + | Private, _ | _, Public -> true + | Public, Private -> false + +let rec find_expans priv p1 = function + Mnil -> None + | Mcons (priv', p2, _ty0, ty, _) + when lte_public priv priv' && Path.same p1 p2 -> Some ty + | Mcons (_, _, _, _, rem) -> find_expans priv p1 rem + | Mlink {contents = rem} -> find_expans priv p1 rem + +(* debug: check for cycles in abbreviation. only works with -principal +let rec check_expans visited ty = + let ty = repr ty in + assert (not (List.memq ty visited)); + match ty.desc with + Tconstr (path, args, abbrev) -> + begin match find_expans path !abbrev with + Some ty' -> check_expans (ty :: visited) ty' + | None -> () + end + | _ -> () +*) + +let memo = s_ref [] + (* Contains the list of saved abbreviation expansions. *) + +let cleanup_abbrev () = + (* Remove all memorized abbreviation expansions. *) + List.iter (fun abbr -> abbr := Mnil) !memo; + memo := [] + +let memorize_abbrev mem priv path v v' = + (* Memorize the expansion of an abbreviation. *) + mem := Mcons (priv, path, v, v', !mem); + (* check_expans [] v; *) + memo := mem :: !memo + +let rec forget_abbrev_rec mem path = + match mem with + Mnil -> + mem + | Mcons (_, path', _, _, rem) when Path.same path path' -> + rem + | Mcons (priv, path', v, v', rem) -> + Mcons (priv, path', v, v', forget_abbrev_rec rem path) + | Mlink mem' -> + mem' := forget_abbrev_rec !mem' path; + raise Exit + +let forget_abbrev mem path = + try mem := forget_abbrev_rec !mem path with Exit -> () + +(* debug: check for invalid abbreviations +let rec check_abbrev_rec = function + Mnil -> true + | Mcons (_, ty1, ty2, rem) -> + repr ty1 != repr ty2 + | Mlink mem' -> + check_abbrev_rec !mem' + +let check_memorized_abbrevs () = + List.for_all (fun mem -> check_abbrev_rec !mem) !memo +*) + +(* Re-export backtrack *) + +let snapshot = snapshot +let backtrack = backtrack ~cleanup_abbrev + + (**********************************) + (* Utilities for labels *) + (**********************************) + +let is_optional = function Optional _ -> true | _ -> false + +let label_name = function + Nolabel -> "" + | Labelled s + | Optional s -> s + +let prefixed_label_name = function + Nolabel -> "" + | Labelled s -> "~" ^ s + | Optional s -> "?" ^ s + +let rec extract_label_aux hd l = function + | [] -> None + | (l',t as p) :: ls -> + if label_name l' = l then + Some (l', t, hd <> [], List.rev_append hd ls) + else + extract_label_aux (p::hd) l ls + +let extract_label l ls = extract_label_aux [] l ls + + (*******************************) + (* Operations on class types *) + (*******************************) + +let rec signature_of_class_type = + function + Cty_constr (_, _, cty) -> signature_of_class_type cty + | Cty_signature sign -> sign + | Cty_arrow (_, _, cty) -> signature_of_class_type cty + +let rec class_body cty = + match cty with + Cty_constr _ -> + cty (* Only class bodies can be abbreviated *) + | Cty_signature _ -> + cty + | Cty_arrow (_, _, cty) -> + class_body cty + +(* Fully expand the head of a class type *) +let rec scrape_class_type = + function + Cty_constr (_, _, cty) -> scrape_class_type cty + | cty -> cty + +let rec class_type_arity = + function + Cty_constr (_, _, cty) -> class_type_arity cty + | Cty_signature _ -> 0 + | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty + +let rec abbreviate_class_type path params cty = + match cty with + Cty_constr (_, _, _) | Cty_signature _ -> + Cty_constr (path, params, cty) + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, ty, abbreviate_class_type path params cty) + +let self_type cty = + (signature_of_class_type cty).csig_self + +let self_type_row cty = + (signature_of_class_type cty).csig_self_row + +(* Return the methods of a class signature *) +let methods sign = + Meths.fold + (fun name _ l -> name :: l) + sign.csig_meths [] + +(* Return the virtual methods of a class signature *) +let virtual_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_meths [] + +(* Return the concrete methods of a class signature *) +let concrete_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> MethSet.add name s) + sign.csig_meths MethSet.empty + +(* Return the public methods of a class signature *) +let public_methods sign = + Meths.fold + (fun name (priv, _vr, _ty) l -> + match priv with + | Mprivate _ -> l + | Mpublic -> name :: l) + sign.csig_meths [] + +(* Return the instance variables of a class signature *) +let instance_vars sign = + Vars.fold + (fun name _ l -> name :: l) + sign.csig_vars [] + +(* Return the virtual instance variables of a class signature *) +let virtual_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_vars [] + +(* Return the concrete instance variables of a class signature *) +let concrete_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> VarSet.add name s) + sign.csig_vars VarSet.empty + +let method_type label sign = + match Meths.find label sign.csig_meths with + | (_, _, ty) -> ty + | exception Not_found -> assert false + +let instance_variable_type label sign = + match Vars.find label sign.csig_vars with + | (_, _, ty) -> ty + | exception Not_found -> assert false + + (**********************************) + (* Utilities for level-marking *) + (**********************************) + +let not_marked_node ty = get_level ty >= lowest_level + (* type nodes with negative levels are "marked" *) +let flip_mark_node ty = + let ty = Transient_expr.repr ty in + Transient_expr.set_level ty (pivot_level - ty.level) +let logged_mark_node ty = + set_level ty (pivot_level - get_level ty) + +let try_mark_node ty = not_marked_node ty && (flip_mark_node ty; true) +let try_logged_mark_node ty = not_marked_node ty && (logged_mark_node ty; true) + +let rec mark_type ty = + if not_marked_node ty then begin + flip_mark_node ty; + iter_type_expr mark_type ty + end + +let mark_type_params ty = + iter_type_expr mark_type ty + +let type_iterators = + let it_type_expr it ty = + if try_mark_node ty then it.it_do_type_expr it ty + in + {type_iterators with it_type_expr} + + +(* Remove marks from a type. *) +let rec unmark_type ty = + if get_level ty < lowest_level then begin + (* flip back the marked level *) + flip_mark_node ty; + iter_type_expr unmark_type ty + end + +let unmark_iterators = + let it_type_expr _it ty = unmark_type ty in + {type_iterators with it_type_expr} + +let unmark_type_decl decl = + unmark_iterators.it_type_declaration unmark_iterators decl + +let unmark_extension_constructor ext = + List.iter unmark_type ext.ext_type_params; + iter_type_expr_cstr_args unmark_type ext.ext_args; + Option.iter unmark_type ext.ext_ret_type + +let unmark_class_signature sign = + unmark_type sign.csig_self; + unmark_type sign.csig_self_row; + Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars; + Meths.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_meths + +let unmark_class_type cty = + unmark_iterators.it_class_type unmark_iterators cty + +(**** Type information getter ****) + +let cstr_type_path cstr = + match get_desc cstr.cstr_res with + | Tconstr (p, _, _) -> p + | _ -> assert false diff --git a/ocamlmerlin_mlx/ocaml/typing/btype.mli b/ocamlmerlin_mlx/ocaml/typing/btype.mli new file mode 100644 index 0000000..d79b8d2 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/btype.mli @@ -0,0 +1,315 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Basic operations on core types *) + +open Asttypes +open Types + +(**** Sets, maps and hashtables of types ****) + +module TypeSet : sig + include Set.S with type elt = transient_expr + val add: type_expr -> t -> t + val mem: type_expr -> t -> bool + val singleton: type_expr -> t + val exists: (type_expr -> bool) -> t -> bool + val elements: t -> type_expr list +end +module TransientTypeMap : Map.S with type key = transient_expr +module TypeMap : sig + include Map.S with type key = transient_expr + and type 'a t = 'a TransientTypeMap.t + val add: type_expr -> 'a -> 'a t -> 'a t + val find: type_expr -> 'a t -> 'a + val singleton: type_expr -> 'a -> 'a t + val fold: (type_expr -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end +module TypeHash : sig + include Hashtbl.S with type key = transient_expr + val add: 'a t -> type_expr -> 'a -> unit + val remove : 'a t -> type_expr -> unit + val find: 'a t -> type_expr -> 'a + val iter: (type_expr -> 'a -> unit) -> 'a t -> unit +end +module TypePairs : sig + type t + val create: int -> t + val clear: t -> unit + val add: t -> type_expr * type_expr -> unit + val mem: t -> type_expr * type_expr -> bool + val iter: (type_expr * type_expr -> unit) -> t -> unit +end + +(**** Levels ****) + +val generic_level: int + +val newgenty: type_desc -> type_expr + (* Create a generic type *) +val newgenvar: ?name:string -> unit -> type_expr + (* Return a fresh generic variable *) +val newgenstub: scope:int -> type_expr + (* Return a fresh generic node, to be instantiated + by [Transient_expr.set_stub_desc] *) + +(* Use Tsubst instead +val newmarkedvar: int -> type_expr + (* Return a fresh marked variable *) +val newmarkedgenvar: unit -> type_expr + (* Return a fresh marked generic variable *) +*) + +(**** Types ****) + +val is_Tvar: type_expr -> bool +val is_Tunivar: type_expr -> bool +val is_Tconstr: type_expr -> bool +val dummy_method: label + +(**** polymorphic variants ****) + +val is_fixed: row_desc -> bool +(* Return whether the row is directly marked as fixed or not *) + +val has_fixed_explanation: row_desc -> bool +(* Return whether the row should be treated as fixed or not. + In particular, [is_fixed row] implies [has_fixed_explanation row]. +*) + +val fixed_explanation: row_desc -> fixed_explanation option +(* Return the potential explanation for the fixed row *) + +val merge_fixed_explanation: + fixed_explanation option -> fixed_explanation option + -> fixed_explanation option +(* Merge two explanations for a fixed row *) + +val static_row: row_desc -> bool + (* Return whether the row is static or not *) +val hash_variant: label -> int + (* Hash function for variant tags *) + +val proxy: type_expr -> type_expr + (* Return the proxy representative of the type: either itself + or a row variable *) + +(**** Utilities for private abbreviations with fixed rows ****) +val row_of_type: type_expr -> type_expr +val has_constr_row: type_expr -> bool +val is_row_name: string -> bool +val is_constr_row: allow_ident:bool -> type_expr -> bool + +(* Set the polymorphic variant row_name field *) +val set_static_row_name: type_declaration -> Path.t -> unit + +(**** Utilities for type traversal ****) + +val iter_type_expr: (type_expr -> unit) -> type_expr -> unit + (* Iteration on types *) +val fold_type_expr: ('a -> type_expr -> 'a) -> 'a -> type_expr -> 'a +val iter_row: (type_expr -> unit) -> row_desc -> unit + (* Iteration on types in a row *) +val fold_row: ('a -> type_expr -> 'a) -> 'a -> row_desc -> 'a +val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit + (* Iteration on types in an abbreviation list *) +val iter_type_expr_kind: (type_expr -> unit) -> (type_decl_kind -> unit) + +val iter_type_expr_cstr_args: (type_expr -> unit) -> + (constructor_arguments -> unit) +val map_type_expr_cstr_args: (type_expr -> type_expr) -> + (constructor_arguments -> constructor_arguments) + + +type type_iterators = + { it_signature: type_iterators -> signature -> unit; + it_signature_item: type_iterators -> signature_item -> unit; + it_value_description: type_iterators -> value_description -> unit; + it_type_declaration: type_iterators -> type_declaration -> unit; + it_extension_constructor: type_iterators -> extension_constructor -> unit; + it_module_declaration: type_iterators -> module_declaration -> unit; + it_modtype_declaration: type_iterators -> modtype_declaration -> unit; + it_class_declaration: type_iterators -> class_declaration -> unit; + it_class_type_declaration: type_iterators -> class_type_declaration -> unit; + it_functor_param: type_iterators -> functor_parameter -> unit; + it_module_type: type_iterators -> module_type -> unit; + it_class_type: type_iterators -> class_type -> unit; + it_type_kind: type_iterators -> type_decl_kind -> unit; + it_do_type_expr: type_iterators -> type_expr -> unit; + it_type_expr: type_iterators -> type_expr -> unit; + it_path: Path.t -> unit; } +val type_iterators: type_iterators + (* Iteration on arbitrary type information. + [it_type_expr] calls [mark_node] to avoid loops. *) +val unmark_iterators: type_iterators + (* Unmark any structure containing types. See [unmark_type] below. *) + +val copy_type_desc: + ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc + (* Copy on types *) +val copy_row: + (type_expr -> type_expr) -> + bool -> row_desc -> bool -> type_expr -> row_desc + +module For_copy : sig + + type copy_scope + (* The private state that the primitives below are mutating, it should + remain scoped within a single [with_scope] call. + + While it is possible to circumvent that discipline in various + ways, you should NOT do that. *) + + val redirect_desc: copy_scope -> type_expr -> type_desc -> unit + (* Temporarily change a type description *) + + val with_scope: (copy_scope -> 'a) -> 'a + (* [with_scope f] calls [f] and restores saved type descriptions + before returning its result. *) +end + +val lowest_level: int + (* Marked type: ty.level < lowest_level *) + +val not_marked_node: type_expr -> bool + (* Return true if a type node is not yet marked *) + +val logged_mark_node: type_expr -> unit + (* Mark a type node, logging the marking so it can be backtracked *) +val try_logged_mark_node: type_expr -> bool + (* Mark a type node if it is not yet marked, logging the marking so it + can be backtracked. + Return false if it was already marked *) + +val flip_mark_node: type_expr -> unit + (* Mark a type node. + The marking is not logged and will have to be manually undone using + one of the various [unmark]'ing functions below. *) +val try_mark_node: type_expr -> bool + (* Mark a type node if it is not yet marked. + The marking is not logged and will have to be manually undone using + one of the various [unmark]'ing functions below. + + Return false if it was already marked *) +val mark_type: type_expr -> unit + (* Mark a type recursively *) +val mark_type_params: type_expr -> unit + (* Mark the sons of a type node recursively *) + +val unmark_type: type_expr -> unit +val unmark_type_decl: type_declaration -> unit +val unmark_extension_constructor: extension_constructor -> unit +val unmark_class_type: class_type -> unit +val unmark_class_signature: class_signature -> unit + (* Remove marks from a type *) + +(**** Memorization of abbreviation expansion ****) + +val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option + (* Look up a memorized abbreviation *) +val cleanup_abbrev: unit -> unit + (* Flush the cache of abbreviation expansions. + When some types are saved (using [output_value]), this + function MUST be called just before. *) +val memorize_abbrev: + abbrev_memo ref -> + private_flag -> Path.t -> type_expr -> type_expr -> unit + (* Add an expansion in the cache *) +val forget_abbrev: + abbrev_memo ref -> Path.t -> unit + (* Remove an abbreviation from the cache *) + +(**** Backtracking ****) + +val snapshot: unit -> snapshot +val backtrack: snapshot -> unit + (* Backtrack to a given snapshot. Only possible if you have + not already backtracked to a previous snapshot. + Calls [cleanup_abbrev] internally *) + +(**** Utilities for labels ****) + +val is_optional : arg_label -> bool +val label_name : arg_label -> label + +(* Returns the label name with first character '?' or '~' as appropriate. *) +val prefixed_label_name : arg_label -> label + +val extract_label : + label -> (arg_label * 'a) list -> + (arg_label * 'a * bool * (arg_label * 'a) list) option +(* actual label, + value, + whether (label, value) was at the head of the list, + list without the extracted (label, value) *) + +(**** Utilities for class types ****) + +(* Get the class signature within a class type *) +val signature_of_class_type : class_type -> class_signature + +(* Get the body of a class type (i.e. without parameters) *) +val class_body : class_type -> class_type +(* Fully expand the head of a class type *) +val scrape_class_type : class_type -> class_type + +(* Return the number of parameters of a class type *) +val class_type_arity : class_type -> int + +(* Given a path and type parameters, add an abbreviation to a class type *) +val abbreviate_class_type : + Path.t -> type_expr list -> class_type -> class_type + +(* Get the self type of a class *) +val self_type : class_type -> type_expr + +(* Get the row variable of the self type of a class *) +val self_type_row : class_type -> type_expr + +(* Return the methods of a class signature *) +val methods : class_signature -> string list + +(* Return the virtual methods of a class signature *) +val virtual_methods : class_signature -> string list + +(* Return the concrete methods of a class signature *) +val concrete_methods : class_signature -> MethSet.t + +(* Return the public methods of a class signature *) +val public_methods : class_signature -> string list + +(* Return the instance variables of a class signature *) +val instance_vars : class_signature -> string list + +(* Return the virtual instance variables of a class signature *) +val virtual_instance_vars : class_signature -> string list + +(* Return the concrete instance variables of a class signature *) +val concrete_instance_vars : class_signature -> VarSet.t + +(* Return the type of a method. + @raises [Assert_failure] if the class has no such method. *) +val method_type : label -> class_signature -> type_expr + +(* Return the type of an instance variable. + @raises [Assert_failure] if the class has no such method. *) +val instance_variable_type : label -> class_signature -> type_expr + +(**** Forward declarations ****) +val print_raw: (Format.formatter -> type_expr -> unit) ref + +(**** Type information getter ****) + +val cstr_type_path : constructor_description -> Path.t diff --git a/ocamlmerlin_mlx/ocaml/typing/cmi_cache.ml b/ocamlmerlin_mlx/ocaml/typing/cmi_cache.ml new file mode 100644 index 0000000..220f652 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/cmi_cache.ml @@ -0,0 +1,34 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + + +include File_cache.Make (struct + type t = Cmi_format.cmi_infos + let read name = Cmi_format.read_cmi name + let cache_name = "Cmi_cache" +end) diff --git a/ocamlmerlin_mlx/ocaml/typing/cmi_format.ml b/ocamlmerlin_mlx/ocaml/typing/cmi_format.ml new file mode 100644 index 0000000..b4934e2 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/cmi_format.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc + +type pers_flags = + | Rectypes + | Alerts of alerts + | Opaque + +(* these type abbreviations are not exported; + they are used to provide consistency across + input_value and output_value usage. *) +type signature = Types.signature_item list +type flags = pers_flags list +type header = modname * signature + +type cmi_infos = { + cmi_name : modname; + cmi_sign : signature; + cmi_crcs : crcs; + cmi_flags : flags; +} + +let input_cmi ic = + let (name, sign) = (Ocaml_compression.input_value ic : header) in + let crcs = (input_value ic : crcs) in + let flags = (input_value ic : flags) in + { + cmi_name = name; + cmi_sign = sign; + cmi_crcs = crcs; + cmi_flags = flags; + } + +let read_cmi filename = + let open Magic_numbers.Cmi in + let ic = open_in_bin filename in + try + let buffer = + really_input_string ic (String.length Config.cmi_magic_number) + in + if buffer <> Config.cmi_magic_number then begin + close_in ic; + let pre_len = String.length Config.cmi_magic_number - 3 in + if String.sub buffer 0 pre_len + = String.sub Config.cmi_magic_number 0 pre_len then + begin + raise (Error (Wrong_version_interface (filename, buffer))) + end else begin + raise(Error(Not_an_interface filename)) + end + end; + let cmi = input_cmi ic in + close_in ic; + cmi + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_interface(filename))) + | Error e -> + close_in ic; + raise (Error e) + +let output_cmi filename oc cmi = +(* beware: the provided signature must have been substituted for saving *) + output_string oc Config.cmi_magic_number; + Ocaml_compression.output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header); + flush oc; + let crc = Digest.file filename in + let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in + output_value oc (crcs : crcs); + output_value oc (cmi.cmi_flags : flags); + crc + +(* Error report moved to src/ocaml/typing/magic_numbers.ml *) diff --git a/ocamlmerlin_mlx/ocaml/typing/cmi_format.mli b/ocamlmerlin_mlx/ocaml/typing/cmi_format.mli new file mode 100644 index 0000000..179dce3 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/cmi_format.mli @@ -0,0 +1,39 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc + +type pers_flags = + | Rectypes + | Alerts of alerts + | Opaque + +type cmi_infos = { + cmi_name : modname; + cmi_sign : Types.signature_item list; + cmi_crcs : crcs; + cmi_flags : pers_flags list; +} + +(* write the magic + the cmi information *) +val output_cmi : string -> out_channel -> cmi_infos -> Digest.t + +(* read the cmi information (the magic is supposed to have already been read) *) +val input_cmi : in_channel -> cmi_infos + +(* read a cmi from a filename, checking the magic *) +val read_cmi : string -> cmi_infos + +(* Error report moved to {!Magic_numbers.Cmi} *) diff --git a/ocamlmerlin_mlx/kernel/mreader_lexer.mli b/ocamlmerlin_mlx/ocaml/typing/cmt_cache.ml similarity index 67% rename from ocamlmerlin_mlx/kernel/mreader_lexer.mli rename to ocamlmerlin_mlx/ocaml/typing/cmt_cache.ml index cfc0b20..5292e94 100644 --- a/ocamlmerlin_mlx/kernel/mreader_lexer.mli +++ b/ocamlmerlin_mlx/ocaml/typing/cmt_cache.ml @@ -1,4 +1,3 @@ -# 1 "merlin/src/kernel/mreader_lexer.mli" (* {{{ COPYING *( This file is part of Merlin, an helper for ocaml editors @@ -27,25 +26,18 @@ )* }}} *) -type keywords = Lexer_raw.keywords +type cmt_item = { + cmt_infos : Cmt_format.cmt_infos ; + mutable location_trie : exn; +} -type triple = Parser_raw.token * Lexing.position * Lexing.position +include File_cache.Make (struct + type t = cmt_item -type t + let read file = { + cmt_infos = Cmt_format.read_cmt file ; + location_trie = Not_found; + } -val make : Warnings.state -> keywords -> Mconfig.t -> Msource.t -> t - -val for_completion: t -> Lexing.position -> - bool (* complete labels or not *) * t - -val initial_position : t -> Lexing.position - -val tokens : t -> triple list -val keywords : t -> string list -val errors : t -> exn list -val comments : t -> (string * Location.t) list - -val reconstruct_identifier: - Mconfig.t -> Msource.t -> Lexing.position -> string Location.loc list - -val identifier_suffix: string Location.loc list -> string Location.loc list + let cache_name = "Cmt_cache" +end) diff --git a/ocamlmerlin_mlx/ocaml/typing/cmt_format.ml b/ocamlmerlin_mlx/ocaml/typing/cmt_format.ml new file mode 100644 index 0000000..6fbc314 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/cmt_format.ml @@ -0,0 +1,216 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** cmt and cmti files format. *) +open Std +open Cmi_format + +(* Note that in Typerex, there is an awful hack to save a cmt file + together with the interface file that was generated by ocaml (this + is because the installed version of ocaml might differ from the one + integrated in Typerex). +*) + +(** The layout of a cmt file is as follows: + := \{\} \{cmt infos\} \{\} + where is the cmi file format: + := . + More precisely, the optional part must be present if and only if + the file is: + - a cmti, or + - a cmt, for a ml file which has no corresponding mli (hence no + corresponding cmti). + + Thus, we provide a common reading function for cmi and cmt(i) + files which returns an option for each of the three parts: cmi + info, cmt info, source info. *) + +open Typedtree + + +let read_magic_number ic = + let len_magic_number = String.length Config.cmt_magic_number in + really_input_string ic len_magic_number + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = + | Partial_structure of structure + | Partial_structure_item of structure_item + | Partial_expression of expression + | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part + | Partial_class_expr of class_expr + | Partial_signature of signature + | Partial_signature_item of signature_item + | Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : string; + cmt_annots : binary_annots; + cmt_value_dependencies : + (Types.value_description * Types.value_description) list; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : string list; + cmt_source_digest : Digest.t option; + cmt_initial_env : Env.t; + cmt_imports : (string * Digest.t option) list; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; + cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_impl_shape : Shape.t option; (* None for mli *) +} + +type error = + Not_a_typedtree of string + +let need_to_clear_env = + try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false + with Not_found -> true + +let keep_only_summary = Env.keep_only_summary + +open Tast_mapper + +let cenv = + {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} + +let clear_part = function + | Partial_structure s -> Partial_structure (cenv.structure cenv s) + | Partial_structure_item s -> + Partial_structure_item (cenv.structure_item cenv s) + | Partial_expression e -> Partial_expression (cenv.expr cenv e) + | Partial_pattern (category, p) -> Partial_pattern (category, cenv.pat cenv p) + | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce) + | Partial_signature s -> Partial_signature (cenv.signature cenv s) + | Partial_signature_item s -> + Partial_signature_item (cenv.signature_item cenv s) + | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s) + +let clear_env binary_annots = + if need_to_clear_env then + match binary_annots with + | Implementation s -> Implementation (cenv.structure cenv s) + | Interface s -> Interface (cenv.signature cenv s) + | Packed _ -> binary_annots + | Partial_implementation array -> + Partial_implementation (Array.map clear_part array) + | Partial_interface array -> + Partial_interface (Array.map clear_part array) + + else binary_annots + +exception Error of error + +let input_cmt ic = (Ocaml_compression.input_value ic : cmt_infos) + +let output_cmt oc cmt = + output_string oc Config.cmt_magic_number; + Ocaml_compression.output_value oc (cmt : cmt_infos) + +let read filename = +(* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) + let ic = open_in_bin filename in + Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> + let magic_number = read_magic_number ic in + let cmi, cmt = + if magic_number = Config.cmt_magic_number then + None, Some (input_cmt ic) + else if magic_number = Config.cmi_magic_number then + let cmi = Cmi_format.input_cmi ic in + let cmt = try + let magic_number = read_magic_number ic in + if magic_number = Config.cmt_magic_number then + let cmt = input_cmt ic in + Some cmt + else None + with _ -> None + in + Some cmi, cmt + else + raise Magic_numbers.Cmi.(Error(Not_an_interface filename)) + in + cmi, cmt + ) + +let read_cmt filename = + match read filename with + _, None -> raise (Error (Not_a_typedtree filename)) + | _, Some cmt -> cmt + +let read_cmi filename = + match read filename with + None, _ -> + raise Magic_numbers.Cmi.(Error (Not_an_interface filename)) + | Some cmi, _ -> cmi + +let saved_types = ref [] +let value_deps = ref [] + +let clear () = + saved_types := []; + value_deps := [] + +let add_saved_type b = saved_types := b :: !saved_types +let get_saved_types () = !saved_types +let set_saved_types l = saved_types := l + +(*let record_value_dependency vd1 vd2 = + if vd1.Types.val_loc <> vd2.Types.val_loc then + value_deps := (vd1, vd2) :: !value_deps*) + +let record_value_dependency _vd1 _vd2 = () + +let save_cmt filename modname binary_annots sourcefile initial_env cmi shape = + if !Clflags.binary_annotations && not !Clflags.print_types then begin + Misc.output_to_file_via_temporary + ~mode:[Open_binary] filename + (fun temp_file_name oc -> + let this_crc = + match cmi with + | None -> None + | Some cmi -> Some (output_cmi temp_file_name oc cmi) + in + let source_digest = Option.map ~f:Digest.file sourcefile in + let cmt = { + cmt_modname = modname; + cmt_annots = clear_env binary_annots; + cmt_value_dependencies = !value_deps; + cmt_comments = []; + cmt_args = Sys.argv; + cmt_sourcefile = sourcefile; + cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ()); + cmt_loadpath = Load_path.get_paths (); + cmt_source_digest = source_digest; + cmt_initial_env = if need_to_clear_env then + keep_only_summary initial_env else initial_env; + cmt_imports = List.sort ~cmp:compare (Env.imports ()); + cmt_interface_digest = this_crc; + cmt_use_summaries = need_to_clear_env; + cmt_uid_to_loc = Env.get_uid_to_loc_tbl (); + cmt_impl_shape = shape; + } in + output_cmt oc cmt) + end; + clear () diff --git a/ocamlmerlin_mlx/ocaml/typing/cmt_format.mli b/ocamlmerlin_mlx/ocaml/typing/cmt_format.mli new file mode 100644 index 0000000..43e09f1 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/cmt_format.mli @@ -0,0 +1,126 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** cmt and cmti files format. *) + +open Misc + +(** The layout of a cmt file is as follows: + := \{\} \{cmt infos\} \{\} + where is the cmi file format: + := . + More precisely, the optional part must be present if and only if + the file is: + - a cmti, or + - a cmt, for a ml file which has no corresponding mli (hence no + corresponding cmti). + + Thus, we provide a common reading function for cmi and cmt(i) + files which returns an option for each of the three parts: cmi + info, cmt info, source info. *) + +open Typedtree + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = + | Partial_structure of structure + | Partial_structure_item of structure_item + | Partial_expression of expression + | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part + | Partial_class_expr of class_expr + | Partial_signature of signature + | Partial_signature_item of signature_item + | Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : modname; + cmt_annots : binary_annots; + cmt_value_dependencies : + (Types.value_description * Types.value_description) list; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : string list; + cmt_source_digest : string option; + cmt_initial_env : Env.t; + cmt_imports : crcs; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; + cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_impl_shape : Shape.t option; (* None for mli *) +} + +type error = + Not_a_typedtree of string + +exception Error of error + +(** [read filename] opens filename, and extract both the cmi_infos, if + it exists, and the cmt_infos, if it exists. Thus, it can be used + with .cmi, .cmt and .cmti files. + + .cmti files always contain a cmi_infos at the beginning. .cmt files + only contain a cmi_infos at the beginning if there is no associated + .cmti file. +*) +val read : string -> Cmi_format.cmi_infos option * cmt_infos option + +val read_cmt : string -> cmt_infos +val read_cmi : string -> Cmi_format.cmi_infos + +(** [save_cmt filename modname binary_annots sourcefile initial_env cmi] + writes a cmt(i) file. *) +val save_cmt : + string -> (* filename.cmt to generate *) + string -> (* module name *) + binary_annots -> + string option -> (* source file *) + Env.t -> (* initial env *) + Cmi_format.cmi_infos option -> (* if a .cmi was generated *) + Shape.t option -> + unit + +(* Miscellaneous functions *) + +val read_magic_number : in_channel -> string + +val clear: unit -> unit + +val add_saved_type : binary_part -> unit +val get_saved_types : unit -> binary_part list +val set_saved_types : binary_part list -> unit + +val record_value_dependency: + Types.value_description -> Types.value_description -> unit + + +(* + + val is_magic_number : string -> bool + val read : in_channel -> Env.cmi_infos option * t + val write_magic_number : out_channel -> unit + val write : out_channel -> t -> unit + + val find : string list -> string -> string + val read_signature : 'a -> string -> Types.signature * 'b list * 'c list + +*) diff --git a/ocamlmerlin_mlx/ocaml/typing/ctype.ml b/ocamlmerlin_mlx/ocaml/typing/ctype.ml new file mode 100644 index 0000000..b70965e --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/ctype.ml @@ -0,0 +1,5544 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Operations on core types *) + +open Misc +open Asttypes +open Types +open Btype +open Errortrace + +open Local_store + +(* + Type manipulation after type inference + ====================================== + If one wants to manipulate a type after type inference (for + instance, during code generation or in the debugger), one must + first make sure that the type levels are correct, using the + function [correct_levels]. Then, this type can be correctly + manipulated by [apply], [expand_head] and [moregeneral]. +*) + +(* + General notes + ============= + - As much sharing as possible should be kept : it makes types + smaller and better abbreviated. + When necessary, some sharing can be lost. Types will still be + printed correctly (+++ TO DO...), and abbreviations defined by a + class do not depend on sharing thanks to constrained + abbreviations. (Of course, even if some sharing is lost, typing + will still be correct.) + - All nodes of a type have a level : that way, one knows whether a + node need to be duplicated or not when instantiating a type. + - Levels of a type are decreasing (generic level being considered + as greatest). + - The level of a type constructor is superior to the binding + time of its path. + - Recursive types without limitation should be handled (even if + there is still an occur check). This avoid treating specially the + case for objects, for instance. Furthermore, the occur check + policy can then be easily changed. +*) + +(**** Errors ****) + +(* There are two classes of errortrace-related exceptions: *traces* and + *errors*. The former, whose names end with [_trace], contain + [Errortrace.trace]s, representing traces that are currently being built; they + are local to this file. All the internal functions that implement + unification, type equality, and moregen raise trace exceptions. Once we are + done, in the top level functions such as [unify], [equal], and [moregen], we + catch the trace exceptions and transform them into the analogous error + exception. This indicates that we are done building the trace, and expect + the error to flow out of unification, type equality, or moregen into + surrounding code (with some few exceptions when these top-level functions are + used as building blocks elsewhere.) Only the error exceptions are exposed in + [ctype.mli]; the trace exceptions are an implementation detail. Any trace + exception that escapes from a function in this file is a bug. *) + +exception Unify_trace of unification trace +exception Equality_trace of comparison trace +exception Moregen_trace of comparison trace + +exception Unify of unification_error +exception Equality of equality_error +exception Moregen of moregen_error +exception Subtype of Subtype.error + +exception Escape of type_expr escape + +(* For local use: throw the appropriate exception. Can be passed into local + functions as a parameter *) +type _ trace_exn = +| Unify : unification trace_exn +| Moregen : comparison trace_exn +| Equality : comparison trace_exn + +let raise_trace_for + (type variant) + (tr_exn : variant trace_exn) + (tr : variant trace) : 'a = + match tr_exn with + | Unify -> raise (Unify_trace tr) + | Equality -> raise (Equality_trace tr) + | Moregen -> raise (Moregen_trace tr) + +(* Uses of this function are a bit suspicious, as we usually want to maintain + trace information; sometimes it makes sense, however, since we're maintaining + the trace at an outer exception handler. *) +let raise_unexplained_for tr_exn = + raise_trace_for tr_exn [] + +let raise_for tr_exn e = + raise_trace_for tr_exn [e] + +(* Thrown from [moregen_kind] *) +exception Public_method_to_private_method + +let escape kind = {kind; context = None} +let escape_exn kind = Escape (escape kind) +let scope_escape_exn ty = escape_exn (Equation ty) +let raise_escape_exn kind = raise (escape_exn kind) +let raise_scope_escape_exn ty = raise (scope_escape_exn ty) + +exception Tags of label * label + +let () = + Location.register_error_of_exn + (function + | Tags (l, l') -> + Some + Location. + (errorf ~loc:(in_file !input_name) + "In this program,@ variant constructors@ `%s and `%s@ \ + have the same hash value.@ Change one of them." l l' + ) + | _ -> None + ) + +exception Cannot_expand + +exception Cannot_apply + +exception Cannot_subst + +exception Cannot_unify_universal_variables + +exception Matches_failure of Env.t * unification_error + +exception Incompatible + +(**** Type level management ****) + +let current_level = s_ref 0 +let nongen_level = s_ref 0 +let global_level = s_ref 0 +let saved_level = s_ref [] + + +(* merlin specific *) +type levels = + { current_level: int; nongen_level: int; global_level: int; + saved_level: (int * int) list; } +let save_levels () = + { current_level = !current_level; + nongen_level = !nongen_level; + global_level = !global_level; + saved_level = !saved_level } +let set_levels l = + current_level := l.current_level; + nongen_level := l.nongen_level; + global_level := l.global_level; + saved_level := l.saved_level +(* end merlin specific *) + +let get_current_level () = !current_level +let init_def level = current_level := level; nongen_level := level +let begin_def () = + saved_level := (!current_level, !nongen_level) :: !saved_level; + incr current_level; nongen_level := !current_level +let begin_class_def () = + saved_level := (!current_level, !nongen_level) :: !saved_level; + incr current_level +let raise_nongen_level () = + saved_level := (!current_level, !nongen_level) :: !saved_level; + nongen_level := !current_level +let end_def () = + let (cl, nl) = List.hd !saved_level in + saved_level := List.tl !saved_level; + current_level := cl; nongen_level := nl +let create_scope () = + init_def (!current_level + 1); + !current_level + +let wrap_end_def f = Misc.try_finally f ~always:end_def + +let with_local_level ?post f = + begin_def (); + let result = wrap_end_def f in + Option.iter (fun g -> g result) post; + result +let with_local_level_if cond f ~post = + if cond then with_local_level f ~post else f () +let with_local_level_iter f ~post = + begin_def (); + let result, l = wrap_end_def f in + List.iter post l; + result +let with_local_level_iter_if cond f ~post = + if cond then with_local_level_iter f ~post else fst (f ()) +let with_local_level_if_principal f ~post = + with_local_level_if !Clflags.principal f ~post +let with_local_level_iter_if_principal f ~post = + with_local_level_iter_if !Clflags.principal f ~post +let with_level ~level f = + begin_def (); init_def level; + let result = wrap_end_def f in + result +let with_level_if cond ~level f = + if cond then with_level ~level f else f () + +let with_local_level_for_class ?post f = + begin_class_def (); + let result = wrap_end_def f in + Option.iter (fun g -> g result) post; + result + +let with_raised_nongen_level f = + raise_nongen_level (); + wrap_end_def f + + +let reset_global_level () = + global_level := !current_level +let increase_global_level () = + let gl = !global_level in + global_level := !current_level; + gl +let restore_global_level gl = + global_level := gl + +(**** Control tracing of GADT instances *) + +let trace_gadt_instances = ref false +let check_trace_gadt_instances env = + not !trace_gadt_instances && Env.has_local_constraints env && + (trace_gadt_instances := true; cleanup_abbrev (); true) + +let reset_trace_gadt_instances b = + if b then trace_gadt_instances := false + +let wrap_trace_gadt_instances env f x = + let b = check_trace_gadt_instances env in + let y = f x in + reset_trace_gadt_instances b; + y + +(**** Abbreviations without parameters ****) +(* Shall reset after generalizing *) + +let simple_abbrevs = ref Mnil + +let proper_abbrevs tl abbrev = + if tl <> [] || !trace_gadt_instances || !Clflags.principal + then abbrev + else simple_abbrevs + +(**** Some type creators ****) + +(* Re-export generic type creators *) + +let newty desc = newty2 ~level:!current_level desc +let new_scoped_ty scope desc = newty3 ~level:!current_level ~scope desc + +let newvar ?name () = newty2 ~level:!current_level (Tvar name) +let newvar2 ?name level = newty2 ~level:level (Tvar name) +let new_global_var ?name () = newty2 ~level:!global_level (Tvar name) +let newstub ~scope = newty3 ~level:!current_level ~scope (Tvar None) + +let newobj fields = newty (Tobject (fields, ref None)) + +let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) + +let none = newty (Ttuple []) (* Clearly ill-formed type *) + +(**** unification mode ****) + +type equations_generation = + | Forbidden + | Allowed of { equated_types : TypePairs.t } + +type unification_mode = + | Expression (* unification in expression *) + | Pattern of + { equations_generation : equations_generation; + assume_injective : bool; + allow_recursive_equations : bool; } + (* unification in pattern which may add local constraints *) + | Subst + (* unification during type constructor expansion; more + relaxed than [Expression] in some cases. *) + +let umode = ref Expression + +let in_pattern_mode () = + match !umode with + | Expression | Subst -> false + | Pattern _ -> true + +let in_subst_mode () = + match !umode with + | Expression | Pattern _ -> false + | Subst -> true + +let can_generate_equations () = + match !umode with + | Expression | Subst | Pattern { equations_generation = Forbidden } -> false + | Pattern { equations_generation = Allowed _ } -> true + +(* Can only be called when generate_equations is true *) +let record_equation t1 t2 = + match !umode with + | Expression | Subst | Pattern { equations_generation = Forbidden } -> + assert false + | Pattern { equations_generation = Allowed { equated_types } } -> + TypePairs.add equated_types (t1, t2) + +let can_assume_injective () = + match !umode with + | Expression | Subst -> false + | Pattern { assume_injective } -> assume_injective + +let in_counterexample () = + match !umode with + | Expression | Subst -> false + | Pattern { allow_recursive_equations } -> allow_recursive_equations + +let allow_recursive_equations () = + !Clflags.recursive_types + || match !umode with + | Expression | Subst -> false + | Pattern { allow_recursive_equations } -> allow_recursive_equations + +let set_mode_pattern ~allow_recursive_equations ~equated_types f = + let equations_generation = Allowed { equated_types } in + let assume_injective = true in + let new_umode = + Pattern + { equations_generation; + assume_injective; + allow_recursive_equations } + in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f + +let without_assume_injective f = + match !umode with + | Expression | Subst -> f () + | Pattern r -> + let new_umode = Pattern { r with assume_injective = false } in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f + +let without_generating_equations f = + match !umode with + | Expression | Subst -> f () + | Pattern r -> + let new_umode = Pattern { r with equations_generation = Forbidden } in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f + +(*** Checks for type definitions ***) + +let rec in_current_module = function + | Path.Pident _ -> true + | Path.Pdot _ | Path.Papply _ -> false + | Path.Pextra_ty (p, _) -> in_current_module p + +let in_pervasives p = + in_current_module p && + try ignore (Env.find_type p Env.initial); true + with Not_found -> false + +let is_datatype decl= + match decl.type_kind with + Type_record _ | Type_variant _ | Type_open -> true + | Type_abstract -> false + + + (**********************************************) + (* Miscellaneous operations on object types *) + (**********************************************) + +(* Note: + We need to maintain some invariants: + * cty_self must be a Tobject + * ... +*) + +(**** Object field manipulation. ****) + +let object_fields ty = + match get_desc ty with + Tobject (fields, _) -> fields + | _ -> assert false + +let flatten_fields ty = + let rec flatten l ty = + match get_desc ty with + Tfield(s, k, ty1, ty2) -> + flatten ((s, k, ty1)::l) ty2 + | _ -> + (l, ty) + in + let (l, r) = flatten [] ty in + (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r) + +let build_fields level = + List.fold_right + (fun (s, k, ty1) ty2 -> newty2 ~level (Tfield(s, k, ty1, ty2))) + +let associate_fields fields1 fields2 = + let rec associate p s s' = + function + (l, []) -> + (List.rev p, (List.rev s) @ l, List.rev s') + | ([], l') -> + (List.rev p, List.rev s, (List.rev s') @ l') + | ((n, k, t)::r, (n', k', t')::r') when n = n' -> + associate ((n, k, t, k', t')::p) s s' (r, r') + | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' -> + associate p ((n, k, t)::s) s' (r, l') + | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) -> + associate p s ((n', k', t')::s') (l, r') + in + associate [] [] [] (fields1, fields2) + +(**** Check whether an object is open ****) + +(* +++ The abbreviation should eventually be expanded *) +let rec object_row ty = + match get_desc ty with + Tobject (t, _) -> object_row t + | Tfield(_, _, _, t) -> object_row t + | _ -> ty + +let opened_object ty = + match get_desc (object_row ty) with + | Tvar _ | Tunivar _ | Tconstr _ -> true + | _ -> false + +let concrete_object ty = + match get_desc (object_row ty) with + | Tvar _ -> false + | _ -> true + +(**** Row variable of an object type ****) + +let rec fields_row_variable ty = + match get_desc ty with + | Tfield (_, _, _, ty) -> fields_row_variable ty + | Tvar _ -> ty + | _ -> assert false + +(**** Object name manipulation ****) +(* +++ Bientot obsolete *) + +let set_object_name id params ty = + match get_desc ty with + | Tobject (fi, nm) -> + let rv = fields_row_variable fi in + set_name nm (Some (Path.Pident id, rv::params)) + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.set_object_name" + +let remove_object_name ty = + match get_desc ty with + Tobject (_, nm) -> set_name nm None + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.remove_object_name" + + (*******************************************) + (* Miscellaneous operations on row types *) + (*******************************************) + +let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q) + +let rec merge_rf r1 r2 pairs fi1 fi2 = + match fi1, fi2 with + (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> + if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else + if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else + merge_rf r1 (p2::r2) pairs fi1 fi2' + | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) + | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) + +let merge_row_fields fi1 fi2 = + match fi1, fi2 with + [], _ | _, [] -> (fi1, fi2, []) + | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, []) + | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, []) + | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2) + +let rec filter_row_fields erase = function + [] -> [] + | (_l,f as p)::fi -> + let fi = filter_row_fields erase fi in + match row_field_repr f with + Rabsent -> fi + | Reither(_,_,false) when erase -> + link_row_field_ext ~inside:f rf_absent; fi + | _ -> p :: fi + + (**************************************) + (* Check genericity of type schemes *) + (**************************************) + +type variable_kind = Row_variable | Type_variable +exception Non_closed of type_expr * variable_kind + +(* [free_vars] collects the variables of the input type expression. It + is used for several different things in the type-checker, with the + following bells and whistles: + - If [env] is Some typing environment, types in the environment + are expanded to check whether the apparently-free variable would vanish + during expansion. + - We collect both type variables and row variables, paired with + a [variable_kind] to distinguish them. + - We do not count "virtual" free variables -- free variables stored in + the abbreviation of an object type that has been expanded (we store + the abbreviations for use when displaying the type). + + [free_vars] returns a [(variable * bool) list], while + [free_variables] below drops the type/row information + and only returns a [variable list]. + *) +let free_vars ?env ty = + let rec fv ~kind acc ty = + if not (try_mark_node ty) then acc + else match get_desc ty, env with + | Tvar _, _ -> + (ty, kind) :: acc + | Tconstr (path, tl, _), Some env -> + let acc = + match Env.find_type_expansion path env with + | exception Not_found -> acc + | (_, body, _) -> + if get_level body = generic_level then acc + else (ty, kind) :: acc + in + List.fold_left (fv ~kind:Type_variable) acc tl + | Tobject (ty, _), _ -> + (* ignoring the second parameter of [Tobject] amounts to not + counting "virtual free variables". *) + fv ~kind:Row_variable acc ty + | Tfield (_, _, ty1, ty2), _ -> + let acc = fv ~kind:Type_variable acc ty1 in + fv ~kind:Row_variable acc ty2 + | Tvariant row, _ -> + let acc = fold_row (fv ~kind:Type_variable) acc row in + if static_row row then acc + else fv ~kind:Row_variable acc (row_more row) + | _ -> + fold_type_expr (fv ~kind) acc ty + in fv ~kind:Type_variable [] ty + +let free_variables ?env ty = + let tl = List.map fst (free_vars ?env ty) in + unmark_type ty; + tl + +let closed_type ty = + match free_vars ty with + [] -> () + | (v, real) :: _ -> raise (Non_closed (v, real)) + +let closed_parameterized_type params ty = + List.iter mark_type params; + let ok = + try closed_type ty; true with Non_closed _ -> false in + List.iter unmark_type params; + unmark_type ty; + ok + +let closed_type_decl decl = + try + List.iter mark_type decl.type_params; + begin match decl.type_kind with + Type_abstract -> + () + | Type_variant (v, _rep) -> + List.iter + (fun {cd_args; cd_res; _} -> + match cd_res with + | Some _ -> () + | None -> + match cd_args with + | Cstr_tuple l -> List.iter closed_type l + | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l + ) + v + | Type_record(r, _rep) -> + List.iter (fun l -> closed_type l.ld_type) r + | Type_open -> () + end; + begin match decl.type_manifest with + None -> () + | Some ty -> closed_type ty + end; + unmark_type_decl decl; + None + with Non_closed (ty, _) -> + unmark_type_decl decl; + Some ty + +let closed_extension_constructor ext = + try + List.iter mark_type ext.ext_type_params; + begin match ext.ext_ret_type with + | Some _ -> () + | None -> iter_type_expr_cstr_args closed_type ext.ext_args + end; + unmark_extension_constructor ext; + None + with Non_closed (ty, _) -> + unmark_extension_constructor ext; + Some ty + +type closed_class_failure = { + free_variable: type_expr * variable_kind; + meth: string; + meth_ty: type_expr; +} +exception CCFailure of closed_class_failure + +let closed_class params sign = + List.iter mark_type params; + ignore (try_mark_node sign.csig_self_row); + try + Meths.iter + (fun lab (priv, _, ty) -> + if priv = Mpublic then begin + try closed_type ty with Non_closed (ty0, variable_kind) -> + raise (CCFailure { + free_variable = (ty0, variable_kind); + meth = lab; + meth_ty = ty; + }) + end) + sign.csig_meths; + List.iter unmark_type params; + unmark_class_signature sign; + None + with CCFailure reason -> + List.iter unmark_type params; + unmark_class_signature sign; + Some reason + + + (**********************) + (* Type duplication *) + (**********************) + + +(* Duplicate a type, preserving only type variables *) +let duplicate_type ty = + Subst.type_expr Subst.identity ty + +(* Same, for class types *) +let duplicate_class_type ty = + Subst.class_type Subst.identity ty + + + (*****************************) + (* Type level manipulation *) + (*****************************) + +(* + It would be a bit more efficient to remove abbreviation expansions + rather than generalizing them: these expansions will usually not be + used anymore. However, this is not possible in the general case, as + [expand_abbrev] (via [subst]) requires these expansions to be + preserved. Does it worth duplicating this code ? +*) +let rec generalize ty = + let level = get_level ty in + if (level > !current_level) && (level <> generic_level) then begin + set_level ty generic_level; + (* recur into abbrev for the speed *) + begin match get_desc ty with + Tconstr (_, _, abbrev) -> + iter_abbrev generalize !abbrev + | _ -> () + end; + iter_type_expr generalize ty + end + +let generalize ty = + simple_abbrevs := Mnil; + generalize ty + +(* Generalize the structure and lower the variables *) + +let rec generalize_structure ty = + let level = get_level ty in + if level <> generic_level then begin + if is_Tvar ty && level > !current_level then + set_level ty !current_level + else if level > !current_level then begin + begin match get_desc ty with + Tconstr (_, _, abbrev) -> + abbrev := Mnil + | _ -> () + end; + set_level ty generic_level; + iter_type_expr generalize_structure ty + end + end + +let generalize_structure ty = + simple_abbrevs := Mnil; + generalize_structure ty + +(* Generalize the spine of a function, if the level >= !current_level *) + +let rec generalize_spine ty = + let level = get_level ty in + if level < !current_level || level = generic_level then () else + match get_desc ty with + Tarrow (_, ty1, ty2, _) -> + set_level ty generic_level; + generalize_spine ty1; + generalize_spine ty2; + | Tpoly (ty', _) -> + set_level ty generic_level; + generalize_spine ty' + | Ttuple tyl -> + set_level ty generic_level; + List.iter generalize_spine tyl + | Tpackage (_, fl) -> + set_level ty generic_level; + List.iter (fun (_n, ty) -> generalize_spine ty) fl + | Tconstr (_, tyl, memo) -> + set_level ty generic_level; + memo := Mnil; + List.iter generalize_spine tyl + | _ -> () + +let forward_try_expand_safe = (* Forward declaration *) + ref (fun _env _ty -> assert false) + +(* + Lower the levels of a type (assume [level] is not + [generic_level]). +*) + +let rec normalize_package_path env p = + let t = + try (Env.find_modtype p env).mtd_type + with Not_found -> None + in + match t with + | Some (Mty_ident p) -> normalize_package_path env p + | Some (Mty_signature _ | Mty_functor _ | Mty_alias _ | Mty_for_hole) + | None -> + match p with + Path.Pdot (p1, s) -> + (* For module aliases *) + let p1' = Env.normalize_module_path None env p1 in + if Path.same p1 p1' then p else + normalize_package_path env (Path.Pdot (p1', s)) + | _ -> p + +let rec check_scope_escape env level ty = + let orig_level = get_level ty in + if try_logged_mark_node ty then begin + if level < get_scope ty then + raise_scope_escape_exn ty; + begin match get_desc ty with + | Tconstr (p, _, _) when level < Path.scope p -> + begin match !forward_try_expand_safe env ty with + | ty' -> + check_scope_escape env level ty' + | exception Cannot_expand -> + raise_escape_exn (Constructor p) + end + | Tpackage (p, fl) when level < Path.scope p -> + let p' = normalize_package_path env p in + if Path.same p p' then raise_escape_exn (Module_type p); + check_scope_escape env level + (newty2 ~level:orig_level (Tpackage (p', fl))) + | _ -> + iter_type_expr (check_scope_escape env level) ty + end; + end + +let check_scope_escape env level ty = + let snap = snapshot () in + try check_scope_escape env level ty; backtrack snap + with Escape e -> + backtrack snap; + raise (Escape { e with context = Some ty }) + +let rec update_scope scope ty = + if get_scope ty < scope then begin + if get_level ty < scope then raise_scope_escape_exn ty; + set_scope ty scope; + (* Only recurse in principal mode as this is not necessary for soundness *) + if !Clflags.principal then iter_type_expr (update_scope scope) ty + end + +let update_scope_for tr_exn scope ty = + try + update_scope scope ty + with Escape e -> raise_for tr_exn (Escape e) + +(* Note: the level of a type constructor must be greater than its binding + time. That way, a type constructor cannot escape the scope of its + definition, as would be the case in + let x = ref [] + module M = struct type t let _ = (x : t list ref) end + (without this constraint, the type system would actually be unsound.) +*) + +let rec update_level env level expand ty = + if get_level ty > level then begin + if level < get_scope ty then raise_scope_escape_exn ty; + match get_desc ty with + Tconstr(p, _tl, _abbrev) when level < Path.scope p -> + (* Try first to replace an abbreviation by its expansion. *) + begin try + let ty' = !forward_try_expand_safe env ty in + link_type ty ty'; + update_level env level expand ty' + with Cannot_expand -> + raise_escape_exn (Constructor p) + end + | Tconstr(p, (_ :: _ as tl), _) -> + let variance = + try (Env.find_type p env).type_variance + with Not_found -> List.map (fun _ -> Variance.unknown) tl in + let needs_expand = + expand || + List.exists2 + (fun var ty -> var = Variance.null && get_level ty > level) + variance tl + in + begin try + if not needs_expand then raise Cannot_expand; + let ty' = !forward_try_expand_safe env ty in + link_type ty ty'; + update_level env level expand ty' + with Cannot_expand -> + set_level ty level; + iter_type_expr (update_level env level expand) ty + end + | Tpackage (p, fl) when level < Path.scope p -> + let p' = normalize_package_path env p in + if Path.same p p' then raise_escape_exn (Module_type p); + set_type_desc ty (Tpackage (p', fl)); + update_level env level expand ty + | Tobject (_, ({contents=Some(p, _tl)} as nm)) + when level < Path.scope p -> + set_name nm None; + update_level env level expand ty + | Tvariant row -> + begin match row_name row with + | Some (p, _tl) when level < Path.scope p -> + set_type_desc ty (Tvariant (set_row_name row None)) + | _ -> () + end; + set_level ty level; + iter_type_expr (update_level env level expand) ty + | Tfield(lab, _, ty1, _) + when lab = dummy_method && level < get_scope ty1 -> + raise_escape_exn Self + | _ -> + set_level ty level; + (* XXX what about abbreviations in Tconstr ? *) + iter_type_expr (update_level env level expand) ty + end + +(* First try without expanding, then expand everything, + to avoid combinatorial blow-up *) +let update_level env level ty = + if get_level ty > level then begin + let snap = snapshot () in + try + update_level env level false ty + with Escape _ -> + backtrack snap; + update_level env level true ty + end + +let update_level_for tr_exn env level ty = + try + update_level env level ty + with Escape e -> raise_for tr_exn (Escape e) + +(* Lower level of type variables inside contravariant branches *) + +let rec lower_contravariant env var_level visited contra ty = + let must_visit = + get_level ty > var_level && + match Hashtbl.find visited (get_id ty) with + | done_contra -> contra && not done_contra + | exception Not_found -> true + in + if must_visit then begin + Hashtbl.add visited (get_id ty) contra; + let lower_rec = lower_contravariant env var_level visited in + match get_desc ty with + Tvar _ -> if contra then set_level ty var_level + | Tconstr (_, [], _) -> () + | Tconstr (path, tyl, _abbrev) -> + let variance, maybe_expand = + try + let typ = Env.find_type path env in + typ.type_variance, + typ.type_kind = Type_abstract + with Not_found -> + (* See testsuite/tests/typing-missing-cmi-2 for an example *) + List.map (fun _ -> Variance.unknown) tyl, + false + in + if List.for_all ((=) Variance.null) variance then () else + let not_expanded () = + List.iter2 + (fun v t -> + if v = Variance.null then () else + if Variance.(mem May_weak v) + then lower_rec true t + else lower_rec contra t) + variance tyl in + if maybe_expand then (* we expand cautiously to avoid missing cmis *) + match !forward_try_expand_safe env ty with + | ty -> lower_rec contra ty + | exception Cannot_expand -> not_expanded () + else not_expanded () + | Tpackage (_, fl) -> + List.iter (fun (_n, ty) -> lower_rec true ty) fl + | Tarrow (_, t1, t2, _) -> + lower_rec true t1; + lower_rec contra t2 + | _ -> + iter_type_expr (lower_rec contra) ty + end + +let lower_variables_only env level ty = + simple_abbrevs := Mnil; + lower_contravariant env level (Hashtbl.create 7) true ty + +let lower_contravariant env ty = + simple_abbrevs := Mnil; + lower_contravariant env !nongen_level (Hashtbl.create 7) false ty + +let rec generalize_class_type' gen = + function + Cty_constr (_, params, cty) -> + List.iter gen params; + generalize_class_type' gen cty + | Cty_signature csig -> + gen csig.csig_self; + gen csig.csig_self_row; + Vars.iter (fun _ (_, _, ty) -> gen ty) csig.csig_vars; + Meths.iter (fun _ (_, _, ty) -> gen ty) csig.csig_meths + | Cty_arrow (_, ty, cty) -> + gen ty; + generalize_class_type' gen cty + +let generalize_class_type cty = + generalize_class_type' generalize cty + +let generalize_class_type_structure cty = + generalize_class_type' generalize_structure cty + +(* Correct the levels of type [ty]. *) +let correct_levels ty = + duplicate_type ty + +(* Only generalize the type ty0 in ty *) +let limited_generalize ty0 ty = + let graph = Hashtbl.create 17 in + let idx = ref lowest_level in + let roots = ref [] in + + let rec inverse pty ty = + let level = get_level ty in + if (level > !current_level) || (level = generic_level) then begin + decr idx; + Hashtbl.add graph !idx (ty, ref pty); + if (level = generic_level) || eq_type ty ty0 then + roots := ty :: !roots; + set_level ty !idx; + iter_type_expr (inverse [ty]) ty + end else if level < lowest_level then begin + let (_, parents) = Hashtbl.find graph level in + parents := pty @ !parents + end + + and generalize_parents ty = + let idx = get_level ty in + if idx <> generic_level then begin + set_level ty generic_level; + List.iter generalize_parents !(snd (Hashtbl.find graph idx)); + (* Special case for rows: must generalize the row variable *) + match get_desc ty with + Tvariant row -> + let more = row_more row in + let lv = get_level more in + if (lv < lowest_level || lv > !current_level) + && lv <> generic_level then set_level more generic_level + | _ -> () + end + in + + inverse [] ty; + if get_level ty0 < lowest_level then + iter_type_expr (inverse []) ty0; + List.iter generalize_parents !roots; + Hashtbl.iter + (fun _ (ty, _) -> + if get_level ty <> generic_level then set_level ty !current_level) + graph + +let limited_generalize_class_type rv cty = + generalize_class_type' (limited_generalize rv) cty + +(* Compute statically the free univars of all nodes in a type *) +(* This avoids doing it repeatedly during instantiation *) + +type inv_type_expr = + { inv_type : type_expr; + mutable inv_parents : inv_type_expr list } + +let rec inv_type hash pty ty = + try + let inv = TypeHash.find hash ty in + inv.inv_parents <- pty @ inv.inv_parents + with Not_found -> + let inv = { inv_type = ty; inv_parents = pty } in + TypeHash.add hash ty inv; + iter_type_expr (inv_type hash [inv]) ty + +let compute_univars ty = + let inverted = TypeHash.create 17 in + inv_type inverted [] ty; + let node_univars = TypeHash.create 17 in + let rec add_univar univ inv = + match get_desc inv.inv_type with + Tpoly (_ty, tl) when List.memq (get_id univ) (List.map get_id tl) -> () + | _ -> + try + let univs = TypeHash.find node_univars inv.inv_type in + if not (TypeSet.mem univ !univs) then begin + univs := TypeSet.add univ !univs; + List.iter (add_univar univ) inv.inv_parents + end + with Not_found -> + TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ)); + List.iter (add_univar univ) inv.inv_parents + in + TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv) + inverted; + fun ty -> + try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty + + +let fully_generic ty = + let rec aux ty = + if not_marked_node ty then + if get_level ty = generic_level then + (flip_mark_node ty; iter_type_expr aux ty) + else raise Exit + in + let res = try aux ty; true with Exit -> false in + unmark_type ty; + res + + + (*******************) + (* Instantiation *) + (*******************) + + +let rec find_repr p1 = + function + Mnil -> + None + | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 -> + Some ty + | Mcons (_, _, _, _, rem) -> + find_repr p1 rem + | Mlink {contents = rem} -> + find_repr p1 rem + +(* + Generic nodes are duplicated, while non-generic nodes are left + as-is. + + During instantiation, the result of copying a generic node is + "cached" in-place by temporarily mutating the node description by + a stub [Tsubst (newvar ())] using [For_copy.redirect_desc]. The + scope of this mutation is determined by the [copy_scope] parameter, + and the [For_copy.with_scope] helper is in charge of creating a new + scope and performing the necessary book-keeping -- in particular + reverting the in-place updates after the instantiation is done. *) + +let abbreviations = ref (ref Mnil) + (* Abbreviation memorized. *) + +(* partial: we may not wish to copy the non generic types + before we call type_pat *) +let rec copy ?partial ?keep_names copy_scope ty = + let copy = copy ?partial ?keep_names copy_scope in + match get_desc ty with + Tsubst (ty, _) -> ty + | desc -> + let level = get_level ty in + if level <> generic_level && partial = None then ty else + (* We only forget types that are non generic and do not contain + free univars *) + let forget = + if level = generic_level then generic_level else + match partial with + None -> assert false + | Some (free_univars, keep) -> + if TypeSet.is_empty (free_univars ty) then + if keep then level else !current_level + else generic_level + in + if forget <> generic_level then newty2 ~level:forget (Tvar None) else + let t = newstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let desc' = + match desc with + | Tconstr (p, tl, _) -> + let abbrevs = proper_abbrevs tl !abbreviations in + begin match find_repr p !abbrevs with + Some ty when not (eq_type ty t) -> + Tlink ty + | _ -> + (* + One must allocate a new reference, so that abbrevia- + tions belonging to different branches of a type are + independent. + Moreover, a reference containing a [Mcons] must be + shared, so that the memorized expansion of an abbrevi- + ation can be released by changing the content of just + one reference. + *) + Tconstr (p, List.map copy tl, + ref (match !(!abbreviations) with + Mcons _ -> Mlink !abbreviations + | abbrev -> abbrev)) + end + | Tvariant row -> + let more = row_more row in + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + begin match mored with + Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + (* If the row variable is not generic, we must keep it *) + let keep = get_level more <> generic_level && partial = None in + let more' = + match mored with + Tsubst (ty, None) -> ty + (* TODO: is this case possible? + possibly an interaction with (copy more) below? *) + | Tconstr _ | Tnil -> + copy more + | Tvar _ | Tunivar _ -> + if keep then more else newty mored + | _ -> assert false + in + let row = + match get_desc more' with (* PR#6163 *) + Tconstr (x,_,_) when not (is_fixed row) -> + let Row {fields; more; closed; name} = row_repr row in + create_row ~fields ~more ~closed ~name + ~fixed:(Some (Reified x)) + | _ -> row + in + (* Open row if partial for pattern and contains Reither *) + let more', row = + match partial with + Some (free_univars, false) -> + let not_reither (_, f) = + match row_field_repr f with + Reither _ -> false + | _ -> true + in + let fields = row_fields row in + if row_closed row && not (is_fixed row) + && TypeSet.is_empty (free_univars ty) + && not (List.for_all not_reither fields) then + let more' = newvar () in + (more', + create_row ~fields:(List.filter not_reither fields) + ~more:more' ~closed:false ~fixed:None ~name:None) + else (more', row) + | _ -> (more', row) + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope more + (Tsubst(more', Some t)); + (* Return a new copy *) + Tvariant (copy_row copy true row keep more') + end + | Tobject (ty1, _) when partial <> None -> + Tobject (copy ty1, ref None) + | _ -> copy_type_desc ?keep_names copy desc + in + Transient_expr.set_stub_desc t desc'; + t + +(**** Variants of instantiations ****) + +let instance ?partial sch = + let partial = + match partial with + None -> None + | Some keep -> Some (compute_univars sch, keep) + in + For_copy.with_scope (fun copy_scope -> + copy ?partial copy_scope sch) + +let generic_instance sch = + let old = !current_level in + current_level := generic_level; + let ty = instance sch in + current_level := old; + ty + +let instance_list schl = + For_copy.with_scope (fun copy_scope -> + List.map (fun t -> copy copy_scope t) schl) + +(* Create unique names to new type constructors. + Used for existential types and local constraints. *) +let get_new_abstract_name env s = + (* unique names are needed only for error messages *) + if in_counterexample () then s else + let name index = + if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else + Printf.sprintf "%s%d" s index + in + let check index = + match Env.find_type_by_name (Longident.Lident (name index)) env with + | _ -> false + | exception Not_found -> true + in + let index = Misc.find_first_mono check in + name index + +let new_local_type ?(loc = Location.none) ?manifest_and_scope () = + let manifest, expansion_scope = + match manifest_and_scope with + None -> None, Btype.lowest_level + | Some (ty, scope) -> Some ty, scope + in + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = manifest; + type_variance = []; + type_separability = []; + type_is_newtype = true; + type_expansion_scope = expansion_scope; + type_loc = loc; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + +let existential_name cstr ty = + match get_desc ty with + | Tvar (Some name) -> "$" ^ cstr.cstr_name ^ "_'" ^ name + | _ -> "$" ^ cstr.cstr_name + +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of { env: Env.t ref; scope: int } + +let instance_constructor existential_treatment cstr = + For_copy.with_scope (fun copy_scope -> + let copy_existential = + match existential_treatment with + | Keep_existentials_flexible -> copy copy_scope + | Make_existentials_abstract {env; scope = fresh_constr_scope} -> + fun existential -> + let decl = new_local_type () in + let name = existential_name cstr existential in + let (id, new_env) = + Env.enter_type (get_new_abstract_name !env name) decl !env + ~scope:fresh_constr_scope in + env := new_env; + let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in + let tv = copy copy_scope existential in + assert (is_Tvar tv); + link_type tv to_unify; + tv + in + let ty_ex = List.map copy_existential cstr.cstr_existentials in + let ty_res = copy copy_scope cstr.cstr_res in + let ty_args = List.map (copy copy_scope) cstr.cstr_args in + (ty_args, ty_res, ty_ex) + ) + +let instance_parameterized_type ?keep_names sch_args sch = + For_copy.with_scope (fun copy_scope -> + let ty_args = List.map (fun t -> copy ?keep_names copy_scope t) sch_args in + let ty = copy copy_scope sch in + (ty_args, ty) + ) + +let map_kind f = function + | Type_abstract -> Type_abstract + | Type_open -> Type_open + | Type_variant (cl, rep) -> + Type_variant ( + List.map + (fun c -> + {c with + cd_args = map_type_expr_cstr_args f c.cd_args; + cd_res = Option.map f c.cd_res + }) + cl, rep) + | Type_record (fl, rr) -> + Type_record ( + List.map + (fun l -> + {l with ld_type = f l.ld_type} + ) fl, rr) + + +let instance_declaration decl = + For_copy.with_scope (fun copy_scope -> + {decl with type_params = List.map (copy copy_scope) decl.type_params; + type_manifest = Option.map (copy copy_scope) decl.type_manifest; + type_kind = map_kind (copy copy_scope) decl.type_kind; + } + ) + +let generic_instance_declaration decl = + let old = !current_level in + current_level := generic_level; + let decl = instance_declaration decl in + current_level := old; + decl + +let instance_class params cty = + let rec copy_class_type copy_scope = function + | Cty_constr (path, tyl, cty) -> + let tyl' = List.map (copy copy_scope) tyl in + let cty' = copy_class_type copy_scope cty in + Cty_constr (path, tyl', cty') + | Cty_signature sign -> + Cty_signature + {csig_self = copy copy_scope sign.csig_self; + csig_self_row = copy copy_scope sign.csig_self_row; + csig_vars = + Vars.map + (function (m, v, ty) -> (m, v, copy copy_scope ty)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, ty) -> (p, v, copy copy_scope ty)) + sign.csig_meths} + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, copy copy_scope ty, copy_class_type copy_scope cty) + in + For_copy.with_scope (fun copy_scope -> + let params' = List.map (copy copy_scope) params in + let cty' = copy_class_type copy_scope cty in + (params', cty') + ) + +(**** Instantiation for types with free universal variables ****) + +(* [copy_sep] is used to instantiate first-class polymorphic types. + * It first makes a separate copy of the type as a graph, omitting nodes + that have no free univars. + * In this first pass, [visited] is used as a mapping for previously visited + nodes, and must already contain all the free univars in [ty]. + * The remaining (univar-closed) parts of the type are then instantiated + with [copy] using a common [copy_scope]. + The reason to work in two passes lies in recursive types such as: + [let h (x : < m : 'a. < n : 'a; p : 'b > > as 'b) = x#m] + The type of [x#m] should be: + [ < n : 'c; p : < m : 'a. < n : 'a; p : 'b > > as 'b > ] + I.e., the universal type variable ['a] is both instantiated as a fresh + type variable ['c] when outside of its binder, and kept as universal + when under its binder. + Assumption: in the first call to [copy_sep], all the free univars should + be bound by the same [Tpoly] node. This guarantees that they are only + bound when under this [Tpoly] node, which has no free univars, and as + such is not part of the separate copy. In turn, this allows the separate + copy to keep the sharing of the original type without breaking its + binding structure. + *) +let copy_sep ~copy_scope ~fixed ~(visited : type_expr TypeHash.t) sch = + let free = compute_univars sch in + let delayed_copies = ref [] in + let add_delayed_copy t ty = + delayed_copies := + lazy (Transient_expr.set_stub_desc t (Tlink (copy copy_scope ty))) :: + !delayed_copies + in + let rec copy_rec ~may_share (ty : type_expr) = + let univars = free ty in + if is_Tvar ty || may_share && TypeSet.is_empty univars then + if get_level ty <> generic_level then ty else + let t = newstub ~scope:(get_scope ty) in + add_delayed_copy t ty; + t + else try + TypeHash.find visited ty + with Not_found -> begin + let t = newstub ~scope:(get_scope ty) in + TypeHash.add visited ty t; + let desc' = + match get_desc ty with + | Tvariant row -> + let more = row_more row in + (* We shall really check the level on the row variable *) + let keep = is_Tvar more && get_level more <> generic_level in + (* In that case we should keep the original, but we still + call copy to correct the levels *) + if keep then (add_delayed_copy t ty; Tvar None) else + let more' = copy_rec ~may_share:false more in + let fixed' = fixed && (is_Tvar more || is_Tunivar more) in + let row = + copy_row (copy_rec ~may_share:true) fixed' row keep more' in + Tvariant row + | Tfield (p, k, ty1, ty2) -> + (* the kind is kept shared, see Btype.copy_type_desc *) + Tfield (p, field_kind_internal_repr k, + copy_rec ~may_share:true ty1, + copy_rec ~may_share:false ty2) + | desc -> copy_type_desc (copy_rec ~may_share:true) desc + in + Transient_expr.set_stub_desc t desc'; + t + end + in + let ty = copy_rec ~may_share:true sch in + List.iter Lazy.force !delayed_copies; + ty + +let instance_poly' copy_scope ~keep_names fixed univars sch = + (* In order to compute univars below, [sch] should not contain [Tsubst] *) + let copy_var ty = + match get_desc ty with + Tunivar name -> if keep_names then newty (Tvar name) else newvar () + | _ -> assert false + in + let vars = List.map copy_var univars in + let visited = TypeHash.create 17 in + List.iter2 (TypeHash.add visited) univars vars; + let ty = copy_sep ~copy_scope ~fixed ~visited sch in + vars, ty + +let instance_poly ?(keep_names=false) fixed univars sch = + For_copy.with_scope (fun copy_scope -> + instance_poly' copy_scope ~keep_names fixed univars sch + ) + +let instance_label fixed lbl = + For_copy.with_scope (fun copy_scope -> + let vars, ty_arg = + match get_desc lbl.lbl_arg with + Tpoly (ty, tl) -> + instance_poly' copy_scope ~keep_names:false fixed tl ty + | _ -> + [], copy copy_scope lbl.lbl_arg + in + (* call [copy] after [instance_poly] to avoid introducing [Tsubst] *) + let ty_res = copy copy_scope lbl.lbl_res in + (vars, ty_arg, ty_res) + ) + +(**** Instantiation with parameter substitution ****) + +(* NB: since this is [unify_var], it raises [Unify], not [Unify_trace] *) +let unify_var' = (* Forward declaration *) + ref (fun _env _ty1 _ty2 -> assert false) + +let subst env level priv abbrev oty params args body = + if List.length params <> List.length args then raise Cannot_subst; + let old_level = !current_level in + current_level := level; + let body0 = newvar () in (* Stub *) + let undo_abbrev = + match oty with + | None -> fun () -> () (* No abbreviation added *) + | Some ty -> + match get_desc ty with + Tconstr (path, tl, _) -> + let abbrev = proper_abbrevs tl abbrev in + memorize_abbrev abbrev priv path ty body0; + fun () -> forget_abbrev abbrev path + | _ -> assert false + in + abbreviations := abbrev; + let (params', body') = instance_parameterized_type params body in + abbreviations := ref Mnil; + let old_umode = !umode in + umode := Subst; + try + !unify_var' env body0 body'; + List.iter2 (!unify_var' env) params' args; + current_level := old_level; + umode := old_umode; + body' + with Unify _ -> + current_level := old_level; + umode := old_umode; + undo_abbrev (); + raise Cannot_subst + +(* + Default to generic level. Usually, only the shape of the type matters, not + whether it is generic or not. [generic_level] might be somewhat slower, but + it ensures invariants on types are enforced (decreasing levels), and we don't + care about efficiency here. +*) +let apply ?(use_current_level = false) env params body args = + let level = if use_current_level then !current_level else generic_level in + try + subst env level Public (ref Mnil) None params args body + with + Cannot_subst -> raise Cannot_apply + +let () = Subst.ctype_apply_env_empty := apply Env.empty + + (****************************) + (* Abbreviation expansion *) + (****************************) + +(* + If the environment has changed, memorized expansions might not + be correct anymore, and so we flush the cache. This is safe but + quite pessimistic: it would be enough to flush the cache when a + type or module definition is overridden in the environment. +*) +let previous_env = ref Env.empty +(*let string_of_kind = function Public -> "public" | Private -> "private"*) +let check_abbrev_env env = + if env != !previous_env then begin + (* prerr_endline "cleanup expansion cache"; *) + cleanup_abbrev (); + previous_env := env + end + + +(* Expand an abbreviation. The expansion is memorized. *) +(* + Assume the level is greater than the path binding time of the + expanded abbreviation. +*) +(* + An abbreviation expansion will fail in either of these cases: + 1. The type constructor does not correspond to a manifest type. + 2. The type constructor is defined in an external file, and this + file is not in the path (missing -I options). + 3. The type constructor is not in the "local" environment. This can + happens when a non-generic type variable has been instantiated + afterwards to the not yet defined type constructor. (Actually, + this cannot happen at the moment due to the strong constraints + between type levels and constructor binding time.) + 4. The expansion requires the expansion of another abbreviation, + and this other expansion fails. +*) +let expand_abbrev_gen kind find_type_expansion env ty = + check_abbrev_env env; + match get_desc ty with + Tconstr (path, args, abbrev) -> + let level = get_level ty in + let scope = get_scope ty in + let lookup_abbrev = proper_abbrevs args abbrev in + begin match find_expans kind path !lookup_abbrev with + Some ty' -> + (* prerr_endline + ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) + if level <> generic_level then + begin try + update_level env level ty' + with Escape _ -> + (* XXX This should not happen. + However, levels are not correctly restored after a + typing error *) + () + end; + begin try + update_scope scope ty'; + with Escape _ -> + (* XXX This should not happen. + However, levels are not correctly restored after a + typing error *) + () + end; + ty' + | None -> + match find_type_expansion path env with + | exception Not_found -> + (* another way to expand is to normalize the path itself *) + let path' = Env.normalize_type_path None env path in + if Path.same path path' then raise Cannot_expand + else newty2 ~level (Tconstr (path', args, abbrev)) + | (params, body, lv) -> + (* prerr_endline + ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) + let ty' = + try + subst env level kind abbrev (Some ty) params args body + with Cannot_subst -> raise_escape_exn Constraint + in + (* For gadts, remember type as non exportable *) + (* The ambiguous level registered for ty' should be the highest *) + (* if !trace_gadt_instances then begin *) + let scope = Int.max lv (get_scope ty) in + update_scope scope ty; + update_scope scope ty'; + ty' + end + | _ -> + assert false + +(* Expand respecting privacy *) +let expand_abbrev env ty = + expand_abbrev_gen Public Env.find_type_expansion env ty + +(* Expand once the head of a type *) +let expand_head_once env ty = + try + expand_abbrev env ty + with Cannot_expand | Escape _ -> assert false + +(* Check whether a type can be expanded *) +let safe_abbrev env ty = + let snap = Btype.snapshot () in + try ignore (expand_abbrev env ty); true with + Cannot_expand -> + Btype.backtrack snap; + false + | Escape _ -> + Btype.backtrack snap; + cleanup_abbrev (); + false + +(* Expand the head of a type once. + Raise Cannot_expand if the type cannot be expanded. + May raise Escape, if a recursion was hidden in the type. *) +let try_expand_once env ty = + match get_desc ty with + Tconstr _ -> expand_abbrev env ty + | _ -> raise Cannot_expand + +(* This one only raises Cannot_expand *) +let try_expand_safe env ty = + let snap = Btype.snapshot () in + try try_expand_once env ty + with Escape _ -> + Btype.backtrack snap; cleanup_abbrev (); raise Cannot_expand + +(* Fully expand the head of a type. *) +let rec try_expand_head + (try_once : Env.t -> type_expr -> type_expr) env ty = + let ty' = try_once env ty in + try try_expand_head try_once env ty' + with Cannot_expand -> ty' + +(* Unsafe full expansion, may raise [Unify [Escape _]]. *) +let expand_head_unif env ty = + try + try_expand_head try_expand_once env ty + with + | Cannot_expand -> ty + | Escape e -> raise_for Unify (Escape e) + +(* Safe version of expand_head, never fails *) +let expand_head env ty = + try try_expand_head try_expand_safe env ty + with Cannot_expand -> ty + +let _ = forward_try_expand_safe := try_expand_safe + + +(* Expand until we find a non-abstract type declaration, + use try_expand_safe to avoid raising "Unify _" when + called on recursive types + *) + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + | Has_no_typedecl + | May_have_typedecl + +let rec extract_concrete_typedecl env ty = + match get_desc ty with + Tconstr (p, _, _) -> + begin match Env.find_type p env with + | exception Not_found -> May_have_typedecl + | decl -> + if decl.type_kind <> Type_abstract then Typedecl(p, p, decl) + else begin + match try_expand_safe env ty with + | exception Cannot_expand -> May_have_typedecl + | ty -> + match extract_concrete_typedecl env ty with + | Typedecl(_, p', decl) -> Typedecl(p, p', decl) + | Has_no_typedecl -> Has_no_typedecl + | May_have_typedecl -> May_have_typedecl + end + end + | Tpoly(ty, _) -> extract_concrete_typedecl env ty + | Tarrow _ | Ttuple _ | Tobject _ | Tfield _ | Tnil + | Tvariant _ | Tpackage _ -> Has_no_typedecl + | Tvar _ | Tunivar _ -> May_have_typedecl + | Tlink _ | Tsubst _ -> assert false + +(* Implementing function [expand_head_opt], the compiler's own version of + [expand_head] used for type-based optimisations. + [expand_head_opt] uses [Env.find_type_expansion_opt] to access the + manifest type information of private abstract data types which is + normally hidden to the type-checker out of the implementation module of + the private abbreviation. *) + +let expand_abbrev_opt env ty = + expand_abbrev_gen Private Env.find_type_expansion_opt env ty + +let safe_abbrev_opt env ty = + let snap = Btype.snapshot () in + try ignore (expand_abbrev_opt env ty); true + with Cannot_expand | Escape _ -> + Btype.backtrack snap; + false + +let try_expand_once_opt env ty = + match get_desc ty with + Tconstr _ -> expand_abbrev_opt env ty + | _ -> raise Cannot_expand + +let try_expand_safe_opt env ty = + let snap = Btype.snapshot () in + try try_expand_once_opt env ty + with Escape _ -> + Btype.backtrack snap; raise Cannot_expand + +let expand_head_opt env ty = + try try_expand_head try_expand_safe_opt env ty with Cannot_expand -> ty + +(* Recursively expand the head of a type. + Also expand #-types. + + Error printing relies on [full_expand] returning exactly its input (i.e., a + physically equal type) when nothing changes. *) +let full_expand ~may_forget_scope env ty = + let ty = + if may_forget_scope then + try expand_head_unif env ty with Unify_trace _ -> + (* #10277: forget scopes when printing trace *) + with_level ~level:(get_level ty) begin fun () -> + (* The same as [expand_head], except in the failing case we return the + *original* type, not [correct_levels ty].*) + try try_expand_head try_expand_safe env (correct_levels ty) with + | Cannot_expand -> ty + end + else expand_head env ty + in + match get_desc ty with + Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar v -> + newty2 ~level:(get_level ty) (Tobject (fi, ref None)) + | _ -> + ty + +(* + Check whether the abbreviation expands to a well-defined type. + During the typing of a class, abbreviations for correspondings + types expand to non-generic types. +*) +let generic_abbrev env path = + try + let (_, body, _) = Env.find_type_expansion path env in + get_level body = generic_level + with + Not_found -> + false + +let generic_private_abbrev env path = + try + match Env.find_type path env with + {type_kind = Type_abstract; + type_private = Private; + type_manifest = Some body} -> + get_level body = generic_level + | _ -> false + with Not_found -> false + +let is_contractive env p = + try + let decl = Env.find_type p env in + in_pervasives p && decl.type_manifest = None || is_datatype decl + with Not_found -> false + + + (*****************) + (* Occur check *) + (*****************) + + +exception Occur + +let rec occur_rec env allow_recursive visited ty0 ty = + if eq_type ty ty0 then raise Occur; + match get_desc ty with + Tconstr(p, _tl, _abbrev) -> + if allow_recursive && is_contractive env p then () else + begin try + if TypeSet.mem ty visited then raise Occur; + let visited = TypeSet.add ty visited in + iter_type_expr (occur_rec env allow_recursive visited ty0) ty + with Occur -> try + let ty' = try_expand_head try_expand_once env ty in + (* This call used to be inlined, but there seems no reason for it. + Message was referring to change in rev. 1.58 of the CVS repo. *) + occur_rec env allow_recursive visited ty0 ty' + with Cannot_expand -> + raise Occur + end + | Tobject _ | Tvariant _ -> + () + | _ -> + if allow_recursive || TypeSet.mem ty visited then () else begin + let visited = TypeSet.add ty visited in + iter_type_expr (occur_rec env allow_recursive visited ty0) ty + end + +let type_changed = ref false (* trace possible changes to the studied type *) + +let merge r b = if b then r := true + +let occur env ty0 ty = + let allow_recursive = allow_recursive_equations () in + let old = !type_changed in + try + while + type_changed := false; + if not (eq_type ty0 ty) then + occur_rec env allow_recursive TypeSet.empty ty0 ty; + !type_changed + do () (* prerr_endline "changed" *) done; + merge type_changed old + with exn -> + merge type_changed old; + raise exn + +let occur_for tr_exn env t1 t2 = + try + occur env t1 t2 + with Occur -> raise_for tr_exn (Rec_occur(t1, t2)) + +let occur_in env ty0 t = + try occur env ty0 t; false with Occur -> true + +(* Check that a local constraint is well-founded *) +(* PR#6405: not needed since we allow recursion and work on normalized types *) +(* PR#6992: we actually need it for contractiveness *) +(* This is a simplified version of occur, only for the rectypes case *) + +let rec local_non_recursive_abbrev ~allow_rec strict visited env p ty = + (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*) + if not (List.memq (get_id ty) visited) then begin + match get_desc ty with + Tconstr(p', args, _abbrev) -> + if Path.same p p' then raise Occur; + if allow_rec && not strict && is_contractive env p' then () else + let visited = get_id ty :: visited in + begin try + (* try expanding, since [p] could be hidden *) + local_non_recursive_abbrev ~allow_rec strict visited env p + (try_expand_head try_expand_safe_opt env ty) + with Cannot_expand -> + let params = + try (Env.find_type p' env).type_params + with Not_found -> args + in + List.iter2 + (fun tv ty -> + let strict = strict || not (is_Tvar tv) in + local_non_recursive_abbrev ~allow_rec strict visited env p ty) + params args + end + | Tobject _ | Tvariant _ when not strict -> + () + | _ -> + if strict || not allow_rec then (* PR#7374 *) + let visited = get_id ty :: visited in + iter_type_expr + (local_non_recursive_abbrev ~allow_rec true visited env p) ty + end + +let local_non_recursive_abbrev env p ty = + let allow_rec = allow_recursive_equations () in + try (* PR#7397: need to check trace_gadt_instances *) + wrap_trace_gadt_instances env + (local_non_recursive_abbrev ~allow_rec false [] env p) ty; + true + with Occur -> false + + + (*****************************) + (* Polymorphic Unification *) + (*****************************) + +(* Since we cannot duplicate universal variables, unification must + be done at meta-level, using bindings in univar_pairs *) +(* TODO: use find_opt *) +let rec unify_univar t1 t2 = function + (cl1, cl2) :: rem -> + let find_univ t cl = + try + let (_, r) = List.find (fun (t',_) -> eq_type t t') cl in + Some r + with Not_found -> None + in + begin match find_univ t1 cl1, find_univ t2 cl2 with + Some {contents=Some t'2}, Some _ when eq_type t2 t'2 -> + () + | Some({contents=None} as r1), Some({contents=None} as r2) -> + set_univar r1 t2; set_univar r2 t1 + | None, None -> + unify_univar t1 t2 rem + | _ -> + raise Cannot_unify_universal_variables + end + | [] -> raise Cannot_unify_universal_variables + +(* The same as [unify_univar], but raises the appropriate exception instead of + [Cannot_unify_universal_variables] *) +let unify_univar_for tr_exn t1 t2 univar_pairs = + try unify_univar t1 t2 univar_pairs + with Cannot_unify_universal_variables -> raise_unexplained_for tr_exn + +(* Test the occurrence of free univars in a type *) +(* That's way too expensive. Must do some kind of caching *) +(* If [inj_only=true], only check injective positions *) +let occur_univar ?(inj_only=false) env ty = + let visited = ref TypeMap.empty in + let rec occur_rec bound ty = + if not_marked_node ty then + if TypeSet.is_empty bound then + (flip_mark_node ty; occur_desc bound ty) + else try + let bound' = TypeMap.find ty !visited in + if not (TypeSet.subset bound' bound) then begin + visited := TypeMap.add ty (TypeSet.inter bound bound') !visited; + occur_desc bound ty + end + with Not_found -> + visited := TypeMap.add ty bound !visited; + occur_desc bound ty + and occur_desc bound ty = + match get_desc ty with + Tunivar _ -> + if not (TypeSet.mem ty bound) then + raise_escape_exn (Univ ty) + | Tpoly (ty, tyl) -> + let bound = List.fold_right TypeSet.add tyl bound in + occur_rec bound ty + | Tconstr (_, [], _) -> () + | Tconstr (p, tl, _) -> + begin try + let td = Env.find_type p env in + List.iter2 + (fun t v -> + (* The null variance only occurs in type abbreviations and + corresponds to type variables that do not occur in the + definition (expansion would erase them completely). + The type-checker consistently ignores type expressions + in this position. Physical expansion, as done in `occur`, + would be costly here, since we need to check inside + object and variant types too. *) + if Variance.(if inj_only then mem Inj v else not (eq v null)) + then occur_rec bound t) + tl td.type_variance + with Not_found -> + if not inj_only then List.iter (occur_rec bound) tl + end + | _ -> iter_type_expr (occur_rec bound) ty + in + Misc.try_finally (fun () -> + occur_rec TypeSet.empty ty + ) + ~always:(fun () -> unmark_type ty) + +let has_free_univars env ty = + try occur_univar ~inj_only:false env ty; false with Escape _ -> true +let has_injective_univars env ty = + try occur_univar ~inj_only:true env ty; false with Escape _ -> true + +let occur_univar_for tr_exn env ty = + try + occur_univar env ty + with Escape e -> raise_for tr_exn (Escape e) + +(* Grouping univars by families according to their binders *) +let add_univars = + List.fold_left (fun s (t,_) -> TypeSet.add t s) + +let get_univar_family univar_pairs univars = + if univars = [] then TypeSet.empty else + let insert s = function + cl1, (_::_ as cl2) -> + if List.exists (fun (t1,_) -> TypeSet.mem t1 s) cl1 then + add_univars s cl2 + else s + | _ -> s + in + let s = List.fold_right TypeSet.add univars TypeSet.empty in + List.fold_left insert s univar_pairs + +(* Whether a family of univars escapes from a type *) +let univars_escape env univar_pairs vl ty = + let family = get_univar_family univar_pairs vl in + let visited = ref TypeSet.empty in + let rec occur t = + if TypeSet.mem t !visited then () else begin + visited := TypeSet.add t !visited; + match get_desc t with + Tpoly (t, tl) -> + if List.exists (fun t -> TypeSet.mem t family) tl then () + else occur t + | Tunivar _ -> if TypeSet.mem t family then raise_escape_exn (Univ t) + | Tconstr (_, [], _) -> () + | Tconstr (p, tl, _) -> + begin try + let td = Env.find_type p env in + List.iter2 + (* see occur_univar *) + (fun t v -> if not Variance.(eq v null) then occur t) + tl td.type_variance + with Not_found -> + List.iter occur tl + end + | _ -> + iter_type_expr occur t + end + in + occur ty + +(* Wrapper checking that no variable escapes and updating univar_pairs *) +let enter_poly env univar_pairs t1 tl1 t2 tl2 f = + let old_univars = !univar_pairs in + let known_univars = + List.fold_left (fun s (cl,_) -> add_univars s cl) + TypeSet.empty old_univars + in + if List.exists (fun t -> TypeSet.mem t known_univars) tl1 then + univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2))); + if List.exists (fun t -> TypeSet.mem t known_univars) tl2 then + univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1))); + let cl1 = List.map (fun t -> t, ref None) tl1 + and cl2 = List.map (fun t -> t, ref None) tl2 in + univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; + Misc.try_finally (fun () -> f t1 t2) + ~always:(fun () -> univar_pairs := old_univars) + +let enter_poly_for tr_exn env univar_pairs t1 tl1 t2 tl2 f = + try + enter_poly env univar_pairs t1 tl1 t2 tl2 f + with Escape e -> raise_for tr_exn (Escape e) + +let univar_pairs = ref [] + +(**** Instantiate a generic type into a poly type ***) + +let polyfy env ty vars = + let subst_univar copy_scope ty = + match get_desc ty with + | Tvar name when get_level ty = generic_level -> + let t = newty (Tunivar name) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + Some t + | _ -> None + in + (* need to expand twice? cf. Ctype.unify2 *) + let vars = List.map (expand_head env) vars in + let vars = List.map (expand_head env) vars in + For_copy.with_scope (fun copy_scope -> + let vars' = List.filter_map (subst_univar copy_scope) vars in + let ty = copy copy_scope ty in + let ty = newty2 ~level:(get_level ty) (Tpoly(ty, vars')) in + let complete = List.length vars = List.length vars' in + ty, complete + ) + +(* assumption: [ty] is fully generalized. *) +let reify_univars env ty = + let vars = free_variables ty in + let ty, _ = polyfy env ty vars in + ty + + (*****************) + (* Unification *) + (*****************) + + + +let rec has_cached_expansion p abbrev = + match abbrev with + Mnil -> false + | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem + | Mlink rem -> has_cached_expansion p !rem + +(**** Transform error trace ****) +(* +++ Move it to some other place ? *) +(* That's hard to do because it relies on the expansion machinery in Ctype, + but still might be nice. *) + +let expand_type env ty = + { ty = ty; + expanded = full_expand ~may_forget_scope:true env ty } + +let expand_any_trace map env trace = + map (expand_type env) trace + +let expand_trace env trace = + expand_any_trace Errortrace.map env trace + +let expand_subtype_trace env trace = + expand_any_trace Subtype.map env trace + +let expand_to_unification_error env trace = + unification_error ~trace:(expand_trace env trace) + +let expand_to_equality_error env trace subst = + equality_error ~trace:(expand_trace env trace) ~subst + +let expand_to_moregen_error env trace = + moregen_error ~trace:(expand_trace env trace) + +(* [expand_trace] and the [expand_to_*_error] functions take care of most of the + expansion in this file, but we occasionally need to build [Errortrace.error]s + in other ways/elsewhere, so we expose some machinery for doing so +*) + +(* Equivalent to [expand_trace env [Diff {got; expected}]] for a single + element *) +let expanded_diff env ~got ~expected = + Diff (map_diff (expand_type env) {got; expected}) + +(* Diff while transforming a [type_expr] into an [expanded_type] without + expanding *) +let unexpanded_diff ~got ~expected = + Diff (map_diff trivial_expansion {got; expected}) + +(**** Unification ****) + +(* Return whether [t0] occurs in [ty]. Objects are also traversed. *) +let deep_occur t0 ty = + let rec occur_rec ty = + if get_level ty >= get_level t0 && try_mark_node ty then begin + if eq_type ty t0 then raise Occur; + iter_type_expr occur_rec ty + end + in + try + occur_rec ty; unmark_type ty; false + with Occur -> + unmark_type ty; true + +let gadt_equations_level = ref None + +let get_gadt_equations_level () = + match !gadt_equations_level with + | None -> assert false + | Some x -> x + + +(* a local constraint can be added only if the rhs + of the constraint does not contain any Tvars. + They need to be removed using this function *) +let reify env t = + let fresh_constr_scope = get_gadt_equations_level () in + let create_fresh_constr lev name = + let name = match name with Some s -> "$'"^s | _ -> "$" in + let decl = new_local_type () in + let (id, new_env) = + Env.enter_type (get_new_abstract_name !env name) decl !env + ~scope:fresh_constr_scope in + let path = Path.Pident id in + let t = newty2 ~level:lev (Tconstr (path,[],ref Mnil)) in + env := new_env; + path, t + in + let visited = ref TypeSet.empty in + let rec iterator ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty with + Tvar o -> + let level = get_level ty in + let path, t = create_fresh_constr level o in + link_type ty t; + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) + | Tvariant r -> + if not (static_row r) then begin + if is_fixed r then iterator (row_more r) else + let m = row_more r in + match get_desc m with + Tvar o -> + let level = get_level m in + let path, t = create_fresh_constr level o in + let row = + let fixed = Some (Reified path) in + create_row ~fields:[] ~more:t ~fixed + ~name:(row_name r) ~closed:(row_closed r) in + link_type m (newty2 ~level (Tvariant row)); + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) + | _ -> assert false + end; + iter_row iterator r + | _ -> + iter_type_expr iterator ty + end + in + iterator t + +let find_expansion_scope env path = + match Env.find_type path env with + | { type_manifest = None ; _ } | exception Not_found -> generic_level + | decl -> decl.type_expansion_scope + +let non_aliasable p decl = + (* in_pervasives p || (subsumed by in_current_module) *) + in_current_module p && not decl.type_is_newtype + +let is_instantiable env p = + try + let decl = Env.find_type p env in + decl.type_kind = Type_abstract && + decl.type_private = Public && + decl.type_arity = 0 && + decl.type_manifest = None && + not (non_aliasable p decl) + with Not_found -> false + + +let compatible_paths p1 p2 = + let open Predef in + Path.same p1 p2 || + Path.same p1 path_bytes && Path.same p2 path_string || + Path.same p1 path_string && Path.same p2 path_bytes + +(* Check for datatypes carefully; see PR#6348 *) +let rec expands_to_datatype env ty = + match get_desc ty with + Tconstr (p, _, _) -> + begin try + is_datatype (Env.find_type p env) || + expands_to_datatype env (try_expand_safe env ty) + with Not_found | Cannot_expand -> false + end + | _ -> false + +(* [mcomp] tests if two types are "compatible" -- i.e., if they could ever + unify. (This is distinct from [eqtype], which checks if two types *are* + exactly the same.) This is used to decide whether GADT cases are + unreachable. It is broadly part of unification. *) + +(* mcomp type_pairs subst env t1 t2 does not raise an + exception if it is possible that t1 and t2 are actually + equal, assuming the types in type_pairs are equal and + that the mapping subst holds. + Assumes that both t1 and t2 do not contain any tvars + and that both their objects and variants are closed + *) + +let rec mcomp type_pairs env t1 t2 = + if eq_type t1 t2 then () else + match (get_desc t1, get_desc t2) with + | (Tvar _, _) + | (_, Tvar _) -> + () + | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> + () + | _ -> + let t1' = expand_head_opt env t1 in + let t2' = expand_head_opt env t2 in + (* Expansion may have changed the representative of the types... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + | (Tvar _, _) + | (_, Tvar _) -> + () + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) + when l1 = l2 || not (is_optional l1 || is_optional l2) -> + mcomp type_pairs env t1 t2; + mcomp type_pairs env u1 u2; + | (Ttuple tl1, Ttuple tl2) -> + mcomp_list type_pairs env tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) -> + mcomp_type_decl type_pairs env p1 p2 tl1 tl2 + | (Tconstr (_, [], _), _) when has_injective_univars env t2' -> + raise_unexplained_for Unify + | (_, Tconstr (_, [], _)) when has_injective_univars env t1' -> + raise_unexplained_for Unify + | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) -> + begin try + let decl = Env.find_type p env in + if non_aliasable p decl || is_datatype decl then + raise Incompatible + with Not_found -> () + end + (* + | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 -> + mcomp_list type_pairs env tl1 tl2 + *) + | (Tpackage _, Tpackage _) -> () + | (Tvariant row1, Tvariant row2) -> + mcomp_row type_pairs env row1 row2 + | (Tobject (fi1, _), Tobject (fi2, _)) -> + mcomp_fields type_pairs env fi1 fi2 + | (Tfield _, Tfield _) -> (* Actually unused *) + mcomp_fields type_pairs env t1' t2' + | (Tnil, Tnil) -> + () + | (Tpoly (t1, []), Tpoly (t2, [])) -> + mcomp type_pairs env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + (try + enter_poly env univar_pairs + t1 tl1 t2 tl2 (mcomp type_pairs env) + with Escape _ -> raise Incompatible) + | (Tunivar _, Tunivar _) -> + (try unify_univar t1' t2' !univar_pairs + with Cannot_unify_universal_variables -> raise Incompatible) + | (_, _) -> + raise Incompatible + end + +and mcomp_list type_pairs env tl1 tl2 = + if List.length tl1 <> List.length tl2 then + raise Incompatible; + List.iter2 (mcomp type_pairs env) tl1 tl2 + +and mcomp_fields type_pairs env ty1 ty2 = + if not (concrete_object ty1 && concrete_object ty2) then assert false; + let (fields2, rest2) = flatten_fields ty2 in + let (fields1, rest1) = flatten_fields ty1 in + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let has_present = + List.exists (fun (_, k, _) -> field_kind_repr k = Fpublic) in + mcomp type_pairs env rest1 rest2; + if has_present miss1 && get_desc (object_row ty2) = Tnil + || has_present miss2 && get_desc (object_row ty1) = Tnil + then raise Incompatible; + List.iter + (function (_n, k1, t1, k2, t2) -> + mcomp_kind k1 k2; + mcomp type_pairs env t1 t2) + pairs + +and mcomp_kind k1 k2 = + let k1 = field_kind_repr k1 in + let k2 = field_kind_repr k2 in + match k1, k2 with + (Fpublic, Fabsent) + | (Fabsent, Fpublic) -> raise Incompatible + | _ -> () + +and mcomp_row type_pairs env row1 row2 = + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + let cannot_erase (_,f) = + match row_field_repr f with + Rpresent _ -> true + | Rabsent | Reither _ -> false + in + if row_closed row1 && List.exists cannot_erase r2 + || row_closed row2 && List.exists cannot_erase r1 then raise Incompatible; + List.iter + (fun (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _) | Rabsent) + | Rpresent (Some _), (Rpresent None | Reither (true, _, _) | Rabsent) + | (Reither (_, _::_, _) | Rabsent), Rpresent None + | (Reither (true, _, _) | Rabsent), Rpresent (Some _) -> + raise Incompatible + | Rpresent(Some t1), Rpresent(Some t2) -> + mcomp type_pairs env t1 t2 + | Rpresent(Some t1), Reither(false, tl2, _) -> + List.iter (mcomp type_pairs env t1) tl2 + | Reither(false, tl1, _), Rpresent(Some t2) -> + List.iter (mcomp type_pairs env t2) tl1 + | _ -> ()) + pairs + +and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = + try + let decl = Env.find_type p1 env in + let decl' = Env.find_type p2 env in + if compatible_paths p1 p2 then begin + let inj = + try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance + with Not_found -> List.map (fun _ -> false) tl1 + in + List.iter2 + (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2) + inj (List.combine tl1 tl2) + end else if non_aliasable p1 decl && non_aliasable p2 decl' then + raise Incompatible + else + match decl.type_kind, decl'.type_kind with + | Type_record (lst,r), Type_record (lst',r') when r = r' -> + mcomp_list type_pairs env tl1 tl2; + mcomp_record_description type_pairs env lst lst' + | Type_variant (v1,r), Type_variant (v2,r') when r = r' -> + mcomp_list type_pairs env tl1 tl2; + mcomp_variant_description type_pairs env v1 v2 + | Type_open, Type_open -> + mcomp_list type_pairs env tl1 tl2 + | Type_abstract, Type_abstract -> () + | Type_abstract, _ when not (non_aliasable p1 decl)-> () + | _, Type_abstract when not (non_aliasable p2 decl') -> () + | _ -> raise Incompatible + with Not_found -> () + +and mcomp_type_option type_pairs env t t' = + match t, t' with + None, None -> () + | Some t, Some t' -> mcomp type_pairs env t t' + | _ -> raise Incompatible + +and mcomp_variant_description type_pairs env xs ys = + let rec iter = fun x y -> + match x, y with + | c1 :: xs, c2 :: ys -> + mcomp_type_option type_pairs env c1.cd_res c2.cd_res; + begin match c1.cd_args, c2.cd_args with + | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2 + | Cstr_record l1, Cstr_record l2 -> + mcomp_record_description type_pairs env l1 l2 + | _ -> raise Incompatible + end; + if Ident.name c1.cd_id = Ident.name c2.cd_id + then iter xs ys + else raise Incompatible + | [],[] -> () + | _ -> raise Incompatible + in + iter xs ys + +and mcomp_record_description type_pairs env = + let rec iter x y = + match x, y with + | l1 :: xs, l2 :: ys -> + mcomp type_pairs env l1.ld_type l2.ld_type; + if Ident.name l1.ld_id = Ident.name l2.ld_id && + l1.ld_mutable = l2.ld_mutable + then iter xs ys + else raise Incompatible + | [], [] -> () + | _ -> raise Incompatible + in + iter + +let mcomp env t1 t2 = + mcomp (TypePairs.create 4) env t1 t2 + +let mcomp_for tr_exn env t1 t2 = + try + mcomp env t1 t2 + with Incompatible -> raise_unexplained_for tr_exn + +(* Real unification *) + +let find_lowest_level ty = + let lowest = ref generic_level in + let rec find ty = + if not_marked_node ty then begin + let level = get_level ty in + if level < !lowest then lowest := level; + flip_mark_node ty; + iter_type_expr find ty + end + in find ty; unmark_type ty; !lowest + +let add_gadt_equation env source destination = + (* Format.eprintf "@[add_gadt_equation %s %a@]@." + (Path.name source) !Btype.print_raw destination; *) + if has_free_univars !env destination then + occur_univar ~inj_only:true !env destination + else if local_non_recursive_abbrev !env source destination then begin + let destination = duplicate_type destination in + let expansion_scope = + Int.max (Path.scope source) (get_gadt_equations_level ()) + in + let decl = + new_local_type ~manifest_and_scope:(destination, expansion_scope) () in + env := Env.add_local_type source decl !env; + cleanup_abbrev () + end + +let unify_eq_set = TypePairs.create 11 + +let order_type_pair t1 t2 = + if get_id t1 <= get_id t2 then (t1, t2) else (t2, t1) + +let add_type_equality t1 t2 = + TypePairs.add unify_eq_set (order_type_pair t1 t2) + +let eq_package_path env p1 p2 = + Path.same p1 p2 || + Path.same (normalize_package_path env p1) (normalize_package_path env p2) + +let nondep_type' = ref (fun _ _ _ -> assert false) +let package_subtype = ref (fun _ _ _ _ _ -> assert false) + +exception Nondep_cannot_erase of Ident.t + +let rec concat_longident lid1 = + let open Longident in + function + Lident s -> Ldot (lid1, s) + | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s) + | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid) + +let nondep_instance env level id ty = + let ty = !nondep_type' env [id] ty in + if level = generic_level then duplicate_type ty else + let old = !current_level in + current_level := level; + let ty = instance ty in + current_level := old; + ty + +(* Find the type paths nl1 in the module type mty2, and add them to the + list (nl2, tl2). raise Not_found if impossible *) +let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = + (* This is morally WRONG: we're adding a (dummy) module without a scope in the + environment. However no operation which cares about levels/scopes is going + to happen while this module exists. + The only operations that happen are: + - Env.find_type_by_name + - nondep_instance + None of which check the scope. + + It'd be nice if we avoided creating such temporary dummy modules and broken + environments though. *) + let id2 = Ident.create_local "Pkg" in + let env' = Env.add_module id2 Mp_present mty2 env in + let rec complete fl1 fl2 = + match fl1, fl2 with + [], _ -> fl2 + | (n, _) :: nl, (n2, _ as nt2) :: ntl' when n >= n2 -> + nt2 :: complete (if n = n2 then nl else fl1) ntl' + | (n, _) :: nl, _ -> + let lid = concat_longident (Longident.Lident "Pkg") n in + match Env.find_type_by_name lid env' with + | (_, {type_arity = 0; type_kind = Type_abstract; + type_private = Public; type_manifest = Some t2}) -> + begin match nondep_instance env' lv2 id2 t2 with + | t -> (n, t) :: complete nl fl2 + | exception Nondep_cannot_erase _ -> + if allow_absent then + complete nl fl2 + else + raise Exit + end + | (_, {type_arity = 0; type_kind = Type_abstract; + type_private = Public; type_manifest = None}) + when allow_absent -> + complete nl fl2 + | _ -> raise Exit + | exception Not_found when allow_absent-> + complete nl fl2 + in + match complete fl1 fl2 with + | res -> res + | exception Exit -> raise Not_found + +(* raise Not_found rather than Unify if the module types are incompatible *) +let unify_package env unify_list lv1 p1 fl1 lv2 p2 fl2 = + let ntl2 = complete_type_list env fl1 lv2 (Mty_ident p2) fl2 + and ntl1 = complete_type_list env fl2 lv1 (Mty_ident p1) fl1 in + unify_list (List.map snd ntl1) (List.map snd ntl2); + if eq_package_path env p1 p2 + || !package_subtype env p1 fl1 p2 fl2 + && !package_subtype env p2 fl2 p1 fl1 then () else raise Not_found + + +(* force unification in Reither when one side has a non-conjunctive type *) +let rigid_variants = ref false + +let unify_eq t1 t2 = + eq_type t1 t2 + || (in_pattern_mode () + && TypePairs.mem unify_eq_set (order_type_pair t1 t2)) + +let unify1_var env t1 t2 = + assert (is_Tvar t1); + occur_for Unify env t1 t2; + match occur_univar_for Unify env t2 with + | () -> + begin + try + update_level env (get_level t1) t2; + update_scope (get_scope t1) t2; + with Escape e -> + raise_for Unify (Escape e) + end; + link_type t1 t2; + true + | exception Unify_trace _ when in_pattern_mode () -> + false + +(* Called from unify3 *) +let unify3_var env t1' t2 t2' = + occur_for Unify !env t1' t2; + match occur_univar_for Unify !env t2 with + | () -> link_type t1' t2 + | exception Unify_trace _ when in_pattern_mode () -> + reify env t1'; + reify env t2'; + if can_generate_equations () then begin + occur_univar ~inj_only:true !env t2'; + record_equation t1' t2'; + end + +(* + 1. When unifying two non-abbreviated types, one type is made a link + to the other. When unifying an abbreviated type with a + non-abbreviated type, the non-abbreviated type is made a link to + the other one. When unifying to abbreviated types, these two + types are kept distincts, but they are made to (temporally) + expand to the same type. + 2. Abbreviations with at least one parameter are systematically + expanded. The overhead does not seem too high, and that way + abbreviations where some parameters does not appear in the + expansion, such as ['a t = int], are correctly handled. In + particular, for this example, unifying ['a t] with ['b t] keeps + ['a] and ['b] distincts. (Is it really important ?) + 3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield + ['a t as 'a]. Indeed, the type variable would otherwise be lost. + This problem occurs for abbreviations expanding to a type + variable, but also to many other constrained abbreviations (for + instance, [(< x : 'a > -> unit) t = ]). The solution is + that, if an abbreviation is unified with some subpart of its + parameters, then the parameter actually does not get + abbreviated. It would be possible to check whether some + information is indeed lost, but it probably does not worth it. +*) + +let rec unify (env:Env.t ref) t1 t2 = + (* First step: special cases (optimizations) *) + if unify_eq t1 t2 then () else + let reset_tracing = check_trace_gadt_instances !env in + + try + type_changed := true; + begin match (get_desc t1, get_desc t2) with + (Tvar _, Tconstr _) when deep_occur t1 t2 -> + unify2 env t1 t2 + | (Tconstr _, Tvar _) when deep_occur t2 t1 -> + unify2 env t1 t2 + | (Tvar _, _) -> + if unify1_var !env t1 t2 then () else unify2 env t1 t2 + | (_, Tvar _) -> + if unify1_var !env t2 t1 then () else unify2 env t1 t2 + | (Tunivar _, Tunivar _) -> + unify_univar_for Unify t1 t2 !univar_pairs; + update_level_for Unify !env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) + when Path.same p1 p2 (* && actual_mode !env = Old *) + (* This optimization assumes that t1 does not expand to t2 + (and conversely), so we fall back to the general case + when any of the types has a cached expansion. *) + && not (has_cached_expansion p1 !a1 + || has_cached_expansion p2 !a2) -> + update_level_for Unify !env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + | (Tconstr _, Tconstr _) when Env.has_local_constraints !env -> + unify2_rec env t1 t1 t2 t2 + | _ -> + unify2 env t1 t2 + end; + reset_trace_gadt_instances reset_tracing; + with Unify_trace trace -> + reset_trace_gadt_instances reset_tracing; + raise_trace_for Unify (Diff {got = t1; expected = t2} :: trace) + +and unify2 env t1 t2 = unify2_expand env t1 t1 t2 t2 + +and unify2_rec env t10 t1 t20 t2 = + if unify_eq t1 t2 then () else + try match (get_desc t1, get_desc t2) with + | (Tconstr (p1, tl1, a1), Tconstr (p2, tl2, a2)) -> + if Path.same p1 p2 && tl1 = [] && tl2 = [] + && not (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) + then begin + update_level_for Unify !env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + end else + if find_expansion_scope !env p1 > find_expansion_scope !env p2 + then unify2_rec env t10 t1 t20 (try_expand_safe !env t2) + else unify2_rec env t10 (try_expand_safe !env t1) t20 t2 + | _ -> + raise Cannot_expand + with Cannot_expand -> + unify2_expand env t10 t1 t20 t2 + +and unify2_expand env t1 t1' t2 t2' = + (* Second step: expansion of abbreviations *) + (* Expansion may change the representative of the types. *) + ignore (expand_head_unif !env t1'); + ignore (expand_head_unif !env t2'); + let t1' = expand_head_unif !env t1' in + let t2' = expand_head_unif !env t2' in + let lv = Int.min (get_level t1') (get_level t2') in + let scope = Int.max (get_scope t1') (get_scope t2') in + update_level_for Unify !env lv t2; + update_level_for Unify !env lv t1; + update_scope_for Unify scope t2; + update_scope_for Unify scope t1; + if unify_eq t1' t2' then () else + + let t1, t2 = + if !Clflags.principal + && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then + (* Expand abbreviations hiding a lower level *) + (* Should also do it for parameterized types, after unification... *) + (match get_desc t1 with Tconstr (_, [], _) -> t1' | _ -> t1), + (match get_desc t2 with Tconstr (_, [], _) -> t2' | _ -> t2) + else (t1, t2) + in + if unify_eq t1 t1' || not (unify_eq t2 t2') then + unify3 env t1 t1' t2 t2' + else + try unify3 env t2 t2' t1 t1' with Unify_trace trace -> + raise_trace_for Unify (swap_trace trace) + +and unify3 env t1 t1' t2 t2' = + (* Third step: truly unification *) + (* Assumes either [t1 == t1'] or [t2 != t2'] *) + let tt1' = Transient_expr.repr t1' in + let d1 = tt1'.desc and d2 = get_desc t2' in + let create_recursion = + (not (eq_type t2 t2')) && (deep_occur t1' t2) in + + begin match (d1, d2) with (* handle vars and univars specially *) + (Tunivar _, Tunivar _) -> + unify_univar_for Unify t1' t2' !univar_pairs; + link_type t1' t2' + | (Tvar _, _) -> + unify3_var env t1' t2 t2' + | (_, Tvar _) -> + unify3_var env t2' t1 t1' + | (Tfield _, Tfield _) -> (* special case for GADTs *) + unify_fields env t1' t2' + | _ -> + if in_pattern_mode () then + add_type_equality t1' t2' + else begin + occur_for Unify !env t1' t2; + link_type t1' t2 + end; + try + begin match (d1, d2) with + (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 || + (!Clflags.classic || in_pattern_mode ()) && + not (is_optional l1 || is_optional l2) -> + unify env t1 t2; unify env u1 u2; + begin match is_commu_ok c1, is_commu_ok c2 with + | false, true -> set_commu_ok c1 + | true, false -> set_commu_ok c2 + | false, false -> link_commu ~inside:c1 c2 + | true, true -> () + end + | (Ttuple tl1, Ttuple tl2) -> + unify_list env tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> + if not (can_generate_equations ()) then + unify_list env tl1 tl2 + else if can_assume_injective () then + without_assume_injective (fun () -> unify_list env tl1 tl2) + else if in_current_module p1 (* || in_pervasives p1 *) + || List.exists (expands_to_datatype !env) [t1'; t1; t2] + then + unify_list env tl1 tl2 + else + let inj = + try List.map Variance.(mem Inj) + (Env.find_type p1 !env).type_variance + with Not_found -> List.map (fun _ -> false) tl1 + in + List.iter2 + (fun i (t1, t2) -> + if i then unify env t1 t2 else + without_generating_equations + begin fun () -> + let snap = snapshot () in + try unify env t1 t2 with Unify_trace _ -> + backtrack snap; + reify env t1; + reify env t2 + end) + inj (List.combine tl1 tl2) + | (Tconstr (path,[],_), + Tconstr (path',[],_)) + when is_instantiable !env path && is_instantiable !env path' + && can_generate_equations () -> + let source, destination = + if Path.scope path > Path.scope path' + then path , t2' + else path', t1' + in + record_equation t1' t2'; + add_gadt_equation env source destination + | (Tconstr (path,[],_), _) + when is_instantiable !env path && can_generate_equations () -> + reify env t2'; + record_equation t1' t2'; + add_gadt_equation env path t2' + | (_, Tconstr (path,[],_)) + when is_instantiable !env path && can_generate_equations () -> + reify env t1'; + record_equation t1' t2'; + add_gadt_equation env path t1' + | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when in_pattern_mode () -> + reify env t1'; + reify env t2'; + if can_generate_equations () then ( + mcomp_for Unify !env t1' t2'; + record_equation t1' t2' + ) + | (Tobject (fi1, nm1), Tobject (fi2, _)) -> + unify_fields env fi1 fi2; + (* Type [t2'] may have been instantiated by [unify_fields] *) + (* XXX One should do some kind of unification... *) + begin match get_desc t2' with + Tobject (_, {contents = Some (_, va::_)}) when + (match get_desc va with + Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () + | Tobject (_, nm2) -> set_name nm2 !nm1 + | _ -> () + end + | (Tvariant row1, Tvariant row2) -> + if not (in_pattern_mode ()) then + unify_row env row1 row2 + else begin + let snap = snapshot () in + try unify_row env row1 row2 + with Unify_trace _ -> + backtrack snap; + reify env t1'; + reify env t2'; + if can_generate_equations () then ( + mcomp_for Unify !env t1' t2'; + record_equation t1' t2' + ) + end + | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) -> + begin match field_kind_repr kind with + Fprivate when f <> dummy_method -> + link_kind ~inside:kind field_absent; + if d2 = Tnil then unify env rem t2' + else unify env (newgenty Tnil) rem + | _ -> + if f = dummy_method then + raise_for Unify (Obj Self_cannot_be_closed) + else if d1 = Tnil then + raise_for Unify (Obj (Missing_field(First, f))) + else + raise_for Unify (Obj (Missing_field(Second, f))) + end + | (Tnil, Tnil) -> + () + | (Tpoly (t1, []), Tpoly (t2, [])) -> + unify env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly_for Unify !env univar_pairs t1 tl1 t2 tl2 (unify env) + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> + begin try + unify_package !env (unify_list env) + (get_level t1) p1 fl1 (get_level t2) p2 fl2 + with Not_found -> + if not (in_pattern_mode ()) then raise_unexplained_for Unify; + List.iter (fun (_n, ty) -> reify env ty) (fl1 @ fl2); + (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) + end + | (Tnil, Tconstr _ ) -> + raise_for Unify (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> + raise_for Unify (Obj (Abstract_row First)) + | (_, _) -> raise_unexplained_for Unify + end; + (* XXX Commentaires + changer "create_recursion" + ||| Comments + change "create_recursion" *) + if create_recursion then + match get_desc t2 with + Tconstr (p, tl, abbrev) -> + forget_abbrev abbrev p; + let t2'' = expand_head_unif !env t2 in + if not (closed_parameterized_type tl t2'') then + link_type t2 t2' + | _ -> + () (* t2 has already been expanded by update_level *) + with Unify_trace trace -> + Transient_expr.set_desc tt1' d1; + raise_trace_for Unify trace + end + +and unify_list env tl1 tl2 = + if List.length tl1 <> List.length tl2 then + raise_unexplained_for Unify; + List.iter2 (unify env) tl1 tl2 + +(* Build a fresh row variable for unification *) +and make_rowvar level use1 rest1 use2 rest2 = + let set_name ty name = + match get_desc ty with + Tvar None -> set_type_desc ty (Tvar name) + | _ -> () + in + let name = + match get_desc rest1, get_desc rest2 with + Tvar (Some _ as name1), Tvar (Some _ as name2) -> + if get_level rest1 <= get_level rest2 then name1 else name2 + | Tvar (Some _ as name), _ -> + if use2 then set_name rest2 name; name + | _, Tvar (Some _ as name) -> + if use1 then set_name rest2 name; name + | _ -> None + in + if use1 then rest1 else + if use2 then rest2 else newty2 ~level (Tvar name) + +and unify_fields env ty1 ty2 = (* Optimization *) + let (fields1, rest1) = flatten_fields ty1 + and (fields2, rest2) = flatten_fields ty2 in + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let l1 = get_level ty1 and l2 = get_level ty2 in + let va = make_rowvar (Int.min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in + let tr1 = Transient_expr.repr rest1 and tr2 = Transient_expr.repr rest2 in + let d1 = tr1.desc and d2 = tr2.desc in + try + unify env (build_fields l1 miss1 va) rest2; + unify env rest1 (build_fields l2 miss2 va); + List.iter + (fun (name, k1, t1, k2, t2) -> + unify_kind k1 k2; + try + if !trace_gadt_instances && not (in_subst_mode ()) then begin + (* in_subst_mode: see PR#11771 *) + update_level_for Unify !env (get_level va) t1; + update_scope_for Unify (get_scope va) t1 + end; + unify env t1 t2 + with Unify_trace trace -> + raise_trace_for Unify + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) + ) + pairs + with exn -> + Transient_expr.set_desc tr1 d1; + Transient_expr.set_desc tr2 d2; + raise exn + +and unify_kind k1 k2 = + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fprivate) -> link_kind ~inside:k2 k1 + | (Fpublic, Fpublic) -> () + | _ -> assert false + +and unify_row env row1 row2 = + let Row {fields = row1_fields; more = rm1; + closed = row1_closed; name = row1_name} = row_repr row1 in + let Row {fields = row2_fields; more = rm2; + closed = row2_closed; name = row2_name} = row_repr row2 in + if unify_eq rm1 rm2 then () else + let r1, r2, pairs = merge_row_fields row1_fields row2_fields in + if r1 <> [] && r2 <> [] then begin + let ht = Hashtbl.create (List.length r1) in + List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1; + List.iter + (fun (l,_) -> + try raise (Tags(l, Hashtbl.find ht (hash_variant l))) + with Not_found -> ()) + r2 + end; + let fixed1 = fixed_explanation row1 and fixed2 = fixed_explanation row2 in + let more = match fixed1, fixed2 with + | Some _, Some _ -> if get_level rm2 < get_level rm1 then rm2 else rm1 + | Some _, None -> rm1 + | None, Some _ -> rm2 + | None, None -> + newty2 ~level:(Int.min (get_level rm1) (get_level rm2)) (Tvar None) + in + let fixed = merge_fixed_explanation fixed1 fixed2 + and closed = row1_closed || row2_closed in + let keep switch = + List.for_all + (fun (_,f1,f2) -> + let f1, f2 = switch f1 f2 in + row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent) + pairs + in + let empty fields = + List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in + (* Check whether we are going to build an empty type *) + if closed && (empty r1 || row2_closed) && (empty r2 || row1_closed) + && List.for_all + (fun (_,f1,f2) -> + row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent) + pairs + then raise_for Unify (Variant No_intersection); + let name = + if row1_name <> None && (row1_closed || empty r2) && + (not row2_closed || keep (fun f1 f2 -> f1, f2) && empty r1) + then row1_name + else if row2_name <> None && (row2_closed || empty r1) && + (not row1_closed || keep (fun f1 f2 -> f2, f1) && empty r2) + then row2_name + else None + in + let set_more pos row rest = + let rest = + if closed then + filter_row_fields (row_closed row) rest + else rest in + begin match fixed_explanation row with + | None -> + if rest <> [] && row_closed row then + raise_for Unify (Variant (No_tags(pos,rest))) + | Some fixed -> + if closed && not (row_closed row) then + raise_for Unify (Variant (Fixed_row(pos,Cannot_be_closed,fixed))) + else if rest <> [] then + let case = Cannot_add_tags (List.map fst rest) in + raise_for Unify (Variant (Fixed_row(pos,case,fixed))) + end; + (* The following test is not principal... should rather use Tnil *) + let rm = row_more row in + (*if !trace_gadt_instances && rm.desc = Tnil then () else*) + if !trace_gadt_instances && not (in_subst_mode ()) then + (* in_subst_mode: see PR#11771 *) + update_level_for Unify !env (get_level rm) (newgenty (Tvariant row)); + if has_fixed_explanation row then + if eq_type more rm then () else + if is_Tvar rm then link_type rm more else unify env rm more + else + let ty = + newgenty (Tvariant + (create_row ~fields:rest ~more ~closed ~fixed ~name)) + in + update_level_for Unify !env (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty; + link_type rm ty + in + let tm1 = Transient_expr.repr rm1 and tm2 = Transient_expr.repr rm2 in + let md1 = tm1.desc and md2 = tm2.desc in + begin try + set_more Second row2 r1; + set_more First row1 r2; + List.iter + (fun (l,f1,f2) -> + try unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 + with Unify_trace trace -> + raise_trace_for Unify (Variant (Incompatible_types_for l) :: trace) + ) + pairs; + if static_row row1 then begin + let rm = row_more row1 in + if is_Tvar rm then link_type rm (newty2 ~level:(get_level rm) Tnil) + end + with exn -> + Transient_expr.set_desc tm1 md1; + Transient_expr.set_desc tm2 md2; + raise exn + end + +and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = + let if_not_fixed (pos,fixed) f = + match fixed with + | None -> f () + | Some fix -> + let tr = [Variant(Fixed_row(pos,Cannot_add_tags [l],fix))] in + raise_trace_for Unify tr in + let first = First, fixed1 and second = Second, fixed2 in + let either_fixed = match fixed1, fixed2 with + | None, None -> false + | _ -> true in + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 + | Rpresent None, Rpresent None -> () + | Reither(c1, tl1, m1), Reither(c2, tl2, m2) -> + if eq_row_field_ext f1 f2 then () else + let no_arg = c1 || c2 and matched = m1 || m2 in + if either_fixed && not no_arg + && List.length tl1 = List.length tl2 then begin + (* PR#7496 *) + let f = rf_either [] ~no_arg ~matched in + link_row_field_ext ~inside:f1 f; link_row_field_ext ~inside:f2 f; + List.iter2 (unify env) tl1 tl2 + end + else let redo = + (m1 || m2 || either_fixed || + !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && + begin match tl1 @ tl2 with [] -> false + | t1 :: tl -> + if no_arg then raise_unexplained_for Unify; + Types.changed_row_field_exts [f1;f2] (fun () -> + List.iter (unify env t1) tl + ) + end in + if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else + let remq tl = + List.filter (fun ty -> not (List.exists (eq_type ty) tl)) in + let tl1' = remq tl2 tl1 and tl2' = remq tl1 tl2 in + (* PR#6744 *) + let (tlu1,tl1') = List.partition (has_free_univars !env) tl1' + and (tlu2,tl2') = List.partition (has_free_univars !env) tl2' in + begin match tlu1, tlu2 with + [], [] -> () + | (tu1::tlu1), _ :: _ -> + (* Attempt to merge all the types containing univars *) + List.iter (unify env tu1) (tlu1@tlu2) + | (tu::_, []) | ([], tu::_) -> + occur_univar_for Unify !env tu + end; + (* Is this handling of levels really principal? *) + let update_levels rm = + List.iter + (fun ty -> + update_level_for Unify !env (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty) + in + update_levels rm2 tl1'; + update_levels rm1 tl2'; + let f1' = rf_either tl2' ~no_arg ~matched in + let f2' = rf_either tl1' ~use_ext_of:f1' ~no_arg ~matched in + link_row_field_ext ~inside:f1 f1'; link_row_field_ext ~inside:f2 f2'; + | Reither(_, _, false), Rabsent -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rabsent, Reither(_, _, false) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | Rabsent, Rabsent -> () + | Reither(false, tl, _), Rpresent(Some t2) -> + if_not_fixed first (fun () -> + let s = snapshot () in + link_row_field_ext ~inside:f1 f2; + update_level_for Unify !env (get_level rm1) t2; + update_scope_for Unify (get_scope rm1) t2; + (try List.iter (fun t1 -> unify env t1 t2) tl + with exn -> undo_first_change_after s; raise exn) + ) + | Rpresent(Some t1), Reither(false, tl, _) -> + if_not_fixed second (fun () -> + let s = snapshot () in + link_row_field_ext ~inside:f2 f1; + update_level_for Unify !env (get_level rm2) t1; + update_scope_for Unify (get_scope rm2) t1; + (try List.iter (unify env t1) tl + with exn -> undo_first_change_after s; raise exn) + ) + | Reither(true, [], _), Rpresent None -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rpresent None, Reither(true, [], _) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | _ -> raise_unexplained_for Unify + +let unify env ty1 ty2 = + let snap = Btype.snapshot () in + try + unify env ty1 ty2 + with + Unify_trace trace -> + undo_compress snap; + raise (Unify (expand_to_unification_error !env trace)) + +let unify_gadt ~equations_level:lev ~allow_recursive_equations + (env:Env.t ref) ty1 ty2 = + try + univar_pairs := []; + gadt_equations_level := Some lev; + let equated_types = TypePairs.create 0 in + set_mode_pattern ~allow_recursive_equations ~equated_types + (fun () -> unify env ty1 ty2); + gadt_equations_level := None; + TypePairs.clear unify_eq_set; + equated_types + with e -> + gadt_equations_level := None; + TypePairs.clear unify_eq_set; + raise e + +let unify_var env t1 t2 = + if eq_type t1 t2 then () else + match get_desc t1, get_desc t2 with + Tvar _, Tconstr _ when deep_occur t1 t2 -> + unify (ref env) t1 t2 + | Tvar _, _ -> + let reset_tracing = check_trace_gadt_instances env in + begin try + occur_for Unify env t1 t2; + update_level_for Unify env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2; + reset_trace_gadt_instances reset_tracing; + with Unify_trace trace -> + reset_trace_gadt_instances reset_tracing; + raise (Unify (expand_to_unification_error + env + (Diff { got = t1; expected = t2 } :: trace))) + end + | _ -> + unify (ref env) t1 t2 + +let _ = unify_var' := unify_var + +let unify_pairs env ty1 ty2 pairs = + univar_pairs := pairs; + unify env ty1 ty2 + +let unify env ty1 ty2 = + unify_pairs (ref env) ty1 ty2 [] + +(* Lower the level of a type to the current level *) +let enforce_current_level env ty = unify_var env (newvar ()) ty + + +(**** Special cases of unification ****) + +let expand_head_trace env t = + let reset_tracing = check_trace_gadt_instances env in + let t = expand_head_unif env t in + reset_trace_gadt_instances reset_tracing; + t + +(* + Unify [t] and [l:'a -> 'b]. Return ['a] and ['b]. + In [-nolabels] mode, label mismatch is accepted when + (1) the requested label is "" + (2) the original label is not optional +*) + +type filter_arrow_failure = + | Unification_error of unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +let filter_arrow env t l = + let function_type level = + let t1 = newvar2 level and t2 = newvar2 level in + let t' = newty2 ~level (Tarrow (l, t1, t2, commu_ok)) in + t', t1, t2 + in + let t = + try expand_head_trace env t + with Unify_trace trace -> + let t', _, _ = function_type (get_level t) in + raise (Filter_arrow_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = t'; expected = t } :: trace)))) + in + match get_desc t with + | Tvar _ -> + let t', t1, t2 = function_type (get_level t) in + link_type t t'; + (t1, t2) + | Tarrow(l', t1, t2, _) -> + if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') + then (t1, t2) + else raise (Filter_arrow_failed + (Label_mismatch + { got = l; expected = l'; expected_type = t })) + | _ -> + raise (Filter_arrow_failed Not_a_function) + +type filter_method_failure = + | Unification_error of unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + +(* Used by [filter_method]. *) +let rec filter_method_field env name ty = + let method_type ~level = + let ty1 = newvar2 level and ty2 = newvar2 level in + let ty' = newty2 ~level (Tfield (name, field_public, ty1, ty2)) in + ty', ty1 + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let ty', _ = method_type ~level in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let ty', ty1 = method_type ~level in + link_type ty ty'; + ty1 + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + unify_kind kind field_public; + ty1 + end else + filter_method_field env name ty2 + | _ -> + raise (Filter_method_failed Not_a_method) + +(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) +let filter_method env name ty = + let object_type ~level ~scope = + let ty1 = newvar2 level in + let ty' = newty3 ~level ~scope (Tobject (ty1, ref None)) in + let ty_meth = filter_method_field env name ty1 in + (ty', ty_meth) + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let scope = get_scope ty in + let ty', _ = object_type ~level ~scope in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let scope = get_scope ty in + let ty', ty_meth = object_type ~level ~scope in + link_type ty ty'; + ty_meth + | Tobject(f, _) -> + filter_method_field env name f + | _ -> + raise (Filter_method_failed (Not_an_object ty)) + +exception Filter_method_row_failed + +let rec filter_method_row env name priv ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let field = newvar2 level in + let row = newvar2 level in + let kind, priv = + match priv with + | Private -> + let kind = field_private () in + kind, Mprivate kind + | Public -> + field_public, Mpublic + in + let ty' = newty2 ~level (Tfield (name, kind, field, row)) in + link_type ty ty'; + priv, field, row + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + let priv = + match priv with + | Public -> + unify_kind kind field_public; + Mpublic + | Private -> Mprivate kind + in + priv, ty1, ty2 + end else begin + let level = get_level ty in + let priv, field, row = filter_method_row env name priv ty2 in + let row = newty2 ~level (Tfield (n, kind, ty1, row)) in + priv, field, row + end + | Tnil -> + if name = Btype.dummy_method then raise Filter_method_row_failed + else begin + match priv with + | Public -> raise Filter_method_row_failed + | Private -> + let level = get_level ty in + let kind = field_absent in + Mprivate kind, newvar2 level, ty + end + | _ -> + raise Filter_method_row_failed + +(* Operations on class signatures *) + +let new_class_signature () = + let row = newvar () in + let self = newobj row in + { csig_self = self; + csig_self_row = row; + csig_vars = Vars.empty; + csig_meths = Meths.empty; } + +let add_dummy_method env ~scope sign = + let _, ty, row = + filter_method_row env dummy_method Private sign.csig_self_row + in + unify env ty (new_scoped_ty scope (Ttuple [])); + sign.csig_self_row <- row + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +let add_method env label priv virt ty sign = + let meths = sign.csig_meths in + let priv, virt = + match Meths.find label meths with + | (priv', virt', ty') -> begin + let priv = + match priv' with + | Mpublic -> Mpublic + | Mprivate k -> + match priv with + | Public -> + begin match field_kind_repr k with + | Fpublic -> () + | Fprivate -> link_kind ~inside:k field_public + | Fabsent -> assert false + end; + Mpublic + | Private -> priv' + in + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + match unify env ty ty' with + | () -> priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + | exception Not_found -> begin + let priv, ty', row = + match filter_method_row env label priv sign.csig_self_row with + | priv, ty', row -> + priv, ty', row + | exception Filter_method_row_failed -> + raise (Add_method_failed Unexpected_method) + in + match unify env ty ty' with + | () -> + sign.csig_self_row <- row; + priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + in + let meths = Meths.add label (priv, virt, ty) meths in + sign.csig_meths <- meths + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +let check_mutability mut mut' = + match mut, mut' with + | Mutable, Mutable -> () + | Immutable, Immutable -> () + | Mutable, Immutable | Immutable, Mutable -> + raise (Add_instance_variable_failed (Mutability_mismatch mut)) + +let add_instance_variable ~strict env label mut virt ty sign = + let vars = sign.csig_vars in + let virt = + match Vars.find label vars with + | (mut', virt', ty') -> + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + if strict then begin + check_mutability mut mut'; + match unify env ty ty' with + | () -> () + | exception Unify trace -> + raise (Add_instance_variable_failed (Type_mismatch trace)) + end; + virt + | exception Not_found -> virt + in + let vars = Vars.add label (mut, virt, ty) vars in + sign.csig_vars <- vars + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +let unify_self_types env sign1 sign2 = + let self_type1 = sign1.csig_self in + let self_type2 = sign2.csig_self in + match unify env self_type1 self_type2 with + | () -> () + | exception Unify err -> begin + match err.trace with + | Errortrace.Diff _ :: Errortrace.Incompatible_fields {name; _} :: rem -> + let err = Errortrace.unification_error ~trace:rem in + let failure = Method (name, Type_mismatch err) in + raise (Inherit_class_signature_failed failure) + | _ -> + raise (Inherit_class_signature_failed (Self_type_mismatch err)) + end + +(* Unify components of sign2 into sign1 *) +let inherit_class_signature ~strict env sign1 sign2 = + unify_self_types env sign1 sign2; + Meths.iter + (fun label (priv, virt, ty) -> + let priv = + match priv with + | Mpublic -> Public + | Mprivate kind -> + assert (field_kind_repr kind = Fabsent); + Private + in + match add_method env label priv virt ty sign1 with + | () -> () + | exception Add_method_failed failure -> + let failure = Method(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_meths; + Vars.iter + (fun label (mut, virt, ty) -> + match add_instance_variable ~strict env label mut virt ty sign1 with + | () -> () + | exception Add_instance_variable_failed failure -> + let failure = Instance_variable(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_vars + +let update_class_signature env sign = + let self = expand_head env sign.Types.csig_self in + let fields, row = flatten_fields (object_fields self) in + let meths, implicitly_public, implicitly_declared = + List.fold_left + (fun (meths, implicitly_public, implicitly_declared) (lab, k, ty) -> + if lab = dummy_method then + meths, implicitly_public, implicitly_declared + else begin + match Meths.find lab meths with + | priv, virt, ty' -> + let meths, implicitly_public = + match priv, field_kind_repr k with + | Mpublic, _ -> meths, implicitly_public + | Mprivate _, Fpublic -> + let meths = Meths.add lab (Mpublic, virt, ty') meths in + let implicitly_public = lab :: implicitly_public in + meths, implicitly_public + | Mprivate _, _ -> meths, implicitly_public + in + meths, implicitly_public, implicitly_declared + | exception Not_found -> + let meths, implicitly_declared = + match field_kind_repr k with + | Fpublic -> + let meths = Meths.add lab (Mpublic, Virtual, ty) meths in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fprivate -> + let meths = + Meths.add lab (Mprivate k, Virtual, ty) meths + in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fabsent -> meths, implicitly_declared + in + meths, implicitly_public, implicitly_declared + end) + (sign.csig_meths, [], []) fields + in + sign.csig_meths <- meths; + sign.csig_self_row <- row; + implicitly_public, implicitly_declared + +let hide_private_methods env sign = + let self = expand_head env sign.Types.csig_self in + let fields, _ = flatten_fields (object_fields self) in + List.iter + (fun (_, k, _) -> + match field_kind_repr k with + | Fprivate -> link_kind ~inside:k field_absent + | _ -> ()) + fields + +let close_class_signature env sign = + let rec close env ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + link_type ty (newty2 ~level Tnil); true + | Tfield(lab, _, _, _) when lab = dummy_method -> + false + | Tfield(_, _, _, ty') -> close env ty' + | Tnil -> true + | _ -> assert false + in + let self = expand_head env sign.csig_self in + close env (object_fields self) + +let generalize_class_signature_spine env sign = + (* Generalize the spine of methods *) + let meths = sign.csig_meths in + Meths.iter (fun _ (_, _, ty) -> generalize_spine ty) meths; + let new_meths = + Meths.map + (fun (priv, virt, ty) -> (priv, virt, generic_instance ty)) + meths + in + (* But keep levels correct on the type of self *) + Meths.iter + (fun _ (_, _, ty) -> unify_var env (newvar ()) ty) + meths; + sign.csig_meths <- new_meths + + (***********************************) + (* Matching between type schemes *) + (***********************************) + +(* + Update the level of [ty]. First check that the levels of generic + variables from the subject are not lowered. +*) +let moregen_occur env level ty = + let rec occur ty = + let lv = get_level ty in + if lv <= level then () else + if is_Tvar ty && lv >= generic_level - 1 then raise Occur else + if try_mark_node ty then iter_type_expr occur ty + in + begin try + occur ty; unmark_type ty + with Occur -> + unmark_type ty; raise_unexplained_for Moregen + end; + (* also check for free univars *) + occur_univar_for Moregen env ty; + update_level_for Moregen env level ty + +let may_instantiate inst_nongen t1 = + let level = get_level t1 in + if inst_nongen then level <> generic_level - 1 + else level = generic_level + +let rec moregen inst_nongen type_pairs env t1 t2 = + if eq_type t1 t2 then () else + + try + match (get_desc t1, get_desc t2) with + (Tvar _, _) when may_instantiate inst_nongen t1 -> + moregen_occur env (get_level t1) t2; + update_scope_for Moregen (get_scope t1) t2; + occur_for Moregen env t1 t2; + link_type t1 t2 + | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> + () + | _ -> + let t1' = expand_head env t1 in + let t2' = expand_head env t2 in + (* Expansion may have changed the representative of the types... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, _) when may_instantiate inst_nongen t1' -> + moregen_occur env (get_level t1') t2; + update_scope_for Moregen (get_scope t1') t2; + link_type t1' t2 + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 + || !Clflags.classic && not (is_optional l1 || is_optional l2) -> + moregen inst_nongen type_pairs env t1 t2; + moregen inst_nongen type_pairs env u1 u2 + | (Ttuple tl1, Ttuple tl2) -> + moregen_list inst_nongen type_pairs env tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) + when Path.same p1 p2 -> + moregen_list inst_nongen type_pairs env tl1 tl2 + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> + begin try + unify_package env (moregen_list inst_nongen type_pairs env) + (get_level t1') p1 fl1 (get_level t2') p2 fl2 + with Not_found -> raise_unexplained_for Moregen + end + | (Tnil, Tconstr _ ) -> raise_for Moregen (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> raise_for Moregen (Obj (Abstract_row First)) + | (Tvariant row1, Tvariant row2) -> + moregen_row inst_nongen type_pairs env row1 row2 + | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> + moregen_fields inst_nongen type_pairs env fi1 fi2 + | (Tfield _, Tfield _) -> (* Actually unused *) + moregen_fields inst_nongen type_pairs env + t1' t2' + | (Tnil, Tnil) -> + () + | (Tpoly (t1, []), Tpoly (t2, [])) -> + moregen inst_nongen type_pairs env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly_for Moregen env univar_pairs t1 tl1 t2 tl2 + (moregen inst_nongen type_pairs env) + | (Tunivar _, Tunivar _) -> + unify_univar_for Moregen t1' t2' !univar_pairs + | (_, _) -> + raise_unexplained_for Moregen + end + with Moregen_trace trace -> + raise_trace_for Moregen (Diff {got = t1; expected = t2} :: trace) + + +and moregen_list inst_nongen type_pairs env tl1 tl2 = + if List.length tl1 <> List.length tl2 then + raise_unexplained_for Moregen; + List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 + +and moregen_fields inst_nongen type_pairs env ty1 ty2 = + let (fields1, rest1) = flatten_fields ty1 + and (fields2, rest2) = flatten_fields ty2 in + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + begin + match miss1 with + | (n, _, _) :: _ -> raise_for Moregen (Obj (Missing_field (Second, n))) + | [] -> () + end; + moregen inst_nongen type_pairs env rest1 + (build_fields (get_level ty2) miss2 rest2); + List.iter + (fun (name, k1, t1, k2, t2) -> + (* The below call should never throw [Public_method_to_private_method] *) + moregen_kind k1 k2; + try moregen inst_nongen type_pairs env t1 t2 with Moregen_trace trace -> + raise_trace_for Moregen + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) + ) + pairs + +and moregen_kind k1 k2 = + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fpublic) -> () + | (Fpublic, Fprivate) -> raise Public_method_to_private_method + | (Fabsent, _) | (_, Fabsent) -> assert false + +and moregen_row inst_nongen type_pairs env row1 row2 = + let Row {fields = row1_fields; more = rm1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = rm2; closed = row2_closed; + fixed = row2_fixed} = row_repr row2 in + if eq_type rm1 rm2 then () else + let may_inst = + is_Tvar rm1 && may_instantiate inst_nongen rm1 || get_desc rm1 = Tnil in + let r1, r2, pairs = merge_row_fields row1_fields row2_fields in + let r1, r2 = + if row2_closed then + filter_row_fields may_inst r1, filter_row_fields false r2 + else r1, r2 + in + begin + if r1 <> [] then raise_for Moregen (Variant (No_tags (Second, r1))) + end; + if row1_closed then begin + match row2_closed, r2 with + | false, _ -> raise_for Moregen (Variant (Openness Second)) + | _, _ :: _ -> raise_for Moregen (Variant (No_tags (First, r2))) + | _, [] -> () + end; + let md1 = get_desc rm1 (* This lets us undo a following [link_type] *) in + begin match md1, get_desc rm2 with + Tunivar _, Tunivar _ -> + unify_univar_for Moregen rm1 rm2 !univar_pairs + | Tunivar _, _ | _, Tunivar _ -> + raise_unexplained_for Moregen + | _ when static_row row1 -> () + | _ when may_inst -> + let ext = + newgenty (Tvariant + (create_row ~fields:r2 ~more:rm2 ~name:None + ~fixed:row2_fixed ~closed:row2_closed)) + in + moregen_occur env (get_level rm1) ext; + update_scope_for Moregen (get_scope rm1) ext; + (* This [link_type] has to be undone if the rest of the function fails *) + link_type rm1 ext + | Tconstr _, Tconstr _ -> + moregen inst_nongen type_pairs env rm1 rm2 + | _ -> raise_unexplained_for Moregen + end; + try + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + moregen inst_nongen type_pairs env t1 t2 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both [Reither] *) + | Reither(c1, tl1, _), Reither(c2, tl2, m2) -> begin + try + if not (eq_row_field_ext f1 f2) then begin + if c1 && not c2 then raise_unexplained_for Moregen; + let f2' = + rf_either [] ~use_ext_of:f2 ~no_arg:c2 ~matched:m2 in + link_row_field_ext ~inside:f1 f2'; + if List.length tl1 = List.length tl2 then + List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 + else match tl2 with + | t2 :: _ -> + List.iter + (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 + | [] -> if tl1 <> [] then raise_unexplained_for Moregen + end + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + (* Generalizing [Reither] *) + | Reither(false, tl1, _), Rpresent(Some t2) when may_inst -> begin + try + link_row_field_ext ~inside:f1 f2; + List.iter + (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Reither(true, [], _), Rpresent None when may_inst -> + link_row_field_ext ~inside:f1 f2 + | Reither(_, _, _), Rabsent when may_inst -> + link_row_field_ext ~inside:f1 f2 + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) -> + raise_for Moregen (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Moregen (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Moregen (Variant (No_tags (Second, [l, f1])))) + pairs + with exn -> + (* Undo [link_type] if we failed *) + set_type_desc rm1 md1; raise exn + +(* Must empty univar_pairs first *) +let moregen inst_nongen type_pairs env patt subj = + univar_pairs := []; + moregen inst_nongen type_pairs env patt subj + +(* + Non-generic variable can be instantiated only if [inst_nongen] is + true. So, [inst_nongen] should be set to false if the subject might + contain non-generic variables (and we do not want them to be + instantiated). + Usually, the subject is given by the user, and the pattern + is unimportant. So, no need to propagate abbreviations. +*) +let moregeneral env inst_nongen pat_sch subj_sch = + let old_level = !current_level in + current_level := generic_level - 1; + (* + Generic variables are first duplicated with [instance]. So, + their levels are lowered to [generic_level - 1]. The subject is + then copied with [duplicate_type]. That way, its levels won't be + changed. + *) + let subj_inst = instance subj_sch in + let subj = duplicate_type subj_inst in + current_level := generic_level; + (* Duplicate generic variables *) + let patt = instance pat_sch in + + Misc.try_finally + (fun () -> + try + moregen inst_nongen (TypePairs.create 13) env patt subj + with Moregen_trace trace -> + (* Moregen splits the generic level into two finer levels: + [generic_level] and [generic_level - 1]. In order to properly + detect and print weak variables when printing this error, we need to + merge them back together, by regeneralizing the levels of the types + after they were instantiated at [generic_level - 1] above. Because + [moregen] does some unification that we need to preserve for more + legible error messages, we have to manually perform the + regeneralization rather than backtracking. *) + current_level := generic_level - 2; + generalize subj_inst; + raise (Moregen (expand_to_moregen_error env trace))) + ~always:(fun () -> current_level := old_level) + +let is_moregeneral env inst_nongen pat_sch subj_sch = + match moregeneral env inst_nongen pat_sch subj_sch with + | () -> true + | exception Moregen _ -> false + +(* Alternative approach: "rigidify" a type scheme, + and check validity after unification *) +(* Simpler, no? *) + +let rec rigidify_rec vars ty = + if try_mark_node ty then + begin match get_desc ty with + | Tvar _ -> + if not (TypeSet.mem ty !vars) then vars := TypeSet.add ty !vars + | Tvariant row -> + let Row {more; name; closed} = row_repr row in + if is_Tvar more && not (has_fixed_explanation row) then begin + let more' = newty2 ~level:(get_level more) (get_desc more) in + let row' = + create_row ~fixed:(Some Rigid) ~fields:[] ~more:more' + ~name ~closed + in link_type more (newty2 ~level:(get_level ty) (Tvariant row')) + end; + iter_row (rigidify_rec vars) row; + (* only consider the row variable if the variant is not static *) + if not (static_row row) then + rigidify_rec vars (row_more row) + | _ -> + iter_type_expr (rigidify_rec vars) ty + end + +let rigidify ty = + let vars = ref TypeSet.empty in + rigidify_rec vars ty; + unmark_type ty; + TypeSet.elements !vars + +let all_distinct_vars env vars = + let tys = ref TypeSet.empty in + List.for_all + (fun ty -> + let ty = expand_head env ty in + if TypeSet.mem ty !tys then false else + (tys := TypeSet.add ty !tys; is_Tvar ty)) + vars + +let matches ~expand_error_trace env ty ty' = + let snap = snapshot () in + let vars = rigidify ty in + cleanup_abbrev (); + match unify env ty ty' with + | () -> + if not (all_distinct_vars env vars) then begin + backtrack snap; + let diff = + if expand_error_trace + then expanded_diff env ~got:ty ~expected:ty' + else unexpanded_diff ~got:ty ~expected:ty' + in + raise (Matches_failure (env, unification_error ~trace:[diff])) + end; + backtrack snap + | exception Unify err -> + backtrack snap; + raise (Matches_failure (env, err)) + +let does_match env ty ty' = + match matches ~expand_error_trace:false env ty ty' with + | () -> true + | exception Matches_failure (_, _) -> false + + (*********************************************) + (* Equivalence between parameterized types *) + (*********************************************) + +let expand_head_rigid env ty = + let old = !rigid_variants in + rigid_variants := true; + let ty' = expand_head env ty in + rigid_variants := old; ty' + +let eqtype_subst type_pairs subst t1 t2 = + if List.exists + (fun (t,t') -> + let found1 = eq_type t1 t in + let found2 = eq_type t2 t' in + if found1 && found2 then true else + if found1 || found2 then raise_unexplained_for Equality else false) + !subst + then () + else begin + subst := (t1, t2) :: !subst; + TypePairs.add type_pairs (t1, t2) + end + +let rec eqtype rename type_pairs subst env t1 t2 = + if eq_type t1 t2 then () else + + try + match (get_desc t1, get_desc t2) with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1 t2 + | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> + () + | _ -> + let t1' = expand_head_rigid env t1 in + let t2' = expand_head_rigid env t2 in + (* Expansion may have changed the representative of the types... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1' t2' + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 + || !Clflags.classic && not (is_optional l1 || is_optional l2) -> + eqtype rename type_pairs subst env t1 t2; + eqtype rename type_pairs subst env u1 u2; + | (Ttuple tl1, Ttuple tl2) -> + eqtype_list rename type_pairs subst env tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) + when Path.same p1 p2 -> + eqtype_list rename type_pairs subst env tl1 tl2 + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> + begin try + unify_package env (eqtype_list rename type_pairs subst env) + (get_level t1') p1 fl1 (get_level t2') p2 fl2 + with Not_found -> raise_unexplained_for Equality + end + | (Tnil, Tconstr _ ) -> + raise_for Equality (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> + raise_for Equality (Obj (Abstract_row First)) + | (Tvariant row1, Tvariant row2) -> + eqtype_row rename type_pairs subst env row1 row2 + | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> + eqtype_fields rename type_pairs subst env fi1 fi2 + | (Tfield _, Tfield _) -> (* Actually unused *) + eqtype_fields rename type_pairs subst env + t1' t2' + | (Tnil, Tnil) -> + () + | (Tpoly (t1, []), Tpoly (t2, [])) -> + eqtype rename type_pairs subst env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly_for Equality env univar_pairs t1 tl1 t2 tl2 + (eqtype rename type_pairs subst env) + | (Tunivar _, Tunivar _) -> + unify_univar_for Equality t1' t2' !univar_pairs + | (_, _) -> + raise_unexplained_for Equality + end + with Equality_trace trace -> + raise_trace_for Equality (Diff {got = t1; expected = t2} :: trace) + +and eqtype_list rename type_pairs subst env tl1 tl2 = + if List.length tl1 <> List.length tl2 then + raise_unexplained_for Equality; + List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 + +and eqtype_fields rename type_pairs subst env ty1 ty2 = + let (fields1, rest1) = flatten_fields ty1 in + let (fields2, rest2) = flatten_fields ty2 in + (* First check if same row => already equal *) + let same_row = + eq_type rest1 rest2 || TypePairs.mem type_pairs (rest1,rest2) + in + if same_row then () else + (* Try expansion, needed when called from Includecore.type_manifest *) + match get_desc (expand_head_rigid env rest2) with + Tobject(ty2,_) -> eqtype_fields rename type_pairs subst env ty1 ty2 + | _ -> + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + eqtype rename type_pairs subst env rest1 rest2; + match miss1, miss2 with + | ((n, _, _)::_, _) -> raise_for Equality (Obj (Missing_field (Second, n))) + | (_, (n, _, _)::_) -> raise_for Equality (Obj (Missing_field (First, n))) + | [], [] -> + List.iter + (function (name, k1, t1, k2, t2) -> + eqtype_kind k1 k2; + try + eqtype rename type_pairs subst env t1 t2; + with Equality_trace trace -> + raise_trace_for Equality + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace)) + pairs + +and eqtype_kind k1 k2 = + let k1 = field_kind_repr k1 in + let k2 = field_kind_repr k2 in + match k1, k2 with + | (Fprivate, Fprivate) + | (Fpublic, Fpublic) -> () + | _ -> raise_unexplained_for Unify + (* It's probably not possible to hit this case with + real OCaml code *) + +and eqtype_row rename type_pairs subst env row1 row2 = + (* Try expansion, needed when called from Includecore.type_manifest *) + match get_desc (expand_head_rigid env (row_more row2)) with + Tvariant row2 -> eqtype_row rename type_pairs subst env row1 row2 + | _ -> + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + if row_closed row1 <> row_closed row2 then begin + raise_for Equality + (Variant (Openness (if row_closed row2 then First else Second))) + end; + if not (row_closed row1) then begin + match r1, r2 with + | _::_, _ -> raise_for Equality (Variant (No_tags (Second, r1))) + | _, _::_ -> raise_for Equality (Variant (No_tags (First, r2))) + | _, _ -> () + end; + begin + match filter_row_fields false r1 with + | [] -> (); + | _ :: _ as r1 -> raise_for Equality (Variant (No_tags (Second, r1))) + end; + begin + match filter_row_fields false r2 with + | [] -> () + | _ :: _ as r2 -> raise_for Equality (Variant (No_tags (First, r2))) + end; + if not (static_row row1) then + eqtype rename type_pairs subst env (row_more row1) (row_more row2); + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + eqtype rename type_pairs subst env t1 t2 + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both matching [Reither]s *) + | Reither(c1, [], _), Reither(c2, [], _) when c1 = c2 -> () + | Reither(c1, t1::tl1, _), Reither(c2, t2::tl2, _) + when c1 = c2 -> begin + try + eqtype rename type_pairs subst env t1 t2; + if List.length tl1 = List.length tl2 then + (* if same length allow different types (meaning?) *) + List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 + else begin + (* otherwise everything must be equal *) + List.iter (eqtype rename type_pairs subst env t1) tl2; + List.iter + (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1 + end + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) + | Reither _, Reither _ -> + raise_for Equality (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Equality (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Equality (Variant (No_tags (Second, [l, f1])))) + pairs + +(* Must empty univar_pairs first *) +let eqtype_list rename type_pairs subst env tl1 tl2 = + univar_pairs := []; + let snap = Btype.snapshot () in + Misc.try_finally + ~always:(fun () -> backtrack snap) + (fun () -> eqtype_list rename type_pairs subst env tl1 tl2) + +let eqtype rename type_pairs subst env t1 t2 = + eqtype_list rename type_pairs subst env [t1] [t2] + +(* Two modes: with or without renaming of variables *) +let equal env rename tyl1 tyl2 = + let subst = ref [] in + try eqtype_list rename (TypePairs.create 11) subst env tyl1 tyl2 + with Equality_trace trace -> + raise (Equality (expand_to_equality_error env trace !subst)) + +let is_equal env rename tyl1 tyl2 = + match equal env rename tyl1 tyl2 with + | () -> true + | exception Equality _ -> false + +let rec equal_private env params1 ty1 params2 ty2 = + match equal env true (params1 @ [ty1]) (params2 @ [ty2]) with + | () -> () + | exception (Equality _ as err) -> + match try_expand_safe_opt env (expand_head env ty1) with + | ty1' -> equal_private env params1 ty1' params2 ty2 + | exception Cannot_expand -> raise err + + (*************************) + (* Class type matching *) + (*************************) + +type class_match_failure = + CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of Env.t * equality_error + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of Env.t * moregen_error + | CM_Val_type_mismatch of string * Env.t * comparison_error + | CM_Meth_type_mismatch of string * Env.t * comparison_error + | CM_Non_mutable_value of string + | CM_Non_concrete_value of string + | CM_Missing_value of string + | CM_Missing_method of string + | CM_Hide_public of string + | CM_Hide_virtual of string * string + | CM_Public_method of string + | CM_Private_method of string + | CM_Virtual_method of string + +exception Failure of class_match_failure list + +let match_class_sig_shape ~strict sign1 sign2 = + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> CM_Missing_method lab::err + | (priv', vr', _) -> + match priv', priv with + | Mpublic, Mprivate _ -> CM_Public_method lab::err + | Mprivate _, Mpublic when strict -> CM_Private_method lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Virtual_method lab::err + | _, _ -> err) + sign2.csig_meths [] + in + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + if Meths.mem lab sign2.csig_meths then err + else begin + let err = + match priv with + | Mpublic -> CM_Hide_public lab :: err + | Mprivate _ -> err + in + match vr with + | Virtual -> CM_Hide_virtual ("method", lab) :: err + | Concrete -> err + end) + sign1.csig_meths errors + in + let errors = + Vars.fold + (fun lab (mut, vr, _) err -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> CM_Missing_value lab::err + | (mut', vr', _) -> + match mut', mut with + | Immutable, Mutable -> CM_Non_mutable_value lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Non_concrete_value lab::err + | _, _ -> err) + sign2.csig_vars errors + in + Vars.fold + (fun lab (_,vr,_) err -> + if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then + CM_Hide_virtual ("instance variable", lab) :: err + else err) + sign1.csig_vars errors + +let rec moregen_clty trace type_pairs env cty1 cty2 = + try + match cty1, cty2 with + | Cty_constr (_, _, cty1), _ -> + moregen_clty true type_pairs env cty1 cty2 + | _, Cty_constr (_, _, cty2) -> + moregen_clty true type_pairs env cty1 cty2 + | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 -> + begin + try moregen true type_pairs env ty1 ty2 with Moregen_trace trace -> + raise (Failure [ + CM_Parameter_mismatch (env, expand_to_moregen_error env trace)]) + end; + moregen_clty false type_pairs env cty1' cty2' + | Cty_signature sign1, Cty_signature sign2 -> + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error env trace))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error env trace))])) + sign2.csig_vars + | _ -> + raise (Failure []) + with + Failure error when trace || error = [] -> + raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) + +let match_class_types ?(trace=true) env pat_sch subj_sch = + let sign1 = signature_of_class_type pat_sch in + let sign2 = signature_of_class_type subj_sch in + let errors = match_class_sig_shape ~strict:false sign1 sign2 in + match errors with + | [] -> + let old_level = !current_level in + current_level := generic_level - 1; + (* + Generic variables are first duplicated with [instance]. So, + their levels are lowered to [generic_level - 1]. The subject is + then copied with [duplicate_type]. That way, its levels won't be + changed. + *) + let (_, subj_inst) = instance_class [] subj_sch in + let subj = duplicate_class_type subj_inst in + current_level := generic_level; + (* Duplicate generic variables *) + let (_, patt) = instance_class [] pat_sch in + let type_pairs = TypePairs.create 53 in + let sign1 = signature_of_class_type patt in + let sign2 = signature_of_class_type subj in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + moregen true type_pairs env row1 row2; + let res = + match moregen_clty trace type_pairs env patt subj with + | () -> [] + | exception Failure res -> + (* We've found an error. Moregen splits the generic level into two + finer levels: [generic_level] and [generic_level - 1]. In order + to properly detect and print weak variables when printing this + error, we need to merge them back together, by regeneralizing the + levels of the types after they were instantiated at + [generic_level - 1] above. Because [moregen] does some + unification that we need to preserve for more legible error + messages, we have to manually perform the regeneralization rather + than backtracking. *) + current_level := generic_level - 2; + generalize_class_type subj_inst; + res + in + current_level := old_level; + res + | errors -> + CM_Class_type_mismatch (env, pat_sch, subj_sch) :: errors + +let equal_clsig trace type_pairs subst env sign1 sign2 = + try + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + sign2.csig_vars + with + Failure error when trace -> + raise (Failure (CM_Class_type_mismatch + (env, Cty_signature sign1, Cty_signature sign2)::error)) + +let match_class_declarations env patt_params patt_type subj_params subj_type = + let sign1 = signature_of_class_type patt_type in + let sign2 = signature_of_class_type subj_type in + let errors = match_class_sig_shape ~strict:true sign1 sign2 in + match errors with + | [] -> begin + try + let subst = ref [] in + let type_pairs = TypePairs.create 53 in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + eqtype true type_pairs subst env row1 row2; + let lp = List.length patt_params in + let ls = List.length subj_params in + if lp <> ls then + raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]); + List.iter2 (fun p s -> + try eqtype true type_pairs subst env p s with Equality_trace trace -> + raise (Failure + [CM_Type_parameter_mismatch + (env, expand_to_equality_error env trace !subst)])) + patt_params subj_params; + (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) + equal_clsig false type_pairs subst env sign1 sign2; + (* Use moregeneral for class parameters, need to recheck everything to + keeps relationships (PR#4824) *) + let clty_params = + List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in + match_class_types ~trace:false env + (clty_params patt_params patt_type) + (clty_params subj_params subj_type) + with Failure r -> r + end + | error -> + error + + + (***************) + (* Subtyping *) + (***************) + + +(**** Build a subtype of a given type. ****) + +(* build_subtype: + [visited] traces traversed object and variant types + [loops] is a mapping from variables to variables, to reproduce + positive loops in a class type + [posi] true if the current variance is positive + [level] number of expansions/enlargement allowed on this branch *) + +let warn = ref false (* whether double coercion might do better *) +let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n +let pred_enlarge n = if n mod 2 = 1 then pred n else n + +type change = Unchanged | Equiv | Changed +let max_change c1 c2 = + match c1, c2 with + | _, Changed | Changed, _ -> Changed + | Equiv, _ | _, Equiv -> Equiv + | _ -> Unchanged + +let collect l = List.fold_left (fun c1 (_, c2) -> max_change c1 c2) Unchanged l + +let rec filter_visited = function + [] -> [] + | {desc=Tobject _|Tvariant _} :: _ as l -> l + | _ :: l -> filter_visited l + +let memq_warn t visited = + if List.memq t visited then (warn := true; true) else false + +let find_cltype_for_path env p = + let cl_abbr = Env.find_hash_type p env in + match cl_abbr.type_manifest with + Some ty -> + begin match get_desc ty with + Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty + | _ -> raise Not_found + end + | None -> assert false + +let has_constr_row' env t = + has_constr_row (expand_abbrev env t) + +let rec build_subtype env (visited : transient_expr list) + (loops : (int * type_expr) list) posi level t = + match get_desc t with + Tvar _ -> + if posi then + try + let t' = List.assq (get_id t) loops in + warn := true; + (t', Equiv) + with Not_found -> + (t, Unchanged) + else + (t, Unchanged) + | Tarrow(l, t1, t2, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: visited in + let (t1', c1) = build_subtype env visited loops (not posi) level t1 in + let (t2', c2) = build_subtype env visited loops posi level t2 in + let c = max_change c1 c2 in + if c > Unchanged + then (newty (Tarrow(l, t1', t2', commu_ok)), c) + else (t, Unchanged) + | Ttuple tlist -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: visited in + let tlist' = + List.map (build_subtype env visited loops posi level) tlist + in + let c = collect tlist' in + if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c) + else (t, Unchanged) + | Tconstr(p, tl, abbrev) + when level > 0 && generic_abbrev env p && safe_abbrev env t + && not (has_constr_row' env t) -> + let t' = expand_abbrev env t in + let level' = pred_expand level in + begin try match get_desc t' with + Tobject _ when posi && not (opened_object t') -> + let cl_abbr, body = find_cltype_for_path env p in + let ty = + try + subst env !current_level Public abbrev None + cl_abbr.type_params tl body + with Cannot_subst -> assert false in + let ty1, tl1 = + match get_desc ty with + Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' -> + ty1, tl1 + | _ -> raise Not_found + in + (* Fix PR#4505: do not set ty to Tvar when it appears in tl1, + as this occurrence might break the occur check. + XXX not clear whether this correct anyway... *) + if List.exists (deep_occur ty) tl1 then raise Not_found; + set_type_desc ty (Tvar None); + let t'' = newvar () in + let loops = (get_id ty, t'') :: loops in + (* May discard [visited] as level is going down *) + let (ty1', c) = + build_subtype env [Transient_expr.repr t'] + loops posi (pred_enlarge level') ty1 in + assert (is_Tvar t''); + let nm = + if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in + set_type_desc t'' (Tobject (ty1', ref nm)); + (try unify_var env ty t with Unify _ -> assert false); + ( t'', Changed) + | _ -> raise Not_found + with Not_found -> + let (t'',c) = + build_subtype env visited loops posi level' t' in + if c > Unchanged then (t'',c) + else (t, Unchanged) + end + | Tconstr(p, tl, _abbrev) -> + (* Must check recursion on constructors, since we do not always + expand them *) + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: visited in + begin try + let decl = Env.find_type p env in + if level = 0 && generic_abbrev env p && safe_abbrev env t + && not (has_constr_row' env t) + then warn := true; + let tl' = + List.map2 + (fun v t -> + let (co,cn) = Variance.get_upper v in + if cn then + if co then (t, Unchanged) + else build_subtype env visited loops (not posi) level t + else + if co then build_subtype env visited loops posi level t + else (newvar(), Changed)) + decl.type_variance tl + in + let c = collect tl' in + if c > Unchanged then (newconstr p (List.map fst tl'), c) + else (t, Unchanged) + with Not_found -> + (t, Unchanged) + end + | Tvariant row -> + let tt = Transient_expr.repr t in + if memq_warn tt visited || not (static_row row) then (t, Unchanged) else + let level' = pred_enlarge level in + let visited = + tt :: if level' < level then [] else filter_visited visited in + let fields = filter_row_fields false (row_fields row) in + let fields = + List.map + (fun (l,f as orig) -> match row_field_repr f with + Rpresent None -> + if posi then + (l, rf_either_of None), Unchanged + else + orig, Unchanged + | Rpresent(Some t) -> + let (t', c) = build_subtype env visited loops posi level' t in + let f = + if posi && level > 0 + then rf_either_of (Some t') + else rf_present (Some t') + in (l, f), c + | _ -> assert false) + fields + in + let c = collect fields in + let row = + create_row ~fields:(List.map fst fields) ~more:(newvar ()) + ~closed:posi ~fixed:None + ~name:(if c > Unchanged then None else row_name row) + in + (newty (Tvariant row), Changed) + | Tobject (t1, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited || opened_object t1 then (t, Unchanged) else + let level' = pred_enlarge level in + let visited = + tt :: if level' < level then [] else filter_visited visited in + let (t1', c) = build_subtype env visited loops posi level' t1 in + if c > Unchanged then (newty (Tobject (t1', ref None)), c) + else (t, Unchanged) + | Tfield(s, _, t1, t2) (* Always present *) -> + let (t1', c1) = build_subtype env visited loops posi level t1 in + let (t2', c2) = build_subtype env visited loops posi level t2 in + let c = max_change c1 c2 in + if c > Unchanged then (newty (Tfield(s, field_public, t1', t2')), c) + else (t, Unchanged) + | Tnil -> + if posi then + let v = newvar () in + (v, Changed) + else begin + warn := true; + (t, Unchanged) + end + | Tsubst _ | Tlink _ -> + assert false + | Tpoly(t1, tl) -> + let (t1', c) = build_subtype env visited loops posi level t1 in + if c > Unchanged then (newty (Tpoly(t1', tl)), c) + else (t, Unchanged) + | Tunivar _ | Tpackage _ -> + (t, Unchanged) + +let enlarge_type env ty = + warn := false; + (* [level = 4] allows 2 expansions involving objects/variants *) + let (ty', _) = build_subtype env [] [] true 4 ty in + (ty', !warn) + +(**** Check whether a type is a subtype of another type. ****) + +(* + During the traversal, a trace of visited types is maintained. It + is printed in case of error. + Constraints (pairs of types that must be equals) are accumulated + rather than being enforced straight. Indeed, the result would + otherwise depend on the order in which these constraints are + enforced. + A function enforcing these constraints is returned. That way, type + variables can be bound to their actual values before this function + is called (see Typecore). + Only well-defined abbreviations are expanded (hence the tests + [generic_abbrev ...]). +*) + +let subtypes = TypePairs.create 17 + +let subtype_error ~env ~trace ~unification_trace = + raise (Subtype (Subtype.error + ~trace:(expand_subtype_trace env (List.rev trace)) + ~unification_trace)) + +let rec subtype_rec env trace t1 t2 cstrs = + if eq_type t1 t2 then cstrs else + + if TypePairs.mem subtypes (t1, t2) then + cstrs + else begin + TypePairs.add subtypes (t1, t2); + match (get_desc t1, get_desc t2) with + (Tvar _, _) | (_, Tvar _) -> + (trace, t1, t2, !univar_pairs)::cstrs + | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2 + || !Clflags.classic && not (is_optional l1 || is_optional l2) -> + let cstrs = + subtype_rec + env + (Subtype.Diff {got = t2; expected = t1} :: trace) + t2 t1 + cstrs + in + subtype_rec + env + (Subtype.Diff {got = u1; expected = u2} :: trace) + u1 u2 + cstrs + | (Ttuple tl1, Ttuple tl2) -> + subtype_list env trace tl1 tl2 cstrs + | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 -> + cstrs + | (Tconstr(p1, _tl1, _abbrev1), _) + when generic_abbrev env p1 && safe_abbrev env t1 -> + subtype_rec env trace (expand_abbrev env t1) t2 cstrs + | (_, Tconstr(p2, _tl2, _abbrev2)) + when generic_abbrev env p2 && safe_abbrev env t2 -> + subtype_rec env trace t1 (expand_abbrev env t2) cstrs + | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 -> + begin try + let decl = Env.find_type p1 env in + List.fold_left2 + (fun cstrs v (t1, t2) -> + let (co, cn) = Variance.get_upper v in + if co then + if cn then + (trace, newty2 ~level:(get_level t1) (Ttuple[t1]), + newty2 ~level:(get_level t2) (Ttuple[t2]), !univar_pairs) + :: cstrs + else + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + else + if cn + then + subtype_rec + env + (Subtype.Diff {got = t2; expected = t1} :: trace) + t2 t1 + cstrs + else cstrs) + cstrs decl.type_variance (List.combine tl1 tl2) + with Not_found -> + (trace, t1, t2, !univar_pairs)::cstrs + end + | (Tconstr(p1, _, _), _) + when generic_private_abbrev env p1 && safe_abbrev_opt env t1 -> + subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs +(* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 -> + subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *) + | (Tobject (f1, _), Tobject (f2, _)) + when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> + (* Same row variable implies same object. *) + (trace, t1, t2, !univar_pairs)::cstrs + | (Tobject (f1, _), Tobject (f2, _)) -> + subtype_fields env trace f1 f2 cstrs + | (Tvariant row1, Tvariant row2) -> + begin try + subtype_row env trace row1 row2 cstrs + with Exit -> + (trace, t1, t2, !univar_pairs)::cstrs + end + | (Tpoly (u1, []), Tpoly (u2, [])) -> + subtype_rec env trace u1 u2 cstrs + | (Tpoly (u1, tl1), Tpoly (u2, [])) -> + let _, u1' = instance_poly false tl1 u1 in + subtype_rec env trace u1' u2 cstrs + | (Tpoly (u1, tl1), Tpoly (u2,tl2)) -> + begin try + enter_poly env univar_pairs u1 tl1 u2 tl2 + (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs) + with Escape _ -> + (trace, t1, t2, !univar_pairs)::cstrs + end + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> + begin try + let ntl1 = + complete_type_list env fl2 (get_level t1) (Mty_ident p1) fl1 + and ntl2 = + complete_type_list env fl1 (get_level t2) (Mty_ident p2) fl2 + ~allow_absent:true in + let cstrs' = + List.map + (fun (n2,t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs)) + ntl2 + in + if eq_package_path env p1 p2 then cstrs' @ cstrs + else begin + (* need to check module subtyping *) + let snap = Btype.snapshot () in + match List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs' with + | () when !package_subtype env p1 fl1 p2 fl2 -> + Btype.backtrack snap; cstrs' @ cstrs + | () | exception Unify _ -> + Btype.backtrack snap; raise Not_found + end + with Not_found -> + (trace, t1, t2, !univar_pairs)::cstrs + end + | (_, _) -> + (trace, t1, t2, !univar_pairs)::cstrs + end + +and subtype_list env trace tl1 tl2 cstrs = + if List.length tl1 <> List.length tl2 then + subtype_error ~env ~trace ~unification_trace:[]; + List.fold_left2 + (fun cstrs t1 t2 -> + subtype_rec + env + (Subtype.Diff { got = t1; expected = t2 } :: trace) + t1 t2 + cstrs) + cstrs tl1 tl2 + +and subtype_fields env trace ty1 ty2 cstrs = + (* Assume that either rest1 or rest2 is not Tvar *) + let (fields1, rest1) = flatten_fields ty1 in + let (fields2, rest2) = flatten_fields ty2 in + let (pairs, miss1, miss2) = associate_fields fields1 fields2 in + let cstrs = + if get_desc rest2 = Tnil then cstrs else + if miss1 = [] then + subtype_rec + env + (Subtype.Diff {got = rest1; expected = rest2} :: trace) + rest1 rest2 + cstrs + else + (trace, build_fields (get_level ty1) miss1 rest1, rest2, + !univar_pairs) :: cstrs + in + let cstrs = + if miss2 = [] then cstrs else + (trace, rest1, build_fields (get_level ty2) miss2 (newvar ()), + !univar_pairs) :: cstrs + in + List.fold_left + (fun cstrs (_, _k1, t1, _k2, t2) -> + (* These fields are always present *) + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs) + cstrs pairs + +and subtype_row env trace row1 row2 cstrs = + let Row {fields = row1_fields; more = more1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = more2; closed = row2_closed} = + row_repr row2 in + let r1, r2, pairs = + merge_row_fields row1_fields row2_fields in + let r1 = if row2_closed then filter_row_fields false r1 else r1 in + let r2 = if row1_closed then filter_row_fields false r2 else r2 in + match get_desc more1, get_desc more2 with + Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> + subtype_rec + env + (Subtype.Diff {got = more1; expected = more2} :: trace) + more1 more2 + cstrs + | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) + when row1_closed && r1 = [] -> + List.fold_left + (fun cstrs (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + (Rpresent None|Reither(true,_,_)), Rpresent None -> + cstrs + | Rpresent(Some t1), Rpresent(Some t2) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Reither(false, t1::_, _), Rpresent(Some t2) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Rabsent, _ -> cstrs + | _ -> raise Exit) + cstrs pairs + | Tunivar _, Tunivar _ + when row1_closed = row2_closed && r1 = [] && r2 = [] -> + let cstrs = + subtype_rec + env + (Subtype.Diff {got = more1; expected = more2} :: trace) + more1 more2 + cstrs + in + List.fold_left + (fun cstrs (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + Rpresent None, Rpresent None + | Reither(true,[],_), Reither(true,[],_) + | Rabsent, Rabsent -> + cstrs + | Rpresent(Some t1), Rpresent(Some t2) + | Reither(false,[t1],_), Reither(false,[t2],_) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | _ -> raise Exit) + cstrs pairs + | _ -> + raise Exit + +let subtype env ty1 ty2 = + TypePairs.clear subtypes; + univar_pairs := []; + (* Build constraint set. *) + let cstrs = + subtype_rec env [Subtype.Diff {got = ty1; expected = ty2}] ty1 ty2 [] + in + TypePairs.clear subtypes; + (* Enforce constraints. *) + function () -> + List.iter + (function (trace0, t1, t2, pairs) -> + try unify_pairs (ref env) t1 t2 pairs with Unify {trace} -> + subtype_error ~env ~trace:trace0 ~unification_trace:(List.tl trace)) + (List.rev cstrs) + + (*******************) + (* Miscellaneous *) + (*******************) + +(* Utility for printing. The resulting type is not used in computation. *) +let rec unalias_object ty = + let level = get_level ty in + match get_desc ty with + Tfield (s, k, t1, t2) -> + newty2 ~level (Tfield (s, k, t1, unalias_object t2)) + | Tvar _ | Tnil as desc -> + newty2 ~level desc + | Tunivar _ -> + ty + | Tconstr _ -> + newvar2 level + | _ -> + assert false + +let unalias ty = + let level = get_level ty in + match get_desc ty with + Tvar _ | Tunivar _ -> + ty + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + newty2 ~level + (Tvariant + (create_row ~fields ~name ~fixed ~closed ~more: + (newty2 ~level:(get_level more) (get_desc more)))) + | Tobject (ty, nm) -> + newty2 ~level (Tobject (unalias_object ty, nm)) + | desc -> + newty2 ~level desc + +(* Return the arity (as for curried functions) of the given type. *) +let rec arity ty = + match get_desc ty with + Tarrow(_, _t1, t2, _) -> 1 + arity t2 + | _ -> 0 + +(* Check for non-generalizable type variables *) +let add_nongen_vars_in_schema = + let rec loop env ((visited, weak_set) as acc) ty = + if TypeSet.mem ty visited + then acc + else begin + let visited = TypeSet.add ty visited in + match get_desc ty with + | Tvar _ when get_level ty <> generic_level -> + visited, TypeSet.add ty weak_set + | Tconstr _ -> + let (_, unexpanded_candidate) as unexpanded_candidate' = + fold_type_expr + (loop env) + (visited, weak_set) + ty + in + (* Using `==` is okay because `loop` will return the original set + when it does not change it. Similarly, `TypeSet.add` will return + the original set if the element is already present. *) + if unexpanded_candidate == weak_set + then (visited, weak_set) + else begin + match + loop env (visited, weak_set) + (try_expand_head try_expand_safe env ty) + with + | exception Cannot_expand -> unexpanded_candidate' + | expanded_result -> expanded_result + end + | Tfield(_, kind, t1, t2) -> + let visited, weak_set = + match field_kind_repr kind with + | Fpublic -> loop env (visited, weak_set) t1 + | _ -> visited, weak_set + in + loop env (visited, weak_set) t2 + | Tvariant row -> + let visited, weak_set = + fold_row (loop env) (visited, weak_set) row + in + if not (static_row row) + then loop env (visited, weak_set) (row_more row) + else (visited, weak_set) + | _ -> + fold_type_expr (loop env) (visited, weak_set) ty + end + in + fun env acc ty -> + let _, result = loop env (TypeSet.empty, acc) ty in + result + +(* Return all non-generic variables of [ty]. *) +let nongen_vars_in_schema env ty = + let result = add_nongen_vars_in_schema env TypeSet.empty ty in + if TypeSet.is_empty result + then None + else Some result + +(* Check that all type variables are generalizable *) +(* Use Env.empty to prevent expansion of recursively defined object types; + cf. typing-poly/poly.ml *) +let nongen_class_type = + let add_nongen_vars_in_schema' ty weak_set = + add_nongen_vars_in_schema Env.empty weak_set ty + in + let add_nongen_vars_in_schema_fold fold m weak_set = + let f _key (_,_,ty) weak_set = + add_nongen_vars_in_schema Env.empty weak_set ty + in + fold f m weak_set + in + let rec nongen_class_type cty weak_set = + match cty with + | Cty_constr (_, params, _) -> + List.fold_left + (add_nongen_vars_in_schema Env.empty) + weak_set + params + | Cty_signature sign -> + weak_set + |> add_nongen_vars_in_schema' sign.csig_self + |> add_nongen_vars_in_schema' sign.csig_self_row + |> add_nongen_vars_in_schema_fold Meths.fold sign.csig_meths + |> add_nongen_vars_in_schema_fold Vars.fold sign.csig_vars + | Cty_arrow (_, ty, cty) -> + add_nongen_vars_in_schema' ty weak_set + |> nongen_class_type cty + in + nongen_class_type + +let nongen_class_declaration cty = + List.fold_left + (add_nongen_vars_in_schema Env.empty) + TypeSet.empty + cty.cty_params + |> nongen_class_type cty.cty_type + +let nongen_vars_in_class_declaration cty = + let result = nongen_class_declaration cty in + if TypeSet.is_empty result + then None + else Some result + +(* Normalize a type before printing, saving... *) +(* Cannot use mark_type because deep_occur uses it too *) +let rec normalize_type_rec visited ty = + if not (TypeSet.mem ty !visited) then begin + visited := TypeSet.add ty !visited; + let tm = row_of_type ty in + begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then + match get_desc tm with (* PR#7348 *) + Tconstr (Path.Pdot(m,i), tl, _abbrev) -> + let i' = String.sub i 0 (String.length i - 4) in + set_type_desc ty (Tconstr(Path.Pdot(m,i'), tl, ref Mnil)) + | _ -> assert false + else match get_desc ty with + | Tvariant row -> + let Row {fields = orig_fields; more; name; fixed; closed} = + row_repr row in + let fields = List.map + (fun (l,f) -> + l, + match row_field_repr f with Reither(b, ty::(_::_ as tyl), m) -> + let tyl' = + List.fold_left + (fun tyl ty -> + if List.exists + (fun ty' -> is_equal Env.empty false [ty] [ty']) + tyl + then tyl + else ty::tyl) + [ty] tyl + in + if List.length tyl' <= List.length tyl then + rf_either (List.rev tyl') ~use_ext_of:f ~no_arg:b ~matched:m + else f + | _ -> f) + orig_fields in + let fields = + List.sort (fun (p,_) (q,_) -> compare p q) + (List.filter (fun (_,fi) -> row_field_repr fi <> Rabsent) fields) in + set_type_desc ty (Tvariant + (create_row ~fields ~more ~name ~fixed ~closed)) + | Tobject (fi, nm) -> + begin match !nm with + | None -> () + | Some (n, v :: l) -> + if deep_occur ty (newgenty (Ttuple l)) then + (* The abbreviation may be hiding something, so remove it *) + set_name nm None + else + begin match get_desc v with + | Tvar _ | Tunivar _ -> () + | Tnil -> set_type_desc ty (Tconstr (n, l, ref Mnil)) + | _ -> set_name nm None + end + | _ -> + fatal_error "Ctype.normalize_type_rec" + end; + let level = get_level fi in + if level < lowest_level then () else + let fields, row = flatten_fields fi in + let fi' = build_fields level fields row in + set_type_desc fi (get_desc fi') + | _ -> () + end; + iter_type_expr (normalize_type_rec visited) ty; + end + +let normalize_type ty = + normalize_type_rec (ref TypeSet.empty) ty + + + (*************************) + (* Remove dependencies *) + (*************************) + + +(* + Variables are left unchanged. Other type nodes are duplicated, with + levels set to generic level. + We cannot use Tsubst here, because unification may be called by + expand_abbrev. +*) + +let nondep_hash = TypeHash.create 47 +let nondep_variants = TypeHash.create 17 +let clear_hash () = + TypeHash.clear nondep_hash; TypeHash.clear nondep_variants + +let rec nondep_type_rec ?(expand_private=false) env ids ty = + let try_expand env t = + if expand_private then try_expand_safe_opt env t + else try_expand_safe env t + in + match get_desc ty with + Tvar _ | Tunivar _ -> ty + | _ -> try TypeHash.find nondep_hash ty + with Not_found -> + let ty' = newgenstub ~scope:(get_scope ty) in + TypeHash.add nondep_hash ty ty'; + match + match get_desc ty with + | Tconstr(p, tl, _abbrev) as desc -> + begin try + (* First, try keeping the same type constructor p *) + match Path.find_free_opt ids p with + | Some id -> + raise (Nondep_cannot_erase id) + | None -> + Tconstr(p, List.map (nondep_type_rec env ids) tl, ref Mnil) + with (Nondep_cannot_erase _) as exn -> + (* If that doesn't work, try expanding abbrevs *) + try Tlink (nondep_type_rec ~expand_private env ids + (try_expand env (newty2 ~level:(get_level ty) desc))) + (* + The [Tlink] is important. The expanded type may be a + variable, or may not be completely copied yet + (recursive type), so one cannot just take its + description. + *) + with Cannot_expand -> raise exn + end + | Tpackage(p, fl) when Path.exists_free ids p -> + let p' = normalize_package_path env p in + begin match Path.find_free_opt ids p' with + | Some id -> raise (Nondep_cannot_erase id) + | None -> + let nondep_field_rec (n, ty) = (n, nondep_type_rec env ids ty) in + Tpackage (p', List.map nondep_field_rec fl) + end + | Tobject (t1, name) -> + Tobject (nondep_type_rec env ids t1, + ref (match !name with + None -> None + | Some (p, tl) -> + if Path.exists_free ids p then None + else Some (p, List.map (nondep_type_rec env ids) tl))) + | Tvariant row -> + let more = row_more row in + (* We must keep sharing according to the row variable *) + begin try + let ty2 = TypeHash.find nondep_variants more in + (* This variant type has been already copied *) + TypeHash.add nondep_hash ty ty2; + Tlink ty2 + with Not_found -> + (* Register new type first for recursion *) + TypeHash.add nondep_variants more ty'; + let static = static_row row in + let more' = + if static then newgenty Tnil else nondep_type_rec env ids more + in + (* Return a new copy *) + let row = + copy_row (nondep_type_rec env ids) true row true more' in + match row_name row with + Some (p, _tl) when Path.exists_free ids p -> + Tvariant (set_row_name row None) + | _ -> Tvariant row + end + | desc -> copy_type_desc (nondep_type_rec env ids) desc + with + | desc -> + Transient_expr.set_stub_desc ty' desc; + ty' + | exception e -> + TypeHash.remove nondep_hash ty; + raise e + +let nondep_type env id ty = + try + let ty' = nondep_type_rec env id ty in + clear_hash (); + ty' + with Nondep_cannot_erase _ as exn -> + clear_hash (); + raise exn + +let () = nondep_type' := nondep_type + +(* Preserve sharing inside type declarations. *) +let nondep_type_decl env mid is_covariant decl = + try + let params = List.map (nondep_type_rec env mid) decl.type_params in + let tk = + try map_kind (nondep_type_rec env mid) decl.type_kind + with Nondep_cannot_erase _ when is_covariant -> Type_abstract + and tm, priv = + match decl.type_manifest with + | None -> None, decl.type_private + | Some ty -> + try Some (nondep_type_rec env mid ty), decl.type_private + with Nondep_cannot_erase _ when is_covariant -> + clear_hash (); + try Some (nondep_type_rec ~expand_private:true env mid ty), + Private + with Nondep_cannot_erase _ -> + None, decl.type_private + in + clear_hash (); + let priv = + match tm with + | Some ty when Btype.has_constr_row ty -> Private + | _ -> priv + in + { type_params = params; + type_arity = decl.type_arity; + type_kind = tk; + type_manifest = tm; + type_private = priv; + type_variance = decl.type_variance; + type_separability = decl.type_separability; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = decl.type_loc; + type_attributes = decl.type_attributes; + type_immediate = decl.type_immediate; + type_unboxed_default = decl.type_unboxed_default; + type_uid = decl.type_uid; + } + with Nondep_cannot_erase _ as exn -> + clear_hash (); + raise exn + +(* Preserve sharing inside extension constructors. *) +let nondep_extension_constructor env ids ext = + try + let type_path, type_params = + match Path.find_free_opt ids ext.ext_type_path with + | Some id -> + begin + let ty = + newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil)) + in + let ty' = nondep_type_rec env ids ty in + match get_desc ty' with + Tconstr(p, tl, _) -> p, tl + | _ -> raise (Nondep_cannot_erase id) + end + | None -> + let type_params = + List.map (nondep_type_rec env ids) ext.ext_type_params + in + ext.ext_type_path, type_params + in + let args = map_type_expr_cstr_args (nondep_type_rec env ids) ext.ext_args in + let ret_type = Option.map (nondep_type_rec env ids) ext.ext_ret_type in + clear_hash (); + { ext_type_path = type_path; + ext_type_params = type_params; + ext_args = args; + ext_ret_type = ret_type; + ext_private = ext.ext_private; + ext_attributes = ext.ext_attributes; + ext_loc = ext.ext_loc; + ext_uid = ext.ext_uid; + } + with Nondep_cannot_erase _ as exn -> + clear_hash (); + raise exn + + +(* Preserve sharing inside class types. *) +let nondep_class_signature env id sign = + { csig_self = nondep_type_rec env id sign.csig_self; + csig_self_row = nondep_type_rec env id sign.csig_self_row; + csig_vars = + Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) + sign.csig_vars; + csig_meths = + Meths.map (function (p, v, t) -> (p, v, nondep_type_rec env id t)) + sign.csig_meths } + +let rec nondep_class_type env ids = + function + Cty_constr (p, _, cty) when Path.exists_free ids p -> + nondep_class_type env ids cty + | Cty_constr (p, tyl, cty) -> + Cty_constr (p, List.map (nondep_type_rec env ids) tyl, + nondep_class_type env ids cty) + | Cty_signature sign -> + Cty_signature (nondep_class_signature env ids sign) + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, nondep_type_rec env ids ty, nondep_class_type env ids cty) + +let nondep_class_declaration env ids decl = + assert (not (Path.exists_free ids decl.cty_path)); + let decl = + { cty_params = List.map (nondep_type_rec env ids) decl.cty_params; + cty_variance = decl.cty_variance; + cty_type = nondep_class_type env ids decl.cty_type; + cty_path = decl.cty_path; + cty_new = + begin match decl.cty_new with + None -> None + | Some ty -> Some (nondep_type_rec env ids ty) + end; + cty_loc = decl.cty_loc; + cty_attributes = decl.cty_attributes; + cty_uid = decl.cty_uid; + } + in + clear_hash (); + decl + +let nondep_cltype_declaration env ids decl = + assert (not (Path.exists_free ids decl.clty_path)); + let decl = + { clty_params = List.map (nondep_type_rec env ids) decl.clty_params; + clty_variance = decl.clty_variance; + clty_type = nondep_class_type env ids decl.clty_type; + clty_path = decl.clty_path; + clty_hash_type = nondep_type_decl env ids false decl.clty_hash_type ; + clty_loc = decl.clty_loc; + clty_attributes = decl.clty_attributes; + clty_uid = decl.clty_uid; + } + in + clear_hash (); + decl + +(* collapse conjunctive types in class parameters *) +let rec collapse_conj env visited ty = + let id = get_id ty in + if List.memq id visited then () else + let visited = id :: visited in + match get_desc ty with + Tvariant row -> + List.iter + (fun (_l,fi) -> + match row_field_repr fi with + Reither (_c, t1::(_::_ as tl), _m) -> + List.iter (unify env t1) tl + | _ -> + ()) + (row_fields row); + iter_row (collapse_conj env visited) row + | _ -> + iter_type_expr (collapse_conj env visited) ty + +let collapse_conj_params env params = + List.iter (collapse_conj env []) params + +let same_constr env t1 t2 = + let t1 = expand_head env t1 in + let t2 = expand_head env t2 in + match get_desc t1, get_desc t2 with + | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2 + | _ -> false + +let () = + Env.same_constr := same_constr + +let immediacy env typ = + match get_desc typ with + | Tconstr(p, _args, _abbrev) -> + begin try + let type_decl = Env.find_type p env in + type_decl.type_immediate + with Not_found -> Type_immediacy.Unknown + (* This can happen due to e.g. missing -I options, + causing some .cmi files to be unavailable. + Maybe we should emit a warning. *) + end + | Tvariant row -> + (* if all labels are devoid of arguments, not a pointer *) + if + not (row_closed row) + || List.exists + (fun (_, f) -> match row_field_repr f with + | Rpresent (Some _) | Reither (false, _, _) -> true + | _ -> false) + (row_fields row) + then + Type_immediacy.Unknown + else + Type_immediacy.Always + | _ -> Type_immediacy.Unknown diff --git a/ocamlmerlin_mlx/ocaml/typing/ctype.mli b/ocamlmerlin_mlx/ocaml/typing/ctype.mli new file mode 100644 index 0000000..be4fddb --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/ctype.mli @@ -0,0 +1,464 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Operations on core types *) + +open Asttypes +open Types + +exception Unify of Errortrace.unification_error +exception Equality of Errortrace.equality_error +exception Moregen of Errortrace.moregen_error +exception Subtype of Errortrace.Subtype.error + +exception Escape of type_expr Errortrace.escape + +exception Tags of label * label +exception Cannot_expand +exception Cannot_apply +exception Matches_failure of Env.t * Errortrace.unification_error + (* Raised from [matches], hence the odd name *) +exception Incompatible + (* Raised from [mcomp] *) + +(* All the following wrapper functions revert to the original level, + even in case of exception. *) +val with_local_level: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* [with_local_level (fun () -> cmd) ~post] evaluates [cmd] at a + raised level. + If given, [post] is applied to the result, at the original level. + It is expected to contain only level related post-processing. *) +val with_local_level_if: bool -> (unit -> 'a) -> post:('a -> unit) -> 'a + (* Same as [with_local_level], but only raise the level conditionally. + [post] also is only called if the level is raised. *) +val with_local_level_iter: (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Variant of [with_local_level], where [post] is iterated on the + returned list. *) +val with_local_level_iter_if: + bool -> (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Conditional variant of [with_local_level_iter] *) +val with_level: level: int -> (unit -> 'a) -> 'a + (* [with_level ~level (fun () -> cmd)] evaluates [cmd] with + [current_level] set to [level] *) +val with_level_if: bool -> level: int -> (unit -> 'a) -> 'a + (* Conditional variant of [with_level] *) +val with_local_level_if_principal: (unit -> 'a) -> post:('a -> unit) -> 'a +val with_local_level_iter_if_principal: + (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Applications of [with_local_level_if] and [with_local_level_iter_if] + to [!Clflags.principal] *) + +val with_local_level_for_class: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* Variant of [with_local_level], where the current level is raised but + the nongen level is not touched *) +val with_raised_nongen_level: (unit -> 'a) -> 'a + (* Variant of [with_local_level], + raises the nongen level to the current level *) + +val reset_global_level: unit -> unit + (* Reset the global level before typing an expression *) +val increase_global_level: unit -> int +val restore_global_level: int -> unit + (* This pair of functions is only used in Typetexp *) +type levels = + { current_level: int; nongen_level: int; global_level: int; + saved_level: (int * int) list; } +val save_levels: unit -> levels +val set_levels: levels -> unit + +val create_scope : unit -> int + +val newty: type_desc -> type_expr +val new_scoped_ty: int -> type_desc -> type_expr +val newvar: ?name:string -> unit -> type_expr +val newvar2: ?name:string -> int -> type_expr + (* Return a fresh variable *) +val new_global_var: ?name:string -> unit -> type_expr + (* Return a fresh variable, bound at toplevel + (as type variables ['a] in type constraints). *) +val newobj: type_expr -> type_expr +val newconstr: Path.t -> type_expr list -> type_expr +val none: type_expr + (* A dummy type expression *) + +val object_fields: type_expr -> type_expr +val flatten_fields: + type_expr -> (string * field_kind * type_expr) list * type_expr +(** Transform a field type into a list of pairs label-type. + The fields are sorted. + + Beware of the interaction with GADTs: + + Due to the introduction of object indexes for GADTs, the row variable of + an object may now be an expansible type abbreviation. + A first consequence is that [flatten_fields] will not completely flatten + the object, since the type abbreviation will not be expanded + ([flatten_fields] does not receive the current environment). + Another consequence is that various functions may be called with the + expansion of this type abbreviation, which is a Tfield, e.g. during + printing. + + Concrete problems have been fixed, but new bugs may appear in the + future. (Test cases were added to typing-gadts/test.ml) +*) + +val associate_fields: + (string * field_kind * type_expr) list -> + (string * field_kind * type_expr) list -> + (string * field_kind * type_expr * field_kind * type_expr) list * + (string * field_kind * type_expr) list * + (string * field_kind * type_expr) list +val opened_object: type_expr -> bool +val set_object_name: + Ident.t -> type_expr list -> type_expr -> unit +val remove_object_name: type_expr -> unit +val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr + +val sort_row_fields: (label * row_field) list -> (label * row_field) list +val merge_row_fields: + (label * row_field) list -> (label * row_field) list -> + (label * row_field) list * (label * row_field) list * + (label * row_field * row_field) list +val filter_row_fields: + bool -> (label * row_field) list -> (label * row_field) list + +val generalize: type_expr -> unit + (* Generalize in-place the given type *) +val lower_contravariant: Env.t -> type_expr -> unit + (* Lower level of type variables inside contravariant branches; + to be used before generalize for expansive expressions *) +val lower_variables_only: Env.t -> int -> type_expr -> unit + (* Lower all variables to the given level *) +val enforce_current_level: Env.t -> type_expr -> unit + (* Lower whole type to !current_level *) +val generalize_structure: type_expr -> unit + (* Generalize the structure of a type, lowering variables + to !current_level *) +val generalize_class_type : class_type -> unit + (* Generalize the components of a class type *) +val generalize_class_type_structure : class_type -> unit + (* Generalize the structure of the components of a class type *) +val generalize_class_signature_spine : Env.t -> class_signature -> unit + (* Special function to generalize methods during inference *) +val correct_levels: type_expr -> type_expr + (* Returns a copy with decreasing levels *) +val limited_generalize: type_expr -> type_expr -> unit + (* Only generalize some part of the type + Make the remaining of the type non-generalizable *) +val limited_generalize_class_type: type_expr -> class_type -> unit + (* Same, but for class types *) + +val fully_generic: type_expr -> bool + +val check_scope_escape : Env.t -> int -> type_expr -> unit + (* [check_scope_escape env lvl ty] ensures that [ty] could be raised + to the level [lvl] without any scope escape. + Raises [Escape] otherwise *) + +val instance: ?partial:bool -> type_expr -> type_expr + (* Take an instance of a type scheme *) + (* partial=None -> normal + partial=false -> newvar() for non generic subterms + partial=true -> newty2 ty.level Tvar for non generic subterms *) +val generic_instance: type_expr -> type_expr + (* Same as instance, but new nodes at generic_level *) +val instance_list: type_expr list -> type_expr list + (* Take an instance of a list of type schemes *) +val new_local_type: + ?loc:Location.t -> + ?manifest_and_scope:(type_expr * int) -> unit -> type_declaration +val existential_name: constructor_description -> type_expr -> string + +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of { env: Env.t ref; scope: int } + +val instance_constructor: existential_treatment -> + constructor_description -> type_expr list * type_expr * type_expr list + (* Same, for a constructor. Also returns existentials. *) +val instance_parameterized_type: + ?keep_names:bool -> + type_expr list -> type_expr -> type_expr list * type_expr +val instance_declaration: type_declaration -> type_declaration +val generic_instance_declaration: type_declaration -> type_declaration + (* Same as instance_declaration, but new nodes at generic_level *) +val instance_class: + type_expr list -> class_type -> type_expr list * class_type + +val instance_poly: + ?keep_names:bool -> + bool -> type_expr list -> type_expr -> type_expr list * type_expr + (* Take an instance of a type scheme containing free univars *) +val polyfy: Env.t -> type_expr -> type_expr list -> type_expr * bool +val instance_label: + bool -> label_description -> type_expr list * type_expr * type_expr + (* Same, for a label *) +val apply: + ?use_current_level:bool -> + Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr + (* [apply [p1...pN] t [a1...aN]] applies the type function + [fun p1 ... pN -> t] to the arguments [a1...aN] and returns the + resulting instance of [t]. + New nodes default to generic level except if [use_current_level] is + set to true. + Exception [Cannot_apply] is raised in case of failure. *) + +val try_expand_once_opt: Env.t -> type_expr -> type_expr +val try_expand_safe_opt: Env.t -> type_expr -> type_expr + +val expand_head_once: Env.t -> type_expr -> type_expr +val expand_head: Env.t -> type_expr -> type_expr +val expand_head_opt: Env.t -> type_expr -> type_expr +(** The compiler's own version of [expand_head] necessary for type-based + optimisations. *) + +(** Expansion of types for error traces; lives here instead of in [Errortrace] + because the expansion machinery lives here. *) + +(** Create an [Errortrace.Diff] by expanding the two types *) +val expanded_diff : + Env.t -> + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +(** Create an [Errortrace.Diff] by *duplicating* the two types, so that each + one's expansion is identical to itself. Despite the name, does create + [Errortrace.expanded_type]s. *) +val unexpanded_diff : + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +val full_expand: may_forget_scope:bool -> Env.t -> type_expr -> type_expr + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + (* The original path of the types, and the first concrete + type declaration found expanding it. *) + | Has_no_typedecl + | May_have_typedecl + +val extract_concrete_typedecl: + Env.t -> type_expr -> typedecl_extraction_result + +val unify: Env.t -> type_expr -> type_expr -> unit + (* Unify the two types given. Raise [Unify] if not possible. *) +val unify_gadt: + equations_level:int -> allow_recursive_equations:bool -> + Env.t ref -> type_expr -> type_expr -> Btype.TypePairs.t + (* Unify the two types given and update the environment with the + local constraints. Raise [Unify] if not possible. + Returns the pairs of types that have been equated. *) +val unify_var: Env.t -> type_expr -> type_expr -> unit + (* Same as [unify], but allow free univars when first type + is a variable. *) +val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr + (* A special case of unification with [l:'a -> 'b]. Raises + [Filter_arrow_failed] instead of [Unify]. *) +val filter_method: Env.t -> string -> type_expr -> type_expr + (* A special case of unification (with {m : 'a; 'b}). Raises + [Filter_method_failed] instead of [Unify]. *) +val occur_in: Env.t -> type_expr -> type_expr -> bool +val deep_occur: type_expr -> type_expr -> bool +val moregeneral: Env.t -> bool -> type_expr -> type_expr -> unit + (* Check if the first type scheme is more general than the second. *) +val is_moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool +val rigidify: type_expr -> type_expr list + (* "Rigidify" a type and return its type variable *) +val all_distinct_vars: Env.t -> type_expr list -> bool + (* Check those types are all distinct type variables *) +val matches: expand_error_trace:bool -> Env.t -> type_expr -> type_expr -> unit + (* Same as [moregeneral false], implemented using the two above + functions and backtracking. Ignore levels. The [expand_error_trace] + flag controls whether the error raised performs expansion; this + should almost always be [true]. *) +val does_match: Env.t -> type_expr -> type_expr -> bool + (* Same as [matches], but returns a [bool] *) + +val reify_univars : Env.t -> Types.type_expr -> Types.type_expr + (* Replaces all the variables of a type by a univar. *) + +(* Exceptions for special cases of unify *) + +type filter_arrow_failure = + | Unification_error of Errortrace.unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +type filter_method_failure = + | Unification_error of Errortrace.unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + +type class_match_failure = + CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of Env.t * Errortrace.equality_error + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of Env.t * Errortrace.moregen_error + | CM_Val_type_mismatch of string * Env.t * Errortrace.comparison_error + | CM_Meth_type_mismatch of string * Env.t * Errortrace.comparison_error + | CM_Non_mutable_value of string + | CM_Non_concrete_value of string + | CM_Missing_value of string + | CM_Missing_method of string + | CM_Hide_public of string + | CM_Hide_virtual of string * string + | CM_Public_method of string + | CM_Private_method of string + | CM_Virtual_method of string + +val match_class_types: + ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list + (* Check if the first class type is more general than the second. *) +val equal: Env.t -> bool -> type_expr list -> type_expr list -> unit + (* [equal env [x1...xn] tau [y1...yn] sigma] + checks whether the parameterized types + [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *) +val is_equal : Env.t -> bool -> type_expr list -> type_expr list -> bool +val equal_private : + Env.t -> type_expr list -> type_expr -> + type_expr list -> type_expr -> unit +(* [equal_private env t1 params1 t2 params2] checks that [t1::params1] + equals [t2::params2] but it is allowed to expand [t1] if it is a + private abbreviations. *) + +val match_class_declarations: + Env.t -> type_expr list -> class_type -> type_expr list -> + class_type -> class_match_failure list + (* Check if the first class type is more general than the second. *) + +val enlarge_type: Env.t -> type_expr -> type_expr * bool + (* Make a type larger, flag is true if some pruning had to be done *) +val subtype: Env.t -> type_expr -> type_expr -> unit -> unit + (* [subtype env t1 t2] checks that [t1] is a subtype of [t2]. + It accumulates the constraints the type variables must + enforce and returns a function that enforces this + constraints. *) + +(* Operations on class signatures *) + +val new_class_signature : unit -> class_signature +val add_dummy_method : Env.t -> scope:int -> class_signature -> unit + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +val add_method : Env.t -> + label -> private_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +val add_instance_variable : strict:bool -> Env.t -> + label -> mutable_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +val inherit_class_signature : strict:bool -> Env.t -> + class_signature -> class_signature -> unit + +val update_class_signature : + Env.t -> class_signature -> label list * label list + +val hide_private_methods : Env.t -> class_signature -> unit + +val close_class_signature : Env.t -> class_signature -> bool + +exception Nondep_cannot_erase of Ident.t + +val nondep_type: Env.t -> Ident.t list -> type_expr -> type_expr + (* Return a type equivalent to the given type but without + references to any of the given identifiers. + Raise [Nondep_cannot_erase id] if no such type exists because [id], + in particular, could not be erased. *) +val nondep_type_decl: + Env.t -> Ident.t list -> bool -> type_declaration -> type_declaration + (* Same for type declarations. *) +val nondep_extension_constructor: + Env.t -> Ident.t list -> extension_constructor -> + extension_constructor + (* Same for extension constructor *) +val nondep_class_declaration: + Env.t -> Ident.t list -> class_declaration -> class_declaration + (* Same for class declarations. *) +val nondep_cltype_declaration: + Env.t -> Ident.t list -> class_type_declaration -> class_type_declaration + (* Same for class type declarations. *) +(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*) +val is_contractive: Env.t -> Path.t -> bool +val normalize_type: type_expr -> unit + +val nongen_vars_in_schema: Env.t -> type_expr -> Btype.TypeSet.t option + (* Return any non-generic variables in the type scheme *) + +val nongen_vars_in_class_declaration:class_declaration -> Btype.TypeSet.t option + (* Return any non-generic variables in the class type. + Uses the empty environment. *) + +type variable_kind = Row_variable | Type_variable +type closed_class_failure = { + free_variable: type_expr * variable_kind; + meth: string; + meth_ty: type_expr; +} + +val free_variables: ?env:Env.t -> type_expr -> type_expr list + (* If env present, then check for incomplete definitions too *) +val closed_type_decl: type_declaration -> type_expr option +val closed_extension_constructor: extension_constructor -> type_expr option +val closed_class: + type_expr list -> class_signature -> + closed_class_failure option + (* Check whether all type variables are bound *) + +val unalias: type_expr -> type_expr + +val arity: type_expr -> int + (* Return the arity (as for curried functions) of the given type. *) + +val collapse_conj_params: Env.t -> type_expr list -> unit + (* Collapse conjunctive types in class parameters *) + +val get_current_level: unit -> int +val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b + +val immediacy : Env.t -> type_expr -> Type_immediacy.t + +(* Stubs *) +val package_subtype : + (Env.t -> Path.t -> (Longident.t * type_expr) list -> + Path.t -> (Longident.t * type_expr) list -> bool) ref + +(* Raises [Incompatible] *) +val mcomp : Env.t -> type_expr -> type_expr -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/datarepr.ml b/ocamlmerlin_mlx/ocaml/typing/datarepr.ml new file mode 100644 index 0000000..004859e --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/datarepr.ml @@ -0,0 +1,238 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compute constructor and label descriptions from type declarations, + determining their representation. *) + +open Asttypes +open Types +open Btype + +(* Simplified version of Ctype.free_vars *) +let free_vars ?(param=false) ty = + let ret = ref TypeSet.empty in + let rec loop ty = + if try_mark_node ty then + match get_desc ty with + | Tvar _ -> + ret := TypeSet.add ty !ret + | Tvariant row -> + iter_row loop row; + if not (static_row row) then begin + match get_desc (row_more row) with + | Tvar _ when param -> ret := TypeSet.add ty !ret + | _ -> loop (row_more row) + end + (* XXX: What about Tobject ? *) + | _ -> + iter_type_expr loop ty + in + loop ty; + unmark_type ty; + !ret + +let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) + +let constructor_existentials cd_args cd_res = + let tyl = + match cd_args with + | Cstr_tuple l -> l + | Cstr_record l -> List.map (fun l -> l.ld_type) l + in + let existentials = + match cd_res with + | None -> [] + | Some type_ret -> + let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in + let res_vars = free_vars type_ret in + TypeSet.elements (TypeSet.diff arg_vars_set res_vars) + in + (tyl, existentials) + +let constructor_args ~current_unit priv cd_args cd_res path rep = + let tyl, existentials = constructor_existentials cd_args cd_res in + match cd_args with + | Cstr_tuple l -> existentials, l, None + | Cstr_record lbls -> + let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in + let type_params = TypeSet.elements arg_vars_set in + let arity = List.length type_params in + let tdecl = + { + type_params; + type_arity = arity; + type_kind = Type_record (lbls, rep); + type_private = priv; + type_manifest = None; + type_variance = Variance.unknown_signature ~injective:true ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = Location.none; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.mk ~current_unit; + } + in + existentials, + [ newgenconstr path type_params ], + Some tdecl + +let constructor_descrs ~current_unit ty_path decl cstrs rep = + let ty_res = newgenconstr ty_path decl.type_params in + let num_consts = ref 0 and num_nonconsts = ref 0 in + List.iter + (fun {cd_args; _} -> + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts) + cstrs; + let rec describe_constructors idx_const idx_nonconst = function + [] -> [] + | {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_uid} :: rem -> + let ty_res = + match cd_res with + | Some ty_res' -> ty_res' + | None -> ty_res + in + let (tag, descr_rem) = + match cd_args, rep with + | _, Variant_unboxed -> + assert (rem = []); + (Cstr_unboxed, []) + | Cstr_tuple [], Variant_regular -> + (Cstr_constant idx_const, + describe_constructors (idx_const+1) idx_nonconst rem) + | _, Variant_regular -> + (Cstr_block idx_nonconst, + describe_constructors idx_const (idx_nonconst+1) rem) in + let cstr_name = Ident.name cd_id in + let existentials, cstr_args, cstr_inlined = + let representation = + match rep with + | Variant_unboxed -> Record_unboxed true + | Variant_regular -> Record_inlined idx_nonconst + in + constructor_args ~current_unit decl.type_private cd_args cd_res + Path.(Pextra_ty (ty_path, Pcstr_ty cstr_name)) representation + in + let cstr = + { cstr_name; + cstr_res = ty_res; + cstr_existentials = existentials; + cstr_args; + cstr_arity = List.length cstr_args; + cstr_tag = tag; + cstr_consts = !num_consts; + cstr_nonconsts = !num_nonconsts; + cstr_private = decl.type_private; + cstr_generalized = cd_res <> None; + cstr_loc = cd_loc; + cstr_attributes = cd_attributes; + cstr_inlined; + cstr_uid = cd_uid; + } in + (cd_id, cstr) :: descr_rem in + describe_constructors 0 0 cstrs + +let extension_descr ~current_unit path_ext ext = + let ty_res = + match ext.ext_ret_type with + Some type_ret -> type_ret + | None -> newgenconstr ext.ext_type_path ext.ext_type_params + in + let existentials, cstr_args, cstr_inlined = + constructor_args ~current_unit ext.ext_private ext.ext_args ext.ext_ret_type + Path.(Pextra_ty (path_ext, Pext_ty)) (Record_extension path_ext) + in + { cstr_name = Path.last path_ext; + cstr_res = ty_res; + cstr_existentials = existentials; + cstr_args; + cstr_arity = List.length cstr_args; + cstr_tag = Cstr_extension(path_ext, cstr_args = []); + cstr_consts = -1; + cstr_nonconsts = -1; + cstr_private = ext.ext_private; + cstr_generalized = ext.ext_ret_type <> None; + cstr_loc = ext.ext_loc; + cstr_attributes = ext.ext_attributes; + cstr_inlined; + cstr_uid = ext.ext_uid; + } + +let none = + create_expr (Ttuple []) ~level:(-1) ~scope:Btype.generic_level ~id:(-1) + (* Clearly ill-formed type *) + +let dummy_label = + { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; + lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; + lbl_private = Public; + lbl_loc = Location.none; + lbl_attributes = []; + lbl_uid = Uid.internal_not_actually_unique; + } + +let label_descrs ty_res lbls repres priv = + let all_labels = Array.make (List.length lbls) dummy_label in + let rec describe_labels num = function + [] -> [] + | l :: rest -> + let lbl = + { lbl_name = Ident.name l.ld_id; + lbl_res = ty_res; + lbl_arg = l.ld_type; + lbl_mut = l.ld_mutable; + lbl_pos = num; + lbl_all = all_labels; + lbl_repres = repres; + lbl_private = priv; + lbl_loc = l.ld_loc; + lbl_attributes = l.ld_attributes; + lbl_uid = l.ld_uid; + } in + all_labels.(num) <- lbl; + (l.ld_id, lbl) :: describe_labels (num+1) rest in + describe_labels 0 lbls + +exception Constr_not_found + +let rec find_constr tag num_const num_nonconst = function + [] -> + raise Constr_not_found + | {cd_args = Cstr_tuple []; _} as c :: rem -> + if tag = Cstr_constant num_const + then c + else find_constr tag (num_const + 1) num_nonconst rem + | c :: rem -> + if tag = Cstr_block num_nonconst || tag = Cstr_unboxed + then c + else find_constr tag num_const (num_nonconst + 1) rem + +let find_constr_by_tag tag cstrlist = + find_constr tag 0 0 cstrlist + +let constructors_of_type ~current_unit ty_path decl = + match decl.type_kind with + | Type_variant (cstrs,rep) -> + constructor_descrs ~current_unit ty_path decl cstrs rep + | Type_record _ | Type_abstract | Type_open -> [] + +let labels_of_type ty_path decl = + match decl.type_kind with + | Type_record(labels, rep) -> + label_descrs (newgenconstr ty_path decl.type_params) + labels rep decl.type_private + | Type_variant _ | Type_abstract | Type_open -> [] diff --git a/ocamlmerlin_mlx/ocaml/typing/datarepr.mli b/ocamlmerlin_mlx/ocaml/typing/datarepr.mli new file mode 100644 index 0000000..38f05f7 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/datarepr.mli @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Compute constructor and label descriptions from type declarations, + determining their representation. *) + +open Types + +val extension_descr: + current_unit:string -> Path.t -> extension_constructor -> + constructor_description + +val labels_of_type: + Path.t -> type_declaration -> + (Ident.t * label_description) list +val constructors_of_type: + current_unit:string -> Path.t -> type_declaration -> + (Ident.t * constructor_description) list + + +exception Constr_not_found + +val find_constr_by_tag: + constructor_tag -> constructor_declaration list -> + constructor_declaration + +val constructor_existentials : + constructor_arguments -> type_expr option -> type_expr list * type_expr list +(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and + returns: + - the types of the constructor's arguments + - the existential variables introduced by the constructor + *) diff --git a/ocamlmerlin_mlx/ocaml/typing/dune b/ocamlmerlin_mlx/ocaml/typing/dune new file mode 100644 index 0000000..9212932 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/dune @@ -0,0 +1,21 @@ +(library + (name mlx_ocaml_typing) + (package ocamlmerlin-mlx) + (flags + -open=Mlx_ocaml_utils + -open=Mlx_ocaml_parsing + -open=Mlx_ocaml_compression + -open=Mlx_utils + (:standard -w -9)) + (modules_without_implementation annot outcometree) + (libraries + mlx_utils + mlx_ocaml_parsing + mlx_ocaml_compression + mlx_ocaml_utils)) + +(copy_files + (enabled_if + (<> %{profile} "release")) + (mode promote) + (files %{project_root}/merlin/src/ocaml/typing/*.{ml,mli})) diff --git a/ocamlmerlin_mlx/ocaml/typing/env.ml b/ocamlmerlin_mlx/ocaml/typing/env.ml new file mode 100644 index 0000000..986b46d --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/env.ml @@ -0,0 +1,4137 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Environment handling *) + +open Cmi_format +open Misc +open Asttypes +open Longident +open Path +open Types + +open Local_store + +module String = Misc.String + +let add_delayed_check_forward = ref (fun _ -> assert false) + +type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t +(** This table is used to track usage of value declarations. + A declaration is identified by its uid. + The callback attached to a declaration is called whenever the value (or + type, or ...) is used explicitly (lookup_value, ...) or implicitly + (inclusion test between signatures, cf Includemod.value_descriptions, ...). +*) + +let value_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 +let type_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 +let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 + +let uid_to_loc : Location.t Types.Uid.Tbl.t ref = + s_table Types.Uid.Tbl.create 16 + +let register_uid uid loc = Types.Uid.Tbl.add !uid_to_loc uid loc + +let get_uid_to_loc_tbl () = !uid_to_loc + +type constructor_usage = Positive | Pattern | Exported_private | Exported +type constructor_usages = + { + mutable cu_positive: bool; + mutable cu_pattern: bool; + mutable cu_exported_private: bool; + } +let add_constructor_usage cu usage = + match usage with + | Positive -> cu.cu_positive <- true + | Pattern -> cu.cu_pattern <- true + | Exported_private -> cu.cu_exported_private <- true + | Exported -> + cu.cu_positive <- true; + cu.cu_pattern <- true; + cu.cu_exported_private <- true + +let constructor_usages () = + {cu_positive = false; cu_pattern = false; cu_exported_private = false} + +let constructor_usage_complaint ~rebind priv cu + : Warnings.constructor_usage_warning option = + match priv, rebind with + | Asttypes.Private, _ | _, true -> + if cu.cu_positive || cu.cu_pattern || cu.cu_exported_private then None + else Some Unused + | Asttypes.Public, false -> begin + match cu.cu_positive, cu.cu_pattern, cu.cu_exported_private with + | true, _, _ -> None + | false, false, false -> Some Unused + | false, true, _ -> Some Not_constructed + | false, false, true -> Some Only_exported_private + end + +let used_constructors : constructor_usage usage_tbl ref = + s_table Types.Uid.Tbl.create 16 + +type label_usage = + Projection | Mutation | Construct | Exported_private | Exported +type label_usages = + { + mutable lu_projection: bool; + mutable lu_mutation: bool; + mutable lu_construct: bool; + } +let add_label_usage lu usage = + match usage with + | Projection -> lu.lu_projection <- true; + | Mutation -> lu.lu_mutation <- true + | Construct -> lu.lu_construct <- true + | Exported_private -> + lu.lu_projection <- true + | Exported -> + lu.lu_projection <- true; + lu.lu_mutation <- true; + lu.lu_construct <- true + +let is_mutating_label_usage = function + | Mutation -> true + | (Projection | Construct | Exported_private | Exported) -> false + +let label_usages () = + {lu_projection = false; lu_mutation = false; lu_construct = false} + +let label_usage_complaint priv mut lu + : Warnings.field_usage_warning option = + match priv, mut with + | Asttypes.Private, _ -> + if lu.lu_projection then None + else Some Unused + | Asttypes.Public, Asttypes.Immutable -> begin + match lu.lu_projection, lu.lu_construct with + | true, _ -> None + | false, false -> Some Unused + | false, true -> Some Not_read + end + | Asttypes.Public, Asttypes.Mutable -> begin + match lu.lu_projection, lu.lu_mutation, lu.lu_construct with + | true, true, _ -> None + | false, false, false -> Some Unused + | false, _, _ -> Some Not_read + | true, false, _ -> Some Not_mutated + end + +let used_labels : label_usage usage_tbl ref = + s_table Types.Uid.Tbl.create 16 + +(** Map indexed by the name of module components. *) +module NameMap = String.Map + +type value_unbound_reason = + | Val_unbound_instance_variable + | Val_unbound_self + | Val_unbound_ancestor + | Val_unbound_ghost_recursive of Location.t + +type module_unbound_reason = + | Mod_unbound_illegal_recursion + +type summary = + Env_empty + | Env_value of summary * Ident.t * value_description + | Env_type of summary * Ident.t * type_declaration + | Env_extension of summary * Ident.t * extension_constructor + | Env_module of summary * Ident.t * module_presence * module_declaration + | Env_modtype of summary * Ident.t * modtype_declaration + | Env_class of summary * Ident.t * class_declaration + | Env_cltype of summary * Ident.t * class_type_declaration + | Env_open of summary * Path.t + | Env_functor_arg of summary * Ident.t + | Env_constraints of summary * type_declaration Path.Map.t + | Env_copy_types of summary + | Env_persistent of summary * Ident.t + | Env_value_unbound of summary * string * value_unbound_reason + | Env_module_unbound of summary * string * module_unbound_reason + +let map_summary f = function + Env_empty -> Env_empty + | Env_value (s, id, d) -> Env_value (f s, id, d) + | Env_type (s, id, d) -> Env_type (f s, id, d) + | Env_extension (s, id, d) -> Env_extension (f s, id, d) + | Env_module (s, id, p, d) -> Env_module (f s, id, p, d) + | Env_modtype (s, id, d) -> Env_modtype (f s, id, d) + | Env_class (s, id, d) -> Env_class (f s, id, d) + | Env_cltype (s, id, d) -> Env_cltype (f s, id, d) + | Env_open (s, p) -> Env_open (f s, p) + | Env_functor_arg (s, id) -> Env_functor_arg (f s, id) + | Env_constraints (s, m) -> Env_constraints (f s, m) + | Env_copy_types s -> Env_copy_types (f s) + | Env_persistent (s, id) -> Env_persistent (f s, id) + | Env_value_unbound (s, u, r) -> Env_value_unbound (f s, u, r) + | Env_module_unbound (s, u, r) -> Env_module_unbound (f s, u, r) + +type address = + | Aident of Ident.t + | Adot of address * int + +module TycompTbl = + struct + (** This module is used to store components of types (i.e. labels + and constructors). We keep a representation of each nested + "open" and the set of local bindings between each of them. *) + + type 'a t = { + current: 'a Ident.tbl; + (** Local bindings since the last open. *) + + opened: 'a opened option; + (** Symbolic representation of the last (innermost) open, if any. *) + } + + and 'a opened = { + components: ('a list) NameMap.t; + (** Components from the opened module. We keep a list of + bindings for each name, as in comp_labels and + comp_constrs. *) + + root: Path.t; + (** Only used to check removal of open *) + + using: (string -> ('a * 'a) option -> unit) option; + (** A callback to be applied when a component is used from this + "open". This is used to detect unused "opens". The + arguments are used to detect shadowing. *) + + next: 'a t; + (** The table before opening the module. *) + } + + let empty = { current = Ident.empty; opened = None } + + let add id x tbl = + {tbl with current = Ident.add id x tbl.current} + + let add_open slot wrap root components next = + let using = + match slot with + | None -> None + | Some f -> Some (fun s x -> f s (wrap x)) + in + { + current = Ident.empty; + opened = Some {using; components; root; next}; + } + + let remove_last_open rt tbl = + match tbl.opened with + | Some {root; next; _} when Path.same rt root -> + { next with current = + Ident.fold_all Ident.add tbl.current next.current } + | _ -> + assert false + + let rec find_same id tbl = + try Ident.find_same id tbl.current + with Not_found as exn -> + begin match tbl.opened with + | Some {next; _} -> find_same id next + | None -> raise exn + end + + let nothing = fun () -> () + + let mk_callback rest name desc using = + match using with + | None -> nothing + | Some f -> + (fun () -> + match rest with + | [] -> f name None + | (hidden, _) :: _ -> f name (Some (desc, hidden))) + + let rec find_all ~mark name tbl = + List.map (fun (_id, desc) -> desc, nothing) + (Ident.find_all name tbl.current) @ + match tbl.opened with + | None -> [] + | Some {using; next; components; root = _} -> + let rest = find_all ~mark name next in + let using = if mark then using else None in + match NameMap.find name components with + | exception Not_found -> rest + | opened -> + List.map + (fun desc -> desc, mk_callback rest name desc using) + opened + @ rest + + let rec fold_name f tbl acc = + let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in + match tbl.opened with + | Some {using = _; next; components; root = _} -> + acc + |> NameMap.fold + (fun _name -> List.fold_right f) + components + |> fold_name f next + | None -> + acc + + let rec local_keys tbl acc = + let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in + match tbl.opened with + | Some o -> local_keys o.next acc + | None -> acc + + let diff_keys is_local tbl1 tbl2 = + let keys2 = local_keys tbl2 [] in + List.filter + (fun id -> + is_local (find_same id tbl2) && + try ignore (find_same id tbl1); false + with Not_found -> true) + keys2 + + end + + +module IdTbl = + struct + (** This module is used to store all kinds of components except + (labels and constructors) in environments. We keep a + representation of each nested "open" and the set of local + bindings between each of them. *) + + + type ('a, 'b) t = { + current: 'a Ident.tbl; + (** Local bindings since the last open *) + + layer: ('a, 'b) layer; + (** Symbolic representation of the last (innermost) open, if any. *) + } + + and ('a, 'b) layer = + | Open of { + root: Path.t; + (** The path of the opened module, to be prefixed in front of + its local names to produce a valid path in the current + environment. *) + + components: 'b NameMap.t; + (** Components from the opened module. *) + + using: (string -> ('a * 'a) option -> unit) option; + (** A callback to be applied when a component is used from this + "open". This is used to detect unused "opens". The + arguments are used to detect shadowing. *) + + next: ('a, 'b) t; + (** The table before opening the module. *) + } + + | Map of { + f: ('a -> 'a); + next: ('a, 'b) t; + } + + | Nothing + + let empty = { current = Ident.empty; layer = Nothing } + + let add id x tbl = + {tbl with current = Ident.add id x tbl.current} + + let remove id tbl = + {tbl with current = Ident.remove id tbl.current} + + let add_open slot wrap root components next = + let using = + match slot with + | None -> None + | Some f -> Some (fun s x -> f s (wrap x)) + in + { + current = Ident.empty; + layer = Open {using; root; components; next}; + } + + let remove_last_open rt tbl = + match tbl.layer with + | Open {root; next; _} when Path.same rt root -> + { next with current = + Ident.fold_all Ident.add tbl.current next.current } + | _ -> + assert false + + let map f next = + { + current = Ident.empty; + layer = Map {f; next} + } + + let rec find_same id tbl = + try Ident.find_same id tbl.current + with Not_found as exn -> + begin match tbl.layer with + | Open {next; _} -> find_same id next + | Map {f; next} -> f (find_same id next) + | Nothing -> raise exn + end + + let rec find_name wrap ~mark name tbl = + try + let (id, desc) = Ident.find_name name tbl.current in + Pident id, desc + with Not_found as exn -> + begin match tbl.layer with + | Open {using; root; next; components} -> + begin try + let descr = wrap (NameMap.find name components) in + let res = Pdot (root, name), descr in + if mark then begin match using with + | None -> () + | Some f -> begin + match find_name wrap ~mark:false name next with + | exception Not_found -> f name None + | _, descr' -> f name (Some (descr', descr)) + end + end; + res + with Not_found -> + find_name wrap ~mark name next + end + | Map {f; next} -> + let (p, desc) = find_name wrap ~mark name next in + p, f desc + | Nothing -> + raise exn + end + + let rec find_all wrap name tbl = + List.map + (fun (id, desc) -> Pident id, desc) + (Ident.find_all name tbl.current) @ + match tbl.layer with + | Nothing -> [] + | Open {root; using = _; next; components} -> + begin try + let desc = wrap (NameMap.find name components) in + (Pdot (root, name), desc) :: find_all wrap name next + with Not_found -> + find_all wrap name next + end + | Map {f; next} -> + List.map (fun (p, desc) -> (p, f desc)) + (find_all wrap name next) + + let rec find_all_idents name tbl () = + let current = + Ident.find_all_seq name tbl.current + |> Seq.map (fun (id, _) -> Some id) + in + let next () = + match tbl.layer with + | Nothing -> Seq.Nil + | Open { next; components; _ } -> + if NameMap.mem name components then + Seq.Cons(None, find_all_idents name next) + else + find_all_idents name next () + | Map {next; _ } -> find_all_idents name next () + in + Seq.append current next () + + let rec fold_name wrap f tbl acc = + let acc = + Ident.fold_name + (fun id d -> f (Ident.name id) (Pident id, d)) + tbl.current acc + in + match tbl.layer with + | Open {root; using = _; next; components} -> + acc + |> NameMap.fold + (fun name desc -> f name (Pdot (root, name), wrap desc)) + components + |> fold_name wrap f next + | Nothing -> + acc + | Map {f=g; next} -> + acc + |> fold_name wrap + (fun name (path, desc) -> f name (path, g desc)) + next + + let rec local_keys tbl acc = + let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in + match tbl.layer with + | Open {next; _ } | Map {next; _} -> local_keys next acc + | Nothing -> acc + + + let rec iter wrap f tbl = + Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; + match tbl.layer with + | Open {root; using = _; next; components} -> + NameMap.iter + (fun s x -> + let root_scope = Path.scope root in + f (Ident.create_scoped ~scope:root_scope s) + (Pdot (root, s), wrap x)) + components; + iter wrap f next + | Map {f=g; next} -> + iter wrap (fun id (path, desc) -> f id (path, g desc)) next + | Nothing -> () + + let diff_keys tbl1 tbl2 = + let keys2 = local_keys tbl2 [] in + List.filter + (fun id -> + try ignore (find_same id tbl1); false + with Not_found -> true) + keys2 + + + end + +type type_descr_kind = + (label_description, constructor_description) type_kind + +type type_descriptions = type_descr_kind + +let in_signature_flag = 0x01 + +let stamped_changelog = + s_table Stamped_hashtable.create_changelog () + +let stamped_add table path value = + let rec path_stamp = function + | Pident id -> Ident.stamp id + | Pdot (t, _) -> path_stamp t + | Papply (t1, t2) -> Int.max (path_stamp t1) (path_stamp t2) + | Pextra_ty (t, _) -> path_stamp t + in + let stamp = path_stamp path in + let stamp = if stamp = 0 then None else Some stamp in + Stamped_hashtable.add table ?stamp path value + +let stamped_mem table path = + Stamped_hashtable.mem table path + +let stamped_find table path = + Stamped_hashtable.find table path + +let stamped_create n = + Stamped_hashtable.create !stamped_changelog n + +type t = { + values: (value_entry, value_data) IdTbl.t; + constrs: constructor_data TycompTbl.t; + labels: label_data TycompTbl.t; + types: (type_data, type_data) IdTbl.t; + modules: (module_entry, module_data) IdTbl.t; + modtypes: (modtype_data, modtype_data) IdTbl.t; + classes: (class_data, class_data) IdTbl.t; + cltypes: (cltype_data, cltype_data) IdTbl.t; + functor_args: unit Ident.tbl; + summary: summary; + local_constraints: type_declaration Path.Map.t; + flags: int; + short_paths: Short_paths.t option; + short_paths_additions: short_paths_addition list; +} + +and module_components = + { + alerts: alerts; + uid: Uid.t; + comps: + (components_maker, + (module_components_repr, module_components_failure) result) + Lazy_backtrack.t; + } + +and components_maker = { + cm_env: t; + cm_prefixing_subst: Subst.t; + cm_path: Path.t; + cm_addr: address_lazy; + cm_mty: Subst.Lazy.modtype; + cm_shape: Shape.t; +} + +and module_components_repr = + Structure_comps of structure_components + | Functor_comps of functor_components + +and module_components_failure = + | No_components_abstract + | No_components_alias of Path.t + +and structure_components = { + mutable comp_values: value_data NameMap.t; + mutable comp_constrs: constructor_data list NameMap.t; + mutable comp_labels: label_data list NameMap.t; + mutable comp_types: type_data NameMap.t; + mutable comp_modules: module_data NameMap.t; + mutable comp_modtypes: modtype_data NameMap.t; + mutable comp_classes: class_data NameMap.t; + mutable comp_cltypes: cltype_data NameMap.t; +} + +and functor_components = { + fcomp_arg: functor_parameter; + (* Formal parameter and argument signature *) + fcomp_res: module_type; (* Result signature *) + fcomp_shape: Shape.t; + fcomp_cache: (Path.t, module_components) Stamped_hashtable.t; (* For memoization *) + fcomp_subst_cache: (Path.t, module_type) Stamped_hashtable.t; +} + +and address_unforced = + | Projection of { parent : address_lazy; pos : int; } + | ModAlias of { env : t; path : Path.t; } + +and address_lazy = (address_unforced, address) Lazy_backtrack.t + +and value_data = + { vda_description : value_description; + vda_address : address_lazy; + vda_shape : Shape.t } + +and value_entry = + | Val_bound of value_data + | Val_unbound of value_unbound_reason + +and constructor_data = + { cda_description : constructor_description; + cda_address : address_lazy option; + cda_shape: Shape.t; } + +and label_data = label_description + +and type_data = + { tda_declaration : type_declaration; + tda_descriptions : type_descriptions; + tda_shape : Shape.t; } + +and module_data = + { mda_declaration : Subst.Lazy.module_decl; + mda_components : module_components; + mda_address : address_lazy; + mda_shape: Shape.t; } + +and module_entry = + | Mod_local of module_data + | Mod_persistent + | Mod_unbound of module_unbound_reason + +and modtype_data = + { mtda_declaration : Subst.Lazy.modtype_declaration; + mtda_shape : Shape.t; } + +and class_data = + { clda_declaration : class_declaration; + clda_address : address_lazy; + clda_shape : Shape.t } + +and cltype_data = + { cltda_declaration : class_type_declaration; + cltda_shape : Shape.t } + +and short_paths_addition = + | Type of Ident.t * type_declaration + | Class_type of Ident.t * class_type_declaration + | Module_type of Ident.t * modtype_declaration + | Module of Ident.t * module_declaration * module_components + | Type_open of Path.t * type_data NameMap.t + | Class_type_open of Path.t * class_type_declaration NameMap.t + | Module_type_open of Path.t * modtype_declaration NameMap.t + | Module_open of Path.t * module_data NameMap.t + +let empty_structure = + Structure_comps { + comp_values = NameMap.empty; + comp_constrs = NameMap.empty; + comp_labels = NameMap.empty; + comp_types = NameMap.empty; + comp_modules = NameMap.empty; comp_modtypes = NameMap.empty; + comp_classes = NameMap.empty; + comp_cltypes = NameMap.empty } + +type unbound_value_hint = + | No_hint + | Missing_rec of Location.t + +type lookup_error = + | Unbound_value of Longident.t * unbound_value_hint + | Unbound_type of Longident.t + | Unbound_constructor of Longident.t + | Unbound_label of Longident.t + | Unbound_module of Longident.t + | Unbound_class of Longident.t + | Unbound_modtype of Longident.t + | Unbound_cltype of Longident.t + | Unbound_instance_variable of string + | Not_an_instance_variable of string + | Masked_instance_variable of Longident.t + | Masked_self_variable of Longident.t + | Masked_ancestor_variable of Longident.t + | Structure_used_as_functor of Longident.t + | Abstract_used_as_functor of Longident.t + | Functor_used_as_structure of Longident.t + | Abstract_used_as_structure of Longident.t + | Generative_used_as_applicative of Longident.t + | Illegal_reference_to_recursive_module + | Cannot_scrape_alias of Longident.t * Path.t + +type error = + | Missing_module of Location.t * Path.t * Path.t + | Illegal_value_name of Location.t * string + | Lookup_error of Location.t * t * lookup_error + +exception Error of error + +let error err = raise (Error err) + +let lookup_error loc env err = + error (Lookup_error(loc, env, err)) + +let same_constr = ref (fun _ _ _ -> assert false) + +let check_well_formed_module = ref (fun _ -> assert false) + +(* Helper to decide whether to report an identifier shadowing + by some 'open'. For labels and constructors, we do not report + if the two elements are from the same re-exported declaration. + + Later, one could also interpret some attributes on value and + type declarations to silence the shadowing warnings. *) + +let check_shadowing env = function + | `Constructor (Some (cda1, cda2)) + when not (!same_constr env + cda1.cda_description.cstr_res + cda2.cda_description.cstr_res) -> + Some "constructor" + | `Label (Some (l1, l2)) + when not (!same_constr env l1.lbl_res l2.lbl_res) -> + Some "label" + | `Value (Some _) -> Some "value" + | `Type (Some _) -> Some "type" + | `Module (Some _) | `Component (Some _) -> Some "module" + | `Module_type (Some _) -> Some "module type" + | `Class (Some _) -> Some "class" + | `Class_type (Some _) -> Some "class type" + | `Constructor _ | `Label _ + | `Value None | `Type None | `Module None | `Module_type None + | `Class None | `Class_type None | `Component None -> + None + +let empty = { + values = IdTbl.empty; constrs = TycompTbl.empty; + labels = TycompTbl.empty; types = IdTbl.empty; + modules = IdTbl.empty; modtypes = IdTbl.empty; + classes = IdTbl.empty; cltypes = IdTbl.empty; + summary = Env_empty; local_constraints = Path.Map.empty; + flags = 0; + functor_args = Ident.empty; + short_paths = None; + short_paths_additions = []; + } + +let in_signature b env = + let flags = + if b then env.flags lor in_signature_flag + else env.flags land (lnot in_signature_flag) + in + {env with flags} + +let is_in_signature env = env.flags land in_signature_flag <> 0 + +let has_local_constraints env = + not (Path.Map.is_empty env.local_constraints) + +let is_ext cda = + match cda.cda_description with + | {cstr_tag = Cstr_extension _} -> true + | _ -> false + +let is_local_ext cda = + match cda.cda_description with + | {cstr_tag = Cstr_extension(p, _)} -> begin + match p with + | Pident _ -> true + | Pdot _ | Papply _ | Pextra_ty _ -> false + end + | _ -> false + +let diff env1 env2 = + IdTbl.diff_keys env1.values env2.values @ + TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs @ + IdTbl.diff_keys env1.modules env2.modules @ + IdTbl.diff_keys env1.classes env2.classes + +(* Functions for use in "wrap" parameters in IdTbl *) +let wrap_identity x = x +let wrap_value vda = Val_bound vda +let wrap_module mda = Mod_local mda + +(* Forward declarations *) + +let components_of_module_maker' = + ref ((fun _ -> assert false) : + components_maker -> + (module_components_repr, module_components_failure) result) + +let components_of_functor_appl' = + ref ((fun ~loc:_ ~f_path:_ ~f_comp:_ ~arg:_ _env -> assert false) : + loc:Location.t -> f_path:Path.t -> f_comp:functor_components -> + arg:Path.t -> t -> module_components) +let check_functor_application = + (* to be filled by Includemod *) + ref ((fun ~errors:_ ~loc:_ + ~lid_whole_app:_ ~f0_path:_ ~args:_ + ~arg_path:_ ~arg_mty:_ ~param_mty:_ + _env + -> assert false) : + errors:bool -> loc:Location.t -> + lid_whole_app:Longident.t -> + f0_path:Path.t -> args:(Path.t * Types.module_type) list -> + arg_path:Path.t -> arg_mty:module_type -> param_mty:module_type -> + t -> unit) +let strengthen = + (* to be filled with Mtype.strengthen *) + ref ((fun ~aliasable:_ _env _mty _path -> assert false) : + aliasable:bool -> t -> Subst.Lazy.modtype -> + Path.t -> Subst.Lazy.modtype) + +let shorten_module_path = + (* to be filled with Printtyp.shorten_module_path *) + ref ((fun _ _ -> assert false) : + t -> Path.t -> Path.t) + +let md md_type = + {md_type; md_attributes=[]; md_loc=Location.none + ;md_uid = Uid.internal_not_actually_unique} + +(* Print addresses *) + +let rec print_address ppf = function + | Aident id -> Format.fprintf ppf "%s" (Ident.name id) + | Adot(a, pos) -> Format.fprintf ppf "%a.[%i]" print_address a pos + +(* The name of the compilation unit currently compiled. + "" if outside a compilation unit. *) +module Current_unit_name : sig + val get : unit -> modname + val set : modname -> unit + val is : modname -> bool + val is_ident : Ident.t -> bool + val is_path : Path.t -> bool +end = struct + let current_unit = + ref "" + let get () = + !current_unit + let set name = + current_unit := name + let is name = + !current_unit = name + let is_ident id = + Ident.persistent id && is (Ident.name id) + let is_path = function + | Pident id -> is_ident id + | Pdot _ | Papply _ | Pextra_ty _ -> false +end + +let set_unit_name = Current_unit_name.set +let get_unit_name = Current_unit_name.get + +let find_same_module id tbl = + match IdTbl.find_same id tbl with + | x -> x + | exception Not_found + when Ident.persistent id && not (Current_unit_name.is_ident id) -> + Mod_persistent + +let find_name_module ~mark name tbl = + match IdTbl.find_name wrap_module ~mark name tbl with + | x -> x + | exception Not_found when not (Current_unit_name.is name) -> + let path = Pident(Ident.create_persistent name) in + path, Mod_persistent + +(* Short paths basis *) + +let short_paths_module_components_desc' = ref (fun _ -> assert false) + +let short_paths_components name pm = + let path = Pident (Ident.create_persistent name) in + lazy (!short_paths_module_components_desc' empty path pm.mda_components) + +let add_persistent_structure id env = + if not (Ident.persistent id) then invalid_arg "Env.add_persistent_structure"; + if Current_unit_name.is_ident id then env + else begin + let material = + (* This addition only observably changes the environment if it shadows a + non-persistent module already in the environment. + (See PR#9345) *) + match + IdTbl.find_name wrap_module ~mark:false (Ident.name id) env.modules + with + | exception Not_found | _, Mod_persistent -> false + | _ -> true + in + let summary = + if material then Env_persistent (env.summary, id) + else env.summary + in + let modules = + (* With [-no-alias-deps], non-material additions should not + affect the environment at all. We should only observe the + existence of a cmi when accessing components of the module. + (See #9991). *) + if material || not !Clflags.transparent_modules then + IdTbl.add id Mod_persistent env.modules + else + env.modules + in + { env with modules; summary } + end + +let components_of_module ~alerts ~uid env ps path addr mty shape = + { + alerts; + uid; + comps = Lazy_backtrack.create { + cm_env = env; + cm_prefixing_subst = ps; + cm_path = path; + cm_addr = addr; + cm_mty = mty; + cm_shape = shape; + } + } + +let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } = + let name = cmi.cmi_name in + let sign = cmi.cmi_sign in + let flags = cmi.cmi_flags in + let id_subst = Subst.(make_loc_ghost identity) in + let id = Ident.create_persistent name in + let path = Pident id in + let alerts = + List.fold_left (fun acc -> function Alerts s -> s | _ -> acc) + Misc.String.Map.empty + flags + in + let md = + { md_type = Mty_signature sign; + md_loc = Location.none; + md_attributes = []; + md_uid = Uid.of_compilation_unit_id id; + } + in + let mda_address = Lazy_backtrack.create_forced (Aident id) in + let mda_declaration = + Subst.(Lazy.module_decl Make_local id_subst (Lazy.of_module_decl md)) + in + let mda_shape = Shape.for_persistent_unit name in + let mda_components = + let mty = Subst.Lazy.of_modtype (Mty_signature sign) in + let mty = + if freshen then + Subst.Lazy.modtype (Subst.Rescope (Path.scope path)) + id_subst mty + else mty + in + components_of_module ~alerts ~uid:md.md_uid + empty Subst.identity + path mda_address mty mda_shape + in + { + mda_declaration; + mda_components; + mda_address; + mda_shape; + } + +let read_sign_of_cmi = sign_of_cmi ~freshen:true + +let save_sign_of_cmi = sign_of_cmi ~freshen:false + +let persistent_env : module_data Persistent_env.t ref = + s_table Persistent_env.empty () + +let without_cmis f x = + Persistent_env.without_cmis !persistent_env f x + +let imports () = Persistent_env.imports !persistent_env + +let import_crcs ~source crcs = + Persistent_env.import_crcs !persistent_env ~source crcs + +let read_pers_mod modname filename = + Persistent_env.read !persistent_env + read_sign_of_cmi short_paths_components modname filename + +let find_pers_mod name = + Persistent_env.find !persistent_env + read_sign_of_cmi short_paths_components name + +let check_pers_mod ~loc name = + Persistent_env.check !persistent_env + read_sign_of_cmi short_paths_components ~loc name + +let crc_of_unit name = + Persistent_env.crc_of_unit !persistent_env + read_sign_of_cmi short_paths_components name + +let is_imported_opaque modname = + Persistent_env.is_imported_opaque !persistent_env modname + +let register_import_as_opaque modname = + Persistent_env.register_import_as_opaque !persistent_env modname + +let reset_declaration_caches () = + Types.Uid.Tbl.clear !value_declarations; + Types.Uid.Tbl.clear !type_declarations; + Types.Uid.Tbl.clear !module_declarations; + Types.Uid.Tbl.clear !used_constructors; + Types.Uid.Tbl.clear !used_labels; + Types.Uid.Tbl.clear !uid_to_loc; + () + +let reset_cache () = + Current_unit_name.set ""; + Persistent_env.clear !persistent_env; + reset_declaration_caches (); + () + +let reset_cache_toplevel () = + Persistent_env.clear_missing !persistent_env; + reset_declaration_caches (); + () + +(* get_components *) + +let get_components_res c = + match Persistent_env.can_load_cmis !persistent_env with + | Persistent_env.Can_load_cmis -> + Lazy_backtrack.force !components_of_module_maker' c.comps + | Persistent_env.Cannot_load_cmis log -> + Lazy_backtrack.force_logged log !components_of_module_maker' c.comps + +let get_components c = + match get_components_res c with + | Error _ -> empty_structure + | Ok c -> c + +(* Module type of functor application *) + +let modtype_of_functor_appl fcomp p1 p2 = + match fcomp.fcomp_res with + | Mty_alias _ as mty -> mty + | mty -> + try + stamped_find fcomp.fcomp_subst_cache p2 + with Not_found -> + let scope = Path.scope (Papply(p1, p2)) in + let mty = + let subst = + match fcomp.fcomp_arg with + | Unit + | Named (None, _) -> Subst.identity + | Named (Some param, _) -> Subst.add_module param p2 Subst.identity + in + Subst.modtype (Rescope scope) subst mty + in + stamped_add fcomp.fcomp_subst_cache p2 mty; + mty + +let check_functor_appl + ~errors ~loc ~lid_whole_app ~f0_path ~args + ~f_comp + ~arg_path ~arg_mty ~param_mty + env = + if not (stamped_mem f_comp.fcomp_cache arg_path) then + !check_functor_application + ~errors ~loc ~lid_whole_app ~f0_path ~args + ~arg_path ~arg_mty ~param_mty + env + +(* Lookup by identifier *) + +let find_ident_module id env = + match find_same_module id env.modules with + | Mod_local data -> data + | Mod_unbound _ -> raise Not_found + | Mod_persistent -> find_pers_mod (Ident.name id) + +let rec find_module_components path env = + match path with + | Pident id -> (find_ident_module id env).mda_components + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_modules).mda_components + | Papply(f_path, arg) -> + let f_comp = find_functor_components f_path env in + let loc = Location.(in_file !input_name) in + !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env + | Pextra_ty _ -> raise Not_found + +and find_structure_components path env = + match get_components (find_module_components path env) with + | Structure_comps c -> c + | Functor_comps _ -> raise Not_found + +and find_functor_components path env = + match get_components (find_module_components path env) with + | Functor_comps f -> f + | Structure_comps _ -> raise Not_found + +let find_module ~alias path env = + match path with + | Pident id -> + let data = find_ident_module id env in + Subst.Lazy.force_module_decl data.mda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + Subst.Lazy.force_module_decl data.mda_declaration + | Papply(p1, p2) -> + let fc = find_functor_components p1 env in + if alias then md (fc.fcomp_res) + else md (modtype_of_functor_appl fc p1 p2) + | Pextra_ty _ -> raise Not_found + +let find_module_lazy ~alias path env = + match path with + | Pident id -> + let data = find_ident_module id env in + data.mda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + data.mda_declaration + | Papply(p1, p2) -> + let fc = find_functor_components p1 env in + let md = + if alias then md (fc.fcomp_res) + else md (modtype_of_functor_appl fc p1 p2) + in + Subst.Lazy.of_module_decl md + | Pextra_ty _ -> raise Not_found + +let find_strengthened_module ~aliasable path env = + let md = find_module_lazy ~alias:true path env in + let mty = !strengthen ~aliasable env md.mdl_type path in + Subst.Lazy.force_modtype mty + +let find_value_full path env = + match path with + | Pident id -> begin + match IdTbl.find_same id env.values with + | Val_bound data -> data + | Val_unbound _ -> raise Not_found + end + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_values + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_extension_full path env = + match path with + | Pident id -> TycompTbl.find_same id env.constrs + | Pdot(p, s) -> begin + let comps = find_structure_components p env in + let cstrs = NameMap.find s comps.comp_constrs in + let exts = List.filter is_ext cstrs in + match exts with + | [cda] -> cda + | _ -> raise Not_found + end + | Papply _ | Pextra_ty _ -> raise Not_found + +let type_of_cstr path = function + | {cstr_inlined = Some decl; _} -> + let labels = + List.map snd (Datarepr.labels_of_type path decl) + in + begin match decl.type_kind with + | Type_record (_, repr) -> + { + tda_declaration = decl; + tda_descriptions = Type_record (labels, repr); + tda_shape = Shape.leaf decl.type_uid; + } + | _ -> assert false + end + | _ -> assert false + +let rec find_type_data path env = + match Path.Map.find path env.local_constraints with + | decl -> + { + tda_declaration = decl; + tda_descriptions = Type_abstract; + tda_shape = Shape.leaf decl.type_uid; + } + | exception Not_found -> begin + match path with + | Pident id -> IdTbl.find_same id env.types + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_types + | Papply _ -> raise Not_found + | Pextra_ty (p, extra) -> begin + match extra with + | Pcstr_ty s -> + let cstr = find_cstr p s env in + type_of_cstr path cstr + | Pext_ty -> + let cda = find_extension_full p env in + type_of_cstr path cda.cda_description + end + end +and find_cstr path name env = + let tda = find_type_data path env in + match tda.tda_descriptions with + | Type_variant (cstrs, _) -> + List.find (fun cstr -> cstr.cstr_name = name) cstrs + | Type_record _ | Type_abstract | Type_open -> raise Not_found + + + +let find_modtype_lazy path env = + match path with + | Pident id -> (IdTbl.find_same id env.modtypes).mtda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_modtypes).mtda_declaration + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_modtype path env = + Subst.Lazy.force_modtype_decl (find_modtype_lazy path env) + +let find_class_full path env = + match path with + | Pident id -> IdTbl.find_same id env.classes + | Pdot(p, s) -> + let sc = find_structure_components p env in + NameMap.find s sc.comp_classes + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_cltype path env = + match path with + | Pident id -> (IdTbl.find_same id env.cltypes).cltda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_cltypes).cltda_declaration + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_value path env = + (find_value_full path env).vda_description + +let find_class path env = + (find_class_full path env).clda_declaration + +let find_ident_constructor id env = + (TycompTbl.find_same id env.constrs).cda_description + +let find_ident_label id env = + TycompTbl.find_same id env.labels + +let find_type p env = + (find_type_data p env).tda_declaration +let find_type_descrs p env = + (find_type_data p env).tda_descriptions + +let rec find_module_address path env = + match path with + | Pident id -> get_address (find_ident_module id env).mda_address + | Pdot(p, s) -> + let c = find_structure_components p env in + get_address (NameMap.find s c.comp_modules).mda_address + | Papply _ | Pextra_ty _ -> raise Not_found + +and force_address = function + | Projection { parent; pos } -> Adot(get_address parent, pos) + | ModAlias { env; path } -> find_module_address path env + +and get_address a = + Lazy_backtrack.force force_address a + +let find_value_address path env = + get_address (find_value_full path env).vda_address + +let find_class_address path env = + get_address (find_class_full path env).clda_address + +let rec get_constrs_address = function + | [] -> raise Not_found + | cda :: rest -> + match cda.cda_address with + | None -> get_constrs_address rest + | Some a -> get_address a + +let find_constructor_address path env = + match path with + | Pident id -> begin + let cda = TycompTbl.find_same id env.constrs in + match cda.cda_address with + | None -> raise Not_found + | Some addr -> get_address addr + end + | Pdot(p, s) -> + let c = find_structure_components p env in + get_constrs_address (NameMap.find s c.comp_constrs) + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_hash_type path env = + match path with + | Pident id -> + let name = Ident.name id in + let _, cltda = + IdTbl.find_name wrap_identity ~mark:false name env.cltypes + in + cltda.cltda_declaration.clty_hash_type + | Pdot(p, name) -> + let c = find_structure_components p env in + let cltda = NameMap.find name c.comp_cltypes in + cltda.cltda_declaration.clty_hash_type + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_shape env (ns : Shape.Sig_component_kind.t) id = + match ns with + | Type -> + (IdTbl.find_same id env.types).tda_shape + | Extension_constructor -> + (TycompTbl.find_same id env.constrs).cda_shape + | Value -> + begin match IdTbl.find_same id env.values with + | Val_bound x -> x.vda_shape + | Val_unbound _ -> raise Not_found + end + | Module -> + begin match IdTbl.find_same id env.modules with + | Mod_local { mda_shape; _ } -> mda_shape + | Mod_persistent -> Shape.for_persistent_unit (Ident.name id) + | Mod_unbound _ -> + (* Only present temporarily while approximating the environment for + recursive modules. + [find_shape] is only ever called after the environment gets + properly populated. *) + assert false + | exception Not_found + when Ident.persistent id && not (Current_unit_name.is_ident id) -> + Shape.for_persistent_unit (Ident.name id) + end + | Module_type -> + (IdTbl.find_same id env.modtypes).mtda_shape + | Class -> + (IdTbl.find_same id env.classes).clda_shape + | Class_type -> + (IdTbl.find_same id env.cltypes).cltda_shape + +let shape_of_path ~namespace env = + Shape.of_path ~namespace ~find_shape:(find_shape env) + +let shape_or_leaf uid = function + | None -> Shape.leaf uid + | Some shape -> shape + +let required_globals = s_ref [] +let reset_required_globals () = required_globals := [] +let get_required_globals () = !required_globals +let add_required_global id = + if Ident.global id && not !Clflags.transparent_modules + && not (List.exists (Ident.same id) !required_globals) + then required_globals := id :: !required_globals + +let rec normalize_module_path lax env = function + | Pident id as path when lax && Ident.persistent id -> + path (* fast path (avoids lookup) *) + | Pdot (p, s) as path -> + let p' = normalize_module_path lax env p in + if p == p' then expand_module_path lax env path + else expand_module_path lax env (Pdot(p', s)) + | Papply (p1, p2) as path -> + let p1' = normalize_module_path lax env p1 in + let p2' = normalize_module_path true env p2 in + if p1 == p1' && p2 == p2' then expand_module_path lax env path + else expand_module_path lax env (Papply(p1', p2')) + | Pident _ as path -> + expand_module_path lax env path + | Pextra_ty _ -> assert false + +and expand_module_path lax env path = + try match find_module_lazy ~alias:true path env with + {mdl_type=MtyL_alias path1} -> + let path' = normalize_module_path lax env path1 in + if lax || !Clflags.transparent_modules then path' else + let id = Path.head path in + if Ident.global id && not (Ident.same id (Path.head path')) + then add_required_global id; + path' + | _ -> path + with Not_found when lax + || (match path with Pident id -> not (Ident.persistent id) | _ -> true) -> + path + +let normalize_module_path oloc env path = + try normalize_module_path (oloc = None) env path + with Not_found -> + match oloc with None -> assert false + | Some loc -> + error (Missing_module(loc, path, + normalize_module_path true env path)) + +let rec normalize_path_prefix oloc env path = + match path with + | Pdot(p, s) -> + let p2 = normalize_module_path oloc env p in + if p == p2 then path else Pdot(p2, s) + | Pident _ -> + path + | Pextra_ty (p, extra) -> + let p2 = normalize_path_prefix oloc env p in + if p == p2 then path else Pextra_ty (p2, extra) + | Papply _ -> + assert false + +let normalize_type_path = normalize_path_prefix + +let normalize_value_path = normalize_path_prefix + +let rec normalize_modtype_path env path = + let path = normalize_path_prefix None env path in + expand_modtype_path env path + +and expand_modtype_path env path = + match (find_modtype_lazy path env).mtdl_type with + | Some (MtyL_ident path) -> normalize_modtype_path env path + | _ | exception Not_found -> path + +let find_module path env = + find_module ~alias:false path env + +let find_module_lazy path env = + find_module_lazy ~alias:false path env + +(* Find the manifest type associated to a type when appropriate: + - the type should be public or should have a private row, + - the type should have an associated manifest type. *) +let find_type_expansion path env = + let decl = find_type path env in + match decl.type_manifest with + | Some body when decl.type_private = Public + || decl.type_kind <> Type_abstract + || Btype.has_constr_row body -> + (decl.type_params, body, decl.type_expansion_scope) + (* The manifest type of Private abstract data types without + private row are still considered unknown to the type system. + Hence, this case is caught by the following clause that also handles + purely abstract data types without manifest type definition. *) + | _ -> raise Not_found + +(* Find the manifest type information associated to a type, i.e. + the necessary information for the compiler's type-based optimisations. + In particular, the manifest type associated to a private abstract type + is revealed for the sake of compiler's type-based optimisations. *) +let find_type_expansion_opt path env = + let decl = find_type path env in + match decl.type_manifest with + (* The manifest type of Private abstract data types can still get + an approximation using their manifest type. *) + | Some body -> + (decl.type_params, body, decl.type_expansion_scope) + | _ -> raise Not_found + +let find_modtype_expansion_lazy path env = + match (find_modtype_lazy path env).mtdl_type with + | None -> raise Not_found + | Some mty -> mty + +let find_modtype_expansion path env = + Subst.Lazy.force_modtype (find_modtype_expansion_lazy path env) + +let rec is_functor_arg path env = + match path with + Pident id -> + begin try Ident.find_same id env.functor_args; true + with Not_found -> false + end + | Pdot (p, _) | Pextra_ty (p, _) -> is_functor_arg p env + | Papply _ -> true + +(* Copying types associated with values *) + +let make_copy_of_types env0 = + let memo = Hashtbl.create 16 in + let copy t = + try + Hashtbl.find memo (get_id t) + with Not_found -> + let t2 = Subst.type_expr Subst.identity t in + Hashtbl.add memo (get_id t) t2; + t2 + in + let f = function + | Val_unbound _ as entry -> entry + | Val_bound vda -> + let desc = vda.vda_description in + let desc = { desc with val_type = copy desc.val_type } in + Val_bound { vda with vda_description = desc } + in + let values = + IdTbl.map f env0.values + in + (fun env -> + (*if env.values != env0.values then fatal_error "Env.make_copy_of_types";*) + {env with values; summary = Env_copy_types env.summary} + ) + +(* Iter on an environment (ignoring the body of functors and + not yet evaluated structures) *) + +type iter_cont = unit -> unit +let iter_env_cont = ref [] + +let rec scrape_alias_for_visit env mty = + let open Subst.Lazy in + match mty with + | MtyL_alias path -> begin + match path with + | Pident id + when Ident.persistent id + && not (Persistent_env.looked_up !persistent_env (Ident.name id)) -> + false + | path -> (* PR#6600: find_module may raise Not_found *) + try + scrape_alias_for_visit env (find_module_lazy path env).mdl_type + with Not_found -> false + end + | _ -> true + +let iter_env wrap proj1 proj2 f env () = + IdTbl.iter wrap (fun id x -> f (Pident id) x) (proj1 env); + let rec iter_components path path' mcomps = + let cont () = + let visit = + match Lazy_backtrack.get_arg mcomps.comps with + | None -> true + | Some { cm_mty; _ } -> + scrape_alias_for_visit env cm_mty + in + if not visit then () else + match get_components mcomps with + Structure_comps comps -> + NameMap.iter + (fun s d -> f (Pdot (path, s)) (Pdot (path', s), d)) + (proj2 comps); + NameMap.iter + (fun s mda -> + iter_components + (Pdot (path, s)) (Pdot (path', s)) mda.mda_components) + comps.comp_modules + | Functor_comps _ -> () + in iter_env_cont := (path, cont) :: !iter_env_cont + in + IdTbl.iter wrap_module + (fun id (path, entry) -> + match entry with + | Mod_unbound _ -> () + | Mod_local data -> + iter_components (Pident id) path data.mda_components + | Mod_persistent -> + let modname = Ident.name id in + match Persistent_env.find_in_cache !persistent_env modname with + | None -> () + | Some data -> + iter_components (Pident id) path data.mda_components) + env.modules + +let run_iter_cont l = + iter_env_cont := []; + List.iter (fun c -> c ()) l; + let cont = List.rev !iter_env_cont in + iter_env_cont := []; + cont + +let iter_types f = + iter_env wrap_identity (fun env -> env.types) (fun sc -> sc.comp_types) + (fun p1 (p2, tda) -> f p1 (p2, tda.tda_declaration)) + +let same_types env1 env2 = + env1.types == env2.types && env1.modules == env2.modules + +let used_persistent () = + Persistent_env.fold !persistent_env + (fun s _m r -> String.Set.add s r) + String.Set.empty + +let find_all_comps wrap proj s (p, mda) = + match get_components mda.mda_components with + Functor_comps _ -> [] + | Structure_comps comps -> + try + let c = NameMap.find s (proj comps) in + [Pdot(p,s), wrap c] + with Not_found -> [] + +let rec find_shadowed_comps path env = + match path with + | Pident id -> + List.filter_map + (fun (p, data) -> + match data with + | Mod_local x -> Some (p, x) + | Mod_unbound _ | Mod_persistent -> None) + (IdTbl.find_all wrap_module (Ident.name id) env.modules) + | Pdot (p, s) -> + let l = find_shadowed_comps p env in + let l' = + List.map + (find_all_comps wrap_identity + (fun comps -> comps.comp_modules) s) l + in + List.flatten l' + | Papply _ | Pextra_ty _ -> [] + +let find_shadowed wrap proj1 proj2 path env = + match path with + Pident id -> + IdTbl.find_all wrap (Ident.name id) (proj1 env) + | Pdot (p, s) -> + let l = find_shadowed_comps p env in + let l' = List.map (find_all_comps wrap proj2 s) l in + List.flatten l' + | Papply _ | Pextra_ty _ -> [] + +let find_shadowed_types path env = + List.map fst + (find_shadowed wrap_identity + (fun env -> env.types) (fun comps -> comps.comp_types) path env) + +(* Expand manifest module type names at the top of the given module type *) + +let rec scrape_alias env ?path mty = + let open Subst.Lazy in + match mty, path with + MtyL_ident p, _ -> + begin try + scrape_alias env (find_modtype_expansion_lazy p env) ?path + with Not_found -> + mty + end + | MtyL_alias path, _ -> + begin try + scrape_alias env ((find_module_lazy path env).mdl_type) ~path + with Not_found -> + (*Location.prerr_warning Location.none + (Warnings.No_cmi_file (Path.name path));*) + mty + end + | mty, Some path -> + !strengthen ~aliasable:true env mty path + | _ -> mty + +(* Given a signature and a root path, prefix all idents in the signature + by the root path and build the corresponding substitution. *) + +let prefix_idents root prefixing_sub sg = + let open Subst.Lazy in + let rec prefix_idents root items_and_paths prefixing_sub = + function + | [] -> (List.rev items_and_paths, prefixing_sub) + | SigL_value(id, _, _) as item :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((item, p) :: items_and_paths) prefixing_sub rem + | SigL_type(id, td, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_type(id, td, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_typext(id, ec, es, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + (* we extend the substitution in case of an inlined record *) + prefix_idents root + ((SigL_typext(id, ec, es, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_module(id, pres, md, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_module(id, pres, md, rs, vis), p) :: items_and_paths) + (Subst.add_module id p prefixing_sub) + rem + | SigL_modtype(id, mtd, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_modtype(id, mtd, vis), p) :: items_and_paths) + (Subst.add_modtype id (Mty_ident p) prefixing_sub) + rem + | SigL_class(id, cd, rs, vis) :: rem -> + (* pretend this is a type, cf. PR#6650 *) + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_class(id, cd, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_class_type(id, ctd, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_class_type(id, ctd, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + in + let sg = Subst.Lazy.force_signature_once sg in + prefix_idents root [] prefixing_sub sg + +(* Short path additions *) + +let short_paths_type ~long_path predef id decl old = + if long_path || (not predef && !Clflags.real_paths) then old + else Type(id, decl) :: old + +let short_paths_type_open path decls old = + if !Clflags.real_paths then old + else Type_open(path, decls) :: old + +let unbound_class = Path.Pident (Ident.create_local "*undef*") + +let is_dummy_class decl = + Path.same decl.clty_path unbound_class + +let short_paths_class_type id decl old = + if !Clflags.real_paths || is_dummy_class decl then old + else Class_type(id, decl) :: old + +let short_paths_class_type_open path decls old = + let decls = NameMap.map (fun cltda -> cltda.cltda_declaration) decls in + if !Clflags.real_paths then old + else Class_type_open(path, decls) :: old + +let short_paths_module_type id decl old = + let decl = Subst.Lazy.force_modtype_decl decl in + if !Clflags.real_paths then old + else Module_type(id, decl) :: old + +let short_paths_module_type_open path decls old = + let decls = NameMap.map + (fun mtda -> Subst.Lazy.force_modtype_decl mtda.mtda_declaration) + decls + in + if !Clflags.real_paths then old + else Module_type_open(path, decls) :: old + +let short_paths_module id decl comps old = + let decl = Subst.Lazy.force_module_decl decl in + if !Clflags.real_paths then old + else Module(id, decl, comps) :: old + +let short_paths_module_open path comps old = + if !Clflags.real_paths then old + else Module_open(path, comps) :: old + +(* Compute structure descriptions *) + +let add_to_tbl id decl tbl = + let decls = try NameMap.find id tbl with Not_found -> [] in + NameMap.add id (decl :: decls) tbl + +let value_declaration_address (_ : t) id decl = + match decl.val_kind with + | Val_prim _ -> Lazy_backtrack.create_failed Not_found + | _ -> Lazy_backtrack.create_forced (Aident id) + +let extension_declaration_address (_ : t) id (_ : extension_constructor) = + Lazy_backtrack.create_forced (Aident id) + +let class_declaration_address (_ : t) id (_ : class_declaration) = + Lazy_backtrack.create_forced (Aident id) + +let module_declaration_address env id presence md = + match presence with + | Mp_absent -> begin + let open Subst.Lazy in + match md.mdl_type with + | MtyL_alias path -> Lazy_backtrack.create (ModAlias {env; path}) + | _ -> assert false + end + | Mp_present -> + Lazy_backtrack.create_forced (Aident id) + +let is_identchar c = + (* This should be kept in sync with the [identchar_latin1] character class + in [lexer.mll] *) + match c with + | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' + | '\216'..'\246' | '\248'..'\255' | '\'' | '0'..'9' -> + true + | _ -> + false + +let rec components_of_module_maker + {cm_env; cm_prefixing_subst; + cm_path; cm_addr; cm_mty; cm_shape} : _ result = + match scrape_alias cm_env cm_mty with + MtyL_signature sg -> + let c = + { comp_values = NameMap.empty; + comp_constrs = NameMap.empty; + comp_labels = NameMap.empty; comp_types = NameMap.empty; + comp_modules = NameMap.empty; comp_modtypes = NameMap.empty; + comp_classes = NameMap.empty; comp_cltypes = NameMap.empty } + in + let items_and_paths, sub = + prefix_idents cm_path cm_prefixing_subst sg + in + let env = ref cm_env in + let pos = ref 0 in + let next_address () = + let addr : address_unforced = + Projection { parent = cm_addr; pos = !pos } + in + incr pos; + Lazy_backtrack.create addr + in + List.iter (fun ((item : Subst.Lazy.signature_item), path) -> + match item with + SigL_value(id, decl, _) -> + let decl' = Subst.value_description sub decl in + let addr = + match decl.val_kind with + | Val_prim _ -> Lazy_backtrack.create_failed Not_found + | _ -> next_address () + in + let vda_shape = Shape.proj cm_shape (Shape.Item.value id) in + let vda = + { vda_description = decl'; vda_address = addr; vda_shape } + in + c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values; + | SigL_type(id, decl, _, _) -> + let final_decl = Subst.type_declaration sub decl in + Btype.set_static_row_name final_decl + (Subst.type_path sub (Path.Pident id)); + let descrs = + match decl.type_kind with + | Type_variant (_,repr) -> + let cstrs = List.map snd + (Datarepr.constructors_of_type path final_decl + ~current_unit:(get_unit_name ())) + in + List.iter + (fun descr -> + let cda_shape = Shape.leaf descr.cstr_uid in + let cda = { + cda_description = descr; + cda_address = None; + cda_shape } + in + c.comp_constrs <- + add_to_tbl descr.cstr_name cda c.comp_constrs + ) cstrs; + Type_variant (cstrs, repr) + | Type_record (_, repr) -> + let lbls = List.map snd + (Datarepr.labels_of_type path final_decl) + in + List.iter + (fun descr -> + c.comp_labels <- + add_to_tbl descr.lbl_name descr c.comp_labels) + lbls; + Type_record (lbls, repr) + | Type_abstract -> Type_abstract + | Type_open -> Type_open + in + let shape = Shape.proj cm_shape (Shape.Item.type_ id) in + let tda = + { tda_declaration = final_decl; + tda_descriptions = descrs; + tda_shape = shape; } + in + c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types; + env := store_type_infos ~tda_shape:shape id decl !env + | SigL_typext(id, ext, _, _) -> + let ext' = Subst.extension_constructor sub ext in + let descr = + Datarepr.extension_descr ~current_unit:(get_unit_name ()) path + ext' + in + let addr = next_address () in + let cda_shape = + Shape.proj cm_shape (Shape.Item.extension_constructor id) + in + let cda = + { cda_description = descr; cda_address = Some addr; cda_shape } + in + c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs + | SigL_module(id, pres, md, _, _) -> + let md' = + (* The prefixed items get the same scope as [cm_path], which is + the prefix. *) + Subst.Lazy.module_decl + (Subst.Rescope (Path.scope cm_path)) sub md + in + let addr = + match pres with + | Mp_absent -> begin + match md.mdl_type with + | MtyL_alias path -> + Lazy_backtrack.create (ModAlias {env = !env; path}) + | _ -> assert false + end + | Mp_present -> next_address () + in + let alerts = + Builtin_attributes.alerts_of_attrs md.mdl_attributes + in + let shape = Shape.proj cm_shape (Shape.Item.module_ id) in + let comps = + components_of_module ~alerts ~uid:md.mdl_uid !env + sub path addr md.mdl_type shape + in + let mda = + { mda_declaration = md'; + mda_components = comps; + mda_address = addr; + mda_shape = shape; } + in + c.comp_modules <- + NameMap.add (Ident.name id) mda c.comp_modules; + env := + store_module ~update_summary:false ~check:None + id addr pres md shape !env + | SigL_modtype(id, decl, _) -> + let final_decl = + (* The prefixed items get the same scope as [cm_path], which is + the prefix. *) + Subst.Lazy.modtype_decl (Rescope (Path.scope cm_path)) + sub decl + in + let shape = Shape.proj cm_shape (Shape.Item.module_type id) in + let mtda = + { mtda_declaration = final_decl; + mtda_shape = shape; } + in + c.comp_modtypes <- + NameMap.add (Ident.name id) mtda c.comp_modtypes; + env := store_modtype ~update_summary:false id decl shape !env + | SigL_class(id, decl, _, _) -> + let decl' = Subst.class_declaration sub decl in + let addr = next_address () in + let shape = Shape.proj cm_shape (Shape.Item.class_ id) in + let clda = + { clda_declaration = decl'; + clda_address = addr; + clda_shape = shape; } + in + c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes + | SigL_class_type(id, decl, _, _) -> + let decl' = Subst.cltype_declaration sub decl in + let shape = Shape.proj cm_shape (Shape.Item.class_type id) in + let cltda = { cltda_declaration = decl'; cltda_shape = shape } in + c.comp_cltypes <- + NameMap.add (Ident.name id) cltda c.comp_cltypes) + items_and_paths; + Ok (Structure_comps c) + | MtyL_functor(arg, ty_res) -> + let sub = cm_prefixing_subst in + let scoping = Subst.Rescope (Path.scope cm_path) in + let open Subst.Lazy in + Ok (Functor_comps { + (* fcomp_arg and fcomp_res must be prefixed eagerly, because + they are interpreted in the outer environment *) + fcomp_arg = + (match arg with + | Unit -> Unit + | Named (param, ty_arg) -> + Named (param, force_modtype (modtype scoping sub ty_arg))); + fcomp_res = force_modtype (modtype scoping sub ty_res); + fcomp_shape = cm_shape; + fcomp_cache = stamped_create 17; + fcomp_subst_cache = stamped_create 17 }) + | MtyL_ident _ -> Error No_components_abstract + | MtyL_alias p -> Error (No_components_alias p) + | MtyL_for_hole -> Error No_components_abstract + +(* Insertion of bindings by identifier + path *) + +and check_usage loc id uid warn tbl = + if not loc.Location.loc_ghost && + Uid.for_actual_declaration uid && + Warnings.is_active (warn "") + then begin + let name = Ident.name id in + if Types.Uid.Tbl.mem tbl uid then () + else let used = ref false in + Types.Uid.Tbl.add tbl uid (fun () -> used := true); + if not (name = "" || name.[0] = '_' || name.[0] = '#') + then + !add_delayed_check_forward + (fun () -> if not !used then Location.prerr_warning loc (warn name)) + end; + +and check_value_name name loc = + (* Note: we could also check here general validity of the + identifier, to protect against bad identifiers forged by -pp or + -ppx preprocessors. *) + if String.length name > 0 && not (is_identchar name.[0]) then + for i = 1 to String.length name - 1 do + if name.[i] = '#' then + error (Illegal_value_name(loc, name)) + done + +and store_value ?check id addr decl shape env = + check_value_name (Ident.name id) decl.val_loc; + Option.iter + (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations) + check; + let vda = + { vda_description = decl; + vda_address = addr; + vda_shape = shape } + in + { env with + values = IdTbl.add id (Val_bound vda) env.values; + summary = Env_value(env.summary, id, decl) } + +and store_constructor ~check type_decl type_id cstr_id cstr env = + Builtin_attributes.warning_scope cstr.cstr_attributes (fun () -> + if check && not type_decl.type_loc.Location.loc_ghost + && Warnings.is_active (Warnings.Unused_constructor ("", Unused)) + then begin + let ty_name = Ident.name type_id in + let name = cstr.cstr_name in + let loc = cstr.cstr_loc in + let k = cstr.cstr_uid in + let priv = type_decl.type_private in + if not (Types.Uid.Tbl.mem !used_constructors k) then begin + let used = constructor_usages () in + Types.Uid.Tbl.add !used_constructors k + (add_constructor_usage used); + if not (ty_name = "" || ty_name.[0] = '_') + then + !add_delayed_check_forward + (fun () -> + Option.iter + (fun complaint -> + if not (is_in_signature env) then + Location.prerr_warning loc + (Warnings.Unused_constructor(name, complaint))) + (constructor_usage_complaint ~rebind:false priv used)); + end; + end); + let cda_shape = Shape.leaf cstr.cstr_uid in + { env with + constrs = + TycompTbl.add cstr_id + { cda_description = cstr; cda_address = None; cda_shape } env.constrs; + } + +and store_label ~check type_decl type_id lbl_id lbl env = + Builtin_attributes.warning_scope lbl.lbl_attributes (fun () -> + if check && not type_decl.type_loc.Location.loc_ghost + && Warnings.is_active (Warnings.Unused_field ("", Unused)) + then begin + let ty_name = Ident.name type_id in + let priv = type_decl.type_private in + let name = lbl.lbl_name in + let loc = lbl.lbl_loc in + let mut = lbl.lbl_mut in + let k = lbl.lbl_uid in + if not (Types.Uid.Tbl.mem !used_labels k) then + let used = label_usages () in + Types.Uid.Tbl.add !used_labels k + (add_label_usage used); + if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_') + then !add_delayed_check_forward + (fun () -> + Option.iter + (fun complaint -> + if not (is_in_signature env) then + Location.prerr_warning + loc (Warnings.Unused_field(name, complaint))) + (label_usage_complaint priv mut used)) + end); + { env with + labels = TycompTbl.add lbl_id lbl env.labels; + } + +and store_type ~check ~long_path ~predef id info shape env = + let loc = info.type_loc in + if check then + check_usage loc id info.type_uid + (fun s -> Warnings.Unused_type_declaration s) + !type_declarations; + let descrs, env = + let path = Pident id in + match info.type_kind with + | Type_variant (_,repr) -> + let constructors = Datarepr.constructors_of_type path info + ~current_unit:(get_unit_name ()) + in + Type_variant (List.map snd constructors, repr), + List.fold_left + (fun env (cstr_id, cstr) -> + store_constructor ~check info id cstr_id cstr env) + env constructors + | Type_record (_, repr) -> + let labels = Datarepr.labels_of_type path info in + Type_record (List.map snd labels, repr), + List.fold_left + (fun env (lbl_id, lbl) -> + store_label ~check info id lbl_id lbl env) + env labels + | Type_abstract -> Type_abstract, env + | Type_open -> Type_open, env + in + let tda = + { tda_declaration = info; + tda_descriptions = descrs; + tda_shape = shape } + in + { env with + types = IdTbl.add id tda env.types; + summary = Env_type(env.summary, id, info); + short_paths_additions = + short_paths_type ~long_path predef id info env.short_paths_additions; } + +and store_type_infos ~tda_shape id info env = + (* Simplified version of store_type that doesn't compute and store + constructor and label infos, but simply record the arity and + manifest-ness of the type. Used in components_of_module to + keep track of type abbreviations (e.g. type t = float) in the + computation of label representations. *) + let tda = + { + tda_declaration = info; + tda_descriptions = Type_abstract; + tda_shape + } + in + { env with + types = IdTbl.add id tda env.types; + summary = Env_type(env.summary, id, info); + short_paths_additions = + short_paths_type ~long_path:false false id info env.short_paths_additions; } + +and store_extension ~check ~rebind id addr ext shape env = + let loc = ext.ext_loc in + let cstr = + Datarepr.extension_descr ~current_unit:(get_unit_name ()) (Pident id) ext + in + let cda = + { cda_description = cstr; + cda_address = Some addr; + cda_shape = shape } + in + Builtin_attributes.warning_scope ext.ext_attributes (fun () -> + if check && not loc.Location.loc_ghost && + Warnings.is_active (Warnings.Unused_extension ("", false, Unused)) + then begin + let priv = ext.ext_private in + let is_exception = Path.same ext.ext_type_path Predef.path_exn in + let name = cstr.cstr_name in + let k = cstr.cstr_uid in + if not (Types.Uid.Tbl.mem !used_constructors k) then begin + let used = constructor_usages () in + Types.Uid.Tbl.add !used_constructors k + (add_constructor_usage used); + !add_delayed_check_forward + (fun () -> + Option.iter + (fun complaint -> + if not (is_in_signature env) then + Location.prerr_warning loc + (Warnings.Unused_extension + (name, is_exception, complaint))) + (constructor_usage_complaint ~rebind priv used)) + end; + end); + { env with + constrs = TycompTbl.add id cda env.constrs; + summary = Env_extension(env.summary, id, ext) } + +and store_module ?(update_summary=true) ~check + id addr presence md shape env = + let open Subst.Lazy in + let loc = md.mdl_loc in + Option.iter + (fun f -> check_usage loc id md.mdl_uid f !module_declarations) check; + let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in + let comps = + components_of_module ~alerts ~uid:md.mdl_uid + env Subst.identity (Pident id) addr md.mdl_type shape + in + let mda = + { mda_declaration = md; + mda_components = comps; + mda_address = addr; + mda_shape = shape } + in + let summary = + if not update_summary then env.summary + else Env_module (env.summary, id, presence, force_module_decl md) in + { env with + modules = IdTbl.add id (Mod_local mda) env.modules; + summary; + short_paths_additions = + short_paths_module id md comps env.short_paths_additions; } + +and store_modtype ?(update_summary=true) id info shape env = + let mtda = { mtda_declaration = info; mtda_shape = shape } in + let summary = + if not update_summary then env.summary + else Env_modtype (env.summary, id, Subst.Lazy.force_modtype_decl info) in + { env with + modtypes = IdTbl.add id mtda env.modtypes; + summary; + short_paths_additions = + short_paths_module_type id info env.short_paths_additions; } + +and store_class id addr desc shape env = + let clda = + { clda_declaration = desc; + clda_address = addr; + clda_shape = shape; } + in + { env with + classes = IdTbl.add id clda env.classes; + summary = Env_class(env.summary, id, desc) } + +and store_cltype id desc shape env = + let cltda = { cltda_declaration = desc; cltda_shape = shape } in + { env with + cltypes = IdTbl.add id cltda env.cltypes; + summary = Env_cltype(env.summary, id, desc); + short_paths_additions = + short_paths_class_type id desc env.short_paths_additions; } + +let scrape_alias env mty = scrape_alias env mty + +(* Compute the components of a functor application in a path. *) + +let components_of_functor_appl ~loc ~f_path ~f_comp ~arg env = + try + let c = stamped_find f_comp.fcomp_cache arg in + c + with Not_found -> + let p = Papply(f_path, arg) in + let sub = + match f_comp.fcomp_arg with + | Unit + | Named (None, _) -> Subst.identity + | Named (Some param, _) -> Subst.add_module param arg Subst.identity + in + (* we have to apply eagerly instead of passing sub to [components_of_module] + because of the call to [check_well_formed_module]. *) + let mty = Subst.modtype (Rescope (Path.scope p)) sub f_comp.fcomp_res in + let addr = Lazy_backtrack.create_failed Not_found in + !check_well_formed_module env loc + ("the signature of " ^ Path.name p) mty; + let shape_arg = + shape_of_path ~namespace:Shape.Sig_component_kind.Module env arg + in + let shape = Shape.app f_comp.fcomp_shape ~arg:shape_arg in + let comps = + components_of_module ~alerts:Misc.String.Map.empty + ~uid:Uid.internal_not_actually_unique + (*???*) + env Subst.identity p addr (Subst.Lazy.of_modtype mty) shape + in + stamped_add f_comp.fcomp_cache arg comps; + comps + +(* Define forward functions *) + +let _ = + components_of_functor_appl' := components_of_functor_appl; + components_of_module_maker' := components_of_module_maker + +(* Insertion of bindings by identifier *) + +let add_functor_arg id env = + {env with + functor_args = Ident.add id () env.functor_args; + summary = Env_functor_arg (env.summary, id)} + +let add_value ?check ?shape id desc env = + let addr = value_declaration_address env id desc in + let shape = shape_or_leaf desc.val_uid shape in + store_value ?check id addr desc shape env + +let add_type ~check ?shape id info env = + let shape = shape_or_leaf info.type_uid shape in + store_type ~check id info shape env + +and add_extension ~check ?shape ~rebind id ext env = + let addr = extension_declaration_address env id ext in + let shape = shape_or_leaf ext.ext_uid shape in + store_extension ~check ~rebind id addr ext shape env + +and add_module_declaration ?(arg=false) ?shape ~check id presence md env = + let check = + if not check then + None + else if arg && is_in_signature env then + Some (fun s -> Warnings.Unused_functor_parameter s) + else + Some (fun s -> Warnings.Unused_module s) + in + let md = Subst.Lazy.of_module_decl md in + let addr = module_declaration_address env id presence md in + let shape = shape_or_leaf md.mdl_uid shape in + let env = store_module ~check id addr presence md shape env in + if arg then add_functor_arg id env else env + +and add_module_declaration_lazy ~update_summary id presence md env = + let addr = module_declaration_address env id presence md in + let shape = Shape.leaf md.Subst.Lazy.mdl_uid in + let env = + store_module ~update_summary ~check:None id addr presence md shape env + in + env + +and add_modtype ?shape id info env = + let shape = shape_or_leaf info.mtd_uid shape in + store_modtype id (Subst.Lazy.of_modtype_decl info) shape env + +and add_modtype_lazy ~update_summary id info env = + let shape = Shape.leaf info.Subst.Lazy.mtdl_uid in + store_modtype ~update_summary id info shape env + +and add_class ?shape id ty env = + let addr = class_declaration_address env id ty in + let shape = shape_or_leaf ty.cty_uid shape in + store_class id addr ty shape env + +and add_cltype ?shape id ty env = + let shape = shape_or_leaf ty.clty_uid shape in + store_cltype id ty shape env + +let add_module ?arg ?shape id presence mty env = + add_module_declaration ~check:false ?arg ?shape id presence (md mty) env + +let add_module_lazy ~update_summary id presence mty env = + let md = Subst.Lazy.{mdl_type = mty; + mdl_attributes = []; + mdl_loc = Location.none; + mdl_uid = Uid.internal_not_actually_unique} + in + add_module_declaration_lazy ~update_summary id presence md env + +let add_local_type path info env = + { env with + local_constraints = Path.Map.add path info env.local_constraints } + +(* Non-lazy version of scrape_alias *) +let scrape_alias t mty = + mty |> Subst.Lazy.of_modtype |> scrape_alias t |> Subst.Lazy.force_modtype + +(* Insertion of bindings by name *) + +let enter_value ?check name desc env = + let id = Ident.create_local name in + let addr = value_declaration_address env id desc in + let env = store_value ?check id addr desc (Shape.leaf desc.val_uid) env in + (id, env) + +let enter_type ~scope name info env = + let id = Ident.create_scoped ~scope name in + let env = store_type ~check:true ~predef:false ~long_path:false + id info (Shape.leaf info.type_uid) env + in + (id, env) + +let enter_extension ~scope ~rebind name ext env = + let id = Ident.create_scoped ~scope name in + let addr = extension_declaration_address env id ext in + let shape = Shape.leaf ext.ext_uid in + let env = store_extension ~check:true ~rebind id addr ext shape env in + (id, env) + +let enter_module_declaration ~scope ?arg ?shape s presence md env = + let id = Ident.create_scoped ~scope s in + (id, add_module_declaration ?arg ?shape ~check:true id presence md env) + +let enter_modtype ~scope name mtd env = + let id = Ident.create_scoped ~scope name in + let shape = Shape.leaf mtd.mtd_uid in + let env = store_modtype id (Subst.Lazy.of_modtype_decl mtd) shape env in + (id, env) + +let enter_class ~scope name desc env = + let id = Ident.create_scoped ~scope name in + let addr = class_declaration_address env id desc in + let env = store_class id addr desc (Shape.leaf desc.cty_uid) env in + (id, env) + +let enter_cltype ~scope name desc env = + let id = Ident.create_scoped ~scope name in + let env = store_cltype id desc (Shape.leaf desc.clty_uid) env in + (id, env) + +let enter_module ~scope ?arg s presence mty env = + enter_module_declaration ~scope ?arg s presence (md mty) env + +(* Insertion of all components of a signature *) + +let add_item (map, mod_shape) comp env = + let proj_shape item = + match mod_shape with + | None -> map, None + | Some mod_shape -> + let shape = Shape.proj mod_shape item in + Shape.Map.add map item shape, Some shape + in + match comp with + | Sig_value(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.value id) in + map, add_value ?shape id decl env + | Sig_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.type_ id) in + map, + add_type ~long_path:false ~check:false ~predef:false ?shape id decl env + | Sig_typext(id, ext, _, _) -> + let map, shape = proj_shape (Shape.Item.extension_constructor id) in + map, add_extension ~check:false ?shape ~rebind:false id ext env + | Sig_module(id, presence, md, _, _) -> + let map, shape = proj_shape (Shape.Item.module_ id) in + map, add_module_declaration ~check:false ?shape id presence md env + | Sig_modtype(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.module_type id) in + map, add_modtype ?shape id decl env + | Sig_class(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_ id) in + map, add_class ?shape id decl env + | Sig_class_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_type id) in + map, add_cltype ?shape id decl env + +let rec add_signature (map, mod_shape) sg env = + match sg with + [] -> map, env + | comp :: rem -> + let map, env = add_item (map, mod_shape) comp env in + add_signature (map, mod_shape) rem env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + let sg = Subst.signature (Rescope scope) Subst.identity sg in + let shape, env = add_signature (parent_shape, mod_shape) sg env in + sg, shape, env + +let enter_signature ?mod_shape ~scope sg env = + let sg, _, env = + enter_signature_and_shape ~scope ~parent_shape:Shape.Map.empty + mod_shape sg env + in + sg, env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env + +let add_value = add_value ?shape:None +let add_type = add_type ?shape:None +let add_extension = add_extension ?shape:None +let add_class = add_class ?shape:None +let add_cltype = add_cltype ?shape:None +let add_modtype = add_modtype ?shape:None +let add_signature sg env = + let _, env = add_signature (Shape.Map.empty, None) sg env in + env + +(* Add "unbound" bindings *) + +let enter_unbound_value name reason env = + let id = Ident.create_local name in + { env with + values = IdTbl.add id (Val_unbound reason) env.values; + summary = Env_value_unbound(env.summary, name, reason) } + +let enter_unbound_module name reason env = + let id = Ident.create_local name in + { env with + modules = IdTbl.add id (Mod_unbound reason) env.modules; + summary = Env_module_unbound(env.summary, name, reason) } + +(* Open a signature path *) + +let add_components slot root env0 comps = + let add_l w comps env0 = + TycompTbl.add_open slot w root comps env0 + in + let add w comps env0 = IdTbl.add_open slot w root comps env0 in + let add_types w comps env0 additions = + let types = add w comps env0 in + let additions = short_paths_type_open root comps additions in + types, additions + in + let add_cltypes w comps env0 additions = + let cltypes = add w comps env0 in + let additions = short_paths_class_type_open root comps additions in + cltypes, additions + in + let add_modtypes w comps env0 additions = + let modtypes = add w comps env0 in + let additions = short_paths_module_type_open root comps additions in + modtypes, additions + in + let add_modules w comps env0 additions = + let modules = add w comps env0 in + let additions = short_paths_module_open root comps additions in + modules, additions + in + let constrs = + add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs + in + let labels = + add_l (fun x -> `Label x) comps.comp_labels env0.labels + in + let values = + add (fun x -> `Value x) comps.comp_values env0.values + in + let types, additions = + add_types (fun x -> `Type x) + comps.comp_types env0.types env0.short_paths_additions + in + let modtypes, additions = + add_modtypes (fun x -> `Module_type x) + comps.comp_modtypes env0.modtypes additions + in + let classes = + add (fun x -> `Class x) comps.comp_classes env0.classes + in + let cltypes, additions = + add_cltypes (fun x -> `Class_type x) + comps.comp_cltypes env0.cltypes additions + in + let modules, additions = + add_modules (fun x -> `Module x) + comps.comp_modules env0.modules additions + in + { env0 with + summary = Env_open(env0.summary, root); + constrs; + labels; + values; + types; + modtypes; + classes; + cltypes; + modules; + short_paths_additions = additions + } + +let open_signature slot root env0 : (_,_) result = + match get_components_res (find_module_components root env0) with + | Error _ -> Error `Not_found + | exception Not_found -> Error `Not_found + | Ok (Functor_comps _) -> Error `Functor + | Ok (Structure_comps comps) -> + Ok (add_components slot root env0 comps) + +let remove_last_open root env0 = + let rec filter_summary summary = + match summary with + Env_empty -> raise Exit + | Env_open (s, p) -> + if Path.same p root then s else raise Exit + | Env_value _ + | Env_type _ + | Env_extension _ + | Env_module _ + | Env_modtype _ + | Env_class _ + | Env_cltype _ + | Env_functor_arg _ + | Env_constraints _ + | Env_persistent _ + | Env_copy_types _ + | Env_value_unbound _ + | Env_module_unbound _ -> + map_summary filter_summary summary + in + match filter_summary env0.summary with + | summary -> + let rem_l tbl = TycompTbl.remove_last_open root tbl + and rem tbl = IdTbl.remove_last_open root tbl in + Some { env0 with + summary; + constrs = rem_l env0.constrs; + labels = rem_l env0.labels; + values = rem env0.values; + types = rem env0.types; + modtypes = rem env0.modtypes; + classes = rem env0.classes; + cltypes = rem env0.cltypes; + modules = rem env0.modules; } + | exception Exit -> + None + +(* Open a signature from a file *) + +let open_pers_signature name env = + match open_signature None (Pident(Ident.create_persistent name)) env with + | (Ok _ | Error `Not_found as res) -> res + | Error `Functor -> assert false + (* a compilation unit cannot refer to a functor *) + +let open_signature + ?(used_slot = ref false) + ?(loc = Location.none) ?(toplevel = false) + ovf root env = + let unused root = + match ovf with + | Asttypes.Fresh -> Warnings.Unused_open (Path.name root) + | Asttypes.Override -> Warnings.Unused_open_bang (Path.name root) + in + let warn_unused = + Warnings.is_active (unused root) + and warn_shadow_id = + Warnings.is_active (Warnings.Open_shadow_identifier ("", "")) + and warn_shadow_lc = + Warnings.is_active (Warnings.Open_shadow_label_constructor ("","")) + in + if not toplevel && not loc.Location.loc_ghost + && (warn_unused || warn_shadow_id || warn_shadow_lc) + then begin + let used = used_slot in + if warn_unused then + !add_delayed_check_forward + (fun () -> + if not !used then begin + used := true; + Location.prerr_warning loc (unused (!shorten_module_path env root)) + end + ); + let shadowed = ref [] in + let slot s b = + begin match check_shadowing env b with + | Some kind when + ovf = Asttypes.Fresh && not (List.mem (kind, s) !shadowed) -> + shadowed := (kind, s) :: !shadowed; + let w = + match kind with + | "label" | "constructor" -> + Warnings.Open_shadow_label_constructor (kind, s) + | _ -> Warnings.Open_shadow_identifier (kind, s) + in + Location.prerr_warning loc w + | _ -> () + end; + used := true + in + open_signature (Some slot) root env + end + else open_signature None root env + +(* Read a signature from a file *) +let read_signature modname filename = + let mda = read_pers_mod modname filename in + let md = Subst.Lazy.force_module_decl mda.mda_declaration in + match md.md_type with + | Mty_signature sg -> sg + | Mty_ident _ | Mty_functor _ | Mty_alias _ | Mty_for_hole -> assert false + +let is_identchar_latin1 = function + | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246' + | '\248'..'\255' | '\'' | '0'..'9' -> true + | _ -> false + +let unit_name_of_filename fn = + match Filename.extension fn with + | ".cmi" -> begin + let unit = + String.capitalize_ascii (Filename.remove_extension fn) + in + if Std.String.for_all is_identchar_latin1 unit then + Some unit + else + None + end + | _ -> None + +let persistent_structures_of_dir dir = + Load_path.Dir.files dir + |> List.to_seq + |> Seq.filter_map unit_name_of_filename + |> String.Set.of_seq + +(* Save a signature to a file *) +let save_signature_with_transform cmi_transform ~alerts sg modname filename = + Btype.cleanup_abbrev (); + Subst.reset_for_saving (); + let sg = Subst.signature Make_local (Subst.for_saving Subst.identity) sg in + let cmi = + Persistent_env.make_cmi !persistent_env modname sg alerts + |> cmi_transform in + let pm = save_sign_of_cmi + { Persistent_env.Persistent_signature.cmi; filename } in + Persistent_env.save_cmi !persistent_env + { Persistent_env.Persistent_signature.filename; cmi } pm; + cmi + +let save_signature ~alerts sg modname filename = + save_signature_with_transform (fun cmi -> cmi) + ~alerts sg modname filename + +let save_signature_with_imports ~alerts sg modname filename imports = + let with_imports cmi = { cmi with cmi_crcs = imports } in + save_signature_with_transform with_imports + ~alerts sg modname filename + +(* Make the initial environment *) +let initial = + Predef.build_initial_env + (add_type ~check:false ~predef:true ~long_path:false) + (add_extension ~check:false ~rebind:false) + empty + +let add_type_long_path ~check id info env = + add_type ~check ~predef:false ~long_path:true id info env + +let add_type ~check id info env = + add_type ~check ~predef:false ~long_path:false id info env + +(* Tracking usage *) + +let mark_module_used uid = + match Types.Uid.Tbl.find !module_declarations uid with + | mark -> mark () + | exception Not_found -> () + +let mark_modtype_used _uid = () + +let mark_value_used uid = + match Types.Uid.Tbl.find !value_declarations uid with + | mark -> mark () + | exception Not_found -> () + +let mark_type_used uid = + match Types.Uid.Tbl.find !type_declarations uid with + | mark -> mark () + | exception Not_found -> () + +let mark_type_path_used env path = + match find_type path env with + | decl -> mark_type_used decl.type_uid + | exception Not_found -> () + +let mark_constructor_used usage cd = + match Types.Uid.Tbl.find !used_constructors cd.cd_uid with + | mark -> mark usage + | exception Not_found -> () + +let mark_extension_used usage ext = + match Types.Uid.Tbl.find !used_constructors ext.ext_uid with + | mark -> mark usage + | exception Not_found -> () + +let mark_label_used usage ld = + match Types.Uid.Tbl.find !used_labels ld.ld_uid with + | mark -> mark usage + | exception Not_found -> () + +let mark_constructor_description_used usage env cstr = + let ty_path = Btype.cstr_type_path cstr in + mark_type_path_used env ty_path; + match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with + | mark -> mark usage + | exception Not_found -> () + +let mark_label_description_used usage env lbl = + let ty_path = + match get_desc lbl.lbl_res with + | Tconstr(path, _, _) -> path + | _ -> assert false + in + mark_type_path_used env ty_path; + match Types.Uid.Tbl.find !used_labels lbl.lbl_uid with + | mark -> mark usage + | exception Not_found -> () + +let mark_class_used uid = + match Types.Uid.Tbl.find !type_declarations uid with + | mark -> mark () + | exception Not_found -> () + +let mark_cltype_used uid = + match Types.Uid.Tbl.find !type_declarations uid with + | mark -> mark () + | exception Not_found -> () + +let set_value_used_callback vd callback = + Types.Uid.Tbl.add !value_declarations vd.val_uid callback + +let set_type_used_callback td callback = + if Uid.for_actual_declaration td.type_uid then + let old = + try Types.Uid.Tbl.find !type_declarations td.type_uid + with Not_found -> ignore + in + Types.Uid.Tbl.replace !type_declarations td.type_uid + (fun () -> callback old) + +(* Lookup by name *) + +let may_lookup_error report_errors loc env err = + if report_errors then lookup_error loc env err + else raise Not_found + +let report_module_unbound ~errors ~loc env reason = + match reason with + | Mod_unbound_illegal_recursion -> + (* see #5965 *) + may_lookup_error errors loc env Illegal_reference_to_recursive_module + +let report_value_unbound ~errors ~loc env reason lid = + match reason with + | Val_unbound_instance_variable -> + may_lookup_error errors loc env (Masked_instance_variable lid) + | Val_unbound_self -> + may_lookup_error errors loc env (Masked_self_variable lid) + | Val_unbound_ancestor -> + may_lookup_error errors loc env (Masked_ancestor_variable lid) + | Val_unbound_ghost_recursive rloc -> + let show_hint = + (* Only display the "missing rec" hint for non-ghost code *) + not loc.Location.loc_ghost + && not rloc.Location.loc_ghost + in + let hint = + if show_hint then Missing_rec rloc else No_hint + in + may_lookup_error errors loc env (Unbound_value(lid, hint)) + +let use_module ~use ~loc path mda = + if use then begin + let comps = mda.mda_components in + mark_module_used comps.uid; + Misc.String.Map.iter + (fun kind message -> + let message = if message = "" then "" else "\n" ^ message in + Location.alert ~kind loc + (Printf.sprintf "module %s%s" (Path.name path) message) + ) + comps.alerts + end + +let use_value ~use ~loc path vda = + if use then begin + let desc = vda.vda_description in + mark_value_used desc.val_uid; + Builtin_attributes.check_alerts loc desc.val_attributes + (Path.name path) + end + +let use_type ~use ~loc path tda = + if use then begin + let decl = tda.tda_declaration in + mark_type_used decl.type_uid; + Builtin_attributes.check_alerts loc decl.type_attributes + (Path.name path) + end + +let use_modtype ~use ~loc path desc = + let open Subst.Lazy in + if use then begin + mark_modtype_used desc.mtdl_uid; + Builtin_attributes.check_alerts loc desc.mtdl_attributes + (Path.name path) + end + +let use_class ~use ~loc path clda = + if use then begin + let desc = clda.clda_declaration in + mark_class_used desc.cty_uid; + Builtin_attributes.check_alerts loc desc.cty_attributes + (Path.name path) + end + +let use_cltype ~use ~loc path desc = + if use then begin + mark_cltype_used desc.clty_uid; + Builtin_attributes.check_alerts loc desc.clty_attributes + (Path.name path) + end + +let use_label ~use ~loc usage env lbl = + if use then begin + mark_label_description_used usage env lbl; + Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name; + if is_mutating_label_usage usage then + Builtin_attributes.check_deprecated_mutable loc lbl.lbl_attributes + lbl.lbl_name + end + +let use_constructor_desc ~use ~loc usage env cstr = + if use then begin + mark_constructor_description_used usage env cstr; + Builtin_attributes.check_alerts loc cstr.cstr_attributes cstr.cstr_name + end + +let use_constructor ~use ~loc usage env cda = + use_constructor_desc ~use ~loc usage env cda.cda_description + +type _ load = + | Load : module_data load + | Don't_load : unit load + +let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env = + let path, data = + match find_name_module ~mark:use s env.modules with + | res -> res + | exception Not_found -> + may_lookup_error errors loc env (Unbound_module (Lident s)) + in + match data with + | Mod_local mda -> begin + use_module ~use ~loc path mda; + match load with + | Load -> path, (mda : a) + | Don't_load -> path, (() : a) + end + | Mod_unbound reason -> + report_module_unbound ~errors ~loc env reason + | Mod_persistent -> begin + match load with + | Don't_load -> + check_pers_mod ~loc s; + path, (() : a) + | Load -> begin + match find_pers_mod s with + | mda -> + use_module ~use ~loc path mda; + path, (mda : a) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_module (Lident s)) + end + end + +let lookup_ident_value ~errors ~use ~loc name env = + match IdTbl.find_name wrap_value ~mark:use name env.values with + | (path, Val_bound vda) -> + use_value ~use ~loc path vda; + path, vda.vda_description + | (_, Val_unbound reason) -> + report_value_unbound ~errors ~loc env reason (Lident name) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_value (Lident name, No_hint)) + +let lookup_ident_type ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.types with + | (path, data) as res -> + use_type ~use ~loc path data; + res + | exception Not_found -> + may_lookup_error errors loc env (Unbound_type (Lident s)) + +let lookup_ident_modtype ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.modtypes with + | (path, data) -> + use_modtype ~use ~loc path data.mtda_declaration; + (path, data.mtda_declaration) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_modtype (Lident s)) + +let lookup_ident_class ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.classes with + | (path, clda) -> + use_class ~use ~loc path clda; + path, clda.clda_declaration + | exception Not_found -> + may_lookup_error errors loc env (Unbound_class (Lident s)) + +let lookup_ident_cltype ~errors ~use ~loc s env = + match IdTbl.find_name wrap_identity ~mark:use s env.cltypes with + | path, cltda -> + use_cltype ~use ~loc path cltda.cltda_declaration; + path, cltda.cltda_declaration + | exception Not_found -> + may_lookup_error errors loc env (Unbound_cltype (Lident s)) + +let lookup_all_ident_labels ~errors ~use ~loc usage s env = + match TycompTbl.find_all ~mark:use s env.labels with + | [] -> may_lookup_error errors loc env (Unbound_label (Lident s)) + | lbls -> begin + List.map + (fun (lbl, use_fn) -> + let use_fn () = + use_label ~use ~loc usage env lbl; + use_fn () + in + (lbl, use_fn)) + lbls + end + +let lookup_all_ident_constructors ~errors ~use ~loc usage s env = + match TycompTbl.find_all ~mark:use s env.constrs with + | [] -> may_lookup_error errors loc env (Unbound_constructor (Lident s)) + | cstrs -> + List.map + (fun (cda, use_fn) -> + let use_fn () = + use_constructor ~use ~loc usage env cda; + use_fn () + in + (cda.cda_description, use_fn)) + cstrs + +let rec lookup_module_components ~errors ~use ~loc lid env = + match lid with + | Lident s -> + let path, data = lookup_ident_module Load ~errors ~use ~loc s env in + path, data.mda_components + | Ldot(l, s) -> + let path, data = lookup_dot_module ~errors ~use ~loc l s env in + path, data.mda_components + | Lapply _ as lid -> + let f_path, f_comp, arg = lookup_apply ~errors ~use ~loc lid env in + let comps = + !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env in + Papply (f_path, arg), comps + +and lookup_structure_components ~errors ~use ~loc lid env = + let path, comps = lookup_module_components ~errors ~use ~loc lid env in + match get_components_res comps with + | Ok (Structure_comps comps) -> path, comps + | Ok (Functor_comps _) -> + may_lookup_error errors loc env (Functor_used_as_structure lid) + | Error No_components_abstract -> + may_lookup_error errors loc env (Abstract_used_as_structure lid) + | Error (No_components_alias p) -> + may_lookup_error errors loc env (Cannot_scrape_alias(lid, p)) + +and get_functor_components ~errors ~loc lid env comps = + match get_components_res comps with + | Ok (Functor_comps fcomps) -> begin + match fcomps.fcomp_arg with + | Unit -> (* PR#7611 *) + may_lookup_error errors loc env (Generative_used_as_applicative lid) + | Named (_, arg) -> fcomps, arg + end + | Ok (Structure_comps _) -> + may_lookup_error errors loc env (Structure_used_as_functor lid) + | Error No_components_abstract -> + may_lookup_error errors loc env (Abstract_used_as_functor lid) + | Error (No_components_alias p) -> + may_lookup_error errors loc env (Cannot_scrape_alias(lid, p)) + +and lookup_all_args ~errors ~use ~loc lid0 env = + let rec loop_lid_arg args = function + | Lident _ | Ldot _ as f_lid -> + (f_lid, args) + | Lapply (f_lid, arg_lid) -> + let arg_path, arg_md = lookup_module ~errors ~use ~loc arg_lid env in + loop_lid_arg ((f_lid,arg_path,arg_md.md_type)::args) f_lid + in + loop_lid_arg [] lid0 + +and lookup_apply ~errors ~use ~loc lid0 env = + let f0_lid, args0 = lookup_all_args ~errors ~use ~loc lid0 env in + let args_for_errors = List.map (fun (_,p,mty) -> (p,mty)) args0 in + let f0_path, f0_comp = + lookup_module_components ~errors ~use ~loc f0_lid env + in + let check_one_apply ~errors ~loc ~f_lid ~f_comp ~arg_path ~arg_mty env = + let f_comp, param_mty = + get_functor_components ~errors ~loc f_lid env f_comp + in + check_functor_appl + ~errors ~loc ~lid_whole_app:lid0 + ~f0_path ~args:args_for_errors ~f_comp + ~arg_path ~arg_mty ~param_mty + env; + arg_path, f_comp + in + let rec check_apply ~path:f_path ~comp:f_comp = function + | [] -> invalid_arg "Env.lookup_apply: empty argument list" + | [ f_lid, arg_path, arg_mty ] -> + let arg_path, comps = + check_one_apply ~errors ~loc ~f_lid ~f_comp + ~arg_path ~arg_mty env + in + f_path, comps, arg_path + | (f_lid, arg_path, arg_mty) :: args -> + let arg_path, f_comp = + check_one_apply ~errors ~loc ~f_lid ~f_comp + ~arg_path ~arg_mty env + in + let comp = + !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg:arg_path env + in + let path = Papply (f_path, arg_path) in + check_apply ~path ~comp args + in + check_apply ~path:f0_path ~comp:f0_comp args0 + +and lookup_module ~errors ~use ~loc lid env = + match lid with + | Lident s -> + let path, data = lookup_ident_module Load ~errors ~use ~loc s env in + let md = Subst.Lazy.force_module_decl data.mda_declaration in + path, md + | Ldot(l, s) -> + let path, data = lookup_dot_module ~errors ~use ~loc l s env in + let md = Subst.Lazy.force_module_decl data.mda_declaration in + path, md + | Lapply _ as lid -> + let path_f, comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in + let md = md (modtype_of_functor_appl comp_f path_f path_arg) in + Papply(path_f, path_arg), md + +and lookup_dot_module ~errors ~use ~loc l s env = + let p, comps = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_modules with + | mda -> + let path = Pdot(p, s) in + use_module ~use ~loc path mda; + (path, mda) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_module (Ldot(l, s))) + +let lookup_dot_value ~errors ~use ~loc l s env = + let (path, comps) = + lookup_structure_components ~errors ~use ~loc l env + in + match NameMap.find s comps.comp_values with + | vda -> + let path = Pdot(path, s) in + use_value ~use ~loc path vda; + (path, vda.vda_description) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_value (Ldot(l, s), No_hint)) + +let lookup_dot_type ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_types with + | tda -> + let path = Pdot(p, s) in + use_type ~use ~loc path tda; + (path, tda) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_type (Ldot(l, s))) + +let lookup_dot_modtype ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_modtypes with + | mta -> + let path = Pdot(p, s) in + use_modtype ~use ~loc path mta.mtda_declaration; + (path, mta.mtda_declaration) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_modtype (Ldot(l, s))) + +let lookup_dot_class ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_classes with + | clda -> + let path = Pdot(p, s) in + use_class ~use ~loc path clda; + (path, clda.clda_declaration) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_class (Ldot(l, s))) + +let lookup_dot_cltype ~errors ~use ~loc l s env = + let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_cltypes with + | cltda -> + let path = Pdot(p, s) in + use_cltype ~use ~loc path cltda.cltda_declaration; + (path, cltda.cltda_declaration) + | exception Not_found -> + may_lookup_error errors loc env (Unbound_cltype (Ldot(l, s))) + +let lookup_all_dot_labels ~errors ~use ~loc usage l s env = + let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_labels with + | [] | exception Not_found -> + may_lookup_error errors loc env (Unbound_label (Ldot(l, s))) + | lbls -> + List.map + (fun lbl -> + let use_fun () = use_label ~use ~loc usage env lbl in + (lbl, use_fun)) + lbls + +let lookup_all_dot_constructors ~errors ~use ~loc usage l s env = + match l with + | Longident.Lident "*predef*" -> + (* Hack to support compilation of default arguments *) + lookup_all_ident_constructors + ~errors ~use ~loc usage s initial + | _ -> + let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in + match NameMap.find s comps.comp_constrs with + | [] | exception Not_found -> + may_lookup_error errors loc env (Unbound_constructor (Ldot(l, s))) + | cstrs -> + List.map + (fun cda -> + let use_fun () = use_constructor ~use ~loc usage env cda in + (cda.cda_description, use_fun)) + cstrs + +(* General forms of the lookup functions *) + +let lookup_module_path ~errors ~use ~loc ~load lid env : Path.t = + match lid with + | Lident s -> + if !Clflags.transparent_modules && not load then + fst (lookup_ident_module Don't_load ~errors ~use ~loc s env) + else + fst (lookup_ident_module Load ~errors ~use ~loc s env) + | Ldot(l, s) -> fst (lookup_dot_module ~errors ~use ~loc l s env) + | Lapply _ as lid -> + let path_f, _comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in + Papply(path_f, path_arg) + +let lookup_value ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_value ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_value ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_type_full ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_type ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_type ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_type ~errors ~use ~loc lid env = + let (path, tda) = lookup_type_full ~errors ~use ~loc lid env in + path, tda.tda_declaration + +let lookup_modtype_lazy ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_modtype ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_modtype ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_modtype ~errors ~use ~loc lid env = + let (path, mt) = lookup_modtype_lazy ~errors ~use ~loc lid env in + path, Subst.Lazy.force_modtype_decl mt + +let lookup_class ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_class ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_class ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_cltype ~errors ~use ~loc lid env = + match lid with + | Lident s -> lookup_ident_cltype ~errors ~use ~loc s env + | Ldot(l, s) -> lookup_dot_cltype ~errors ~use ~loc l s env + | Lapply _ -> assert false + +let lookup_all_labels ~errors ~use ~loc usage lid env = + match lid with + | Lident s -> lookup_all_ident_labels ~errors ~use ~loc usage s env + | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~loc usage l s env + | Lapply _ -> assert false + +let lookup_label ~errors ~use ~loc usage lid env = + match lookup_all_labels ~errors ~use ~loc usage lid env with + | [] -> assert false + | (desc, use) :: _ -> use (); desc + +let lookup_all_labels_from_type ~use ~loc usage ty_path env = + match find_type_descrs ty_path env with + | exception Not_found -> [] + | Type_variant _ | Type_abstract | Type_open -> [] + | Type_record (lbls, _) -> + List.map + (fun lbl -> + let use_fun () = use_label ~use ~loc usage env lbl in + (lbl, use_fun)) + lbls + +let lookup_all_constructors ~errors ~use ~loc usage lid env = + match lid with + | Lident s -> lookup_all_ident_constructors ~errors ~use ~loc usage s env + | Ldot(l, s) -> lookup_all_dot_constructors ~errors ~use ~loc usage l s env + | Lapply _ -> assert false + +let lookup_constructor ~errors ~use ~loc usage lid env = + match lookup_all_constructors ~errors ~use ~loc usage lid env with + | [] -> assert false + | (desc, use) :: _ -> use (); desc + +let lookup_all_constructors_from_type ~use ~loc usage ty_path env = + match find_type_descrs ty_path env with + | exception Not_found -> [] + | Type_record _ | Type_abstract | Type_open -> [] + | Type_variant (cstrs, _) -> + List.map + (fun cstr -> + let use_fun () = + use_constructor_desc ~use ~loc usage env cstr + in + (cstr, use_fun)) + cstrs + +(* Lookup functions that do not mark the item as used or + warn if it has alerts, and raise [Not_found] rather + than report errors *) + +let find_module_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_module ~errors:false ~use:false ~loc lid env + +let find_value_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_value ~errors:false ~use:false ~loc lid env + +let find_type_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_type ~errors:false ~use:false ~loc lid env + +let find_modtype_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_modtype ~errors:false ~use:false ~loc lid env + +let find_class_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_class ~errors:false ~use:false ~loc lid env + +let find_cltype_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_cltype ~errors:false ~use:false ~loc lid env + +let find_constructor_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_constructor ~errors:false ~use:false ~loc Positive lid env + +let find_label_by_name lid env = + let loc = Location.(in_file !input_name) in + lookup_label ~errors:false ~use:false ~loc Projection lid env + +(* Stable name lookup for printing *) + +let find_index_tbl ident tbl = + let lbs = IdTbl.find_all_idents (Ident.name ident) tbl in + let find_ident (n,p) = match p with + | Some id -> if Ident.same ident id then Some n else None + | _ -> None + in + Seq.find_map find_ident @@ Seq.mapi (fun i x -> i,x) lbs + +let find_value_index id env = find_index_tbl id env.values +let find_type_index id env = find_index_tbl id env.types +let find_module_index id env = find_index_tbl id env.modules +let find_modtype_index id env = find_index_tbl id env.modtypes +let find_class_index id env = find_index_tbl id env.classes +let find_cltype_index id env = find_index_tbl id env.cltypes + +(* Ordinary lookup functions *) + +let lookup_module_path ?(use=true) ~loc ~load lid env = + lookup_module_path ~errors:true ~use ~loc ~load lid env + +let lookup_module ?(use=true) ~loc lid env = + lookup_module ~errors:true ~use ~loc lid env + +let lookup_value ?(use=true) ~loc lid env = + check_value_name (Longident.last lid) loc; + lookup_value ~errors:true ~use ~loc lid env + +let lookup_type ?(use=true) ~loc lid env = + lookup_type ~errors:true ~use ~loc lid env + +let lookup_modtype ?(use=true) ~loc lid env = + lookup_modtype ~errors:true ~use ~loc lid env + +let lookup_modtype_path ?(use=true) ~loc lid env = + fst (lookup_modtype_lazy ~errors:true ~use ~loc lid env) + +let lookup_class ?(use=true) ~loc lid env = + lookup_class ~errors:true ~use ~loc lid env + +let lookup_cltype ?(use=true) ~loc lid env = + lookup_cltype ~errors:true ~use ~loc lid env + +let lookup_all_constructors ?(use=true) ~loc usage lid env = + match lookup_all_constructors ~errors:true ~use ~loc usage lid env with + | exception Error(Lookup_error(loc', env', err)) -> + (Error(loc', env', err) : _ result) + | cstrs -> Ok cstrs + +let lookup_constructor ?(use=true) ~loc lid env = + lookup_constructor ~errors:true ~use ~loc lid env + +let lookup_all_constructors_from_type ?(use=true) ~loc usage ty_path env = + lookup_all_constructors_from_type ~use ~loc usage ty_path env + +let lookup_all_labels ?(use=true) ~loc usage lid env = + match lookup_all_labels ~errors:true ~use ~loc usage lid env with + | exception Error(Lookup_error(loc', env', err)) -> + (Error(loc', env', err) : _ result) + | lbls -> Ok lbls + +let lookup_label ?(use=true) ~loc lid env = + lookup_label ~errors:true ~use ~loc lid env + +let lookup_all_labels_from_type ?(use=true) ~loc usage ty_path env = + lookup_all_labels_from_type ~use ~loc usage ty_path env + +let lookup_instance_variable ?(use=true) ~loc name env = + match IdTbl.find_name wrap_value ~mark:use name env.values with + | (path, Val_bound vda) -> begin + let desc = vda.vda_description in + match desc.val_kind with + | Val_ivar(mut, cl_num) -> + use_value ~use ~loc path vda; + path, mut, cl_num, desc.val_type + | _ -> + lookup_error loc env (Not_an_instance_variable name) + end + | (_, Val_unbound Val_unbound_instance_variable) -> + lookup_error loc env (Masked_instance_variable (Lident name)) + | (_, Val_unbound Val_unbound_self) -> + lookup_error loc env (Not_an_instance_variable name) + | (_, Val_unbound Val_unbound_ancestor) -> + lookup_error loc env (Not_an_instance_variable name) + | (_, Val_unbound Val_unbound_ghost_recursive _) -> + lookup_error loc env (Unbound_instance_variable name) + | exception Not_found -> + lookup_error loc env (Unbound_instance_variable name) + +(* Checking if a name is bound *) + +let bound_module name env = + match IdTbl.find_name wrap_module ~mark:false name env.modules with + | _ -> true + | exception Not_found -> + if Current_unit_name.is name then false + else begin + match find_pers_mod name with + | _ -> true + | exception Not_found -> false + end + +let bound wrap proj name env = + match IdTbl.find_name wrap ~mark:false name (proj env) with + | _ -> true + | exception Not_found -> false + +let bound_value name env = + bound wrap_value (fun env -> env.values) name env + +let bound_type name env = + bound wrap_identity (fun env -> env.types) name env + +let bound_modtype name env = + bound wrap_identity (fun env -> env.modtypes) name env + +let bound_class name env = + bound wrap_identity (fun env -> env.classes) name env + +let bound_cltype name env = + bound wrap_identity (fun env -> env.cltypes) name env + +(* Folding on environments *) + +let find_all wrap proj1 proj2 f lid env acc = + match lid with + | None -> + IdTbl.fold_name wrap + (fun name (p, data) acc -> f name p data acc) + (proj1 env) acc + | Some l -> + let p, desc = + lookup_module_components + ~errors:false ~use:false ~loc:Location.none l env + in + begin match get_components desc with + | Structure_comps c -> + NameMap.fold + (fun s data acc -> f s (Pdot (p, s)) (wrap data) acc) + (proj2 c) acc + | Functor_comps _ -> + acc + end + +let find_all_simple_list proj1 proj2 f lid env acc = + match lid with + | None -> + TycompTbl.fold_name + (fun data acc -> f data acc) + (proj1 env) acc + | Some l -> + let (_p, desc) = + lookup_module_components + ~errors:false ~use:false ~loc:Location.none l env + in + begin match get_components desc with + | Structure_comps c -> + NameMap.fold + (fun _s comps acc -> + match comps with + | [] -> acc + | data :: _ -> f data acc) + (proj2 c) acc + | Functor_comps _ -> + acc + end + +let fold_modules f lid env acc = + match lid with + | None -> + IdTbl.fold_name wrap_module + (fun name (p, entry) acc -> + match entry with + | Mod_unbound _ -> acc + | Mod_local mda -> + let md = + Subst.Lazy.force_module_decl mda.mda_declaration + in + f name p md acc + | Mod_persistent -> + match Persistent_env.find_in_cache !persistent_env name with + | None -> acc + | Some mda -> + let md = + Subst.Lazy.force_module_decl mda.mda_declaration + in + f name p md acc) + env.modules + acc + | Some l -> + let p, desc = + lookup_module_components + ~errors:false ~use:false ~loc:Location.none l env + in + begin match get_components desc with + | Structure_comps c -> + NameMap.fold + (fun s mda acc -> + let md = + Subst.Lazy.force_module_decl mda.mda_declaration + in + f s (Pdot (p, s)) md acc) + c.comp_modules + acc + | Functor_comps _ -> + acc + end + +let fold_values f = + find_all wrap_value (fun env -> env.values) (fun sc -> sc.comp_values) + (fun k p ve acc -> + match ve with + | Val_unbound _ -> acc + | Val_bound vda -> f k p vda.vda_description acc) +and fold_constructors f = + find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) + (fun cda acc -> f cda.cda_description acc) +and fold_labels f = + find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f +and fold_types f = + find_all wrap_identity + (fun env -> env.types) (fun sc -> sc.comp_types) + (fun k p tda acc -> f k p tda.tda_declaration acc) +and fold_modtypes f = + let f l path data acc = f l path (Subst.Lazy.force_modtype_decl data) acc in + find_all wrap_identity + (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + (fun k p mta acc -> f k p mta.mtda_declaration acc) +and fold_classes f = + find_all wrap_identity (fun env -> env.classes) (fun sc -> sc.comp_classes) + (fun k p clda acc -> f k p clda.clda_declaration acc) +and fold_cltypes f = + find_all wrap_identity + (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) + (fun k p cltda acc -> f k p cltda.cltda_declaration acc) + +let filter_non_loaded_persistent f env = + let to_remove = + IdTbl.fold_name wrap_module + (fun name (_, entry) acc -> + match entry with + | Mod_local _ -> acc + | Mod_unbound _ -> acc + | Mod_persistent -> + match Persistent_env.find_in_cache !persistent_env name with + | Some _ -> acc + | None -> + if f (Ident.create_persistent name) then + acc + else + String.Set.add name acc) + env.modules + String.Set.empty + in + let remove_ids tbl ids = + String.Set.fold + (fun name tbl -> IdTbl.remove (Ident.create_persistent name) tbl) + ids + tbl + in + let rec filter_summary summary ids = + if String.Set.is_empty ids then + summary + else + match summary with + Env_persistent (s, id) when String.Set.mem (Ident.name id) ids -> + filter_summary s (String.Set.remove (Ident.name id) ids) + | Env_empty + | Env_value _ + | Env_type _ + | Env_extension _ + | Env_module _ + | Env_modtype _ + | Env_class _ + | Env_cltype _ + | Env_open _ + | Env_functor_arg _ + | Env_constraints _ + | Env_copy_types _ + | Env_persistent _ + | Env_value_unbound _ + | Env_module_unbound _ -> + map_summary (fun s -> filter_summary s ids) summary + in + { env with + modules = remove_ids env.modules to_remove; + summary = filter_summary env.summary to_remove; + } + +(* Return the environment summary *) + +let summary env = + if Path.Map.is_empty env.local_constraints then env.summary + else Env_constraints (env.summary, env.local_constraints) + +let last_env = s_ref empty +let last_reduced_env = s_ref empty + +let keep_only_summary env = + if !last_env == env then !last_reduced_env + else begin + let new_env = + { + empty with + summary = env.summary; + local_constraints = env.local_constraints; + flags = env.flags; + } + in + last_env := env; + last_reduced_env := new_env; + new_env + end + + +let env_of_only_summary env_from_summary env = + let new_env = env_from_summary env.summary Subst.identity in + { new_env with + local_constraints = env.local_constraints; + flags = env.flags; + } + +(* Error report *) + +open Format + +(* Forward declarations *) + +let print_longident = + ref ((fun _ _ -> assert false) : formatter -> Longident.t -> unit) + +let print_path = + ref ((fun _ _ -> assert false) : formatter -> Path.t -> unit) + +let spellcheck ppf extract env lid = + let choices ~path name = Misc.spellcheck (extract path env) name in + match lid with + | Longident.Lapply _ -> () + | Longident.Lident s -> + Misc.did_you_mean ppf (fun () -> choices ~path:None s) + | Longident.Ldot (r, s) -> + Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) + +let spellcheck_name ppf extract env name = + Misc.did_you_mean ppf + (fun () -> Misc.spellcheck (extract env) name) + +let extract_values path env = + fold_values (fun name _ _ acc -> name :: acc) path env [] +let extract_types path env = + fold_types (fun name _ _ acc -> name :: acc) path env [] +let extract_modules path env = + fold_modules (fun name _ _ acc -> name :: acc) path env [] +let extract_constructors path env = + fold_constructors (fun desc acc -> desc.cstr_name :: acc) path env [] +let extract_labels path env = + fold_labels (fun desc acc -> desc.lbl_name :: acc) path env [] +let extract_classes path env = + fold_classes (fun name _ _ acc -> name :: acc) path env [] +let extract_modtypes path env = + fold_modtypes (fun name _ _ acc -> name :: acc) path env [] +let extract_cltypes path env = + fold_cltypes (fun name _ _ acc -> name :: acc) path env [] +let extract_instance_variables env = + fold_values + (fun name _ descr acc -> + match descr.val_kind with + | Val_ivar _ -> name :: acc + | _ -> acc) None env [] + +let report_lookup_error _loc env ppf = function + | Unbound_value(lid, hint) -> begin + fprintf ppf "Unbound value %a" !print_longident lid; + spellcheck ppf extract_values env lid; + match hint with + | No_hint -> () + | Missing_rec def_loc -> + let (_, line, _) = + Location.get_pos_info def_loc.Location.loc_start + in + fprintf ppf + "@.@[@{Hint@}: If this is a recursive definition,@ %s %i@]" + "you should add the 'rec' keyword on line" + line + end + | Unbound_type lid -> + fprintf ppf "Unbound type constructor %a" !print_longident lid; + spellcheck ppf extract_types env lid; + | Unbound_module lid -> begin + fprintf ppf "Unbound module %a" !print_longident lid; + match find_modtype_by_name lid env with + | exception Not_found -> spellcheck ppf extract_modules env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a module type named %a, %s@]" + !print_longident lid + "but module types are not modules" + end + | Unbound_constructor lid -> + fprintf ppf "Unbound constructor %a" !print_longident lid; + spellcheck ppf extract_constructors env lid; + | Unbound_label lid -> + fprintf ppf "Unbound record field %a" !print_longident lid; + spellcheck ppf extract_labels env lid; + | Unbound_class lid -> begin + fprintf ppf "Unbound class %a" !print_longident lid; + match find_cltype_by_name lid env with + | exception Not_found -> spellcheck ppf extract_classes env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a class type named %a, %s@]" + !print_longident lid + "but classes are not class types" + end + | Unbound_modtype lid -> begin + fprintf ppf "Unbound module type %a" !print_longident lid; + match find_module_by_name lid env with + | exception Not_found -> spellcheck ppf extract_modtypes env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a module named %a, %s@]" + !print_longident lid + "but modules are not module types" + end + | Unbound_cltype lid -> + fprintf ppf "Unbound class type %a" !print_longident lid; + spellcheck ppf extract_cltypes env lid; + | Unbound_instance_variable s -> + fprintf ppf "Unbound instance variable %s" s; + spellcheck_name ppf extract_instance_variables env s; + | Not_an_instance_variable s -> + fprintf ppf "The value %s is not an instance variable" s; + spellcheck_name ppf extract_instance_variables env s; + | Masked_instance_variable lid -> + fprintf ppf + "The instance variable %a@ \ + cannot be accessed from the definition of another instance variable" + !print_longident lid + | Masked_self_variable lid -> + fprintf ppf + "The self variable %a@ \ + cannot be accessed from the definition of an instance variable" + !print_longident lid + | Masked_ancestor_variable lid -> + fprintf ppf + "The ancestor variable %a@ \ + cannot be accessed from the definition of an instance variable" + !print_longident lid + | Illegal_reference_to_recursive_module -> + fprintf ppf "Illegal recursive module reference" + | Structure_used_as_functor lid -> + fprintf ppf "@[The module %a is a structure, it cannot be applied@]" + !print_longident lid + | Abstract_used_as_functor lid -> + fprintf ppf "@[The module %a is abstract, it cannot be applied@]" + !print_longident lid + | Functor_used_as_structure lid -> + fprintf ppf "@[The module %a is a functor, \ + it cannot have any components@]" !print_longident lid + | Abstract_used_as_structure lid -> + fprintf ppf "@[The module %a is abstract, \ + it cannot have any components@]" !print_longident lid + | Generative_used_as_applicative lid -> + fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \ + applied@ in@ type@ expressions@]" !print_longident lid + | Cannot_scrape_alias(lid, p) -> + let cause = + if Current_unit_name.is_path p then "is the current compilation unit" + else "is missing" + in + fprintf ppf + "The module %a is an alias for module %a, which %s" + !print_longident lid !print_path p cause + +let report_error ppf = function + | Missing_module(_, path1, path2) -> + fprintf ppf "@[@["; + if Path.same path1 path2 then + fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1) + else + fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling." + (Path.name path1) (Path.name path2); + fprintf ppf "@]@ @[%s@ %s@ %s.@]@]" + "The compiled interface for module" (Ident.name (Path.head path2)) + "was not found" + | Illegal_value_name(_loc, name) -> + fprintf ppf "'%s' is not a valid value identifier." + name + | Lookup_error(loc, t, err) -> report_lookup_error loc t ppf err + +let () = + Location.register_error_of_exn + (function + | Error err -> + let loc = + match err with + | Missing_module (loc, _, _) + | Illegal_value_name (loc, _) + | Lookup_error(loc, _, _) -> loc + in + let error_of_printer = + if loc = Location.none + then Location.error_of_printer_file + else Location.error_of_printer ~loc ?sub:None + in + Some (error_of_printer report_error err) + | _ -> + None + ) + +(* helper for merlin *) + +let check_state_consistency () = + let missing modname = + match Load_path.find_uncap (modname ^ ".cmi") with + | _ -> false + | exception Not_found -> true + and found _modname filename ps_name _md = + match Cmi_cache.get_cached_entry filename with + | cmi_infos -> ps_name == cmi_infos.Cmi_format.cmi_name + | exception Not_found -> false + in + Persistent_env.forall ~found ~missing !persistent_env + +let with_cmis f = + Persistent_env.with_cmis !persistent_env f () + +let add_merlin_extension_module id mty env = add_module id Mp_present mty env + +(* Update short paths *) + +let rec index l x = + match l with + [] -> raise Not_found + | a :: l -> if x == a then 0 else 1 + index l x + +let rec uniq = function + [] -> true + | a :: l -> not (List.memq a l) && uniq l + +let short_paths_type_desc decl = + let open Short_paths.Desc.Type in + match decl.type_manifest with + | None -> Fresh + | Some ty -> + let ty = Transient_expr.repr ty in + if ty.level <> Btype.generic_level then Fresh + else begin + match decl.type_private, decl.type_kind with + | Private, Type_abstract -> Fresh + | _, _ -> begin + let params = List.map get_desc decl.type_params in + match ty with + | {desc = Tconstr (path, args, _)} -> + let args = List.map get_desc args in + if List.length params = List.length args + && List.for_all2 (==) params args + then Alias path + else if List.length params <= List.length args + || not (uniq args) then Fresh + else begin + match List.map (index params) args with + | exception Not_found -> Fresh + | ns -> Subst(path, ns) + end + | ty -> begin + let ty = Transient_expr.type_expr ty in + match index params (get_desc ty) with + | exception Not_found -> Fresh + | n -> Nth n + end + end + end + +let short_paths_class_type_desc clty = + let open Short_paths.Desc.Class_type in + match clty.clty_type with + | Cty_signature _ | Cty_arrow _ -> Fresh + | Cty_constr(path, args, _) -> + let params = List.map get_desc clty.clty_params in + let args = List.map get_desc args in + if List.length params = List.length args + && List.for_all2 (==) params args + then Alias path + else if List.length params <= List.length args + || not (uniq args) then Fresh + else begin + match List.map (index params) args with + | exception Not_found -> Fresh + | ns -> Subst(path, ns) + end + +let short_paths_module_type_desc mty = + let open Short_paths.Desc.Module_type in + match mty with + | None | Some Mty_for_hole -> Fresh + | Some (Mty_ident path) -> Alias path + | Some (Mty_signature _ | Mty_functor _) -> Fresh + | Some (Mty_alias _) -> assert false + +let deprecated_of_alerts alerts = + if + String.Map.exists (fun key _ -> + match key with + | "deprecated" | "ocaml.deprecated" -> true + | _ -> false + ) alerts + then + Short_paths.Desc.Deprecated + else + Short_paths.Desc.Not_deprecated + +let deprecated_of_attributes attrs = + deprecated_of_alerts (Builtin_attributes.alerts_of_attrs attrs) + +let rec short_paths_module_desc env mpath mty comp = + let open Short_paths.Desc.Module in + match mty with + | Mty_alias path -> Alias path + | Mty_ident path -> begin + match find_modtype_expansion path env with + | exception Not_found -> Fresh (Signature (lazy [])) + | mty -> short_paths_module_desc env mpath mty comp + end + | Mty_signature _ -> + let components = + lazy (short_paths_module_components_desc env mpath comp) + in + Fresh (Signature components) + | Mty_functor _ -> + let apply path = + short_paths_functor_components_desc env mpath comp path + in + Fresh (Functor apply) + | Mty_for_hole -> Fresh (Signature (lazy [])) + +and short_paths_module_components_desc env mpath comp = + match get_components comp with + | Functor_comps _ -> assert false + | Structure_comps c -> + let comps = + String.Map.fold (fun name { tda_declaration = decl; _ } acc -> + let desc = short_paths_type_desc decl in + let depr = deprecated_of_attributes decl.type_attributes in + let item = Short_paths.Desc.Module.Type(name, desc, depr) in + item :: acc + ) c.comp_types [] + in + let comps = + String.Map.fold (fun name cltda acc -> + let clty = cltda.cltda_declaration in + let desc = short_paths_class_type_desc clty in + let depr = deprecated_of_attributes clty.clty_attributes in + let item = Short_paths.Desc.Module.Class_type(name, desc, depr) in + item :: acc + ) c.comp_cltypes comps + in + let comps = + String.Map.fold (fun name mtda acc -> + let mtd = Subst.Lazy.force_modtype_decl mtda.mtda_declaration in + let desc = short_paths_module_type_desc mtd.mtd_type in + let depr = deprecated_of_attributes mtd.mtd_attributes in + let item = Short_paths.Desc.Module.Module_type(name, desc, depr) in + item :: acc + ) c.comp_modtypes comps + in + let comps = + String.Map.fold (fun name { mda_declaration; mda_components; _ } acc -> + let mty = Subst.Lazy.force_module_decl mda_declaration in + let mpath = Pdot(mpath, name) in + let desc = + short_paths_module_desc env mpath mty.md_type mda_components + in + let depr = deprecated_of_alerts mda_components.alerts in + let item = Short_paths.Desc.Module.Module(name, desc, depr) in + item :: acc + ) c.comp_modules comps + in + comps + +and short_paths_functor_components_desc env mpath comp path = + match get_components comp with + | Structure_comps _ -> assert false + | Functor_comps f -> + let mty = + try + stamped_find f.fcomp_subst_cache path + with Not_found -> + let mty = + let subst = + match f.fcomp_arg with + | Unit + | Named (None, _) -> Subst.identity + | Named (Some id, _) -> Subst.add_module id path Subst.identity + in + Subst.modtype (Rescope (Path.scope (Papply (mpath, path)))) + subst f.fcomp_res + in + stamped_add f.fcomp_subst_cache path mty; + mty + in + let loc = Location.(in_file !input_name) in + let comps = + components_of_functor_appl ~loc ~f_comp:f env ~f_path:mpath ~arg:path + in + let mpath = Papply(mpath, path) in + short_paths_module_desc env mpath mty comps + +let short_paths_additions_desc env additions = + List.fold_left + (fun acc add -> + match add with + | Type(id, decl) -> + let desc = short_paths_type_desc decl in + let source = Short_paths.Desc.Local in + let depr = deprecated_of_attributes decl.type_attributes in + Short_paths.Desc.Type(id, desc, source, depr) :: acc + | Class_type(id, clty) -> + let desc = short_paths_class_type_desc clty in + let source = Short_paths.Desc.Local in + let depr = deprecated_of_attributes clty.clty_attributes in + Short_paths.Desc.Class_type(id, desc, source, depr) :: acc + | Module_type(id, mtd) -> + let desc = short_paths_module_type_desc mtd.mtd_type in + let source = Short_paths.Desc.Local in + let depr = deprecated_of_attributes mtd.mtd_attributes in + Short_paths.Desc.Module_type(id, desc, source, depr) :: acc + | Module(id, md, comps) -> + let desc = + short_paths_module_desc env (Pident id) md.md_type comps + in + let source = Short_paths.Desc.Local in + let depr = deprecated_of_alerts comps.alerts in + Short_paths.Desc.Module(id, desc, source, depr) :: acc + | Type_open(root, decls) -> + String.Map.fold + (fun name { tda_declaration = decl; _ } acc -> + let id = Ident.create_local name in + let path = Pdot(root, name) in + let desc = Short_paths.Desc.Type.Alias path in + let source = Short_paths.Desc.Open in + let depr = deprecated_of_attributes decl.type_attributes in + Short_paths.Desc.Type(id, desc, source, depr) :: acc) + decls acc + | Class_type_open(root, decls) -> + String.Map.fold + (fun name clty acc -> + let id = Ident.create_local name in + let path = Pdot(root, name) in + let desc = Short_paths.Desc.Class_type.Alias path in + let source = Short_paths.Desc.Open in + let depr = deprecated_of_attributes clty.clty_attributes in + Short_paths.Desc.Class_type(id, desc, source, depr) :: acc) + decls acc + | Module_type_open(root, decls) -> + String.Map.fold + (fun name mtd acc -> + let id = Ident.create_local name in + let path = Pdot(root, name) in + let desc = Short_paths.Desc.Module_type.Alias path in + let source = Short_paths.Desc.Open in + let depr = deprecated_of_attributes mtd.mtd_attributes in + Short_paths.Desc.Module_type(id, desc, source, depr) :: acc) + decls acc + | Module_open(root, decls) -> + String.Map.fold + (fun name { mda_components = comps; _ } acc -> + let id = Ident.create_local name in + let path = Pdot(root, name) in + let desc = Short_paths.Desc.Module.Alias path in + let source = Short_paths.Desc.Open in + let depr = deprecated_of_alerts comps.alerts in + Short_paths.Desc.Module(id, desc, source, depr) :: acc) + decls acc) + [] additions + +let () = + short_paths_module_components_desc' := short_paths_module_components_desc + +let update_short_paths env = + let env, short_paths = + match env.short_paths with + | None -> + let basis = Persistent_env.short_paths_basis !persistent_env in + let short_paths = Short_paths.initial basis in + let env = { env with short_paths = Some short_paths } in + env, short_paths + | Some short_paths -> env, short_paths + in + match env.short_paths_additions with + | [] -> env + | _ :: _ as additions -> + let short_paths = + Short_paths.add short_paths + (lazy (short_paths_additions_desc env additions)) + in + { env with short_paths = Some short_paths; + short_paths_additions = []; } + +let short_paths env = + match env.short_paths with + | None -> + let basis = Persistent_env.short_paths_basis !persistent_env in + Short_paths.initial basis + | Some short_paths -> short_paths + +let cleanup_functor_caches ~stamp = + Stamped_hashtable.backtrack !stamped_changelog ~stamp diff --git a/ocamlmerlin_mlx/ocaml/typing/env.mli b/ocamlmerlin_mlx/ocaml/typing/env.mli new file mode 100644 index 0000000..f8c95da --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/env.mli @@ -0,0 +1,549 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Environment handling *) + +open Types +open Misc + +val register_uid : Uid.t -> Location.t -> unit + +val get_uid_to_loc_tbl : unit -> Location.t Types.Uid.Tbl.t + +type value_unbound_reason = + | Val_unbound_instance_variable + | Val_unbound_self + | Val_unbound_ancestor + | Val_unbound_ghost_recursive of Location.t + +type module_unbound_reason = + | Mod_unbound_illegal_recursion + +type summary = + Env_empty + | Env_value of summary * Ident.t * value_description + | Env_type of summary * Ident.t * type_declaration + | Env_extension of summary * Ident.t * extension_constructor + | Env_module of summary * Ident.t * module_presence * module_declaration + | Env_modtype of summary * Ident.t * modtype_declaration + | Env_class of summary * Ident.t * class_declaration + | Env_cltype of summary * Ident.t * class_type_declaration + | Env_open of summary * Path.t + (** The string set argument of [Env_open] represents a list of module names + to skip, i.e. that won't be imported in the toplevel namespace. *) + | Env_functor_arg of summary * Ident.t + | Env_constraints of summary * type_declaration Path.Map.t + | Env_copy_types of summary + | Env_persistent of summary * Ident.t + | Env_value_unbound of summary * string * value_unbound_reason + | Env_module_unbound of summary * string * module_unbound_reason + +type address = + | Aident of Ident.t + | Adot of address * int + +type t + +val empty: t +val initial: t +val diff: t -> t -> Ident.t list + +type type_descr_kind = + (label_description, constructor_description) type_kind + + (* alias for compatibility *) +type type_descriptions = type_descr_kind + +(* For short-paths *) +type iter_cont +val iter_types: + (Path.t -> Path.t * type_declaration -> unit) -> + t -> iter_cont +val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list +val same_types: t -> t -> bool +val used_persistent: unit -> String.Set.t +val find_shadowed_types: Path.t -> t -> Path.t list +val without_cmis: ('a -> 'b) -> 'a -> 'b +(* [without_cmis f arg] applies [f] to [arg], but does not + allow opening cmis during its execution *) + +(* Lookup by paths *) + +val find_value: Path.t -> t -> value_description +val find_type: Path.t -> t -> type_declaration +val find_type_descrs: Path.t -> t -> type_descriptions +val find_module: Path.t -> t -> module_declaration +val find_modtype: Path.t -> t -> modtype_declaration +val find_class: Path.t -> t -> class_declaration +val find_cltype: Path.t -> t -> class_type_declaration + +val find_strengthened_module: + aliasable:bool -> Path.t -> t -> module_type + +val find_ident_constructor: Ident.t -> t -> constructor_description +val find_ident_label: Ident.t -> t -> label_description + +val find_type_expansion: + Path.t -> t -> type_expr list * type_expr * int +val find_type_expansion_opt: + Path.t -> t -> type_expr list * type_expr * int +(* Find the manifest type information associated to a type for the sake + of the compiler's type-based optimisations. *) +val find_modtype_expansion: Path.t -> t -> module_type +val find_modtype_expansion_lazy: Path.t -> t -> Subst.Lazy.modtype + +val find_hash_type: Path.t -> t -> type_declaration +(* Find the "#t" type given the path for "t" *) + +val find_value_address: Path.t -> t -> address +val find_module_address: Path.t -> t -> address +val find_class_address: Path.t -> t -> address +val find_constructor_address: Path.t -> t -> address + +val shape_of_path: + namespace:Shape.Sig_component_kind.t -> t -> Path.t -> Shape.t + +val add_functor_arg: Ident.t -> t -> t +val is_functor_arg: Path.t -> t -> bool + +val normalize_module_path: Location.t option -> t -> Path.t -> Path.t +(* Normalize the path to a concrete module. + If the option is None, allow returning dangling paths. + Otherwise raise a Missing_module error, and may add forgotten + head as required global. *) + +val normalize_type_path: Location.t option -> t -> Path.t -> Path.t +(* Normalize the prefix part of the type path *) + +val normalize_value_path: Location.t option -> t -> Path.t -> Path.t +(* Normalize the prefix part of the value path *) + +val normalize_modtype_path: t -> Path.t -> Path.t +(* Normalize a module type path *) + +val reset_required_globals: unit -> unit +val get_required_globals: unit -> Ident.t list +val add_required_global: Ident.t -> unit + +val has_local_constraints: t -> bool + +(* Mark definitions as used *) +val mark_value_used: Uid.t -> unit +val mark_module_used: Uid.t -> unit +val mark_type_used: Uid.t -> unit + +type constructor_usage = Positive | Pattern | Exported_private | Exported +val mark_constructor_used: + constructor_usage -> constructor_declaration -> unit +val mark_extension_used: + constructor_usage -> extension_constructor -> unit + +type label_usage = + Projection | Mutation | Construct | Exported_private | Exported +val mark_label_used: + label_usage -> label_declaration -> unit + +(* Lookup by long identifiers *) + +(* Lookup errors *) + +type unbound_value_hint = + | No_hint + | Missing_rec of Location.t + +type lookup_error = + | Unbound_value of Longident.t * unbound_value_hint + | Unbound_type of Longident.t + | Unbound_constructor of Longident.t + | Unbound_label of Longident.t + | Unbound_module of Longident.t + | Unbound_class of Longident.t + | Unbound_modtype of Longident.t + | Unbound_cltype of Longident.t + | Unbound_instance_variable of string + | Not_an_instance_variable of string + | Masked_instance_variable of Longident.t + | Masked_self_variable of Longident.t + | Masked_ancestor_variable of Longident.t + | Structure_used_as_functor of Longident.t + | Abstract_used_as_functor of Longident.t + | Functor_used_as_structure of Longident.t + | Abstract_used_as_structure of Longident.t + | Generative_used_as_applicative of Longident.t + | Illegal_reference_to_recursive_module + | Cannot_scrape_alias of Longident.t * Path.t + +val lookup_error: Location.t -> t -> lookup_error -> 'a + +(* The [lookup_foo] functions will emit proper error messages (by + raising [Error]) if the identifier cannot be found, whereas the + [find_foo_by_name] functions will raise [Not_found] instead. + + The [~use] parameters of the [lookup_foo] functions control + whether this lookup should be counted as a use for usage + warnings and alerts. + + [Longident.t]s in the program source should be looked up using + [lookup_foo ~use:true] exactly one time -- otherwise warnings may be + emitted the wrong number of times. *) + +val lookup_value: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * value_description +val lookup_type: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * type_declaration +val lookup_module: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * module_declaration +val lookup_modtype: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * modtype_declaration +val lookup_class: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * class_declaration +val lookup_cltype: + ?use:bool -> loc:Location.t -> Longident.t -> t -> + Path.t * class_type_declaration + +val lookup_module_path: + ?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> Path.t +val lookup_modtype_path: + ?use:bool -> loc:Location.t -> Longident.t -> t -> Path.t + +val lookup_constructor: + ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t -> + constructor_description +val lookup_all_constructors: + ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t -> + ((constructor_description * (unit -> unit)) list, + Location.t * t * lookup_error) result +val lookup_all_constructors_from_type: + ?use:bool -> loc:Location.t -> constructor_usage -> Path.t -> t -> + (constructor_description * (unit -> unit)) list + +val lookup_label: + ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t -> + label_description +val lookup_all_labels: + ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t -> + ((label_description * (unit -> unit)) list, + Location.t * t * lookup_error) result +val lookup_all_labels_from_type: + ?use:bool -> loc:Location.t -> label_usage -> Path.t -> t -> + (label_description * (unit -> unit)) list + +val lookup_instance_variable: + ?use:bool -> loc:Location.t -> string -> t -> + Path.t * Asttypes.mutable_flag * string * type_expr + +val find_value_by_name: + Longident.t -> t -> Path.t * value_description +val find_type_by_name: + Longident.t -> t -> Path.t * type_declaration +val find_module_by_name: + Longident.t -> t -> Path.t * module_declaration +val find_modtype_by_name: + Longident.t -> t -> Path.t * modtype_declaration +val find_class_by_name: + Longident.t -> t -> Path.t * class_declaration +val find_cltype_by_name: + Longident.t -> t -> Path.t * class_type_declaration + +val find_constructor_by_name: + Longident.t -> t -> constructor_description +val find_label_by_name: + Longident.t -> t -> label_description + +(** The [find_*_index] functions computes a "namespaced" De Bruijn index + of an identifier in a given environment. In other words, it returns how many + times an identifier has been shadowed by a more recent identifiers with the + same name in a given environment. + Those functions return [None] when the identifier is not bound in the + environment. This behavior is there to facilitate the detection of + inconsistent printing environment, but should disappear in the long term. +*) +val find_value_index: Ident.t -> t -> int option +val find_type_index: Ident.t -> t -> int option +val find_module_index: Ident.t -> t -> int option +val find_modtype_index: Ident.t -> t -> int option +val find_class_index: Ident.t -> t -> int option +val find_cltype_index: Ident.t -> t -> int option + +(* Check if a name is bound *) + +val bound_value: string -> t -> bool +val bound_module: string -> t -> bool +val bound_type: string -> t -> bool +val bound_modtype: string -> t -> bool +val bound_class: string -> t -> bool +val bound_cltype: string -> t -> bool + +val make_copy_of_types: t -> (t -> t) + +(* Insertion by identifier *) + +val add_value: + ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t +val add_type: check:bool -> Ident.t -> type_declaration -> t -> t +val add_type_long_path: check:bool -> Ident.t -> type_declaration -> t -> t +val add_extension: + check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t +val add_module: ?arg:bool -> ?shape:Shape.t -> + Ident.t -> module_presence -> module_type -> t -> t +val add_module_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.modtype -> t -> t +val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> + Ident.t -> module_presence -> module_declaration -> t -> t +val add_module_declaration_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.module_decl -> t -> t +val add_modtype: Ident.t -> modtype_declaration -> t -> t +val add_modtype_lazy: update_summary:bool -> + Ident.t -> Subst.Lazy.modtype_declaration -> t -> t +val add_class: Ident.t -> class_declaration -> t -> t +val add_cltype: Ident.t -> class_type_declaration -> t -> t +val add_local_type: Path.t -> type_declaration -> t -> t + +(* Insertion of persistent signatures *) + +(* [add_persistent_structure id env] is an environment such that + module [id] points to the persistent structure contained in the + external compilation unit with the same name. + + The compilation unit itself is looked up in the load path when the + contents of the module is accessed. *) +val add_persistent_structure : Ident.t -> t -> t + +(* Returns the set of persistent structures found in the given + directory. *) +val persistent_structures_of_dir : Load_path.Dir.t -> Misc.String.Set.t + +(* [filter_non_loaded_persistent f env] removes all the persistent + structures that are not yet loaded and for which [f] returns + [false]. *) +val filter_non_loaded_persistent : (Ident.t -> bool) -> t -> t + +(* Insertion of all fields of a signature. *) + +val add_signature: signature -> t -> t + +(* Insertion of all fields of a signature, relative to the given path. + Used to implement open. Returns None if the path refers to a functor, + not a structure. *) +val open_signature: + ?used_slot:bool ref -> + ?loc:Location.t -> ?toplevel:bool -> + Asttypes.override_flag -> Path.t -> + t -> (t, [`Not_found | `Functor]) result + +val open_pers_signature: string -> t -> (t, [`Not_found]) result + +val remove_last_open: Path.t -> t -> t option + +(* Insertion by name *) + +val enter_value: + ?check:(string -> Warnings.t) -> + string -> value_description -> t -> Ident.t * t +val enter_type: scope:int -> string -> type_declaration -> t -> Ident.t * t +val enter_extension: + scope:int -> rebind:bool -> string -> + extension_constructor -> t -> Ident.t * t +val enter_module: + scope:int -> ?arg:bool -> string -> module_presence -> + module_type -> t -> Ident.t * t +val enter_module_declaration: + scope:int -> ?arg:bool -> ?shape:Shape.t -> string -> module_presence -> + module_declaration -> t -> Ident.t * t +val enter_modtype: + scope:int -> string -> modtype_declaration -> t -> Ident.t * t +val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t +val enter_cltype: + scope:int -> string -> class_type_declaration -> t -> Ident.t * t + +(* Same as [add_signature] but refreshes (new stamp) and rescopes bound idents + in the process. *) +val enter_signature: ?mod_shape:Shape.t -> scope:int -> signature -> t -> + signature * t + +(* Same as [enter_signature] but also extends the shape map ([parent_shape]) + with all the the items from the signature, their shape being a projection + from the given shape. *) +val enter_signature_and_shape: scope:int -> parent_shape:Shape.Map.t -> + Shape.t -> signature -> t -> signature * Shape.Map.t * t + +val enter_unbound_value : string -> value_unbound_reason -> t -> t + +val enter_unbound_module : string -> module_unbound_reason -> t -> t + +(* Initialize the cache of in-core module interfaces. *) +val reset_cache: unit -> unit + +(* To be called before each toplevel phrase. *) +val reset_cache_toplevel: unit -> unit + +(* Remember the name of the current compilation unit. *) +val set_unit_name: string -> unit +val get_unit_name: unit -> string + +(* Read, save a signature to/from a file *) +val read_signature: modname -> filepath -> signature + (* Arguments: module name, file name. Results: signature. *) +val save_signature: + alerts:alerts -> signature -> modname -> filepath + -> Cmi_format.cmi_infos + (* Arguments: signature, module name, file name. *) +val save_signature_with_imports: + alerts:alerts -> signature -> modname -> filepath -> crcs + -> Cmi_format.cmi_infos + (* Arguments: signature, module name, file name, + imported units with their CRCs. *) + +(* Return the CRC of the interface of the given compilation unit *) +val crc_of_unit: modname -> Digest.t + +(* Return the set of compilation units imported, with their CRC *) +val imports: unit -> crcs + +(* may raise Persistent_env.Consistbl.Inconsistency *) +val import_crcs: source:string -> crcs -> unit + +(* [is_imported_opaque md] returns true if [md] is an opaque imported module *) +val is_imported_opaque: modname -> bool + +(* [register_import_as_opaque md] registers [md] as an opaque imported module *) +val register_import_as_opaque: modname -> unit + +(* Summaries -- compact representation of an environment, to be + exported in debugging information. *) + +val summary: t -> summary + +(* Return an equivalent environment where all fields have been reset, + except the summary. The initial environment can be rebuilt from the + summary, using Envaux.env_of_only_summary. *) + +val keep_only_summary : t -> t +val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t + +(* Update the short paths table *) +val update_short_paths : t -> t + +(* Return the short paths table *) +val short_paths : t -> Short_paths.t + +(* Error report *) + +type error = + | Missing_module of Location.t * Path.t * Path.t + | Illegal_value_name of Location.t * string + | Lookup_error of Location.t * t * lookup_error + +exception Error of error + +open Format + +val report_error: formatter -> error -> unit + +val report_lookup_error: Location.t -> t -> formatter -> lookup_error -> unit + +val in_signature: bool -> t -> t + +val is_in_signature: t -> bool + +val set_value_used_callback: + value_description -> (unit -> unit) -> unit +val set_type_used_callback: + type_declaration -> ((unit -> unit) -> unit) -> unit + +(* Forward declaration to break mutual recursion with Includemod. *) +val check_functor_application: + (errors:bool -> loc:Location.t -> + lid_whole_app:Longident.t -> + f0_path:Path.t -> args:(Path.t * Types.module_type) list -> + arg_path:Path.t -> arg_mty:Types.module_type -> + param_mty:Types.module_type -> + t -> unit) ref +(* Forward declaration to break mutual recursion with Typemod. *) +val check_well_formed_module: + (t -> Location.t -> string -> module_type -> unit) ref +(* Forward declaration to break mutual recursion with Typecore. *) +val add_delayed_check_forward: ((unit -> unit) -> unit) ref +(* Forward declaration to break mutual recursion with Mtype. *) +val strengthen: + (aliasable:bool -> t -> Subst.Lazy.modtype -> + Path.t -> Subst.Lazy.modtype) ref +(* Forward declaration to break mutual recursion with Ctype. *) +val same_constr: (t -> type_expr -> type_expr -> bool) ref +(* Forward declaration to break mutual recursion with Printtyp. *) +val print_longident: (Format.formatter -> Longident.t -> unit) ref +(* Forward declaration to break mutual recursion with Printtyp. *) +val print_path: (Format.formatter -> Path.t -> unit) ref + + +(* Forward declaration to break mutual recursion with Printtyp *) +val shorten_module_path : (t -> Path.t -> Path.t) ref + +(** Folds *) + +(** Folding over all identifiers (for analysis purpose) *) + +val fold_values: + (string -> Path.t -> value_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_types: + (string -> Path.t -> type_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_constructors: + (constructor_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_labels: + (label_description -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + +(** Persistent structures are only traversed if they are already loaded. *) +val fold_modules: + (string -> Path.t -> module_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + +val fold_modtypes: + (string -> Path.t -> modtype_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_classes: + (string -> Path.t -> class_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a +val fold_cltypes: + (string -> Path.t -> class_type_declaration -> 'a -> 'a) -> + Longident.t option -> t -> 'a -> 'a + + +(** Utilities *) +val scrape_alias: t -> module_type -> module_type +val check_value_name: string -> Location.t -> unit + +val print_address : Format.formatter -> address -> unit + +val unbound_class : Path.t + +(** merlin: manage internal state *) + +val check_state_consistency: unit -> bool + +val with_cmis : (unit -> 'a) -> 'a + +(* helper for merlin *) + +val add_merlin_extension_module: Ident.t -> module_type -> t -> t +val cleanup_functor_caches : stamp:int -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/envaux.ml b/ocamlmerlin_mlx/ocaml/typing/envaux.ml new file mode 100644 index 0000000..a0bbbc2 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/envaux.ml @@ -0,0 +1,115 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Env + +type error = + Module_not_found of Path.t + +exception Error of error + +let env_cache = + (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t) + +let reset_cache () = + Hashtbl.clear env_cache; + Env.reset_cache() + +let rec env_from_summary sum subst = + try + Hashtbl.find env_cache (sum, subst) + with Not_found -> + let env = + match sum with + Env_empty -> + Env.empty + | Env_value(s, id, desc) -> + Env.add_value id (Subst.value_description subst desc) + (env_from_summary s subst) + | Env_type(s, id, desc) -> + Env.add_type ~check:false id + (Subst.type_declaration subst desc) + (env_from_summary s subst) + | Env_extension(s, id, desc) -> + Env.add_extension ~check:false ~rebind:false id + (Subst.extension_constructor subst desc) + (env_from_summary s subst) + | Env_module(s, id, pres, desc) -> + Env.add_module_declaration ~check:false id pres + (Subst.module_declaration Keep subst desc) + (env_from_summary s subst) + | Env_modtype(s, id, desc) -> + Env.add_modtype id (Subst.modtype_declaration Keep subst desc) + (env_from_summary s subst) + | Env_class(s, id, desc) -> + Env.add_class id (Subst.class_declaration subst desc) + (env_from_summary s subst) + | Env_cltype (s, id, desc) -> + Env.add_cltype id (Subst.cltype_declaration subst desc) + (env_from_summary s subst) + | Env_open(s, path) -> + let env = env_from_summary s subst in + let path' = Subst.module_path subst path in + begin match Env.open_signature Asttypes.Override path' env with + | Ok env -> env + | Error `Functor -> assert false + | Error `Not_found -> raise (Error (Module_not_found path')) + end + | Env_functor_arg(Env_module(s, id, pres, desc), id') + when Ident.same id id' -> + Env.add_module_declaration ~check:false + id pres (Subst.module_declaration Keep subst desc) + ~arg:true (env_from_summary s subst) + | Env_functor_arg _ -> assert false + | Env_constraints(s, map) -> + Path.Map.fold + (fun path info -> + Env.add_local_type (Subst.type_path subst path) + (Subst.type_declaration subst info)) + map (env_from_summary s subst) + | Env_copy_types s -> + let env = env_from_summary s subst in + Env.make_copy_of_types env env + | Env_persistent (s, id) -> + let env = env_from_summary s subst in + Env.add_persistent_structure id env + | Env_value_unbound (s, str, reason) -> + let env = env_from_summary s subst in + Env.enter_unbound_value str reason env + | Env_module_unbound (s, str, reason) -> + let env = env_from_summary s subst in + Env.enter_unbound_module str reason env + in + Hashtbl.add env_cache (sum, subst) env; + env + +let env_of_only_summary env = + Env.env_of_only_summary env_from_summary env + +(* Error report *) + +open Format + +let report_error ppf = function + | Module_not_found p -> + fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/ocamlmerlin_mlx/ocaml/typing/envaux.mli b/ocamlmerlin_mlx/ocaml/typing/envaux.mli new file mode 100644 index 0000000..2869890 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/envaux.mli @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Format + +(* Convert environment summaries to environments *) + +val env_from_summary : Env.summary -> Subst.t -> Env.t + +(* Empty the environment caches. To be called when load_path changes. *) + +val reset_cache: unit -> unit + +val env_of_only_summary : Env.t -> Env.t + +(* Error report *) + +type error = + Module_not_found of Path.t + +exception Error of error + +val report_error: formatter -> error -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/errortrace.ml b/ocamlmerlin_mlx/ocaml/typing/errortrace.ml new file mode 100644 index 0000000..407b343 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/errortrace.ml @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* Antal Spector-Zabusky, Jane Street, New York *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2021 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types +open Format + +type position = First | Second + +let swap_position = function + | First -> Second + | Second -> First + +let print_pos ppf = function + | First -> fprintf ppf "first" + | Second -> fprintf ppf "second" + +type expanded_type = { ty: type_expr; expanded: type_expr } + +let trivial_expansion ty = { ty; expanded = ty } + +type 'a diff = { got: 'a; expected: 'a } + +let map_diff f r = + (* ordering is often meaningful when dealing with type_expr *) + let got = f r.got in + let expected = f r.expected in + { got; expected } + +let swap_diff x = { got = x.expected; expected = x.got } + +type 'a escape_kind = + | Constructor of Path.t + | Univ of type_expr + (* The type_expr argument of [Univ] is always a [Tunivar _], + we keep a [type_expr] to track renaming in {!Printtyp} *) + | Self + | Module_type of Path.t + | Equation of 'a + | Constraint + +type 'a escape = + { kind : 'a escape_kind; + context : type_expr option } + +let map_escape f esc = + {esc with kind = match esc.kind with + | Equation eq -> Equation (f eq) + | (Constructor _ | Univ _ | Self | Module_type _ | Constraint) as c -> c} + +let explain trace f = + let rec explain = function + | [] -> None + | [h] -> f ~prev:None h + | h :: (prev :: _ as rem) -> + match f ~prev:(Some prev) h with + | Some _ as m -> m + | None -> explain rem in + explain (List.rev trace) + +(* Type indices *) +type unification = private Unification +type comparison = private Comparison + +type fixed_row_case = + | Cannot_be_closed + | Cannot_add_tags of string list + +type 'variety variant = + (* Common *) + | Incompatible_types_for : string -> _ variant + | No_tags : position * (Asttypes.label * row_field) list -> _ variant + (* Unification *) + | No_intersection : unification variant + | Fixed_row : + position * fixed_row_case * fixed_explanation -> unification variant + (* Equality & Moregen *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | Openness : position (* Always [Second] for Moregen *) -> comparison variant + +type 'variety obj = + (* Common *) + | Missing_field : position * string -> _ obj + | Abstract_row : position -> _ obj + (* Unification *) + | Self_cannot_be_closed : unification obj + +type ('a, 'variety) elt = + (* Common *) + | Diff : 'a diff -> ('a, _) elt + | Variant : 'variety variant -> ('a, 'variety) elt + | Obj : 'variety obj -> ('a, 'variety) elt + | Escape : 'a escape -> ('a, _) elt + | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt + (* Could move [Incompatible_fields] into [obj] *) + (* Unification & Moregen; included in Equality for simplicity *) + | Rec_occur : type_expr * type_expr -> ('a, _) elt + +type ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +let map_desc f { ty; expanded } = + let ty = f ty in + let expanded = f expanded in + { ty; expanded } + +let map_elt (type variety) f : ('a, variety) elt -> ('b, variety) elt = function + | Diff x -> Diff (map_diff f x) + | Escape {kind = Equation x; context} -> + Escape { kind = Equation (f x); context } + | Escape {kind = (Univ _ | Self | Constructor _ | Module_type _ | Constraint); + _} + | Variant _ | Obj _ | Incompatible_fields _ | Rec_occur (_, _) as x -> x + +let map f t = List.map (map_elt f) t + +let map_types f = map (map_desc f) + +let incompatible_fields ~name ~got ~expected = + Incompatible_fields { name; diff={got; expected} } + +let swap_elt (type variety) : ('a, variety) elt -> ('a, variety) elt = function + | Diff x -> Diff (swap_diff x) + | Incompatible_fields { name; diff } -> + Incompatible_fields { name; diff = swap_diff diff} + | Obj (Missing_field(pos,s)) -> Obj (Missing_field(swap_position pos,s)) + | Obj (Abstract_row pos) -> Obj (Abstract_row (swap_position pos)) + | Variant (Fixed_row(pos,k,f)) -> + Variant (Fixed_row(swap_position pos,k,f)) + | Variant (No_tags(pos,f)) -> + Variant (No_tags(swap_position pos,f)) + | x -> x + +let swap_trace e = List.map swap_elt e + +type unification_error = { trace : unification error } [@@unboxed] + +type equality_error = + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = { trace : comparison error } [@@unboxed] + +let unification_error ~trace : unification_error = + assert (trace <> []); + { trace } + +let equality_error ~trace ~subst : equality_error = + assert (trace <> []); + { trace; subst } + +let moregen_error ~trace : moregen_error = + assert (trace <> []); + { trace } + +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +let swap_unification_error ({trace} : unification_error) = + ({trace = swap_trace trace} : unification_error) + +module Subtype = struct + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = + { trace : error_trace + ; unification_trace : unification error } + + let error ~trace ~unification_trace = + assert (trace <> []); + { trace; unification_trace } + + let map_elt f = function + | Diff x -> Diff (map_diff f x) + + let map f t = List.map (map_elt f) t + + let map_desc f { ty; expanded } = + let ty = f ty in + let expanded = f expanded in + { ty; expanded } + + let map_types f = map (map_desc f) +end diff --git a/ocamlmerlin_mlx/ocaml/typing/errortrace.mli b/ocamlmerlin_mlx/ocaml/typing/errortrace.mli new file mode 100644 index 0000000..f3cfe48 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/errortrace.mli @@ -0,0 +1,176 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* Antal Spector-Zabusky, Jane Street, New York *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2021 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +type position = First | Second + +val swap_position : position -> position +val print_pos : Format.formatter -> position -> unit + +type expanded_type = { ty: type_expr; expanded: type_expr } + +(** [trivial_expansion ty] creates an [expanded_type] whose expansion is also + [ty]. Usually, you want [Ctype.expand_type] instead, since the expansion + carries useful information; however, in certain circumstances, the error is + about the expansion of the type, meaning that actually performing the + expansion produces more confusing or inaccurate output. *) +val trivial_expansion : type_expr -> expanded_type + +type 'a diff = { got: 'a; expected: 'a } + +(** [map_diff f {expected;got}] is [{expected=f expected; got=f got}] *) +val map_diff: ('a -> 'b) -> 'a diff -> 'b diff + +(** Scope escape related errors *) +type 'a escape_kind = + | Constructor of Path.t + | Univ of type_expr + (* The type_expr argument of [Univ] is always a [Tunivar _], + we keep a [type_expr] to track renaming in {!Printtyp} *) + | Self + | Module_type of Path.t + | Equation of 'a + | Constraint + +type 'a escape = + { kind : 'a escape_kind; + context : type_expr option } + +val map_escape : ('a -> 'b) -> 'a escape -> 'b escape + +val explain: 'a list -> + (prev:'a option -> 'a -> 'b option) -> + 'b option + +(** Type indices *) +type unification = private Unification +type comparison = private Comparison + +type fixed_row_case = + | Cannot_be_closed + | Cannot_add_tags of string list + +type 'variety variant = + (* Common *) + | Incompatible_types_for : string -> _ variant + | No_tags : position * (Asttypes.label * row_field) list -> _ variant + (* Unification *) + | No_intersection : unification variant + | Fixed_row : + position * fixed_row_case * fixed_explanation -> unification variant + (* Equality & Moregen *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | Openness : position (* Always [Second] for Moregen *) -> comparison variant + +type 'variety obj = + (* Common *) + | Missing_field : position * string -> _ obj + | Abstract_row : position -> _ obj + (* Unification *) + | Self_cannot_be_closed : unification obj + +type ('a, 'variety) elt = + (* Common *) + | Diff : 'a diff -> ('a, _) elt + | Variant : 'variety variant -> ('a, 'variety) elt + | Obj : 'variety obj -> ('a, 'variety) elt + | Escape : 'a escape -> ('a, _) elt + | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt + (* Unification & Moregen; included in Equality for simplicity *) + | Rec_occur : type_expr * type_expr -> ('a, _) elt + +type ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +(** merlin specific *) +val map_types : + (type_expr -> type_expr) -> + (expanded_type, 'variety) t -> (expanded_type, 'variety) t + +val map : ('a -> 'b) -> ('a, 'variety) t -> ('b, 'variety) t + +val incompatible_fields : + name:string -> got:type_expr -> expected:type_expr -> (type_expr, _) elt + +val swap_trace : ('a, 'variety) t -> ('a, 'variety) t + +(** The traces (['variety t]) are the core error types. However, we bundle them + up into three "top-level" error types, which are used elsewhere: + [unification_error], [equality_error], and [moregen_error]. In the case of + [equality_error], this has to bundle in extra information; in general, it + distinguishes the three types of errors and allows us to distinguish traces + that are being built (or processed) from those that are complete and have + become the final error. These error types have the invariants that their + traces are nonempty; we ensure that through three smart constructors with + matching names. *) + +type unification_error = private { trace : unification error } [@@unboxed] + +type equality_error = private + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = private { trace : comparison error } [@@unboxed] + +val unification_error : trace:unification error -> unification_error + +val equality_error : + trace:comparison error -> subst:(type_expr * type_expr) list -> equality_error + +val moregen_error : trace:comparison error -> moregen_error + +(** Wraps up the two different kinds of [comparison] errors in one type *) +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +(** Lift [swap_trace] to [unification_error] *) +val swap_unification_error : unification_error -> unification_error + +module Subtype : sig + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + (** Just as outside [Subtype], we split traces, completed traces, and complete + errors. However, in a minor asymmetry, the name [Subtype.error_trace] + corresponds to the outside [error] type, and [Subtype.error] corresponds + to the outside [*_error] types (e.g., [unification_error]). This [error] + type has the invariant that the subtype trace is nonempty; note that no + such invariant is imposed on the unification trace. *) + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = private + { trace : error_trace + ; unification_trace : unification error } + + val error : + trace:error_trace -> unification_trace:unification_error_trace -> error + + val map : ('a -> 'b) -> 'a t -> 'b t + + (** merlin specific *) + val map_types : (type_expr -> type_expr) -> expanded_type t -> expanded_type t +end diff --git a/ocamlmerlin_mlx/ocaml/typing/ident.ml b/ocamlmerlin_mlx/ocaml/typing/ident.ml new file mode 100644 index 0000000..149feff --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/ident.ml @@ -0,0 +1,395 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Local_store + +let lowest_scope = 0 +let highest_scope = 100000000 + +type t = + | Local of { name: string; stamp: int } + | Scoped of { name: string; stamp: int; scope: int } + | Global of string + | Predef of { name: string; stamp: int } + (* the stamp is here only for fast comparison, but the name of + predefined identifiers is always unique. *) + +(* A stamp of 0 denotes a persistent identifier *) + +let currentstamp = s_ref 0 +let predefstamp = s_ref 0 + +let create_scoped ~scope s = + incr currentstamp; + Scoped { name = s; stamp = !currentstamp; scope } + +let create_local s = + incr currentstamp; + Local { name = s; stamp = !currentstamp } + +let create_predef s = + incr predefstamp; + Predef { name = s; stamp = !predefstamp } + +let create_persistent s = + Global s + +let name = function + | Local { name; _ } + | Scoped { name; _ } + | Global name + | Predef { name; _ } -> name + +let rename = function + | Local { name; stamp = _ } + | Scoped { name; stamp = _; scope = _ } -> + incr currentstamp; + Local { name; stamp = !currentstamp } + | id -> + Misc.fatal_errorf "Ident.rename %s" (name id) + +let unique_name = function + | Local { name; stamp } + | Scoped { name; stamp } -> name ^ "_" ^ Int.to_string stamp + | Global name -> + (* we're adding a fake stamp, because someone could have named his unit + [Foo_123] and since we're using unique_name to produce symbol names, + we might clash with an ident [Local { "Foo"; 123 }]. *) + name ^ "_0" + | Predef { name; _ } -> + (* we know that none of the predef names (currently) finishes in + "_", and that their name is unique. *) + name + +let unique_toplevel_name = function + | Local { name; stamp } + | Scoped { name; stamp } -> name ^ "/" ^ Int.to_string stamp + | Global name + | Predef { name; _ } -> name + +let persistent = function + | Global _ -> true + | _ -> false + +let equal i1 i2 = + match i1, i2 with + | Local { name = name1; _ }, Local { name = name2; _ } + | Scoped { name = name1; _ }, Scoped { name = name2; _ } + | Global name1, Global name2 -> + name1 = name2 + | Predef { stamp = s1; _ }, Predef { stamp = s2 } -> + (* if they don't have the same stamp, they don't have the same name *) + s1 = s2 + | _ -> + false + +let same i1 i2 = + match i1, i2 with + | Local { stamp = s1; _ }, Local { stamp = s2; _ } + | Scoped { stamp = s1; _ }, Scoped { stamp = s2; _ } + | Predef { stamp = s1; _ }, Predef { stamp = s2 } -> + s1 = s2 + | Global name1, Global name2 -> + name1 = name2 + | _ -> + false + +let stamp = function + | Local { stamp; _ } + | Scoped { stamp; _ } -> stamp + | _ -> 0 + +let scope = function + | Scoped { scope; _ } -> scope + | Local _ -> highest_scope + | Global _ | Predef _ -> lowest_scope + +let reinit_level = ref (-1) + +let reinit () = + if !reinit_level < 0 + then reinit_level := !currentstamp + else currentstamp := !reinit_level + +let global = function + | Local _ + | Scoped _ -> false + | Global _ + | Predef _ -> true + +let is_predef = function + | Predef _ -> true + | _ -> false + +let print ~with_scope ppf = + let open Format in + function + | Global name -> fprintf ppf "%s!" name + | Predef { name; stamp = n } -> + fprintf ppf "%s/%i!" name n + | Local { name; stamp = n } -> + fprintf ppf "%s/%i" name n + | Scoped { name; stamp = n; scope } -> + fprintf ppf "%s/%i%s" name n + (if with_scope then sprintf "[%i]" scope else "") + +let print_with_scope ppf id = print ~with_scope:true ppf id + +let print ppf id = print ~with_scope:false ppf id + +(* For the documentation of ['a Ident.tbl], see ident.mli. + + The implementation is a copy-paste specialization of + a balanced-tree implementation similar to Map. + ['a tbl] + is a slightly more compact version of + [(Ident.t * 'a) list Map.Make(String)] + + This implementation comes from Caml Light where duplication was + unavoidable in absence of functors. It works well enough, and so + far we have not had strong incentives to do the deduplication work + (implementation, tests, benchmarks, etc.). +*) +type 'a tbl = + Empty + | Node of 'a tbl * 'a data * 'a tbl * int + +and 'a data = + { ident: t; + data: 'a; + previous: 'a data option } + +let empty = Empty + +(* Inline expansion of height for better speed + * let height = function + * Empty -> 0 + * | Node(_,_,_,h) -> h + *) + +let mknode l d r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h + and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1)) + +let balance l d r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h + and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + if hl > hr + 1 then + match l with + | Node (ll, ld, lr, _) + when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >= + (match lr with Empty -> 0 | Node(_,_,_,h) -> h) -> + mknode ll ld (mknode lr d r) + | Node (ll, ld, Node(lrl, lrd, lrr, _), _) -> + mknode (mknode ll ld lrl) lrd (mknode lrr d r) + | _ -> assert false + else if hr > hl + 1 then + match r with + | Node (rl, rd, rr, _) + when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >= + (match rl with Empty -> 0 | Node(_,_,_,h) -> h) -> + mknode (mknode l d rl) rd rr + | Node (Node (rll, rld, rlr, _), rd, rr, _) -> + mknode (mknode l d rll) rld (mknode rlr rd rr) + | _ -> assert false + else + mknode l d r + +let rec add id data = function + Empty -> + Node(Empty, {ident = id; data = data; previous = None}, Empty, 1) + | Node(l, k, r, h) -> + let c = String.compare (name id) (name k.ident) in + if c = 0 then + Node(l, {ident = id; data = data; previous = Some k}, r, h) + else if c < 0 then + balance (add id data l) k r + else + balance l k (add id data r) + +let rec min_binding = function + Empty -> raise Not_found + | Node (Empty, d, _, _) -> d + | Node (l, _, _, _) -> min_binding l + +let rec remove_min_binding = function + Empty -> invalid_arg "Map.remove_min_elt" + | Node (Empty, _, r, _) -> r + | Node (l, d, r, _) -> balance (remove_min_binding l) d r + +let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> + let d = min_binding t2 in + balance t1 d (remove_min_binding t2) + +let rec remove id = function + Empty -> + Empty + | (Node (l, k, r, h) as m) -> + let c = String.compare (name id) (name k.ident) in + if c = 0 then + match k.previous with + | None -> merge l r + | Some k -> Node (l, k, r, h) + else if c < 0 then + let ll = remove id l in if l == ll then m else balance ll k r + else + let rr = remove id r in if r == rr then m else balance l k rr + +let rec find_previous id = function + None -> + raise Not_found + | Some k -> + if same id k.ident then k.data else find_previous id k.previous + +let rec find_same id = function + Empty -> + raise Not_found + | Node(l, k, r, _) -> + let c = String.compare (name id) (name k.ident) in + if c = 0 then + if same id k.ident + then k.data + else find_previous id k.previous + else + find_same id (if c < 0 then l else r) + +let rec find_name n = function + Empty -> + raise Not_found + | Node(l, k, r, _) -> + let c = String.compare n (name k.ident) in + if c = 0 then + k.ident, k.data + else + find_name n (if c < 0 then l else r) + +let rec get_all = function + | None -> [] + | Some k -> (k.ident, k.data) :: get_all k.previous + +let rec find_all n = function + Empty -> + [] + | Node(l, k, r, _) -> + let c = String.compare n (name k.ident) in + if c = 0 then + (k.ident, k.data) :: get_all k.previous + else + find_all n (if c < 0 then l else r) + +let get_all_seq k () = + Seq.unfold (Option.map (fun k -> (k.ident, k.data), k.previous)) + k () + +let rec find_all_seq n tbl () = + match tbl with + | Empty -> Seq.Nil + | Node(l, k, r, _) -> + let c = String.compare n (name k.ident) in + if c = 0 then + Seq.Cons((k.ident, k.data), get_all_seq k.previous) + else + find_all_seq n (if c < 0 then l else r) () + + +let rec fold_aux f stack accu = function + Empty -> + begin match stack with + [] -> accu + | a :: l -> fold_aux f l accu a + end + | Node(l, k, r, _) -> + fold_aux f (l :: stack) (f k accu) r + +let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl + +let rec fold_data f d accu = + match d with + None -> accu + | Some k -> f k.ident k.data (fold_data f k.previous accu) + +let fold_all f tbl accu = + fold_aux (fun k -> fold_data f (Some k)) [] accu tbl + +(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *) + +let rec iter f = function + Empty -> () + | Node(l, k, r, _) -> + iter f l; f k.ident k.data; iter f r + +(* Idents for sharing keys *) + +(* They should be 'totally fresh' -> neg numbers *) +let key_name = "" + +let make_key_generator () = + let c = ref 1 in + function + | Local _ + | Scoped _ -> + let stamp = !c in + decr c ; + Local { name = key_name; stamp = stamp } + | global_id -> + Misc.fatal_errorf "Ident.make_key_generator () %s" (name global_id) + +let compare x y = + match x, y with + | Local x, Local y -> + let c = x.stamp - y.stamp in + if c <> 0 then c + else compare x.name y.name + | Local _, _ -> 1 + | _, Local _ -> (-1) + | Scoped x, Scoped y -> + let c = x.stamp - y.stamp in + if c <> 0 then c + else compare x.name y.name + | Scoped _, _ -> 1 + | _, Scoped _ -> (-1) + | Global x, Global y -> compare x y + | Global _, _ -> 1 + | _, Global _ -> (-1) + | Predef { stamp = s1; _ }, Predef { stamp = s2; _ } -> compare s1 s2 + +let output oc id = output_string oc (unique_name id) +let hash i = (Char.code (name i).[0]) lxor (stamp i) + +let original_equal = equal +include Identifiable.Make (struct + type nonrec t = t + let compare = compare + let output = output + let print = print + let hash = hash + let equal = same +end) +let equal = original_equal + +let rename_no_exn = function + | Local { name; stamp = _ } + | Scoped { name; stamp = _; scope = _ } -> + incr currentstamp; + Local { name; stamp = !currentstamp } + | id -> id + +let get_currentstamp () = + !currentstamp diff --git a/ocamlmerlin_mlx/ocaml/typing/ident.mli b/ocamlmerlin_mlx/ocaml/typing/ident.mli new file mode 100644 index 0000000..cfc4ca1 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/ident.mli @@ -0,0 +1,120 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Identifiers (unique names) *) + +type t + +include Identifiable.S with type t := t +(* Notes: + - [equal] compares identifiers by name + - [compare x y] is 0 if [same x y] is true. + - [compare] compares identifiers by binding location +*) + +val print_with_scope : Format.formatter -> t -> unit + (** Same as {!print} except that it will also add a "[n]" suffix + if the scope of the argument is [n]. *) + + +val create_scoped: scope:int -> string -> t +val create_local: string -> t +val create_persistent: string -> t +val create_predef: string -> t + +val rename: t -> t + (** Creates an identifier with the same name as the input, a fresh + stamp, and no scope. + @raise [Fatal_error] if called on a persistent / predef ident. *) + +val name: t -> string +val unique_name: t -> string +val unique_toplevel_name: t -> string +val persistent: t -> bool +val same: t -> t -> bool + (** Compare identifiers by binding location. + Two identifiers are the same either if they are both + non-persistent and have been created by the same call to + [create_*], or if they are both persistent and have the same + name. *) + +val compare: t -> t -> int + +val global: t -> bool +val is_predef: t -> bool + +val scope: t -> int +val stamp: t -> int + +val lowest_scope : int +val highest_scope: int + +val reinit: unit -> unit + +type 'a tbl +(** ['a tbl] represents association tables from identifiers to values + of type ['a]. + + ['a tbl] plays the role of map, but bindings can be looked up + from either the full Ident using [find_same], or just its + user-visible name using [find_name]. In general the two lookups may + not return the same result, as an identifier may have been shadowed + in the environment by a distinct identifier with the same name. + + [find_all] returns the bindings for all idents of a given name, + most recently introduced first. + + In other words, + ['a tbl] + corresponds to + [(Ident.t * 'a) list Map.Make(String)] + and the implementation is very close to that representation. + + Note in particular that searching among idents of the same name + takes linear time, and that [add] simply extends the list without + checking for duplicates. So it is not a good idea to implement + union by repeated [add] calls, which may result in many duplicated + identifiers and poor [find_same] performance. It is even possible + to build overly large same-name lists such that non-recursive + functions like [find_all] or [fold_all] blow the stack. + + You should probably use [Map.Make(Ident)] instead, unless you + really need to query bindings by user-visible name, not just by + unique identifiers. +*) + +val empty: 'a tbl +val add: t -> 'a -> 'a tbl -> 'a tbl +val find_same: t -> 'a tbl -> 'a +val find_name: string -> 'a tbl -> t * 'a +val find_all: string -> 'a tbl -> (t * 'a) list +val find_all_seq: string -> 'a tbl -> (t * 'a) Seq.t +val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b +val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b +val iter: (t -> 'a -> unit) -> 'a tbl -> unit +val remove: t -> 'a tbl -> 'a tbl + +(* Idents for sharing keys *) + +val make_key_generator : unit -> (t -> t) + +(* merlin *) + +val rename_no_exn: t -> t + (** Like [rename], but does not fail on persistent/predef idents. *) + +val get_currentstamp: unit -> int + (** Get the value of the current stamp (the stamp of the last created + identifier). Used to flush identifier-based caches when backtracking. *) diff --git a/ocamlmerlin_mlx/ocaml/typing/includeclass.ml b/ocamlmerlin_mlx/ocaml/typing/includeclass.ml new file mode 100644 index 0000000..3a2cd57 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/includeclass.ml @@ -0,0 +1,116 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the class language *) + +open Types + +let class_types env cty1 cty2 = + Ctype.match_class_types env cty1 cty2 + +let class_type_declarations ~loc env cty1 cty2 = + Builtin_attributes.check_alerts_inclusion + ~def:cty1.clty_loc + ~use:cty2.clty_loc + loc + cty1.clty_attributes cty2.clty_attributes + (Path.last cty1.clty_path); + Ctype.match_class_declarations env + cty1.clty_params cty1.clty_type + cty2.clty_params cty2.clty_type + +let class_declarations env cty1 cty2 = + match cty1.cty_new, cty2.cty_new with + None, Some _ -> + [Ctype.CM_Virtual_class] + | _ -> + Ctype.match_class_declarations env + cty1.cty_params cty1.cty_type + cty2.cty_params cty2.cty_type + +open Format +open Ctype + +(* +let rec hide_params = function + Tcty_arrow ("*", _, cty) -> hide_params cty + | cty -> cty +*) + +let include_err mode ppf = + function + | CM_Virtual_class -> + fprintf ppf "A class cannot be changed from virtual to concrete" + | CM_Parameter_arity_mismatch _ -> + fprintf ppf + "The classes do not have the same number of type parameters" + | CM_Type_parameter_mismatch (env, err) -> + Printtyp.report_equality_error ppf mode env err + (function ppf -> + fprintf ppf "A type parameter has type") + (function ppf -> + fprintf ppf "but is expected to have type") + | CM_Class_type_mismatch (env, cty1, cty2) -> + Printtyp.wrap_printing_env ~error:true env (fun () -> + fprintf ppf + "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]" + Printtyp.class_type cty1 + "is not matched by the class type" + Printtyp.class_type cty2) + | CM_Parameter_mismatch (env, err) -> + Printtyp.report_moregen_error ppf mode env err + (function ppf -> + fprintf ppf "A parameter has type") + (function ppf -> + fprintf ppf "but is expected to have type") + | CM_Val_type_mismatch (lab, env, err) -> + Printtyp.report_comparison_error ppf mode env err + (function ppf -> + fprintf ppf "The instance variable %s@ has type" lab) + (function ppf -> + fprintf ppf "but is expected to have type") + | CM_Meth_type_mismatch (lab, env, err) -> + Printtyp.report_comparison_error ppf mode env err + (function ppf -> + fprintf ppf "The method %s@ has type" lab) + (function ppf -> + fprintf ppf "but is expected to have type") + | CM_Non_mutable_value lab -> + fprintf ppf + "@[The non-mutable instance variable %s cannot become mutable@]" lab + | CM_Non_concrete_value lab -> + fprintf ppf + "@[The virtual instance variable %s cannot become concrete@]" lab + | CM_Missing_value lab -> + fprintf ppf "@[The first class type has no instance variable %s@]" lab + | CM_Missing_method lab -> + fprintf ppf "@[The first class type has no method %s@]" lab + | CM_Hide_public lab -> + fprintf ppf "@[The public method %s cannot be hidden@]" lab + | CM_Hide_virtual (k, lab) -> + fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab + | CM_Public_method lab -> + fprintf ppf "@[The public method %s cannot become private@]" lab + | CM_Virtual_method lab -> + fprintf ppf "@[The virtual method %s cannot become concrete@]" lab + | CM_Private_method lab -> + fprintf ppf "@[The private method %s cannot become public@]" lab + +let report_error mode ppf = function + | [] -> () + | err :: errs -> + let print_errs ppf errs = + List.iter (fun err -> fprintf ppf "@ %a" (include_err mode) err) errs in + fprintf ppf "@[%a%a@]" (include_err mode) err print_errs errs diff --git a/ocamlmerlin_mlx/ocaml/typing/includeclass.mli b/ocamlmerlin_mlx/ocaml/typing/includeclass.mli new file mode 100644 index 0000000..84de621 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/includeclass.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the class language *) + +open Types +open Ctype +open Format + +val class_types: + Env.t -> class_type -> class_type -> class_match_failure list +val class_type_declarations: + loc:Location.t -> + Env.t -> class_type_declaration -> class_type_declaration -> + class_match_failure list +val class_declarations: + Env.t -> class_declaration -> class_declaration -> + class_match_failure list + +val report_error : + Printtyp.type_or_scheme -> formatter -> class_match_failure list -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/includecore.ml b/ocamlmerlin_mlx/ocaml/typing/includecore.ml new file mode 100644 index 0000000..a3cdd18 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/includecore.ml @@ -0,0 +1,1020 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the core language *) + +open Asttypes +open Path +open Types +open Typedtree + +type position = Errortrace.position = First | Second + +(* Inclusion between value descriptions *) + +type primitive_mismatch = + | Name + | Arity + | No_alloc of position + | Native_name + | Result_repr + | Argument_repr of int + +let native_repr_args nra1 nra2 = + let rec loop i nra1 nra2 = + match nra1, nra2 with + | [], [] -> None + | [], _ :: _ -> assert false + | _ :: _, [] -> assert false + | nr1 :: nra1, nr2 :: nra2 -> + if not (Primitive.equal_native_repr nr1 nr2) then Some (Argument_repr i) + else loop (i+1) nra1 nra2 + in + loop 1 nra1 nra2 + +let primitive_descriptions pd1 pd2 = + let open Primitive in + if not (String.equal pd1.prim_name pd2.prim_name) then + Some Name + else if not (Int.equal pd1.prim_arity pd2.prim_arity) then + Some Arity + else if (not pd1.prim_alloc) && pd2.prim_alloc then + Some (No_alloc First) + else if pd1.prim_alloc && (not pd2.prim_alloc) then + Some (No_alloc Second) + else if not (String.equal pd1.prim_native_name pd2.prim_native_name) then + Some Native_name + else if not + (Primitive.equal_native_repr + pd1.prim_native_repr_res pd2.prim_native_repr_res) then + Some Result_repr + else + native_repr_args pd1.prim_native_repr_args pd2.prim_native_repr_args + +type value_mismatch = + | Primitive_mismatch of primitive_mismatch + | Not_a_primitive + | Type of Errortrace.moregen_error + +exception Dont_match of value_mismatch + +let value_descriptions ~loc env name + (vd1 : Types.value_description) + (vd2 : Types.value_description) = + Builtin_attributes.check_alerts_inclusion + ~def:vd1.val_loc + ~use:vd2.val_loc + loc + vd1.val_attributes vd2.val_attributes + name; + match Ctype.moregeneral env true vd1.val_type vd2.val_type with + | exception Ctype.Moregen err -> raise (Dont_match (Type err)) + | () -> begin + match (vd1.val_kind, vd2.val_kind) with + | (Val_prim p1, Val_prim p2) -> begin + match primitive_descriptions p1 p2 with + | None -> Tcoerce_none + | Some err -> raise (Dont_match (Primitive_mismatch err)) + end + | (Val_prim p, _) -> + let pc = + { pc_desc = p; pc_type = vd2.Types.val_type; + pc_env = env; pc_loc = vd1.Types.val_loc; } + in + Tcoerce_primitive pc + | (_, Val_prim _) -> raise (Dont_match Not_a_primitive) + | (_, _) -> Tcoerce_none + end + +(* Inclusion between manifest types (particularly for private row types) *) + +let is_absrow env ty = + match get_desc ty with + | Tconstr(Pident _, _, _) -> + (* This function is checking for an abstract row on the side that is being + included into (usually numbered with "2" in this file). In this case, + the abstract row variable has been substituted for an object or variant + type. *) + begin match get_desc (Ctype.expand_head env ty) with + | Tobject _|Tvariant _ -> true + | _ -> false + end + | _ -> false + +(* Inclusion between type declarations *) + +let choose ord first second = + match ord with + | First -> first + | Second -> second + +let choose_other ord first second = + match ord with + | First -> choose Second first second + | Second -> choose First first second + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type type_kind = + | Kind_abstract + | Kind_record + | Kind_variant + | Kind_open + +let of_kind = function + | Type_abstract -> Kind_abstract + | Type_record (_, _) -> Kind_record + | Type_variant (_, _) -> Kind_variant + | Type_open -> Kind_open + +type kind_mismatch = type_kind * type_kind + +type label_mismatch = + | Type of Errortrace.equality_error + | Mutability of position + +type record_change = + (Types.label_declaration, Types.label_declaration, label_mismatch) + Diffing_with_keys.change + +type record_mismatch = + | Label_mismatch of record_change list + | Unboxed_float_representation of position + +type constructor_mismatch = + | Type of Errortrace.equality_error + | Arity + | Inline_record of record_change list + | Kind of position + | Explicit_return_type of position + +type extension_constructor_mismatch = + | Constructor_privacy + | Constructor_mismatch of Ident.t + * Types.extension_constructor + * Types.extension_constructor + * constructor_mismatch + +type private_variant_mismatch = + | Only_outer_closed (* It's only dangerous in one direction *) + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type variant_change = + (Types.constructor_declaration as 'l, 'l, constructor_mismatch) + Diffing_with_keys.change + +type type_mismatch = + | Arity + | Privacy of privacy_mismatch + | Kind of kind_mismatch + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | Private_variant of type_expr * type_expr * private_variant_mismatch + | Private_object of type_expr * type_expr * private_object_mismatch + | Variance + | Record_mismatch of record_mismatch + | Variant_mismatch of variant_change list + | Unboxed_representation of position + | Immediate of Type_immediacy.Violation.t + +let report_primitive_mismatch first second ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : primitive_mismatch) with + | Name -> + pr "The names of the primitives are not the same" + | Arity -> + pr "The syntactic arities of these primitives were not the same.@ \ + (They must have the same number of arrows present in the source.)" + | No_alloc ord -> + pr "%s primitive is [@@@@noalloc] but %s is not" + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + | Native_name -> + pr "The native names of the primitives are not the same" + | Result_repr -> + pr "The two primitives' results have different representations" + | Argument_repr n -> + pr "The two primitives' %d%s arguments have different representations" + n (Misc.ordinal_suffix n) + +let report_value_mismatch first second env ppf err = + let pr fmt = Format.fprintf ppf fmt in + pr "@ "; + match (err : value_mismatch) with + | Primitive_mismatch pm -> + report_primitive_mismatch first second ppf pm + | Not_a_primitive -> + pr "The implementation is not a primitive." + | Type trace -> + Printtyp.report_moregen_error ppf Type_scheme env trace + (fun ppf -> Format.fprintf ppf "The type") + (fun ppf -> Format.fprintf ppf "is not compatible with the type") + +let report_type_inequality env ppf err = + Printtyp.report_equality_error ppf Type_scheme env err + (fun ppf -> Format.fprintf ppf "The type") + (fun ppf -> Format.fprintf ppf "is not equal to the type") + +let report_privacy_mismatch ppf err = + let singular, item = + match err with + | Private_type_abbreviation -> true, "type abbreviation" + | Private_variant_type -> false, "variant constructor(s)" + | Private_record_type -> true, "record constructor" + | Private_extensible_variant -> true, "extensible variant" + | Private_row_type -> true, "row type" + in Format.fprintf ppf "%s %s would be revealed." + (if singular then "A private" else "Private") + item + +let report_label_mismatch first second env ppf err = + match (err : label_mismatch) with + | Type err -> + report_type_inequality env ppf err + | Mutability ord -> + Format.fprintf ppf "%s is mutable and %s is not." + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + +let pp_record_diff first second prefix decl env ppf (x : record_change) = + match x with + | Delete cd -> + Format.fprintf ppf "%aAn extra field, %s, is provided in %s %s." + prefix x (Ident.name cd.delete.ld_id) first decl + | Insert cd -> + Format.fprintf ppf "%aA field, %s, is missing in %s %s." + prefix x (Ident.name cd.insert.ld_id) first decl + | Change Type {got=lbl1; expected=lbl2; reason} -> + Format.fprintf ppf + "@[%aFields do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + Printtyp.label lbl1 + Printtyp.label lbl2 + (report_label_mismatch first second env) reason + | Change Name n -> + Format.fprintf ppf "%aFields have different names, %s and %s." + prefix x n.got n.expected + | Swap sw -> + Format.fprintf ppf "%aFields %s and %s have been swapped." + prefix x sw.first sw.last + | Move {name; got; expected } -> + Format.fprintf ppf + "@[<2>%aField %s has been moved@ from@ position %d@ to %d.@]" + prefix x name expected got + +let report_patch pr_diff first second decl env ppf patch = + let nl ppf () = Format.fprintf ppf "@," in + let no_prefix _ppf _ = () in + match patch with + | [ elt ] -> + Format.fprintf ppf "@[%a@]" + (pr_diff first second no_prefix decl env) elt + | _ -> + let pp_diff = pr_diff first second Diffing_with_keys.prefix decl env in + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list ~pp_sep:nl pp_diff) patch + +let report_record_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match err with + | Label_mismatch patch -> + report_patch pp_record_diff first second decl env ppf patch + | Unboxed_float_representation ord -> + pr "@[Their internal representations differ:@ %s %s %s.@]" + (choose ord first second) decl + "uses unboxed float representation" + +let report_constructor_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : constructor_mismatch) with + | Type err -> report_type_inequality env ppf err + | Arity -> pr "They have different arities." + | Inline_record err -> + report_patch pp_record_diff first second decl env ppf err + | Kind ord -> + pr "%s uses inline records and %s doesn't." + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + | Explicit_return_type ord -> + pr "%s has explicit return type and %s doesn't." + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + +let pp_variant_diff first second prefix decl env ppf (x : variant_change) = + match x with + | Delete cd -> + Format.fprintf ppf "%aAn extra constructor, %s, is provided in %s %s." + prefix x (Ident.name cd.delete.cd_id) first decl + | Insert cd -> + Format.fprintf ppf "%aA constructor, %s, is missing in %s %s." + prefix x (Ident.name cd.insert.cd_id) first decl + | Change Type {got; expected; reason} -> + Format.fprintf ppf + "@[%aConstructors do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + Printtyp.constructor got + Printtyp.constructor expected + (report_constructor_mismatch first second decl env) reason + | Change Name n -> + Format.fprintf ppf + "%aConstructors have different names, %s and %s." + prefix x n.got n.expected + | Swap sw -> + Format.fprintf ppf + "%aConstructors %s and %s have been swapped." + prefix x sw.first sw.last + | Move {name; got; expected} -> + Format.fprintf ppf + "@[<2>%aConstructor %s has been moved@ from@ position %d@ to %d.@]" + prefix x name expected got + +let report_extension_constructor_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : extension_constructor_mismatch) with + | Constructor_privacy -> + pr "Private extension constructor(s) would be revealed." + | Constructor_mismatch (id, ext1, ext2, err) -> + pr "@[Constructors do not match:@;<1 2>%a@ is not the same as:\ + @;<1 2>%a@ %a@]" + (Printtyp.extension_only_constructor id) ext1 + (Printtyp.extension_only_constructor id) ext2 + (report_constructor_mismatch first second decl env) err + +let report_private_variant_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : private_variant_mismatch) with + | Only_outer_closed -> + (* It's only dangerous in one direction, so we don't have a position *) + pr "%s is private and closed, but %s is not closed" + (String.capitalize_ascii second) first + | Missing (ord, name) -> + pr "The constructor %s is only present in %s %s." + name (choose ord first second) decl + | Presence s -> + pr "The tag `%s is present in the %s %s,@ but might not be in the %s" + s second decl first + | Incompatible_types_for s -> pr "Types for tag `%s are incompatible" s + | Types err -> + report_type_inequality env ppf err + +let report_private_object_mismatch env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : private_object_mismatch) with + | Missing s -> pr "The implementation is missing the method %s" s + | Types err -> report_type_inequality env ppf err + +let report_kind_mismatch first second ppf (kind1, kind2) = + let pr fmt = Format.fprintf ppf fmt in + let kind_to_string = function + | Kind_abstract -> "abstract" + | Kind_record -> "a record" + | Kind_variant -> "a variant" + | Kind_open -> "an extensible variant" in + pr "%s is %s, but %s is %s." + (String.capitalize_ascii first) + (kind_to_string kind1) + second + (kind_to_string kind2) + +let report_type_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + pr "@ "; + match err with + | Arity -> + pr "They have different arities." + | Privacy err -> + report_privacy_mismatch ppf err + | Kind err -> + report_kind_mismatch first second ppf err + | Constraint err -> + (* This error can come from implicit parameter disagreement or from + explicit `constraint`s. Both affect the parameters, hence this choice + of explanatory text *) + pr "Their parameters differ@,"; + report_type_inequality env ppf err + | Manifest err -> + report_type_inequality env ppf err + | Private_variant (_ty1, _ty2, mismatch) -> + report_private_variant_mismatch first second decl env ppf mismatch + | Private_object (_ty1, _ty2, mismatch) -> + report_private_object_mismatch env ppf mismatch + | Variance -> + pr "Their variances do not agree." + | Record_mismatch err -> + report_record_mismatch first second decl env ppf err + | Variant_mismatch err -> + report_patch pp_variant_diff first second decl env ppf err + | Unboxed_representation ord -> + pr "Their internal representations differ:@ %s %s %s." + (choose ord first second) decl + "uses unboxed representation" + | Immediate violation -> + let first = StringLabels.capitalize_ascii first in + match violation with + | Type_immediacy.Violation.Not_always_immediate -> + pr "%s is not an immediate type." first + | Type_immediacy.Violation.Not_always_immediate_on_64bits -> + pr "%s is not a type that is always immediate on 64 bit platforms." + first + +module Record_diffing = struct + + let compare_labels env params1 params2 + (ld1 : Types.label_declaration) + (ld2 : Types.label_declaration) = + if ld1.ld_mutable <> ld2.ld_mutable + then + let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in + Some (Mutability ord) + else + let tl1 = params1 @ [ld1.ld_type] in + let tl2 = params2 @ [ld2.ld_type] in + match Ctype.equal env true tl1 tl2 with + | exception Ctype.Equality err -> + Some (Type err : label_mismatch) + | () -> None + + let rec equal ~loc env params1 params2 + (labels1 : Types.label_declaration list) + (labels2 : Types.label_declaration list) = + match labels1, labels2 with + | [], [] -> true + | _ :: _ , [] | [], _ :: _ -> false + | ld1 :: rem1, ld2 :: rem2 -> + if Ident.name ld1.ld_id <> Ident.name ld2.ld_id + then false + else begin + Builtin_attributes.check_deprecated_mutable_inclusion + ~def:ld1.ld_loc + ~use:ld2.ld_loc + loc + ld1.ld_attributes ld2.ld_attributes + (Ident.name ld1.ld_id); + match compare_labels env params1 params2 ld1 ld2 with + | Some _ -> false + (* add arguments to the parameters, cf. PR#7378 *) + | None -> + equal ~loc env + (ld1.ld_type::params1) (ld2.ld_type::params2) + rem1 rem2 + end + + module Defs = struct + type left = Types.label_declaration + type right = left + type diff = label_mismatch + type state = type_expr list * type_expr list + end + module Diff = Diffing_with_keys.Define(Defs) + + let update (d:Diff.change) (params1,params2 as st) = + match d with + | Insert _ | Change _ | Delete _ -> st + | Keep (x,y,_) -> + (* We need to add equality between existential type parameters + (in inline records) *) + x.data.ld_type::params1, y.data.ld_type::params2 + + let test _loc env (params1,params2) + ({pos; data=lbl1}: Diff.left) + ({data=lbl2; _ }: Diff.right) + = + let name1, name2 = Ident.name lbl1.ld_id, Ident.name lbl2.ld_id in + if name1 <> name2 then + let types_match = + match compare_labels env params1 params2 lbl1 lbl2 with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_labels env params1 params2 lbl1 lbl2 with + | Some reason -> + Error ( + Diffing_with_keys.Type {pos; got=lbl1; expected=lbl2; reason} + ) + | None -> Ok () + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name t ) -> + if t.types_match then 10 else 15 + | Change _ -> 10 + + + + let key (x: Defs.left) = Ident.name x.ld_id + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let module Compute = Diff.Simple(struct + let key_left = key + let key_right = key + let update = update + let test = test loc env + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + + let compare_with_representation ~loc env params1 params2 l r rep1 rep2 = + if not (equal ~loc env params1 params2 l r) then + let patch = diffing loc env params1 params2 l r in + Some (Record_mismatch (Label_mismatch patch)) + else + match rep1, rep2 with + | Record_unboxed _, Record_unboxed _ -> None + | Record_unboxed _, _ -> Some (Unboxed_representation First) + | _, Record_unboxed _ -> Some (Unboxed_representation Second) + + | Record_float, Record_float -> None + | Record_float, _ -> + Some (Record_mismatch (Unboxed_float_representation First)) + | _, Record_float -> + Some (Record_mismatch (Unboxed_float_representation Second)) + + | Record_regular, Record_regular + | Record_inlined _, Record_inlined _ + | Record_extension _, Record_extension _ -> None + | (Record_regular|Record_inlined _|Record_extension _), + (Record_regular|Record_inlined _|Record_extension _) -> + assert false + +end + + +module Variant_diffing = struct + + let compare_constructor_arguments ~loc env params1 params2 arg1 arg2 = + match arg1, arg2 with + | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> + if List.length arg1 <> List.length arg2 then + Some (Arity : constructor_mismatch) + else begin + (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *) + match Ctype.equal env true (params1 @ arg1) (params2 @ arg2) with + | exception Ctype.Equality err -> Some (Type err) + | () -> None + end + | Types.Cstr_record l1, Types.Cstr_record l2 -> + Option.map + (fun rec_err -> Inline_record rec_err) + (Record_diffing.compare env ~loc params1 params2 l1 l2) + | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch) + | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch) + + let compare_constructors ~loc env params1 params2 res1 res2 args1 args2 = + match res1, res2 with + | Some r1, Some r2 -> + begin match Ctype.equal env true [r1] [r2] with + | exception Ctype.Equality err -> Some (Type err) + | () -> compare_constructor_arguments ~loc env [r1] [r2] args1 args2 + end + | Some _, None -> Some (Explicit_return_type First) + | None, Some _ -> Some (Explicit_return_type Second) + | None, None -> + compare_constructor_arguments ~loc env params1 params2 args1 args2 + + let equal ~loc env params1 params2 + (cstrs1 : Types.constructor_declaration list) + (cstrs2 : Types.constructor_declaration list) = + List.length cstrs1 = List.length cstrs2 && + List.for_all2 (fun (cd1:Types.constructor_declaration) + (cd2:Types.constructor_declaration) -> + Ident.name cd1.cd_id = Ident.name cd2.cd_id + && + begin + Builtin_attributes.check_alerts_inclusion + ~def:cd1.cd_loc + ~use:cd2.cd_loc + loc + cd1.cd_attributes cd2.cd_attributes + (Ident.name cd1.cd_id) + ; + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some _ -> false + | None -> true + end) cstrs1 cstrs2 + + module Defs = struct + type left = Types.constructor_declaration + type right = left + type diff = constructor_mismatch + type state = type_expr list * type_expr list + end + module D = Diffing_with_keys.Define(Defs) + + let update _ st = st + + let weight: D.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name t) -> + if t.types_match then 10 else 15 + | Change _ -> 10 + + + let test loc env (params1,params2) + ({pos; data=cd1}: D.left) + ({data=cd2; _}: D.right) = + let name1, name2 = Ident.name cd1.cd_id, Ident.name cd2.cd_id in + if name1 <> name2 then + let types_match = + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some reason -> + Error (Diffing_with_keys.Type {pos; got=cd1; expected=cd2; reason}) + | None -> Ok () + + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let key (x:Defs.left) = Ident.name x.cd_id in + let module Compute = D.Simple(struct + let key_left = key + let key_right = key + let test = test loc env + let update = update + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + let compare_with_representation ~loc env params1 params2 + cstrs1 cstrs2 rep1 rep2 + = + let err = compare ~loc env params1 params2 cstrs1 cstrs2 in + match err, rep1, rep2 with + | None, Variant_regular, Variant_regular + | None, Variant_unboxed, Variant_unboxed -> + None + | Some err, _, _ -> + Some (Variant_mismatch err) + | None, Variant_unboxed, Variant_regular -> + Some (Unboxed_representation First) + | None, Variant_regular, Variant_unboxed -> + Some (Unboxed_representation Second) +end + +(* Inclusion between "private" annotations *) +let privacy_mismatch env decl1 decl2 = + match decl1.type_private, decl2.type_private with + | Private, Public -> begin + match decl1.type_kind, decl2.type_kind with + | Type_record _, Type_record _ -> Some Private_record_type + | Type_variant _, Type_variant _ -> Some Private_variant_type + | Type_open, Type_open -> Some Private_extensible_variant + | Type_abstract, Type_abstract + when Option.is_some decl2.type_manifest -> begin + match decl1.type_manifest with + | Some ty1 -> begin + let ty1 = Ctype.expand_head env ty1 in + match get_desc ty1 with + | Tvariant row when Btype.is_constr_row ~allow_ident:true + (row_more row) -> + Some Private_row_type + | Tobject (fi, _) when Btype.is_constr_row ~allow_ident:true + (snd (Ctype.flatten_fields fi)) -> + Some Private_row_type + | _ -> + Some Private_type_abbreviation + end + | None -> + None + end + | _, _ -> + None + end + | _, _ -> + None + +let private_variant env row1 params1 row2 params2 = + let r1, r2, pairs = + Ctype.merge_row_fields (row_fields row1) (row_fields row2) + in + let row1_closed = row_closed row1 in + let row2_closed = row_closed row2 in + let err = + if row2_closed && not row1_closed then Some Only_outer_closed + else begin + match row2_closed, Ctype.filter_row_fields false r1 with + | true, (s, _) :: _ -> + Some (Missing (Second, s) : private_variant_mismatch) + | _, _ -> None + end + in + if err <> None then err else + let err = + let missing = + List.find_opt + (fun (_,f) -> + match row_field_repr f with + | Rabsent | Reither _ -> false + | Rpresent _ -> true) + r2 + in + match missing with + | None -> None + | Some (s, _) -> Some (Missing (First, s) : private_variant_mismatch) + in + if err <> None then err else + let rec loop tl1 tl2 pairs = + match pairs with + | [] -> begin + match Ctype.equal env true tl1 tl2 with + | exception Ctype.Equality err -> + Some (Types err : private_variant_mismatch) + | () -> None + end + | (s, f1, f2) :: pairs -> begin + match row_field_repr f1, row_field_repr f2 with + | Rpresent to1, Rpresent to2 -> begin + match to1, to2 with + | Some t1, Some t2 -> + loop (t1 :: tl1) (t2 :: tl2) pairs + | None, None -> + loop tl1 tl2 pairs + | Some _, None | None, Some _ -> + Some (Incompatible_types_for s) + end + | Rpresent to1, Reither(const2, ts2, _) -> begin + match to1, const2, ts2 with + | Some t1, false, [t2] -> loop (t1 :: tl1) (t2 :: tl2) pairs + | None, true, [] -> loop tl1 tl2 pairs + | _, _, _ -> Some (Incompatible_types_for s) + end + | Rpresent _, Rabsent -> + Some (Missing (Second, s) : private_variant_mismatch) + | Reither(const1, ts1, _), Reither(const2, ts2, _) -> + if const1 = const2 && List.length ts1 = List.length ts2 then + loop (ts1 @ tl1) (ts2 @ tl2) pairs + else + Some (Incompatible_types_for s) + | Reither _, Rpresent _ -> + Some (Presence s) + | Reither _, Rabsent -> + Some (Missing (Second, s) : private_variant_mismatch) + | Rabsent, (Reither _ | Rabsent) -> + loop tl1 tl2 pairs + | Rabsent, Rpresent _ -> + Some (Missing (First, s) : private_variant_mismatch) + end + in + loop params1 params2 pairs + +let private_object env fields1 params1 fields2 params2 = + let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in + let err = + match miss2 with + | [] -> None + | (f, _, _) :: _ -> Some (Missing f) + in + if err <> None then err else + let tl1, tl2 = + List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) + in + begin + match Ctype.equal env true (params1 @ tl1) (params2 @ tl2) with + | exception Ctype.Equality err -> Some (Types err) + | () -> None + end + +let type_manifest env ty1 params1 ty2 params2 priv2 kind2 = + let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in + match get_desc ty1', get_desc ty2' with + | Tvariant row1, Tvariant row2 + when is_absrow env (row_more row2) -> begin + assert (Ctype.is_equal env true (ty1::params1) (row_more row2::params2)); + match private_variant env row1 params1 row2 params2 with + | None -> None + | Some err -> Some (Private_variant(ty1, ty2, err)) + end + | Tobject (fi1, _), Tobject (fi2, _) + when is_absrow env (snd (Ctype.flatten_fields fi2)) -> begin + let (fields2,rest2) = Ctype.flatten_fields fi2 in + let (fields1,_) = Ctype.flatten_fields fi1 in + assert (Ctype.is_equal env true (ty1::params1) (rest2::params2)); + match private_object env fields1 params1 fields2 params2 with + | None -> None + | Some err -> Some (Private_object(ty1, ty2, err)) + end + | _ -> begin + let is_private_abbrev_2 = + match priv2, kind2 with + | Private, Type_abstract -> begin + (* Same checks as the [when] guards from above, inverted *) + match get_desc ty2' with + | Tvariant row -> + not (is_absrow env (row_more row)) + | Tobject (fi, _) -> + not (is_absrow env (snd (Ctype.flatten_fields fi))) + | _ -> true + end + | _, _ -> false + in + match + if is_private_abbrev_2 then + Ctype.equal_private env params1 ty1 params2 ty2 + else + Ctype.equal env true (params1 @ [ty1]) (params2 @ [ty2]) + with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> None + end + +let type_declarations ?(equality = false) ~loc env ~mark name + decl1 path decl2 = + Builtin_attributes.check_alerts_inclusion + ~def:decl1.type_loc + ~use:decl2.type_loc + loc + decl1.type_attributes decl2.type_attributes + name; + if decl1.type_arity <> decl2.type_arity then Some Arity else + let err = + match privacy_mismatch env decl1 decl2 with + | Some err -> Some (Privacy err) + | None -> None + in + if err <> None then err else + let err = match (decl1.type_manifest, decl2.type_manifest) with + (_, None) -> + begin + match Ctype.equal env true decl1.type_params decl2.type_params with + | exception Ctype.Equality err -> Some (Constraint err) + | () -> None + end + | (Some ty1, Some ty2) -> + type_manifest env ty1 decl1.type_params ty2 decl2.type_params + decl2.type_private decl2.type_kind + | (None, Some ty2) -> + let ty1 = + Btype.newgenty (Tconstr(path, decl2.type_params, ref Mnil)) + in + match Ctype.equal env true decl1.type_params decl2.type_params with + | exception Ctype.Equality err -> Some (Constraint err) + | () -> + match Ctype.equal env false [ty1] [ty2] with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> None + in + if err <> None then err else + let err = match (decl1.type_kind, decl2.type_kind) with + (_, Type_abstract) -> None + | (Type_variant (cstrs1, rep1), Type_variant (cstrs2, rep2)) -> + if mark then begin + let mark usage cstrs = + List.iter (Env.mark_constructor_used usage) cstrs + in + let usage : Env.constructor_usage = + if decl2.type_private = Public then Env.Exported + else Env.Exported_private + in + mark usage cstrs1; + if equality then mark Env.Exported cstrs2 + end; + Variant_diffing.compare_with_representation ~loc env + decl1.type_params + decl2.type_params + cstrs1 + cstrs2 + rep1 + rep2 + | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> + if mark then begin + let mark usage lbls = + List.iter (Env.mark_label_used usage) lbls + in + let usage : Env.label_usage = + if decl2.type_private = Public then Env.Exported + else Env.Exported_private + in + mark usage labels1; + if equality then mark Env.Exported labels2 + end; + Record_diffing.compare_with_representation ~loc env + decl1.type_params decl2.type_params + labels1 labels2 + rep1 rep2 + | (Type_open, Type_open) -> None + | (_, _) -> Some (Kind (of_kind decl1.type_kind, of_kind decl2.type_kind)) + in + if err <> None then err else + let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in + (* If attempt to assign a non-immediate type (e.g. string) to a type that + * must be immediate, then we error *) + let err = + if not abstr then + None + else + match + Type_immediacy.coerce decl1.type_immediate ~as_:decl2.type_immediate + with + | Ok () -> None + | Error violation -> Some (Immediate violation) + in + if err <> None then err else + let need_variance = + abstr || decl1.type_private = Private || decl1.type_kind = Type_open in + if not need_variance then None else + let abstr = abstr || decl2.type_private = Private in + let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in + let constrained ty = not (Btype.is_Tvar ty) in + if List.for_all2 + (fun ty (v1,v2) -> + let open Variance in + let imp a b = not a || b in + let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in + (if abstr then (imp co1 co2 && imp cn1 cn2) + else if opn || constrained ty then (co1 = co2 && cn1 = cn2) + else true) && + let (p1,n1,j1) = get_lower v1 and (p2,n2,j2) = get_lower v2 in + imp abstr (imp p2 p1 && imp n2 n1 && imp j2 j1)) + decl2.type_params (List.combine decl1.type_variance decl2.type_variance) + then None else Some Variance + +(* Inclusion between extension constructors *) + +let extension_constructors ~loc env ~mark id ext1 ext2 = + if mark then begin + let usage : Env.constructor_usage = + if ext2.ext_private = Public then Env.Exported + else Env.Exported_private + in + Env.mark_extension_used usage ext1 + end; + let ty1 = + Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil)) + in + let ty2 = + Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil)) + in + let tl1 = ty1 :: ext1.ext_type_params in + let tl2 = ty2 :: ext2.ext_type_params in + match Ctype.equal env true tl1 tl2 with + | exception Ctype.Equality err -> + Some (Constructor_mismatch (id, ext1, ext2, Type err)) + | () -> + let r = + Variant_diffing.compare_constructors ~loc env + ext1.ext_type_params ext2.ext_type_params + ext1.ext_ret_type ext2.ext_ret_type + ext1.ext_args ext2.ext_args + in + match r with + | Some r -> Some (Constructor_mismatch (id, ext1, ext2, r)) + | None -> + match ext1.ext_private, ext2.ext_private with + | Private, Public -> Some Constructor_privacy + | _, _ -> None diff --git a/ocamlmerlin_mlx/ocaml/typing/includecore.mli b/ocamlmerlin_mlx/ocaml/typing/includecore.mli new file mode 100644 index 0000000..5082597 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/includecore.mli @@ -0,0 +1,139 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the core language *) + +open Typedtree +open Types + +type position = Errortrace.position = First | Second + +type primitive_mismatch = + | Name + | Arity + | No_alloc of position + | Native_name + | Result_repr + | Argument_repr of int + +type value_mismatch = + | Primitive_mismatch of primitive_mismatch + | Not_a_primitive + | Type of Errortrace.moregen_error + +exception Dont_match of value_mismatch + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type type_kind = + | Kind_abstract + | Kind_record + | Kind_variant + | Kind_open + +type kind_mismatch = type_kind * type_kind + +type label_mismatch = + | Type of Errortrace.equality_error + | Mutability of position + +type record_change = + (Types.label_declaration as 'ld, 'ld, label_mismatch) Diffing_with_keys.change + +type record_mismatch = + | Label_mismatch of record_change list + | Unboxed_float_representation of position + +type constructor_mismatch = + | Type of Errortrace.equality_error + | Arity + | Inline_record of record_change list + | Kind of position + | Explicit_return_type of position + +type extension_constructor_mismatch = + | Constructor_privacy + | Constructor_mismatch of Ident.t + * extension_constructor + * extension_constructor + * constructor_mismatch +type variant_change = + (Types.constructor_declaration as 'cd, 'cd, constructor_mismatch) + Diffing_with_keys.change + +type private_variant_mismatch = + | Only_outer_closed + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type type_mismatch = + | Arity + | Privacy of privacy_mismatch + | Kind of kind_mismatch + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | Private_variant of type_expr * type_expr * private_variant_mismatch + | Private_object of type_expr * type_expr * private_object_mismatch + | Variance + | Record_mismatch of record_mismatch + | Variant_mismatch of variant_change list + | Unboxed_representation of position + | Immediate of Type_immediacy.Violation.t + +val value_descriptions: + loc:Location.t -> Env.t -> string -> + value_description -> value_description -> module_coercion + +val type_declarations: + ?equality:bool -> + loc:Location.t -> + Env.t -> mark:bool -> string -> + type_declaration -> Path.t -> type_declaration -> type_mismatch option + +val extension_constructors: + loc:Location.t -> Env.t -> mark:bool -> Ident.t -> + extension_constructor -> extension_constructor -> + extension_constructor_mismatch option +(* +val class_types: + Env.t -> class_type -> class_type -> bool +*) + +val report_value_mismatch : + string -> string -> + Env.t -> + Format.formatter -> value_mismatch -> unit + +val report_type_mismatch : + string -> string -> string -> + Env.t -> + Format.formatter -> type_mismatch -> unit + +val report_extension_constructor_mismatch : + string -> string -> string -> + Env.t -> + Format.formatter -> extension_constructor_mismatch -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/includemod.ml b/ocamlmerlin_mlx/ocaml/typing/includemod.ml new file mode 100644 index 0000000..d0fa23a --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/includemod.ml @@ -0,0 +1,1242 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the module language *) + +open Misc +open Typedtree +open Types + +type symptom = + Missing_field of Ident.t * Location.t * string (* kind *) + | Value_descriptions of Ident.t * value_description * value_description + * Includecore.value_mismatch + | Type_declarations of Ident.t * type_declaration + * type_declaration * Includecore.type_mismatch + | Extension_constructors of Ident.t * extension_constructor + * extension_constructor * Includecore.extension_constructor_mismatch + | Module_types of module_type * module_type + | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration + | Modtype_permutation of Types.module_type * Typedtree.module_coercion + | Interface_mismatch of string * string + | Class_type_declarations of + Ident.t * class_type_declaration * class_type_declaration * + Ctype.class_match_failure list + | Class_declarations of + Ident.t * class_declaration * class_declaration * + Ctype.class_match_failure list + | Unbound_module_path of Path.t + | Invalid_module_alias of Path.t + +type pos = + | Module of Ident.t + | Modtype of Ident.t + | Arg of functor_parameter + | Body of functor_parameter + + +module Error = struct + + type functor_arg_descr = + | Anonymous + | Named of Path.t + | Unit + | Empty_struct + (** For backward compatibility's sake, an empty struct can be implicitly + converted to an unit module *) + + type ('a,'b) diff = {got:'a; expected:'a; symptom:'b} + type 'a core_diff =('a,unit) diff + let diff x y s = {got=x;expected=y; symptom=s} + let sdiff x y = {got=x; expected=y; symptom=()} + + type core_sigitem_symptom = + | Value_descriptions of (value_description, Includecore.value_mismatch) diff + | Type_declarations of (type_declaration, Includecore.type_mismatch) diff + | Extension_constructors of + (extension_constructor, Includecore.extension_constructor_mismatch) diff + | Class_type_declarations of + (class_type_declaration, Ctype.class_match_failure list) diff + | Class_declarations of + (class_declaration, Ctype.class_match_failure list) diff + + type core_module_type_symptom = + | Not_an_alias + | Not_an_identifier + | Incompatible_aliases + | Abstract_module_type + | Unbound_module_path of Path.t + + type module_type_symptom = + | Mt_core of core_module_type_symptom + | Signature of signature_symptom + | Functor of functor_symptom + | Invalid_module_alias of Path.t + | After_alias_expansion of module_type_diff + + + and module_type_diff = (module_type, module_type_symptom) diff + + and functor_symptom = + | Params of functor_params_diff + | Result of module_type_diff + + and ('arg,'path) functor_param_symptom = + | Incompatible_params of 'arg * functor_parameter + | Mismatch of module_type_diff + + and arg_functor_param_symptom = + (functor_parameter, Ident.t) functor_param_symptom + + and functor_params_diff = (functor_parameter list * module_type) core_diff + + and signature_symptom = { + env: Env.t; + missings: signature_item list; + incompatibles: (Ident.t * sigitem_symptom) list; + oks: (int * module_coercion) list; + leftovers: (signature_item * signature_item * int) list; + } + and sigitem_symptom = + | Core of core_sigitem_symptom + | Module_type_declaration of + (modtype_declaration, module_type_declaration_symptom) diff + | Module_type of module_type_diff + + and module_type_declaration_symptom = + | Illegal_permutation of Typedtree.module_coercion + | Not_greater_than of module_type_diff + | Not_less_than of module_type_diff + | Incomparable of + {less_than:module_type_diff; greater_than: module_type_diff} + + + type all = + | In_Compilation_unit of (string, signature_symptom) diff + | In_Signature of signature_symptom + | In_Module_type of module_type_diff + | In_Module_type_substitution of + Ident.t * (Types.module_type,module_type_declaration_symptom) diff + | In_Type_declaration of Ident.t * core_sigitem_symptom + | In_Expansion of core_module_type_symptom + +end + +type mark = + | Mark_both + | Mark_positive + | Mark_negative + | Mark_neither + +let negate_mark = function + | Mark_both -> Mark_both + | Mark_positive -> Mark_negative + | Mark_negative -> Mark_positive + | Mark_neither -> Mark_neither + +let mark_positive = function + | Mark_both | Mark_positive -> true + | Mark_negative | Mark_neither -> false + +(* All functions "blah env x1 x2" check that x1 is included in x2, + i.e. that x1 is the type of an implementation that fulfills the + specification x2. If not, Error is raised with a backtrace of the error. *) + +(* Inclusion between value descriptions *) + +let value_descriptions ~loc env ~mark subst id vd1 vd2 = + Cmt_format.record_value_dependency vd1 vd2; + if mark_positive mark then + Env.mark_value_used vd1.val_uid; + let vd2 = Subst.value_description subst vd2 in + try + Ok (Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2) + with Includecore.Dont_match err -> + Error Error.(Core (Value_descriptions (diff vd1 vd2 err))) + +(* Inclusion between type declarations *) + +let type_declarations ~loc env ~mark ?old_env:_ subst id decl1 decl2 = + let mark = mark_positive mark in + if mark then + Env.mark_type_used decl1.type_uid; + let decl2 = Subst.type_declaration subst decl2 in + match + Includecore.type_declarations ~loc env ~mark + (Ident.name id) decl1 (Path.Pident id) decl2 + with + | None -> Ok Tcoerce_none + | Some err -> + Error Error.(Core(Type_declarations (diff decl1 decl2 err))) + +(* Inclusion between extension constructors *) + +let extension_constructors ~loc env ~mark subst id ext1 ext2 = + let mark = mark_positive mark in + let ext2 = Subst.extension_constructor subst ext2 in + match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with + | None -> Ok Tcoerce_none + | Some err -> + Error Error.(Core(Extension_constructors(diff ext1 ext2 err))) + +(* Inclusion between class declarations *) + +let class_type_declarations ~loc ~old_env:_ env subst decl1 decl2 = + let decl2 = Subst.cltype_declaration subst decl2 in + match Includeclass.class_type_declarations ~loc env decl1 decl2 with + [] -> Ok Tcoerce_none + | reason -> + Error Error.(Core(Class_type_declarations(diff decl1 decl2 reason))) + +let class_declarations ~old_env:_ env subst decl1 decl2 = + let decl2 = Subst.class_declaration subst decl2 in + match Includeclass.class_declarations env decl1 decl2 with + [] -> Ok Tcoerce_none + | reason -> + Error Error.(Core(Class_declarations(diff decl1 decl2 reason))) + +(* Expand a module type identifier when possible *) + +let expand_modtype_path env path = + match Env.find_modtype_expansion path env with + | exception Not_found -> None + | x -> Some x + +let expand_module_alias ~strengthen env path = + match + if strengthen then Env.find_strengthened_module ~aliasable:true path env + else (Env.find_module path env).md_type + with + | x -> Ok x + | exception Not_found -> Error (Error.Unbound_module_path path) + +(* Extract name, kind and ident from a signature item *) + +type field_kind = + | Field_value + | Field_type + | Field_exception + | Field_typext + | Field_module + | Field_modtype + | Field_class + | Field_classtype + + + +type field_desc = { name: string; kind: field_kind } + +let kind_of_field_desc fd = match fd.kind with + | Field_value -> "value" + | Field_type -> "type" + | Field_exception -> "exception" + | Field_typext -> "extension constructor" + | Field_module -> "module" + | Field_modtype -> "module type" + | Field_class -> "class" + | Field_classtype -> "class type" + +let field_desc kind id = { kind; name = Ident.name id } + +(** Map indexed by both field types and names. + This avoids name clashes between different sorts of fields + such as values and types. *) +module FieldMap = Map.Make(struct + type t = field_desc + let compare = Stdlib.compare + end) + +let item_ident_name = function + Sig_value(id, d, _) -> (id, d.val_loc, field_desc Field_value id) + | Sig_type(id, d, _, _) -> (id, d.type_loc, field_desc Field_type id ) + | Sig_typext(id, d, _, _) -> + let kind = + if Path.same d.ext_type_path Predef.path_exn + then Field_exception + else Field_typext + in + (id, d.ext_loc, field_desc kind id) + | Sig_module(id, _, d, _, _) -> (id, d.md_loc, field_desc Field_module id) + | Sig_modtype(id, d, _) -> (id, d.mtd_loc, field_desc Field_modtype id) + | Sig_class(id, d, _, _) -> (id, d.cty_loc, field_desc Field_class id) + | Sig_class_type(id, d, _, _) -> + (id, d.clty_loc, field_desc Field_classtype id) + +let is_runtime_component = function + | Sig_value(_,{val_kind = Val_prim _}, _) + | Sig_type(_,_,_,_) + | Sig_module(_,Mp_absent,_,_,_) + | Sig_modtype(_,_,_) + | Sig_class_type(_,_,_,_) -> false + | Sig_value(_,_,_) + | Sig_typext(_,_,_,_) + | Sig_module(_,Mp_present,_,_,_) + | Sig_class(_,_,_,_) -> true + +(* Print a coercion *) + +let rec print_list pr ppf = function + [] -> () + | [a] -> pr ppf a + | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l +let print_list pr ppf l = + Format.fprintf ppf "[@[%a@]]" (print_list pr) l + +let rec print_coercion ppf c = + let pr fmt = Format.fprintf ppf fmt in + match c with + Tcoerce_none -> pr "id" + | Tcoerce_structure (fl, nl) -> + pr "@[<2>struct@ %a@ %a@]" + (print_list print_coercion2) fl + (print_list print_coercion3) nl + | Tcoerce_functor (inp, out) -> + pr "@[<2>functor@ (%a)@ (%a)@]" + print_coercion inp + print_coercion out + | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> + pr "prim %s@ (%a)" pc_desc.Primitive.prim_name + Printtyp.raw_type_expr pc_type + | Tcoerce_alias (_, p, c) -> + pr "@[<2>alias %a@ (%a)@]" + Printtyp.path p + print_coercion c +and print_coercion2 ppf (n, c) = + Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c +and print_coercion3 ppf (i, n, c) = + Format.fprintf ppf "@[%s, %d,@ %a@]" + (Ident.unique_name i) n print_coercion c + +(* Simplify a structure coercion *) + +let equal_module_paths env p1 subst p2 = + Path.same p1 p2 + || Path.same (Env.normalize_module_path None env p1) + (Env.normalize_module_path None env + (Subst.module_path subst p2)) + +let equal_modtype_paths env p1 subst p2 = + Path.same p1 p2 + || Path.same (Env.normalize_modtype_path env p1) + (Env.normalize_modtype_path env + (Subst.modtype_path subst p2)) + +let simplify_structure_coercion cc id_pos_list = + let rec is_identity_coercion pos = function + | [] -> + true + | (n, c) :: rem -> + n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in + if is_identity_coercion 0 cc + then Tcoerce_none + else Tcoerce_structure (cc, id_pos_list) + +let retrieve_functor_params env mty = + let rec retrieve_functor_params before env = + function + | Mty_ident p as res -> + begin match expand_modtype_path env p with + | Some mty -> retrieve_functor_params before env mty + | None -> List.rev before, res + end + | Mty_alias p as res -> + begin match expand_module_alias ~strengthen:false env p with + | Ok mty -> retrieve_functor_params before env mty + | Error _ -> List.rev before, res + end + | Mty_functor (p, res) -> retrieve_functor_params (p :: before) env res + | Mty_signature _ as res -> List.rev before, res + | Mty_for_hole as res -> List.rev before, res + in + retrieve_functor_params [] env mty + +(* Inclusion between module types. + Return the restriction that transforms a value of the smaller type + into a value of the bigger type. *) + +(* When computing a signature difference, we need to distinguish between + recoverable errors at the value level and unrecoverable errors at the type + level that require us to stop the computation of the difference due to + incoherent types. +*) +type 'a recoverable_error = { error: 'a; recoverable:bool } +let mark_error_as_recoverable r = + Result.map_error (fun error -> { error; recoverable=true}) r +let mark_error_as_unrecoverable r = + Result.map_error (fun error -> { error; recoverable=false}) r + + +module Sign_diff = struct + type t = { + runtime_coercions: (int * Typedtree.module_coercion) list; + shape_map: Shape.Map.t; + deep_modifications:bool; + errors: (Ident.t * Error.sigitem_symptom) list; + leftovers: ((Types.signature_item as 'it) * 'it * int) list + } + + let empty = { + runtime_coercions = []; + shape_map = Shape.Map.empty; + deep_modifications = false; + errors = []; + leftovers = [] + } + + let merge x y = + { + runtime_coercions = x.runtime_coercions @ y.runtime_coercions; + shape_map = y.shape_map; + (* the shape map is threaded the map during the difference computation, + the last shape map contains all previous elements. *) + deep_modifications = x.deep_modifications || y.deep_modifications; + errors = x.errors @ y.errors; + leftovers = x.leftovers @ y.leftovers + } +end + +(** + In the group of mutual functions below, the [~in_eq] argument is [true] when + we are in fact checking equality of module types. + + The module subtyping relation [A <: B] checks that [A.T = B.T] when [A] + and [B] define a module type [T]. The relation [A.T = B.T] is equivalent + to [(A.T <: B.T) and (B.T <: A.T)], but checking both recursively would lead + to an exponential slowdown (see #10598 and #10616). + To avoid this issue, when [~in_eq] is [true], we compute a coarser relation + [A << B] which is the same as [A <: B] except that module types [T] are + checked only for [A.T << B.T] and not the reverse. + Thus, we can implement a cheap module type equality check [A.T = B.T] by + computing [(A.T << B.T) and (B.T << A.T)], avoiding the exponential slowdown + described above. +*) + +let rec modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape = + match try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape with + | Ok _ as ok -> ok + | Error reason -> + let mty2 = Subst.modtype Make_local subst mty2 in + Error Error.(diff mty1 mty2 reason) + +and try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = + match mty1, mty2 with + | (Mty_alias p1, Mty_alias p2) -> + if Env.is_functor_arg p2 env then + Error (Error.Invalid_module_alias p2) + else if not (equal_module_paths env p1 subst p2) then + Error Error.(Mt_core Incompatible_aliases) + else Ok (Tcoerce_none, orig_shape) + | (Mty_alias p1, _) -> begin + match + Env.normalize_module_path (Some Location.none) env p1 + with + | exception Env.Error (Env.Missing_module (_, _, path)) -> + Error Error.(Mt_core(Unbound_module_path path)) + | p1 -> + begin match expand_module_alias ~strengthen:false env p1 with + | Error e -> Error (Error.Mt_core e) + | Ok mty1 -> + match strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark + subst mty1 p1 mty2 orig_shape + with + | Ok _ as x -> x + | Error reason -> Error (Error.After_alias_expansion reason) + end + end + | (Mty_ident p1, Mty_ident p2) -> + let p1 = Env.normalize_modtype_path env p1 in + let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in + if Path.same p1 p2 then Ok (Tcoerce_none, orig_shape) + else + begin match expand_modtype_path env p1, expand_modtype_path env p2 with + | Some mty1, Some mty2 -> + try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape + | None, _ | _, None -> Error (Error.Mt_core Abstract_module_type) + end + | (Mty_ident p1, _) -> + let p1 = Env.normalize_modtype_path env p1 in + begin match expand_modtype_path env p1 with + | Some p1 -> + try_modtypes ~in_eq ~loc env ~mark subst p1 mty2 orig_shape + | None -> Error (Error.Mt_core Abstract_module_type) + end + | (_, Mty_ident p2) -> + let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in + begin match expand_modtype_path env p2 with + | Some p2 -> try_modtypes ~in_eq ~loc env ~mark subst mty1 p2 orig_shape + | None -> + begin match mty1 with + | Mty_functor _ -> + let params1 = retrieve_functor_params env mty1 in + let d = Error.sdiff params1 ([],mty2) in + Error Error.(Functor (Params d)) + | _ -> Error Error.(Mt_core Not_an_identifier) + end + end + | (Mty_signature sig1, Mty_signature sig2) -> + begin match + signatures ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape + with + | Ok _ as ok -> ok + | Error e -> Error (Error.Signature e) + end + | Mty_functor (param1, res1), Mty_functor (param2, res2) -> + let cc_arg, env, subst = + functor_param ~in_eq ~loc env ~mark:(negate_mark mark) + subst param1 param2 + in + let var, res_shape = + match Shape.decompose_abs orig_shape with + | Some (var, res_shape) -> var, res_shape + | None -> + (* Using a fresh variable with a placeholder uid here is fine: users + will never try to jump to the definition of that variable. + If they try to jump to the parameter from inside the functor, + they will use the variable shape that is stored in the local + environment. *) + let var, shape_var = + Shape.fresh_var Uid.internal_not_actually_unique + in + var, Shape.app orig_shape ~arg:shape_var + in + let cc_res = modtypes ~in_eq ~loc env ~mark subst res1 res2 res_shape in + begin match cc_arg, cc_res with + | Ok Tcoerce_none, Ok (Tcoerce_none, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_none, final_shape) + | Ok cc_arg, Ok (cc_res, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_functor(cc_arg, cc_res), final_shape) + | _, Error {Error.symptom = Error.Functor Error.Params res; _} -> + let got_params, got_res = res.got in + let expected_params, expected_res = res.expected in + let d = Error.sdiff + (param1::got_params, got_res) + (param2::expected_params, expected_res) in + Error Error.(Functor (Params d)) + | Error _, _ -> + let params1, res1 = retrieve_functor_params env res1 in + let params2, res2 = retrieve_functor_params env res2 in + let d = Error.sdiff (param1::params1, res1) (param2::params2, res2) in + Error Error.(Functor (Params d)) + | Ok _, Error res -> + Error Error.(Functor (Result res)) + end + | Mty_functor _, _ + | _, Mty_functor _ -> + let params1 = retrieve_functor_params env mty1 in + let params2 = retrieve_functor_params env mty2 in + let d = Error.sdiff params1 params2 in + Error Error.(Functor (Params d)) + | Mty_for_hole, _ | _, Mty_for_hole -> + Ok (Tcoerce_none, Shape.dummy_mod) + | _, Mty_alias _ -> + Error (Error.Mt_core Error.Not_an_alias) + +(* Functor parameters *) + +and functor_param ~in_eq ~loc env ~mark subst param1 param2 = + match param1, param2 with + | Unit, Unit -> + Ok Tcoerce_none, env, subst + | Named (name1, arg1), Named (name2, arg2) -> + let arg2' = Subst.modtype Keep subst arg2 in + let cc_arg = + match + modtypes ~in_eq ~loc env ~mark Subst.identity arg2' arg1 + Shape.dummy_mod + with + | Ok (cc, _) -> Ok cc + | Error err -> Error (Error.Mismatch err) + in + let env, subst = equate_one_functor_param subst env arg2' name1 name2 in + cc_arg, env, subst + | _, _ -> + Error (Error.Incompatible_params (param1, param2)), env, subst + +and equate_one_functor_param subst env arg2' name1 name2 = + match name1, name2 with + | Some id1, Some id2 -> + (* two matching abstract parameters: we add one identifier to the + environment and record the equality between the two identifiers + in the substitution *) + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | None, Some id2 -> + let id1 = Ident.rename id2 in + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | Some id1, None -> + Env.add_module id1 Mp_present arg2' env, subst + | None, None -> + env, subst + +and strengthened_modtypes ~in_eq ~loc ~aliasable env ~mark + subst mty1 path1 mty2 shape = + match mty1, mty2 with + | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> + Ok (Tcoerce_none, shape) + | _, _ -> + let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in + modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape + +and strengthened_module_decl ~loc ~aliasable env ~mark + subst md1 path1 md2 shape = + match md1.md_type, md2.md_type with + | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> + Ok (Tcoerce_none, shape) + | _, _ -> + let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in + modtypes ~in_eq:false ~loc env ~mark subst md1.md_type md2.md_type shape + +(* Inclusion between signatures *) + +and signatures ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = + (* Environment used to check inclusion of components *) + let new_env = + Env.add_signature sig1 (Env.in_signature true env) in + (* Keep ids for module aliases *) + let (id_pos_list,_) = + List.fold_left + (fun (l,pos) -> function + Sig_module (id, Mp_present, _, _, _) -> + ((id,pos,Tcoerce_none)::l , pos+1) + | item -> (l, if is_runtime_component item then pos+1 else pos)) + ([], 0) sig1 in + (* Build a table of the components of sig1, along with their positions. + The table is indexed by kind and name of component *) + let rec build_component_table nb_exported pos tbl = function + [] -> nb_exported, pos, tbl + | item :: rem -> + let pos, nextpos = + if is_runtime_component item then pos, pos + 1 + else -1, pos + in + match item_visibility item with + | Hidden -> + (* do not pair private items. *) + build_component_table nb_exported nextpos tbl rem + | Exported -> + let (id, _loc, name) = item_ident_name item in + build_component_table (nb_exported + 1) nextpos + (FieldMap.add name (id, item, pos) tbl) rem + in + let exported_len1, runtime_len1, comps1 = + build_component_table 0 0 FieldMap.empty sig1 + in + let exported_len2, runtime_len2 = + List.fold_left (fun (el, rl) i -> + let el = match item_visibility i with Hidden -> el | Exported -> el + 1 in + let rl = if is_runtime_component i then rl + 1 else rl in + el, rl + ) (0, 0) sig2 + in + (* Pair each component of sig2 with a component of sig1, + identifying the names along the way. + Return a coercion list indicating, for all run-time components + of sig2, the position of the matching run-time components of sig1 + and the coercion to be applied to it. *) + let rec pair_components subst paired unpaired = function + [] -> + let open Sign_diff in + let d = + signature_components ~in_eq ~loc env ~mark new_env subst mod_shape + Shape.Map.empty + (List.rev paired) + in + begin match unpaired, d.errors, d.runtime_coercions, d.leftovers with + | [], [], cc, [] -> + let shape = + if not d.deep_modifications && exported_len1 = exported_len2 + then mod_shape + else Shape.str ?uid:mod_shape.Shape.uid d.shape_map + in + if runtime_len1 = runtime_len2 then (* see PR#5098 *) + Ok (simplify_structure_coercion cc id_pos_list, shape) + else + Ok (Tcoerce_structure (cc, id_pos_list), shape) + | missings, incompatibles, runtime_coercions, leftovers -> + Error { + Error.env=new_env; + missings; + incompatibles; + oks=runtime_coercions; + leftovers; + } + end + | item2 :: rem -> + let (id2, _loc, name2) = item_ident_name item2 in + let name2, report = + match item2, name2 with + Sig_type (_, {type_manifest=None}, _, _), {name=s; kind=Field_type} + when Btype.is_row_name s -> + (* Do not report in case of failure, + as the main type will generate an error *) + { kind=Field_type; name=String.sub s 0 (String.length s - 4) }, + false + | _ -> name2, true + in + begin match FieldMap.find name2 comps1 with + | (id1, item1, pos1) -> + let new_subst = + match item2 with + Sig_type _ -> + Subst.add_type id2 (Path.Pident id1) subst + | Sig_module _ -> + Subst.add_module id2 (Path.Pident id1) subst + | Sig_modtype _ -> + Subst.add_modtype id2 (Mty_ident (Path.Pident id1)) subst + | Sig_value _ | Sig_typext _ + | Sig_class _ | Sig_class_type _ -> + subst + in + pair_components new_subst + ((item1, item2, pos1) :: paired) unpaired rem + | exception Not_found -> + let unpaired = + if report then + item2 :: unpaired + else unpaired in + pair_components subst paired unpaired rem + end in + (* Do the pairing and checking, and return the final coercion *) + pair_components subst [] [] sig2 + +(* Inclusion between signature components *) + +and signature_components ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map paired = + match paired with + | [] -> Sign_diff.{ empty with shape_map } + | (sigi1, sigi2, pos) :: rem -> + let shape_modified = ref false in + let id, item, shape_map, present_at_runtime = + match sigi1, sigi2 with + | Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) -> + let item = + value_descriptions ~loc env ~mark subst id1 valdecl1 valdecl2 + in + let item = mark_error_as_recoverable item in + let present_at_runtime = match valdecl2.val_kind with + | Val_prim _ -> false + | _ -> true + in + let shape_map = Shape.Map.add_value_proj shape_map id1 orig_shape in + id1, item, shape_map, present_at_runtime + | Sig_type(id1, tydec1, _, _), Sig_type(_id2, tydec2, _, _) -> + let item = + type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in + id1, item, shape_map, false + | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> + let item = + extension_constructors ~loc env ~mark subst id1 ext1 ext2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_extcons_proj shape_map id1 orig_shape + in + id1, item, shape_map, true + | Sig_module(id1, pres1, mty1, _, _), Sig_module(_, pres2, mty2, _, _) + -> begin + let orig_shape = + Shape.(proj orig_shape (Item.module_ id1)) + in + let item = + module_declarations ~in_eq ~loc env ~mark subst id1 mty1 mty2 + orig_shape + in + let item, shape_map = + match item with + | Ok (cc, shape) -> + if shape != orig_shape then shape_modified := true; + let mod_shape = Shape.set_uid_if_none shape mty1.md_uid in + Ok cc, Shape.Map.add_module shape_map id1 mod_shape + | Error diff -> + Error (Error.Module_type diff), + (* We add the original shape to the map, even though + there is a type error. + It could still be useful for merlin. *) + Shape.Map.add_module shape_map id1 orig_shape + in + let present_at_runtime, item = + match pres1, pres2, mty1.md_type with + | Mp_present, Mp_present, _ -> true, item + | _, Mp_absent, _ -> false, item + | Mp_absent, Mp_present, Mty_alias p1 -> + true, Result.map (fun i -> Tcoerce_alias (env, p1, i)) item + | Mp_absent, Mp_present, _ -> assert false + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, present_at_runtime + end + | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) -> + let item = + modtype_infos ~in_eq ~loc env ~mark subst id1 info1 info2 + in + let shape_map = + Shape.Map.add_module_type_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, false + | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) -> + let item = + class_declarations ~old_env env subst decl1 decl2 + in + let shape_map = + Shape.Map.add_class_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, true + | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) -> + let item = + class_type_declarations ~loc ~old_env env subst info1 info2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_class_type_proj shape_map id1 orig_shape + in + id1, item, shape_map, false + | _ -> + assert false + in + let deep_modifications = !shape_modified in + let first = + match item with + | Ok x -> + let runtime_coercions = + if present_at_runtime then [pos,x] else [] + in + Sign_diff.{ empty with deep_modifications; runtime_coercions } + | Error { error; recoverable=_ } -> + Sign_diff.{ empty with errors=[id,error]; deep_modifications } + in + let continue = match item with + | Ok _ -> true + | Error x -> x.recoverable + in + let rest = + if continue then + signature_components ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map rem + else Sign_diff.{ empty with leftovers=rem } + in + Sign_diff.merge first rest + +and module_declarations ~in_eq ~loc env ~mark subst id1 md1 md2 orig_shape = + Builtin_attributes.check_alerts_inclusion + ~def:md1.md_loc + ~use:md2.md_loc + loc + md1.md_attributes md2.md_attributes + (Ident.name id1); + let p1 = Path.Pident id1 in + if mark_positive mark then + Env.mark_module_used md1.md_uid; + strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark subst + md1.md_type p1 md2.md_type orig_shape + +(* Inclusion between module type specifications *) + +and modtype_infos ~in_eq ~loc env ~mark subst id info1 info2 = + Builtin_attributes.check_alerts_inclusion + ~def:info1.mtd_loc + ~use:info2.mtd_loc + loc + info1.mtd_attributes info2.mtd_attributes + (Ident.name id); + let info2 = Subst.modtype_declaration Keep subst info2 in + let r = + match (info1.mtd_type, info2.mtd_type) with + (None, None) -> Ok Tcoerce_none + | (Some _, None) -> Ok Tcoerce_none + | (Some mty1, Some mty2) -> + check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 + | (None, Some mty2) -> + let mty1 = Mty_ident(Path.Pident id) in + check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 in + match r with + | Ok _ as ok -> ok + | Error e -> Error Error.(Module_type_declaration (diff info1 info2 e)) + +and check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 = + let c1 = + modtypes ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2 Shape.dummy_mod + in + let c2 = + (* For nested module type paths, we check only one side of the equivalence: + the outer module type is the one responsible for checking the other side + of the equivalence. + *) + if in_eq then None + else + let mark = negate_mark mark in + Some ( + modtypes ~in_eq:true ~loc env ~mark Subst.identity + mty2 mty1 Shape.dummy_mod + ) + in + match c1, c2 with + | Ok (Tcoerce_none, _), (Some Ok (Tcoerce_none, _)|None) -> Ok Tcoerce_none + | Ok (c1, _), (Some Ok _ | None) -> + (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." + print_coercion _c1 print_coercion _c2; *) + Error Error.(Illegal_permutation c1) + | Ok _, Some Error e -> Error Error.(Not_greater_than e) + | Error e, (Some Ok _ | None) -> Error Error.(Not_less_than e) + | Error less_than, Some Error greater_than -> + Error Error.(Incomparable {less_than; greater_than}) + + +(* Simplified inclusion check between module types (for Env) *) + +let can_alias env path = + let rec no_apply = function + | Path.Pident _ -> true + | Path.Pdot(p, _) | Path.Pextra_ty (p, _) -> no_apply p + | Path.Papply _ -> false + in + no_apply path && not (Env.is_functor_arg path env) + + + +type explanation = Env.t * Error.all +exception Error of explanation + +exception Apply_error of { + loc : Location.t ; + env : Env.t ; + lid_app : Longident.t option ; + mty_f : module_type ; + args : (Error.functor_arg_descr * module_type) list ; + } + +let check_modtype_inclusion_raw ~loc env mty1 path1 mty2 = + let aliasable = can_alias env path1 in + strengthened_modtypes ~in_eq:false ~loc ~aliasable env ~mark:Mark_both + Subst.identity mty1 path1 mty2 Shape.dummy_mod + |> Result.map fst + +let check_modtype_inclusion ~loc env mty1 path1 mty2 = + match check_modtype_inclusion_raw ~loc env mty1 path1 mty2 with + | Ok _ -> None + | Error e -> Some (env, Error.In_Module_type e) + +let check_functor_application_in_path + ~errors ~loc ~lid_whole_app ~f0_path ~args + ~arg_path ~arg_mty ~param_mty env = + match check_modtype_inclusion_raw ~loc env arg_mty arg_path param_mty with + | Ok _ -> () + | Error _errs -> + if errors then + let prepare_arg (arg_path, arg_mty) = + let aliasable = can_alias env arg_path in + let smd = Mtype.strengthen ~aliasable env arg_mty arg_path in + (Error.Named arg_path, smd) + in + let mty_f = (Env.find_module f0_path env).md_type in + let args = List.map prepare_arg args in + let lid_app = Some lid_whole_app in + raise (Apply_error {loc; env; lid_app; mty_f; args}) + else + raise Not_found + +let () = + Env.check_functor_application := check_functor_application_in_path + + +(* Check that an implementation of a compilation unit meets its + interface. *) + +let compunit env ~mark impl_name impl_sig intf_name intf_sig unit_shape = + match + signatures ~in_eq:false ~loc:(Location.in_file impl_name) env ~mark + Subst.identity impl_sig intf_sig unit_shape + with Result.Error reasons -> + let cdiff = + Error.In_Compilation_unit(Error.diff impl_name intf_name reasons) in + raise(Error(env, cdiff)) + | Ok x -> x + +(* Functor diffing computation: + The diffing computation uses the internal typing function + *) + +module Functor_inclusion_diff = struct + + module Defs = struct + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state = { + res: module_type option; + env: Env.t; + subst: Subst.t; + } + end + open Defs + + module Diff = Diffing.Define(Defs) + + let param_name = function + | Named(x,_) -> x + | Unit -> None + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Change _ -> 10 + | Keep (param1, param2, _) -> begin + match param_name param1, param_name param2 with + | None, None + -> 0 + | Some n1, Some n2 + when String.equal (Ident.name n1) (Ident.name n2) + -> 0 + | Some _, Some _ -> 1 + | Some _, None | None, Some _ -> 1 + end + + + + let keep_expansible_param = function + | Mty_ident _ | Mty_alias _ as mty -> Some mty + | Mty_signature _ | Mty_functor _ | Mty_for_hole -> None + + let lookup_expansion { env ; res ; _ } = match res with + | None -> None + | Some res -> + match retrieve_functor_params env res with + | [], _ -> None + | params, res -> + let more = Array.of_list params in + Some (keep_expansible_param res, more) + + let expand_params state = + match lookup_expansion state with + | None -> state, [||] + | Some (res, expansion) -> { state with res }, expansion + + (* Whenever we have a named parameter that doesn't match it anonymous + counterpart, we add it to the typing environment because it may + contain useful abbreviations, but without adding any equations *) + let bind id arg state = + let arg' = Subst.modtype Keep state.subst arg in + let env = Env.add_module id Mp_present arg' state.env in + { state with env } + + let rec update (d:Diff.change) st = + match d with + | Insert (Unit | Named (None,_)) + | Delete (Unit | Named (None,_)) + | Keep (Unit,_,_) + | Keep (_,Unit,_) -> + (* No named abstract parameters: we keep the same environment *) + st, [||] + | Insert (Named (Some id, arg)) | Delete (Named (Some id, arg)) -> + (* one named parameter to bind *) + st |> bind id arg |> expand_params + | Change (delete, insert, _) -> + (* Change should be delete + insert: we add both abstract parameters + to the environment without equating them. *) + let st, _expansion = update (Diffing.Delete delete) st in + update (Diffing.Insert insert) st + | Keep (Named (name1, _), Named (name2, arg2), _) -> + let arg = Subst.modtype Keep st.subst arg2 in + let env, subst = + equate_one_functor_param st.subst st.env arg name1 name2 + in + expand_params { st with env; subst } + + let diff env (l1,res1) (l2,_) = + let module Compute = Diff.Left_variadic(struct + let test st mty1 mty2 = + let loc = Location.none in + let res, _, _ = + functor_param ~in_eq:false ~loc st.env ~mark:Mark_neither + st.subst mty1 mty2 + in + res + let update = update + let weight = weight + end) + in + let param1 = Array.of_list l1 in + let param2 = Array.of_list l2 in + let state = + { env; subst = Subst.identity; res = keep_expansible_param res1} + in + Compute.diff state param1 param2 + +end + +module Functor_app_diff = struct + module I = Functor_inclusion_diff + module Defs= struct + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state = I.Defs.state + end + module Diff = Diffing.Define(Defs) + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Change _ -> 10 + | Keep (param1, param2, _) -> + (* We assign a small penalty to named arguments with + non-matching names *) + begin + let desc1 : Error.functor_arg_descr = fst param1 in + match desc1, I.param_name param2 with + | (Unit | Empty_struct | Anonymous) , None + -> 0 + | Named (Path.Pident n1), Some n2 + when String.equal (Ident.name n1) (Ident.name n2) + -> 0 + | Named _, Some _ -> 1 + | Named _, None | (Unit | Empty_struct | Anonymous), Some _ -> 1 + end + + let update (d: Diff.change) (st:Defs.state) = + let open Error in + match d with + | Insert (Unit|Named(None,_)) + | Delete _ (* delete is a concrete argument, not an abstract parameter*) + | Keep ((Unit,_),_,_) (* Keep(Unit,_) implies Keep(Unit,Unit) *) + | Keep (_,(Unit|Named(None,_)),_) + | Change (_,(Unit|Named (None,_)), _ ) -> + (* no abstract parameters to add, nor any equations *) + st, [||] + | Insert(Named(Some param, param_ty)) + | Change(_, Named(Some param, param_ty), _ ) -> + (* Change is Delete + Insert: we add the Inserted parameter to the + environnement to track equalities with external components that the + parameter might add. *) + let mty = Subst.modtype Keep st.subst param_ty in + let env = Env.add_module ~arg:true param Mp_present mty st.env in + I.expand_params { st with env } + | Keep ((Named arg, _mty) , Named (Some param, _param), _) -> + let res = + Option.map (fun res -> + let scope = Ctype.create_scope () in + let subst = Subst.add_module param arg Subst.identity in + Subst.modtype (Rescope scope) subst res + ) + st.res + in + let subst = Subst.add_module param arg st.subst in + I.expand_params { st with subst; res } + | Keep (((Anonymous|Empty_struct), mty), + Named (Some param, _param), _) -> + let mty' = Subst.modtype Keep st.subst mty in + let env = Env.add_module ~arg:true param Mp_present mty' st.env in + let res = Option.map (Mtype.nondep_supertype env [param]) st.res in + I.expand_params { st with env; res} + + let diff env ~f ~args = + let params, res = retrieve_functor_params env f in + let module Compute = Diff.Right_variadic(struct + let update = update + let test (state:Defs.state) (arg,arg_mty) param = + let loc = Location.none in + let res = match (arg:Error.functor_arg_descr), param with + | (Unit|Empty_struct), Unit -> Ok Tcoerce_none + | Unit, Named _ | (Anonymous | Named _), Unit -> + Result.Error (Error.Incompatible_params(arg,param)) + | ( Anonymous | Named _ | Empty_struct ), Named (_, param) -> + match + modtypes ~in_eq:false ~loc state.env ~mark:Mark_neither + state.subst arg_mty param Shape.dummy_mod + with + | Error mty -> Result.Error (Error.Mismatch mty) + | Ok (cc, _) -> Ok cc + in + res + let weight = weight + end) + in + let args = Array.of_list args in + let params = Array.of_list params in + let state : Defs.state = + { env; subst = Subst.identity; res = I.keep_expansible_param res } + in + Compute.diff state args params + +end + +(* Hide the context and substitution parameters to the outside world *) + +let modtypes_with_shape ~shape ~loc env ~mark mty1 mty2 = + match modtypes ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 shape + with + | Ok (cc, shape) -> cc, shape + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let modtypes ~loc env ~mark mty1 mty2 = + match modtypes ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let signatures env ~mark sig1 sig2 = + match signatures ~in_eq:false ~loc:Location.none env ~mark + Subst.identity sig1 sig2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error(env,Error.(In_Signature reason))) + +let type_declarations ~loc env ~mark id decl1 decl2 = + match type_declarations ~loc env ~mark Subst.identity id decl1 decl2 with + | Ok _ -> () + | Error (Error.Core reason) -> + raise (Error(env,Error.(In_Type_declaration(id,reason)))) + | Error _ -> assert false + +let strengthened_module_decl ~loc ~aliasable env ~mark md1 path1 md2 = + match strengthened_module_decl ~loc ~aliasable env ~mark Subst.identity + md1 path1 md2 Shape.dummy_mod with + | Ok (x, _shape) -> x + | Error mdiff -> + raise (Error(env,Error.(In_Module_type mdiff))) + +let expand_module_alias ~strengthen env path = + match expand_module_alias ~strengthen env path with + | Ok x -> x + | Result.Error _ -> + raise (Error(env,In_Expansion(Error.Unbound_module_path path))) + +let check_modtype_equiv ~loc env id mty1 mty2 = + match check_modtype_equiv ~in_eq:false ~loc env ~mark:Mark_both mty1 mty2 with + | Ok _ -> () + | Error e -> + raise (Error(env, + Error.(In_Module_type_substitution (id,diff mty1 mty2 e))) + ) diff --git a/ocamlmerlin_mlx/ocaml/typing/includemod.mli b/ocamlmerlin_mlx/ocaml/typing/includemod.mli new file mode 100644 index 0000000..d5b2ee9 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/includemod.mli @@ -0,0 +1,255 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the module language *) + +open Typedtree +open Types + +(** Type describing which arguments of an inclusion to consider as used + for the usage warnings. [Mark_both] is the default. *) +type mark = + | Mark_both + (** Mark definitions used from both arguments *) + | Mark_positive + (** Mark definitions used from the positive (first) argument *) + | Mark_negative + (** Mark definitions used from the negative (second) argument *) + | Mark_neither + (** Do not mark definitions used from either argument *) + +module Error: sig + + type ('elt,'explanation) diff = { + got:'elt; + expected:'elt; + symptom:'explanation + } + type 'elt core_diff =('elt,unit) diff + + type functor_arg_descr = + | Anonymous + | Named of Path.t + | Unit + | Empty_struct + (** For backward compatibility's sake, an empty struct can be implicitly + converted to an unit module. *) + + type core_sigitem_symptom = + | Value_descriptions of + (Types.value_description, Includecore.value_mismatch) diff + | Type_declarations of + (Types.type_declaration, Includecore.type_mismatch) diff + | Extension_constructors of + (Types.extension_constructor, + Includecore.extension_constructor_mismatch) diff + | Class_type_declarations of + (Types.class_type_declaration, Ctype.class_match_failure list) diff + | Class_declarations of + (Types.class_declaration, Ctype.class_match_failure list) diff + + type core_module_type_symptom = + | Not_an_alias + | Not_an_identifier + | Incompatible_aliases + | Abstract_module_type + | Unbound_module_path of Path.t + + type module_type_symptom = + | Mt_core of core_module_type_symptom + | Signature of signature_symptom + | Functor of functor_symptom + | Invalid_module_alias of Path.t + | After_alias_expansion of module_type_diff + + + and module_type_diff = (Types.module_type, module_type_symptom) diff + + and functor_symptom = + | Params of functor_params_diff + | Result of module_type_diff + + and ('arg,'path) functor_param_symptom = + | Incompatible_params of 'arg * Types.functor_parameter + | Mismatch of module_type_diff + + and arg_functor_param_symptom = + (Types.functor_parameter, Ident.t) functor_param_symptom + + and functor_params_diff = + (Types.functor_parameter list * Types.module_type) core_diff + + and signature_symptom = { + env: Env.t; + missings: Types.signature_item list; + incompatibles: (Ident.t * sigitem_symptom) list; + oks: (int * Typedtree.module_coercion) list; + leftovers: ((Types.signature_item as 'it) * 'it * int) list + (** signature items that could not be compared due to type divergence *) + } + and sigitem_symptom = + | Core of core_sigitem_symptom + | Module_type_declaration of + (Types.modtype_declaration, module_type_declaration_symptom) diff + | Module_type of module_type_diff + + and module_type_declaration_symptom = + | Illegal_permutation of Typedtree.module_coercion + | Not_greater_than of module_type_diff + | Not_less_than of module_type_diff + | Incomparable of + {less_than:module_type_diff; greater_than: module_type_diff} + + + type all = + | In_Compilation_unit of (string, signature_symptom) diff + | In_Signature of signature_symptom + | In_Module_type of module_type_diff + | In_Module_type_substitution of + Ident.t * (Types.module_type,module_type_declaration_symptom) diff + | In_Type_declaration of Ident.t * core_sigitem_symptom + | In_Expansion of core_module_type_symptom +end +type explanation = Env.t * Error.all + +(* Extract name, kind and ident from a signature item *) +type field_kind = + | Field_value + | Field_type + | Field_exception + | Field_typext + | Field_module + | Field_modtype + | Field_class + | Field_classtype + +type field_desc = { name: string; kind: field_kind } + +val kind_of_field_desc: field_desc -> string +val field_desc: field_kind -> Ident.t -> field_desc + +(** Map indexed by both field types and names. + This avoids name clashes between different sorts of fields + such as values and types. *) +module FieldMap: Map.S with type key = field_desc + +val item_ident_name: Types.signature_item -> Ident.t * Location.t * field_desc +val is_runtime_component: Types.signature_item -> bool + + +(* Typechecking *) + +val modtypes: + loc:Location.t -> Env.t -> mark:mark -> + module_type -> module_type -> module_coercion + +val modtypes_with_shape: + shape:Shape.t -> loc:Location.t -> Env.t -> mark:mark -> + module_type -> module_type -> module_coercion * Shape.t + +val strengthened_module_decl: + loc:Location.t -> aliasable:bool -> Env.t -> mark:mark -> + module_declaration -> Path.t -> module_declaration -> module_coercion + +val check_modtype_inclusion : + loc:Location.t -> Env.t -> Types.module_type -> Path.t -> Types.module_type -> + explanation option +(** [check_modtype_inclusion ~loc env mty1 path1 mty2] checks that the + functor application F(M) is well typed, where mty2 is the type of + the argument of F and path1/mty1 is the path/unstrenghened type of M. *) + +val check_modtype_equiv: + loc:Location.t -> Env.t -> Ident.t -> module_type -> module_type -> unit + +val signatures: Env.t -> mark:mark -> + signature -> signature -> module_coercion + +val compunit: + Env.t -> mark:mark -> string -> signature -> + string -> signature -> Shape.t -> module_coercion * Shape.t + +val type_declarations: + loc:Location.t -> Env.t -> mark:mark -> + Ident.t -> type_declaration -> type_declaration -> unit + +val print_coercion: Format.formatter -> module_coercion -> unit + +type symptom = + Missing_field of Ident.t * Location.t * string (* kind *) + | Value_descriptions of + Ident.t * value_description * value_description + * Includecore.value_mismatch + | Type_declarations of Ident.t * type_declaration + * type_declaration * Includecore.type_mismatch + | Extension_constructors of Ident.t * extension_constructor + * extension_constructor * Includecore.extension_constructor_mismatch + | Module_types of module_type * module_type + | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration + | Modtype_permutation of Types.module_type * Typedtree.module_coercion + | Interface_mismatch of string * string + | Class_type_declarations of + Ident.t * class_type_declaration * class_type_declaration * + Ctype.class_match_failure list + | Class_declarations of + Ident.t * class_declaration * class_declaration * + Ctype.class_match_failure list + | Unbound_module_path of Path.t + | Invalid_module_alias of Path.t + +type pos = + | Module of Ident.t + | Modtype of Ident.t + | Arg of functor_parameter + | Body of functor_parameter + +exception Error of explanation +exception Apply_error of { + loc : Location.t ; + env : Env.t ; + lid_app : Longident.t option ; + mty_f : module_type ; + args : (Error.functor_arg_descr * Types.module_type) list ; + } + +val expand_module_alias: strengthen:bool -> Env.t -> Path.t -> Types.module_type + +module Functor_inclusion_diff: sig + module Defs: sig + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state + end + val diff: Env.t -> + Types.functor_parameter list * Types.module_type -> + Types.functor_parameter list * Types.module_type -> + Diffing.Define(Defs).patch +end + +module Functor_app_diff: sig + module Defs: sig + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state + end + val diff: + Env.t -> + f:Types.module_type -> + args:(Error.functor_arg_descr * Types.module_type) list -> + Diffing.Define(Defs).patch +end diff --git a/ocamlmerlin_mlx/ocaml/typing/includemod_errorprinter.ml b/ocamlmerlin_mlx/ocaml/typing/includemod_errorprinter.ml new file mode 100644 index 0000000..f72795c --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/includemod_errorprinter.ml @@ -0,0 +1,941 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +module Context = struct + type pos = + | Module of Ident.t + | Modtype of Ident.t + | Arg of Types.functor_parameter + | Body of Types.functor_parameter + + let path_of_context = function + Module id :: rem -> + let rec subm path = function + | [] -> path + | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem + | _ -> assert false + in subm (Path.Pident id) rem + | _ -> assert false + + + let rec context ppf = function + Module id :: rem -> + Format.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem + | Modtype id :: rem -> + Format.fprintf ppf "@[<2>module type %a =@ %a@]" + Printtyp.ident id context_mty rem + | Body x :: rem -> + Format.fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem + | Arg x :: rem -> + Format.fprintf ppf "functor (%s : %a) -> ..." + (argname x) context_mty rem + | [] -> + Format.fprintf ppf "" + and context_mty ppf = function + (Module _ | Modtype _) :: _ as rem -> + Format.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem + | cxt -> context ppf cxt + and args ppf = function + Body x :: rem -> + Format.fprintf ppf "(%s)%a" (argname x) args rem + | Arg x :: rem -> + Format.fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem + | cxt -> + Format.fprintf ppf " :@ %a" context_mty cxt + and argname = function + | Types.Unit -> "" + | Types.Named (None, _) -> "_" + | Types.Named (Some id, _) -> Ident.name id + + let alt_pp ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then + Format.fprintf ppf "in module %a," Printtyp.path (path_of_context cxt) + else + Format.fprintf ppf "@[at position@ %a,@]" context cxt + + let pp ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then + Format.fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt) + else + Format.fprintf ppf "@[At position@ %a@]@ " context cxt +end + +module Illegal_permutation = struct + (** Extraction of information in case of illegal permutation + in a module type *) + + (** When examining coercions, we only have runtime component indices, + we use thus a limited version of {!pos}. *) + type coerce_pos = + | Item of int + | InArg + | InBody + + let either f x g y = match f x with + | None -> g y + | Some _ as v -> v + + (** We extract a lone transposition from a full tree of permutations. *) + let rec transposition_under path (coerc:Typedtree.module_coercion) = + match coerc with + | Tcoerce_structure(c,_) -> + either + (not_fixpoint path 0) c + (first_non_id path 0) c + | Tcoerce_functor(arg,res) -> + either + (transposition_under (InArg::path)) arg + (transposition_under (InBody::path)) res + | Tcoerce_none -> None + | Tcoerce_alias _ | Tcoerce_primitive _ -> + (* these coercions are not inversible, and raise an error earlier when + checking for module type equivalence *) + assert false + (* we search the first point which is not invariant at the current level *) + and not_fixpoint path pos = function + | [] -> None + | (n, _) :: q -> + if n = pos then + not_fixpoint path (pos+1) q + else + Some(List.rev path, pos, n) + (* we search the first item with a non-identity inner coercion *) + and first_non_id path pos = function + | [] -> None + | (_, Typedtree.Tcoerce_none) :: q -> first_non_id path (pos + 1) q + | (_,c) :: q -> + either + (transposition_under (Item pos :: path)) c + (first_non_id path (pos + 1)) q + + let transposition c = + match transposition_under [] c with + | None -> raise Not_found + | Some x -> x + + let rec runtime_item k = function + | [] -> raise Not_found + | item :: q -> + if not(Includemod.is_runtime_component item) then + runtime_item k q + else if k = 0 then + item + else + runtime_item (k-1) q + + (* Find module type at position [path] and convert the [coerce_pos] path to + a [pos] path *) + let rec find env ctx path (mt:Types.module_type) = match mt, path with + | (Mty_ident p | Mty_alias p), _ -> + begin match (Env.find_modtype p env).mtd_type with + | None -> raise Not_found + | Some mt -> find env ctx path mt + end + | Mty_signature s , [] -> List.rev ctx, s + | Mty_signature s, Item k :: q -> + begin match runtime_item k s with + | Sig_module (id, _, md,_,_) -> + find env (Context.Module id :: ctx) q md.md_type + | _ -> raise Not_found + end + | Mty_functor(Named (_,mt) as arg,_), InArg :: q -> + find env (Context.Arg arg :: ctx) q mt + | Mty_functor(arg, mt), InBody :: q -> + find env (Context.Body arg :: ctx) q mt + | _ -> raise Not_found + + let find env path mt = find env [] path mt + let item mt k = Includemod.item_ident_name (runtime_item k mt) + + let pp_item ppf (id,_,kind) = + Format.fprintf ppf "%s %S" + (Includemod.kind_of_field_desc kind) + (Ident.name id) + + let pp ctx_printer env ppf (mty,c) = + try + let p, k, l = transposition c in + let ctx, mt = find env p mty in + Format.fprintf ppf + "@[Illegal permutation of runtime components in a module type.@ \ + @[For example,@ %a@]@ @[the %a@ and the %a are not in the same order@ \ + in the expected and actual module types.@]@]" + ctx_printer ctx pp_item (item mt k) pp_item (item mt l) + with Not_found -> (* this should not happen *) + Format.fprintf ppf + "Illegal permutation of runtime components in a module type." + +end + + + +module Err = Includemod.Error + +let buffer = ref Bytes.empty +let is_big obj = + let size = !Clflags.error_size in + size > 0 && + begin + if Bytes.length !buffer < size then buffer := Bytes.create size; + try ignore (Marshal.to_buffer !buffer 0 size obj []); false + with _ -> true + end + +let show_loc msg ppf loc = + let pos = loc.Location.loc_start in + if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then () + else Format.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg + +let show_locs ppf (loc1, loc2) = + show_loc "Expected declaration" ppf loc2; + show_loc "Actual declaration" ppf loc1 + + +let dmodtype mty = + let tmty = Printtyp.tree_of_modtype mty in + Format.dprintf "%a" !Oprint.out_module_type tmty + +let space ppf () = Format.fprintf ppf "@ " + +(** + In order to display a list of functor arguments in a compact format, + we introduce a notion of shorthand for functor arguments. + The aim is to first present the lists of actual and expected types with + shorthands: + + (X: $S1) (Y: $S2) (Z: An_existing_module_type) ... + does not match + (X: $T1) (Y: A_real_path) (Z: $T3) ... + + and delay the full display of the module types corresponding to $S1, $S2, + $T1, and $T3 to the suberror message. + +*) +module With_shorthand = struct + + (** A item with a potential shorthand name *) + type 'a named = { + item: 'a; + name : string; + } + + type 'a t = + | Original of 'a (** The shorthand has been discarded *) + | Synthetic of 'a named + (** The shorthand is potentially useful *) + + type functor_param = + | Unit + | Named of (Ident.t option * Types.module_type t) + + (** Shorthand generation *) + type kind = + | Got + | Expected + | Unneeded + + type variant = + | App + | Inclusion + + let elide_if_app ctx s = match ctx with + | App -> Unneeded + | Inclusion -> s + + let make side pos = + match side with + | Got -> Format.sprintf "$S%d" pos + | Expected -> Format.sprintf "$T%d" pos + | Unneeded -> "..." + + (** Add shorthands to a patch *) + open Diffing + let patch ctx p = + let add_shorthand side pos mty = + {name = (make side pos); item = mty } + in + let aux i d = + let pos = i + 1 in + let d = match d with + | Insert mty -> + Insert (add_shorthand Expected pos mty) + | Delete mty -> + Delete (add_shorthand (elide_if_app ctx Got) pos mty) + | Change (g, e, p) -> + Change + (add_shorthand Got pos g, + add_shorthand Expected pos e, p) + | Keep (g, e, p) -> + Keep (add_shorthand Got pos g, + add_shorthand (elide_if_app ctx Expected) pos e, p) + in + pos, d + in + List.mapi aux p + + (** Shorthand computation from named item *) + let modtype (r : _ named) = match r.item with + | Types.Mty_ident _ + | Types.Mty_alias _ + | Types.Mty_signature [] + | Types.Mty_for_hole + -> Original r.item + | Types.Mty_signature _ | Types.Mty_functor _ + -> Synthetic r + + let functor_param (ua : _ named) = match ua.item with + | Types.Unit -> Unit + | Types.Named (from, mty) -> + Named (from, modtype { ua with item = mty }) + + (** Printing of arguments with shorthands *) + let pp ppx = function + | Original x -> ppx x + | Synthetic s -> Format.dprintf "%s" s.name + + let pp_orig ppx = function + | Original x | Synthetic { item=x; _ } -> ppx x + + let definition x = match functor_param x with + | Unit -> Format.dprintf "()" + | Named(_,short_mty) -> + match short_mty with + | Original mty -> dmodtype mty + | Synthetic {name; item = mty} -> + Format.dprintf + "%s@ =@ %t" name (dmodtype mty) + + let param x = match functor_param x with + | Unit -> Format.dprintf "()" + | Named (_, short_mty) -> + pp dmodtype short_mty + + let qualified_param x = match functor_param x with + | Unit -> Format.dprintf "()" + | Named (None, Original (Mty_signature []) ) -> + Format.dprintf "(sig end)" + | Named (None, short_mty) -> + pp dmodtype short_mty + | Named (Some p, short_mty) -> + Format.dprintf "(%s : %t)" + (Ident.name p) (pp dmodtype short_mty) + + let definition_of_argument ua = + let arg, mty = ua.item in + match (arg: Err.functor_arg_descr) with + | Unit -> Format.dprintf "()" + | Empty_struct -> Format.dprintf "(struct end)" + | Named p -> + let mty = modtype { ua with item = mty } in + Format.dprintf + "%a@ :@ %t" + Printtyp.path p + (pp_orig dmodtype mty) + | Anonymous -> + let short_mty = modtype { ua with item = mty } in + begin match short_mty with + | Original mty -> dmodtype mty + | Synthetic {name; item=mty} -> + Format.dprintf "%s@ :@ %t" name (dmodtype mty) + end + + let arg ua = + let arg, mty = ua.item in + match (arg: Err.functor_arg_descr) with + | Unit -> Format.dprintf "()" + | Empty_struct -> Format.dprintf "(struct end)" + | Named p -> fun ppf -> Printtyp.path ppf p + | Anonymous -> + let short_mty = modtype { ua with item=mty } in + pp dmodtype short_mty + +end + + +module Functor_suberror = struct + open Err + + let param_id x = match x.With_shorthand.item with + | Types.Named (Some _ as x,_) -> x + | Types.(Unit | Named(None,_)) -> None + + (** Print the list of params with style *) + let pretty_params sep proj printer patch = + let elt (x,param) = + let sty = Diffing.(style @@ classify x) in + Format.dprintf "%a%t%a" + Format.pp_open_stag (Misc.Color.Style sty) + (printer param) + Format.pp_close_stag () + in + let params = List.filter_map proj @@ List.map snd patch in + Printtyp.functor_parameters ~sep elt params + + let expected d = + let extract: _ Diffing.change -> _ = function + | Insert mty + | Keep(_,mty,_) + | Change (_,mty,_) as x -> + Some (param_id mty,(x, mty)) + | Delete _ -> None + in + pretty_params space extract With_shorthand.qualified_param d + + let drop_inserted_suffix patch = + let rec drop = function + | Diffing.Insert _ :: q -> drop q + | rest -> List.rev rest in + drop (List.rev patch) + + let prepare_patch ~drop ~ctx patch = + let drop_suffix x = if drop then drop_inserted_suffix x else x in + patch |> drop_suffix |> With_shorthand.patch ctx + + + module Inclusion = struct + + let got d = + let extract: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (param_id mty,(x,mty)) + | Insert _ -> None + in + pretty_params space extract With_shorthand.qualified_param d + + let insert mty = + Format.dprintf + "An argument appears to be missing with module type@;<1 2>@[%t@]" + (With_shorthand.definition mty) + + let delete mty = + Format.dprintf + "An extra argument is provided of module type@;<1 2>@[%t@]" + (With_shorthand.definition mty) + + let ok x y = + Format.dprintf + "Module types %t and %t match" + (With_shorthand.param x) + (With_shorthand.param y) + + let diff g e more = + let g = With_shorthand.definition g in + let e = With_shorthand.definition e in + Format.dprintf + "Module types do not match:@ @[%t@]@;<1 -2>does not include@ \ + @[%t@]%t" + g e (more ()) + + let incompatible = function + | Types.Unit -> + Format.dprintf + "The functor was expected to be applicative at this position" + | Types.Named _ -> + Format.dprintf + "The functor was expected to be generative at this position" + + let patch env got expected = + Includemod.Functor_inclusion_diff.diff env got expected + |> prepare_patch ~drop:false ~ctx:Inclusion + + end + + module App = struct + + let patch env ~f ~args = + Includemod.Functor_app_diff.diff env ~f ~args + |> prepare_patch ~drop:true ~ctx:App + + let got d = + let extract: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (None,(x,mty)) + | Insert _ -> None + in + pretty_params space extract With_shorthand.arg d + + let delete mty = + Format.dprintf + "The following extra argument is provided@;<1 2>@[%t@]" + (With_shorthand.definition_of_argument mty) + + let insert = Inclusion.insert + + let ok x y = + let pp_orig_name = match With_shorthand.functor_param y with + | With_shorthand.Named (_, Original mty) -> + Format.dprintf " %t" (dmodtype mty) + | _ -> ignore + in + Format.dprintf + "Module %t matches the expected module type%t" + (With_shorthand.arg x) + pp_orig_name + + let diff g e more = + let g = With_shorthand.definition_of_argument g in + let e = With_shorthand.definition e in + Format.dprintf + "Modules do not match:@ @[%t@]@;<1 -2>\ + is not included in@ @[%t@]%t" + g e (more ()) + + (** Specialized to avoid introducing shorthand names + for single change difference + *) + let single_diff g e more = + let _arg, mty = g.With_shorthand.item in + let e = match e.With_shorthand.item with + | Types.Unit -> Format.dprintf "()" + | Types.Named(_, mty) -> dmodtype mty + in + Format.dprintf + "Modules do not match:@ @[%t@]@;<1 -2>\ + is not included in@ @[%t@]%t" + (dmodtype mty) e (more ()) + + + let incompatible = function + | Unit -> + Format.dprintf + "The functor was expected to be applicative at this position" + | Named _ | Anonymous -> + Format.dprintf + "The functor was expected to be generative at this position" + | Empty_struct -> + (* an empty structure can be used in both applicative and generative + context *) + assert false + end + + let subcase sub ~expansion_token env (pos, diff) = + Location.msg "%a%a%a%a@[%t@]%a" + Format.pp_print_tab () + Format.pp_open_tbox () + Diffing.prefix (pos, Diffing.classify diff) + Format.pp_set_tab () + (Printtyp.wrap_printing_env env ~error:true + (fun () -> sub ~expansion_token env diff) + ) + Format.pp_close_tbox () + + let onlycase sub ~expansion_token env (_, diff) = + Location.msg "%a@[%t@]" + Format.pp_print_tab () + (Printtyp.wrap_printing_env env ~error:true + (fun () -> sub ~expansion_token env diff) + ) + + let params sub ~expansion_token env l = + let rec aux subcases = function + | [] -> subcases + | (_, Diffing.Keep _) as a :: q -> + aux (subcase sub ~expansion_token env a :: subcases) q + | a :: q -> + List.fold_left (fun acc x -> + (subcase sub ~expansion_token:false env x) :: acc + ) + (subcase sub ~expansion_token env a :: subcases) + q + in + match l with + | [a] -> [onlycase sub ~expansion_token env a] + | l -> aux [] l +end + + +(** Construct a linear presentation of the error tree *) + +open Err + +(* Context helper functions *) +let with_context ?loc ctx printer diff = + Location.msg ?loc "%a%a" Context.pp (List.rev ctx) + printer diff + +let dwith_context ?loc ctx printer = + Location.msg ?loc "%a%t" Context.pp (List.rev ctx) printer + +let dwith_context_and_elision ?loc ctx printer diff = + if is_big (diff.got,diff.expected) then + Location.msg ?loc "..." + else + dwith_context ?loc ctx (printer diff) + +(* Merge sub msgs into one printer *) +let coalesce msgs = + match List.rev msgs with + | [] -> ignore + | before -> + let ctx ppf = + Format.pp_print_list ~pp_sep:space + (fun ppf x -> x.Location.txt ppf) + ppf before in + ctx + +let subcase_list l ppf = match l with + | [] -> () + | _ :: _ -> + Format.fprintf ppf "@;<1 -2>@[%a@]" + (Format.pp_print_list ~pp_sep:space + (fun ppf f -> f.Location.txt ppf) + ) + (List.rev l) + +(* Printers for leaves *) +let core env id x = + match x with + | Err.Value_descriptions diff -> + Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + "Values do not match" + !Oprint.out_sig_item + (Printtyp.tree_of_value_description id diff.got) + "is not included in" + !Oprint.out_sig_item + (Printtyp.tree_of_value_description id diff.expected) + (Includecore.report_value_mismatch + "the first" "the second" env) diff.symptom + show_locs (diff.got.val_loc, diff.expected.val_loc) + Printtyp.Conflicts.print_explanations + | Err.Type_declarations diff -> + Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + "Type declarations do not match" + !Oprint.out_sig_item + (Printtyp.tree_of_type_declaration id diff.got Trec_first) + "is not included in" + !Oprint.out_sig_item + (Printtyp.tree_of_type_declaration id diff.expected Trec_first) + (Includecore.report_type_mismatch + "the first" "the second" "declaration" env) diff.symptom + show_locs (diff.got.type_loc, diff.expected.type_loc) + Printtyp.Conflicts.print_explanations + | Err.Extension_constructors diff -> + Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a%t@]" + "Extension declarations do not match" + !Oprint.out_sig_item + (Printtyp.tree_of_extension_constructor id diff.got Text_first) + "is not included in" + !Oprint.out_sig_item + (Printtyp.tree_of_extension_constructor id diff.expected Text_first) + (Includecore.report_extension_constructor_mismatch + "the first" "the second" "declaration" env) diff.symptom + show_locs (diff.got.ext_loc, diff.expected.ext_loc) + Printtyp.Conflicts.print_explanations + | Err.Class_type_declarations diff -> + Format.dprintf + "@[Class type declarations do not match:@ \ + %a@;<1 -2>does not match@ %a@]@ %a%t" + !Oprint.out_sig_item + (Printtyp.tree_of_cltype_declaration id diff.got Trec_first) + !Oprint.out_sig_item + (Printtyp.tree_of_cltype_declaration id diff.expected Trec_first) + (Includeclass.report_error Type_scheme) diff.symptom + Printtyp.Conflicts.print_explanations + | Err.Class_declarations {got;expected;symptom} -> + let t1 = Printtyp.tree_of_class_declaration id got Trec_first in + let t2 = Printtyp.tree_of_class_declaration id expected Trec_first in + Format.dprintf + "@[Class declarations do not match:@ \ + %a@;<1 -2>does not match@ %a@]@ %a%t" + !Oprint.out_sig_item t1 + !Oprint.out_sig_item t2 + (Includeclass.report_error Type_scheme) symptom + Printtyp.Conflicts.print_explanations + +let missing_field ppf item = + let id, loc, kind = Includemod.item_ident_name item in + Format.fprintf ppf "The %s `%a' is required but not provided%a" + (Includemod.kind_of_field_desc kind) Printtyp.ident id + (show_loc "Expected declaration") loc + +let module_types {Err.got=mty1; expected=mty2} = + Format.dprintf + "@[Modules do not match:@ \ + %a@;<1 -2>is not included in@ %a@]" + !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) + !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) + +let eq_module_types {Err.got=mty1; expected=mty2} = + Format.dprintf + "@[Module types do not match:@ \ + %a@;<1 -2>is not equal to@ %a@]" + !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) + !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) + +let module_type_declarations id {Err.got=d1 ; expected=d2} = + Format.dprintf + "@[Module type declarations do not match:@ \ + %a@;<1 -2>does not match@ %a@]" + !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1) + !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2) + +let interface_mismatch ppf (diff: _ Err.diff) = + Format.fprintf ppf + "The implementation %s@ does not match the interface %s:@ " + diff.got diff.expected + +let core_module_type_symptom (x:Err.core_module_type_symptom) = + match x with + | Not_an_alias | Not_an_identifier | Abstract_module_type + | Incompatible_aliases -> + if Printtyp.Conflicts.exists () then + Some Printtyp.Conflicts.print_explanations + else None + | Unbound_module_path path -> + Some(Format.dprintf "Unbound module %a" Printtyp.path path) + +(* Construct a linearized error message from the error tree *) + +let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx diff = + match diff.symptom with + | Invalid_module_alias _ (* the difference is non-informative here *) + | After_alias_expansion _ (* we print only the expanded module types *) -> + module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx + diff.symptom + | Functor Params d -> (* We jump directly to the functor param error *) + functor_params ~expansion_token ~env ~before ~ctx d + | _ -> + let inner = if eqmode then eq_module_types else module_types in + let next = + match diff.symptom with + | Mt_core _ -> + (* In those cases, the refined error messages for the current error + will at most add some minor comments on the current error. + It is thus better to avoid eliding the current error message. + *) + dwith_context ctx (inner diff) + | _ -> dwith_context_and_elision ctx inner diff + in + let before = next :: before in + module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx + diff.symptom + +and module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx = function + | Mt_core core -> + begin match core_module_type_symptom core with + | None -> before + | Some msg -> Location.msg "%t" msg :: before + end + | Signature s -> signature ~expansion_token ~env ~before ~ctx s + | Functor f -> functor_symptom ~expansion_token ~env ~before ~ctx f + | After_alias_expansion diff -> + module_type ~eqmode ~expansion_token ~env ~before ~ctx diff + | Invalid_module_alias path -> + let printer = + Format.dprintf "Module %a cannot be aliased" Printtyp.path path + in + dwith_context ctx printer :: before + +and functor_params ~expansion_token ~env ~before ~ctx {got;expected;_} = + let d = Functor_suberror.Inclusion.patch env got expected in + let actual = Functor_suberror.Inclusion.got d in + let expected = Functor_suberror.expected d in + let main = + Format.dprintf + "@[Modules do not match:@ \ + @[functor@ %t@ -> ...@]@;<1 -2>is not included in@ \ + @[functor@ %t@ -> ...@]@]" + actual expected + in + let msgs = dwith_context ctx main :: before in + let functor_suberrors = + if expansion_token then + Functor_suberror.params functor_arg_diff ~expansion_token env d + else [] + in + functor_suberrors @ msgs + +and functor_symptom ~expansion_token ~env ~before ~ctx = function + | Result res -> + module_type ~expansion_token ~eqmode:false ~env ~before ~ctx res + | Params d -> functor_params ~expansion_token ~env ~before ~ctx d + +and signature ~expansion_token ~env:_ ~before ~ctx sgs = + Printtyp.wrap_printing_env ~error:true sgs.env (fun () -> + match sgs.missings, sgs.incompatibles with + | a :: l , _ -> + if expansion_token then + with_context ctx missing_field a + :: List.map (Location.msg "%a" missing_field) l + @ before + else + before + | [], a :: _ -> sigitem ~expansion_token ~env:sgs.env ~before ~ctx a + | [], [] -> assert false + ) +and sigitem ~expansion_token ~env ~before ~ctx (name,s) = match s with + | Core c -> + dwith_context ctx (core env name c) :: before + | Module_type diff -> + module_type ~expansion_token ~eqmode:false ~env ~before + ~ctx:(Context.Module name :: ctx) diff + | Module_type_declaration diff -> + module_type_decl ~expansion_token ~env ~before ~ctx name diff +and module_type_decl ~expansion_token ~env ~before ~ctx id diff = + let next = + dwith_context_and_elision ctx (module_type_declarations id) diff in + let before = next :: before in + match diff.symptom with + | Not_less_than mts -> + let before = + Location.msg "The first module type is not included in the second" + :: before + in + module_type ~expansion_token ~eqmode:true ~before ~env + ~ctx:(Context.Modtype id :: ctx) mts + | Not_greater_than mts -> + let before = + Location.msg "The second module type is not included in the first" + :: before in + module_type ~expansion_token ~eqmode:true ~before ~env + ~ctx:(Context.Modtype id :: ctx) mts + | Incomparable mts -> + module_type ~expansion_token ~eqmode:true ~env ~before + ~ctx:(Context.Modtype id :: ctx) mts.less_than + | Illegal_permutation c -> + begin match diff.got.Types.mtd_type with + | None -> assert false + | Some mty -> + with_context (Modtype id::ctx) + (Illegal_permutation.pp Context.alt_pp env) (mty,c) + :: before + end + +and functor_arg_diff ~expansion_token env (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.Inclusion.insert mty + | Delete mty -> Functor_suberror.Inclusion.delete mty + | Keep (x, y, _) -> Functor_suberror.Inclusion.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.Inclusion.incompatible i + | Change (g, e, Err.Mismatch mty_diff) -> + let more () = + subcase_list @@ + module_type_symptom ~eqmode:false ~expansion_token ~env ~before:[] + ~ctx:[] mty_diff.symptom + in + Functor_suberror.Inclusion.diff g e more + +let functor_app_diff ~expansion_token env (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.App.insert mty + | Delete mty -> Functor_suberror.App.delete mty + | Keep (x, y, _) -> Functor_suberror.App.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.App.incompatible i + | Change (g, e, Err.Mismatch mty_diff) -> + let more () = + subcase_list @@ + module_type_symptom ~eqmode:false ~expansion_token ~env ~before:[] + ~ctx:[] mty_diff.symptom + in + Functor_suberror.App.diff g e more + +let module_type_subst ~env id diff = + match diff.symptom with + | Not_less_than mts -> + module_type ~expansion_token:true ~eqmode:true ~before:[] ~env + ~ctx:[Modtype id] mts + | Not_greater_than mts -> + module_type ~expansion_token:true ~eqmode:true ~before:[] ~env + ~ctx:[Modtype id] mts + | Incomparable mts -> + module_type ~expansion_token:true ~eqmode:true ~env ~before:[] + ~ctx:[Modtype id] mts.less_than + | Illegal_permutation c -> + let mty = diff.got in + let main = + with_context [Modtype id] + (Illegal_permutation.pp Context.alt_pp env) (mty,c) in + [main] + +let all env = function + | In_Compilation_unit diff -> + let first = Location.msg "%a" interface_mismatch diff in + signature ~expansion_token:true ~env ~before:[first] ~ctx:[] diff.symptom + | In_Type_declaration (id,reason) -> + [Location.msg "%t" (core env id reason)] + | In_Module_type diff -> + module_type ~expansion_token:true ~eqmode:false ~before:[] ~env ~ctx:[] + diff + | In_Module_type_substitution (id,diff) -> + module_type_subst ~env id diff + | In_Signature diff -> + signature ~expansion_token:true ~before:[] ~env ~ctx:[] diff + | In_Expansion cmts -> + match core_module_type_symptom cmts with + | None -> assert false + | Some main -> [Location.msg "%t" main] + +(* General error reporting *) + +let err_msgs (env, err) = + Printtyp.Conflicts.reset(); + Printtyp.wrap_printing_env ~error:true env + (fun () -> coalesce @@ all env err) + +let report_error err = + let main = err_msgs err in + Location.errorf ~loc:Location.(in_file !input_name) "%t" main + +let report_apply_error ~loc env (lid_app, mty_f, args) = + let may_print_app ppf = match lid_app with + | None -> () + | Some lid -> Format.fprintf ppf "%a " Printtyp.longident lid + in + let d = Functor_suberror.App.patch env ~f:mty_f ~args in + match d with + (* We specialize the one change and one argument case to remove the + presentation of the functor arguments *) + | [ _, Change (_, _, Err.Incompatible_params (i,_)) ] -> + Location.errorf ~loc "%t" (Functor_suberror.App.incompatible i) + | [ _, Change (g, e, Err.Mismatch mty_diff) ] -> + let more () = + subcase_list @@ + module_type_symptom ~eqmode:false ~expansion_token:true ~env ~before:[] + ~ctx:[] mty_diff.symptom + in + Location.errorf ~loc "%t" (Functor_suberror.App.single_diff g e more) + | _ -> + let actual = Functor_suberror.App.got d in + let expected = Functor_suberror.expected d in + let sub = + List.rev @@ + Functor_suberror.params functor_app_diff env ~expansion_token:true d + in + Location.errorf ~loc ~sub + "@[The functor application %tis ill-typed.@ \ + These arguments:@;<1 2>\ + @[%t@]@ do not match these parameters:@;<1 2>@[functor@ %t@ -> ...@]@]" + may_print_app + actual expected + +let register () = + Location.register_error_of_exn + (function + | Includemod.Error err -> Some (report_error err) + | Includemod.Apply_error {loc; env; lid_app; mty_f; args} -> + Some (Printtyp.wrap_printing_env env ~error:true (fun () -> + report_apply_error ~loc env (lid_app, mty_f, args)) + ) + | _ -> None + ) diff --git a/ocamlmerlin_mlx/ocaml/typing/includemod_errorprinter.mli b/ocamlmerlin_mlx/ocaml/typing/includemod_errorprinter.mli new file mode 100644 index 0000000..12ea216 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/includemod_errorprinter.mli @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val err_msgs: Includemod.explanation -> Format.formatter -> unit +val register: unit -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/magic_numbers.ml b/ocamlmerlin_mlx/ocaml/typing/magic_numbers.ml new file mode 100644 index 0000000..f052ec9 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/magic_numbers.ml @@ -0,0 +1,76 @@ +open Std + +module Cmi = struct + type error = + | Not_an_interface of string + | Wrong_version_interface of string * string + | Corrupted_interface of string + + exception Error of error + + let to_version_opt = function + | "Caml1999I017" -> Some "4.02" + | "Caml1999I020" -> Some "4.03" + | "Caml1999I021" -> Some "4.04 or 4.05" + | "Caml1999I022" -> Some "4.06" + | "Caml1999I023" -> Some "4.07.0" + | "Caml1999I024" -> Some "4.07.1" + | "Caml1999I025" -> Some "4.08" + | "Caml1999I026" -> Some "4.09" + | "Caml1999I027" -> Some "4.10" + | "Caml1999I028" -> Some "4.11" + | "Caml1999I029" -> Some "4.12" + | "Caml1999I030" -> Some "4.13" + | "Caml1999I031" -> Some "4.14" + | "Caml1999I032" -> Some "5.0" + | "Caml1999I033" -> Some "5.1" + | _ -> None + + let () = assert (to_version_opt Config.cmi_magic_number <> None) + + open Format + + let report_error ppf = function + | Not_an_interface filename -> + fprintf ppf "%a@ is not a compiled interface" + Location.print_filename filename + | Wrong_version_interface (filename, compiler_magic) -> + let program_name = Lib_config.program_name () in + begin match to_version_opt compiler_magic with + | None -> + fprintf ppf + "Compiler version mismatch: this project seems to be compiled with a \ + version of the OCaml compiler that is not supported by this version \ + of %s. OCaml language support will not work properly until this \ + problem is fixed. \n\ + Hint: It seems that the project is built with a newer OCaml compiler \ + version that the running %s version does not know about. Make sure \ + your editor runs a version of %s that supports this version of the \ + compiler. \n\ + This diagnostic is based on the compiled interface file: %a" + program_name program_name program_name + Location.print_filename filename + | Some version -> + fprintf ppf + "Compiler version mismatch: this project seems to be compiled with \ + version %s of the OCaml compiler, but the running %s supports OCaml \ + version %s. OCaml language support will not work properly until this \ + problem is fixed. \n\ + Hint: Make sure your editor runs a version of %s that supports the \ + correct version of the compiler. \n\ + This diagnostic is based on the compiled interface file: %a" + version program_name + (Option.get @@ to_version_opt Config.cmi_magic_number) + program_name Location.print_filename filename + end + | Corrupted_interface filename -> + fprintf ppf "Corrupted compiled interface@ %a" + Location.print_filename filename + + let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) +end diff --git a/ocamlmerlin_mlx/ocaml/typing/msupport.ml b/ocamlmerlin_mlx/ocaml/typing/msupport.ml new file mode 100644 index 0000000..0261938 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/msupport.ml @@ -0,0 +1,182 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +open Std + +let errors : (exn list ref * unit Btype.TypeHash.t) option ref = ref None + +let monitor_errors' = ref (ref false) +let monitor_errors () = + if !(!monitor_errors') then + monitor_errors' := (ref false); + !monitor_errors' + +let raise_error ?(ignore_unify=false) exn = + !monitor_errors' := true; + match !errors with + | Some (l,_) -> + begin match exn with + | Ctype.Unify _ when ignore_unify -> () + | Ctype.Unify _ | Failure _ -> + Logger.log ~section:"Typing_aux.raise_error" + ~title:(Printexc.exn_slot_name exn) "%a" + Logger.fmt (fun fmt -> + Printexc.record_backtrace true; + Format.pp_print_string fmt (Printexc.get_backtrace ()) + ) + | exn -> l := exn :: !l + end + | None -> raise exn + +let () = + Msupport_parsing.msupport_raise_error := raise_error + +exception Resume + +let resume_raise exn = + raise_error exn; + raise Resume + +let catch_errors warnings caught f = + let warnings' = Warnings.backup () in + let errors' = !errors in + Warnings.restore warnings; + errors := (Some (caught,Btype.TypeHash.create 3)); + Misc.try_finally f + ~always:(fun () -> + errors := errors'; + Warnings.restore warnings') + +let uncatch_errors f = + let_ref errors None f + +let erroneous_type_register te = + let te = Types.Transient_expr.coerce te in + match !errors with + | Some (_,h) -> Btype.TypeHash.replace h te () + | None -> () + +let erroneous_type_check te = + let te = Types.Transient_expr.coerce te in + match !errors with + | Some (_,h) -> Btype.TypeHash.mem h te + | _ -> false + +let rec erroneous_expr_check e = + (erroneous_type_check e.Typedtree.exp_type) || + match e.Typedtree.exp_desc with + | Typedtree.Texp_ident (p,_,_) + when Ident.name (Path.head p) = "_" -> true + | Typedtree.Texp_apply (e',_) -> erroneous_expr_check e' + | _ -> false + +exception Warning of Location.t * string + +let prerr_warning loc w = + match !errors with + | None -> () (*Location.print_warning loc Format.err_formatter w*) + | Some (l, _) -> + let ppf, to_string = Format.to_string () in + Location.print_warning loc ppf w; + match to_string () with + | "" -> () + | s -> l := Warning (loc,s) :: !l + +let prerr_alert loc w = + match !errors with + | None -> () (*Location.print_warning loc Format.err_formatter w*) + | Some (l, _) -> + let ppf, to_string = Format.to_string () in + Location.print_alert loc ppf w; + match to_string () with + | "" -> () + | s -> l := Warning (loc,s) :: !l + +let () = Location.register_error_of_exn (function + | Warning (loc, str) -> Some (Location.error ~loc ~source:Location.Warning str) + | _ -> None + ) + +let () = Location.prerr_warning_ref := prerr_warning + +let () = Location.prerr_alert_ref := prerr_alert + +let flush_saved_types () = + match Cmt_format.get_saved_types () with + | [] -> [] + | parts -> + Cmt_format.set_saved_types []; + let open Ast_helper in + let pexp = Exp.constant (Saved_parts.store parts) in + let pstr = Str.eval pexp in + [Attr.mk (Saved_parts.attribute) (Parsetree.PStr [pstr])] + +let rec get_saved_types_from_attributes = function + | [] -> [] + | attr :: attrs -> + let (attr, str) = Ast_helper.Attr.as_tuple attr in + if attr = Saved_parts.attribute then + let open Parsetree in + begin match str with + | PStr({pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant key; _ } ,_) + ; _ } :: _) -> + Saved_parts.find key + | _ -> [] + end + else + get_saved_types_from_attributes attrs + +let with_warning_attribute ?warning_attribute f = + match warning_attribute with + | None -> f () + | Some attr -> Builtin_attributes.warning_scope attr f + +let with_saved_types ?warning_attribute ?save_part f = + let saved_types = Cmt_format.get_saved_types () in + Cmt_format.set_saved_types []; + try + let result = with_warning_attribute ?warning_attribute f in + begin match save_part with + | None -> () + | Some f -> Cmt_format.set_saved_types (f result :: saved_types) + end; + result + with exn -> + let saved_types'= Cmt_format.get_saved_types () in + Cmt_format.set_saved_types (saved_types' @ saved_types); + reraise exn + +let incorrect_attribute = + Ast_helper.Attr.mk (Location.mknoloc "merlin.incorrect") (Parsetree.PStr []) + +let recovery_attributes attrs = + let attrs' = incorrect_attribute :: flush_saved_types () in + match attrs with + | [] -> attrs' + | attrs -> attrs' @ attrs diff --git a/ocamlmerlin_mlx/ocaml/typing/msupport.mli b/ocamlmerlin_mlx/ocaml/typing/msupport.mli new file mode 100644 index 0000000..43d0493 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/msupport.mli @@ -0,0 +1,76 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +(** Raise an error that can be caught: normal flow is resumed if a + [catch_errors] handler was installed. *) +val raise_error: ?ignore_unify:bool -> exn -> unit + +(** Resume after error: like [raise_error], but if a handler was provided a + Resume exception is raised. This allows to specify a special case when an + error is caught. *) +exception Resume +val resume_raise: exn -> 'a + +(** Installing (and removing) error handlers. *) + +(** Any [raise_error] invoked inside catch_errors will be added to the list. *) +val catch_errors: Warnings.state -> exn list ref -> (unit -> 'a) -> 'a + +(** Temporary disable catching errors *) +val uncatch_errors: (unit -> 'a) -> 'a + +(** Returns a reference initially set to false that will be set to true when a + type error is raised. *) +val monitor_errors: unit -> bool ref + +(** Warnings can also be stored in the caught exception list, wrapped inside + this exception *) +exception Warning of Location.t * string + +(* Keep track of type variables generated by error recovery. *) + +val erroneous_type_register: Types.type_expr -> unit +val erroneous_type_check: Types.type_expr -> bool +val erroneous_expr_check: Typedtree.expression -> bool + +(** Turn saved types from Cmt_format into attributes *) +val flush_saved_types : unit -> Parsetree.attributes + +val incorrect_attribute: Parsetree.attribute + +(** Extend the given attributes with an incorrect attribute and the saved types + after turning them into attributes *) +val recovery_attributes : Parsetree.attributes -> Parsetree.attributes + +(** Retrieve saved types that were turned into attributes *) +val get_saved_types_from_attributes : Parsetree.attributes -> Cmt_format.binary_part list + +val with_saved_types : + ?warning_attribute:Parsetree.attributes -> + ?save_part:('a -> Cmt_format.binary_part) -> + (unit -> 'a) -> 'a diff --git a/ocamlmerlin_mlx/ocaml/typing/mtype.ml b/ocamlmerlin_mlx/ocaml/typing/mtype.ml new file mode 100644 index 0000000..312fec5 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/mtype.ml @@ -0,0 +1,569 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Operations on module types *) + +open Asttypes +open Path +open Types + +let rec scrape_lazy env mty = + let open Subst.Lazy in + match mty with + MtyL_ident p -> + begin try + scrape_lazy env (Env.find_modtype_expansion_lazy p env) + with Not_found -> + mty + end + | _ -> mty + +let scrape env mty = + match mty with + Mty_ident p -> + Subst.Lazy.force_modtype (scrape_lazy env (MtyL_ident p)) + | _ -> mty + +let freshen ~scope mty = + Subst.modtype (Rescope scope) Subst.identity mty + +let rec strengthen_lazy ~aliasable env mty p = + let open Subst.Lazy in + match scrape_lazy env mty with + MtyL_signature sg -> + MtyL_signature(strengthen_lazy_sig ~aliasable env sg p) + | MtyL_functor(Named (Some param, arg), res) + when !Clflags.applicative_functors -> + let env = + Env.add_module_lazy ~update_summary:false param Mp_present arg env + in + MtyL_functor(Named (Some param, arg), + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) + | MtyL_functor(Named (None, arg), res) + when !Clflags.applicative_functors -> + let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in + MtyL_functor(Named (Some param, arg), + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) + | mty -> + mty + +and strengthen_lazy_sig' ~aliasable env sg p = + let open Subst.Lazy in + match sg with + [] -> [] + | (SigL_value(_, _, _) as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | SigL_type(id, {type_kind=Type_abstract}, _, _) :: rem + when Btype.is_row_name (Ident.name id) -> + strengthen_lazy_sig' ~aliasable env rem p + | SigL_type(id, decl, rs, vis) :: rem -> + let newdecl = + match decl.type_manifest, decl.type_private, decl.type_kind with + Some _, Public, _ -> decl + | Some _, Private, (Type_record _ | Type_variant _) -> decl + | _ -> + let manif = + Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id), + decl.type_params, ref Mnil))) in + if decl.type_kind = Type_abstract then + { decl with type_private = Public; type_manifest = manif } + else + { decl with type_manifest = manif } + in + SigL_type(id, newdecl, rs, vis) :: + strengthen_lazy_sig' ~aliasable env rem p + | (SigL_typext _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | SigL_module(id, pres, md, rs, vis) :: rem -> + let str = + strengthen_lazy_decl ~aliasable env md (Pdot(p, Ident.name id)) + in + let env = + Env.add_module_declaration_lazy ~update_summary:false id pres md env in + SigL_module(id, pres, str, rs, vis) + :: strengthen_lazy_sig' ~aliasable env rem p + (* Need to add the module in case it defines manifest module types *) + | SigL_modtype(id, decl, vis) :: rem -> + let newdecl = + match decl.mtdl_type with + | Some _ when not aliasable -> + (* [not alisable] condition needed because of recursive modules. + See [Typemod.check_recmodule_inclusion]. *) + decl + | _ -> + {decl with mtdl_type = Some(MtyL_ident(Pdot(p,Ident.name id)))} + in + let env = Env.add_modtype_lazy ~update_summary:false id decl env in + SigL_modtype(id, newdecl, vis) :: + strengthen_lazy_sig' ~aliasable env rem p + (* Need to add the module type in case it is manifest *) + | (SigL_class _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | (SigL_class_type _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + +and strengthen_lazy_sig ~aliasable env sg p = + let sg = Subst.Lazy.force_signature_once sg in + let sg = strengthen_lazy_sig' ~aliasable env sg p in + Subst.Lazy.of_signature_items sg + +and strengthen_lazy_decl ~aliasable env md p = + let open Subst.Lazy in + match md.mdl_type with + | MtyL_alias _ -> md + | _ when aliasable -> {md with mdl_type = MtyL_alias p} + | mty -> {md with mdl_type = strengthen_lazy ~aliasable env mty p} + +let () = Env.strengthen := strengthen_lazy + +let strengthen ~aliasable env mty p = + let mty = strengthen_lazy ~aliasable env (Subst.Lazy.of_modtype mty) p in + Subst.Lazy.force_modtype mty + +let strengthen_decl ~aliasable env md p = + let md = strengthen_lazy_decl ~aliasable env + (Subst.Lazy.of_module_decl md) p in + Subst.Lazy.force_module_decl md + +let rec make_aliases_absent pres mty = + match mty with + | Mty_alias _ -> Mp_absent, mty + | Mty_signature sg -> + pres, Mty_signature(make_aliases_absent_sig sg) + | Mty_functor(arg, res) -> + let _, res = make_aliases_absent Mp_present res in + pres, Mty_functor(arg, res) + | mty -> + pres, mty + +and make_aliases_absent_sig sg = + match sg with + [] -> [] + | Sig_module(id, pres, md, rs, priv) :: rem -> + let pres, md_type = make_aliases_absent pres md.md_type in + let md = { md with md_type } in + Sig_module(id, pres, md, rs, priv) :: make_aliases_absent_sig rem + | sigelt :: rem -> + sigelt :: make_aliases_absent_sig rem + +let scrape_for_type_of env pres mty = + let rec loop env path mty = + match mty, path with + | Mty_alias path, _ -> begin + try + let md = Env.find_module path env in + loop env (Some path) md.md_type + with Not_found -> mty + end + | mty, Some path -> + strengthen ~aliasable:false env mty path + | _ -> mty + in + make_aliases_absent pres (loop env None mty) + +(* In nondep_supertype, env is only used for the type it assigns to id. + Hence there is no need to keep env up-to-date by adding the bindings + traversed. *) + +type variance = Co | Contra | Strict + +let rec nondep_mty_with_presence env va ids pres mty = + match mty with + Mty_ident p -> + begin match Path.find_free_opt ids p with + | Some id -> + let expansion = + try Env.find_modtype_expansion p env + with Not_found -> + raise (Ctype.Nondep_cannot_erase id) + in + nondep_mty_with_presence env va ids pres expansion + | None -> pres, mty + end + | Mty_alias p -> + begin match Path.find_free_opt ids p with + | Some id -> + let expansion = + try Env.find_module p env + with Not_found -> + raise (Ctype.Nondep_cannot_erase id) + in + nondep_mty_with_presence env va ids Mp_present expansion.md_type + | None -> pres, mty + end + | Mty_signature sg -> + let mty = Mty_signature(nondep_sig env va ids sg) in + pres, mty + | Mty_functor(Unit, res) -> + pres, Mty_functor(Unit, nondep_mty env va ids res) + | Mty_functor(Named (param, arg), res) -> + let var_inv = + match va with Co -> Contra | Contra -> Co | Strict -> Strict in + let res_env = + match param with + | None -> env + | Some param -> Env.add_module ~arg:true param Mp_present arg env + in + let mty = + Mty_functor(Named (param, nondep_mty env var_inv ids arg), + nondep_mty res_env va ids res) + in + pres, mty + | Mty_for_hole -> pres, Mty_for_hole + +and nondep_mty env va ids mty = + snd (nondep_mty_with_presence env va ids Mp_present mty) + +and nondep_sig_item env va ids = function + | Sig_value(id, d, vis) -> + Sig_value(id, + {d with val_type = Ctype.nondep_type env ids d.val_type}, + vis) + | Sig_type(id, d, rs, vis) -> + Sig_type(id, Ctype.nondep_type_decl env ids (va = Co) d, rs, vis) + | Sig_typext(id, ext, es, vis) -> + Sig_typext(id, Ctype.nondep_extension_constructor env ids ext, es, vis) + | Sig_module(id, pres, md, rs, vis) -> + let pres, mty = nondep_mty_with_presence env va ids pres md.md_type in + Sig_module(id, pres, {md with md_type = mty}, rs, vis) + | Sig_modtype(id, d, vis) -> + begin try + Sig_modtype(id, nondep_modtype_decl env ids d, vis) + with Ctype.Nondep_cannot_erase _ as exn -> + match va with + Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none; + mtd_attributes=[]; mtd_uid = d.mtd_uid}, vis) + | _ -> raise exn + end + | Sig_class(id, d, rs, vis) -> + Sig_class(id, Ctype.nondep_class_declaration env ids d, rs, vis) + | Sig_class_type(id, d, rs, vis) -> + Sig_class_type(id, Ctype.nondep_cltype_declaration env ids d, rs, vis) + +and nondep_sig env va ids sg = + let scope = Ctype.create_scope () in + let sg, env = Env.enter_signature ~scope sg env in + List.map (nondep_sig_item env va ids) sg + +and nondep_modtype_decl env ids mtd = + {mtd with mtd_type = Option.map (nondep_mty env Strict ids) mtd.mtd_type} + +let nondep_supertype env ids = nondep_mty env Co ids +let nondep_sig_item env ids = nondep_sig_item env Co ids + +let enrich_typedecl env p id decl = + match decl.type_manifest with + Some _ -> decl + | None -> + match Env.find_type p env with + | exception Not_found -> decl + (* Type which was not present in the signature, so we don't have + anything to do. *) + | orig_decl -> + if decl.type_arity <> orig_decl.type_arity then + decl + else begin + let orig_ty = + Ctype.reify_univars env + (Btype.newgenty(Tconstr(p, orig_decl.type_params, ref Mnil))) + in + let new_ty = + Ctype.reify_univars env + (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil))) + in + let env = Env.add_type ~check:false id decl env in + match Ctype.mcomp env orig_ty new_ty with + | exception Ctype.Incompatible -> decl + (* The current declaration is not compatible with the one we got + from the signature. We should just fail now, but then, we could + also have failed if the arities of the two decls were + different, which we didn't. *) + | () -> + let orig_ty = + Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)) + in + {decl with type_manifest = Some orig_ty} + end + +let rec enrich_modtype env p mty = + match mty with + Mty_signature sg -> + Mty_signature(List.map (enrich_item env p) sg) + | _ -> + mty + +and enrich_item env p = function + Sig_type(id, decl, rs, priv) -> + Sig_type(id, + enrich_typedecl env (Pdot(p, Ident.name id)) id decl, rs, priv) + | Sig_module(id, pres, md, rs, priv) -> + Sig_module(id, pres, + {md with + md_type = enrich_modtype env + (Pdot(p, Ident.name id)) md.md_type}, + rs, + priv) + | item -> item + +let rec type_paths env p mty = + match scrape env mty with + Mty_ident _ -> [] + | Mty_alias _ -> [] + | Mty_signature sg -> type_paths_sig env p sg + | Mty_functor _ -> [] + | Mty_for_hole -> [] + +and type_paths_sig env p sg = + match sg with + [] -> [] + | Sig_type(id, _decl, _, _) :: rem -> + Pdot(p, Ident.name id) :: type_paths_sig env p rem + | Sig_module(id, pres, md, _, _) :: rem -> + type_paths env (Pdot(p, Ident.name id)) md.md_type @ + type_paths_sig (Env.add_module_declaration ~check:false id pres md env) + p rem + | Sig_modtype(id, decl, _) :: rem -> + type_paths_sig (Env.add_modtype id decl env) p rem + | (Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type _) :: rem -> + type_paths_sig env p rem + + +let rec no_code_needed_mod env pres mty = + match pres with + | Mp_absent -> true + | Mp_present -> begin + match scrape env mty with + Mty_ident _ -> false + | Mty_signature sg -> no_code_needed_sig env sg + | Mty_functor _ -> false + | Mty_alias _ -> false + | Mty_for_hole -> true + end + +and no_code_needed_sig env sg = + match sg with + [] -> true + | Sig_value(_id, decl, _) :: rem -> + begin match decl.val_kind with + | Val_prim _ -> no_code_needed_sig env rem + | _ -> false + end + | Sig_module(id, pres, md, _, _) :: rem -> + no_code_needed_mod env pres md.md_type && + no_code_needed_sig + (Env.add_module_declaration ~check:false id pres md env) rem + | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> + no_code_needed_sig env rem + | (Sig_typext _ | Sig_class _) :: _ -> + false + +let no_code_needed env mty = no_code_needed_mod env Mp_present mty + +(* Check whether a module type may return types *) + +let rec contains_type env = function + Mty_ident path -> + begin try match (Env.find_modtype path env).mtd_type with + | None -> raise Exit (* PR#6427 *) + | Some mty -> contains_type env mty + with Not_found -> raise Exit + end + | Mty_signature sg -> + contains_type_sig env sg + | Mty_functor (_, body) -> + contains_type env body + | Mty_alias _ + | Mty_for_hole -> + () + +and contains_type_sig env = List.iter (contains_type_item env) + +and contains_type_item env = function + Sig_type (_,({type_manifest = None} | + {type_kind = Type_abstract; type_private = Private}),_, _) + | Sig_modtype _ + | Sig_typext (_, {ext_args = Cstr_record _}, _, _) -> + (* We consider that extension constructors with an inlined + record create a type (the inlined record), even though + it would be technically safe to ignore that considering + the current constraints which guarantee that this type + is kept local to expressions. *) + raise Exit + | Sig_module (_, _, {md_type = mty}, _, _) -> + contains_type env mty + | Sig_value _ + | Sig_type _ + | Sig_typext _ + | Sig_class _ + | Sig_class_type _ -> + () + +let contains_type env mty = + try contains_type env mty; false with Exit -> true + + +(* Remove module aliases from a signature *) + +let rec get_prefixes = function + | Pident _ -> Path.Set.empty + | Pdot (p, _) | Papply (p, _) | Pextra_ty (p, _) + -> Path.Set.add p (get_prefixes p) + +let rec get_arg_paths = function + | Pident _ -> Path.Set.empty + | Pdot (p, _) | Pextra_ty (p, _) -> get_arg_paths p + | Papply (p1, p2) -> + Path.Set.add p2 + (Path.Set.union (get_prefixes p2) + (Path.Set.union (get_arg_paths p1) (get_arg_paths p2))) + +let rec rollback_path subst p = + try Pident (Path.Map.find p subst) + with Not_found -> + match p with + Pident _ | Papply _ -> p + | Pdot (p1, s) -> + let p1' = rollback_path subst p1 in + if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s)) + | Pextra_ty (p1, extra) -> + let p1' = rollback_path subst p1 in + if Path.same p1 p1' then p + else rollback_path subst (Pextra_ty (p1', extra)) + +let rec collect_ids subst bindings p = + begin match rollback_path subst p with + Pident id -> + let ids = + try collect_ids subst bindings (Ident.find_same id bindings) + with Not_found -> Ident.Set.empty + in + Ident.Set.add id ids + | _ -> Ident.Set.empty + end + +let collect_arg_paths mty = + let open Btype in + let paths = ref Path.Set.empty + and subst = ref Path.Map.empty + and bindings = ref Ident.empty in + (* let rt = Ident.create "Root" in + and prefix = ref (Path.Pident rt) in *) + let it_path p = paths := Path.Set.union (get_arg_paths p) !paths + and it_signature_item it si = + type_iterators.it_signature_item it si; + match si with + | Sig_module (id, _, {md_type=Mty_alias p}, _, _) -> + bindings := Ident.add id p !bindings + | Sig_module (id, _, {md_type=Mty_signature sg}, _, _) -> + List.iter + (function Sig_module (id', _, _, _, _) -> + subst := + Path.Map.add (Pdot (Pident id, Ident.name id')) id' !subst + | _ -> ()) + sg + | _ -> () + in + let it = {type_iterators with it_path; it_signature_item} in + it.it_module_type it mty; + it.it_module_type unmark_iterators mty; + Path.Set.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p)) + !paths Ident.Set.empty + +type remove_alias_args = + { mutable modified: bool; + exclude: Ident.t -> Path.t -> bool; + scrape: Env.t -> module_type -> module_type } + +let rec remove_aliases_mty env args pres mty = + let args' = {args with modified = false} in + let res = + match args.scrape env mty with + Mty_signature sg -> + Mp_present, Mty_signature (remove_aliases_sig env args' sg) + | Mty_alias _ -> + let mty' = Env.scrape_alias env mty in + if mty' = mty then begin + pres, mty + end else begin + args'.modified <- true; + remove_aliases_mty env args' Mp_present mty' + end + | mty -> + Mp_present, mty + in + if args'.modified then begin + args.modified <- true; + res + end else begin + pres, mty + end + +and remove_aliases_sig env args sg = + match sg with + [] -> [] + | Sig_module(id, pres, md, rs, priv) :: rem -> + let pres, mty = + match md.md_type with + Mty_alias p when args.exclude id p -> + pres, md.md_type + | mty -> + remove_aliases_mty env args pres mty + in + Sig_module(id, pres, {md with md_type = mty} , rs, priv) :: + remove_aliases_sig (Env.add_module id pres mty env) args rem + | Sig_modtype(id, mtd, priv) :: rem -> + Sig_modtype(id, mtd, priv) :: + remove_aliases_sig (Env.add_modtype id mtd env) args rem + | it :: rem -> + it :: remove_aliases_sig env args rem + +let scrape_for_functor_arg env mty = + let exclude _id p = + try ignore (Env.find_module p env); true with Not_found -> false + in + let _, mty = + remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty + in + mty + +let scrape_for_type_of ~remove_aliases env mty = + if remove_aliases then begin + let excl = collect_arg_paths mty in + let exclude id _p = Ident.Set.mem id excl in + let scrape _ mty = mty in + let _, mty = + remove_aliases_mty env {modified=false; exclude; scrape} Mp_present mty + in + mty + end else begin + let _, mty = scrape_for_type_of env Mp_present mty in + mty + end + +(* Lower non-generalizable type variables *) + +let lower_nongen nglev mty = + let open Btype in + let it_type_expr it ty = + match get_desc ty with + Tvar _ -> + let level = get_level ty in + if level < generic_level && level > nglev then set_level ty nglev + | _ -> + type_iterators.it_type_expr it ty + in + let it = {type_iterators with it_type_expr} in + it.it_module_type it mty; + it.it_module_type unmark_iterators mty diff --git a/ocamlmerlin_mlx/ocaml/typing/mtype.mli b/ocamlmerlin_mlx/ocaml/typing/mtype.mli new file mode 100644 index 0000000..68d290b --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/mtype.mli @@ -0,0 +1,55 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Operations on module types *) + +open Types + +val scrape: Env.t -> module_type -> module_type + (* Expand toplevel module type abbreviations + till hitting a "hard" module type (signature, functor, + or abstract module type ident. *) +val scrape_for_functor_arg: Env.t -> module_type -> module_type + (* Remove aliases in a functor argument type *) +val scrape_for_type_of: + remove_aliases:bool -> Env.t -> module_type -> module_type + (* Process type for module type of *) +val freshen: scope:int -> module_type -> module_type + (* Return an alpha-equivalent copy of the given module type + where bound identifiers are fresh. *) +val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type + (* Strengthen abstract type components relative to the + given path. *) +val strengthen_decl: + aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration +val nondep_supertype: Env.t -> Ident.t list -> module_type -> module_type + (* Return the smallest supertype of the given type + in which none of the given idents appears. + @raise [Ctype.Nondep_cannot_erase] if no such type exists. *) +val nondep_sig_item: Env.t -> Ident.t list -> signature_item -> signature_item + (* Returns the signature item with its type updated + to be the smallest supertype of its initial type + in which none of the given idents appears. + @raise [Ctype.Nondep_cannot_erase] if no such type exists. *) +val no_code_needed: Env.t -> module_type -> bool +val no_code_needed_sig: Env.t -> signature -> bool + (* Determine whether a module needs no implementation code, + i.e. consists only of type definitions. *) +val enrich_modtype: Env.t -> Path.t -> module_type -> module_type +val enrich_typedecl: Env.t -> Path.t -> Ident.t -> type_declaration -> + type_declaration +val type_paths: Env.t -> Path.t -> module_type -> Path.t list +val contains_type: Env.t -> module_type -> bool +val lower_nongen: int -> module_type -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/natural.ml b/ocamlmerlin_mlx/ocaml/typing/natural.ml new file mode 100644 index 0000000..c79be05 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/natural.ml @@ -0,0 +1,270 @@ + +module type Array = sig + + type index + + type 'a t + + val empty : 'a t + + val singleton : 'a -> 'a t + + val extend : 'a t -> index -> (index -> 'a) -> 'a t + + val retract : 'a t -> index -> 'a t + + val contains : 'a t -> index -> bool + + val last : 'a t -> index option + + val set : 'a t -> index -> 'a -> unit + + val get : 'a t -> index -> 'a + +end + +module type S_no_zero = sig + + type t + + val one : t + + val maximum : t + + val succ : t -> t + + val pred : t -> t option + + val compare : t -> t -> int + + val equal : t -> t -> bool + + val less_than : t -> t -> bool + + val less_than_or_equal : t -> t -> bool + + val max : t -> t -> t + + val plus : t -> t -> t + + val pp : Format.formatter -> t -> unit + + module Map : Map.S with type key = t + + module Set : Set.S with type elt = t + + module Tbl : Hashtbl.S with type key = t + + module Array : Array with type index = t + +end + +module type S = sig + + include S_no_zero + + val zero : t + +end + +module IntOps = struct + + type t = int + + let compare (x : t) (y : t) = + compare x y + + let equal (x : t) (y : t) = + x = y + + let less_than (x : t) (y : t) = + x < y + + let less_than_or_equal (x : t) (y : t) = + x <= y + + let max (x : t) (y : t) = + if x >= y then x + else y + + let hash = Hashtbl.hash + + let pp ppf x = Format.pp_print_int ppf x + +end + +module IntMap = Map.Make(IntOps) + +module IntSet = Set.Make(IntOps) + +module IntTbl = Hashtbl.Make(IntOps) + +module Array_zero_indexed = struct + + type index = int + + type 'a t = 'a array + + let empty = [| |] + + let singleton x = [| x |] + + let extend t idx init = + let len = idx + 1 in + let old_len = Array.length t in + if old_len > idx then + failwith "Natural.Array.extend: array already contains index"; + if old_len = 0 then begin + Array.init len init + end else begin + let extended = Array.make len (t.(0)) in + Array.blit t 0 extended 0 old_len; + for i = old_len to idx do + Array.unsafe_set extended i (init i) + done; + extended + end + + let retract t idx = + let old_len = Array.length t in + if old_len <= idx then + failwith "Natural.Array.retract: array already doesn't contain index"; + Array.sub t 0 idx + + let contains t idx = + let len = Array.length t in + idx < len + + let last t = + let len = Array.length t in + if len = 0 then None + else Some (len - 1) + + let set t idx data = + t.(idx) <- data + + let get t idx = + t.(idx) + +end + +module Array_one_indexed = struct + + type index = int + + type 'a t = 'a array + + let empty = [| |] + + let singleton x = [| x |] + + let extend t idx init = + let old_len = Array.length t in + if old_len >= idx then + failwith "Natural.Array.extend: array already contains index"; + if old_len = 0 then begin + let initial = init 1 in + let res = Array.make idx initial in + for i = 1 to (idx - 1) do + Array.unsafe_set res i (init (i + 1)) + done; + res + end else begin + let extended = Array.make idx (t.(0)) in + Array.blit t 0 extended 0 old_len; + for i = old_len to (idx - 1) do + Array.unsafe_set extended i (init (i + 1)) + done; + extended + end + + let retract t idx = + let old_len = Array.length t in + if old_len < idx then + failwith "Natural.Array.retract: array already doesn't contain index"; + Array.sub t 0 (idx - 1) + + let contains t idx = + let len = Array.length t in + idx <= len + + let last t = + let len = Array.length t in + if len = 0 then None + else Some len + + let set t idx data = + t.(idx - 1) <- data + + let get t idx = + t.(idx - 1) + +end + +module Nat = struct + + include IntOps + + let zero = 0 + + let one = 1 + + let maximum = max_int + + let succ t = + if t = maximum then t + else t + 1 + + let pred t = + if t = 0 then None + else Some (t - 1) + + let plus t1 t2 = + let res = t1 + t2 in + if res < 0 then maximum + else res + + module Map = IntMap + + module Set = IntSet + + module Tbl = IntTbl + + module Array = Array_zero_indexed + +end + +module Nat_no_zero = struct + + include IntOps + + let one = 1 + + let maximum = max_int + + let succ t = + if t = maximum then t + else t + 1 + + let pred t = + if t = 1 then None + else Some (t - 1) + + let plus t1 t2 = + let res = t1 + t2 in + if res < 0 then maximum + else res + + module Map = IntMap + + module Set = IntSet + + module Tbl = IntTbl + + module Array = Array_one_indexed + +end + +module Make () = Nat + +module Make_no_zero () = Nat_no_zero diff --git a/ocamlmerlin_mlx/ocaml/typing/natural.mli b/ocamlmerlin_mlx/ocaml/typing/natural.mli new file mode 100644 index 0000000..7ae1b08 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/natural.mli @@ -0,0 +1,83 @@ +(** Support for creating fresh types isomorphic to the natural numbers *) + +(** Module type for arrays indexed by a type [index] *) +module type Array = sig + + type index + + type 'a t + + val empty : 'a t + + val singleton : 'a -> 'a t + + val extend : 'a t -> index -> (index -> 'a) -> 'a t + + val retract : 'a t -> index -> 'a t + + val contains : 'a t -> index -> bool + + val last : 'a t -> index option + + val set : 'a t -> index -> 'a -> unit + + val get : 'a t -> index -> 'a + +end + +(** Module type for types isomorphic to the natural numbers + without zero (up to [maximum]) *) +module type S_no_zero = sig + + type t + + val one : t + + val maximum : t + + val succ : t -> t + + val pred : t -> t option + + val compare : t -> t -> int + + val equal : t -> t -> bool + + val less_than : t -> t -> bool + + val less_than_or_equal : t -> t -> bool + + val max : t -> t -> t + + val plus : t -> t -> t + + val pp : Format.formatter -> t -> unit + + module Map : Map.S with type key = t + + module Set : Set.S with type elt = t + + module Tbl : Hashtbl.S with type key = t + + module Array : Array with type index = t + +end + + +(** Module type for types isomorphic to the natural numbers + (up to [maximum]) *) +module type S = sig + + include S_no_zero + + val zero : t + +end + +(** Functor to create fresh types isomorphic to the natural numbers *) +module Make () : S + +(** Functor to create fresh types isomorphic to the natural numbers + without zero *) +module Make_no_zero () : S_no_zero + diff --git a/ocamlmerlin_mlx/ocaml/typing/oprint.ml b/ocamlmerlin_mlx/ocaml/typing/oprint.ml new file mode 100644 index 0000000..8512426 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/oprint.ml @@ -0,0 +1,847 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Format +open Outcometree + +exception Ellipsis + +let cautious f ppf arg = + try f ppf arg with + Ellipsis -> fprintf ppf "..." + +let print_lident ppf = function + | "::" -> pp_print_string ppf "(::)" + | s -> pp_print_string ppf s + +let rec print_ident ppf = + function + Oide_ident s -> print_lident ppf s.printed_name + | Oide_dot (id, s) -> + print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s + | Oide_apply (id1, id2) -> + fprintf ppf "%a(%a)" print_ident id1 print_ident id2 + +let out_ident = ref print_ident + +(* Check a character matches the [identchar_latin1] class from the lexer *) +let is_ident_char c = + match c with + | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246' + | '\248'..'\255' | '\'' | '0'..'9' -> true + | _ -> false + +let all_ident_chars s = + let rec loop s len i = + if i < len then begin + if is_ident_char s.[i] then loop s len (i+1) + else false + end else begin + true + end + in + let len = String.length s in + loop s len 0 + +let parenthesized_ident name = + (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) + || not (all_ident_chars name) + +let value_ident ppf name = + if parenthesized_ident name then + fprintf ppf "( %s )" name + else + pp_print_string ppf name + +(* Values *) + +let valid_float_lexeme s = + let l = String.length s in + let rec loop i = + if i >= l then s ^ "." else + match s.[i] with + | '0' .. '9' | '-' -> loop (i+1) + | _ -> s + in loop 0 + +let float_repres f = + match classify_float f with + FP_nan -> "nan" + | FP_infinite -> + if f < 0.0 then "neg_infinity" else "infinity" + | _ -> + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = float_of_string s1 then s1 else + let s2 = Printf.sprintf "%.15g" f in + if f = float_of_string s2 then s2 else + Printf.sprintf "%.18g" f + in valid_float_lexeme float_val + +let parenthesize_if_neg ppf fmt v isneg = + if isneg then pp_print_char ppf '('; + fprintf ppf fmt v; + if isneg then pp_print_char ppf ')' + +let escape_string s = + (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\' + and '"' *) + let n = ref 0 in + for i = 0 to String.length s - 1 do + n := !n + + (match String.unsafe_get s i with + | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 + | '\x00' .. '\x1F' + | '\x7F' -> 4 + | _ -> 1) + done; + if !n = String.length s then s else begin + let s' = Bytes.create !n in + n := 0; + for i = 0 to String.length s - 1 do + begin match String.unsafe_get s i with + | ('\"' | '\\') as c -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c + | '\n' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n' + | '\t' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't' + | '\r' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r' + | '\b' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b' + | '\x00' .. '\x1F' | '\x7F' as c -> + let a = Char.code c in + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + a / 100)); + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10)); + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10)); + | c -> Bytes.unsafe_set s' !n c + end; + incr n + done; + Bytes.to_string s' + end + + +let print_out_string ppf s = + let not_escaped = + (* let the user dynamically choose if strings should be escaped: *) + match Sys.getenv_opt "OCAMLTOP_UTF_8" with + | None -> true + | Some x -> + match bool_of_string_opt x with + | None -> true + | Some f -> f in + if not_escaped then + fprintf ppf "\"%s\"" (escape_string s) + else + fprintf ppf "%S" s + +let print_out_value ppf tree = + let rec print_tree_1 ppf = + function + | Oval_constr (name, [param]) -> + fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param + | Oval_constr (name, (_ :: _ as params)) -> + fprintf ppf "@[<1>%a@ (%a)@]" print_ident name + (print_tree_list print_tree_1 ",") params + | Oval_variant (name, Some param) -> + fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param + | tree -> print_simple_tree ppf tree + and print_constr_param ppf = function + | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0) + | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l) + | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L) + | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n) + | Oval_float f -> + parenthesize_if_neg ppf "%s" (float_repres f) + (f < 0.0 || 1. /. f = neg_infinity) + | Oval_string (_,_, Ostr_bytes) as tree -> + pp_print_char ppf '('; + print_simple_tree ppf tree; + pp_print_char ppf ')'; + | tree -> print_simple_tree ppf tree + and print_simple_tree ppf = + function + Oval_int i -> fprintf ppf "%i" i + | Oval_int32 i -> fprintf ppf "%lil" i + | Oval_int64 i -> fprintf ppf "%LiL" i + | Oval_nativeint i -> fprintf ppf "%nin" i + | Oval_float f -> pp_print_string ppf (float_repres f) + | Oval_char c -> fprintf ppf "%C" c + | Oval_string (s, maxlen, kind) -> + begin try + let len = String.length s in + let maxlen = max maxlen 8 in (* always show a little prefix *) + let s = if len > maxlen then String.sub s 0 maxlen else s in + begin match kind with + | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s + | Ostr_string -> print_out_string ppf s + end; + (if len > maxlen then + fprintf ppf + "... (* string length %d; truncated *)" len + ) + with + Invalid_argument _ (* "String.create" *)-> fprintf ppf "" + end + | Oval_list tl -> + fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl + | Oval_array tl -> + fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl + | Oval_constr (name, []) -> print_ident ppf name + | Oval_variant (name, None) -> fprintf ppf "`%s" name + | Oval_stuff s -> pp_print_string ppf s + | Oval_record fel -> + fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel + | Oval_ellipsis -> raise Ellipsis + | Oval_printer f -> f ppf + | Oval_tuple tree_list -> + fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list + | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree + and print_fields first ppf = + function + [] -> () + | (name, tree) :: fields -> + if not first then fprintf ppf ";@ "; + fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1) + tree; + print_fields false ppf fields + and print_tree_list print_item sep ppf tree_list = + let rec print_list first ppf = + function + [] -> () + | tree :: tree_list -> + if not first then fprintf ppf "%s@ " sep; + print_item ppf tree; + print_list false ppf tree_list + in + cautious (print_list true) ppf tree_list + in + cautious print_tree_1 ppf tree + +let out_value = ref print_out_value + +(* Types *) + +let rec print_list_init pr sep ppf = + function + [] -> () + | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l + +let rec print_list pr sep ppf = + function + [] -> () + | [a] -> pr ppf a + | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l + +let pr_present = + print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") + +let pr_var = Pprintast.tyvar +let ty_var ~non_gen ppf s = + pr_var ppf (if non_gen then "_" ^ s else s) + +let pr_vars = + print_list pr_var (fun ppf -> fprintf ppf "@ ") + +let rec print_out_type ppf = + function + | Otyp_alias {non_gen; aliased; alias } -> + fprintf ppf "@[%a@ as %a@]" + print_out_type aliased + (ty_var ~non_gen) alias + | Otyp_poly (sl, ty) -> + fprintf ppf "@[%a.@ %a@]" + pr_vars sl + print_out_type ty + | ty -> + print_out_type_1 ppf ty + +and print_out_type_1 ppf = + function + Otyp_arrow (lab, ty1, ty2) -> + pp_open_box ppf 0; + if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':'); + print_out_type_2 ppf ty1; + pp_print_string ppf " ->"; + pp_print_space ppf (); + print_out_type_1 ppf ty2; + pp_close_box ppf () + | ty -> print_out_type_2 ppf ty +and print_out_type_2 ppf = + function + Otyp_tuple tyl -> + fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl + | ty -> print_simple_out_type ppf ty +and print_simple_out_type ppf = + function + Otyp_class (id, tyl) -> + fprintf ppf "@[%a#%a@]" print_typargs tyl print_ident id + | Otyp_constr (id, tyl) -> + pp_open_box ppf 0; + print_typargs ppf tyl; + print_ident ppf id; + pp_close_box ppf () + | Otyp_object {fields; open_row} -> + fprintf ppf "@[<2>< %a >@]" (print_fields open_row) fields + | Otyp_stuff s -> pp_print_string ppf s + | Otyp_var (non_gen, s) -> ty_var ~non_gen ppf s + | Otyp_variant (row_fields, closed, tags) -> + let print_present ppf = + function + None | Some [] -> () + | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l + in + let print_fields ppf = + function + Ovar_fields fields -> + print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") + ppf fields + | Ovar_typ typ -> + print_simple_out_type ppf typ + in + fprintf ppf "@[[%s@[@[%a@]%a@]@ ]@]" + (if closed then if tags = None then " " else "< " + else if tags = None then "> " else "? ") + print_fields row_fields + print_present tags + | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty -> + pp_open_box ppf 1; + pp_print_char ppf '('; + print_out_type ppf ty; + pp_print_char ppf ')'; + pp_close_box ppf () + | Otyp_abstract | Otyp_open + | Otyp_sum _ | Otyp_manifest (_, _) -> () + | Otyp_record lbls -> print_record_decl ppf lbls + | Otyp_module (p, fl) -> + fprintf ppf "@[<1>(module %a" print_ident p; + let first = ref true in + List.iter + (fun (s, t) -> + let sep = if !first then (first := false; "with") else "and" in + fprintf ppf " %s type %s = %a" sep s print_out_type t + ) + fl; + fprintf ppf ")@]" + | Otyp_attribute (t, attr) -> + fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name +and print_record_decl ppf lbls = + fprintf ppf "{%a@;<1 -2>}" + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls +and print_fields open_row ppf = + function + [] -> + if open_row then fprintf ppf ".."; + | [s, t] -> + fprintf ppf "%s : %a" s print_out_type t; + if open_row then fprintf ppf ";@ "; + print_fields open_row ppf [] + | (s, t) :: l -> + fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields open_row) l +and print_row_field ppf (l, opt_amp, tyl) = + let pr_of ppf = + if opt_amp then fprintf ppf " of@ &@ " + else if tyl <> [] then fprintf ppf " of@ " + else fprintf ppf "" + in + fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") + tyl +and print_typlist print_elem sep ppf = + function + [] -> () + | [ty] -> print_elem ppf ty + | ty :: tyl -> + print_elem ppf ty; + pp_print_string ppf sep; + pp_print_space ppf (); + print_typlist print_elem sep ppf tyl +and print_typargs ppf = + function + [] -> () + | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf () + | tyl -> + pp_open_box ppf 1; + pp_print_char ppf '('; + print_typlist print_out_type "," ppf tyl; + pp_print_char ppf ')'; + pp_close_box ppf (); + pp_print_space ppf () +and print_out_label ppf (name, mut, arg) = + fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name + print_out_type arg + +let out_label = ref print_out_label + +let out_type = ref print_out_type + +let out_type_args = ref print_typargs + +(* Class types *) + +let print_type_parameter ppf s = + if s = "_" then fprintf ppf "_" else pr_var ppf s + +let type_parameter ppf (ty, (var, inj)) = + let open Asttypes in + fprintf ppf "%s%s%a" + (match var with Covariant -> "+" | Contravariant -> "-" | NoVariance -> "") + (match inj with Injective -> "!" | NoInjectivity -> "") + print_type_parameter ty + +let print_out_class_params ppf = + function + [] -> () + | tyl -> + fprintf ppf "@[<1>[%a]@]@ " + (print_list type_parameter (fun ppf -> fprintf ppf ", ")) + tyl + +let rec print_out_class_type ppf = + function + Octy_constr (id, tyl) -> + let pr_tyl ppf = + function + [] -> () + | tyl -> + fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl + in + fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id + | Octy_arrow (lab, ty, cty) -> + fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") + print_out_type_2 ty print_out_class_type cty + | Octy_signature (self_ty, csil) -> + let pr_param ppf = + function + Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty + | None -> () + in + fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty + (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) + csil +and print_out_class_sig_item ppf = + function + Ocsg_constraint (ty1, ty2) -> + fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1 + !out_type ty2 + | Ocsg_method (name, priv, virt, ty) -> + fprintf ppf "@[<2>method %s%s%s :@ %a@]" + (if priv then "private " else "") (if virt then "virtual " else "") + name !out_type ty + | Ocsg_value (name, mut, vr, ty) -> + fprintf ppf "@[<2>val %s%s%s :@ %a@]" + (if mut then "mutable " else "") + (if vr then "virtual " else "") + name !out_type ty + +let out_class_type = ref print_out_class_type + +(* Signature *) + +let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type") +let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item") +let out_signature = ref (fun _ -> failwith "Oprint.out_signature") +let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension") +let out_functor_parameters = + ref (fun _ -> failwith "Oprint.out_functor_parameters") + +(* For anonymous functor arguments, the logic to choose between + the long-form + functor (_ : S) -> ... + and the short-form + S -> ... + is as follows: if we are already printing long-form functor arguments, + we use the long form unless all remaining functor arguments can use + the short form. (Otherwise use the short form.) + + For example, + functor (X : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end + will get printed as + functor (X : S1) (_ : S2) (Y : S3) -> S4 -> S5 -> sig end + + but + functor (_ : S1) (_ : S2) (Y : S3) (_ : S4) (_ : S5) -> sig end + gets printed as + S1 -> S2 -> functor (Y : S3) -> S4 -> S5 -> sig end +*) + +(* take a module type that may be a functor type, + and return the longest prefix list of arguments + that should be printed in long form. *) + +let rec collect_functor_args acc = function + | Omty_functor (param, mty_res) -> + collect_functor_args (param :: acc) mty_res + | non_functor -> (acc, non_functor) +let collect_functor_args mty = + let l, rest = collect_functor_args [] mty in + List.rev l, rest + +let constructor_of_extension_constructor + (ext : out_extension_constructor) : out_constructor += + { + ocstr_name = ext.oext_name; + ocstr_args = ext.oext_args; + ocstr_return_type = ext.oext_ret_type; + } + +let split_anon_functor_arguments params = + let rec uncollect_anonymous_suffix acc rest = match acc with + | Some (None, mty_arg) :: acc -> + uncollect_anonymous_suffix acc + (Some (None, mty_arg) :: rest) + | _ :: _ | [] -> + (acc, rest) + in + let (acc, rest) = uncollect_anonymous_suffix (List.rev params) [] in + (List.rev acc, rest) + +let rec print_out_module_type ppf mty = + print_out_functor ppf mty + +and print_out_functor_parameters ppf l = + let print_nonanon_arg ppf = function + | None -> + fprintf ppf "()" + | Some (param, mty) -> + fprintf ppf "(%s : %a)" + (Option.value param ~default:"_") + print_out_module_type mty + in + let rec print_args ppf = function + | [] -> () + | Some (None, mty_arg) :: l -> + fprintf ppf "%a ->@ %a" + print_simple_out_module_type mty_arg + print_args l + | _ :: _ as non_anonymous_functor -> + let args, anons = split_anon_functor_arguments non_anonymous_functor in + fprintf ppf "@[<2>functor@ %a@]@ ->@ %a" + (pp_print_list ~pp_sep:pp_print_space print_nonanon_arg) args + print_args anons + in + print_args ppf l + +and print_out_functor ppf t = + let params, non_functor = collect_functor_args t in + fprintf ppf "@[<2>%a%a@]" + print_out_functor_parameters params + print_simple_out_module_type non_functor +and print_simple_out_module_type ppf = + function + Omty_abstract -> () + | Omty_ident id -> fprintf ppf "%a" print_ident id + | Omty_signature sg -> + begin match sg with + | [] -> fprintf ppf "sig end" + | sg -> + fprintf ppf "@[sig@ %a@;<1 -2>end@]" print_out_signature sg + end + | Omty_alias id -> fprintf ppf "(module %a)" print_ident id + | Omty_functor _ as non_simple -> + fprintf ppf "(%a)" print_out_module_type non_simple + | Omty_hole -> fprintf ppf "_" +and print_out_signature ppf = + function + [] -> () + | [item] -> !out_sig_item ppf item + | Osig_typext(ext, Oext_first) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + Osig_typext(ext, Oext_next) :: items -> + gather_extensions + (constructor_of_extension_constructor ext :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [constructor_of_extension_constructor ext] + items + in + let te = + { otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private } + in + fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items + | item :: items -> + fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items +and print_out_sig_item ppf = + function + Osig_class (vir_flag, name, params, clt, rs) -> + fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" + (if rs = Orec_next then "and" else "class") + (if vir_flag then " virtual" else "") print_out_class_params params + name !out_class_type clt + | Osig_class_type (vir_flag, name, params, clt, rs) -> + fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" + (if rs = Orec_next then "and" else "class type") + (if vir_flag then " virtual" else "") print_out_class_params params + name !out_class_type clt + | Osig_typext (ext, Oext_exception) -> + fprintf ppf "@[<2>exception %a@]" + print_out_constr (constructor_of_extension_constructor ext) + | Osig_typext (ext, _es) -> + print_out_extension_constructor ppf ext + | Osig_modtype (name, Omty_abstract) -> + fprintf ppf "@[<2>module type %s@]" name + | Osig_modtype (name, mty) -> + fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty + | Osig_module (name, Omty_alias id, _) -> + fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id + | Osig_module (name, mty, rs) -> + fprintf ppf "@[<2>%s %s :@ %a@]" + (match rs with Orec_not -> "module" + | Orec_first -> "module rec" + | Orec_next -> "and") + name !out_module_type mty + | Osig_type(td, rs) -> + print_out_type_decl + (match rs with + | Orec_not -> "type nonrec" + | Orec_first -> "type" + | Orec_next -> "and") + ppf td + | Osig_value vd -> + let kwd = if vd.oval_prims = [] then "val" else "external" in + let pr_prims ppf = + function + [] -> () + | s :: sl -> + fprintf ppf "@ = \"%s\"" s; + List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl + in + fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name + !out_type vd.oval_type pr_prims vd.oval_prims + (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name)) + vd.oval_attributes + | Osig_ellipsis -> + fprintf ppf "..." + +and print_out_type_decl kwd ppf td = + let print_constraints ppf = + List.iter + (fun (ty1, ty2) -> + fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1 + !out_type ty2) + td.otype_cstrs + in + let type_defined ppf = + match td.otype_params with + [] -> pp_print_string ppf td.otype_name + | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) + td.otype_params + td.otype_name + in + let print_manifest ppf = + function + Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty + | _ -> () + in + let print_name_params ppf = + fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type + in + let ty = + match td.otype_type with + Otyp_manifest (_, ty) -> ty + | _ -> td.otype_type + in + let print_private ppf = function + Asttypes.Private -> fprintf ppf " private" + | Asttypes.Public -> () + in + let print_immediate ppf = + match td.otype_immediate with + | Unknown -> () + | Always -> fprintf ppf " [%@%@immediate]" + | Always_on_64bits -> fprintf ppf " [%@%@immediate64]" + in + let print_unboxed ppf = + if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else () + in + let print_out_tkind ppf = function + | Otyp_abstract -> () + | Otyp_record lbls -> + fprintf ppf " =%a %a" + print_private td.otype_private + print_record_decl lbls + | Otyp_sum constrs -> + let variants fmt constrs = + if constrs = [] then fprintf fmt "|" else + fprintf fmt "%a" (print_list print_out_constr + (fun ppf -> fprintf ppf "@ | ")) constrs in + fprintf ppf " =%a@;<1 2>%a" + print_private td.otype_private variants constrs + | Otyp_open -> + fprintf ppf " =%a .." + print_private td.otype_private + | ty -> + fprintf ppf " =%a@;<1 2>%a" + print_private td.otype_private + !out_type ty + in + fprintf ppf "@[<2>@[%t%a@]%t%t%t@]" + print_name_params + print_out_tkind ty + print_constraints + print_immediate + print_unboxed + +and print_out_constr ppf constr = + let { + ocstr_name = name; + ocstr_args = tyl; + ocstr_return_type = return_type; + } = constr in + let name = + match name with + | "::" -> "(::)" (* #7200 *) + | s -> s + in + match return_type with + | None -> + begin match tyl with + | [] -> + pp_print_string ppf name + | _ -> + fprintf ppf "@[<2>%s of@ %a@]" name + (print_typlist print_simple_out_type " *") tyl + end + | Some ret_type -> + begin match tyl with + | [] -> + fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type + | _ -> + fprintf ppf "@[<2>%s :@ %a -> %a@]" name + (print_typlist print_simple_out_type " *") + tyl print_simple_out_type ret_type + end + +and print_out_extension_constructor ppf ext = + let print_extended_type ppf = + match ext.oext_type_params with + [] -> fprintf ppf "%s" ext.oext_type_name + | [ty_param] -> + fprintf ppf "@[%a@ %s@]" + print_type_parameter + ty_param + ext.oext_type_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + ext.oext_type_params + ext.oext_type_name + in + fprintf ppf "@[type %t +=%s@;<1 2>%a@]" + print_extended_type + (if ext.oext_private = Asttypes.Private then " private" else "") + print_out_constr + (constructor_of_extension_constructor ext) + +and print_out_type_extension ppf te = + let print_extended_type ppf = + match te.otyext_params with + [] -> fprintf ppf "%s" te.otyext_name + | [param] -> + fprintf ppf "@[%a@ %s@]" + print_type_parameter param + te.otyext_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + te.otyext_params + te.otyext_name + in + fprintf ppf "@[type %t +=%s@;<1 2>%a@]" + print_extended_type + (if te.otyext_private = Asttypes.Private then " private" else "") + (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) + te.otyext_constructors + +let out_constr = ref print_out_constr +let _ = out_module_type := print_out_module_type +let _ = out_signature := print_out_signature +let _ = out_sig_item := print_out_sig_item +let _ = out_type_extension := print_out_type_extension +let _ = out_functor_parameters := print_out_functor_parameters + +(* Phrases *) + +let print_out_exception ppf exn outv = + match exn with + Sys.Break -> fprintf ppf "Interrupted.@." + | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." + | Stack_overflow -> + fprintf ppf "Stack overflow during evaluation (looping recursion?).@." + | _ -> match Printexc.use_printers exn with + | None -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv + | Some s -> fprintf ppf "@[Exception:@ %s@]@." s + +let rec print_items ppf = + function + [] -> () + | (Osig_typext(ext, Oext_first), None) :: items -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + (Osig_typext(ext, Oext_next), None) :: items -> + gather_extensions + (constructor_of_extension_constructor ext :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [constructor_of_extension_constructor ext] + items + in + let te = + { otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private } + in + fprintf ppf "@[%a@]" !out_type_extension te; + if items <> [] then fprintf ppf "@ %a" print_items items + | (tree, valopt) :: items -> + begin match valopt with + Some v -> + fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree + !out_value v + | None -> fprintf ppf "@[%a@]" !out_sig_item tree + end; + if items <> [] then fprintf ppf "@ %a" print_items items + +let print_out_phrase ppf = + function + Ophr_eval (outv, ty) -> + fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv + | Ophr_signature [] -> () + | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items + | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv + +let out_phrase = ref print_out_phrase diff --git a/ocamlmerlin_mlx/ocaml/typing/oprint.mli b/ocamlmerlin_mlx/ocaml/typing/oprint.mli new file mode 100644 index 0000000..31dad9a --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/oprint.mli @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Format +open Outcometree + +val out_ident : (formatter -> out_ident -> unit) ref +val out_value : (formatter -> out_value -> unit) ref +val out_label : (formatter -> string * bool * out_type -> unit) ref +val out_type : (formatter -> out_type -> unit) ref +val out_type_args : (formatter -> out_type list -> unit) ref +val out_constr : (formatter -> out_constructor -> unit) ref +val out_class_type : (formatter -> out_class_type -> unit) ref +val out_module_type : (formatter -> out_module_type -> unit) ref +val out_sig_item : (formatter -> out_sig_item -> unit) ref +val out_signature : (formatter -> out_sig_item list -> unit) ref +val out_functor_parameters : + (formatter -> + (string option * Outcometree.out_module_type) option list -> unit) + ref +val out_type_extension : (formatter -> out_type_extension -> unit) ref +val out_phrase : (formatter -> out_phrase -> unit) ref + +val parenthesized_ident : string -> bool diff --git a/ocamlmerlin_mlx/ocaml/typing/outcometree.mli b/ocamlmerlin_mlx/ocaml/typing/outcometree.mli new file mode 100644 index 0000000..8c32954 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/outcometree.mli @@ -0,0 +1,156 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Module [Outcometree]: results displayed by the toplevel *) + +(* These types represent messages that the toplevel displays as normal + results or errors. The real displaying is customisable using the hooks: + [Toploop.print_out_value] + [Toploop.print_out_type] + [Toploop.print_out_sig_item] + [Toploop.print_out_phrase] *) + +(** An [out_name] is a string representation of an identifier which can be + rewritten on the fly to avoid name collisions *) +type out_name = { mutable printed_name: string } + +type out_ident = + | Oide_apply of out_ident * out_ident + | Oide_dot of out_ident * string + | Oide_ident of out_name + +type out_string = + | Ostr_string + | Ostr_bytes + +type out_attribute = + { oattr_name: string } + +type out_value = + | Oval_array of out_value list + | Oval_char of char + | Oval_constr of out_ident * out_value list + | Oval_ellipsis + | Oval_float of float + | Oval_int of int + | Oval_int32 of int32 + | Oval_int64 of int64 + | Oval_nativeint of nativeint + | Oval_list of out_value list + | Oval_printer of (Format.formatter -> unit) + | Oval_record of (out_ident * out_value) list + | Oval_string of string * int * out_string (* string, size-to-print, kind *) + | Oval_stuff of string + | Oval_tuple of out_value list + | Oval_variant of string * out_value option + +type out_type_param = string * (Asttypes.variance * Asttypes.injectivity) + +type out_type = + | Otyp_abstract + | Otyp_open + | Otyp_alias of {non_gen:bool; aliased:out_type; alias:string} + | Otyp_arrow of string * out_type * out_type + | Otyp_class of out_ident * out_type list + | Otyp_constr of out_ident * out_type list + | Otyp_manifest of out_type * out_type + | Otyp_object of { fields: (string * out_type) list; open_row:bool} + | Otyp_record of (string * bool * out_type) list + | Otyp_stuff of string + | Otyp_sum of out_constructor list + | Otyp_tuple of out_type list + | Otyp_var of bool * string + | Otyp_variant of out_variant * bool * (string list) option + | Otyp_poly of string list * out_type + | Otyp_module of out_ident * (string * out_type) list + | Otyp_attribute of out_type * out_attribute + +and out_constructor = { + ocstr_name: string; + ocstr_args: out_type list; + ocstr_return_type: out_type option; +} + +and out_variant = + | Ovar_fields of (string * bool * out_type list) list + | Ovar_typ of out_type + +type out_class_type = + | Octy_constr of out_ident * out_type list + | Octy_arrow of string * out_type * out_class_type + | Octy_signature of out_type option * out_class_sig_item list +and out_class_sig_item = + | Ocsg_constraint of out_type * out_type + | Ocsg_method of string * bool * bool * out_type + | Ocsg_value of string * bool * bool * out_type + +type out_module_type = + | Omty_abstract + | Omty_functor of (string option * out_module_type) option * out_module_type + | Omty_ident of out_ident + | Omty_signature of out_sig_item list + | Omty_alias of out_ident + | Omty_hole +and out_sig_item = + | Osig_class of + bool * string * out_type_param list * out_class_type * + out_rec_status + | Osig_class_type of + bool * string * out_type_param list * out_class_type * + out_rec_status + | Osig_typext of out_extension_constructor * out_ext_status + | Osig_modtype of string * out_module_type + | Osig_module of string * out_module_type * out_rec_status + | Osig_type of out_type_decl * out_rec_status + | Osig_value of out_val_decl + | Osig_ellipsis +and out_type_decl = + { otype_name: string; + otype_params: out_type_param list; + otype_type: out_type; + otype_private: Asttypes.private_flag; + otype_immediate: Type_immediacy.t; + otype_unboxed: bool; + otype_cstrs: (out_type * out_type) list } +and out_extension_constructor = + { oext_name: string; + oext_type_name: string; + oext_type_params: string list; + oext_args: out_type list; + oext_ret_type: out_type option; + oext_private: Asttypes.private_flag } +and out_type_extension = + { otyext_name: string; + otyext_params: string list; + otyext_constructors: out_constructor list; + otyext_private: Asttypes.private_flag } +and out_val_decl = + { oval_name: string; + oval_type: out_type; + oval_prims: string list; + oval_attributes: out_attribute list } +and out_rec_status = + | Orec_not + | Orec_first + | Orec_next +and out_ext_status = + | Oext_first + | Oext_next + | Oext_exception + +type out_phrase = + | Ophr_eval of out_value * out_type + | Ophr_signature of (out_sig_item * out_value option) list + | Ophr_exception of (exn * out_value) diff --git a/ocamlmerlin_mlx/ocaml/typing/parmatch.ml b/ocamlmerlin_mlx/ocaml/typing/parmatch.ml new file mode 100644 index 0000000..2a388f1 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/parmatch.ml @@ -0,0 +1,2393 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Detection of partial matches and unused match cases. *) + +open Misc +open Asttypes +open Types +open Typedtree + + +(*************************************) +(* Utilities for building patterns *) +(*************************************) + +let make_pat desc ty tenv = + {pat_desc = desc; pat_loc = Location.none; pat_extra = []; + pat_type = ty ; pat_env = tenv; + pat_attributes = []; + } + +let omega = Patterns.omega +let omegas = Patterns.omegas +let omega_list = Patterns.omega_list + +let extra_pat = + make_pat + (Tpat_var (Ident.create_local "+", mknoloc "+")) + Ctype.none Env.empty + + +(*******************) +(* Coherence check *) +(*******************) + +(* For some of the operations we do in this module, we would like (because it + simplifies matters) to assume that patterns appearing on a given column in a + pattern matrix are /coherent/ (think "of the same type"). + Unfortunately that is not always true. + + Consider the following (well-typed) example: + {[ + type _ t = S : string t | U : unit t + + let f (type a) (t1 : a t) (t2 : a t) (a : a) = + match t1, t2, a with + | U, _, () -> () + | _, S, "" -> () + ]} + + Clearly the 3rd column contains incoherent patterns. + + On the example above, most of the algorithms will explore the pattern matrix + as illustrated by the following tree: + + {v + S + -------> | "" | + U | S, "" | __/ | () | + --------> | _, () | \ not S + | U, _, () | __/ -------> | () | + | _, S, "" | \ + ---------> | S, "" | ----------> | "" | + not U S + v} + + where following an edge labelled by a pattern P means "assuming the value I + am matching on is filtered by [P] on the column I am currently looking at, + then the following submatrix is still reachable". + + Notice that at any point of that tree, if the first column of a matrix is + incoherent, then the branch leading to it can only be taken if the scrutinee + is ill-typed. + In the example above the only case where we have a matrix with an incoherent + first column is when we consider [t1, t2, a] to be [U, S, ...]. However such + a value would be ill-typed, so we can never actually get there. + + Checking the first column at each step of the recursion and making the + conscious decision of "aborting" the algorithm whenever the first column + becomes incoherent, allows us to retain the initial assumption in later + stages of the algorithms. + + --- + + N.B. two patterns can be considered coherent even though they might not be of + the same type. + + That's in part because we only care about the "head" of patterns and leave + checking coherence of subpatterns for the next steps of the algorithm: + ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples + of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1). + + But also because it can be hard/costly to determine exactly whether two + patterns are of the same type or not (eg. in the example above with _ and S, + but see also the module [Coherence_illustration] in + testsuite/tests/basic-more/robustmatch.ml). + + For the moment our weak, loosely-syntactic, coherence check seems to be + enough and we leave it to each user to consider (and document!) what happens + when an "incoherence" is not detected by this check. +*) + +(* Given the first column of a simplified matrix, this function first looks for + a "discriminating" pattern on that column (i.e. a non-omega one) and then + check that every other head pattern in the column is coherent with that one. +*) +let all_coherent column = + let open Patterns.Head in + let coherent_heads hp1 hp2 = + match hp1.pat_desc, hp2.pat_desc with + | Construct c, Construct c' -> + c.cstr_consts = c'.cstr_consts + && c.cstr_nonconsts = c'.cstr_nonconsts + | Constant c1, Constant c2 -> begin + match c1, c2 with + | Const_char _, Const_char _ + | Const_int _, Const_int _ + | Const_int32 _, Const_int32 _ + | Const_int64 _, Const_int64 _ + | Const_nativeint _, Const_nativeint _ + | Const_float _, Const_float _ + | Const_string _, Const_string _ -> true + | ( Const_char _ + | Const_int _ + | Const_int32 _ + | Const_int64 _ + | Const_nativeint _ + | Const_float _ + | Const_string _), _ -> false + end + | Tuple l1, Tuple l2 -> l1 = l2 + | Record (lbl1 :: _), Record (lbl2 :: _) -> + Array.length lbl1.lbl_all = Array.length lbl2.lbl_all + | Any, _ + | _, Any + | Record [], Record [] + | Variant _, Variant _ + | Array _, Array _ + | Lazy, Lazy -> true + | _, _ -> false + in + match + List.find + (function + | { pat_desc = Any } -> false + | _ -> true) + column + with + | exception Not_found -> + (* only omegas on the column: the column is coherent. *) + true + | discr_pat -> + List.for_all (coherent_heads discr_pat) column + +let first_column simplified_matrix = + List.map (fun ((head, _args), _rest) -> head) simplified_matrix + +(***********************) +(* Compatibility check *) +(***********************) + +(* Patterns p and q compatible means: + there exists value V that matches both, However.... + + The case of extension types is dubious, as constructor rebind permits + that different constructors are the same (and are thus compatible). + + Compilation must take this into account, consider: + + type t = .. + type t += A|B + type t += C=A + + let f x y = match x,y with + | true,A -> '1' + | _,C -> '2' + | false,A -> '3' + | _,_ -> '_' + + As C is bound to A the value of f false A is '2' (and not '3' as it would + be in the absence of rebinding). + + Not considering rebinding, patterns "false,A" and "_,C" are incompatible + and the compiler can swap the second and third clause, resulting in the + (more efficiently compiled) matching + + match x,y with + | true,A -> '1' + | false,A -> '3' + | _,C -> '2' + | _,_ -> '_' + + This is not correct: when C is bound to A, "f false A" returns '2' (not '3') + + + However, diagnostics do not take constructor rebinding into account. + Notice, that due to module abstraction constructor rebinding is hidden. + + module X : sig type t = .. type t += A|B end = struct + type t = .. + type t += A + type t += B=A + end + + open X + + let f x = match x with + | A -> '1' + | B -> '2' + | _ -> '_' + + The second clause above will NOT (and cannot) be flagged as useless. + + Finally, there are two compatibility functions: + compat p q ---> 'syntactic compatibility, used for diagnostics. + may_compat p q ---> a safe approximation of possible compat, + for compilation + +*) + + +let is_absent tag row = row_field_repr (get_row_field tag !row) = Rabsent + +let is_absent_pat d = + match d.pat_desc with + | Patterns.Head.Variant { tag; cstr_row; _ } -> is_absent tag cstr_row + | _ -> false + +let const_compare x y = + match x,y with + | Const_float f1, Const_float f2 -> + Stdlib.compare (float_of_string f1) (float_of_string f2) + | Const_string (s1, _, _), Const_string (s2, _, _) -> + String.compare s1 s2 + | (Const_int _ + |Const_char _ + |Const_string (_, _, _) + |Const_float _ + |Const_int32 _ + |Const_int64 _ + |Const_nativeint _ + ), _ -> Stdlib.compare x y + +let records_args l1 l2 = + (* Invariant: fields are already sorted by Typecore.type_label_a_list *) + let rec combine r1 r2 l1 l2 = match l1,l2 with + | [],[] -> List.rev r1, List.rev r2 + | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 + | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] + | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 -> + if lbl1.lbl_pos < lbl2.lbl_pos then + combine (p1::r1) (omega::r2) rem1 l2 + else if lbl1.lbl_pos > lbl2.lbl_pos then + combine (omega::r1) (p2::r2) l1 rem2 + else (* same label on both sides *) + combine (p1::r1) (p2::r2) rem1 rem2 in + combine [] [] l1 l2 + + + +module Compat + (Constr:sig + val equal : + Types.constructor_description -> + Types.constructor_description -> + bool + end) = struct + + let rec compat p q = match p.pat_desc,q.pat_desc with +(* Variables match any value *) + | ((Tpat_any|Tpat_var _),_) + | (_,(Tpat_any|Tpat_var _)) -> true +(* Structural induction *) + | Tpat_alias (p,_,_),_ -> compat p q + | _,Tpat_alias (q,_,_) -> compat p q + | Tpat_or (p1,p2,_),_ -> + (compat p1 q || compat p2 q) + | _,Tpat_or (q1,q2,_) -> + (compat p q1 || compat p q2) +(* Constructors, with special case for extension *) + | Tpat_construct (_, c1, ps1, _), Tpat_construct (_, c2, ps2, _) -> + Constr.equal c1 c2 && compats ps1 ps2 +(* More standard stuff *) + | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) -> + l1=l2 && ocompat op1 op2 + | Tpat_constant c1, Tpat_constant c2 -> + const_compare c1 c2 = 0 + | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs + | Tpat_lazy p, Tpat_lazy q -> compat p q + | Tpat_record (l1,_),Tpat_record (l2,_) -> + let ps,qs = records_args l1 l2 in + compats ps qs + | Tpat_array ps, Tpat_array qs -> + List.length ps = List.length qs && + compats ps qs + | _,_ -> false + + and ocompat op oq = match op,oq with + | None,None -> true + | Some p,Some q -> compat p q + | (None,Some _)|(Some _,None) -> false + + and compats ps qs = match ps,qs with + | [], [] -> true + | p::ps, q::qs -> compat p q && compats ps qs + | _,_ -> false + +end + +module SyntacticCompat = + Compat + (struct + let equal c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag + end) + +let compat = SyntacticCompat.compat +and compats = SyntacticCompat.compats + +(* Due to (potential) rebinding, two extension constructors + of the same arity type may equal *) + +exception Empty (* Empty pattern *) + +(****************************************) +(* Utilities for retrieving type paths *) +(****************************************) + +(* May need a clean copy, cf. PR#4745 *) +let clean_copy ty = + if get_level ty = Btype.generic_level then ty + else Subst.type_expr Subst.identity ty + +let get_constructor_type_path ty tenv = + let ty = Ctype.expand_head tenv (clean_copy ty) in + match get_desc ty with + | Tconstr (path,_,_) -> path + | _ -> assert false + +(****************************) +(* Utilities for matching *) +(****************************) + +(* Check top matching *) +let simple_match d h = + let open Patterns.Head in + match d.pat_desc, h.pat_desc with + | Construct c1, Construct c2 -> + Types.equal_tag c1.cstr_tag c2.cstr_tag + | Variant { tag = t1; _ }, Variant { tag = t2 } -> + t1 = t2 + | Constant c1, Constant c2 -> const_compare c1 c2 = 0 + | Lazy, Lazy -> true + | Record _, Record _ -> true + | Tuple len1, Tuple len2 + | Array len1, Array len2 -> len1 = len2 + | _, Any -> true + | _, _ -> false + + + +(* extract record fields as a whole *) +let record_arg ph = + let open Patterns.Head in + match ph.pat_desc with + | Any -> [] + | Record args -> args + | _ -> fatal_error "Parmatch.as_record" + + +let extract_fields lbls arg = + let get_field pos arg = + match List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg with + | _, p -> p + | exception Not_found -> omega + in + List.map (fun lbl -> get_field lbl.lbl_pos arg) lbls + +(* Build argument list when p2 >= p1, where p1 is a simple pattern *) +let simple_match_args discr head args = + let open Patterns.Head in + match head.pat_desc with + | Constant _ -> [] + | Construct _ + | Variant _ + | Tuple _ + | Array _ + | Lazy -> args + | Record lbls -> extract_fields (record_arg discr) (List.combine lbls args) + | Any -> + begin match discr.pat_desc with + | Construct cstr -> Patterns.omegas cstr.cstr_arity + | Variant { has_arg = true } + | Lazy -> [Patterns.omega] + | Record lbls -> omega_list lbls + | Array len + | Tuple len -> Patterns.omegas len + | Variant { has_arg = false } + | Any + | Constant _ -> [] + end + +(* Consider a pattern matrix whose first column has been simplified to contain + only _ or a head constructor + | p1, r1... + | p2, r2... + | p3, r3... + | ... + + We build a normalized /discriminating/ pattern from a pattern [q] by folding + over the first column of the matrix, "refining" [q] as we go: + + - when we encounter a row starting with [Tuple] or [Lazy] then we + can stop and return that head, as we cannot refine any further. Indeed, + these constructors are alone in their signature, so they will subsume + whatever other head we might find, as well as the head we're threading + along. + + - when we find a [Record] then it is a bit more involved: it is also alone + in its signature, however it might only be matching a subset of the + record fields. We use these fields to refine our accumulator and keep going + as another row might match on different fields. + + - rows starting with a wildcard do not bring any information, so we ignore + them and keep going + + - if we encounter anything else (i.e. any other constructor), then we just + stop and return our accumulator. +*) +let discr_pat q pss = + let open Patterns.Head in + let rec refine_pat acc = function + | [] -> acc + | ((head, _), _) :: rows -> + match head.pat_desc with + | Any -> refine_pat acc rows + | Tuple _ | Lazy -> head + | Record lbls -> + (* N.B. we could make this case "simpler" by refining the record case + using [all_record_args]. + In which case we wouldn't need to fold over the first column for + records. + However it makes the witness we generate for the exhaustivity warning + less pretty. *) + let fields = + List.fold_right (fun lbl r -> + if List.exists (fun l -> l.lbl_pos = lbl.lbl_pos) r then + r + else + lbl :: r + ) lbls (record_arg acc) + in + let d = { head with pat_desc = Record fields } in + refine_pat d rows + | _ -> acc + in + let q, _ = deconstruct q in + match q.pat_desc with + (* short-circuiting: clearly if we have anything other than [Record] or + [Any] to start with, we're not going to be able refine at all. So + there's no point going over the matrix. *) + | Any | Record _ -> refine_pat q pss + | _ -> q + +(* + In case a matching value is found, set actual arguments + of the matching pattern. +*) + +let rec read_args xs r = match xs,r with +| [],_ -> [],r +| _::xs, arg::rest -> + let args,rest = read_args xs rest in + arg::args,rest +| _,_ -> + fatal_error "Parmatch.read_args" + +let do_set_args ~erase_mutable q r = match q with +| {pat_desc = Tpat_tuple omegas} -> + let args,rest = read_args omegas r in + make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest +| {pat_desc = Tpat_record (omegas,closed)} -> + let args,rest = read_args omegas r in + make_pat + (Tpat_record + (List.map2 (fun (lid, lbl,_) arg -> + if + erase_mutable && + (match lbl.lbl_mut with + | Mutable -> true | Immutable -> false) + then + lid, lbl, omega + else + lid, lbl, arg) + omegas args, closed)) + q.pat_type q.pat_env:: + rest +| {pat_desc = Tpat_construct (lid, c, omegas, _)} -> + let args,rest = read_args omegas r in + make_pat + (Tpat_construct (lid, c, args, None)) + q.pat_type q.pat_env:: + rest +| {pat_desc = Tpat_variant (l, omega, row)} -> + let arg, rest = + match omega, r with + Some _, a::r -> Some a, r + | None, r -> None, r + | _ -> assert false + in + make_pat + (Tpat_variant (l, arg, row)) q.pat_type q.pat_env:: + rest +| {pat_desc = Tpat_lazy _omega} -> + begin match r with + arg::rest -> + make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest + | _ -> fatal_error "Parmatch.do_set_args (lazy)" + end +| {pat_desc = Tpat_array omegas} -> + let args,rest = read_args omegas r in + make_pat + (Tpat_array args) q.pat_type q.pat_env:: + rest +| {pat_desc=Tpat_constant _|Tpat_any} -> + q::r (* case any is used in matching.ml *) +| _ -> fatal_error "Parmatch.set_args" + +let set_args q r = do_set_args ~erase_mutable:false q r +and set_args_erase_mutable q r = do_set_args ~erase_mutable:true q r + +(* Given a matrix of non-empty rows + p1 :: r1... + p2 :: r2... + p3 :: r3... + + Simplify the first column [p1 p2 p3] by splitting all or-patterns. + The result is a list of pairs + ((pattern head, arguments), rest of row) + + For example, + x :: r1 + (Some _) as y :: r2 + (None as x) as y :: r3 + (Some x | (None as x)) :: r4 + becomes + (( _ , [ ] ), r1) + (( Some, [_] ), r2) + (( None, [ ] ), r3) + (( Some, [x] ), r4) + (( None, [ ] ), r4) + *) +let simplify_head_pat ~add_column p ps k = + let rec simplify_head_pat p ps k = + match Patterns.General.(view p |> strip_vars).pat_desc with + | `Or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k) + | #Patterns.Simple.view as view -> + add_column (Patterns.Head.deconstruct { p with pat_desc = view }) ps k + in simplify_head_pat p ps k + +let rec simplify_first_col = function + | [] -> [] + | [] :: _ -> assert false (* the rows are non-empty! *) + | (p::ps) :: rows -> + let add_column p ps k = (p, ps) :: k in + simplify_head_pat ~add_column p ps (simplify_first_col rows) + + +(* Builds the specialized matrix of [pss] according to the discriminating + pattern head [d]. + See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf + + NOTES: + - we are polymorphic on the type of matrices we work on, in particular a row + might not simply be a [pattern list]. That's why we have the [extend_row] + parameter. +*) +let build_specialized_submatrix ~extend_row discr pss = + let rec filter_rec = function + | ((head, args), ps) :: pss -> + if simple_match discr head + then extend_row (simple_match_args discr head args) ps :: filter_rec pss + else filter_rec pss + | _ -> [] in + filter_rec pss + +(* The "default" and "specialized" matrices of a given matrix. + See section 3.1 of http://moscova.inria.fr/~maranget/papers/warn/warn.pdf . +*) +type 'matrix specialized_matrices = { + default : 'matrix; + constrs : (Patterns.Head.t * 'matrix) list; +} + +(* Consider a pattern matrix whose first column has been simplified + to contain only _ or a head constructor + | p1, r1... + | p2, r2... + | p3, r3... + | ... + + We split this matrix into a list of /specialized/ sub-matrices, one for + each head constructor appearing in the first column. For each row whose + first column starts with a head constructor, remove this head + column, prepend one column for each argument of the constructor, + and add the resulting row in the sub-matrix corresponding to this + head constructor. + + Rows whose left column is omega (the Any pattern _) may match any + head constructor, so they are added to all sub-matrices. + + In the case where all the rows in the matrix have an omega on their first + column, then there is only one /specialized/ sub-matrix, formed of all these + omega rows. + This matrix is also called the /default/ matrix. + + See the documentation of [build_specialized_submatrix] for an explanation of + the [extend_row] parameter. +*) +let build_specialized_submatrices ~extend_row discr rows = + let extend_group discr p args r rs = + let r = extend_row (simple_match_args discr p args) r in + (discr, r :: rs) + in + + (* insert a row of head [p] and rest [r] into the right group + + Note: with this implementation, the order of the groups + is the order of their first row in the source order. + This is a nice property to get exhaustivity counter-examples + in source order. + *) + let rec insert_constr head args r = function + | [] -> + (* if no group matched this row, it has a head constructor that + was never seen before; add a new sub-matrix for this head *) + [extend_group head head args r []] + | (q0,rs) as bd::env -> + if simple_match q0 head + then extend_group q0 head args r rs :: env + else bd :: insert_constr head args r env + in + + (* insert a row of head omega into all groups *) + let insert_omega r env = + List.map (fun (q0,rs) -> extend_group q0 Patterns.Head.omega [] r rs) env + in + + let rec form_groups constr_groups omega_tails = function + | [] -> (constr_groups, omega_tails) + | ((head, args), tail) :: rest -> + match head.pat_desc with + | Patterns.Head.Any -> + (* note that calling insert_omega here would be wrong + as some groups may not have been formed yet, if the + first row with this head pattern comes after in the list *) + form_groups constr_groups (tail :: omega_tails) rest + | _ -> + form_groups + (insert_constr head args tail constr_groups) omega_tails rest + in + + let constr_groups, omega_tails = + let initial_constr_group = + let open Patterns.Head in + match discr.pat_desc with + | Record _ | Tuple _ | Lazy -> + (* [discr] comes from [discr_pat], and in this case subsumes any of the + patterns we could find on the first column of [rows]. So it is better + to use it for our initial environment than any of the normalized + pattern we might obtain from the first column. *) + [discr,[]] + | _ -> [] + in + form_groups initial_constr_group [] rows + in + + (* groups are accumulated in reverse order; + we restore the order of rows in the source code *) + let default = List.rev omega_tails in + let constrs = + List.fold_right insert_omega omega_tails constr_groups + |> List.map (fun (discr, rs) -> (discr, List.rev rs)) + in + { default; constrs; } + +(* Variant related functions *) + +let set_last a = + let rec loop = function + | [] -> assert false + | [_] -> [Patterns.General.erase a] + | x::l -> x :: loop l + in + function + | (_, []) -> (Patterns.Head.deconstruct a, []) + | (first, row) -> (first, loop row) + +(* mark constructor lines for failure when they are incomplete *) +let mark_partial = + let zero = make_pat (`Constant (Const_int 0)) Ctype.none Env.empty in + List.map (fun ((hp, _), _ as ps) -> + match hp.pat_desc with + | Patterns.Head.Any -> ps + | _ -> set_last zero ps + ) + +let close_variant env row = + let Row {fields; more; name=orig_name; closed; fixed} = row_repr row in + let name, static = + List.fold_left + (fun (nm, static) (_tag,f) -> + match row_field_repr f with + | Reither(_, _, false) -> + (* fixed=false means that this tag is not explicitly matched *) + link_row_field_ext ~inside:f rf_absent; + (None, static) + | Reither (_, _, true) -> (nm, false) + | Rabsent | Rpresent _ -> (nm, static)) + (orig_name, true) fields in + if not closed || name != orig_name then begin + let more' = if static then Btype.newgenty Tnil else Btype.newgenvar () in + (* this unification cannot fail *) + Ctype.unify env more + (Btype.newgenty + (Tvariant + (create_row ~fields:[] ~more:more' + ~closed:true ~name ~fixed))) + end + +(* + Check whether the first column of env makes up a complete signature or + not. We work on the discriminating pattern heads of each sub-matrix: they + are not omega/Any. +*) +let full_match closing env = match env with +| [] -> false +| (discr, _) :: _ -> + let open Patterns.Head in + match discr.pat_desc with + | Any -> assert false + | Construct { cstr_tag = Cstr_extension _ ; _ } -> false + | Construct c -> List.length env = c.cstr_consts + c.cstr_nonconsts + | Variant { type_row; _ } -> + let fields = + List.map + (fun (d, _) -> + match d.pat_desc with + | Variant { tag } -> tag + | _ -> assert false) + env + in + let row = type_row () in + if closing && not (Btype.has_fixed_explanation row) then + (* closing=true, we are considering the variant as closed *) + List.for_all + (fun (tag,f) -> + match row_field_repr f with + Rabsent | Reither(_, _, false) -> true + | Reither (_, _, true) + (* m=true, do not discard matched tags, rather warn *) + | Rpresent _ -> List.mem tag fields) + (row_fields row) + else + row_closed row && + List.for_all + (fun (tag,f) -> + row_field_repr f = Rabsent || List.mem tag fields) + (row_fields row) + | Constant Const_char _ -> + List.length env = 256 + | Constant _ + | Array _ -> false + | Tuple _ + | Record _ + | Lazy -> true + +(* Written as a non-fragile matching, PR#7451 originated from a fragile matching + below. *) +let should_extend ext env = match ext with +| None -> false +| Some ext -> begin match env with + | [] -> assert false + | (p,_)::_ -> + let open Patterns.Head in + begin match p.pat_desc with + | Construct {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)} -> + let path = get_constructor_type_path p.pat_type p.pat_env in + Path.same path ext + | Construct {cstr_tag=(Cstr_extension _)} -> false + | Constant _ | Tuple _ | Variant _ | Record _ | Array _ | Lazy -> false + | Any -> assert false + end +end + +(* build a pattern from a constructor description *) +let pat_of_constr ex_pat cstr = + {ex_pat with pat_desc = + Tpat_construct (mknoloc (Longident.Lident cstr.cstr_name), + cstr, omegas cstr.cstr_arity, None)} + +let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env + +let rec orify_many = function +| [] -> assert false +| [x] -> x +| x :: xs -> orify x (orify_many xs) + +(* build an or-pattern from a constructor list *) +let pat_of_constrs ex_pat cstrs = + let ex_pat = Patterns.Head.to_omega_pattern ex_pat in + if cstrs = [] then raise Empty else + orify_many (List.map (pat_of_constr ex_pat) cstrs) + +let pats_of_type env ty = + match Ctype.extract_concrete_typedecl env ty with + | Typedecl (_, path, {type_kind = Type_variant _ | Type_record _}) -> + begin match Env.find_type_descrs path env with + | Type_variant (cstrs,_) when List.length cstrs <= 1 || + (* Only explode when all constructors are GADTs *) + List.for_all (fun cd -> cd.cstr_generalized) cstrs -> + List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs + | Type_record (labels, _) -> + let fields = + List.map (fun ld -> + mknoloc (Longident.Lident ld.lbl_name), ld, omega) + labels + in + [make_pat (Tpat_record (fields, Closed)) ty env] + | _ -> [omega] + end + | Has_no_typedecl -> + begin match get_desc (Ctype.expand_head env ty) with + Ttuple tl -> + [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] + | _ -> [omega] + end + | Typedecl (_, _, {type_kind = Type_abstract | Type_open}) + | May_have_typedecl -> [omega] + +let get_variant_constructors env ty = + match Ctype.extract_concrete_typedecl env ty with + | Typedecl (_, path, {type_kind = Type_variant _}) -> + begin match Env.find_type_descrs path env with + | Type_variant (cstrs,_) -> cstrs + | _ -> fatal_error "Parmatch.get_variant_constructors" + end + | _ -> fatal_error "Parmatch.get_variant_constructors" + +module ConstructorSet = Set.Make(struct + type t = constructor_description + let compare c1 c2 = String.compare c1.cstr_name c2.cstr_name +end) + +(* Sends back a pattern that complements the given constructors used_constrs *) +let complete_constrs constr used_constrs = + let c = constr.pat_desc in + let constrs = get_variant_constructors constr.pat_env c.cstr_res in + let used_constrs = ConstructorSet.of_list used_constrs in + let others = + List.filter + (fun cnstr -> not (ConstructorSet.mem cnstr used_constrs)) + constrs in + (* Split constructors to put constant ones first *) + let const, nonconst = + List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in + const @ nonconst + +let build_other_constrs env p = + let open Patterns.Head in + match p.pat_desc with + | Construct ({ cstr_tag = Cstr_extension _ }) -> extra_pat + | Construct + ({ cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed } as c) -> + let constr = { p with pat_desc = c } in + let get_constr q = + match q.pat_desc with + | Construct c -> c + | _ -> fatal_error "Parmatch.get_constr" in + let used_constrs = List.map (fun (p,_) -> get_constr p) env in + pat_of_constrs p (complete_constrs constr used_constrs) + | _ -> extra_pat + +(* Auxiliary for build_other *) + +let build_other_constant proj make first next p env = + let all = List.map (fun (p, _) -> proj p.pat_desc) env in + let rec try_const i = + if List.mem i all + then try_const (next i) + else make_pat (make i) p.pat_type p.pat_env + in try_const first + +(* + Builds a pattern that is incompatible with all patterns in + the first column of env +*) + +let some_private_tag = "" + +let build_other ext env = + match env with + | [] -> omega + | (d, _) :: _ -> + let open Patterns.Head in + match d.pat_desc with + | Construct { cstr_tag = Cstr_extension _ } -> + (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) + make_pat + (Tpat_var (Ident.create_local "*extension*", + {txt="*extension*"; loc = d.pat_loc})) + Ctype.none Env.empty + | Construct _ -> + begin match ext with + | Some ext -> + if Path.same ext (get_constructor_type_path d.pat_type d.pat_env) + then + extra_pat + else + build_other_constrs env d + | _ -> + build_other_constrs env d + end + | Variant { cstr_row; type_row } -> + let tags = + List.map + (fun (d, _) -> + match d.pat_desc with + | Variant { tag } -> tag + | _ -> assert false) + env + in + let make_other_pat tag const = + let arg = if const then None else Some Patterns.omega in + make_pat (Tpat_variant(tag, arg, cstr_row)) d.pat_type d.pat_env + in + let row = type_row () in + begin match + List.fold_left + (fun others (tag,f) -> + if List.mem tag tags then others else + match row_field_repr f with + Rabsent (* | Reither _ *) -> others + (* This one is called after erasing pattern info *) + | Reither (c, _, _) -> make_other_pat tag c :: others + | Rpresent arg -> make_other_pat tag (arg = None) :: others) + [] (row_fields row) + with + [] -> + let tag = + if Btype.has_fixed_explanation row then some_private_tag else + let rec mktag tag = + if List.mem tag tags then mktag (tag ^ "'") else tag in + mktag "AnyOtherTag" + in make_other_pat tag true + | pat::other_pats -> + List.fold_left + (fun p_res pat -> + make_pat (Tpat_or (pat, p_res, None)) d.pat_type d.pat_env) + pat other_pats + end + | Constant Const_char _ -> + let all_chars = + List.map + (fun (p,_) -> match p.pat_desc with + | Constant (Const_char c) -> c + | _ -> assert false) + env + in + let rec find_other i imax = + if i > imax then raise Not_found + else + let ci = Char.chr i in + if List.mem ci all_chars then + find_other (i+1) imax + else + make_pat (Tpat_constant (Const_char ci)) d.pat_type d.pat_env + in + let rec try_chars = function + | [] -> Patterns.omega + | (c1,c2) :: rest -> + try + find_other (Char.code c1) (Char.code c2) + with + | Not_found -> try_chars rest + in + try_chars + [ 'a', 'z' ; 'A', 'Z' ; '0', '9' ; + ' ', '~' ; Char.chr 0 , Char.chr 255] + | Constant Const_int _ -> + build_other_constant + (function Constant(Const_int i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_int i)) + 0 succ d env + | Constant Const_int32 _ -> + build_other_constant + (function Constant(Const_int32 i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_int32 i)) + 0l Int32.succ d env + | Constant Const_int64 _ -> + build_other_constant + (function Constant(Const_int64 i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_int64 i)) + 0L Int64.succ d env + | Constant Const_nativeint _ -> + build_other_constant + (function Constant(Const_nativeint i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_nativeint i)) + 0n Nativeint.succ d env + | Constant Const_string _ -> + build_other_constant + (function Constant(Const_string (s, _, _)) -> String.length s + | _ -> assert false) + (function i -> + Tpat_constant + (Const_string(String.make i '*',Location.none,None))) + 0 succ d env + | Constant Const_float _ -> + build_other_constant + (function Constant(Const_float f) -> float_of_string f + | _ -> assert false) + (function f -> Tpat_constant(Const_float (string_of_float f))) + 0.0 (fun f -> f +. 1.0) d env + | Array _ -> + let all_lengths = + List.map + (fun (p,_) -> match p.pat_desc with + | Array len -> len + | _ -> assert false) + env in + let rec try_arrays l = + if List.mem l all_lengths then try_arrays (l+1) + else + make_pat (Tpat_array (omegas l)) d.pat_type d.pat_env in + try_arrays 0 + | _ -> Patterns.omega + +let rec has_instance p = match p.pat_desc with + | Tpat_variant (l,_,r) when is_absent l r -> false + | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true + | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p + | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 + | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps -> + has_instances ps + | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps) + | Tpat_lazy p + -> has_instance p + +and has_instances = function + | [] -> true + | q::rem -> has_instance q && has_instances rem + +(* + Core function : + Is the last row of pattern matrix pss + qs satisfiable ? + That is : + Does there exists at least one value vector, es such that : + 1- for all ps in pss ps # es (ps and es are not compatible) + 2- qs <= es (es matches qs) + + --- + + In two places in the following function, we check the coherence of the first + column of (pss + qs). + If it is incoherent, then we exit early saying that (pss + qs) is not + satisfiable (which is equivalent to saying "oh, we shouldn't have considered + that branch, no good result came come from here"). + + But what happens if we have a coherent but ill-typed column? + - we might end up returning [false], which is equivalent to noticing the + incompatibility: clearly this is fine. + - if we end up returning [true] then we're saying that [qs] is useful while + it is not. This is sad but not the end of the world, we're just allowing dead + code to survive. +*) +let rec satisfiable pss qs = match pss with +| [] -> has_instances qs +| _ -> + match qs with + | [] -> false + | q::qs -> + match Patterns.General.(view q |> strip_vars).pat_desc with + | `Or(q1,q2,_) -> + satisfiable pss (q1::qs) || satisfiable pss (q2::qs) + | `Any -> + let pss = simplify_first_col pss in + if not (all_coherent (first_column pss)) then + false + else begin + let { default; constrs } = + let q0 = discr_pat Patterns.Simple.omega pss in + build_specialized_submatrices ~extend_row:(@) q0 pss in + if not (full_match false constrs) then + satisfiable default qs + else + List.exists + (fun (p,pss) -> + not (is_absent_pat p) && + satisfiable pss + (simple_match_args p Patterns.Head.omega [] @ qs)) + constrs + end + | `Variant (l,_,r) when is_absent l r -> false + | #Patterns.Simple.view as view -> + let q = { q with pat_desc = view } in + let pss = simplify_first_col pss in + let hq, qargs = Patterns.Head.deconstruct q in + if not (all_coherent (hq :: first_column pss)) then + false + else begin + let q0 = discr_pat q pss in + satisfiable (build_specialized_submatrix ~extend_row:(@) q0 pss) + (simple_match_args q0 hq qargs @ qs) + end + +(* While [satisfiable] only checks whether the last row of [pss + qs] is + satisfiable, this function returns the (possibly empty) list of vectors [es] + which verify: + 1- for all ps in pss, ps # es (ps and es are not compatible) + 2- qs <= es (es matches qs) + + This is done to enable GADT handling + + For considerations regarding the coherence check, see the comment on + [satisfiable] above. *) +let rec list_satisfying_vectors pss qs = + match pss with + | [] -> if has_instances qs then [qs] else [] + | _ -> + match qs with + | [] -> [] + | q :: qs -> + match Patterns.General.(view q |> strip_vars).pat_desc with + | `Or(q1,q2,_) -> + list_satisfying_vectors pss (q1::qs) @ + list_satisfying_vectors pss (q2::qs) + | `Any -> + let pss = simplify_first_col pss in + if not (all_coherent (first_column pss)) then + [] + else begin + let q0 = discr_pat Patterns.Simple.omega pss in + let wild default_matrix p = + List.map (fun qs -> p::qs) + (list_satisfying_vectors default_matrix qs) + in + match build_specialized_submatrices ~extend_row:(@) q0 pss with + | { default; constrs = [] } -> + (* first column of pss is made of variables only *) + wild default omega + | { default; constrs = ((p,_)::_ as constrs) } -> + let for_constrs () = + List.flatten ( + List.map (fun (p,pss) -> + if is_absent_pat p then + [] + else + let witnesses = + list_satisfying_vectors pss + (simple_match_args p Patterns.Head.omega [] @ qs) + in + let p = Patterns.Head.to_omega_pattern p in + List.map (set_args p) witnesses + ) constrs + ) + in + if full_match false constrs then for_constrs () else + begin match p.pat_desc with + | Construct _ -> + (* activate this code + for checking non-gadt constructors *) + wild default (build_other_constrs constrs p) + @ for_constrs () + | _ -> + wild default Patterns.omega + end + end + | `Variant (l, _, r) when is_absent l r -> [] + | #Patterns.Simple.view as view -> + let q = { q with pat_desc = view } in + let hq, qargs = Patterns.Head.deconstruct q in + let pss = simplify_first_col pss in + if not (all_coherent (hq :: first_column pss)) then + [] + else begin + let q0 = discr_pat q pss in + List.map (set_args (Patterns.Head.to_omega_pattern q0)) + (list_satisfying_vectors + (build_specialized_submatrix ~extend_row:(@) q0 pss) + (simple_match_args q0 hq qargs @ qs)) + end + +(******************************************) +(* Look for a row that matches some value *) +(******************************************) + +(* + Useful for seeing if the example of + non-matched value can indeed be matched + (by a guarded clause) +*) + +let rec do_match pss qs = match qs with +| [] -> + begin match pss with + | []::_ -> true + | _ -> false + end +| q::qs -> match Patterns.General.(view q |> strip_vars).pat_desc with + | `Or (q1,q2,_) -> + do_match pss (q1::qs) || do_match pss (q2::qs) + | `Any -> + let rec remove_first_column = function + | (_::ps)::rem -> ps::remove_first_column rem + | _ -> [] + in + do_match (remove_first_column pss) qs + | #Patterns.Simple.view as view -> + let q = { q with pat_desc = view } in + let q0, qargs = Patterns.Head.deconstruct q in + let pss = simplify_first_col pss in + (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of + its first column. *) + do_match + (build_specialized_submatrix ~extend_row:(@) q0 pss) + (qargs @ qs) + +(* +let print_pat pat = + let rec string_of_pat pat = + match pat.pat_desc with + Tpat_var _ -> "v" + | Tpat_any -> "_" + | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?" (string_of_pat p) + | Tpat_constant n -> "0" + | Tpat_construct (_, lid, _) -> + Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt)) + | Tpat_lazy p -> + Printf.sprintf "(lazy %s)" (string_of_pat p) + | Tpat_or (p1,p2,_) -> + Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2) + | Tpat_tuple list -> + Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list)) + | Tpat_variant (_, _, _) -> "variant" + | Tpat_record (_, _) -> "record" + | Tpat_array _ -> "array" + in + Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat) +*) + +(* + Now another satisfiable function that additionally + supplies an example of a matching value. + + This function should be called for exhaustiveness check only. +*) +let rec exhaust (ext:Path.t option) pss n = match pss with +| [] -> Seq.return (omegas n) +| []::_ -> Seq.empty +| [(p :: ps)] -> exhaust_single_row ext p ps n +| pss -> specialize_and_exhaust ext pss n + +and exhaust_single_row ext p ps n = + (* Shortcut: in the single-row case p :: ps we know that all + counter-examples are either of the form + counter-example(p) :: omegas + or + p :: counter-examples(ps) + + This is very interesting in the case where p contains + or-patterns, as the non-shortcut path below would do a separate + search for each constructor of the or-pattern, which can lead to + an exponential blowup on examples such as + + | (A|B), (A|B), (A|B), (A|B) -> foo + + Note that this shortcut also applies to examples such as + + | A, A, A, A -> foo | (A|B), (A|B), (A|B), (A|B) -> bar + + thanks to the [get_mins] preprocessing step which will drop the + first row (subsumed by the second). Code with this shape does + occur naturally when people want to avoid fragile pattern + matches: if A and B are the only two constructors, this is the + best way to make a non-fragile distinction between "all As" and + "at least one B". + *) + List.to_seq [Some p; None] |> Seq.flat_map + (function + | Some p -> + let sub_witnesses = exhaust ext [ps] (n - 1) in + Seq.map (fun row -> p :: row) sub_witnesses + | None -> + (* note: calling [exhaust] recursively of p would + result in an infinite loop in the case n=1 *) + let p_witnesses = specialize_and_exhaust ext [[p]] 1 in + Seq.map (fun p_row -> p_row @ omegas (n - 1)) p_witnesses + ) + +and specialize_and_exhaust ext pss n = + let pss = simplify_first_col pss in + if not (all_coherent (first_column pss)) then + (* We're considering an ill-typed branch, we won't actually be able to + produce a well typed value taking that branch. *) + Seq.empty + else begin + (* Assuming the first column is ill-typed but considered coherent, we + might end up producing an ill-typed witness of non-exhaustivity + corresponding to the current branch. + + If [exhaust] has been called by [do_check_partial], then the witnesses + produced get typechecked and the ill-typed ones are discarded. + + If [exhaust] has been called by [do_check_fragile], then it is possible + we might fail to warn the user that the matching is fragile. See for + example testsuite/tests/warnings/w04_failure.ml. *) + let q0 = discr_pat Patterns.Simple.omega pss in + match build_specialized_submatrices ~extend_row:(@) q0 pss with + | { default; constrs = [] } -> + (* first column of pss is made of variables only *) + let sub_witnesses = exhaust ext default (n-1) in + let q0 = Patterns.Head.to_omega_pattern q0 in + Seq.map (fun row -> q0::row) sub_witnesses + | { default; constrs } -> + let try_non_omega (p,pss) = + if is_absent_pat p then + Seq.empty + else + let sub_witnesses = + exhaust + ext pss + (List.length (simple_match_args p Patterns.Head.omega []) + + n - 1) + in + let p = Patterns.Head.to_omega_pattern p in + Seq.map (set_args p) sub_witnesses + in + let try_omega () = + if full_match false constrs && not (should_extend ext constrs) then + Seq.empty + else + let sub_witnesses = exhaust ext default (n-1) in + match build_other ext constrs with + | exception Empty -> + (* cannot occur, since constructors don't make + a full signature *) + fatal_error "Parmatch.exhaust" + | p -> + Seq.map (fun tail -> p :: tail) sub_witnesses + in + (* Lazily compute witnesses for all constructor submatrices + (Some constr_mat) then the wildcard/default submatrix (None). + Note that the call to [try_omega ()] is delayed to after + all constructor matrices have been traversed. *) + List.map (fun constr_mat -> Some constr_mat) constrs @ [None] + |> List.to_seq + |> Seq.flat_map + (function + | Some constr_mat -> try_non_omega constr_mat + | None -> try_omega ()) + end + +let exhaust ext pss n = + exhaust ext pss n + |> Seq.map (function + | [x] -> x + | _ -> assert false) + +(* + Another exhaustiveness check, enforcing variant typing. + Note that it does not check exact exhaustiveness, but whether a + matching could be made exhaustive by closing all variant types. + When this is true of all other columns, the current column is left + open (even if it means that the whole matching is not exhaustive as + a result). + When this is false for the matrix minus the current column, and the + current column is composed of variant tags, we close the variant + (even if it doesn't help in making the matching exhaustive). +*) + +let rec pressure_variants tdefs = function + | [] -> false + | []::_ -> true + | pss -> + let pss = simplify_first_col pss in + if not (all_coherent (first_column pss)) then + true + else begin + let q0 = discr_pat Patterns.Simple.omega pss in + match build_specialized_submatrices ~extend_row:(@) q0 pss with + | { default; constrs = [] } -> pressure_variants tdefs default + | { default; constrs } -> + let rec try_non_omega = function + | (_p,pss) :: rem -> + let ok = pressure_variants tdefs pss in + (* The order below matters : we want [pressure_variants] to be + called on all the specialized submatrices because we might + close some variant in any of them regardless of whether [ok] + is true for [pss] or not *) + try_non_omega rem && ok + | [] -> true + in + if full_match (tdefs=None) constrs then + try_non_omega constrs + else if tdefs = None then + pressure_variants None default + else + let full = full_match true constrs in + let ok = + if full then + try_non_omega constrs + else begin + let { constrs = partial_constrs; _ } = + build_specialized_submatrices ~extend_row:(@) q0 + (mark_partial pss) + in + try_non_omega partial_constrs + end + in + begin match constrs, tdefs with + | [], _ + | _, None -> () + | (d, _) :: _, Some env -> + match d.pat_desc with + | Variant { type_row; _ } -> + let row = type_row () in + if Btype.has_fixed_explanation row + || pressure_variants None default then () + else close_variant env row + | _ -> () + end; + ok + end + + +(* Yet another satisfiable function *) + +(* + This time every_satisfiable pss qs checks the + utility of every expansion of qs. + Expansion means expansion of or-patterns inside qs +*) + +type answer = + | Used (* Useful pattern *) + | Unused (* Useless pattern *) + | Upartial of Typedtree.pattern list (* Mixed, with list of useless ones *) + + + +(* this row type enable column processing inside the matrix + - left -> elements not to be processed, + - right -> elements to be processed +*) +type usefulness_row = + {no_ors : pattern list ; ors : pattern list ; active : pattern list} + +(* +let pretty_row {ors=ors ; no_ors=no_ors; active=active} = + pretty_line ors ; prerr_string " *" ; + pretty_line no_ors ; prerr_string " *" ; + pretty_line active + +let pretty_rows rs = + prerr_endline "begin matrix" ; + List.iter + (fun r -> + pretty_row r ; + prerr_endline "") + rs ; + prerr_endline "end matrix" +*) + +(* Initial build *) +let make_row ps = {ors=[] ; no_ors=[]; active=ps} + +let make_rows pss = List.map make_row pss + + +(* Useful to detect and expand or pats inside as pats *) +let is_var p = match Patterns.General.(view p |> strip_vars).pat_desc with +| `Any -> true +| _ -> false + +let is_var_column rs = + List.for_all + (fun r -> match r.active with + | p::_ -> is_var p + | [] -> assert false) + rs + +(* Standard or-args for left-to-right matching *) +let rec or_args p = match p.pat_desc with +| Tpat_or (p1,p2,_) -> p1,p2 +| Tpat_alias (p,_,_) -> or_args p +| _ -> assert false + +(* Just remove current column *) +let remove r = match r.active with +| _::rem -> {r with active=rem} +| [] -> assert false + +let remove_column rs = List.map remove rs + +(* Current column has been processed *) +let push_no_or r = match r.active with +| p::rem -> { r with no_ors = p::r.no_ors ; active=rem} +| [] -> assert false + +let push_or r = match r.active with +| p::rem -> { r with ors = p::r.ors ; active=rem} +| [] -> assert false + +let push_or_column rs = List.map push_or rs +and push_no_or_column rs = List.map push_no_or rs + +let rec simplify_first_usefulness_col = function + | [] -> [] + | row :: rows -> + match row.active with + | [] -> assert false (* the rows are non-empty! *) + | p :: ps -> + let add_column p ps k = + (p, { row with active = ps }) :: k in + simplify_head_pat ~add_column p ps + (simplify_first_usefulness_col rows) + +(* Back to normal matrices *) +let make_vector r = List.rev r.no_ors + +let make_matrix rs = List.map make_vector rs + + +(* Standard union on answers *) +let union_res r1 r2 = match r1, r2 with +| (Unused,_) +| (_, Unused) -> Unused +| Used,_ -> r2 +| _, Used -> r1 +| Upartial u1, Upartial u2 -> Upartial (u1@u2) + +(* propose or pats for expansion *) +let extract_elements qs = + let rec do_rec seen = function + | [] -> [] + | q::rem -> + {no_ors= List.rev_append seen rem @ qs.no_ors ; + ors=[] ; + active = [q]}:: + do_rec (q::seen) rem in + do_rec [] qs.ors + +(* idem for matrices *) +let transpose rs = match rs with +| [] -> assert false +| r::rem -> + let i = List.map (fun x -> [x]) r in + List.fold_left + (List.map2 (fun r x -> x::r)) + i rem + +let extract_columns pss qs = match pss with +| [] -> List.map (fun _ -> []) qs.ors +| _ -> + let rows = List.map extract_elements pss in + transpose rows + +(* Core function + The idea is to first look for or patterns (recursive case), then + check or-patterns argument usefulness (terminal case) +*) + +let rec every_satisfiables pss qs = match qs.active with +| [] -> + (* qs is now partitioned, check usefulness *) + begin match qs.ors with + | [] -> (* no or-patterns *) + if satisfiable (make_matrix pss) (make_vector qs) then + Used + else + Unused + | _ -> (* n or-patterns -> 2n expansions *) + List.fold_right2 + (fun pss qs r -> match r with + | Unused -> Unused + | _ -> + match qs.active with + | [q] -> + let q1,q2 = or_args q in + let r_loc = every_both pss qs q1 q2 in + union_res r r_loc + | _ -> assert false) + (extract_columns pss qs) (extract_elements qs) + Used + end +| q::rem -> + begin match Patterns.General.(view q |> strip_vars).pat_desc with + | `Any -> + if is_var_column pss then + (* forget about ``all-variable'' columns now *) + every_satisfiables (remove_column pss) (remove qs) + else + (* otherwise this is direct food for satisfiable *) + every_satisfiables (push_no_or_column pss) (push_no_or qs) + | `Or (q1,q2,_) -> + if + q1.pat_loc.Location.loc_ghost && + q2.pat_loc.Location.loc_ghost + then + (* syntactically generated or-pats should not be expanded *) + every_satisfiables (push_no_or_column pss) (push_no_or qs) + else + (* this is a real or-pattern *) + every_satisfiables (push_or_column pss) (push_or qs) + | `Variant (l,_,r) when is_absent l r -> (* Ah Jacques... *) + Unused + | #Patterns.Simple.view as view -> + let q = { q with pat_desc = view } in + (* standard case, filter matrix *) + let pss = simplify_first_usefulness_col pss in + let hq, args = Patterns.Head.deconstruct q in + (* The handling of incoherent matrices is kept in line with + [satisfiable] *) + if not (all_coherent (hq :: first_column pss)) then + Unused + else begin + let q0 = discr_pat q pss in + every_satisfiables + (build_specialized_submatrix q0 pss + ~extend_row:(fun ps r -> { r with active = ps @ r.active })) + {qs with active=simple_match_args q0 hq args @ rem} + end + end + +(* + This function ``every_both'' performs the usefulness check + of or-pat q1|q2. + The trick is to call every_satisfied twice with + current active columns restricted to q1 and q2, + That way, + - others orpats in qs.ors will not get expanded. + - all matching work performed on qs.no_ors is not performed again. + *) +and every_both pss qs q1 q2 = + let qs1 = {qs with active=[q1]} + and qs2 = {qs with active=[q2]} in + let r1 = every_satisfiables pss qs1 + and r2 = every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in + match r1 with + | Unused -> + begin match r2 with + | Unused -> Unused + | Used -> Upartial [q1] + | Upartial u2 -> Upartial (q1::u2) + end + | Used -> + begin match r2 with + | Unused -> Upartial [q2] + | _ -> r2 + end + | Upartial u1 -> + begin match r2 with + | Unused -> Upartial (u1@[q2]) + | Used -> r1 + | Upartial u2 -> Upartial (u1 @ u2) + end + + + + +(* le_pat p q means, forall V, V matches q implies V matches p *) +let rec le_pat p q = + match (p.pat_desc, q.pat_desc) with + | (Tpat_var _|Tpat_any),_ -> true + | Tpat_alias(p,_,_), _ -> le_pat p q + | _, Tpat_alias(q,_,_) -> le_pat p q + | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 + | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) -> + Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs + | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) -> + (l1 = l2 && le_pat p1 p2) + | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) -> + l1 = l2 + | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false + | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs + | Tpat_lazy p, Tpat_lazy q -> le_pat p q + | Tpat_record (l1,_), Tpat_record (l2,_) -> + let ps,qs = records_args l1 l2 in + le_pats ps qs + | Tpat_array(ps), Tpat_array(qs) -> + List.length ps = List.length qs && le_pats ps qs +(* In all other cases, enumeration is performed *) + | _,_ -> not (satisfiable [[p]] [q]) + +and le_pats ps qs = + match ps,qs with + p::ps, q::qs -> le_pat p q && le_pats ps qs + | _, _ -> true + +let get_mins le ps = + let rec select_rec r = function + [] -> r + | p::ps -> + if List.exists (fun p0 -> le p0 p) ps + then select_rec r ps + else select_rec (p::r) ps in + select_rec [] (select_rec [] ps) + +(* + lub p q is a pattern that matches all values matched by p and q + may raise Empty, when p and q are not compatible +*) + +let rec lub p q = match p.pat_desc,q.pat_desc with +| Tpat_alias (p,_,_),_ -> lub p q +| _,Tpat_alias (q,_,_) -> lub p q +| (Tpat_any|Tpat_var _),_ -> q +| _,(Tpat_any|Tpat_var _) -> p +| Tpat_or (p1,p2,_),_ -> orlub p1 p2 q +| _,Tpat_or (q1,q2,_) -> orlub q1 q2 p (* Thanks god, lub is commutative *) +| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p +| Tpat_tuple ps, Tpat_tuple qs -> + let rs = lubs ps qs in + make_pat (Tpat_tuple rs) p.pat_type p.pat_env +| Tpat_lazy p, Tpat_lazy q -> + let r = lub p q in + make_pat (Tpat_lazy r) p.pat_type p.pat_env +| Tpat_construct (lid,c1,ps1,_), Tpat_construct (_,c2,ps2,_) + when Types.equal_tag c1.cstr_tag c2.cstr_tag -> + let rs = lubs ps1 ps2 in + make_pat (Tpat_construct (lid, c1, rs, None)) + p.pat_type p.pat_env +| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_) + when l1=l2 -> + let r=lub p1 p2 in + make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env +| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_) + when l1 = l2 -> p +| Tpat_record (l1,closed),Tpat_record (l2,_) -> + let rs = record_lubs l1 l2 in + make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env +| Tpat_array ps, Tpat_array qs + when List.length ps = List.length qs -> + let rs = lubs ps qs in + make_pat (Tpat_array rs) p.pat_type p.pat_env +| _,_ -> + raise Empty + +and orlub p1 p2 q = + try + let r1 = lub p1 q in + try + {q with pat_desc=(Tpat_or (r1,lub p2 q,None))} + with + | Empty -> r1 +with +| Empty -> lub p2 q + +and record_lubs l1 l2 = + let rec lub_rec l1 l2 = match l1,l2 with + | [],_ -> l2 + | _,[] -> l1 + | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 -> + if lbl1.lbl_pos < lbl2.lbl_pos then + (lid1, lbl1,p1)::lub_rec rem1 l2 + else if lbl2.lbl_pos < lbl1.lbl_pos then + (lid2, lbl2,p2)::lub_rec l1 rem2 + else + (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in + lub_rec l1 l2 + +and lubs ps qs = match ps,qs with +| p::ps, q::qs -> lub p q :: lubs ps qs +| _,_ -> [] + + +(******************************) +(* Exported variant closing *) +(******************************) + +(* Apply pressure to variants *) + +let pressure_variants tdefs patl = + ignore (pressure_variants + (Some tdefs) + (List.map (fun p -> [p; omega]) patl)) + +let pressure_variants_in_computation_pattern tdefs patl = + let add_row pss p_opt = + match p_opt with + | None -> pss + | Some p -> p :: pss + in + let val_pss, exn_pss = + List.fold_right (fun pat (vpss, epss)-> + let (vp, ep) = split_pattern pat in + add_row vpss vp, add_row epss ep + ) patl ([], []) + in + pressure_variants tdefs val_pss; + pressure_variants tdefs exn_pss + +(*****************************) +(* Utilities for diagnostics *) +(*****************************) + +(* + Build up a working pattern matrix by forgetting + about guarded patterns +*) + +let rec initial_matrix = function + [] -> [] + | {c_guard=Some _} :: rem -> initial_matrix rem + | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem + +(* + Build up a working pattern matrix by keeping + only the patterns which are guarded +*) +let rec initial_only_guarded = function + | [] -> [] + | { c_guard = None; _} :: rem -> + initial_only_guarded rem + | { c_lhs = pat; _ } :: rem -> + [pat] :: initial_only_guarded rem + + +(************************) +(* Exhaustiveness check *) +(************************) + +(* Whether the counter-example contains an extension pattern *) +let contains_extension pat = + exists_pattern + (function + | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true + | _ -> false) + pat + +let do_check_partial ~pred loc casel pss = match pss with +| [] -> + (* + This can occur + - For empty matches generated by ocamlp4 (no warning) + - when all patterns have guards (then, casel <> []) + (specific warning) + Then match MUST be considered non-exhaustive, + otherwise compilation of PM is broken. + *) + begin match casel with + | [] -> () + | _ -> + if Warnings.is_active Warnings.All_clauses_guarded then + Location.prerr_warning loc Warnings.All_clauses_guarded + end ; + Partial +| ps::_ -> + let counter_examples = + exhaust None pss (List.length ps) |> Seq.filter_map pred in + match counter_examples () with + | Seq.Nil -> Total + | Seq.Cons (v, _rest) -> + if Warnings.is_active (Warnings.Partial_match "") then begin + let errmsg = + try + let buf = Buffer.create 16 in + let fmt = Format.formatter_of_buffer buf in + Printpat.top_pretty fmt v; + if do_match (initial_only_guarded casel) [v] then + Buffer.add_string buf + "\n(However, some guarded clause may match this value.)"; + if contains_extension v then + Buffer.add_string buf + "\nMatching over values of extensible variant types \ + (the *extension* above)\n\ + must include a wild card pattern in order to be exhaustive." + ; + Buffer.contents buf + with _ -> + "" + in + Location.prerr_warning loc (Warnings.Partial_match errmsg) + end; + Partial + +(*****************) +(* Fragile check *) +(*****************) + +(* Collect all data types in a pattern *) + +let rec add_path path = function + | [] -> [path] + | x::rem as paths -> + if Path.same path x then paths + else x::add_path path rem + +let extendable_path path = + not + (Path.same path Predef.path_bool || + Path.same path Predef.path_list || + Path.same path Predef.path_unit || + Path.same path Predef.path_option) + +let rec collect_paths_from_pat r p = match p.pat_desc with +| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)}, + ps, _) -> + let path = get_constructor_type_path p.pat_type p.pat_env in + List.fold_left + collect_paths_from_pat + (if extendable_path path then add_path path r else r) + ps +| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r +| Tpat_tuple ps | Tpat_array ps +| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps, _)-> + List.fold_left collect_paths_from_pat r ps +| Tpat_record (lps,_) -> + List.fold_left + (fun r (_, _, p) -> collect_paths_from_pat r p) + r lps +| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p +| Tpat_or (p1,p2,_) -> + collect_paths_from_pat (collect_paths_from_pat r p1) p2 +| Tpat_lazy p + -> + collect_paths_from_pat r p + + +(* + Actual fragile check + 1. Collect data types in the patterns of the match. + 2. One exhaustivity check per datatype, considering that + the type is extended. +*) + +let do_check_fragile loc casel pss = + let exts = + List.fold_left + (fun r c -> collect_paths_from_pat r c.c_lhs) + [] casel in + match exts with + | [] -> () + | _ -> match pss with + | [] -> () + | ps::_ -> + List.iter + (fun ext -> + let witnesses = exhaust (Some ext) pss (List.length ps) in + match witnesses () with + | Seq.Nil -> + Location.prerr_warning + loc + (Warnings.Fragile_match (Path.name ext)) + | Seq.Cons _ -> ()) + exts + +(********************************) +(* Exported unused clause check *) +(********************************) + +let check_unused pred casel = + if Warnings.is_active Warnings.Redundant_case + || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then + let rec do_rec pref = function + | [] -> () + | {c_lhs=q; c_guard; c_rhs} :: rem -> + let qs = [q] in + begin try + let pss = + (* prev was accumulated in reverse order; + restore source order to get ordered counter-examples *) + List.rev pref + |> List.filter (compats qs) + |> get_mins le_pats in + (* First look for redundant or partially redundant patterns *) + let r = every_satisfiables (make_rows pss) (make_row qs) in + let refute = (c_rhs.exp_desc = Texp_unreachable) in + (* Do not warn for unused [pat -> .] *) + if r = Unused && refute then () else + let r = + (* Do not refine if either: + - we already know the clause is unused + - the clause under consideration is not a refutation clause + and either: + + there are no other lines + + we do not care whether the types prevent this clause to + be reached. + If the clause under consideration *is* a refutation clause + then we do need to check more carefully whether it can be + refuted or not. *) + let skip = + r = Unused || (not refute && pref = []) || + not(refute || Warnings.is_active Warnings.Unreachable_case) in + if skip then r else + (* Then look for empty patterns *) + let sfs = list_satisfying_vectors pss qs in + if sfs = [] then Unused else + let sfs = + List.map (function [u] -> u | _ -> assert false) sfs in + let u = orify_many sfs in + (*Format.eprintf "%a@." pretty_val u;*) + let pattern = {u with pat_loc = q.pat_loc} in + match pred refute pattern with + None when not refute -> + Location.prerr_warning q.pat_loc Warnings.Unreachable_case; + Used + | _ -> r + in + match r with + | Unused -> + Location.prerr_warning + q.pat_loc Warnings.Redundant_case + | Upartial ps -> + List.iter + (fun p -> + Location.prerr_warning + p.pat_loc Warnings.Redundant_subpat) + ps + | Used -> () + with Empty | Not_found -> assert false + end ; + + if c_guard <> None then + do_rec pref rem + else + do_rec ([q]::pref) rem in + + do_rec [] casel + +(*********************************) +(* Exported irrefutability tests *) +(*********************************) + +let irrefutable pat = le_pat pat omega + +let inactive ~partial pat = + match partial with + | Partial -> false + | Total -> begin + let rec loop pat = + match pat.pat_desc with + | Tpat_lazy _ | Tpat_array _ -> + false + | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) -> + true + | Tpat_constant c -> begin + match c with + | Const_string _ + | Const_int _ | Const_char _ | Const_float _ + | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true + end + | Tpat_tuple ps | Tpat_construct (_, _, ps, _) -> + List.for_all (fun p -> loop p) ps + | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) -> + loop p + | Tpat_record (ldps,_) -> + List.for_all + (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p) + ldps + | Tpat_or (p,q,_) -> + loop p && loop q + in + loop pat + end + + + + + + + +(*********************************) +(* Exported exhaustiveness check *) +(*********************************) + +(* + Fragile check is performed when required and + on exhaustive matches only. +*) + +let check_partial pred loc casel = + let pss = initial_matrix casel in + let pss = get_mins le_pats pss in + let total = do_check_partial ~pred loc casel pss in + if + total = Total && Warnings.is_active (Warnings.Fragile_match "") + then begin + do_check_fragile loc casel pss + end ; + total + +(*************************************) +(* Ambiguous variable in or-patterns *) +(*************************************) + +(* Specification: ambiguous variables in or-patterns. + + The semantics of or-patterns in OCaml is specified with + a left-to-right bias: a value [v] matches the pattern [p | q] if it + matches [p] or [q], but if it matches both, the environment + captured by the match is the environment captured by [p], never the + one captured by [q]. + + While this property is generally well-understood, one specific case + where users expect a different semantics is when a pattern is + followed by a when-guard: [| p when g -> e]. Consider for example: + + | ((Const x, _) | (_, Const x)) when is_neutral x -> branch + + The semantics is clear: match the scrutinee against the pattern, if + it matches, test the guard, and if the guard passes, take the + branch. + + However, consider the input [(Const a, Const b)], where [a] fails + the test [is_neutral f], while [b] passes the test [is_neutral + b]. With the left-to-right semantics, the clause above is *not* + taken by its input: matching [(Const a, Const b)] against the + or-pattern succeeds in the left branch, it returns the environment + [x -> a], and then the guard [is_neutral a] is tested and fails, + the branch is not taken. Most users, however, intuitively expect + that any pair that has one side passing the test will take the + branch. They assume it is equivalent to the following: + + | (Const x, _) when is_neutral x -> branch + | (_, Const x) when is_neutral x -> branch + + while it is not. + + The code below is dedicated to finding these confusing cases: the + cases where a guard uses "ambiguous" variables, that are bound to + different parts of the scrutinees by different sides of + a or-pattern. In other words, it finds the cases where the + specified left-to-right semantics is not equivalent to + a non-deterministic semantics (any branch can be taken) relatively + to a specific guard. +*) + +let pattern_vars p = Ident.Set.of_list (Typedtree.pat_bound_idents p) + +(* Row for ambiguous variable search, + row is the traditional pattern row, + varsets contain a list of head variable sets (varsets) + + A given varset contains all the variables that appeared at the head + of a pattern in the row at some point during traversal: they would + all be bound to the same value at matching time. On the contrary, + two variables of different varsets appeared at different places in + the pattern and may be bound to distinct sub-parts of the matched + value. + + All rows of a (sub)matrix have rows of the same length, + but also varsets of the same length. + + Varsets are populated when simplifying the first column + -- the variables of the head pattern are collected in a new varset. + For example, + { row = x :: r1; varsets = s1 } + { row = (Some _) as y :: r2; varsets = s2 } + { row = (None as x) as y :: r3; varsets = s3 } + { row = (Some x | (None as x)) :: r4 with varsets = s4 } + becomes + (_, { row = r1; varsets = {x} :: s1 }) + (Some _, { row = r2; varsets = {y} :: s2 }) + (None, { row = r3; varsets = {x, y} :: s3 }) + (Some x, { row = r4; varsets = {} :: s4 }) + (None, { row = r4; varsets = {x} :: s4 }) +*) +type amb_row = { row : pattern list ; varsets : Ident.Set.t list; } + +let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k = + let rec simpl head_bound_variables varsets p ps k = + match (Patterns.General.view p).pat_desc with + | `Alias (p,x,_) -> + simpl (Ident.Set.add x head_bound_variables) varsets p ps k + | `Var (x, _) -> + simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k + | `Or (p1,p2,_) -> + simpl head_bound_variables varsets p1 ps + (simpl head_bound_variables varsets p2 ps k) + | #Patterns.Simple.view as view -> + add_column (Patterns.Head.deconstruct { p with pat_desc = view }) + { row = ps; varsets = head_bound_variables :: varsets; } k + in simpl head_bound_variables varsets p ps k + +(* + To accurately report ambiguous variables, one must consider + that previous clauses have already matched some values. + Consider for example: + + | (Foo x, Foo y) -> ... + | ((Foo x, _) | (_, Foo x)) when bar x -> ... + + The second line taken in isolation uses an unstable variable, + but the discriminating values, of the shape [(Foo v1, Foo v2)], + would all be filtered by the line above. + + To track this information, the matrices we analyze contain both + *positive* rows, that describe the rows currently being analyzed + (of type Varsets.row, so that their varsets are tracked) and + *negative rows*, that describe the cases already matched against. + + The values matched by a signed matrix are the values matched by + some of the positive rows but none of the negative rows. In + particular, a variable is stable if, for any value not matched by + any of the negative rows, the environment captured by any of the + matching positive rows is identical. +*) +type ('a, 'b) signed = Positive of 'a | Negative of 'b + +let rec simplify_first_amb_col = function + | [] -> [] + | (Negative [] | Positive { row = []; _ }) :: _ -> assert false + | Negative (n :: ns) :: rem -> + let add_column n ns k = (n, Negative ns) :: k in + simplify_head_pat + ~add_column n ns (simplify_first_amb_col rem) + | Positive { row = p::ps; varsets; }::rem -> + let add_column p ps k = (p, Positive ps) :: k in + simplify_head_amb_pat + Ident.Set.empty varsets + ~add_column p ps (simplify_first_amb_col rem) + +(* Compute stable bindings *) + +type stable_vars = + | All + | Vars of Ident.Set.t + +let stable_inter sv1 sv2 = match sv1, sv2 with + | All, sv | sv, All -> sv + | Vars s1, Vars s2 -> Vars (Ident.Set.inter s1 s2) + +let reduce f = function +| [] -> invalid_arg "reduce" +| x::xs -> List.fold_left f x xs + +let rec matrix_stable_vars m = match m with + | [] -> All + | ((Positive {row = []; _} | Negative []) :: _) as empty_rows -> + let exception Negative_empty_row in + (* if at least one empty row is negative, the matrix matches no value *) + let get_varsets = function + | Negative n -> + (* All rows have the same number of columns; + if the first row is empty, they all are. *) + assert (n = []); + raise Negative_empty_row + | Positive p -> + assert (p.row = []); + p.varsets in + begin match List.map get_varsets empty_rows with + | exception Negative_empty_row -> All + | rows_varsets -> + let stables_in_varsets = + reduce (List.map2 Ident.Set.inter) rows_varsets in + (* The stable variables are those stable at any position *) + Vars + (List.fold_left Ident.Set.union Ident.Set.empty stables_in_varsets) + end + | m -> + let is_negative = function + | Negative _ -> true + | Positive _ -> false in + if List.for_all is_negative m then + (* optimization: quit early if there are no positive rows. + This may happen often when the initial matrix has many + negative cases and few positive cases (a small guarded + clause after a long list of clauses) *) + All + else begin + let m = simplify_first_amb_col m in + if not (all_coherent (first_column m)) then + All + else begin + (* If the column is ill-typed but deemed coherent, we might + spuriously warn about some variables being unstable. + As sad as that might be, the warning can be silenced by + splitting the or-pattern... *) + let submatrices = + let extend_row columns = function + | Negative r -> Negative (columns @ r) + | Positive r -> Positive { r with row = columns @ r.row } in + let q0 = discr_pat Patterns.Simple.omega m in + let { default; constrs } = + build_specialized_submatrices ~extend_row q0 m in + let non_default = List.map snd constrs in + if full_match false constrs + then non_default + else default :: non_default in + (* A stable variable must be stable in each submatrix. *) + let submat_stable = List.map matrix_stable_vars submatrices in + List.fold_left stable_inter All submat_stable + end + end + +let pattern_stable_vars ns p = + matrix_stable_vars + (List.fold_left (fun m n -> Negative n :: m) + [Positive {varsets = []; row = [p]}] ns) + +(* All identifier paths that appear in an expression that occurs + as a clause right hand side or guard. +*) + +let all_rhs_idents exp = + let ids = ref Ident.Set.empty in + let open Tast_iterator in + let expr_iter iter exp = + match exp.exp_desc with + | Texp_ident (path, _lid, _descr) -> + List.iter (fun id -> ids := Ident.Set.add id !ids) (Path.heads path) + (* Use default iterator methods for rest of match.*) + | _ -> Tast_iterator.default_iterator.expr iter exp + in + let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in + iterator.expr iterator exp; + !ids + +let check_ambiguous_bindings = + let open Warnings in + let warn0 = Ambiguous_var_in_pattern_guard [] in + fun cases -> + if is_active warn0 then + let check_case ns case = match case with + | { c_lhs = p; c_guard=None ; _} -> [p]::ns + | { c_lhs=p; c_guard=Some g; _} -> + let all = + Ident.Set.inter (pattern_vars p) (all_rhs_idents g) in + if not (Ident.Set.is_empty all) then begin + match pattern_stable_vars ns p with + | All -> () + | Vars stable -> + let ambiguous = Ident.Set.diff all stable in + if not (Ident.Set.is_empty ambiguous) then begin + let pps = + Ident.Set.elements ambiguous |> List.map Ident.name in + let warn = Ambiguous_var_in_pattern_guard pps in + Location.prerr_warning p.pat_loc warn + end + end; + ns + in + ignore (List.fold_left check_case [] cases) + +let do_complete_partial ~(pred : pattern -> pattern option) pss = + (* c/p of [do_check_partial] without the parts concerning the generation of + the error message or the warning emiting. *) + match pss with + | [] -> [] + | ps :: _ -> + let typecheck p = + pred p + in + exhaust None pss (List.length ps) + |> Seq.filter_map typecheck + |> List.of_seq + +let complete_partial ~(pred : pattern -> pattern option) pss = + let pss = get_mins le_pats pss in + do_complete_partial ~pred pss + +let return_unused casel = + let rec do_rec acc pref = function + | [] -> acc + | q :: rem -> + let qs = [q] in + let acc = + try + let pss = get_mins le_pats (List.filter (compats qs) pref) in + let r = every_satisfiables (make_rows pss) (make_row qs) in + match r with + | Unused -> `Unused q :: acc + | Upartial ps -> `Unused_subs (q, ps) :: acc + | Used -> acc + with Empty | Not_found -> assert false + in + (* FIXME: we need to know whether there is a guard here, because if there + is, we dont want to add [[q]] to [pref]. *) + do_rec acc ([q]::pref) rem + in + do_rec [] [] casel diff --git a/ocamlmerlin_mlx/ocaml/typing/parmatch.mli b/ocamlmerlin_mlx/ocaml/typing/parmatch.mli new file mode 100644 index 0000000..0fe0d50 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/parmatch.mli @@ -0,0 +1,129 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Detection of partial matches and unused match cases. *) + +open Asttypes +open Typedtree +open Types + +val const_compare : constant -> constant -> int +(** [const_compare c1 c2] compares the actual values represented by [c1] and + [c2], while simply using [Stdlib.compare] would compare the + representations. + + cf. MPR#5758 *) + +val le_pat : pattern -> pattern -> bool +(** [le_pat p q] means: forall V, V matches q implies V matches p *) + +val le_pats : pattern list -> pattern list -> bool +(** [le_pats (p1 .. pm) (q1 .. qn)] means: forall i <= m, [le_pat pi qi] *) + +(** Exported compatibility functor, abstracted over constructor equality *) +module Compat : + functor + (_ : sig + val equal : + Types.constructor_description -> + Types.constructor_description -> + bool + end) -> sig + val compat : pattern -> pattern -> bool + val compats : pattern list -> pattern list -> bool + end + +exception Empty + +val lub : pattern -> pattern -> pattern +(** [lub p q] is a pattern that matches all values matched by [p] and [q]. + May raise [Empty], when [p] and [q] are not compatible. *) + +val lubs : pattern list -> pattern list -> pattern list +(** [lubs [p1; ...; pn] [q1; ...; qk]], where [n < k], is + [[lub p1 q1; ...; lub pk qk]]. *) + +val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list + +(** Those two functions recombine one pattern and its arguments: + For instance: + (_,_)::p1::p2::rem -> (p1, p2)::rem + The second one will replace mutable arguments by '_' +*) +val set_args : pattern -> pattern list -> pattern list +val set_args_erase_mutable : pattern -> pattern list -> pattern list + +val pat_of_constr : pattern -> constructor_description -> pattern +val complete_constrs : + constructor_description pattern_data -> + constructor_description list -> + constructor_description list + +(** [pats_of_type] builds a list of patterns from a given expected type, + for explosion of wildcard patterns in Typecore.type_pat. + + There are four interesting cases: + - the type is empty ([]) + - no further explosion is necessary ([Pat_any]) + - a single pattern is generated, from a record or tuple type + or a single-variant type ([tp]) + - a list of patterns, in the case that all branches + are GADT constructors ([tp1; ..; tpn]). + *) +val pats_of_type : Env.t -> type_expr -> pattern list + +val pressure_variants: + Env.t -> pattern list -> unit +val pressure_variants_in_computation_pattern: + Env.t -> computation general_pattern list -> unit + +(** [check_partial pred loc caselist] and [check_unused refute pred caselist] + are called with a function [pred] which will be given counter-example + candidates: they may be partially ill-typed, and have to be type-checked + to extract a valid counter-example. + [pred] returns a valid counter-example or [None]. + [refute] indicates that [check_unused] was called on a refutation clause. + *) +val check_partial: + (pattern -> pattern option) -> Location.t -> value case list -> partial +val check_unused: + (bool -> pattern -> pattern option) -> value case list -> unit + +(* Irrefutability tests *) +val irrefutable : pattern -> bool + +(** An inactive pattern is a pattern, matching against which can be duplicated, + erased or delayed without change in observable behavior of the program. + Patterns containing (lazy _) subpatterns or reads of mutable fields are + active. *) +val inactive : partial:partial -> pattern -> bool + +(* Ambiguous bindings *) +val check_ambiguous_bindings : value case list -> unit + +(* The tag used for open polymorphic variant types with an abstract row *) +val some_private_tag : label + +(*******************) +(* Merlin specific *) +(*******************) + +val complete_partial : + pred:(pattern -> pattern option) -> + pattern list list -> + (pattern) list + +val return_unused: pattern list -> + [ `Unused of pattern | `Unused_subs of pattern * pattern list ] list diff --git a/ocamlmerlin_mlx/ocaml/typing/path.ml b/ocamlmerlin_mlx/ocaml/typing/path.ml new file mode 100644 index 0000000..69b8f34 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/path.ml @@ -0,0 +1,144 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + Pident of Ident.t + | Pdot of t * string + | Papply of t * t + | Pextra_ty of t * extra_ty +and extra_ty = + | Pcstr_ty of string + | Pext_ty + +let rec same p1 p2 = + p1 == p2 + || match (p1, p2) with + (Pident id1, Pident id2) -> Ident.same id1 id2 + | (Pdot(p1, s1), Pdot(p2, s2)) -> + s1 = s2 && same p1 p2 + | (Papply(fun1, arg1), Papply(fun2, arg2)) -> + same fun1 fun2 && same arg1 arg2 + | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> + let same_extra = match t1, t2 with + | (Pcstr_ty s1, Pcstr_ty s2) -> s1 = s2 + | (Pext_ty, Pext_ty) -> true + | ((Pcstr_ty _ | Pext_ty), _) -> false + in same_extra && same p1 p2 + | (_, _) -> false + +let rec compare p1 p2 = + if p1 == p2 then 0 + else match (p1, p2) with + (Pident id1, Pident id2) -> Ident.compare id1 id2 + | (Pdot(p1, s1), Pdot(p2, s2)) -> + let h = compare p1 p2 in + if h <> 0 then h else String.compare s1 s2 + | (Papply(fun1, arg1), Papply(fun2, arg2)) -> + let h = compare fun1 fun2 in + if h <> 0 then h else compare arg1 arg2 + | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> + let h = compare_extra t1 t2 in + if h <> 0 then h else compare p1 p2 + | (Pident _, (Pdot _ | Papply _ | Pextra_ty _)) + | (Pdot _, (Papply _ | Pextra_ty _)) + | (Papply _, Pextra_ty _) + -> -1 + | ((Pextra_ty _ | Papply _ | Pdot _), Pident _) + | ((Pextra_ty _ | Papply _) , Pdot _) + | (Pextra_ty _, Papply _) + -> 1 +and compare_extra t1 t2 = + match (t1, t2) with + Pcstr_ty s1, Pcstr_ty s2 -> String.compare s1 s2 + | (Pext_ty, Pext_ty) + -> 0 + | (Pcstr_ty _, Pext_ty) + -> -1 + | (Pext_ty, Pcstr_ty _) + -> 1 + +let rec find_free_opt ids = function + Pident id -> List.find_opt (Ident.same id) ids + | Pdot(p, _) | Pextra_ty (p, _) -> find_free_opt ids p + | Papply(p1, p2) -> begin + match find_free_opt ids p1 with + | None -> find_free_opt ids p2 + | Some _ as res -> res + end + +let exists_free ids p = + match find_free_opt ids p with + | None -> false + | _ -> true + +let rec scope = function + Pident id -> Ident.scope id + | Pdot(p, _) | Pextra_ty (p, _) -> scope p + | Papply(p1, p2) -> Int.max (scope p1) (scope p2) + +let kfalse _ = false + +let rec name ?(paren=kfalse) = function + Pident id -> Ident.name id + | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> + name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s + | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" + | Pextra_ty (p, Pext_ty) -> name ~paren p + +let rec print ppf = function + | Pident id -> Ident.print_with_scope ppf id + | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> + Format.fprintf ppf "%a.%s" print p s + | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2 + | Pextra_ty (p, Pext_ty) -> print ppf p + +let rec head = function + Pident id -> id + | Pdot(p, _) | Pextra_ty (p, _) -> head p + | Papply _ -> assert false + +let flatten = + let rec flatten acc = function + | Pident id -> `Ok (id, acc) + | Pdot (p, s) | Pextra_ty (p, Pcstr_ty s) -> flatten (s :: acc) p + | Papply _ -> `Contains_apply + | Pextra_ty (p, Pext_ty) -> flatten acc p + in + fun t -> flatten [] t + +let heads p = + let rec heads p acc = match p with + | Pident id -> id :: acc + | Pdot (p, _) | Pextra_ty (p, _) -> heads p acc + | Papply(p1, p2) -> + heads p1 (heads p2 acc) + in heads p [] + +let rec last = function + | Pident id -> Ident.name id + | Pdot(_, s) | Pextra_ty (_, Pcstr_ty s) -> s + | Papply(_, p) | Pextra_ty (p, Pext_ty) -> last p + +let is_constructor_typath p = + match p with + | Pident _ | Pdot _ | Papply _ -> false + | Pextra_ty _ -> true + +module T = struct + type nonrec t = t + let compare = compare +end +module Set = Set.Make(T) +module Map = Map.Make(T) diff --git a/ocamlmerlin_mlx/ocaml/typing/path.mli b/ocamlmerlin_mlx/ocaml/typing/path.mli new file mode 100644 index 0000000..39e76a3 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/path.mli @@ -0,0 +1,80 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Access paths *) + +type t = + | Pident of Ident.t + (** Examples: x, List, int *) + | Pdot of t * string + (** Examples: List.map, Float.Array *) + | Papply of t * t + (** Examples: Set.Make(Int), Map.Make(Set.Make(Int)) *) + | Pextra_ty of t * extra_ty + (** [Pextra_ty (p, extra)] are additional paths of types + introduced by specific OCaml constructs. See below. + *) +and extra_ty = + | Pcstr_ty of string + (** [Pextra_ty (p, Pcstr_ty c)] is the type of the inline record for + constructor [c] inside type [p]. + + For example, in + {[ + type 'a t = Nil | Cons of {hd : 'a; tl : 'a t} + ]} + + The inline record type [{hd : 'a; tl : 'a t}] cannot + be named by the user in the surface syntax, but internally + it has the path + [Pextra_ty (Pident `t`, Pcstr_ty "Cons")]. + *) + | Pext_ty + (** [Pextra_ty (p, Pext_ty)] is the type of the inline record for + the extension constructor [p]. + + For example, in + {[ + type exn += Error of {loc : loc; msg : string} + ]} + + The inline record type [{loc : loc; msg : string}] cannot + be named by the user in the surface syntax, but internally + it has the path + [Pextra_ty (Pident `Error`, Pext_ty)]. + *) + +val same: t -> t -> bool +val compare: t -> t -> int +val compare_extra: extra_ty -> extra_ty -> int +val find_free_opt: Ident.t list -> t -> Ident.t option +val exists_free: Ident.t list -> t -> bool +val scope: t -> int +val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ] + +val name: ?paren:(string -> bool) -> t -> string + (* [paren] tells whether a path suffix needs parentheses *) +val head: t -> Ident.t + +val print: Format.formatter -> t -> unit + +val heads: t -> Ident.t list + +val last: t -> string + +val is_constructor_typath: t -> bool + +module Map : Map.S with type key = t +module Set : Set.S with type elt = t diff --git a/ocamlmerlin_mlx/ocaml/typing/patterns.ml b/ocamlmerlin_mlx/ocaml/typing/patterns.ml new file mode 100644 index 0000000..55f9d4f --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/patterns.ml @@ -0,0 +1,254 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Partout, INRIA Paris-Saclay *) +(* Thomas Refis, Jane Street Europe *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Types +open Typedtree + +(* useful pattern auxiliary functions *) + +let omega = { + pat_desc = Tpat_any; + pat_loc = Location.none; + pat_extra = []; + pat_type = Ctype.none; + pat_env = Env.empty; + pat_attributes = []; +} + +let rec omegas i = + if i <= 0 then [] else omega :: omegas (i-1) + +let omega_list l = List.map (fun _ -> omega) l + +module Non_empty_row = struct + type 'a t = 'a * Typedtree.pattern list + + let of_initial = function + | [] -> assert false + | pat :: patl -> (pat, patl) + + let map_first f (p, patl) = (f p, patl) +end + +(* "views" on patterns are polymorphic variants + that allow to restrict the set of pattern constructors + statically allowed at a particular place *) + +module Simple = struct + type view = [ + | `Any + | `Constant of constant + | `Tuple of pattern list + | `Construct of + Longident.t loc * constructor_description * pattern list + | `Variant of label * pattern option * row_desc ref + | `Record of + (Longident.t loc * label_description * pattern) list * closed_flag + | `Array of pattern list + | `Lazy of pattern + ] + + type pattern = view pattern_data + + let omega = { omega with pat_desc = `Any } +end + +module Half_simple = struct + type view = [ + | Simple.view + | `Or of pattern * pattern * row_desc option + ] + + type pattern = view pattern_data +end + +module General = struct + type view = [ + | Half_simple.view + | `Var of Ident.t * string loc + | `Alias of pattern * Ident.t * string loc + ] + type pattern = view pattern_data + + let view_desc = function + | Tpat_any -> + `Any + | Tpat_var (id, str) -> + `Var (id, str) + | Tpat_alias (p, id, str) -> + `Alias (p, id, str) + | Tpat_constant cst -> + `Constant cst + | Tpat_tuple ps -> + `Tuple ps + | Tpat_construct (cstr, cstr_descr, args, _) -> + `Construct (cstr, cstr_descr, args) + | Tpat_variant (cstr, arg, row_desc) -> + `Variant (cstr, arg, row_desc) + | Tpat_record (fields, closed) -> + `Record (fields, closed) + | Tpat_array ps -> `Array ps + | Tpat_or (p, q, row_desc) -> `Or (p, q, row_desc) + | Tpat_lazy p -> `Lazy p + + let view p : pattern = + { p with pat_desc = view_desc p.pat_desc } + + let erase_desc = function + | `Any -> Tpat_any + | `Var (id, str) -> Tpat_var (id, str) + | `Alias (p, id, str) -> Tpat_alias (p, id, str) + | `Constant cst -> Tpat_constant cst + | `Tuple ps -> Tpat_tuple ps + | `Construct (cstr, cst_descr, args) -> + Tpat_construct (cstr, cst_descr, args, None) + | `Variant (cstr, arg, row_desc) -> + Tpat_variant (cstr, arg, row_desc) + | `Record (fields, closed) -> + Tpat_record (fields, closed) + | `Array ps -> Tpat_array ps + | `Or (p, q, row_desc) -> Tpat_or (p, q, row_desc) + | `Lazy p -> Tpat_lazy p + + let erase p : Typedtree.pattern = + { p with pat_desc = erase_desc p.pat_desc } + + let rec strip_vars (p : pattern) : Half_simple.pattern = + match p.pat_desc with + | `Alias (p, _, _) -> strip_vars (view p) + | `Var _ -> { p with pat_desc = `Any } + | #Half_simple.view as view -> { p with pat_desc = view } +end + +(* the head constructor of a simple pattern *) + +module Head : sig + type desc = + | Any + | Construct of constructor_description + | Constant of constant + | Tuple of int + | Record of label_description list + | Variant of + { tag: label; has_arg: bool; + cstr_row: row_desc ref; + type_row : unit -> row_desc; } + | Array of int + | Lazy + + type t = desc pattern_data + + val arity : t -> int + + (** [deconstruct p] returns the head of [p] and the list of sub patterns. *) + val deconstruct : Simple.pattern -> t * pattern list + + (** reconstructs a pattern, putting wildcards as sub-patterns. *) + val to_omega_pattern : t -> pattern + + val omega : t +end = struct + type desc = + | Any + | Construct of constructor_description + | Constant of constant + | Tuple of int + | Record of label_description list + | Variant of + { tag: label; has_arg: bool; + cstr_row: row_desc ref; + type_row : unit -> row_desc; } + (* the row of the type may evolve if [close_variant] is called, + hence the (unit -> ...) delay *) + | Array of int + | Lazy + + type t = desc pattern_data + + let deconstruct (q : Simple.pattern) = + let deconstruct_desc = function + | `Any -> Any, [] + | `Constant c -> Constant c, [] + | `Tuple args -> + Tuple (List.length args), args + | `Construct (_, c, args) -> + Construct c, args + | `Variant (tag, arg, cstr_row) -> + let has_arg, pats = + match arg with + | None -> false, [] + | Some a -> true, [a] + in + let type_row () = + match get_desc (Ctype.expand_head q.pat_env q.pat_type) with + | Tvariant type_row -> type_row + | _ -> assert false + in + Variant {tag; has_arg; cstr_row; type_row}, pats + | `Array args -> + Array (List.length args), args + | `Record (largs, _) -> + let lbls = List.map (fun (_,lbl,_) -> lbl) largs in + let pats = List.map (fun (_,_,pat) -> pat) largs in + Record lbls, pats + | `Lazy p -> + Lazy, [p] + in + let desc, pats = deconstruct_desc q.pat_desc in + { q with pat_desc = desc }, pats + + let arity t = + match t.pat_desc with + | Any -> 0 + | Constant _ -> 0 + | Construct c -> c.cstr_arity + | Tuple n | Array n -> n + | Record l -> List.length l + | Variant { has_arg; _ } -> if has_arg then 1 else 0 + | Lazy -> 1 + + let to_omega_pattern t = + let pat_desc = + let mkloc x = Location.mkloc x t.pat_loc in + match t.pat_desc with + | Any -> Tpat_any + | Lazy -> Tpat_lazy omega + | Constant c -> Tpat_constant c + | Tuple n -> Tpat_tuple (omegas n) + | Array n -> Tpat_array (omegas n) + | Construct c -> + let lid_loc = mkloc (Longident.Lident c.cstr_name) in + Tpat_construct (lid_loc, c, omegas c.cstr_arity, None) + | Variant { tag; has_arg; cstr_row } -> + let arg_opt = if has_arg then Some omega else None in + Tpat_variant (tag, arg_opt, cstr_row) + | Record lbls -> + let lst = + List.map (fun lbl -> + let lid_loc = mkloc (Longident.Lident lbl.lbl_name) in + (lid_loc, lbl, omega) + ) lbls + in + Tpat_record (lst, Closed) + in + { t with + pat_desc; + pat_extra = []; + } + + let omega = { omega with pat_desc = Any } +end diff --git a/ocamlmerlin_mlx/ocaml/typing/patterns.mli b/ocamlmerlin_mlx/ocaml/typing/patterns.mli new file mode 100644 index 0000000..66dd2d0 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/patterns.mli @@ -0,0 +1,109 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Partout, INRIA Paris-Saclay *) +(* Thomas Refis, Jane Street Europe *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree +open Types + +val omega : pattern +(** aka. "Tpat_any" or "_" *) + +val omegas : int -> pattern list +(** [List.init (fun _ -> omega)] *) + +val omega_list : 'a list -> pattern list +(** [List.map (fun _ -> omega)] *) + +module Non_empty_row : sig + type 'a t = 'a * Typedtree.pattern list + + val of_initial : Typedtree.pattern list -> Typedtree.pattern t + (** 'assert false' on empty rows *) + + val map_first : ('a -> 'b) -> 'a t -> 'b t +end + +module Simple : sig + type view = [ + | `Any + | `Constant of constant + | `Tuple of pattern list + | `Construct of + Longident.t loc * constructor_description * pattern list + | `Variant of label * pattern option * row_desc ref + | `Record of + (Longident.t loc * label_description * pattern) list * closed_flag + | `Array of pattern list + | `Lazy of pattern + ] + type pattern = view pattern_data + + val omega : [> view ] pattern_data +end + +module Half_simple : sig + type view = [ + | Simple.view + | `Or of pattern * pattern * row_desc option + ] + type pattern = view pattern_data +end + +module General : sig + type view = [ + | Half_simple.view + | `Var of Ident.t * string loc + | `Alias of pattern * Ident.t * string loc + ] + type pattern = view pattern_data + + val view : Typedtree.pattern -> pattern + val erase : [< view ] pattern_data -> Typedtree.pattern + + val strip_vars : pattern -> Half_simple.pattern +end + +module Head : sig + type desc = + | Any + | Construct of constructor_description + | Constant of constant + | Tuple of int + | Record of label_description list + | Variant of + { tag: label; has_arg: bool; + cstr_row: row_desc ref; + type_row : unit -> row_desc; } + (* the row of the type may evolve if [close_variant] is called, + hence the (unit -> ...) delay *) + | Array of int + | Lazy + + type t = desc pattern_data + + val arity : t -> int + + (** [deconstruct p] returns the head of [p] and the list of sub patterns. + + @raise [Invalid_arg _] if [p] is an or- or an exception-pattern. *) + val deconstruct : Simple.pattern -> t * pattern list + + (** reconstructs a pattern, putting wildcards as sub-patterns. *) + val to_omega_pattern : t -> pattern + + val omega : t + +end diff --git a/ocamlmerlin_mlx/ocaml/typing/persistent_env.ml b/ocamlmerlin_mlx/ocaml/typing/persistent_env.ml new file mode 100644 index 0000000..15bb941 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/persistent_env.ml @@ -0,0 +1,410 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Persistent structure descriptions *) + +open Misc +open Cmi_format + +module Consistbl = Consistbl.Make (Misc.String) + +let add_delayed_check_forward = ref (fun _ -> assert false) + +type error = + | Illegal_renaming of modname * modname * filepath + | Inconsistent_import of modname * filepath * filepath + | Need_recursive_types of modname + +exception Error of error +let error err = raise (Error err) + +module Persistent_signature = struct + type t = + { filename : string; + cmi : Cmi_format.cmi_infos } + + let load = ref (fun ~unit_name -> + match Load_path.find_uncap (unit_name ^ ".cmi") with + | filename -> + let cmi = Cmi_cache.read filename in + Some { filename; cmi } + | exception Not_found -> None) +end + +type can_load_cmis = + | Can_load_cmis + | Cannot_load_cmis of Lazy_backtrack.log + +type pers_struct = { + ps_name: string; + ps_crcs: (string * Digest.t option) list; + ps_filename: string; + ps_flags: pers_flags list; +} + +module String = Misc.String + +(* If a .cmi file is missing (or invalid), we + store it as Missing in the cache. *) +type 'a pers_struct_info = + | Missing + | Found of pers_struct * 'a + +type 'a t = { + persistent_structures : (string, 'a pers_struct_info) Hashtbl.t; + imported_units: String.Set.t ref; + imported_opaque_units: String.Set.t ref; + crc_units: Consistbl.t; + can_load_cmis: can_load_cmis ref; + short_paths_basis: Short_paths.Basis.t ref; +} + +let empty () = { + persistent_structures = Hashtbl.create 17; + imported_units = ref String.Set.empty; + imported_opaque_units = ref String.Set.empty; + crc_units = Consistbl.create (); + can_load_cmis = ref Can_load_cmis; + short_paths_basis = ref (Short_paths.Basis.create ()); +} + +let clear penv = + let { + persistent_structures; + imported_units; + imported_opaque_units; + crc_units; + can_load_cmis; + short_paths_basis; + } = penv in + Hashtbl.clear persistent_structures; + imported_units := String.Set.empty; + imported_opaque_units := String.Set.empty; + Consistbl.clear crc_units; + can_load_cmis := Can_load_cmis; + short_paths_basis := Short_paths.Basis.create (); + () + +let clear_missing {persistent_structures; _} = + let missing_entries = + Hashtbl.fold + (fun name r acc -> if r = Missing then name :: acc else acc) + persistent_structures [] + in + List.iter (Hashtbl.remove persistent_structures) missing_entries + +let add_import {imported_units; _} s = + imported_units := String.Set.add s !imported_units + +let register_import_as_opaque {imported_opaque_units; _} s = + imported_opaque_units := String.Set.add s !imported_opaque_units + +let find_in_cache {persistent_structures; _} s = + match Hashtbl.find persistent_structures s with + | exception Not_found -> None + | Missing -> None + | Found (_ps, pm) -> Some pm + +let import_crcs penv ~source crcs = + let {crc_units; _} = penv in + let import_crc (name, crco) = + match crco with + | None -> () + | Some crc -> + add_import penv name; + Consistbl.check crc_units name crc source + in List.iter import_crc crcs + +let check_consistency penv ps = + try import_crcs penv ~source:ps.ps_filename ps.ps_crcs + with Consistbl.Inconsistency { + unit_name = name; + inconsistent_source = source; + original_source = auth; + } -> + error (Inconsistent_import(name, auth, source)) + +let can_load_cmis penv = + !(penv.can_load_cmis) +let set_can_load_cmis penv setting = + penv.can_load_cmis := setting +let short_paths_basis penv = + !(penv.short_paths_basis) + +let without_cmis penv f x = + let log = Lazy_backtrack.log () in + let res = + Misc.(protect_refs + [R (penv.can_load_cmis, Cannot_load_cmis log)] + (fun () -> f x)) + in + Lazy_backtrack.backtrack log; + res + +let fold {persistent_structures; _} f x = + Hashtbl.fold (fun modname pso x -> match pso with + | Missing -> x + | Found (_, pm) -> f modname pm x) + persistent_structures x + +let register_pers_for_short_paths penv ps components = + let deps, alias_deps = + List.fold_left + (fun (deps, alias_deps) (name, digest) -> + Short_paths.Basis.add (short_paths_basis penv) name; + match digest with + | None -> deps, name :: alias_deps + | Some _ -> name :: deps, alias_deps) + ([], []) ps.ps_crcs + in + let desc = + Short_paths.Desc.Module.(Fresh (Signature components)) + in + let is_deprecated = + List.exists + (function + | Alerts alerts -> + String.Map.mem "deprecated" alerts || + String.Map.mem "ocaml.deprecated" alerts + | _ -> false) + ps.ps_flags + in + let deprecated = + if is_deprecated then Short_paths.Desc.Deprecated + else Short_paths.Desc.Not_deprecated + in + Short_paths.Basis.load (short_paths_basis penv) ps.ps_name + deps alias_deps desc deprecated +(* Reading persistent structures from .cmi files *) + +let save_pers_struct penv crc ps pm = + let {persistent_structures; crc_units; _} = penv in + let modname = ps.ps_name in + Hashtbl.add persistent_structures modname (Found (ps, pm)); + List.iter + (function + | Rectypes -> () + | Alerts _ -> () + | Opaque -> register_import_as_opaque penv modname) + ps.ps_flags; + Consistbl.check crc_units modname crc ps.ps_filename; + add_import penv modname + +let acknowledge_pers_struct penv short_path_comps check modname pers_sig pm = + let { Persistent_signature.filename; cmi } = pers_sig in + let name = cmi.cmi_name in + let crcs = cmi.cmi_crcs in + let flags = cmi.cmi_flags in + let ps = { ps_name = name; + ps_crcs = crcs; + ps_filename = filename; + ps_flags = flags; + } in + if ps.ps_name <> modname then + error (Illegal_renaming(modname, ps.ps_name, filename)); + List.iter + (function + | Rectypes -> + if not !Clflags.recursive_types then + error (Need_recursive_types(ps.ps_name)) + | Alerts _ -> () + | Opaque -> register_import_as_opaque penv modname) + ps.ps_flags; + if check then check_consistency penv ps; + let {persistent_structures; _} = penv in + Hashtbl.add persistent_structures modname (Found (ps, pm)); + register_pers_for_short_paths penv ps (short_path_comps ps.ps_name pm); + ps + +let read_pers_struct penv val_of_pers_sig short_path_comps check modname filename = + add_import penv modname; + let cmi = Cmi_cache.read filename in + let pers_sig = { Persistent_signature.filename; cmi } in + let pm = val_of_pers_sig pers_sig in + let ps = acknowledge_pers_struct penv short_path_comps check modname pers_sig pm in + (ps, pm) + +let find_pers_struct penv val_of_pers_sig short_path_comps check name = + let {persistent_structures; _} = penv in + if name = "*predef*" then raise Not_found; + match Hashtbl.find persistent_structures name with + | Found (ps, pm) -> (ps, pm) + | Missing -> raise Not_found + | exception Not_found -> + match can_load_cmis penv with + | Cannot_load_cmis _ -> raise Not_found + | Can_load_cmis -> + let psig = + match !Persistent_signature.load ~unit_name:name with + | Some psig -> psig + | None -> + Hashtbl.add persistent_structures name Missing; + raise Not_found + in + add_import penv name; + let pm = val_of_pers_sig psig in + let ps = acknowledge_pers_struct penv short_path_comps check name psig pm in + (ps, pm) + +(* Emits a warning if there is no valid cmi for name *) +let check_pers_struct penv f1 f2 ~loc name = + try + ignore (find_pers_struct penv f1 f2 false name) + with + | Not_found -> + let warn = Warnings.No_cmi_file(name, None) in + Location.prerr_warning loc warn + | Magic_numbers.Cmi.Error err -> + let msg = Format.asprintf "%a" Magic_numbers.Cmi.report_error err in + let warn = Warnings.No_cmi_file(name, Some msg) in + Location.prerr_warning loc warn + | Error err -> + let msg = + match err with + | Illegal_renaming(name, ps_name, filename) -> + Format.asprintf + " %a@ contains the compiled interface for @ \ + %s when %s was expected" + Location.print_filename filename ps_name name + | Inconsistent_import _ -> assert false + | Need_recursive_types name -> + Format.sprintf + "%s uses recursive types" + name + in + let warn = Warnings.No_cmi_file(name, Some msg) in + Location.prerr_warning loc warn + +let read penv f1 f2 modname filename = + snd (read_pers_struct penv f1 f2 true modname filename) + +let find penv f1 f2 name = + snd (find_pers_struct penv f1 f2 true name) + +let check penv f1 f2 ~loc name = + let {persistent_structures; _} = penv in + if not (Hashtbl.mem persistent_structures name) then begin + (* PR#6843: record the weak dependency ([add_import]) regardless of + whether the check succeeds, to help make builds more + deterministic. *) + add_import penv name; + if (Warnings.is_active (Warnings.No_cmi_file("", None))) then + !add_delayed_check_forward + (fun () -> check_pers_struct penv f1 f2 ~loc name) + end + +let crc_of_unit penv f1 f2 name = + let (ps, _pm) = find_pers_struct penv f1 f2 true name in + let crco = + try + List.assoc name ps.ps_crcs + with Not_found -> + assert false + in + match crco with + None -> assert false + | Some crc -> crc + +let imports {imported_units; crc_units; _} = + Consistbl.extract (String.Set.elements !imported_units) crc_units + +let looked_up {persistent_structures; _} modname = + Hashtbl.mem persistent_structures modname + +let is_imported {imported_units; _} s = + String.Set.mem s !imported_units + +let is_imported_opaque {imported_opaque_units; _} s = + String.Set.mem s !imported_opaque_units + +let make_cmi penv modname sign alerts = + let flags = + List.concat [ + if !Clflags.recursive_types then [Cmi_format.Rectypes] else []; + if !Clflags.opaque then [Cmi_format.Opaque] else []; + [Alerts alerts]; + ] + in + let crcs = imports penv in + { + cmi_name = modname; + cmi_sign = sign; + cmi_crcs = crcs; + cmi_flags = flags + } + +let save_cmi penv psig pm = + let { Persistent_signature.filename; cmi } = psig in + Misc.try_finally (fun () -> + let { + cmi_name = modname; + cmi_sign = _; + cmi_crcs = imports; + cmi_flags = flags; + } = cmi in + let crc = + output_to_file_via_temporary (* see MPR#7472, MPR#4991 *) + ~mode: [Open_binary] filename + (fun temp_filename oc -> output_cmi temp_filename oc cmi) in + (* Enter signature in persistent table so that imports() + will also return its crc *) + let ps = + { ps_name = modname; + ps_crcs = (cmi.cmi_name, Some crc) :: imports; + ps_filename = filename; + ps_flags = flags; + } in + save_pers_struct penv crc ps pm + ) + ~exceptionally:(fun () -> remove_file filename) + +let report_error ppf = + let open Format in + function + | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf + "Wrong file naming: %a@ contains the compiled interface for@ \ + %s when %s was expected" + Location.print_filename filename ps_name modname + | Inconsistent_import(name, source1, source2) -> fprintf ppf + "@[The files %a@ and %a@ \ + make inconsistent assumptions@ over interface %s@]" + Location.print_filename source1 Location.print_filename source2 name + | Need_recursive_types(import) -> + fprintf ppf + "@[Invalid import of %s, which uses recursive types.@ %s@]" + import "The compilation flag -rectypes is required" + +let () = + Location.register_error_of_exn + (function + | Error err -> + Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +(* helper for merlin *) + +let with_cmis penv f x = + Misc.(protect_refs + [R (penv.can_load_cmis, Can_load_cmis)] + (fun () -> f x)) + +let forall ~found ~missing t = + Std.Hashtbl.forall t.persistent_structures (fun name -> function + | Missing -> missing name + | Found (pers_struct, a) -> + found name pers_struct.ps_filename pers_struct.ps_name a + ) diff --git a/ocamlmerlin_mlx/ocaml/typing/persistent_env.mli b/ocamlmerlin_mlx/ocaml/typing/persistent_env.mli new file mode 100644 index 0000000..afcea8e --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/persistent_env.mli @@ -0,0 +1,119 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc + +module Consistbl : module type of struct + include Consistbl.Make (Misc.String) +end + +type error = + | Illegal_renaming of modname * modname * filepath + | Inconsistent_import of modname * filepath * filepath + | Need_recursive_types of modname + +exception Error of error + +val report_error: Format.formatter -> error -> unit + +module Persistent_signature : sig + type t = + { filename : string; (** Name of the file containing the signature. *) + cmi : Cmi_format.cmi_infos } + + (** Function used to load a persistent signature. The default is to look for + the .cmi file in the load path. This function can be overridden to load + it from memory, for instance to build a self-contained toplevel. *) + val load : (unit_name:string -> t option) ref +end + +type can_load_cmis = + | Can_load_cmis + | Cannot_load_cmis of Lazy_backtrack.log + +type 'a t + +val empty : unit -> 'a t + +val short_paths_basis : 'a t -> Short_paths.Basis.t + +val clear : 'a t -> unit +val clear_missing : 'a t -> unit + +val fold : 'a t -> (modname -> 'a -> 'b -> 'b) -> 'b -> 'b + +val read : 'a t -> (Persistent_signature.t -> 'a) + -> (string -> 'a -> Short_paths.Desc.Module.components Lazy.t) + -> modname -> filepath -> 'a +val find : 'a t -> (Persistent_signature.t -> 'a) + -> (string -> 'a -> Short_paths.Desc.Module.components Lazy.t) + -> modname -> 'a + +val find_in_cache : 'a t -> modname -> 'a option + +val check : 'a t -> (Persistent_signature.t -> 'a) + -> (string -> 'a -> Short_paths.Desc.Module.components Lazy.t) + -> loc:Location.t -> modname -> unit + +(* [looked_up penv md] checks if one has already tried + to read the signature for [md] in the environment + [penv] (it may have failed) *) +val looked_up : 'a t -> modname -> bool + +(* [is_imported penv md] checks if [md] has been successfully + imported in the environment [penv] *) +val is_imported : 'a t -> modname -> bool + +(* [is_imported_opaque penv md] checks if [md] has been imported + in [penv] as an opaque module *) +val is_imported_opaque : 'a t -> modname -> bool + +(* [register_import_as_opaque penv md] registers [md] in [penv] as an + opaque module *) +val register_import_as_opaque : 'a t -> modname -> unit + +val make_cmi : 'a t -> modname -> Types.signature -> alerts + -> Cmi_format.cmi_infos + +val save_cmi : 'a t -> Persistent_signature.t -> 'a -> unit + +val can_load_cmis : 'a t -> can_load_cmis +val set_can_load_cmis : 'a t -> can_load_cmis -> unit +val without_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c +(* [without_cmis penv f arg] applies [f] to [arg], but does not + allow [penv] to openi cmis during its execution *) + +(* may raise Consistbl.Inconsistency *) +val import_crcs : 'a t -> source:filepath -> crcs -> unit + +(* Return the set of compilation units imported, with their CRC *) +val imports : 'a t -> crcs + +(* Return the CRC of the interface of the given compilation unit *) +val crc_of_unit: 'a t -> (Persistent_signature.t -> 'a) + -> (string -> 'a -> Short_paths.Desc.Module.components Lazy.t) + -> modname -> Digest.t + +(* Forward declaration to break mutual recursion with Typecore. *) +val add_delayed_check_forward: ((unit -> unit) -> unit) ref + +(* helper for merlin *) +val with_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c + +val forall : + found:(modname -> filepath -> string -> 'a -> bool) -> + missing:(modname -> bool) -> + 'a t -> bool diff --git a/ocamlmerlin_mlx/ocaml/typing/predef.ml b/ocamlmerlin_mlx/ocaml/typing/predef.ml new file mode 100644 index 0000000..185825c --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/predef.ml @@ -0,0 +1,252 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Predefined type constructors (with special typing rules in typecore) *) + +open Path +open Types +open Btype + +let builtin_idents = ref [] + +let wrap create s = + let id = create s in + builtin_idents := (s, id) :: !builtin_idents; + id + +let ident_create = wrap Ident.create_predef + +let ident_int = ident_create "int" +and ident_char = ident_create "char" +and ident_bytes = ident_create "bytes" +and ident_float = ident_create "float" +and ident_bool = ident_create "bool" +and ident_unit = ident_create "unit" +and ident_exn = ident_create "exn" +and ident_array = ident_create "array" +and ident_list = ident_create "list" +and ident_option = ident_create "option" +and ident_nativeint = ident_create "nativeint" +and ident_int32 = ident_create "int32" +and ident_int64 = ident_create "int64" +and ident_lazy_t = ident_create "lazy_t" +and ident_string = ident_create "string" +and ident_extension_constructor = ident_create "extension_constructor" +and ident_floatarray = ident_create "floatarray" + +let path_int = Pident ident_int +and path_char = Pident ident_char +and path_bytes = Pident ident_bytes +and path_float = Pident ident_float +and path_bool = Pident ident_bool +and path_unit = Pident ident_unit +and path_exn = Pident ident_exn +and path_array = Pident ident_array +and path_list = Pident ident_list +and path_option = Pident ident_option +and path_nativeint = Pident ident_nativeint +and path_int32 = Pident ident_int32 +and path_int64 = Pident ident_int64 +and path_lazy_t = Pident ident_lazy_t +and path_string = Pident ident_string +and path_extension_constructor = Pident ident_extension_constructor +and path_floatarray = Pident ident_floatarray + +let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) +and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) +and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil)) +and type_float = newgenty (Tconstr(path_float, [], ref Mnil)) +and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil)) +and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil)) +and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil)) +and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) +and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil)) +and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil)) +and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil)) +and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil)) +and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil)) +and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) +and type_string = newgenty (Tconstr(path_string, [], ref Mnil)) +and type_extension_constructor = + newgenty (Tconstr(path_extension_constructor, [], ref Mnil)) +and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil)) + +let ident_match_failure = ident_create "Match_failure" +and ident_out_of_memory = ident_create "Out_of_memory" +and ident_invalid_argument = ident_create "Invalid_argument" +and ident_failure = ident_create "Failure" +and ident_not_found = ident_create "Not_found" +and ident_sys_error = ident_create "Sys_error" +and ident_end_of_file = ident_create "End_of_file" +and ident_division_by_zero = ident_create "Division_by_zero" +and ident_stack_overflow = ident_create "Stack_overflow" +and ident_sys_blocked_io = ident_create "Sys_blocked_io" +and ident_assert_failure = ident_create "Assert_failure" +and ident_undefined_recursive_module = + ident_create "Undefined_recursive_module" + +let all_predef_exns = [ + ident_match_failure; + ident_out_of_memory; + ident_invalid_argument; + ident_failure; + ident_not_found; + ident_sys_error; + ident_end_of_file; + ident_division_by_zero; + ident_stack_overflow; + ident_sys_blocked_io; + ident_assert_failure; + ident_undefined_recursive_module; +] + +let path_match_failure = Pident ident_match_failure +and path_assert_failure = Pident ident_assert_failure +and path_undefined_recursive_module = Pident ident_undefined_recursive_module + +let cstr id args = + { + cd_id = id; + cd_args = Cstr_tuple args; + cd_res = None; + cd_loc = Location.none; + cd_attributes = []; + cd_uid = Uid.of_predef_id id; + } + +let ident_false = ident_create "false" +and ident_true = ident_create "true" +and ident_void = ident_create "()" +and ident_nil = ident_create "[]" +and ident_cons = ident_create "::" +and ident_none = ident_create "None" +and ident_some = ident_create "Some" + +let mk_add_type add_type type_ident + ?manifest ?(immediate=Type_immediacy.Unknown) ?(kind=Type_abstract) env = + let decl = + {type_params = []; + type_arity = 0; + type_kind = kind; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = manifest; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_immediate = immediate; + type_unboxed_default = false; + type_uid = Uid.of_predef_id type_ident; + } + in + add_type type_ident decl env + +let build_initial_env add_type add_extension empty_env = + let add_type = mk_add_type add_type + and add_type1 type_ident + ~variance ~separability ?(kind=fun _ -> Type_abstract) env = + let param = newgenvar () in + let decl = + {type_params = [param]; + type_arity = 1; + type_kind = kind param; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = [variance]; + type_separability = [separability]; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.of_predef_id type_ident; + } + in + add_type type_ident decl env + in + let add_extension id l = + add_extension id + { ext_type_path = path_exn; + ext_type_params = []; + ext_args = Cstr_tuple l; + ext_ret_type = None; + ext_private = Asttypes.Public; + ext_loc = Location.none; + ext_attributes = [Ast_helper.Attr.mk + (Location.mknoloc "ocaml.warn_on_literal_pattern") + (Parsetree.PStr [])]; + ext_uid = Uid.of_predef_id id; + } + in + let variant constrs = Type_variant (constrs, Variant_regular) in + empty_env + (* Predefined types - alphabetical order *) + |> add_type1 ident_array + ~variance:Variance.full + ~separability:Separability.Ind + |> add_type ident_bool + ~immediate:Always + ~kind:(variant [cstr ident_false []; cstr ident_true []]) + |> add_type ident_char ~immediate:Always + |> add_type ident_exn ~kind:Type_open + |> add_type ident_extension_constructor + |> add_type ident_float + |> add_type ident_floatarray + |> add_type ident_int ~immediate:Always + |> add_type ident_int32 + |> add_type ident_int64 + |> add_type1 ident_lazy_t + ~variance:Variance.covariant + ~separability:Separability.Ind + |> add_type1 ident_list + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]) + |> add_type ident_nativeint + |> add_type1 ident_option + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_none []; cstr ident_some [tvar]]) + |> add_type ident_string + |> add_type ident_bytes + |> add_type ident_unit + ~immediate:Always + ~kind:(variant [cstr ident_void []]) + (* Predefined exceptions - alphabetical order *) + |> add_extension ident_assert_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_division_by_zero [] + |> add_extension ident_end_of_file [] + |> add_extension ident_failure [type_string] + |> add_extension ident_invalid_argument [type_string] + |> add_extension ident_match_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_not_found [] + |> add_extension ident_out_of_memory [] + |> add_extension ident_stack_overflow [] + |> add_extension ident_sys_blocked_io [] + |> add_extension ident_sys_error [type_string] + |> add_extension ident_undefined_recursive_module + [newgenty (Ttuple[type_string; type_int; type_int])] + +let builtin_values = + List.map (fun id -> (Ident.name id, id)) all_predef_exns + +let builtin_idents = List.rev !builtin_idents diff --git a/ocamlmerlin_mlx/ocaml/typing/predef.mli b/ocamlmerlin_mlx/ocaml/typing/predef.mli new file mode 100644 index 0000000..ff67206 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/predef.mli @@ -0,0 +1,89 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Predefined type constructors (with special typing rules in typecore) *) + +open Types + +val ident_bytes: Ident.t + +val type_int: type_expr +val type_char: type_expr +val type_string: type_expr +val type_bytes: type_expr +val type_float: type_expr +val type_bool: type_expr +val type_unit: type_expr +val type_exn: type_expr +val type_array: type_expr -> type_expr +val type_list: type_expr -> type_expr +val type_option: type_expr -> type_expr +val type_nativeint: type_expr +val type_int32: type_expr +val type_int64: type_expr +val type_lazy_t: type_expr -> type_expr +val type_extension_constructor:type_expr +val type_floatarray:type_expr + +val path_int: Path.t +val path_char: Path.t +val path_string: Path.t +val path_bytes: Path.t +val path_float: Path.t +val path_bool: Path.t +val path_unit: Path.t +val path_exn: Path.t +val path_array: Path.t +val path_list: Path.t +val path_option: Path.t +val path_nativeint: Path.t +val path_int32: Path.t +val path_int64: Path.t +val path_lazy_t: Path.t +val path_extension_constructor: Path.t +val path_floatarray: Path.t + +val path_match_failure: Path.t +val path_assert_failure : Path.t +val path_undefined_recursive_module : Path.t + +val ident_false : Ident.t +val ident_true : Ident.t +val ident_void : Ident.t +val ident_nil : Ident.t +val ident_cons : Ident.t +val ident_none : Ident.t +val ident_some : Ident.t + +(* To build the initial environment. Since there is a nasty mutual + recursion between predef and env, we break it by parameterizing + over Env.t, Env.add_type and Env.add_extension. *) + +val build_initial_env: + (Ident.t -> type_declaration -> 'a -> 'a) -> + (Ident.t -> extension_constructor -> 'a -> 'a) -> + 'a -> 'a + +(* To initialize linker tables *) + +val builtin_values: (string * Ident.t) list +val builtin_idents: (string * Ident.t) list + +(** All predefined exceptions, exposed as [Ident.t] for flambda (for + building value approximations). + The [Ident.t] for division by zero is also exported explicitly + so flambda can generate code to raise it. *) +val ident_division_by_zero: Ident.t +val all_predef_exns : Ident.t list diff --git a/ocamlmerlin_mlx/ocaml/typing/primitive.ml b/ocamlmerlin_mlx/ocaml/typing/primitive.ml new file mode 100644 index 0000000..bf4fe83 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/primitive.ml @@ -0,0 +1,251 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Description of primitive functions *) + +open Misc +open Parsetree + +type boxed_integer = Pnativeint | Pint32 | Pint64 + +type native_repr = + | Same_as_ocaml_repr + | Unboxed_float + | Unboxed_integer of boxed_integer + | Untagged_int + +type description = + { prim_name: string; (* Name of primitive or C function *) + prim_arity: int; (* Number of arguments *) + prim_alloc: bool; (* Does it allocates or raise? *) + prim_native_name: string; (* Name of C function for the nat. code gen. *) + prim_native_repr_args: native_repr list; + prim_native_repr_res: native_repr } + +type error = + | Old_style_float_with_native_repr_attribute + | Old_style_noalloc_with_noalloc_attribute + | No_native_primitive_with_repr_attribute + +exception Error of Location.t * error + +let is_ocaml_repr = function + | Same_as_ocaml_repr -> true + | Unboxed_float + | Unboxed_integer _ + | Untagged_int -> false + +let is_unboxed = function + | Same_as_ocaml_repr + | Untagged_int -> false + | Unboxed_float + | Unboxed_integer _ -> true + +let is_untagged = function + | Untagged_int -> true + | Same_as_ocaml_repr + | Unboxed_float + | Unboxed_integer _ -> false + +let rec make_native_repr_args arity x = + if arity = 0 then + [] + else + x :: make_native_repr_args (arity - 1) x + +let simple ~name ~arity ~alloc = + {prim_name = name; + prim_arity = arity; + prim_alloc = alloc; + prim_native_name = ""; + prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr; + prim_native_repr_res = Same_as_ocaml_repr} + +let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res = + {prim_name = name; + prim_arity = List.length native_repr_args; + prim_alloc = alloc; + prim_native_name = native_name; + prim_native_repr_args = native_repr_args; + prim_native_repr_res = native_repr_res} + +let parse_declaration valdecl ~native_repr_args ~native_repr_res = + let arity = List.length native_repr_args in + let name, native_name, old_style_noalloc, old_style_float = + match valdecl.pval_prim with + | name :: "noalloc" :: name2 :: "float" :: _ -> (name, name2, true, true) + | name :: "noalloc" :: name2 :: _ -> (name, name2, true, false) + | name :: name2 :: "float" :: _ -> (name, name2, false, true) + | name :: "noalloc" :: _ -> (name, "", true, false) + | name :: name2 :: _ -> (name, name2, false, false) + | name :: _ -> (name, "", false, false) + | [] -> + fatal_error "Primitive.parse_declaration" + in + let noalloc_attribute = + Attr_helper.has_no_payload_attribute ["noalloc"; "ocaml.noalloc"] + valdecl.pval_attributes + in + if old_style_float && + not (List.for_all is_ocaml_repr native_repr_args && + is_ocaml_repr native_repr_res) then + raise (Error (valdecl.pval_loc, + Old_style_float_with_native_repr_attribute)); + if old_style_noalloc && noalloc_attribute then + raise (Error (valdecl.pval_loc, + Old_style_noalloc_with_noalloc_attribute)); + (* The compiler used to assume "noalloc" with "float", we just make this + explicit now (GPR#167): *) + let old_style_noalloc = old_style_noalloc || old_style_float in + if old_style_float then + Location.deprecated valdecl.pval_loc + "[@@unboxed] + [@@noalloc] should be used\n\ + instead of \"float\"" + else if old_style_noalloc then + Location.deprecated valdecl.pval_loc + "[@@noalloc] should be used instead of \"noalloc\""; + if native_name = "" && + not (List.for_all is_ocaml_repr native_repr_args && + is_ocaml_repr native_repr_res) then + raise (Error (valdecl.pval_loc, + No_native_primitive_with_repr_attribute)); + let noalloc = old_style_noalloc || noalloc_attribute in + let native_repr_args, native_repr_res = + if old_style_float then + (make_native_repr_args arity Unboxed_float, Unboxed_float) + else + (native_repr_args, native_repr_res) + in + {prim_name = name; + prim_arity = arity; + prim_alloc = not noalloc; + prim_native_name = native_name; + prim_native_repr_args = native_repr_args; + prim_native_repr_res = native_repr_res} + +open Outcometree + +let rec add_native_repr_attributes ty attrs = + match ty, attrs with + | Otyp_arrow (label, a, b), attr_opt :: rest -> + let b = add_native_repr_attributes b rest in + let a = + match attr_opt with + | None -> a + | Some attr -> Otyp_attribute (a, attr) + in + Otyp_arrow (label, a, b) + | _, [Some attr] -> Otyp_attribute (ty, attr) + | _ -> + assert (List.for_all (fun x -> x = None) attrs); + ty + +let oattr_unboxed = { oattr_name = "unboxed" } +let oattr_untagged = { oattr_name = "untagged" } +let oattr_noalloc = { oattr_name = "noalloc" } + +let print p osig_val_decl = + let prims = + if p.prim_native_name <> "" then + [p.prim_name; p.prim_native_name] + else + [p.prim_name] + in + let for_all f = + List.for_all f p.prim_native_repr_args && f p.prim_native_repr_res + in + let all_unboxed = for_all is_unboxed in + let all_untagged = for_all is_untagged in + let attrs = if p.prim_alloc then [] else [oattr_noalloc] in + let attrs = + if all_unboxed then + oattr_unboxed :: attrs + else if all_untagged then + oattr_untagged :: attrs + else + attrs + in + let attr_of_native_repr = function + | Same_as_ocaml_repr -> None + | Unboxed_float + | Unboxed_integer _ -> if all_unboxed then None else Some oattr_unboxed + | Untagged_int -> if all_untagged then None else Some oattr_untagged + in + let type_attrs = + List.map attr_of_native_repr p.prim_native_repr_args @ + [attr_of_native_repr p.prim_native_repr_res] + in + { osig_val_decl with + oval_prims = prims; + oval_type = add_native_repr_attributes osig_val_decl.oval_type type_attrs; + oval_attributes = attrs } + +let native_name p = + if p.prim_native_name <> "" + then p.prim_native_name + else p.prim_name + +let byte_name p = + p.prim_name + +let equal_boxed_integer bi1 bi2 = + match bi1, bi2 with + | Pnativeint, Pnativeint + | Pint32, Pint32 + | Pint64, Pint64 -> + true + | (Pnativeint | Pint32 | Pint64), _ -> + false + +let equal_native_repr nr1 nr2 = + match nr1, nr2 with + | Same_as_ocaml_repr, Same_as_ocaml_repr -> true + | Same_as_ocaml_repr, + (Unboxed_float | Unboxed_integer _ | Untagged_int) -> false + | Unboxed_float, Unboxed_float -> true + | Unboxed_float, + (Same_as_ocaml_repr | Unboxed_integer _ | Untagged_int) -> false + | Unboxed_integer bi1, Unboxed_integer bi2 -> equal_boxed_integer bi1 bi2 + | Unboxed_integer _, + (Same_as_ocaml_repr | Unboxed_float | Untagged_int) -> false + | Untagged_int, Untagged_int -> true + | Untagged_int, + (Same_as_ocaml_repr | Unboxed_float | Unboxed_integer _) -> false + +let native_name_is_external p = + let nat_name = native_name p in + nat_name <> "" && nat_name.[0] <> '%' + +let report_error ppf err = + match err with + | Old_style_float_with_native_repr_attribute -> + Format.fprintf ppf "Cannot use \"float\" in conjunction with \ + [%@unboxed]/[%@untagged]." + | Old_style_noalloc_with_noalloc_attribute -> + Format.fprintf ppf "Cannot use \"noalloc\" in conjunction with \ + [%@%@noalloc]." + | No_native_primitive_with_repr_attribute -> + Format.fprintf ppf + "[@The native code version of the primitive is mandatory@ \ + when attributes [%@untagged] or [%@unboxed] are present.@]" + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error err) + | _ -> + None + ) diff --git a/ocamlmerlin_mlx/ocaml/typing/primitive.mli b/ocamlmerlin_mlx/ocaml/typing/primitive.mli new file mode 100644 index 0000000..e8376ad --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/primitive.mli @@ -0,0 +1,79 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Description of primitive functions *) + +type boxed_integer = Pnativeint | Pint32 | Pint64 + +(* Representation of arguments/result for the native code version + of a primitive *) +type native_repr = + | Same_as_ocaml_repr + | Unboxed_float + | Unboxed_integer of boxed_integer + | Untagged_int + +type description = private + { prim_name: string; (* Name of primitive or C function *) + prim_arity: int; (* Number of arguments *) + prim_alloc: bool; (* Does it allocates or raise? *) + prim_native_name: string; (* Name of C function for the nat. code gen. *) + prim_native_repr_args: native_repr list; + prim_native_repr_res: native_repr } + +(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *) + +val simple + : name:string + -> arity:int + -> alloc:bool + -> description + +val make + : name:string + -> alloc:bool + -> native_name:string + -> native_repr_args: native_repr list + -> native_repr_res: native_repr + -> description + +val parse_declaration + : Parsetree.value_description + -> native_repr_args:native_repr list + -> native_repr_res:native_repr + -> description + +val print + : description + -> Outcometree.out_val_decl + -> Outcometree.out_val_decl + +val native_name: description -> string +val byte_name: description -> string + +val equal_boxed_integer : boxed_integer -> boxed_integer -> bool +val equal_native_repr : native_repr -> native_repr -> bool + +(** [native_name_is_externa] returns [true] iff the [native_name] for the + given primitive identifies that the primitive is not implemented in the + compiler itself. *) +val native_name_is_external : description -> bool + +type error = + | Old_style_float_with_native_repr_attribute + | Old_style_noalloc_with_noalloc_attribute + | No_native_primitive_with_repr_attribute + +exception Error of Location.t * error diff --git a/ocamlmerlin_mlx/ocaml/typing/printpat.ml b/ocamlmerlin_mlx/ocaml/typing/printpat.ml new file mode 100644 index 0000000..64094b6 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/printpat.ml @@ -0,0 +1,169 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Values as patterns pretty printer *) + +open Asttypes +open Typedtree +open Types +open Format + +let is_cons = function +| {cstr_name = "::"} -> true +| _ -> false + +let pretty_const c = match c with +| Const_int i -> Printf.sprintf "%d" i +| Const_char c -> Printf.sprintf "%C" c +| Const_string (s, _, _) -> Printf.sprintf "%S" s +| Const_float f -> Printf.sprintf "%s" f +| Const_int32 i -> Printf.sprintf "%ldl" i +| Const_int64 i -> Printf.sprintf "%LdL" i +| Const_nativeint i -> Printf.sprintf "%ndn" i + +let pretty_extra ppf (cstr, _loc, _attrs) pretty_rest rest = + match cstr with + | Tpat_unpack -> + fprintf ppf "@[(module %a)@]" pretty_rest rest + | Tpat_constraint _ -> + fprintf ppf "@[(%a : _)@]" pretty_rest rest + | Tpat_type _ -> + fprintf ppf "@[(# %a)@]" pretty_rest rest + | Tpat_open _ -> + fprintf ppf "@[(# %a)@]" pretty_rest rest + +let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> + match v.pat_extra with + | extra :: rem -> + pretty_extra ppf extra + pretty_val { v with pat_extra = rem } + | [] -> + match v.pat_desc with + | Tpat_any -> fprintf ppf "_" + | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x) + | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) + | Tpat_tuple vs -> + fprintf ppf "@[(%a)@]" (pretty_vals ",") vs + | Tpat_construct (_, cstr, [], _) -> + fprintf ppf "%s" cstr.cstr_name + | Tpat_construct (_, cstr, [w], None) -> + fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w + | Tpat_construct (_, cstr, vs, vto) -> + let name = cstr.cstr_name in + begin match (name, vs, vto) with + ("::", [v1;v2], None) -> + fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2 + | (_, _, None) -> + fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs + | (_, _, Some ([], _t)) -> + fprintf ppf "@[<2>%s@ @[(%a : _)@]@]" name (pretty_vals ",") vs + | (_, _, Some (vl, _t)) -> + let vars = List.map (fun x -> Ident.name x.txt) vl in + fprintf ppf "@[<2>%s@ (type %s)@ @[(%a : _)@]@]" + name (String.concat " " vars) (pretty_vals ",") vs + end + | Tpat_variant (l, None, _) -> + fprintf ppf "`%s" l + | Tpat_variant (l, Some w, _) -> + fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w + | Tpat_record (lvs,_) -> + let filtered_lvs = List.filter + (function + | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) + | _ -> true) lvs in + begin match filtered_lvs with + | [] -> fprintf ppf "_" + | (_, lbl, _) :: q -> + let elision_mark ppf = + (* we assume that there is no label repetitions here *) + if Array.length lbl.lbl_all > 1 + List.length q then + fprintf ppf ";@ _@ " + else () in + fprintf ppf "@[{%a%t}@]" + pretty_lvals filtered_lvs elision_mark + end + | Tpat_array vs -> + fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs + | Tpat_lazy v -> + fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v + | Tpat_alias (v, x,_) -> + fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x + | Tpat_value v -> + fprintf ppf "%a" pretty_val (v :> pattern) + | Tpat_exception v -> + fprintf ppf "@[<2>exception@ %a@]" pretty_arg v + | Tpat_or _ -> + fprintf ppf "@[(%a)@]" pretty_or v + +and pretty_car ppf v = match v.pat_desc with +| Tpat_construct (_,cstr, [_ ; _], None) + when is_cons cstr -> + fprintf ppf "(%a)" pretty_val v +| _ -> pretty_val ppf v + +and pretty_cdr ppf v = match v.pat_desc with +| Tpat_construct (_,cstr, [v1 ; v2], None) + when is_cons cstr -> + fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 +| _ -> pretty_val ppf v + +and pretty_arg ppf v = match v.pat_desc with +| Tpat_construct (_,_,_::_,None) +| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v +| _ -> pretty_val ppf v + +and pretty_or : type k . _ -> k general_pattern -> _ = fun ppf v -> + match v.pat_desc with + | Tpat_or (v,w,_) -> + fprintf ppf "%a|@,%a" pretty_or v pretty_or w + | _ -> pretty_val ppf v + +and pretty_vals sep ppf = function + | [] -> () + | [v] -> pretty_val ppf v + | v::vs -> + fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs + +and pretty_lvals ppf = function + | [] -> () + | [_,lbl,v] -> + fprintf ppf "%s=%a" lbl.lbl_name pretty_val v + | (_, lbl,v)::rest -> + fprintf ppf "%s=%a;@ %a" + lbl.lbl_name pretty_val v pretty_lvals rest + +let top_pretty ppf v = + fprintf ppf "@[%a@]@?" pretty_val v + +let pretty_pat p = + top_pretty Format.str_formatter p ; + prerr_string (Format.flush_str_formatter ()) + +type 'k matrix = 'k general_pattern list list + +let pretty_line fmt = + List.iter (fun p -> + Format.fprintf fmt " <"; + top_pretty fmt p; + Format.fprintf fmt ">"; + ) + +let pretty_matrix fmt (pss : 'k matrix) = + Format.fprintf fmt "begin matrix\n" ; + List.iter (fun ps -> + pretty_line fmt ps ; + Format.fprintf fmt "\n" + ) pss; + Format.fprintf fmt "end matrix\n%!" diff --git a/ocamlmerlin_mlx/ocaml/typing/printpat.mli b/ocamlmerlin_mlx/ocaml/typing/printpat.mli new file mode 100644 index 0000000..1865a2a --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/printpat.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + + +val pretty_const + : Asttypes.constant -> string +val top_pretty + : Format.formatter -> 'k Typedtree.general_pattern -> unit +val pretty_pat + : 'k Typedtree.general_pattern -> unit +val pretty_line + : Format.formatter -> 'k Typedtree.general_pattern list -> unit +val pretty_matrix + : Format.formatter -> 'k Typedtree.general_pattern list list -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/printtyp.ml b/ocamlmerlin_mlx/ocaml/typing/printtyp.ml new file mode 100644 index 0000000..cba0d9c --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/printtyp.ml @@ -0,0 +1,2577 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Printing functions *) + +module M = Misc.String.Map +module S = Misc.String.Set + +open Misc +open Ctype +open Format +open Longident +open Path +open Asttypes +open Types +open Btype +open Outcometree + +(* Print a long identifier *) + +let rec longident ppf = function + | Lident s -> pp_print_string ppf s + | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s + | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2 + +let () = Env.print_longident := longident + +(* Print an identifier avoiding name collisions *) + +module Out_name = struct + let create x = { printed_name = x } + let print x = x.printed_name +end + +(** Some identifiers may require hiding when printing *) +type bound_ident = { hide:bool; ident:Ident.t } + +(* printing environment for path shortening and naming *) +let printing_env = ref Env.empty + +(* When printing, it is important to only observe the + current printing environment, without reading any new + cmi present on the file system *) +let in_printing_env f = Env.without_cmis f !printing_env + + type namespace = Shape.Sig_component_kind.t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + +module Namespace = struct + + let id = function + | Type -> 0 + | Module -> 1 + | Module_type -> 2 + | Class -> 3 + | Class_type -> 4 + | Extension_constructor | Value -> 5 + (* we do not handle those component *) + + let size = 1 + id Value + + + let pp ppf x = + Format.pp_print_string ppf (Shape.Sig_component_kind.to_string x) + + let lookup = + let to_lookup f lid = fst @@ in_printing_env (f (Lident lid)) in + function + | Some Type -> to_lookup Env.find_type_by_name + | Some Module -> to_lookup Env.find_module_by_name + | Some Module_type -> to_lookup Env.find_modtype_by_name + | Some Class -> to_lookup Env.find_class_by_name + | Some Class_type -> to_lookup Env.find_cltype_by_name + | None | Some(Value|Extension_constructor) -> fun _ -> raise Not_found + + let location namespace id = + let path = Path.Pident id in + try Some ( + match namespace with + | Some Type -> (in_printing_env @@ Env.find_type path).type_loc + | Some Module -> (in_printing_env @@ Env.find_module path).md_loc + | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc + | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc + | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc + | Some (Extension_constructor|Value) | None -> Location.none + ) with Not_found -> None + + let best_class_namespace = function + | Papply _ | Pdot _ -> Some Module + | Pextra_ty _ -> assert false (* Only in type path *) + | Pident c -> + match location (Some Class) c with + | Some _ -> Some Class + | None -> Some Class_type + +end + +(** {2 Conflicts printing} + Conflicts arise when multiple items are attributed the same name, + the following module stores the global conflict references and + provides the printing functions for explaining the source of + the conflicts. +*) +module Conflicts = struct + type explanation = + { kind: namespace; name:string; root_name:string; location:Location.t} + let explanations = ref M.empty + + let add namespace name id = + match Namespace.location (Some namespace) id with + | None -> () + | Some location -> + let explanation = + { kind = namespace; location; name; root_name=Ident.name id} + in + explanations := M.add name explanation !explanations + + let collect_explanation namespace id ~name = + let root_name = Ident.name id in + (* if [name] is of the form "root_name/%d", we register both + [id] and the identifier in scope for [root_name]. + *) + if root_name <> name && not (M.mem name !explanations) then + begin + add namespace name id; + if not (M.mem root_name !explanations) then + (* lookup the identifier in scope with name [root_name] and + add it too + *) + match Namespace.lookup (Some namespace) root_name with + | Pident root_id -> add namespace root_name root_id + | exception Not_found | _ -> () + end + + let pp_explanation ppf r= + Format.fprintf ppf "@[%a:@,Definition of %s %s@]" + Location.print_loc r.location + (Shape.Sig_component_kind.to_string r.kind) r.name + + let print_located_explanations ppf l = + Format.fprintf ppf "@[%a@]" (Format.pp_print_list pp_explanation) l + + let reset () = explanations := M.empty + let list_explanations () = + let c = !explanations in + reset (); + c |> M.bindings |> List.map snd |> List.sort Stdlib.compare + + + let print_toplevel_hint ppf l = + let conj ppf () = Format.fprintf ppf " and@ " in + let pp_namespace_plural ppf n = Format.fprintf ppf "%as" Namespace.pp n in + let root_names = List.map (fun r -> r.kind, r.root_name) l in + let unique_root_names = List.sort_uniq Stdlib.compare root_names in + let submsgs = Array.make Namespace.size [] in + let () = List.iter (fun (n,_ as x) -> + submsgs.(Namespace.id n) <- x :: submsgs.(Namespace.id n) + ) unique_root_names in + let pp_submsg ppf names = + match names with + | [] -> () + | [namespace, a] -> + Format.fprintf ppf + "@ \ + @[<2>@{Hint@}: The %a %s has been defined multiple times@ \ + in@ this@ toplevel@ session.@ \ + Some toplevel values still refer to@ old@ versions@ of@ this@ %a.\ + @ Did you try to redefine them?@]" + Namespace.pp namespace a Namespace.pp namespace + | (namespace, _) :: _ :: _ -> + Format.fprintf ppf + "@ \ + @[<2>@{Hint@}: The %a %a have been defined multiple times@ \ + in@ this@ toplevel@ session.@ \ + Some toplevel values still refer to@ old@ versions@ of@ those@ %a.\ + @ Did you try to redefine them?@]" + pp_namespace_plural namespace + Format.(pp_print_list ~pp_sep:conj pp_print_string) (List.map snd names) + pp_namespace_plural namespace in + Array.iter (pp_submsg ppf) submsgs + + let print_explanations ppf = + let ltop, l = + (* isolate toplevel locations, since they are too imprecise *) + let from_toplevel a = + a.location.Location.loc_start.Lexing.pos_fname = "//toplevel//" in + List.partition from_toplevel (list_explanations ()) + in + begin match l with + | [] -> () + | l -> Format.fprintf ppf "@,%a" print_located_explanations l + end; + (* if there are name collisions in a toplevel session, + display at least one generic hint by namespace *) + print_toplevel_hint ppf ltop + + let exists () = M.cardinal !explanations >0 +end + +module Naming_context = struct + +let enabled = ref true +let enable b = enabled := b + +(* Names bound in recursive definitions should be considered as bound + in the environment when printing identifiers but not when trying + to find shortest path. + For instance, if we define + [{ + module Avoid__me = struct + type t = A + end + type t = X + type u = [` A of t * t ] + module M = struct + type t = A of [ u | `B ] + type r = Avoid__me.t + end + }] + It is is important that in the definition of [t] that the outer type [t] is + printed as [t/2] reserving the name [t] to the type being defined in the + current recursive definition. + Contrarily, in the definition of [r], one should not shorten the + path [Avoid__me.t] to [r] until the end of the definition of [r]. + The [bound_in_recursion] bridges the gap between those two slightly different + notions of printing environment. +*) +let bound_in_recursion = ref M.empty + +(* When dealing with functor arguments, identity becomes fuzzy because the same + syntactic argument may be represented by different identifiers during the + error processing, we are thus disabling disambiguation on the argument name +*) +let fuzzy = ref S.empty +let with_arg id f = + protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f +let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy + +let with_hidden ids f = + let update m id = M.add (Ident.name id.ident) id.ident m in + let updated = List.fold_left update !bound_in_recursion ids in + protect_refs [ R(bound_in_recursion, updated )] f + +let human_id id index = + (* The identifier with index [k] is the (k+1)-th most recent identifier in + the printing environment. We print them as [name/(k+1)] except for [k=0] + which is printed as [name] rather than [name/1]. + *) + if index = 0 then + Ident.name id + else + let ordinal = index + 1 in + String.concat "/" [Ident.name id; string_of_int ordinal] + +let indexed_name namespace id = + let find namespace id env = match namespace with + | Type -> Env.find_type_index id env + | Module -> Env.find_module_index id env + | Module_type -> Env.find_modtype_index id env + | Class -> Env.find_class_index id env + | Class_type-> Env.find_cltype_index id env + | Value | Extension_constructor -> None + in + let index = + match M.find_opt (Ident.name id) !bound_in_recursion with + | Some rec_bound_id -> + (* the identifier name appears in the current group of recursive + definition *) + if Ident.same rec_bound_id id then + Some 0 + else + (* the current recursive definition shadows one more time the + previously existing identifier with the same name *) + Option.map succ (in_printing_env (find namespace id)) + | None -> + in_printing_env (find namespace id) + in + let index = + (* If [index] is [None] at this point, it might indicate that + the identifier id is not defined in the environment, while there + are other identifiers in scope that share the same name. + Currently, this kind of partially incoherent environment happens + within functor error messages where the left and right hand side + have a different views of the environment at the source level. + Printing the source-level by using a default index of `0` + seems like a reasonable compromise in this situation however.*) + Option.value index ~default:0 + in + human_id id index + +let ident_name namespace id = + match namespace, !enabled with + | None, _ | _, false -> Out_name.create (Ident.name id) + | Some namespace, true -> + if fuzzy_id namespace id then Out_name.create (Ident.name id) + else + let name = indexed_name namespace id in + Conflicts.collect_explanation namespace id ~name; + Out_name.create name +end +let ident_name = Naming_context.ident_name + +let ident ppf id = pp_print_string ppf + (Out_name.print (Naming_context.ident_name None id)) + +let namespaced_ident namespace id = + Out_name.print (Naming_context.ident_name (Some namespace) id) + + +(* Print a path *) + +let ident_stdlib = Ident.create_persistent "Stdlib" + +let non_shadowed_stdlib namespace = function + | Pdot(Pident id, s) as path -> + Ident.same id ident_stdlib && + (match Namespace.lookup namespace s with + | path' -> Path.same path path' + | exception Not_found -> true) + | _ -> false + +let find_double_underscore s = + let len = String.length s in + let rec loop i = + if i + 1 >= len then + None + else if s.[i] = '_' && s.[i + 1] = '_' then + Some i + else + loop (i + 1) + in + loop 0 + +let rec module_path_is_an_alias_of env path ~alias_of = + match Env.find_module path env with + | { md_type = Mty_alias path'; _ } -> + Path.same path' alias_of || + module_path_is_an_alias_of env path' ~alias_of + | _ -> false + | exception Not_found -> false + +(* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias + for Foo__bar. This pattern is used by the stdlib. *) +let rec rewrite_double_underscore_paths env p = + match p with + | Pdot (p, s) -> + Pdot (rewrite_double_underscore_paths env p, s) + | Papply (a, b) -> + Papply (rewrite_double_underscore_paths env a, + rewrite_double_underscore_paths env b) + | Pextra_ty (p, extra) -> + Pextra_ty (rewrite_double_underscore_paths env p, extra) + | Pident id -> + let name = Ident.name id in + match find_double_underscore name with + | None -> p + | Some i -> + let better_lid = + Ldot + (Lident (String.sub name 0 i), + String.capitalize_ascii + (String.sub name (i + 2) (String.length name - i - 2))) + in + match Env.find_module_by_name better_lid env with + | exception Not_found -> p + | p', _ -> + if module_path_is_an_alias_of env p' ~alias_of:p then + p' + else + p + +let rewrite_double_underscore_paths env p = + if env == Env.empty then + p + else + rewrite_double_underscore_paths env p + +let rec tree_of_path ?(disambiguation=true) namespace p = + let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in + let namespace = if disambiguation then namespace else None in + match p with + | Pident id -> + Oide_ident (ident_name namespace id) + | Pdot(_, s) as path when non_shadowed_stdlib namespace path -> + Oide_ident (Out_name.create s) + | Pdot(p, s) -> + Oide_dot (tree_of_path (Some Module) p, s) + | Papply(p1, p2) -> + let t1 = tree_of_path (Some Module) p1 in + let t2 = tree_of_path (Some Module) p2 in + Oide_apply (t1, t2) + | Pextra_ty (p, extra) -> begin + (* inline record types are syntactically prevented from escaping their + binding scope, and are never shown to users. *) + match extra with + Pcstr_ty s -> + Oide_dot (tree_of_path (Some Type) p, s) + | Pext_ty -> + tree_of_path None p + end + +let tree_of_path ?disambiguation namespace p = + tree_of_path ?disambiguation namespace + (rewrite_double_underscore_paths !printing_env p) + +let path ppf p = + !Oprint.out_ident ppf (tree_of_path None p) + +let string_of_path p = + Format.asprintf "%a" path p + +let strings_of_paths namespace p = + let trees = List.map (tree_of_path namespace) p in + List.map (Format.asprintf "%a" !Oprint.out_ident) trees + +let () = Env.print_path := path + +(* Print a recursive annotation *) + +let tree_of_rec = function + | Trec_not -> Orec_not + | Trec_first -> Orec_first + | Trec_next -> Orec_next + +(* Print a raw type expression, with sharing *) + +let raw_list pr ppf = function + [] -> fprintf ppf "[]" + | a :: l -> + fprintf ppf "@[<1>[%a%t]@]" pr a + (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) + +let kind_vars = ref [] +let kind_count = ref 0 + +let string_of_field_kind v = + match field_kind_repr v with + | Fpublic -> "Fpublic" + | Fabsent -> "Fabsent" + | Fprivate -> "Fprivate" + +let rec safe_repr v t = + match Transient_expr.coerce t with + {desc = Tlink t} when not (List.memq t v) -> + safe_repr (t::v) t + | t' -> t' + +let rec list_of_memo = function + Mnil -> [] + | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem + | Mlink rem -> list_of_memo !rem + +let print_name ppf = function + None -> fprintf ppf "None" + | Some name -> fprintf ppf "\"%s\"" name + +let string_of_label = function + Nolabel -> "" + | Labelled s -> s + | Optional s -> "?"^s + +let visited = ref [] +let rec raw_type ppf ty = + let ty = safe_repr [] ty in + if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin + visited := ty :: !visited; + fprintf ppf "@[<1>{id=%d;level=%d;scope=%d;desc=@,%a}@]" ty.id ty.level + ty.scope raw_type_desc ty.desc + end +and raw_type_list tl = raw_list raw_type tl +and raw_type_desc ppf = function + Tvar name -> fprintf ppf "Tvar %a" print_name name + | Tarrow(l,t1,t2,c) -> + fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" + (string_of_label l) raw_type t1 raw_type t2 + (if is_commu_ok c then "Cok" else "Cunknown") + | Ttuple tl -> + fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl + | Tconstr (p, tl, abbrev) -> + fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p + raw_type_list tl + (raw_list path) (list_of_memo !abbrev) + | Tobject (t, nm) -> + fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t + (fun ppf -> + match !nm with None -> fprintf ppf " None" + | Some(p,tl) -> + fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) + | Tfield (f, k, t1, t2) -> + fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f + (string_of_field_kind k) + raw_type t1 raw_type t2 + | Tnil -> fprintf ppf "Tnil" + | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t + | Tsubst (t, None) -> fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t + | Tsubst (t, Some t') -> + fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t' + | Tunivar name -> fprintf ppf "Tunivar %a" print_name name + | Tpoly (t, tl) -> + fprintf ppf "@[Tpoly(@,%a,@,%a)@]" + raw_type t + raw_type_list tl + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + fprintf ppf + "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]" + "row_fields=" + (raw_list (fun ppf (l, f) -> + fprintf ppf "@[%s,@ %a@]" l raw_field f)) + fields + "row_more=" raw_type more + "row_closed=" closed + "row_fixed=" raw_row_fixed fixed + "row_name=" + (fun ppf -> + match name with None -> fprintf ppf "None" + | Some(p,tl) -> + fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) + | Tpackage (p, fl) -> + fprintf ppf "@[Tpackage(@,%a@,%a)@]" path p + raw_type_list (List.map snd fl) +and raw_row_fixed ppf = function +| None -> fprintf ppf "None" +| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private" +| Some Types.Rigid -> fprintf ppf "Some Rigid" +| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t +| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p + +and raw_field ppf rf = + match_row_field + ~absent:(fun _ -> fprintf ppf "RFabsent") + ~present:(function + | None -> + fprintf ppf "RFpresent None" + | Some t -> + fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) + ~either:(fun c tl m e -> + fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c + raw_type_list tl m + (fun ppf -> + match e with None -> fprintf ppf " RFnone" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) + rf + +let raw_type_expr ppf t = + visited := []; kind_vars := []; kind_count := 0; + raw_type ppf t; + visited := []; kind_vars := [] + +let () = Btype.print_raw := raw_type_expr + +(* Normalize paths *) + +let set_printing_env env = + printing_env := + if !Clflags.real_paths then Env.empty + else env + +let wrap_printing_env env f = + set_printing_env (Env.update_short_paths env); + try_finally f ~always:(fun () -> set_printing_env Env.empty) + +let wrap_printing_env ?error:_ env f = + Env.without_cmis (wrap_printing_env env) f + +type type_result = Short_paths.type_result = + | Nth of int + | Path of int list option * Path.t + +type type_resolution = Short_paths.type_resolution = + | Nth of int + | Subst of int list + | Id + +let apply_subst ns args = + List.map (List.nth args) ns + +let apply_subst_opt nso args = + match nso with + | None -> args + | Some ns -> apply_subst ns args + +let apply_nth n args = + List.nth args n + +let best_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then Path(None, p) + else Short_paths.find_type (Env.short_paths !printing_env) p + +let best_type_path_resolution p = + if !Clflags.real_paths || !printing_env == Env.empty + then Id + else Short_paths.find_type_resolution (Env.short_paths !printing_env) p + +let best_type_path_simple p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_type_simple (Env.short_paths !printing_env) p + +let best_module_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_module_type (Env.short_paths !printing_env) p + +let best_module_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_module (Env.short_paths !printing_env) p + +let best_class_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then None, p + else Short_paths.find_class_type (Env.short_paths !printing_env) p + +let best_class_type_path_simple p = + if !Clflags.real_paths || !printing_env == Env.empty + then p + else Short_paths.find_class_type_simple (Env.short_paths !printing_env) p + +(* When building a tree for a best type path, we should not disambiguate + identifiers whenever the short-path algorithm detected a better path than + the original one.*) +let tree_of_best_type_path p p' = + if Path.same p p' then tree_of_path (Some Type) p' + else tree_of_path ~disambiguation:false None p' + +(* Print a type expression *) + +let proxy ty = Transient_expr.repr (proxy ty) + +(* When printing a type scheme, we print weak names. When printing a plain + type, we do not. This type controls that behavior *) +type type_or_scheme = Type | Type_scheme + +let is_non_gen mode ty = + match mode with + | Type_scheme -> is_Tvar ty && get_level ty <> generic_level + | Type -> false + +let nameable_row row = + row_name row <> None && + List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither(c, l, _) -> + row_closed row && if c then l = [] else List.length l = 1 + | _ -> true) + (row_fields row) + +(* This specialized version of [Btype.iter_type_expr] normalizes and + short-circuits the traversal of the [type_expr], so that it covers only the + subterms that would be printed by the type printer. *) +let printer_iter_type_expr f ty = + match get_desc ty with + | Tconstr(p, tyl, _) -> begin + match best_type_path_resolution p with + | Nth n -> + f (apply_nth n tyl) + | Subst ns -> + List.iter f (apply_subst ns tyl) + | Id -> + List.iter f tyl + end + | Tvariant row -> begin + match row_name row with + | Some(_p, tyl) when nameable_row row -> + List.iter f tyl + | _ -> + iter_row f row + end + | Tobject (fi, nm) -> begin + match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpublic then + f ty) + fields + | Some (_, l) -> + List.iter f (List.tl l) + end + | Tfield(_, kind, ty1, ty2) -> + if field_kind_repr kind = Fpublic then + f ty1; + f ty2 + | _ -> + Btype.iter_type_expr f ty + +module Names : sig + val reset_names : unit -> unit + + val add_named_vars : type_expr -> unit + val add_subst : (type_expr * type_expr) list -> unit + + val new_name : unit -> string + val new_var_name : non_gen:bool -> type_expr -> unit -> string + + val name_of_type : (unit -> string) -> transient_expr -> string + val check_name_of_type : non_gen:bool -> transient_expr -> unit + + val remove_names : transient_expr list -> unit + + val with_local_names : (unit -> 'a) -> 'a + + (* Refresh the weak variable map in the toplevel; for [print_items], which is + itself for the toplevel *) + val refresh_weak : unit -> unit +end = struct + (* We map from types to names, but not directly; we also store a substitution, + which maps from types to types. The lookup process is + "type -> apply substitution -> find name". The substitution is presumed to + be acyclic. *) + let names = ref ([] : (transient_expr * string) list) + let name_subst = ref ([] : (transient_expr * transient_expr) list) + let name_counter = ref 0 + let named_vars = ref ([] : string list) + let visited_for_named_vars = ref ([] : transient_expr list) + + let weak_counter = ref 1 + let weak_var_map = ref TypeMap.empty + let named_weak_vars = ref String.Set.empty + + let reset_names () = + names := []; + name_subst := []; + name_counter := 0; + named_vars := []; + visited_for_named_vars := [] + + let add_named_var tty = + match tty.desc with + Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else + named_vars := name :: !named_vars + | _ -> () + + let rec add_named_vars ty = + let tty = Transient_expr.repr ty in + let px = proxy ty in + if not (List.memq px !visited_for_named_vars) then begin + visited_for_named_vars := px :: !visited_for_named_vars; + match tty.desc with + | Tvar _ | Tunivar _ -> + add_named_var tty + | _ -> + printer_iter_type_expr add_named_vars ty + end + + let rec substitute ty = + match List.assq ty !name_subst with + | ty' -> substitute ty' + | exception Not_found -> ty + + let add_subst subst = + name_subst := + List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) + subst + @ !name_subst + + let name_is_already_used name = + List.mem name !named_vars + || List.exists (fun (_, name') -> name = name') !names + || String.Set.mem name !named_weak_vars + + let rec new_name () = + let name = + if !name_counter < 26 + then String.make 1 (Char.chr(97 + !name_counter)) + else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^ + Int.to_string(!name_counter / 26) in + incr name_counter; + if name_is_already_used name then new_name () else name + + let rec new_weak_name ty () = + let name = "weak" ^ Int.to_string !weak_counter in + incr weak_counter; + if name_is_already_used name then new_weak_name ty () + else begin + named_weak_vars := String.Set.add name !named_weak_vars; + weak_var_map := TypeMap.add ty name !weak_var_map; + name + end + + let new_var_name ~non_gen ty () = + if non_gen then new_weak_name ty () + else new_name () + + let name_of_type name_generator t = + (* We've already been through repr at this stage, so t is our representative + of the union-find class. *) + let t = substitute t in + try List.assq t !names with Not_found -> + try TransientTypeMap.find t !weak_var_map with Not_found -> + let name = + match t.desc with + Tvar (Some name) | Tunivar (Some name) -> + (* Some part of the type we've already printed has assigned another + * unification variable to that name. We want to keep the name, so + * try adding a number until we find a name that's not taken. *) + let available name = + List.for_all + (fun (_, name') -> name <> name') + !names + in + if available name then name + else + let suffixed i = name ^ Int.to_string i in + let i = Misc.find_first_mono (fun i -> available (suffixed i)) in + suffixed i + | _ -> + (* No name available, create a new one *) + name_generator () + in + (* Exception for type declarations *) + if name <> "_" then names := (t, name) :: !names; + name + + let check_name_of_type ~non_gen px = + let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in + ignore(name_of_type name_gen px) + + let remove_names tyl = + let tyl = List.map substitute tyl in + names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names + + let with_local_names f = + let old_names = !names in + let old_subst = !name_subst in + names := []; + name_subst := []; + try_finally + ~always:(fun () -> + names := old_names; + name_subst := old_subst) + f + + let refresh_weak () = + let refresh t name (m,s) = + if is_non_gen Type_scheme t then + begin + TypeMap.add t name m, + String.Set.add name s + end + else m, s in + let m, s = + TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty) in + named_weak_vars := s; + weak_var_map := m +end + +let reserve_names ty = + normalize_type ty; + Names.add_named_vars ty + +let visited_objects = ref ([] : transient_expr list) +let aliased = ref ([] : transient_expr list) +let delayed = ref ([] : transient_expr list) +let printed_aliases = ref ([] : transient_expr list) + +(* [printed_aliases] is a subset of [aliased] that records only those aliased + types that have actually been printed; this allows us to avoid naming loops + that the user will never see. *) + +let add_delayed t = + if not (List.memq t !delayed) then delayed := t :: !delayed + +let is_aliased_proxy px = List.memq px !aliased + +let add_alias_proxy px = + if not (is_aliased_proxy px) then + aliased := px :: !aliased + +let add_alias ty = add_alias_proxy (proxy ty) + +let add_printed_alias_proxy ~non_gen px = + Names.check_name_of_type ~non_gen px; + printed_aliases := px :: !printed_aliases + +let add_printed_alias ty = add_printed_alias_proxy (proxy ty) + +let aliasable ty = + match get_desc ty with + Tvar _ | Tunivar _ | Tpoly _ -> false + | Tconstr (p, _, _) -> begin + match best_type_path_resolution p with + | Nth _ -> false + | Subst _ | Id -> true + end + | _ -> true + +(* let namable_row row = + row.row_name <> None && + List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither(c, l, _, _) -> + row.row_closed && if c then l = [] else List.length l = 1 + | _ -> true) + row.row_fields *) +let should_visit_object ty = + match get_desc ty with + | Tvariant row -> not (static_row row) + | Tobject _ -> opened_object ty + | _ -> false + +(*let rec mark_loops_rec visited ty = + let ty = repr ty in + let px = proxy ty in + if List.memq px visited && aliasable ty then add_alias px else + let visited = px :: visited in + match ty.desc with + | Tvar _ -> add_named_var ty + | Tarrow(_, ty1, ty2, _) -> + mark_loops_rec visited ty1; mark_loops_rec visited ty2 + | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl + | Tconstr(p, tyl, _) -> begin + match best_type_path_resolution p with + | Nth n -> + mark_loops_rec visited (apply_nth n tyl) + | Subst ns -> + List.iter (mark_loops_rec visited) (apply_subst ns tyl) + | Id -> + List.iter (mark_loops_rec visited) tyl + end + | Tpackage (_, fl) -> + List.iter (fun (_n, ty) -> mark_loops_rec visited ty) fl + | Tvariant row -> + if List.memq px !visited_objects then add_alias px else + begin + let row = row_repr row in + if not (static_row row) then + visited_objects := px :: !visited_objects; + match row.row_name with + | Some(_p, tyl) when namable_row row -> + List.iter (mark_loops_rec visited) tyl + | _ -> + iter_row (mark_loops_rec visited) row + end + | Tobject (fi, nm) -> + if List.memq px !visited_objects then add_alias px else + begin + if opened_object ty then + visited_objects := px :: !visited_objects; + begin match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpresent then + mark_loops_rec visited ty) + fields + | Some (_, l) -> + List.iter (mark_loops_rec visited) (List.tl l) + end + end + | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> + mark_loops_rec visited ty1; mark_loops_rec visited ty2 + | Tfield(_, _, _, ty2) -> + mark_loops_rec visited ty2 + | Tnil -> () + | Tsubst _ -> () (* we do not print arguments *) + | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" + | Tpoly (ty, tyl) -> + List.iter (fun t -> add_alias t) tyl; + mark_loops_rec visited ty + | Tunivar _ -> add_named_var ty *) +let rec mark_loops_rec visited ty = + let px = proxy ty in + if List.memq px visited && aliasable ty then add_alias_proxy px else + let tty = Transient_expr.repr ty in + let visited = px :: visited in + match tty.desc with + | Tvariant _ | Tobject _ -> + if List.memq px !visited_objects then add_alias_proxy px else begin + if should_visit_object ty then + visited_objects := px :: !visited_objects; + printer_iter_type_expr (mark_loops_rec visited) ty + end + | Tpoly(ty, tyl) -> + List.iter add_alias tyl; + mark_loops_rec visited ty + | _ -> + printer_iter_type_expr (mark_loops_rec visited) ty +let mark_loops ty = + mark_loops_rec [] ty;; + +let prepare_type ty = + reserve_names ty; + mark_loops ty;; + +let reset_loop_marks () = + visited_objects := []; aliased := []; delayed := []; printed_aliases := [] + +let reset_except_context () = + Names.reset_names (); reset_loop_marks () + +let reset () = + Conflicts.reset (); + reset_except_context () + +let prepare_for_printing tyl = + reset_except_context (); + List.iter prepare_type tyl + +let add_type_to_preparation = prepare_type + +(* Disabled in classic mode when printing an unification error *) +let print_labels = ref true + +let alias_nongen_row mode px ty = + match get_desc ty with + | Tvariant _ | Tobject _ -> + if is_non_gen mode (Transient_expr.type_expr px) then + add_alias_proxy px + | _ -> () + +let rec tree_of_typexp mode ty = + let px = proxy ty in + if List.memq px !printed_aliases && not (List.memq px !delayed) then + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + let name = Names.name_of_type (Names.new_var_name ~non_gen ty) px in + Otyp_var (non_gen, name) else + + let pr_typ () = + let tty = Transient_expr.repr ty in + match tty.desc with + | Tvar _ -> + let non_gen = is_non_gen mode ty in + let name_gen = Names.new_var_name ~non_gen ty in + Otyp_var (non_gen, Names.name_of_type name_gen tty) + | Tarrow(l, ty1, ty2, _) -> + let lab = + if !print_labels || is_optional l then string_of_label l else "" + in + let t1 = + if is_optional l then + match get_desc ty1 with + | Tconstr(path, [ty], _) + when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty1 in + Otyp_arrow (lab, t1, tree_of_typexp mode ty2) + | Ttuple tyl -> + Otyp_tuple (tree_of_typlist mode tyl) + | Tconstr(p, tyl, _abbrev) -> begin + match best_type_path p with + | Nth n -> tree_of_typexp mode (apply_nth n tyl) + | Path(nso, p) -> + let tyl' = apply_subst_opt nso tyl in + Otyp_constr (tree_of_path (Some Type) p, tree_of_typlist mode tyl') + end + | Tvariant row -> + let Row {fields; name; closed; _} = row_repr row in + let fields = + if closed then + List.filter (fun (_, f) -> row_field_repr f <> Rabsent) + fields + else fields in + let present = + List.filter + (fun (_, f) -> + match row_field_repr f with + | Rpresent _ -> true + | _ -> false) + fields in + let all_present = List.length present = List.length fields in + begin match name with + | Some(p, tyl) when nameable_row row -> + let out_variant = + match best_type_path p with + | Nth n -> tree_of_typexp mode (apply_nth n tyl) + | Path(s, p) -> + let id = tree_of_path (Some Type) p in + let args = tree_of_typlist mode (apply_subst_opt s tyl) in + Otyp_constr (id, args) + in + if closed && all_present then + out_variant + else + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_typ out_variant, closed, tags) + | _ -> + let fields = List.map (tree_of_row_field mode) fields in + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_fields fields, closed, tags) + end + | Tobject (fi, nm) -> + tree_of_typobject mode fi !nm + | Tnil | Tfield _ -> + tree_of_typobject mode ty None + | Tsubst _ -> + (* This case should only happen when debugging the compiler *) + Otyp_stuff "" + | Tlink _ -> + fatal_error "Printtyp.tree_of_typexp" + | Tpoly (ty, []) -> + tree_of_typexp mode ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + if tyl = [] then tree_of_typexp mode ty else begin + let tyl = List.map Transient_expr.repr tyl in + let old_delayed = !delayed in + (* Make the names delayed, so that the real type is + printed once when used as proxy *) + List.iter add_delayed tyl; + let tl = List.map (Names.name_of_type Names.new_name) tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode ty) in + (* Forget names when we leave scope *) + Names.remove_names tyl; + delayed := old_delayed; tr + end + | Tunivar _ -> + Otyp_var (false, Names.name_of_type Names.new_name tty) + | Tpackage (p, fl) -> + let p = best_module_type_path p in + let fl = + List.map + (fun (li, ty) -> ( + String.concat "." (Longident.flatten li), + tree_of_typexp mode ty + )) fl in + Otyp_module (tree_of_path (Some Module_type) p, fl) + in + if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; + alias_nongen_row mode px ty; + if is_aliased_proxy px && aliasable ty then begin + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + add_printed_alias_proxy ~non_gen px; + (* add_printed_alias chose a name, thus the name generator + doesn't matter.*) + let alias = Names.name_of_type (Names.new_var_name ~non_gen ty) px in + Otyp_alias {non_gen; aliased = pr_typ (); alias } end + else pr_typ () + +and tree_of_row_field mode (l, f) = + match row_field_repr f with + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) + | Reither(c, tyl, _) -> + if c (* contradiction: constant constructor with an argument *) + then (l, true, tree_of_typlist mode tyl) + else (l, false, tree_of_typlist mode tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode) tyl + +and tree_of_typobject mode fi nm = + begin match nm with + | None -> + let pr_fields fi = + let (fields, rest) = flatten_fields fi in + let present_fields = + List.fold_right + (fun (n, k, t) l -> + match field_kind_repr k with + | Fpublic -> (n, t) :: l + | _ -> l) + fields [] in + let sorted_fields = + List.sort + (fun (n, _) (n', _) -> String.compare n n') present_fields in + tree_of_typfields mode rest sorted_fields in + let (fields, open_row) = pr_fields fi in + Otyp_object {fields; open_row} + | Some (p, _ty :: tyl) -> + let args = tree_of_typlist mode tyl in + let p' = best_type_path_simple p in + Otyp_class (tree_of_best_type_path p p', args) + | _ -> + fatal_error "Printtyp.tree_of_typobject" + end + +and tree_of_typfields mode rest = function + | [] -> + let open_row = + match get_desc rest with + | Tvar _ | Tunivar _ | Tconstr _-> true + | Tnil -> false + | _ -> fatal_error "typfields (1)" + in + ([], open_row) + | (s, t) :: l -> + let field = (s, tree_of_typexp mode t) in + let (fields, rest) = tree_of_typfields mode rest l in + (field :: fields, rest) + +let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + +let prepared_type_expr ppf ty = typexp Type ppf ty +let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty + +let type_expr ppf ty = + (* [type_expr] is used directly by error message printers, + we mark eventual loops ourself to avoid any misuse and stack overflow *) + prepare_for_printing [ty]; + prepared_type_expr ppf ty + +(* "Half-prepared" type expression: [ty] should have had its names reserved, but + should not have had its loops marked. *) +let type_expr_with_reserved_names ppf ty = + reset_loop_marks (); + mark_loops ty; + prepared_type_expr ppf ty + +let shared_type_scheme ppf ty = + prepare_type ty; + typexp Type_scheme ppf ty + +let type_scheme ppf ty = + prepare_for_printing [ty]; + prepared_type_scheme ppf ty + +let type_path ppf p = + let p = best_class_type_path_simple p in + let t = tree_of_path (Some Type) p in + !Oprint.out_ident ppf t + +let tree_of_type_scheme ty = + prepare_for_printing [ty]; + tree_of_typexp Type_scheme ty + +(* Print one type declaration *) + +let tree_of_constraints params = + List.fold_right + (fun ty list -> + let ty' = unalias ty in + if proxy ty != proxy ty' then + let tr = tree_of_typexp Type_scheme ty in + (tr, tree_of_typexp Type_scheme ty') :: list + else list) + params [] + +let filter_params tyl = + let params = + List.fold_left + (fun tyl ty -> + if List.exists (eq_type ty) tyl + then newty2 ~level:generic_level (Ttuple [ty]) :: tyl + else ty :: tyl) + (* Two parameters might be identical due to a constraint but we need to + print them differently in order to make the output syntactically valid. + We use [Ttuple [ty]] because it is printed as [ty]. *) + (* Replacing fold_left by fold_right does not work! *) + [] tyl + in List.rev params + +let prepare_type_constructor_arguments = function + | Cstr_tuple l -> List.iter prepare_type l + | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l + +let tree_of_label l = + (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type l.ld_type) + +let tree_of_constructor_arguments = function + | Cstr_tuple l -> tree_of_typlist Type l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] + +let tree_of_single_constructor cd = + let name = Ident.name cd.cd_id in + let ret = Option.map (tree_of_typexp Type) cd.cd_res in + let args = tree_of_constructor_arguments cd.cd_args in + { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +(* When printing GADT constructor, we need to forget the naming decision we took + for the type parameters and constraints. Indeed, in + {[ + type 'a t = X: 'a -> 'b t + ]} + It is fine to print both the type parameter ['a] and the existentially + quantified ['a] in the definition of the constructor X as ['a] + *) +let tree_of_constructor_in_decl cd = + match cd.cd_res with + | None -> tree_of_single_constructor cd + | Some _ -> Names.with_local_names (fun () -> tree_of_single_constructor cd) + +let prepare_decl id decl = + let params = filter_params decl.type_params in + begin match decl.type_manifest with + | Some ty -> + let vars = free_variables ty in + List.iter + (fun ty -> + if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + params + | None -> () + end; + List.iter add_alias params; + List.iter prepare_type params; + List.iter (add_printed_alias ~non_gen:false) params; + let ty_manifest = + match decl.type_manifest with + | None -> None + | Some ty -> + let ty = + (* Special hack to hide variant name *) + match get_desc ty with + Tvariant row -> + begin match row_name row with + Some (Pident id', _) when Ident.same id id' -> + newgenty (Tvariant (set_row_name row None)) + | _ -> ty + end + | _ -> ty + in + prepare_type ty; + Some ty + in + begin match decl.type_kind with + | Type_abstract -> () + | Type_variant (cstrs, _rep) -> + List.iter + (fun c -> + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) + cstrs + | Type_record(l, _rep) -> + List.iter (fun l -> prepare_type l.ld_type) l + | Type_open -> () + end; + ty_manifest, params + +let tree_of_type_decl id decl = + let ty_manifest, params = prepare_decl id decl in + let type_param = + function + | Otyp_var (_, id) -> id + | _ -> "?" + in + let type_defined decl = + let abstr = + match decl.type_kind with + Type_abstract -> + decl.type_manifest = None || decl.type_private = Private + | Type_record _ -> + decl.type_private = Private + | Type_variant (tll, _rep) -> + decl.type_private = Private || + List.exists (fun cd -> cd.cd_res <> None) tll + | Type_open -> + decl.type_manifest = None + in + let vari = + List.map2 + (fun ty v -> + let is_var = is_Tvar ty in + if abstr || not is_var then + let inj = + decl.type_kind = Type_abstract && Variance.mem Inj v && + match decl.type_manifest with + | None -> true + | Some ty -> (* only abstract or private row types *) + decl.type_private = Private && + Btype.is_constr_row ~allow_ident:true (Btype.row_of_type ty) + and (co, cn) = Variance.get_upper v in + (if not cn then Covariant else + if not co then Contravariant else NoVariance), + (if inj then Injective else NoInjectivity) + else (NoVariance, NoInjectivity)) + decl.type_params decl.type_variance + in + (Ident.name id, + List.map2 (fun ty cocn -> type_param (tree_of_typexp Type ty), cocn) + params vari) + in + let tree_of_manifest ty1 = + match ty_manifest with + | None -> ty1 + | Some ty -> Otyp_manifest (tree_of_typexp Type ty, ty1) + in + let (name, args) = type_defined decl in + let constraints = tree_of_constraints params in + let ty, priv, unboxed = + match decl.type_kind with + | Type_abstract -> + begin match ty_manifest with + | None -> (Otyp_abstract, Public, false) + | Some ty -> + tree_of_typexp Type ty, decl.type_private, false + end + | Type_variant (cstrs, rep) -> + tree_of_manifest + (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), + decl.type_private, + (rep = Variant_unboxed) + | Type_record(lbls, rep) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private, + (match rep with Record_unboxed _ -> true | _ -> false) + | Type_open -> + tree_of_manifest Otyp_open, + decl.type_private, + false + in + { otype_name = name; + otype_params = args; + otype_type = ty; + otype_private = priv; + otype_immediate = Type_immediacy.of_attributes decl.type_attributes; + otype_unboxed = unboxed; + otype_cstrs = constraints } + +let add_type_decl_to_preparation id decl = + ignore @@ prepare_decl id decl + +let tree_of_prepared_type_decl id decl = + tree_of_type_decl id decl + +let tree_of_type_decl id decl = + reset_except_context(); + tree_of_type_decl id decl + +let add_constructor_to_preparation c = + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res + +let prepared_constructor ppf c = + !Oprint.out_constr ppf (tree_of_single_constructor c) + +let constructor ppf c = + reset_except_context (); + add_constructor_to_preparation c; + prepared_constructor ppf c + +let label ppf l = + reset_except_context (); + prepare_type l.ld_type; + !Oprint.out_label ppf (tree_of_label l) + +let tree_of_type_declaration id decl rs = + Osig_type (tree_of_type_decl id decl, tree_of_rec rs) + +let tree_of_prepared_type_declaration id decl rs = + Osig_type (tree_of_prepared_type_decl id decl, tree_of_rec rs) + +let type_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) + +let add_type_declaration_to_preparation id decl = + add_type_decl_to_preparation id decl + +let prepared_type_declaration id ppf decl = + !Oprint.out_sig_item ppf + (tree_of_prepared_type_declaration id decl Trec_first) + +let constructor_arguments ppf a = + let tys = tree_of_constructor_arguments a in + !Oprint.out_type ppf (Otyp_tuple tys) + +(* Print an extension declaration *) + +let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type = + let ret = Option.map (tree_of_typexp Type) ext_ret_type in + let args = tree_of_constructor_arguments ext_args in + (args, ret) + +(* When printing extension constructor, it is important to ensure that +after printing the constructor, we are still in the scope of the constructor. +For GADT constructor, this can be done by printing the type parameters inside +their own isolated scope. This ensures that in +{[ + type 'b t += A: 'b -> 'b any t +]} +the type parameter `'b` is not bound when printing the type variable `'b` from +the constructor definition from the type parameter. + +Contrarily, for non-gadt constructor, we must keep the same scope for +the type parameters and the constructor because a type constraint may +have changed the name of the type parameter: +{[ +type -'a t = .. constraint 'a> = 'a +(* the universal 'a is here to steal the name 'a from the type parameter *) +type 'a t = X of 'a +]} *) + +let add_extension_constructor_to_preparation ext = + let ty_params = filter_params ext.ext_type_params in + List.iter add_alias ty_params; + List.iter prepare_type ty_params; + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type + +let prepared_tree_of_extension_constructor + id ext es + = + let type_path = best_type_path_simple ext.ext_type_path in + let ty_name = Path.name type_path in + let ty_params = filter_params ext.ext_type_params in + let type_param = + function + | Otyp_var (_, id) -> id + | _ -> "?" + in + let param_scope f = + match ext.ext_ret_type with + | None -> + (* normal constructor: same scope for parameters and the constructor *) + f () + | Some _ -> + (* gadt constructor: isolated scope for the type parameters *) + Names.with_local_names f + in + let ty_params = + param_scope + (fun () -> + List.iter (add_printed_alias ~non_gen:false) ty_params; + List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params + ) + in + let name = Ident.name id in + let args, ret = + extension_constructor_args_and_ret_type_subtree + ext.ext_args + ext.ext_ret_type + in + let ext = + { oext_name = name; + oext_type_name = ty_name; + oext_type_params = ty_params; + oext_args = args; + oext_ret_type = ret; + oext_private = ext.ext_private } + in + let es = + match es with + Text_first -> Oext_first + | Text_next -> Oext_next + | Text_exception -> Oext_exception + in + Osig_typext (ext, es) + +let tree_of_extension_constructor id ext es = + reset_except_context (); + add_extension_constructor_to_preparation ext; + prepared_tree_of_extension_constructor id ext es + +let extension_constructor id ppf ext = + !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) + +let prepared_extension_constructor id ppf ext = + !Oprint.out_sig_item ppf + (prepared_tree_of_extension_constructor id ext Text_first) + +let extension_only_constructor id ppf ext = + reset_except_context (); + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type; + let name = Ident.name id in + let args, ret = + extension_constructor_args_and_ret_type_subtree + ext.ext_args + ext.ext_ret_type + in + Format.fprintf ppf "@[%a@]" + !Oprint.out_constr { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +(* Print a value declaration *) + +let tree_of_value_description id decl = + (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) + let id = Ident.name id in + let ty = tree_of_type_scheme decl.val_type in + let vd = + { oval_name = id; + oval_type = ty; + oval_prims = []; + oval_attributes = [] } + in + let vd = + match decl.val_kind with + | Val_prim p -> Primitive.print p vd + | _ -> vd + in + Osig_value vd + +let value_description id ppf decl = + !Oprint.out_sig_item ppf (tree_of_value_description id decl) + +(* Print a class type *) + +let method_type priv ty = + match priv, get_desc ty with + | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) + | _ , _ -> (ty, []) + +let prepare_method _lab (priv, _virt, ty) = + let ty, _ = method_type priv ty in + prepare_type ty + +let tree_of_method mode (lab, priv, virt, ty) = + let (ty, tyl) = method_type priv ty in + let tty = tree_of_typexp mode ty in + Names.remove_names (List.map Transient_expr.repr tyl); + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, tty) + +let rec prepare_class_type params = function + | Cty_constr (_p, tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects + || not (List.for_all is_Tvar params) + || List.exists (deep_occur row) tyl + then prepare_class_type params cty + else List.iter prepare_type tyl + | Cty_signature sign -> + (* Self may have a name *) + let px = proxy sign.csig_self_row in + if List.memq px !visited_objects then add_alias_proxy px + else visited_objects := px :: !visited_objects; + Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; + Meths.iter prepare_method sign.csig_meths + | Cty_arrow (_, ty, cty) -> + prepare_type ty; + prepare_class_type params cty + +let rec tree_of_class_type mode params = + function + | Cty_constr (p, tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects + || not (List.for_all is_Tvar params) + then + tree_of_class_type mode params cty + else begin + let nso, p = best_class_type_path p in + let tyl = apply_subst_opt nso tyl in + let namespace = Namespace.best_class_namespace p in + Octy_constr (tree_of_path namespace p, tree_of_typlist Type_scheme tyl) + end + | Cty_signature sign -> + let px = proxy sign.csig_self_row in + let self_ty = + if is_aliased_proxy px then + Some + (Otyp_var (false, Names.name_of_type Names.new_name px)) + else None + in + let csil = [] in + let csil = + List.fold_left + (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) + csil (tree_of_constraints params) + in + let all_vars = + Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] + in + (* Consequence of PR#3607: order of Map.fold has changed! *) + let all_vars = List.rev all_vars in + let csil = + List.fold_left + (fun csil (l, m, v, t) -> + Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp mode t) + :: csil) + csil all_vars + in + let all_meths = + Meths.fold + (fun l (p, v, t) all -> (l, p, v, t) :: all) + sign.csig_meths [] + in + let all_meths = List.rev all_meths in + let csil = + List.fold_left + (fun csil meth -> tree_of_method mode meth :: csil) + csil all_meths + in + Octy_signature (self_ty, List.rev csil) + | Cty_arrow (l, ty, cty) -> + let lab = + if !print_labels || is_optional l then string_of_label l else "" + in + let tr = + if is_optional l then + match get_desc ty with + | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty in + Octy_arrow (lab, tr, tree_of_class_type mode params cty) + +let class_type ppf cty = + reset (); + prepare_class_type [] cty; + !Oprint.out_class_type ppf (tree_of_class_type Type [] cty) + +let tree_of_class_param param variance = + (match tree_of_typexp Type_scheme param with + Otyp_var (_, s) -> s + | _ -> "?"), + if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) + else variance + +let class_variance = + let open Variance in let open Asttypes in + List.map (fun v -> + (if not (mem May_pos v) then Contravariant else + if not (mem May_neg v) then Covariant else NoVariance), + NoInjectivity) + +let tree_of_class_declaration id cl rs = + let params = filter_params cl.cty_params in + + reset_except_context (); + List.iter add_alias params; + prepare_class_type params cl.cty_type; + let px = proxy (Btype.self_type_row cl.cty_type) in + List.iter prepare_type params; + + List.iter (add_printed_alias ~non_gen:false) params; + if is_aliased_proxy px then add_printed_alias_proxy ~non_gen:false px; + + let vir_flag = cl.cty_new = None in + Osig_class + (vir_flag, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.cty_variance), + tree_of_class_type Type_scheme params cl.cty_type, + tree_of_rec rs) + +let class_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) + +let tree_of_cltype_declaration id cl rs = + let params = cl.clty_params in + + reset_except_context (); + List.iter add_alias params; + prepare_class_type params cl.clty_type; + let px = proxy (Btype.self_type_row cl.clty_type) in + List.iter prepare_type params; + + List.iter (add_printed_alias ~non_gen:false) params; + if is_aliased_proxy px then (add_printed_alias_proxy ~non_gen:false) px; + + let sign = Btype.signature_of_class_type cl.clty_type in + let has_virtual_vars = + Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_vars false + in + let has_virtual_meths = + Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_meths false + in + Osig_class_type + (has_virtual_vars || has_virtual_meths, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.clty_variance), + tree_of_class_type Type_scheme params cl.clty_type, + tree_of_rec rs) + +let cltype_declaration id ppf cl = + !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) + +(* Print a module type *) + +let wrap_env fenv ftree arg = + let env = !printing_env in + let env' = Env.update_short_paths (fenv env) in + set_printing_env env'; + let tree = ftree arg in + set_printing_env env; + tree + +let dummy = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = Location.none; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.internal_not_actually_unique; + } + +(** we hide items being defined from short-path to avoid shortening + [type t = Path.To.t] into [type t = t]. +*) + +let ident_sigitem = function + | Types.Sig_type(ident,_,_,_) -> {hide=true;ident} + | Types.Sig_class(ident,_,_,_) + | Types.Sig_class_type (ident,_,_,_) + | Types.Sig_module(ident,_, _,_,_) + | Types.Sig_value (ident,_,_) + | Types.Sig_modtype (ident,_,_) + | Types.Sig_typext (ident,_,_,_) -> {hide=false; ident } + +let hide ids env = + let hide_id id env = + (* Global idents cannot be renamed *) + if id.hide && not (Ident.global id.ident) then + Env.add_type ~check:false (Ident.rename_no_exn id.ident) dummy env + else env + in + List.fold_right hide_id ids env + +let with_hidden_items ids f = + let with_hidden_in_printing_env ids f = + wrap_env (hide ids) (Naming_context.with_hidden ids) f + in + if not !Clflags.real_paths then + with_hidden_in_printing_env ids f + else + Naming_context.with_hidden ids f + +let add_sigitem env x = + Env.add_signature (Signature_group.flatten x) env + +let rec tree_of_modtype ?(ellipsis=false) = function + | Mty_ident p -> + let p = best_module_type_path p in + Omty_ident (tree_of_path (Some Module_type) p) + | Mty_signature sg -> + Omty_signature (if ellipsis then [Osig_ellipsis] + else tree_of_signature sg) + | Mty_functor(param, ty_res) -> + let param, env = + tree_of_functor_parameter param + in + let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in + Omty_functor (param, res) + | Mty_alias p -> + let p = best_module_path p in + Omty_alias (tree_of_path (Some Module) p) + | Mty_for_hole -> Omty_hole + +and tree_of_functor_parameter = function + | Unit -> + None, fun k -> k + | Named (param, ty_arg) -> + let name, env = + match param with + | None -> None, fun env -> env + | Some id -> + Some (Ident.name id), + Env.add_module ~arg:true id Mp_present ty_arg + in + Some (name, tree_of_modtype ~ellipsis:false ty_arg), env + +and tree_of_signature sg = + wrap_env (fun env -> env)(fun sg -> + let tree_groups = tree_of_signature_rec !printing_env sg in + List.concat_map (fun (_env,l) -> List.map snd l) tree_groups + ) sg + +and tree_of_signature_rec env' sg = + let structured = List.of_seq (Signature_group.seq sg) in + let collect_trees_of_rec_group group = + let env = !printing_env in + let env', group_trees = + trees_of_recursive_sigitem_group env group + in + set_printing_env env'; + (env, group_trees) in + set_printing_env env'; + List.map collect_trees_of_rec_group structured + +and trees_of_recursive_sigitem_group env + (syntactic_group: Signature_group.rec_group) = + let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in + let env = Env.add_signature syntactic_group.pre_ghosts env in + match syntactic_group.group with + | Not_rec x -> add_sigitem env x, [display x] + | Rec_group items -> + let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in + List.fold_left add_sigitem env items, + with_hidden_items ids (fun () -> List.map display items) + +and tree_of_sigitem = function + | Sig_value(id, decl, _) -> + tree_of_value_description id decl + | Sig_type(id, decl, rs, _) -> + tree_of_type_declaration id decl rs + | Sig_typext(id, ext, es, _) -> + tree_of_extension_constructor id ext es + | Sig_module(id, _, md, rs, _) -> + let ellipsis = + List.exists (function + | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true + | _ -> false) + md.md_attributes in + tree_of_module id md.md_type rs ~ellipsis + | Sig_modtype(id, decl, _) -> + tree_of_modtype_declaration id decl + | Sig_class(id, decl, rs, _) -> + tree_of_class_declaration id decl rs + | Sig_class_type(id, decl, rs, _) -> + tree_of_cltype_declaration id decl rs + +and tree_of_modtype_declaration id decl = + let mty = + match decl.mtd_type with + | None -> Omty_abstract + | Some mty -> tree_of_modtype mty + in + Osig_modtype (Ident.name id, mty) + +and tree_of_module id ?ellipsis mty rs = + Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) + +let rec functor_parameters ~sep custom_printer = function + | [] -> ignore + | [id,param] -> + Format.dprintf "%t%t" + (custom_printer param) + (functor_param ~sep ~custom_printer id []) + | (id,param) :: q -> + Format.dprintf "%t%a%t" + (custom_printer param) + sep () + (functor_param ~sep ~custom_printer id q) +and functor_param ~sep ~custom_printer id q = + match id with + | None -> functor_parameters ~sep custom_printer q + | Some id -> + Naming_context.with_arg id + (fun () -> functor_parameters ~sep custom_printer q) + + + +let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) +let modtype_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) + +(* For the toplevel: merge with tree_of_signature? *) + +let print_items showval env x = + Names.refresh_weak(); + Conflicts.reset (); + let extend_val env (sigitem,outcome) = outcome, showval env sigitem in + let post_process (env,l) = List.map (extend_val env) l in + List.concat_map post_process @@ tree_of_signature_rec env x + +(* Print a signature body (used by -i when compiling a .ml) *) + +let print_signature ppf tree = + fprintf ppf "@[%a@]" !Oprint.out_signature tree + +let signature ppf sg = + fprintf ppf "%a" print_signature (tree_of_signature sg) + +(* Print a signature body (used by -i when compiling a .ml) *) +let printed_signature sourcefile ppf sg = + (* we are tracking any collision event for warning 63 *) + Conflicts.reset (); + let t = tree_of_signature sg in + if Warnings.(is_active @@ Erroneous_printed_signature "") + && Conflicts.exists () + then begin + let conflicts = Format.asprintf "%t" Conflicts.print_explanations in + Location.prerr_warning (Location.in_file sourcefile) + (Warnings.Erroneous_printed_signature conflicts); + Warnings.check_fatal () + end; + fprintf ppf "%a" print_signature t + +(* Trace-specific printing *) + +(* A configuration type that controls which trace we print. This could be + exposed, but we instead expose three separate + [report_{unification,equality,moregen}_error] functions. This also lets us + give the unification case an extra optional argument without adding it to the + equality and moregen cases. *) +type 'variety trace_format = + | Unification : Errortrace.unification trace_format + | Equality : Errortrace.comparison trace_format + | Moregen : Errortrace.comparison trace_format + +let incompatibility_phrase (type variety) : variety trace_format -> string = + function + | Unification -> "is not compatible with type" + | Equality -> "is not equal to type" + | Moregen -> "is not compatible with type" + +(* Print a unification error *) + +let same_path t t' = + eq_type t t' || + match get_desc t, get_desc t' with + | Tconstr(p,tl,_), Tconstr(p',tl',_) -> begin + match best_type_path p, best_type_path p' with + | Nth n, Nth n' when n = n' -> true + | Path(nso, p), Path(nso', p') when Path.same p p' -> + let tl = apply_subst_opt nso tl in + let tl' = apply_subst_opt nso' tl' in + List.length tl = List.length tl' && + List.for_all2 eq_type tl tl' + | _ -> false + end + | _ -> + false + +type 'a diff = Same of 'a | Diff of 'a * 'a + +let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = + reset_loop_marks (); + mark_loops t; + if same_path t t' + then begin add_delayed (proxy t); Same (tree_of_typexp mode t) end + else begin + mark_loops t'; + let t' = if proxy t == proxy t' then unalias t' else t' in + (* beware order matter due to side effect, + e.g. when printing object types *) + let first = tree_of_typexp mode t in + let second = tree_of_typexp mode t' in + if first = second then Same first + else Diff(first,second) + end + +let type_expansion ppf = function + | Same t -> !Oprint.out_type ppf t + | Diff(t,t') -> + fprintf ppf "@[<2>%a@ =@ %a@]" !Oprint.out_type t !Oprint.out_type t' + +let trees_of_trace mode = + List.map (Errortrace.map_diff (trees_of_type_expansion mode)) + +let trees_of_type_path_expansion (tp,tp') = + if Path.same tp tp' then Same(tree_of_path (Some Type) tp) else + Diff(tree_of_path (Some Type) tp, tree_of_path (Some Type) tp') + +let type_path_expansion ppf = function + | Same p -> !Oprint.out_ident ppf p + | Diff(p,p') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + !Oprint.out_ident p + !Oprint.out_ident p' + +let rec trace fst txt ppf = function + | {Errortrace.got; expected} :: rem -> + if not fst then fprintf ppf "@,"; + fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@]%a" + type_expansion got txt type_expansion expected + (trace false txt) rem + | _ -> () + +type printing_status = + | Discard + | Keep + | Optional_refinement + (** An [Optional_refinement] printing status is attributed to trace + elements that are focusing on a new subpart of a structural type. + Since the whole type should have been printed earlier in the trace, + we only print those elements if they are the last printed element + of a trace, and there is no explicit explanation for the + type error. + *) + +let diff_printing_status Errortrace.{ got = {ty = t1; expanded = t1'}; + expected = {ty = t2; expanded = t2'} } = + if is_constr_row ~allow_ident:true t1' + || is_constr_row ~allow_ident:true t2' + then Discard + else if same_path t1 t1' && same_path t2 t2' then Optional_refinement + else Keep + +let printing_status = function + | Errortrace.Diff d -> diff_printing_status d + | Errortrace.Escape {kind = Constraint} -> Keep + | _ -> Keep + +(** Flatten the trace and remove elements that are always discarded + during printing *) + +(* Takes [printing_status] to change behavior for [Subtype] *) +let prepare_any_trace printing_status tr = + let clean_trace x l = match printing_status x with + | Keep -> x :: l + | Optional_refinement when l = [] -> [x] + | Optional_refinement | Discard -> l + in + match tr with + | [] -> [] + | elt :: rem -> elt :: List.fold_right clean_trace rem [] + +let prepare_trace f tr = + prepare_any_trace printing_status (Errortrace.map f tr) + +(** Keep elements that are [Diff _ ] and take the decision + for the last element, require a prepared trace *) +let rec filter_trace keep_last = function + | [] -> [] + | [Errortrace.Diff d as elt] + when printing_status elt = Optional_refinement -> + if keep_last then [d] else [] + | Errortrace.Diff d :: rem -> d :: filter_trace keep_last rem + | _ :: rem -> filter_trace keep_last rem + +let type_path_list = + Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0) + type_path_expansion + +(* Hide variant name and var, to force printing the expanded type *) +let hide_variant_name t = + match get_desc t with + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + if name = None then t else + newty2 ~level:(get_level t) + (Tvariant + (create_row ~fields ~fixed ~closed ~name:None + ~more:(newvar2 (get_level more)))) + | _ -> t + +let prepare_expansion Errortrace.{ty; expanded} = + let expanded = hide_variant_name expanded in + reserve_names ty; + if not (same_path ty expanded) then reserve_names expanded; + Errortrace.{ty; expanded} + +let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = + match get_desc expanded with + Tvariant _ | Tobject _ when compact -> + reserve_names ty; Errortrace.{ty; expanded = ty} + | _ -> prepare_expansion ty_exp + +let print_path p = + Format.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p) + +let print_tag ppf = fprintf ppf "`%s" + +let print_tags = + let comma ppf () = Format.fprintf ppf ",@ " in + Format.pp_print_list ~pp_sep:comma print_tag + +let is_unit env ty = + match get_desc (Ctype.expand_head env ty) with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + +let unifiable env ty1 ty2 = + let snap = Btype.snapshot () in + let res = + try Ctype.unify env ty1 ty2; true + with Unify _ -> false + in + Btype.backtrack snap; + res + +let explanation_diff env t3 t4 : (Format.formatter -> unit) option = + match get_desc t3, get_desc t4 with + | Tarrow (_, ty1, ty2, _), _ + when is_unit env ty1 && unifiable env ty2 t4 -> + Some (fun ppf -> + fprintf ppf + "@,@[@{Hint@}: Did you forget to provide `()' as argument?@]") + | _, Tarrow (_, ty1, ty2, _) + when is_unit env ty1 && unifiable env t3 ty2 -> + Some (fun ppf -> + fprintf ppf + "@,@[@{Hint@}: Did you forget to wrap the expression using \ + `fun () ->'?@]") + | _ -> + None + +let explain_fixed_row_case ppf = function + | Errortrace.Cannot_be_closed -> + fprintf ppf "it cannot be closed" + | Errortrace.Cannot_add_tags tags -> + fprintf ppf "it may not allow the tag(s) %a" print_tags tags + +let explain_fixed_row pos expl = match expl with + | Fixed_private -> + dprintf "The %a variant type is private" Errortrace.print_pos pos + | Univar x -> + reserve_names x; + dprintf "The %a variant type is bound to the universal type variable %a" + Errortrace.print_pos pos type_expr_with_reserved_names x + | Reified p -> + dprintf "The %a variant type is bound to %t" + Errortrace.print_pos pos (print_path p) + | Rigid -> ignore + +let explain_variant (type variety) : variety Errortrace.variant -> _ = function + (* Common *) + | Errortrace.Incompatible_types_for s -> + Some(dprintf "@,Types for tag `%s are incompatible" s) + (* Unification *) + | Errortrace.No_intersection -> + Some(dprintf "@,These two variant types have no intersection") + | Errortrace.No_tags(pos,fields) -> Some( + dprintf + "@,@[The %a variant type does not allow tag(s)@ @[%a@]@]" + Errortrace.print_pos pos + print_tags (List.map fst fields) + ) + | Errortrace.Fixed_row (pos, + k, + (Univar _ | Reified _ | Fixed_private as e)) -> + Some ( + dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e) + explain_fixed_row_case k + ) + | Errortrace.Fixed_row (_,_, Rigid) -> + (* this case never happens *) + None + (* Equality & Moregen *) + | Errortrace.Presence_not_guaranteed_for (pos, s) -> Some( + dprintf + "@,@[The tag `%s is guaranteed to be present in the %a variant type,\ + @ but not in the %a@]" + s + Errortrace.print_pos (Errortrace.swap_position pos) + Errortrace.print_pos pos + ) + | Errortrace.Openness pos -> + Some(dprintf "@,The %a variant type is open and the %a is not" + Errortrace.print_pos pos + Errortrace.print_pos (Errortrace.swap_position pos)) + +let explain_escape pre = function + | Errortrace.Univ u -> + reserve_names u; + Some( + dprintf "%t@,The universal variable %a would escape its scope" + pre type_expr_with_reserved_names u) + | Errortrace.Constructor p -> Some( + dprintf + "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + pre path p + ) + | Errortrace.Module_type p -> Some( + dprintf + "%t@,@[The module type@;<1 2>%a@ would escape its scope@]" + pre path p + ) + | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> + reserve_names t; + Some( + dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" + pre type_expr_with_reserved_names t + "it would escape the scope of its equation" + ) + | Errortrace.Self -> + Some (dprintf "%t@,Self type cannot escape its class" pre) + | Errortrace.Constraint -> + None + +let explain_object (type variety) : variety Errortrace.obj -> _ = function + | Errortrace.Missing_field (pos,f) -> Some( + dprintf "@,@[The %a object type has no method %s@]" + Errortrace.print_pos pos f + ) + | Errortrace.Abstract_row pos -> Some( + dprintf + "@,@[The %a object type has an abstract row, it cannot be closed@]" + Errortrace.print_pos pos + ) + | Errortrace.Self_cannot_be_closed -> + Some (dprintf "@,Self type cannot be unified with a closed object type") + +let explanation (type variety) intro prev env + : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function + | Errortrace.Diff {got; expected} -> + explanation_diff env got.expanded expected.expanded + | Errortrace.Escape {kind; context} -> + let pre = + match context, kind, prev with + | Some ctx, _, _ -> + reserve_names ctx; + dprintf "@[%t@;<1 2>%a@]" intro type_expr_with_reserved_names ctx + | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> + reserve_names diff.got; + reserve_names diff.expected; + dprintf "@,@[The method %s has type@ %a,@ \ + but the expected method type was@ %a@]" + name + type_expr_with_reserved_names diff.got + type_expr_with_reserved_names diff.expected + | _ -> ignore + in + explain_escape pre kind + | Errortrace.Incompatible_fields { name; _ } -> + Some(dprintf "@,Types for method %s are incompatible" name) + | Errortrace.Variant v -> + explain_variant v + | Errortrace.Obj o -> + explain_object o + | Errortrace.Rec_occur(x,y) -> + reserve_names x; + reserve_names y; + begin match get_desc x with + | Tvar _ | Tunivar _ -> + Some(fun ppf -> + reset_loop_marks (); + mark_loops x; + mark_loops y; + dprintf "@,@[The type variable %a occurs inside@ %a@]" + prepared_type_expr x prepared_type_expr y + ppf) + | _ -> + (* We had a delayed unification of the type variable with + a non-variable after the occur check. *) + Some ignore + (* There is no need to search further for an explanation, but + we don't want to print a message of the form: + {[ The type int occurs inside int list -> 'a |} + *) + end + +let mismatch intro env trace = + Errortrace.explain trace (fun ~prev h -> explanation intro prev env h) + +let explain mis ppf = + match mis with + | None -> () + | Some explain -> explain ppf + +let warn_on_missing_def env ppf t = + match get_desc t with + | Tconstr (p,_,_) -> + begin + try + ignore(Env.find_type p env : Types.type_declaration) + with Not_found -> + fprintf ppf + "@,@[%a is abstract because no corresponding cmi file was found \ + in path.@]" path p + end + | _ -> () + +let prepare_expansion_head empty_tr = function + | Errortrace.Diff d -> + Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d) + | _ -> None + +let head_error_printer mode txt_got txt_but = function + | None -> ignore + | Some d -> + let d = Errortrace.map_diff (trees_of_type_expansion mode) d in + dprintf "%t@;<1 2>%a@ %t@;<1 2>%a" + txt_got type_expansion d.Errortrace.got + txt_but type_expansion d.Errortrace.expected + +let warn_on_missing_defs env ppf = function + | None -> () + | Some Errortrace.{got = {ty=te1; expanded=_}; + expected = {ty=te2; expanded=_} } -> + warn_on_missing_def env ppf te1; + warn_on_missing_def env ppf te2 + +(* [subst] comes out of equality, and is [[]] otherwise *) +let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = + reset (); + (* We want to substitute in the opposite order from [Eqtype] *) + Names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); + let tr = + prepare_trace + (fun ty_exp -> + Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) + tr + in + let mis = mismatch txt1 env tr in + match tr with + | [] -> assert false + | elt :: tr -> + try + print_labels := not !Clflags.classic; + let tr = filter_trace (mis = None) tr in + let head = prepare_expansion_head (tr=[]) elt in + let tr = List.map (Errortrace.map_diff prepare_expansion) tr in + let head_error = head_error_printer mode txt1 txt2 head in + let tr = trees_of_trace mode tr in + fprintf ppf + "@[\ + @[%t%t@]%a%t\ + @]" + head_error + ty_expect_explanation + (trace false (incompatibility_phrase trace_format)) tr + (explain mis); + if env <> Env.empty + then warn_on_missing_defs env ppf head; + Conflicts.print_explanations ppf; + print_labels := true + with exn -> + print_labels := true; + raise exn + +let report_error trace_format ppf mode env tr + ?(subst = []) + ?(type_expected_explanation = fun _ -> ()) + txt1 txt2 = + wrap_printing_env ~error:true env (fun () -> + error trace_format mode subst env tr txt1 ppf txt2 + type_expected_explanation) + +let report_unification_error + ppf env ({trace} : Errortrace.unification_error) = + report_error Unification ppf Type env + ?subst:None trace + +let report_equality_error + ppf mode env ({subst; trace} : Errortrace.equality_error) = + report_error Equality ppf mode env + ~subst ?type_expected_explanation:None trace + +let report_moregen_error + ppf mode env ({trace} : Errortrace.moregen_error) = + report_error Moregen ppf mode env + ?subst:None ?type_expected_explanation:None trace + +let report_comparison_error ppf mode env = function + | Errortrace.Equality_error error -> report_equality_error ppf mode env error + | Errortrace.Moregen_error error -> report_moregen_error ppf mode env error + +module Subtype = struct + (* There's a frustrating amount of code duplication between this module and + the outside code, particularly in [prepare_trace] and [filter_trace]. + Unfortunately, [Subtype] is *just* similar enough to have code duplication, + while being *just* different enough (it's only [Diff]) for the abstraction + to be nonobvious. Someday, perhaps... *) + + let printing_status = function + | Errortrace.Subtype.Diff d -> diff_printing_status d + + let prepare_unification_trace = prepare_trace + + let prepare_trace f tr = + prepare_any_trace printing_status (Errortrace.Subtype.map f tr) + + let trace filter_trace get_diff fst keep_last txt ppf tr = + print_labels := not !Clflags.classic; + try match tr with + | elt :: tr' -> + let diffed_elt = get_diff elt in + let tr = + trees_of_trace Type + @@ List.map (Errortrace.map_diff prepare_expansion) + @@ filter_trace keep_last tr' in + let tr = + match fst, diffed_elt with + | true, Some elt -> elt :: tr + | _, _ -> tr + in + trace fst txt ppf tr; + print_labels := true + | _ -> () + with exn -> + print_labels := true; + raise exn + + let rec filter_subtype_trace keep_last = function + | [] -> [] + | [Errortrace.Subtype.Diff d as elt] + when printing_status elt = Optional_refinement -> + if keep_last then [d] else [] + | Errortrace.Subtype.Diff d :: rem -> + d :: filter_subtype_trace keep_last rem + + let unification_get_diff = function + | Errortrace.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + | _ -> None + + let subtype_get_diff = function + | Errortrace.Subtype.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + + let report_error + ppf + env + (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) + txt1 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tr_sub = prepare_trace prepare_expansion tr_sub in + let tr_unif = prepare_unification_trace prepare_expansion tr_unif in + let keep_first = match tr_unif with + | [Obj _ | Variant _ | Escape _ ] | [] -> true + | _ -> false in + fprintf ppf "@[%a" + (trace filter_subtype_trace subtype_get_diff true keep_first txt1) + tr_sub; + if tr_unif = [] then fprintf ppf "@]" else + let mis = mismatch (dprintf "Within this type") env tr_unif in + fprintf ppf "%a%t%t@]" + (trace filter_trace unification_get_diff false + (mis = None) "is not compatible with type") tr_unif + (explain mis) + Conflicts.print_explanations + ) +end + +let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tp0 = trees_of_type_path_expansion tp0 in + match tpl with + [] -> assert false + | [tp] -> + fprintf ppf + "@[%t@;<1 2>%a@ \ + %t@;<1 2>%a\ + @]" + txt1 type_path_expansion (trees_of_type_path_expansion tp) + txt3 type_path_expansion tp0 + | _ -> + fprintf ppf + "@[%t@;<1 2>@[%a@]\ + @ %t@;<1 2>%a\ + @]" + txt2 type_path_list (List.map trees_of_type_path_expansion tpl) + txt3 type_path_expansion tp0) + +(* Adapt functions to exposed interface *) +let tree_of_path = tree_of_path None +let tree_of_modtype = tree_of_modtype ~ellipsis:false +let type_expansion mode ppf ty_exp = + type_expansion ppf (trees_of_type_expansion mode ty_exp) +let tree_of_type_declaration ident td rs = + with_hidden_items [{hide=true; ident}] + (fun () -> tree_of_type_declaration ident td rs) + +let shorten_type_path env p = + wrap_printing_env env + (fun () -> best_type_path_simple p) + +let shorten_module_type_path env p = + wrap_printing_env env + (fun () -> best_module_type_path p) + +let shorten_module_path env p = + wrap_printing_env env + (fun () -> best_module_path p) + +let shorten_class_type_path env p = + wrap_printing_env env + (fun () -> best_class_type_path_simple p) + +let () = + Env.shorten_module_path := shorten_module_path diff --git a/ocamlmerlin_mlx/ocaml/typing/printtyp.mli b/ocamlmerlin_mlx/ocaml/typing/printtyp.mli new file mode 100644 index 0000000..2769fe0 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/printtyp.mli @@ -0,0 +1,254 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Printing functions *) + +open Format +open Types +open Outcometree + +val longident: formatter -> Longident.t -> unit +val ident: formatter -> Ident.t -> unit +val namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string +val tree_of_path: Path.t -> out_ident +val path: formatter -> Path.t -> unit +val string_of_path: Path.t -> string + +val type_path: formatter -> Path.t -> unit +(** Print a type path taking account of [-short-paths]. + Calls should be within [wrap_printing_env]. *) + +module Out_name: sig + val create: string -> out_name + val print: out_name -> string +end + +type namespace := Shape.Sig_component_kind.t option + +val strings_of_paths: namespace -> Path.t list -> string list + (** Print a list of paths, using the same naming context to + avoid name collisions *) + +val raw_type_expr: formatter -> type_expr -> unit +val string_of_label: Asttypes.arg_label -> string + +val wrap_printing_env: ?error:bool -> Env.t -> (unit -> 'a) -> 'a + (* Call the function using the environment for type path shortening *) + (* This affects all the printing functions below *) + (* Also, if [~error:true], then disable the loading of cmis *) +val shorten_type_path: Env.t -> Path.t -> Path.t +val shorten_module_type_path: Env.t -> Path.t -> Path.t +val shorten_module_path: Env.t -> Path.t -> Path.t +val shorten_class_type_path: Env.t -> Path.t -> Path.t + +module Naming_context: sig + val enable: bool -> unit + (** When contextual names are enabled, the mapping between identifiers + and names is ensured to be one-to-one. *) +end + +(** The [Conflicts] module keeps track of conflicts arising when attributing + names to identifiers and provides functions that can print explanations + for these conflict in error messages *) +module Conflicts: sig + val exists: unit -> bool + (** [exists()] returns true if the current naming context renamed + an identifier to avoid a name collision *) + + type explanation = + { kind: Shape.Sig_component_kind.t; + name:string; + root_name:string; + location:Location.t + } + + val list_explanations: unit -> explanation list +(** [list_explanations()] return the list of conflict explanations + collected up to this point, and reset the list of collected + explanations *) + + val print_located_explanations: + Format.formatter -> explanation list -> unit + + val print_explanations: Format.formatter -> unit + (** Print all conflict explanations collected up to this point *) + + val reset: unit -> unit +end + + +val reset: unit -> unit + +(** Print out a type. This will pick names for type variables, and will not + reuse names for common type variables shared across multiple type + expressions. (It will also reset the printing state, which matters for + other type formatters such as [prepared_type_expr].) If you want multiple + types to use common names for type variables, see [prepare_for_printing] and + [prepared_type_expr]. *) +val type_expr: formatter -> type_expr -> unit + +(** [prepare_for_printing] resets the global printing environment, a la [reset], + and prepares the types for printing by reserving names and marking loops. + Any type variables that are shared between multiple types in the input list + will be given the same name when printed with [prepared_type_expr]. *) +val prepare_for_printing: type_expr list -> unit + +(** [add_type_to_preparation ty] extend a previous type expression preparation + to the type expression [ty] +*) +val add_type_to_preparation: type_expr -> unit + +val prepared_type_expr: formatter -> type_expr -> unit +(** The function [prepared_type_expr] is a less-safe but more-flexible version + of [type_expr] that should only be called on [type_expr]s that have been + passed to [prepare_for_printing]. Unlike [type_expr], this function does no + extra work before printing a type; in particular, this means that any loops + in the type expression may cause a stack overflow (see #8860) since this + function does not mark any loops. The benefit of this is that if multiple + type expressions are prepared simultaneously and then printed with + [prepared_type_expr], they will use the same names for the same type + variables. *) + +val constructor_arguments: formatter -> constructor_arguments -> unit +val tree_of_type_scheme: type_expr -> out_type +val type_scheme: formatter -> type_expr -> unit +val prepared_type_scheme: formatter -> type_expr -> unit +val shared_type_scheme: formatter -> type_expr -> unit +(** [shared_type_scheme] is very similar to [type_scheme], but does not reset + the printing context first. This is intended to be used in cases where the + printing should have a particularly wide context, such as documentation + generators; most use cases, such as error messages, have narrower contexts + for which [type_scheme] is better suited. *) + +val tree_of_value_description: Ident.t -> value_description -> out_sig_item +val value_description: Ident.t -> formatter -> value_description -> unit +val label : formatter -> label_declaration -> unit +val add_constructor_to_preparation : constructor_declaration -> unit +val prepared_constructor : formatter -> constructor_declaration -> unit +val constructor : formatter -> constructor_declaration -> unit +val tree_of_type_declaration: + Ident.t -> type_declaration -> rec_status -> out_sig_item +val add_type_declaration_to_preparation : + Ident.t -> type_declaration -> unit +val prepared_type_declaration: Ident.t -> formatter -> type_declaration -> unit +val type_declaration: Ident.t -> formatter -> type_declaration -> unit +val tree_of_extension_constructor: + Ident.t -> extension_constructor -> ext_status -> out_sig_item +val add_extension_constructor_to_preparation : + extension_constructor -> unit +val prepared_extension_constructor: + Ident.t -> formatter -> extension_constructor -> unit +val extension_constructor: + Ident.t -> formatter -> extension_constructor -> unit +(* Prints extension constructor with the type signature: + type ('a, 'b) bar += A of float +*) + +val extension_only_constructor: + Ident.t -> formatter -> extension_constructor -> unit +(* Prints only extension constructor without type signature: + A of float +*) + +val tree_of_module: + Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item +val modtype: formatter -> module_type -> unit +val signature: formatter -> signature -> unit +val tree_of_modtype: module_type -> out_module_type +val tree_of_modtype_declaration: + Ident.t -> modtype_declaration -> out_sig_item + +(** Print a list of functor parameters while adjusting the printing environment + for each functor argument. + + Currently, we are disabling disambiguation for functor argument name to + avoid the need to track the moving association between identifiers and + syntactic names in situation like: + + got: (X: sig module type T end) (Y:X.T) (X:sig module type T end) (Z:X.T) + expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T) +*) +val functor_parameters: + sep:(Format.formatter -> unit -> unit) -> + ('b -> Format.formatter -> unit) -> + (Ident.t option * 'b) list -> Format.formatter -> unit + +type type_or_scheme = Type | Type_scheme + +val tree_of_signature: Types.signature -> out_sig_item list +val tree_of_typexp: type_or_scheme -> type_expr -> out_type +val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit +val class_type: formatter -> class_type -> unit +val tree_of_class_declaration: + Ident.t -> class_declaration -> rec_status -> out_sig_item +val class_declaration: Ident.t -> formatter -> class_declaration -> unit +val tree_of_cltype_declaration: + Ident.t -> class_type_declaration -> rec_status -> out_sig_item +val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit +val type_expansion : + type_or_scheme -> Format.formatter -> Errortrace.expanded_type -> unit +val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type +val report_ambiguous_type_error: + formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> + (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit + +val report_unification_error : + formatter -> + Env.t -> Errortrace.unification_error -> + ?type_expected_explanation:(formatter -> unit) -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_equality_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.equality_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_moregen_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.moregen_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_comparison_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.comparison_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +module Subtype : sig + val report_error : + formatter -> + Env.t -> + Errortrace.Subtype.error -> + string -> + unit +end + +(* for toploop *) +val print_items: (Env.t -> signature_item -> 'a option) -> + Env.t -> signature_item list -> (out_sig_item * 'a option) list + +(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias + for Foo__bar. This pattern is used by the stdlib. *) +val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t + +(** [printed_signature sourcefile ppf sg] print the signature [sg] of + [sourcefile] with potential warnings for name collisions *) +val printed_signature: string -> formatter -> signature -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/printtyped.ml b/ocamlmerlin_mlx/ocaml/typing/printtyped.ml new file mode 100644 index 0000000..67afedc --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/printtyped.ml @@ -0,0 +1,970 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Format +open Lexing +open Location +open Typedtree + +let fmt_position f l = + if l.pos_lnum = -1 + then fprintf f "%s[%d]" l.pos_fname l.pos_cnum + else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) + + +let fmt_location f loc = + if not !Clflags.locations then () + else begin + fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; + if loc.loc_ghost then fprintf f " ghost"; + end + + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident (s) -> fprintf f "%s" s; + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z + + +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt + +let fmt_ident = Ident.print + +let fmt_modname f = function + | None -> fprintf f "_"; + | Some id -> Ident.print f id + +let rec fmt_path_aux f x = + match x with + | Path.Pident (s) -> fprintf f "%a" fmt_ident s + | Path.Pdot (y, s) | Path.(Pextra_ty (y, Pcstr_ty s)) -> + fprintf f "%a.%s" fmt_path_aux y s + | Path.Papply (y, z) -> + fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z + | Path.Pextra_ty (y, Pext_ty) -> fmt_path_aux f y + +let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x + +let fmt_constant f x = + match x with + | Const_int (i) -> fprintf f "Const_int %d" i + | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c) + | Const_string (s, strloc, None) -> + fprintf f "Const_string(%S,%a,None)" s fmt_location strloc + | Const_string (s, strloc, Some delim) -> + fprintf f "Const_string (%S,%a,Some %S)" s fmt_location strloc delim + | Const_float (s) -> fprintf f "Const_float %s" s + | Const_int32 (i) -> fprintf f "Const_int32 %ld" i + | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i + | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable" + | Mutable -> fprintf f "Mutable" + +let fmt_virtual_flag f x = + match x with + | Virtual -> fprintf f "Virtual" + | Concrete -> fprintf f "Concrete" + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override" + | Fresh -> fprintf f "Fresh" + +let fmt_closed_flag f x = + match x with + | Closed -> fprintf f "Closed" + | Open -> fprintf f "Open" + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec" + | Recursive -> fprintf f "Rec" + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up" + | Downto -> fprintf f "Down" + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public" + | Private -> fprintf f "Private" + +let line i f s (*...*) = + fprintf f "%s" (String.make (2*i) ' '); + fprintf f s (*...*) + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n" + | _ :: _ -> + line i ppf "[\n"; + List.iter (f (i+1) ppf) l; + line i ppf "]\n" + +let array i f ppf a = + if Array.length a = 0 then + line i ppf "[]\n" + else begin + line i ppf "[\n"; + Array.iter (f (i+1) ppf) a; + line i ppf "]\n" + end + +let option i f ppf x = + match x with + | None -> line i ppf "None\n" + | Some x -> + line i ppf "Some\n"; + f (i+1) ppf x + +let longident i ppf li = line i ppf "%a\n" fmt_longident li +let string i ppf s = line i ppf "\"%s\"\n" s +let arg_label i ppf = function + | Nolabel -> line i ppf "Nolabel\n" + | Optional s -> line i ppf "Optional \"%s\"\n" s + | Labelled s -> line i ppf "Labelled \"%s\"\n" s + + +let typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + + +let record_representation i ppf = let open Types in function + | Record_regular -> line i ppf "Record_regular\n" + | Record_float -> line i ppf "Record_float\n" + | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b + | Record_inlined i -> line i ppf "Record_inlined %d\n" i + | Record_extension p -> line i ppf "Record_extension %a\n" fmt_path p + +let attribute i ppf k a = + line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt; + Printast.payload i ppf a.Parsetree.attr_payload + +let attributes i ppf l = + let i = i + 1 in + List.iter (fun a -> + line i ppf "attribute \"%s\"\n" a.Parsetree.attr_name.txt; + Printast.payload (i + 1) ppf a.Parsetree.attr_payload + ) l + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ctyp_loc; + attributes i ppf x.ctyp_attributes; + let i = i+1 in + match x.ctyp_desc with + | Ttyp_any -> line i ppf "Ttyp_any\n"; + | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s; + | Ttyp_arrow (l, ct1, ct2) -> + line i ppf "Ttyp_arrow\n"; + arg_label i ppf l; + core_type i ppf ct1; + core_type i ppf ct2; + | Ttyp_tuple l -> + line i ppf "Ttyp_tuple\n"; + list i core_type ppf l; + | Ttyp_constr (li, _, l) -> + line i ppf "Ttyp_constr %a\n" fmt_path li; + list i core_type ppf l; + | Ttyp_variant (l, closed, low) -> + line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed; + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ttyp_object (l, c) -> + line i ppf "Ttyp_object %a\n" fmt_closed_flag c; + let i = i + 1 in + List.iter (fun {of_desc; of_attributes; _} -> + match of_desc with + | OTtag (s, t) -> + line i ppf "method %s\n" s.txt; + attributes i ppf of_attributes; + core_type (i + 1) ppf t + | OTinherit ct -> + line i ppf "OTinherit\n"; + core_type (i + 1) ppf ct + ) l + | Ttyp_class (li, _, l) -> + line i ppf "Ttyp_class %a\n" fmt_path li; + list i core_type ppf l; + | Ttyp_alias (ct, s) -> + line i ppf "Ttyp_alias \"%s\"\n" s; + core_type i ppf ct; + | Ttyp_poly (sl, ct) -> + line i ppf "Ttyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; + core_type i ppf ct; + | Ttyp_package { pack_path = s; pack_fields = l } -> + line i ppf "Ttyp_package %a\n" fmt_path s; + list i package_with ppf l; + +and package_with i ppf (s, t) = + line i ppf "with type %a\n" fmt_longident s; + core_type i ppf t + +and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> + line i ppf "pattern %a\n" fmt_location x.pat_loc; + attributes i ppf x.pat_attributes; + let i = i+1 in + begin match x.pat_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (pattern_extra (i+1) ppf) extra; + end; + match x.pat_desc with + | Tpat_any -> line i ppf "Tpat_any\n"; + | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; + | Tpat_alias (p, s,_) -> + line i ppf "Tpat_alias \"%a\"\n" fmt_ident s; + pattern i ppf p; + | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c; + | Tpat_tuple (l) -> + line i ppf "Tpat_tuple\n"; + list i pattern ppf l; + | Tpat_construct (li, _, po, vto) -> + line i ppf "Tpat_construct %a\n" fmt_longident li; + list i pattern ppf po; + option i + (fun i ppf (vl,ct) -> + let names = List.map (fun {txt} -> "\""^Ident.name txt^"\"") vl in + line i ppf "[%s]\n" (String.concat "; " names); + core_type i ppf ct) + ppf vto + | Tpat_variant (l, po, _) -> + line i ppf "Tpat_variant \"%s\"\n" l; + option i pattern ppf po; + | Tpat_record (l, _c) -> + line i ppf "Tpat_record\n"; + list i longident_x_pattern ppf l; + | Tpat_array (l) -> + line i ppf "Tpat_array\n"; + list i pattern ppf l; + | Tpat_lazy p -> + line i ppf "Tpat_lazy\n"; + pattern i ppf p; + | Tpat_exception p -> + line i ppf "Tpat_exception\n"; + pattern i ppf p; + | Tpat_value p -> + line i ppf "Tpat_value\n"; + pattern i ppf (p :> pattern); + | Tpat_or (p1, p2, _) -> + line i ppf "Tpat_or\n"; + pattern i ppf p1; + pattern i ppf p2; + +and pattern_extra i ppf (extra_pat, _, attrs) = + match extra_pat with + | Tpat_unpack -> + line i ppf "Tpat_extra_unpack\n"; + attributes i ppf attrs; + | Tpat_constraint cty -> + line i ppf "Tpat_extra_constraint\n"; + attributes i ppf attrs; + core_type i ppf cty; + | Tpat_type (id, _) -> + line i ppf "Tpat_extra_type %a\n" fmt_path id; + attributes i ppf attrs; + | Tpat_open (id,_,_) -> + line i ppf "Tpat_extra_open %a\n" fmt_path id; + attributes i ppf attrs; + +and expression_extra i ppf (x,_,attrs) = + match x with + | Texp_constraint ct -> + line i ppf "Texp_constraint\n"; + attributes i ppf attrs; + core_type i ppf ct; + | Texp_coerce (cto1, cto2) -> + line i ppf "Texp_coerce\n"; + attributes i ppf attrs; + option i core_type ppf cto1; + core_type i ppf cto2; + | Texp_poly cto -> + line i ppf "Texp_poly\n"; + attributes i ppf attrs; + option i core_type ppf cto; + | Texp_newtype s -> + line i ppf "Texp_newtype \"%s\"\n" s; + | Texp_newtype' (id, _) -> + line i ppf "Texp_newtype' \"%a\"\n" fmt_ident id; + attributes i ppf attrs; + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.exp_loc; + attributes i ppf x.exp_attributes; + let i = i+1 in + begin match x.exp_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (expression_extra (i+1) ppf) extra; + end; + match x.exp_desc with + | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li; + | Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li; + | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c; + | Texp_let (rf, l, e) -> + line i ppf "Texp_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + expression i ppf e; + | Texp_function { arg_label = p; param = _; cases; partial = _; } -> + line i ppf "Texp_function\n"; + arg_label i ppf p; + list i case ppf cases; + | Texp_apply (e, l) -> + line i ppf "Texp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; + | Texp_match (e, l, _partial) -> + line i ppf "Texp_match\n"; + expression i ppf e; + list i case ppf l; + | Texp_try (e, l) -> + line i ppf "Texp_try\n"; + expression i ppf e; + list i case ppf l; + | Texp_tuple (l) -> + line i ppf "Texp_tuple\n"; + list i expression ppf l; + | Texp_construct (li, _, eo) -> + line i ppf "Texp_construct %a\n" fmt_longident li; + list i expression ppf eo; + | Texp_variant (l, eo) -> + line i ppf "Texp_variant \"%s\"\n" l; + option i expression ppf eo; + | Texp_record { fields; representation; extended_expression } -> + line i ppf "Texp_record\n"; + let i = i+1 in + line i ppf "fields =\n"; + array (i+1) record_field ppf fields; + line i ppf "representation =\n"; + record_representation (i+1) ppf representation; + line i ppf "extended_expression =\n"; + option (i+1) expression ppf extended_expression; + | Texp_field (e, li, _) -> + line i ppf "Texp_field\n"; + expression i ppf e; + longident i ppf li; + | Texp_setfield (e1, li, _, e2) -> + line i ppf "Texp_setfield\n"; + expression i ppf e1; + longident i ppf li; + expression i ppf e2; + | Texp_array (l) -> + line i ppf "Texp_array\n"; + list i expression ppf l; + | Texp_ifthenelse (e1, e2, eo) -> + line i ppf "Texp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo; + | Texp_sequence (e1, e2) -> + line i ppf "Texp_sequence\n"; + expression i ppf e1; + expression i ppf e2; + | Texp_while (e1, e2) -> + line i ppf "Texp_while\n"; + expression i ppf e1; + expression i ppf e2; + | Texp_for (s, _, e1, e2, df, e3) -> + line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3; + | Texp_send (e, Tmeth_name s) -> + line i ppf "Texp_send \"%s\"\n" s; + expression i ppf e + | Texp_send (e, Tmeth_val s) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e + | Texp_send (e, Tmeth_ancestor(s, _)) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e + | Texp_new (li, _, _) -> line i ppf "Texp_new %a\n" fmt_path li; + | Texp_setinstvar (_, s, _, e) -> + line i ppf "Texp_setinstvar %a\n" fmt_path s; + expression i ppf e; + | Texp_override (_, l) -> + line i ppf "Texp_override\n"; + list i string_x_expression ppf l; + | Texp_letmodule (s, _, _, me, e) -> + line i ppf "Texp_letmodule \"%a\"\n" fmt_modname s; + module_expr i ppf me; + expression i ppf e; + | Texp_letexception (cd, e) -> + line i ppf "Texp_letexception\n"; + extension_constructor i ppf cd; + expression i ppf e; + | Texp_assert (e, _) -> + line i ppf "Texp_assert"; + expression i ppf e; + | Texp_lazy (e) -> + line i ppf "Texp_lazy"; + expression i ppf e; + | Texp_object (s, _) -> + line i ppf "Texp_object"; + class_structure i ppf s + | Texp_pack me -> + line i ppf "Texp_pack"; + module_expr i ppf me + | Texp_letop {let_; ands; param = _; body; partial = _} -> + line i ppf "Texp_letop"; + binding_op (i+1) ppf let_; + list (i+1) binding_op ppf ands; + case i ppf body + | Texp_unreachable -> + line i ppf "Texp_unreachable" + | Texp_extension_constructor (li, _) -> + line i ppf "Texp_extension_constructor %a" fmt_longident li + | Texp_open (o, e) -> + line i ppf "Texp_open %a\n" + fmt_override_flag o.open_override; + module_expr i ppf o.open_expr; + attributes i ppf o.open_attributes; + expression i ppf e; + | Texp_hole -> + line i ppf "Texp_hole" + +and value_description i ppf x = + line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location + x.val_loc; + attributes i ppf x.val_attributes; + core_type (i+1) ppf x.val_desc; + list (i+1) string ppf x.val_prim; + +and binding_op i ppf x = + line i ppf "binding_op %a %a\n" fmt_path x.bop_op_path + fmt_location x.bop_loc; + expression i ppf x.bop_exp + +and type_parameter i ppf (x, _variance) = core_type i ppf x + +and type_declaration i ppf x = + line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location + x.typ_loc; + attributes i ppf x.typ_attributes; + let i = i+1 in + line i ppf "ptype_params =\n"; + list (i+1) type_parameter ppf x.typ_params; + line i ppf "ptype_cstrs =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i+1) ppf x.typ_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private; + line i ppf "ptype_manifest =\n"; + option (i+1) core_type ppf x.typ_manifest; + +and type_kind i ppf x = + match x with + | Ttype_abstract -> + line i ppf "Ttype_abstract\n" + | Ttype_variant l -> + line i ppf "Ttype_variant\n"; + list (i+1) constructor_decl ppf l; + | Ttype_record l -> + line i ppf "Ttype_record\n"; + list (i+1) label_decl ppf l; + | Ttype_open -> + line i ppf "Ttype_open\n" + +and type_extension i ppf x = + line i ppf "type_extension\n"; + attributes i ppf x.tyext_attributes; + let i = i+1 in + line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path; + line i ppf "ptyext_params =\n"; + list (i+1) type_parameter ppf x.tyext_params; + line i ppf "ptyext_constructors =\n"; + list (i+1) extension_constructor ppf x.tyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private; + +and type_exception i ppf x = + line i ppf "type_exception\n"; + attributes i ppf x.tyexn_attributes; + let i = i+1 in + line i ppf "ptyext_constructor =\n"; + let i = i+1 in + extension_constructor i ppf x.tyexn_constructor + +and extension_constructor i ppf x = + line i ppf "extension_constructor %a\n" fmt_location x.ext_loc; + attributes i ppf x.ext_attributes; + let i = i + 1 in + line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id; + line i ppf "pext_kind =\n"; + extension_constructor_kind (i + 1) ppf x.ext_kind; + +and extension_constructor_kind i ppf x = + match x with + Text_decl(v, a, r) -> + line i ppf "Text_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; + constructor_arguments (i+1) ppf a; + option (i+1) core_type ppf r; + | Text_rebind(p, _) -> + line i ppf "Text_rebind\n"; + line (i+1) ppf "%a\n" fmt_path p; + +and class_type i ppf x = + line i ppf "class_type %a\n" fmt_location x.cltyp_loc; + attributes i ppf x.cltyp_attributes; + let i = i+1 in + match x.cltyp_desc with + | Tcty_constr (li, _, l) -> + line i ppf "Tcty_constr %a\n" fmt_path li; + list i core_type ppf l; + | Tcty_signature (cs) -> + line i ppf "Tcty_signature\n"; + class_signature i ppf cs; + | Tcty_arrow (l, co, cl) -> + line i ppf "Tcty_arrow\n"; + arg_label i ppf l; + core_type i ppf co; + class_type i ppf cl; + | Tcty_open (o, e) -> + line i ppf "Tcty_open %a %a\n" + fmt_override_flag o.open_override + fmt_path (fst o.open_expr); + class_type i ppf e + +and class_signature i ppf { csig_self = ct; csig_fields = l } = + line i ppf "class_signature\n"; + core_type (i+1) ppf ct; + list (i+1) class_type_field ppf l; + +and class_type_field i ppf x = + line i ppf "class_type_field %a\n" fmt_location x.ctf_loc; + let i = i+1 in + attributes i ppf x.ctf_attributes; + match x.ctf_desc with + | Tctf_inherit (ct) -> + line i ppf "Tctf_inherit\n"; + class_type i ppf ct; + | Tctf_val (s, mf, vf, ct) -> + line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Tctf_method (s, pf, vf, ct) -> + line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Tctf_constraint (ct1, ct2) -> + line i ppf "Tctf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Tctf_attribute a -> + attribute i ppf "Tctf_attribute" a + +and class_description i ppf x = + line i ppf "class_description %a\n" fmt_location x.ci_loc; + attributes i ppf x.ci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.ci_expr; + +and class_type_declaration i ppf x = + line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.ci_expr; + +and class_expr i ppf x = + line i ppf "class_expr %a\n" fmt_location x.cl_loc; + attributes i ppf x.cl_attributes; + let i = i+1 in + match x.cl_desc with + | Tcl_ident (li, _, l) -> + line i ppf "Tcl_ident %a\n" fmt_path li; + list i core_type ppf l; + | Tcl_structure (cs) -> + line i ppf "Tcl_structure\n"; + class_structure i ppf cs; + | Tcl_fun (l, p, _, ce, _) -> + line i ppf "Tcl_fun\n"; + arg_label i ppf l; + pattern i ppf p; + class_expr i ppf ce + | Tcl_apply (ce, l) -> + line i ppf "Tcl_apply\n"; + class_expr i ppf ce; + list i label_x_expression ppf l; + | Tcl_let (rf, l1, l2, ce) -> + line i ppf "Tcl_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l1; + list i ident_x_expression_def ppf l2; + class_expr i ppf ce; + | Tcl_constraint (ce, Some ct, _, _, _) -> + line i ppf "Tcl_constraint\n"; + class_expr i ppf ce; + class_type i ppf ct + | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce + | Tcl_open (o, e) -> + line i ppf "Tcl_open %a %a\n" + fmt_override_flag o.open_override + fmt_path (fst o.open_expr); + class_expr i ppf e + +and class_structure i ppf { cstr_self = p; cstr_fields = l } = + line i ppf "class_structure\n"; + pattern (i+1) ppf p; + list (i+1) class_field ppf l; + +and class_field i ppf x = + line i ppf "class_field %a\n" fmt_location x.cf_loc; + let i = i + 1 in + attributes i ppf x.cf_attributes; + match x.cf_desc with + | Tcf_inherit (ovf, ce, so, _, _) -> + line i ppf "Tcf_inherit %a\n" fmt_override_flag ovf; + class_expr (i+1) ppf ce; + option (i+1) string ppf so; + | Tcf_val (s, mf, _, k, _) -> + line i ppf "Tcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf; + class_field_kind (i+1) ppf k + | Tcf_method (s, pf, k) -> + line i ppf "Tcf_method \"%s\" %a\n" s.txt fmt_private_flag pf; + class_field_kind (i+1) ppf k + | Tcf_constraint (ct1, ct2) -> + line i ppf "Tcf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Tcf_initializer (e) -> + line i ppf "Tcf_initializer\n"; + expression (i+1) ppf e; + | Tcf_attribute a -> + attribute i ppf "Tcf_attribute" a + +and class_field_kind i ppf = function + | Tcfk_concrete (o, e) -> + line i ppf "Concrete %a\n" fmt_override_flag o; + expression i ppf e + | Tcfk_virtual t -> + line i ppf "Virtual\n"; + core_type i ppf t + +and class_declaration i ppf x = + line i ppf "class_declaration %a\n" fmt_location x.ci_loc; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.ci_params; + line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; + line i ppf "pci_expr =\n"; + class_expr (i+1) ppf x.ci_expr; + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.mty_loc; + attributes i ppf x.mty_attributes; + let i = i+1 in + match x.mty_desc with + | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li; + | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li; + | Tmty_signature (s) -> + line i ppf "Tmty_signature\n"; + signature i ppf s; + | Tmty_functor (Unit, mt2) -> + line i ppf "Tmty_functor ()\n"; + module_type i ppf mt2; + | Tmty_functor (Named (s, _, mt1), mt2) -> + line i ppf "Tmty_functor \"%a\"\n" fmt_modname s; + module_type i ppf mt1; + module_type i ppf mt2; + | Tmty_with (mt, l) -> + line i ppf "Tmty_with\n"; + module_type i ppf mt; + list i longident_x_with_constraint ppf l; + | Tmty_typeof m -> + line i ppf "Tmty_typeof\n"; + module_expr i ppf m; + +and signature i ppf x = list i signature_item ppf x.sig_items + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.sig_loc; + let i = i+1 in + match x.sig_desc with + | Tsig_value vd -> + line i ppf "Tsig_value\n"; + value_description i ppf vd; + | Tsig_type (rf, l) -> + line i ppf "Tsig_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Tsig_typesubst l -> + line i ppf "Tsig_typesubst\n"; + list i type_declaration ppf l; + | Tsig_typext e -> + line i ppf "Tsig_typext\n"; + type_extension i ppf e; + | Tsig_exception ext -> + line i ppf "Tsig_exception\n"; + type_exception i ppf ext + | Tsig_module md -> + line i ppf "Tsig_module \"%a\"\n" fmt_modname md.md_id; + attributes i ppf md.md_attributes; + module_type i ppf md.md_type + | Tsig_modsubst ms -> + line i ppf "Tsig_modsubst \"%a\" = %a\n" + fmt_ident ms.ms_id fmt_path ms.ms_manifest; + attributes i ppf ms.ms_attributes; + | Tsig_recmodule decls -> + line i ppf "Tsig_recmodule\n"; + list i module_declaration ppf decls; + | Tsig_modtype x -> + line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type + | Tsig_modtypesubst x -> + line i ppf "Tsig_modtypesubst \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type + | Tsig_open od -> + line i ppf "Tsig_open %a %a\n" + fmt_override_flag od.open_override + fmt_path (fst od.open_expr); + attributes i ppf od.open_attributes + | Tsig_include incl -> + line i ppf "Tsig_include\n"; + attributes i ppf incl.incl_attributes; + module_type i ppf incl.incl_mod + | Tsig_class (l) -> + line i ppf "Tsig_class\n"; + list i class_description ppf l; + | Tsig_class_type (l) -> + line i ppf "Tsig_class_type\n"; + list i class_type_declaration ppf l; + | Tsig_attribute a -> + attribute i ppf "Tsig_attribute" a + +and module_declaration i ppf md = + line i ppf "%a" fmt_modname md.md_id; + attributes i ppf md.md_attributes; + module_type (i+1) ppf md.md_type; + +and module_binding i ppf x = + line i ppf "%a\n" fmt_modname x.mb_id; + attributes i ppf x.mb_attributes; + module_expr (i+1) ppf x.mb_expr + +and modtype_declaration i ppf = function + | None -> line i ppf "#abstract" + | Some mt -> module_type (i + 1) ppf mt + +and with_constraint i ppf x = + match x with + | Twith_type (td) -> + line i ppf "Twith_type\n"; + type_declaration (i+1) ppf td; + | Twith_typesubst (td) -> + line i ppf "Twith_typesubst\n"; + type_declaration (i+1) ppf td; + | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li; + | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li; + | Twith_modtype mty -> + line i ppf "Twith_modtype\n"; + module_type (i+1) ppf mty + | Twith_modtypesubst mty -> + line i ppf "Twith_modtype\n"; + module_type (i+1) ppf mty + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.mod_loc; + attributes i ppf x.mod_attributes; + let i = i+1 in + match x.mod_desc with + | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li; + | Tmod_hole -> line i ppf "Tmod_hole\n"; + | Tmod_structure (s) -> + line i ppf "Tmod_structure\n"; + structure i ppf s; + | Tmod_functor (Unit, me) -> + line i ppf "Tmod_functor ()\n"; + module_expr i ppf me; + | Tmod_functor (Named (s, _, mt), me) -> + line i ppf "Tmod_functor \"%a\"\n" fmt_modname s; + module_type i ppf mt; + module_expr i ppf me; + | Tmod_apply (me1, me2, _) -> + line i ppf "Tmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2; + | Tmod_apply_unit me1 -> + line i ppf "Tmod_apply_unit\n"; + module_expr i ppf me1; + | Tmod_constraint (me, _, Tmodtype_explicit mt, _) -> + line i ppf "Tmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; + | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me + | Tmod_unpack (e, _) -> + line i ppf "Tmod_unpack\n"; + expression i ppf e; + +and structure i ppf x = list i structure_item ppf x.str_items + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.str_loc; + let i = i+1 in + match x.str_desc with + | Tstr_eval (e, attrs) -> + line i ppf "Tstr_eval\n"; + attributes i ppf attrs; + expression i ppf e; + | Tstr_value (rf, l) -> + line i ppf "Tstr_value %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + | Tstr_primitive vd -> + line i ppf "Tstr_primitive\n"; + value_description i ppf vd; + | Tstr_type (rf, l) -> + line i ppf "Tstr_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Tstr_typext te -> + line i ppf "Tstr_typext\n"; + type_extension i ppf te + | Tstr_exception ext -> + line i ppf "Tstr_exception\n"; + type_exception i ppf ext; + | Tstr_module x -> + line i ppf "Tstr_module\n"; + module_binding i ppf x + | Tstr_recmodule bindings -> + line i ppf "Tstr_recmodule\n"; + list i module_binding ppf bindings + | Tstr_modtype x -> + line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type + | Tstr_open od -> + line i ppf "Tstr_open %a\n" + fmt_override_flag od.open_override; + module_expr i ppf od.open_expr; + attributes i ppf od.open_attributes + | Tstr_class (l) -> + line i ppf "Tstr_class\n"; + list i class_declaration ppf (List.map (fun (cl, _) -> cl) l); + | Tstr_class_type (l) -> + line i ppf "Tstr_class_type\n"; + list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); + | Tstr_include incl -> + line i ppf "Tstr_include"; + attributes i ppf incl.incl_attributes; + module_expr i ppf incl.incl_mod; + | Tstr_attribute a -> + attribute i ppf "Tstr_attribute" a + +and longident_x_with_constraint i ppf (li, _, wc) = + line i ppf "%a\n" fmt_path li; + with_constraint (i+1) ppf wc; + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf " %a\n" fmt_location l; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + +and constructor_decl i ppf {cd_id; cd_name = _; cd_vars; + cd_args; cd_res; cd_loc; cd_attributes} = + line i ppf "%a\n" fmt_location cd_loc; + line (i+1) ppf "%a\n" fmt_ident cd_id; + if cd_vars <> [] then line (i+1) ppf "cd_vars =%a\n" typevars cd_vars; + attributes i ppf cd_attributes; + constructor_arguments (i+1) ppf cd_args; + option (i+1) core_type ppf cd_res + +and constructor_arguments i ppf = function + | Cstr_tuple l -> list i core_type ppf l + | Cstr_record l -> list i label_decl ppf l + +and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; + ld_attributes} = + line i ppf "%a\n" fmt_location ld_loc; + attributes i ppf ld_attributes; + line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable; + line (i+1) ppf "%a" fmt_ident ld_id; + core_type (i+1) ppf ld_type + +and longident_x_pattern i ppf (li, _, p) = + line i ppf "%a\n" fmt_longident li; + pattern (i+1) ppf p; + +and case + : type k . _ -> _ -> k case -> unit + = fun i ppf {c_lhs; c_guard; c_rhs} -> + line i ppf "\n"; + pattern (i+1) ppf c_lhs; + begin match c_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf c_rhs; + +and value_binding i ppf x = + line i ppf "\n"; + attributes (i+1) ppf x.vb_attributes; + pattern (i+1) ppf x.vb_pat; + expression (i+1) ppf x.vb_expr + +and string_x_expression i ppf (s, _, e) = + line i ppf " \"%a\"\n" fmt_ident s; + expression (i+1) ppf e; + +and record_field i ppf = function + | _, Overridden (li, e) -> + line i ppf "%a\n" fmt_longident li; + expression (i+1) ppf e; + | _, Kept _ -> + line i ppf "" + +and label_x_expression i ppf (l, e) = + line i ppf "\n"; + arg_label (i+1) ppf l; + (match e with None -> () | Some e -> expression (i+1) ppf e) + +and ident_x_expression_def i ppf (l, e) = + line i ppf " \"%a\"\n" fmt_ident l; + expression (i+1) ppf e; + +and label_x_bool_x_core_type_list i ppf x = + match x.rf_desc with + | Ttag (l, b, ctl) -> + line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b); + attributes (i+1) ppf x.rf_attributes; + list (i+1) core_type ppf ctl + | Tinherit (ct) -> + line i ppf "Tinherit\n"; + core_type (i+1) ppf ct + + +let interface ppf x = list 0 signature_item ppf x.sig_items + +let implementation ppf x = list 0 structure_item ppf x.str_items + +let implementation_with_coercion ppf Typedtree.{structure; _} = + implementation ppf structure diff --git a/ocamlmerlin_mlx/ocaml/typing/printtyped.mli b/ocamlmerlin_mlx/ocaml/typing/printtyped.mli new file mode 100644 index 0000000..ae9a6ad --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/printtyped.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Typedtree +open Format + +val interface : formatter -> signature -> unit +val implementation : formatter -> structure -> unit + +val implementation_with_coercion : + formatter -> Typedtree.implementation -> unit + +(* Added by merlin for debugging purposes *) +val pattern : int -> formatter -> _ general_pattern -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/rec_check.ml b/ocamlmerlin_mlx/ocaml/typing/rec_check.ml new file mode 100644 index 0000000..6dae3a0 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/rec_check.ml @@ -0,0 +1,1274 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremy Yallop, University of Cambridge *) +(* Gabriel Scherer, Project Parsifal, INRIA Saclay *) +(* Alban Reynaud, ENS Lyon *) +(* *) +(* Copyright 2017 Jeremy Yallop *) +(* Copyright 2018 Alban Reynaud *) +(* Copyright 2018 INRIA *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Static checking of recursive declarations + +Some recursive definitions are meaningful +{[ + let rec factorial = function 0 -> 1 | n -> n * factorial (n - 1) + let rec infinite_list = 0 :: infinite_list +]} +but some other are meaningless +{[ + let rec x = x + let rec x = x+1 +]} + +Intuitively, a recursive definition makes sense when the body of the +definition can be evaluated without fully knowing what the recursive +name is yet. + +In the [factorial] example, the name [factorial] refers to a function, +evaluating the function definition [function ...] can be done +immediately and will not force a recursive call to [factorial] -- this +will only happen later, when [factorial] is called with an argument. + +In the [infinite_list] example, we can evaluate [0 :: infinite_list] +without knowing the full content of [infinite_list], but with just its +address. This is a case of productive/guarded recursion. + +On the contrary, [let rec x = x] is unguarded recursion (the meaning +is undetermined), and [let rec x = x+1] would need the value of [x] +while evaluating its definition [x+1]. + +This file implements a static check to decide which definitions are +known to be meaningful, and which may be meaningless. In the general +case, we handle a set of mutually-recursive definitions +{[ +let rec x1 = e1 +and x2 = e2 +... +and xn = en +]} + + +Our check (see function [is_valid_recursive_expression] is defined +using two criteria: + +Usage of recursive variables: how does each of the [e1 .. en] use the + recursive variables [x1 .. xn]? + +Static or dynamic size: for which of the [ei] can we compute the + in-memory size of the value without evaluating [ei] (so that we can + pre-allocate it, and thus know its final address before evaluation). + +The "static or dynamic size" is decided by the classify_* functions below. + +The "variable usage" question is decided by a static analysis looking +very much like a type system. The idea is to assign "access modes" to +variables, where an "access mode" [m] is defined as either + + m ::= Ignore (* the value is not used at all *) + | Delay (* the value is not needed at definition time *) + | Guard (* the value is stored under a data constructor *) + | Return (* the value result is directly returned *) + | Dereference (* full access and inspection of the value *) + +The access modes of an expression [e] are represented by a "context" +[G], which is simply a mapping from variables (the variables used in +[e]) to access modes. + +The core notion of the static check is a type-system-like judgment of +the form [G |- e : m], which can be interpreted as meaning either of: + +- If we are allowed to use the variables of [e] at the modes in [G] + (but not more), then it is safe to use [e] at the mode [m]. + +- If we want to use [e] at the mode [m], then its variables are + used at the modes in [G]. + +In practice, for a given expression [e], our implementation takes the +desired mode of use [m] as *input*, and returns a context [G] as +*output*, which is (uniquely determined as) the most permissive choice +of modes [G] for the variables of [e] such that [G |- e : m] holds. +*) + +open Asttypes +open Typedtree +open Types + +exception Illegal_expr + +(** {1 Static or dynamic size} *) + +type sd = Static | Dynamic + +let is_ref : Types.value_description -> bool = function + | { Types.val_kind = + Types.Val_prim { Primitive.prim_name = "%makemutable"; + prim_arity = 1 } } -> + true + | _ -> false + +(* See the note on abstracted arguments in the documentation for + Typedtree.Texp_apply *) +let is_abstracted_arg : arg_label * expression option -> bool = function + | (_, None) -> true + | (_, Some _) -> false + +let classify_expression : Typedtree.expression -> sd = + (* We need to keep track of the size of expressions + bound by local declarations, to be able to predict + the size of variables. Compare: + + let rec r = + let y = fun () -> r () + in y + + and + + let rec r = + let y = if Random.bool () then ignore else fun () -> r () + in y + + In both cases the final address of `r` must be known before `y` is compiled, + and this is only possible if `r` has a statically-known size. + + The first definition can be allowed (`y` has a statically-known + size) but the second one is unsound (`y` has no statically-known size). + *) + let rec classify_expression env e = match e.exp_desc with + (* binding and variable cases *) + | Texp_let (rec_flag, vb, e) -> + let env = classify_value_bindings rec_flag env vb in + classify_expression env e + | Texp_ident (path, _, _) -> + classify_path env path + + (* non-binding cases *) + | Texp_open (_, e) + | Texp_letmodule (_, _, _, _, e) + | Texp_sequence (_, e) + | Texp_letexception (_, e) -> + classify_expression env e + + | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) -> + classify_expression env e + | Texp_construct _ -> + Static + + | Texp_record { representation = Record_unboxed _; + fields = [| _, Overridden (_,e) |] } -> + classify_expression env e + | Texp_record _ -> + Static + + | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _) + when is_ref vd -> + Static + | Texp_apply (_,args) + when List.exists is_abstracted_arg args -> + Static + | Texp_apply _ -> + Dynamic + + | Texp_for _ + | Texp_constant _ + | Texp_new _ + | Texp_instvar _ + | Texp_tuple _ + | Texp_array _ + | Texp_variant _ + | Texp_setfield _ + | Texp_while _ + | Texp_setinstvar _ + | Texp_pack _ + | Texp_object _ + | Texp_function _ + | Texp_lazy _ + | Texp_unreachable + | Texp_hole + | Texp_extension_constructor _ -> + Static + + | Texp_match _ + | Texp_ifthenelse _ + | Texp_send _ + | Texp_field _ + | Texp_assert _ + | Texp_try _ + | Texp_override _ + | Texp_letop _ -> + Dynamic + and classify_value_bindings rec_flag env bindings = + (* We use a non-recursive classification, classifying each + binding with respect to the old environment + (before all definitions), even if the bindings are recursive. + + Note: computing a fixpoint in some way would be more + precise, as the following could be allowed: + + let rec topdef = + let rec x = y and y = fun () -> topdef () + in x + *) + ignore rec_flag; + let old_env = env in + let add_value_binding env vb = + match vb.vb_pat.pat_desc with + | Tpat_var (id, _loc) -> + let size = classify_expression old_env vb.vb_expr in + Ident.add id size env + | _ -> + (* Note: we don't try to compute any size for complex patterns *) + env + in + List.fold_left add_value_binding env bindings + and classify_path env = function + | Path.Pident x -> + begin + try Ident.find_same x env + with Not_found -> + (* an identifier will be missing from the map if either: + - it is a non-local identifier + (bound outside the letrec-binding we are analyzing) + - or it is bound by a complex (let p = e in ...) local binding + - or it is bound within a module (let module M = ... in ...) + that we are not traversing for size computation + + For non-local identifiers it might be reasonable (although + not completely clear) to consider them Static (they have + already been evaluated), but for the others we must + under-approximate with Dynamic. + + This could be fixed by a more complete implementation. + *) + Dynamic + end + | Path.Pdot _ | Path.Papply _ | Path.Pextra_ty _ -> + (* local modules could have such paths to local definitions; + classify_expression could be extend to compute module + shapes more precisely *) + Dynamic + in classify_expression Ident.empty + + +(** {1 Usage of recursive variables} *) + +module Mode = struct + (** For an expression in a program, its "usage mode" represents + static information about how the value produced by the expression + will be used by the context around it. *) + type t = + | Ignore + (** [Ignore] is for subexpressions that are not used at all during + the evaluation of the whole program. This is the mode of + a variable in an expression in which it does not occur. *) + + | Delay + (** A [Delay] context can be fully evaluated without evaluating its argument + , which will only be needed at a later point of program execution. For + example, [fun x -> ?] or [lazy ?] are [Delay] contexts. *) + + | Guard + (** A [Guard] context returns the value as a member of a data structure, + for example a variant constructor or record. The value can safely be + defined mutually-recursively with their context, for example in + [let rec li = 1 :: li]. + When these subexpressions participate in a cyclic definition, + this definition is productive/guarded. + + The [Guard] mode is also used when a value is not dereferenced, + it is returned by a sub-expression, but the result of this + sub-expression is discarded instead of being returned. + For example, the subterm [?] is in a [Guard] context + in [let _ = ? in e] and in [?; e]. + When these subexpressions participate in a cyclic definition, + they cannot create a self-loop. + *) + + | Return + (** A [Return] context returns its value without further inspection. + This value cannot be defined mutually-recursively with its context, + as there is a risk of self-loop: in [let rec x = y and y = x], the + two definitions use a single variable in [Return] context. *) + + | Dereference + (** A [Dereference] context consumes, inspects and uses the value + in arbitrary ways. Such a value must be fully defined at the point + of usage, it cannot be defined mutually-recursively with its context. *) + + let equal = ((=) : t -> t -> bool) + + (* Lower-ranked modes demand/use less of the variable/expression they qualify + -- so they allow more recursive definitions. + + Ignore < Delay < Guard < Return < Dereference + *) + let rank = function + | Ignore -> 0 + | Delay -> 1 + | Guard -> 2 + | Return -> 3 + | Dereference -> 4 + + (* Returns the more conservative (highest-ranking) mode of the two + arguments. + + In judgments we write (m + m') for (join m m'). + *) + let join m m' = + if rank m >= rank m' then m else m' + + (* If x is used with the mode m in e[x], and e[x] is used with mode + m' in e'[e[x]], then x is used with mode m'[m] (our notation for + "compose m' m") in e'[e[x]]. + + Return is neutral for composition: m[Return] = m = Return[m]. + + Composition is associative and [Ignore] is a zero/annihilator for + it: (compose Ignore m) and (compose m Ignore) are both Ignore. *) + let compose m' m = match m', m with + | Ignore, _ | _, Ignore -> Ignore + | Dereference, _ -> Dereference + | Delay, _ -> Delay + | Guard, Return -> Guard + | Guard, ((Dereference | Guard | Delay) as m) -> m + | Return, Return -> Return + | Return, ((Dereference | Guard | Delay) as m) -> m +end + +type mode = Mode.t = Ignore | Delay | Guard | Return | Dereference + +module Env : +sig + type t + + val single : Ident.t -> Mode.t -> t + (** Create an environment with a single identifier used with a given mode. + *) + + val empty : t + (** An environment with no used identifiers. *) + + val find : Ident.t -> t -> Mode.t + (** Find the mode of an identifier in an environment. The default mode is + Ignore. *) + + val unguarded : t -> Ident.t list -> Ident.t list + (** unguarded e l: the list of all identifiers in l that are dereferenced or + returned in the environment e. *) + + val dependent : t -> Ident.t list -> Ident.t list + (** dependent e l: the list of all identifiers in l that are used in e + (not ignored). *) + + val join : t -> t -> t + val join_list : t list -> t + (** Environments can be joined pointwise (variable per variable) *) + + val compose : Mode.t -> t -> t + (** Environment composition m[G] extends mode composition m1[m2] + by composing each mode in G pointwise *) + + val remove : Ident.t -> t -> t + (** Remove an identifier from an environment. *) + + val take: Ident.t -> t -> Mode.t * t + (** Remove an identifier from an environment, and return its mode *) + + val remove_list : Ident.t list -> t -> t + (** Remove all the identifiers of a list from an environment. *) + + val equal : t -> t -> bool +end = struct + module M = Map.Make(Ident) + + (** A "t" maps each rec-bound variable to an access status *) + type t = Mode.t M.t + + let equal = M.equal Mode.equal + + let find (id: Ident.t) (tbl: t) = + try M.find id tbl with Not_found -> Ignore + + let empty = M.empty + + let join (x: t) (y: t) = + M.fold + (fun (id: Ident.t) (v: Mode.t) (tbl: t) -> + let v' = find id tbl in + M.add id (Mode.join v v') tbl) + x y + + let join_list li = List.fold_left join empty li + + let compose m env = + M.map (Mode.compose m) env + + let single id mode = M.add id mode empty + + let unguarded env li = + List.filter (fun id -> Mode.rank (find id env) > Mode.rank Guard) li + + let dependent env li = + List.filter (fun id -> Mode.rank (find id env) > Mode.rank Ignore) li + + let remove = M.remove + + let take id env = (find id env, remove id env) + + let remove_list l env = + List.fold_left (fun env id -> M.remove id env) env l +end + +let remove_pat pat env = + Env.remove_list (pat_bound_idents pat) env + +let remove_patlist pats env = + List.fold_right remove_pat pats env + +(* Usage mode judgments. + + There are two main groups of judgment functions: + + - Judgments of the form "G |- ... : m" + compute the environment G of a subterm ... from its mode m, so + the corresponding function has type [... -> Mode.t -> Env.t]. + + We write [... -> term_judg] in this case. + + - Judgments of the form "G |- ... : m -| G'" + + correspond to binding constructs (for example "let x = e" in the + term "let x = e in body") that have both an exterior environment + G (the environment of the whole term "let x = e in body") and an + interior environment G' (the environment at the "in", after the + binding construct has introduced new names in scope). + + For example, let-binding could be given the following rule: + + G |- e : m + m' + ----------------------------------- + G+G' |- (let x = e) : m -| x:m', G' + + Checking the whole term composes this judgment + with the "G |- e : m" form for the let body: + + G |- (let x = e) : m -| G' + G' |- body : m + ------------------------------- + G |- let x = e in body : m + + To this judgment "G |- e : m -| G'" our implementation gives the + type [... -> Mode.t -> Env.t -> Env.t]: it takes the mode and + interior environment as inputs, and returns the exterior + environment. + + We write [... -> bind_judg] in this case. +*) +type term_judg = Mode.t -> Env.t +type bind_judg = Mode.t -> Env.t -> Env.t + +let option : 'a. ('a -> term_judg) -> 'a option -> term_judg = + fun f o m -> match o with + | None -> Env.empty + | Some v -> f v m +let list : 'a. ('a -> term_judg) -> 'a list -> term_judg = + fun f li m -> + List.fold_left (fun env item -> Env.join env (f item m)) Env.empty li +let array : 'a. ('a -> term_judg) -> 'a array -> term_judg = + fun f ar m -> + Array.fold_left (fun env item -> Env.join env (f item m)) Env.empty ar + +let single : Ident.t -> term_judg = Env.single +let remove_id : Ident.t -> term_judg -> term_judg = + fun id f m -> Env.remove id (f m) +let remove_ids : Ident.t list -> term_judg -> term_judg = + fun ids f m -> Env.remove_list ids (f m) + +let join : term_judg list -> term_judg = + fun li m -> Env.join_list (List.map (fun f -> f m) li) + +let empty = fun _ -> Env.empty + +(* A judgment [judg] takes a mode from the context as input, and + returns an environment. The judgment [judg << m], given a mode [m'] + from the context, evaluates [judg] in the composed mode [m'[m]]. *) +let (<<) : term_judg -> Mode.t -> term_judg = + fun f inner_mode -> fun outer_mode -> f (Mode.compose outer_mode inner_mode) + +(* A binding judgment [binder] expects a mode and an inner environment, + and returns an outer environment. [binder >> judg] computes + the inner environment as the environment returned by [judg] + in the ambient mode. *) +let (>>) : bind_judg -> term_judg -> term_judg = + fun binder term mode -> binder mode (term mode) + +(* Expression judgment: + G |- e : m + where (m) is an input of the code and (G) is an output; + in the Prolog mode notation, this is (+G |- -e : -m). +*) +let rec expression : Typedtree.expression -> term_judg = + fun exp -> match exp.exp_desc with + | Texp_ident (pth, _, _) -> + path pth + | Texp_let (rec_flag, bindings, body) -> + (* + G |- : m -| G' + G' |- body : m + ------------------------------- + G |- let in body : m + *) + value_bindings rec_flag bindings >> expression body + | Texp_letmodule (x, _, _, mexp, e) -> + module_binding (x, mexp) >> expression e + | Texp_match (e, cases, _) -> + (* + (Gi; mi |- pi -> ei : m)^i + G |- e : sum(mi)^i + ---------------------------------------------- + G + sum(Gi)^i |- match e with (pi -> ei)^i : m + *) + (fun mode -> + let pat_envs, pat_modes = + List.split (List.map (fun c -> case c mode) cases) in + let env_e = expression e (List.fold_left Mode.join Ignore pat_modes) in + Env.join_list (env_e :: pat_envs)) + | Texp_for (_, _, low, high, _, body) -> + (* + G1 |- low: m[Dereference] + G2 |- high: m[Dereference] + G3 |- body: m[Guard] + --- + G1 + G2 + G3 |- for _ = low to high do body done: m + *) + join [ + expression low << Dereference; + expression high << Dereference; + expression body << Guard; + ] + | Texp_constant _ -> + empty + | Texp_new (pth, _, _) -> + (* + G |- c: m[Dereference] + ----------------------- + G |- new c: m + *) + path pth << Dereference + | Texp_instvar (self_path, pth, _inst_var) -> + join [path self_path << Dereference; path pth] + | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Some arg]) + when is_ref vd -> + (* + G |- e: m[Guard] + ------------------ + G |- ref e: m + *) + expression arg << Guard + | Texp_apply (e, args) -> + let arg (_, eo) = option expression eo in + let app_mode = if List.exists is_abstracted_arg args + then (* see the comment on Texp_apply in typedtree.mli; + the non-abstracted arguments are bound to local + variables, which corresponds to a Guard mode. *) + Guard + else Dereference + in + join [expression e; list arg args] << app_mode + | Texp_tuple exprs -> + list expression exprs << Guard + | Texp_array exprs -> + (* + let array_mode = match Typeopt.array_kind exp with + | Lambda.Pfloatarray -> + (* (flat) float arrays unbox their elements *) + Dereference + | Lambda.Pgenarray -> + (* This is counted as a use, because constructing a generic array + involves inspecting to decide whether to unbox (PR#6939). *) + Dereference + | Lambda.Paddrarray | Lambda.Pintarray -> + (* non-generic, non-float arrays act as constructors *) + Guard + in + *) + let array_mode = + (* FIXME MERLIN this is incorrect, but it won't report false positive, so it + will do for now. *) + Guard + in + list expression exprs << array_mode + | Texp_construct (_, desc, exprs) -> + let access_constructor = + match desc.cstr_tag with + | Cstr_extension (pth, _) -> + path pth << Dereference + | _ -> empty + in + let m' = match desc.cstr_tag with + | Cstr_unboxed -> + Return + | Cstr_constant _ | Cstr_block _ | Cstr_extension _ -> + Guard + in + join [ + access_constructor; + list expression exprs << m' + ] + | Texp_variant (_, eo) -> + (* + G |- e: m[Guard] + ------------------ ----------- + G |- `A e: m [] |- `A: m + *) + option expression eo << Guard + | Texp_record { fields = es; extended_expression = eo; + representation = rep } -> + let field_mode = match rep with + | Record_float -> Dereference + | Record_unboxed _ -> Return + | Record_regular | Record_inlined _ + | Record_extension _ -> Guard + in + let field (_label, field_def) = match field_def with + Kept _ -> empty + | Overridden (_, e) -> expression e + in + join [ + array field es << field_mode; + option expression eo << Dereference + ] + | Texp_ifthenelse (cond, ifso, ifnot) -> + (* + Gc |- c: m[Dereference] + G1 |- e1: m + G2 |- e2: m + --- + Gc + G1 + G2 |- if c then e1 else e2: m + + Note: `if c then e1 else e2` is treated in the same way as + `match c with true -> e1 | false -> e2` + *) + join [ + expression cond << Dereference; + expression ifso; + option expression ifnot; + ] + | Texp_setfield (e1, _, _, e2) -> + (* + G1 |- e1: m[Dereference] + G2 |- e2: m[Dereference] + --- + G1 + G2 |- e1.x <- e2: m + + Note: e2 is dereferenced in the case of a field assignment to + a record of unboxed floats in that case, e2 evaluates to + a boxed float and it is unboxed on assignment. + *) + join [ + expression e1 << Dereference; + expression e2 << Dereference; + ] + | Texp_sequence (e1, e2) -> + (* + G1 |- e1: m[Guard] + G2 |- e2: m + -------------------- + G1 + G2 |- e1; e2: m + + Note: `e1; e2` is treated in the same way as `let _ = e1 in e2` + *) + join [ + expression e1 << Guard; + expression e2; + ] + | Texp_while (cond, body) -> + (* + G1 |- cond: m[Dereference] + G2 |- body: m[Guard] + --------------------------------- + G1 + G2 |- while cond do body done: m + *) + join [ + expression cond << Dereference; + expression body << Guard; + ] + | Texp_send (e1, _) -> + (* + G |- e: m[Dereference] + ---------------------- (plus weird 'eo' option) + G |- e#x: m + *) + join [ + expression e1 << Dereference + ] + | Texp_field (e, _, _) -> + (* + G |- e: m[Dereference] + ----------------------- + G |- e.x: m + *) + expression e << Dereference + | Texp_setinstvar (pth,_,_,e) -> + (* + G |- e: m[Dereference] + ---------------------- + G |- x <- e: m + *) + join [ + path pth << Dereference; + expression e << Dereference; + ] + | Texp_letexception ({ext_id}, e) -> + (* G |- e: m + ---------------------------- + G |- let exception A in e: m + *) + remove_id ext_id (expression e) + | Texp_assert (e, _) -> + (* + G |- e: m[Dereference] + ----------------------- + G |- assert e: m + + Note: `assert e` is treated just as if `assert` was a function. + *) + expression e << Dereference + | Texp_pack mexp -> + (* + G |- M: m + ---------------- + G |- module M: m + *) + modexp mexp + | Texp_object (clsstrct, _) -> + class_structure clsstrct + | Texp_try (e, cases) -> + (* + G |- e: m (Gi; _ |- pi -> ei : m)^i + -------------------------------------------- + G + sum(Gi)^i |- try e with (pi -> ei)^i : m + + Contrarily to match, the patterns p do not inspect + the value of e, so their mode does not influence the + mode of e. + *) + let case_env c m = fst (case c m) in + join [ + expression e; + list case_env cases; + ] + | Texp_override (pth, fields) -> + (* + G |- pth : m (Gi |- ei : m[Dereference])^i + ---------------------------------------------------- + G + sum(Gi)^i |- {< (xi = ei)^i >} (at path pth) : m + + Note: {< .. >} is desugared to a function application, but + the function implementation might still use its arguments in + a guarded way only -- intuitively it should behave as a constructor. + We could possibly refine the arguments' Dereference into Guard here. + *) + let field (_, _, arg) = expression arg in + join [ + path pth << Dereference; + list field fields << Dereference; + ] + | Texp_function { cases } -> + (* + (Gi; _ |- pi -> ei : m[Delay])^i + -------------------------------------- + sum(Gi)^i |- function (pi -> ei)^i : m + + Contrarily to match, the value that is pattern-matched + is bound locally, so the pattern modes do not influence + the final environment. + *) + let case_env c m = fst (case c m) in + list case_env cases << Delay + | Texp_lazy e -> + (* + G |- e: m[Delay] + ---------------- (modulo some subtle compiler optimizations) + G |- lazy e: m + *) + let lazy_mode = match Typeopt.classify_lazy_argument e with + | `Constant_or_function + | `Identifier _ + | `Float_that_cannot_be_shortcut -> + Return + | `Other -> + Delay + in + expression e << lazy_mode + | Texp_letop{let_; ands; body; _} -> + let case_env c m = fst (case c m) in + join [ + list binding_op (let_ :: ands) << Dereference; + case_env body << Delay + ] + | Texp_unreachable -> + (* + ---------- + [] |- .: m + *) + empty + | Texp_hole -> empty + | Texp_extension_constructor (_lid, pth) -> + path pth << Dereference + | Texp_open (od, e) -> + open_declaration od >> expression e + +and binding_op : Typedtree.binding_op -> term_judg = + fun bop -> + join [path bop.bop_op_path; expression bop.bop_exp] + +and class_structure : Typedtree.class_structure -> term_judg = + fun cs -> list class_field cs.cstr_fields + +and class_field : Typedtree.class_field -> term_judg = + fun cf -> match cf.cf_desc with + | Tcf_inherit (_, ce, _super, _inh_vars, _inh_meths) -> + class_expr ce << Dereference + | Tcf_val (_lab, _mut, _, cfk, _) -> + class_field_kind cfk + | Tcf_method (_, _, cfk) -> + class_field_kind cfk + | Tcf_constraint _ -> + empty + | Tcf_initializer e -> + expression e << Dereference + | Tcf_attribute _ -> + empty + +and class_field_kind : Typedtree.class_field_kind -> term_judg = + fun cfk -> match cfk with + | Tcfk_virtual _ -> + empty + | Tcfk_concrete (_, e) -> + expression e << Dereference + +and modexp : Typedtree.module_expr -> term_judg = + fun mexp -> match mexp.mod_desc with + | Tmod_ident (pth, _) -> + path pth + | Tmod_structure s -> + structure s + | Tmod_functor (_, e) -> + modexp e << Delay + | Tmod_apply (f, p, _) -> + join [ + modexp f << Dereference; + modexp p << Dereference; + ] + | Tmod_apply_unit f -> + modexp f << Dereference + | Tmod_constraint (mexp, _, _, coe) -> + let rec coercion coe k = match coe with + | Tcoerce_none -> + k Return + | Tcoerce_structure _ + | Tcoerce_functor _ -> + (* These coercions perform a shallow copy of the input module, + by creating a new module with fields obtained by accessing + the same fields in the input module. *) + k Dereference + | Tcoerce_primitive _ -> + (* This corresponds to 'external' declarations, + and the coercion ignores its argument *) + k Ignore + | Tcoerce_alias (_, pth, coe) -> + (* Alias coercions ignore their arguments, but they evaluate + their alias module 'pth' under another coercion. *) + coercion coe (fun m -> path pth << m) + in + coercion coe (fun m -> modexp mexp << m) + | Tmod_unpack (e, _) -> + expression e + | Tmod_hole -> fun _ -> Env.empty + + +(* G |- pth : m *) +and path : Path.t -> term_judg = + (* + ------------ + x: m |- x: m + + G |- A: m[Dereference] + ----------------------- + G |- A.x: m + + G1 |- A: m[Dereference] + G2 |- B: m[Dereference] + ------------------------ (as for term application) + G1 + G2 |- A(B): m + *) + fun pth -> match pth with + | Path.Pident x -> + single x + | Path.Pdot (t, _) -> + path t << Dereference + | Path.Papply (f, p) -> + join [ + path f << Dereference; + path p << Dereference; + ] + | Path.Pextra_ty (p, _extra) -> + path p + +(* G |- struct ... end : m *) +and structure : Typedtree.structure -> term_judg = + (* + G1, {x: _, x in vars(G1)} |- item1: G2 + ... + Gn in m + G2, {x: _, x in vars(G2)} |- item2: G3 + ... + Gn in m + ... + Gn, {x: _, x in vars(Gn)} |- itemn: [] in m + --- + (G1 + ... + Gn) - V |- struct item1 ... itemn end: m + *) + fun s m -> + List.fold_right (fun it env -> structure_item it m env) + s.str_items Env.empty + +(* G |- : m -| G' + where G is an output and m, G' are inputs *) +and structure_item : Typedtree.structure_item -> bind_judg = + fun s m env -> match s.str_desc with + | Tstr_eval (e, _) -> + (* + Ge |- e: m[Guard] + G |- items: m -| G' + --------------------------------- + Ge + G |- (e;; items): m -| G' + + The expression `e` is treated in the same way as let _ = e + *) + let judg_e = expression e << Guard in + Env.join (judg_e m) env + | Tstr_value (rec_flag, bindings) -> + value_bindings rec_flag bindings m env + | Tstr_module {mb_id; mb_expr} -> + module_binding (mb_id, mb_expr) m env + | Tstr_recmodule mbs -> + let bindings = List.map (fun {mb_id; mb_expr} -> (mb_id, mb_expr)) mbs in + recursive_module_bindings bindings m env + | Tstr_primitive _ -> + env + | Tstr_type _ -> + (* + ------------------- + G |- type t: m -| G + *) + env + | Tstr_typext {tyext_constructors = exts; _} -> + let ext_ids = List.map (fun {ext_id = id; _} -> id) exts in + Env.join + (list extension_constructor exts m) + (Env.remove_list ext_ids env) + | Tstr_exception {tyexn_constructor = ext; _} -> + Env.join + (extension_constructor ext m) + (Env.remove ext.ext_id env) + | Tstr_modtype _ + | Tstr_class_type _ + | Tstr_attribute _ -> + env + | Tstr_open od -> + open_declaration od m env + | Tstr_class classes -> + let class_ids = + let class_id ({ci_id_class = id; _}, _) = id in + List.map class_id classes in + let class_declaration ({ci_expr; _}, _) m = + Env.remove_list class_ids (class_expr ci_expr m) in + Env.join + (list class_declaration classes m) + (Env.remove_list class_ids env) + | Tstr_include { incl_mod = mexp; incl_type = mty; _ } -> + let included_ids = List.map Types.signature_item_id mty in + Env.join (modexp mexp m) (Env.remove_list included_ids env) + +(* G |- module M = E : m -| G *) +and module_binding : (Ident.t option * Typedtree.module_expr) -> bind_judg = + fun (id, mexp) m env -> + (* + GE |- E: m[mM + Guard] + ------------------------------------- + GE + G |- module M = E : m -| M:mM, G + *) + let judg_E, env = + match id with + | None -> modexp mexp << Guard, env + | Some id -> + let mM, env = Env.take id env in + let judg_E = modexp mexp << (Mode.join mM Guard) in + judg_E, env + in + Env.join (judg_E m) env + +and open_declaration : Typedtree.open_declaration -> bind_judg = + fun { open_expr = mexp; open_bound_items = sg; _ } m env -> + let judg_E = modexp mexp in + let bound_ids = List.map Types.signature_item_id sg in + Env.join (judg_E m) (Env.remove_list bound_ids env) + +and recursive_module_bindings + : (Ident.t option * Typedtree.module_expr) list -> bind_judg = + fun m_bindings m env -> + let mids = List.filter_map fst m_bindings in + let binding (mid, mexp) m = + let judg_E = + match mid with + | None -> modexp mexp << Guard + | Some mid -> + let mM = Env.find mid env in + modexp mexp << (Mode.join mM Guard) + in + Env.remove_list mids (judg_E m) + in + Env.join (list binding m_bindings m) (Env.remove_list mids env) + +and class_expr : Typedtree.class_expr -> term_judg = + fun ce -> match ce.cl_desc with + | Tcl_ident (pth, _, _) -> + path pth << Dereference + | Tcl_structure cs -> + class_structure cs + | Tcl_fun (_, _, args, ce, _) -> + let ids = List.map fst args in + remove_ids ids (class_expr ce << Delay) + | Tcl_apply (ce, args) -> + let arg (_label, eo) = option expression eo in + join [ + class_expr ce << Dereference; + list arg args << Dereference; + ] + | Tcl_let (rec_flag, bindings, _, ce) -> + value_bindings rec_flag bindings >> class_expr ce + | Tcl_constraint (ce, _, _, _, _) -> + class_expr ce + | Tcl_open (_, ce) -> + class_expr ce + +and extension_constructor : Typedtree.extension_constructor -> term_judg = + fun ec -> match ec.ext_kind with + | Text_decl _ -> + empty + | Text_rebind (pth, _lid) -> + path pth + +(* G |- let (rec?) (pi = ei)^i : m -| G' *) +and value_bindings : rec_flag -> Typedtree.value_binding list -> bind_judg = + fun rec_flag bindings mode bound_env -> + let all_bound_pats = List.map (fun vb -> vb.vb_pat) bindings in + let outer_env = remove_patlist all_bound_pats bound_env in + let bindings_env = + match rec_flag with + | Nonrecursive -> + (* + (Gi, pi:_ |- ei : m[mbody_i])^i (pi : mbody_i -| D)^i + ------------------------------------------------------------ + Sum(Gi) + (D - (pi)^i) |- let (pi=ei)^i : m -| D + *) + let binding_env {vb_pat; vb_expr; _} m = + let m' = Mode.compose m (pattern vb_pat bound_env) in + remove_pat vb_pat (expression vb_expr m') in + list binding_env bindings mode + | Recursive -> + (* + (Gi, (xj : mdef_ij)^j |- ei : m[mbody_i])^i (xi : mbody_i -| D)^i + G'i = Gi + mdef_ij[G'j] + ------------------------------------------------------------------- + Sum(G'i) + (D - (pi)^i) |- let rec (xi=ei)^i : m -| D + + The (mdef_ij)^i,j are a family of modes over two indices: + mdef_ij represents the mode of use, within e_i the definition of x_i, + of the mutually-recursive variable x_j. + + The (G'i)^i are defined from the (Gi)^i as a family of equations, + whose smallest solution is computed as a least fixpoint. + + The (Gi)^i are the "immediate" dependencies of each (ei)^i + on the outer context (excluding the mutually-defined + variables). + The (G'i)^i contain the "transitive" dependencies as well: + if ei depends on xj, then the dependencies of G'i of xi + must contain the dependencies of G'j, composed by + the mode mdef_ij of use of xj in ei. + + For example, consider: + + let rec z = + let rec x = ref y + and y = ref z + in f x + + this definition should be rejected as the body [f x] + dereferences [x], which can be used to access the + yet-unitialized value [z]. This requires realizing that [x] + depends on [z] through [y], which requires the transitive + closure computation. + + An earlier version of our check would take only the (Gi)^i + instead of the (G'i)^i, which is incorrect and would accept + the example above. + *) + (* [binding_env] takes a binding (x_i = e_i) + and computes (Gi, (mdef_ij)^j). *) + let binding_env {vb_pat = x_i; vb_expr = e_i; _} = + let mbody_i = pattern x_i bound_env in + (* Gi, (x_j:mdef_ij)^j *) + let rhs_env_i = expression e_i (Mode.compose mode mbody_i) in + (* (mdef_ij)^j (for a fixed i) *) + let mutual_modes = + let mdef_ij {vb_pat = x_j; _} = pattern x_j rhs_env_i in + List.map mdef_ij bindings in + (* Gi *) + let env_i = remove_patlist all_bound_pats rhs_env_i in + (* (Gi, (mdef_ij)^j) *) + (env_i, mutual_modes) in + let env, mdef = + List.split (List.map binding_env bindings) in + let rec transitive_closure env = + let transitive_deps env_i mdef_i = + (* Gi, (mdef_ij)^j => Gi + Sum_j mdef_ij[Gj] *) + Env.join env_i + (Env.join_list (List.map2 Env.compose mdef_i env)) in + let env' = List.map2 transitive_deps env mdef in + if List.for_all2 Env.equal env env' + then env' + else transitive_closure env' + in + let env'_i = transitive_closure env in + Env.join_list env'_i + in Env.join bindings_env outer_env + +(* G; m' |- (p -> e) : m + with outputs G, m' and input m + + m' is the mode under which the scrutinee of p + (the value matched against p) is placed. +*) +and case + : 'k . 'k Typedtree.case -> mode -> Env.t * mode + = fun { Typedtree.c_lhs; c_guard; c_rhs } -> + (* + Ge |- e : m Gg |- g : m[Dereference] + G := Ge+Gg p : mp -| G + ---------------------------------------- + G - p; m[mp] |- (p (when g)? -> e) : m + *) + let judg = join [ + option expression c_guard << Dereference; + expression c_rhs; + ] in + (fun m -> + let env = judg m in + (remove_pat c_lhs env), Mode.compose m (pattern c_lhs env)) + +(* p : m -| G + with output m and input G + + m is the mode under which the scrutinee of p is placed. +*) +and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env -> + (* + mp := | Dereference if p is destructuring + | Guard otherwise + me := sum{G(x), x in vars(p)} + -------------------------------------------- + p : (mp + me) -| G + *) + let m_pat = if is_destructuring_pattern pat + then Dereference + else Guard + in + let m_env = + pat_bound_idents pat + |> List.map (fun id -> Env.find id env) + |> List.fold_left Mode.join Ignore + in + Mode.join m_pat m_env + +and is_destructuring_pattern : type k . k general_pattern -> bool = + fun pat -> match pat.pat_desc with + | Tpat_any -> false + | Tpat_var (_, _) -> false + | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat + | Tpat_constant _ -> true + | Tpat_tuple _ -> true + | Tpat_construct _ -> true + | Tpat_variant _ -> true + | Tpat_record (_, _) -> true + | Tpat_array _ -> true + | Tpat_lazy _ -> true + | Tpat_value pat -> is_destructuring_pattern (pat :> pattern) + | Tpat_exception _ -> false + | Tpat_or (l,r,_) -> + is_destructuring_pattern l || is_destructuring_pattern r + +let is_valid_recursive_expression idlist expr = + match expr.exp_desc with + | Texp_function _ -> + (* Fast path: functions can never have invalid recursive references *) + true + | _ -> + match classify_expression expr with + | Static -> + (* The expression has known size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] + | Dynamic -> + (* The expression has unknown size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] + +(* A class declaration may contain let-bindings. If they are recursive, + their validity will already be checked by [is_valid_recursive_expression] + during type-checking. This function here prevents a different kind of + invalid recursion, which is the unsafe creations of objects of this class + in the let-binding. For example, + {|class a = let x = new a in object ... end|} + is forbidden, but + {|class a = let x () = new a in object ... end|} + is allowed. +*) +let is_valid_class_expr idlist ce = + let rec class_expr : mode -> Typedtree.class_expr -> Env.t = + fun mode ce -> match ce.cl_desc with + | Tcl_ident (_, _, _) -> + (* + ---------- + [] |- a: m + *) + Env.empty + | Tcl_structure _ -> + (* + ----------------------- + [] |- struct ... end: m + *) + Env.empty + | Tcl_fun (_, _, _, _, _) -> Env.empty + (* + --------------------------- + [] |- fun x1 ... xn -> C: m + *) + | Tcl_apply (_, _) -> Env.empty + | Tcl_let (rec_flag, bindings, _, ce) -> + value_bindings rec_flag bindings mode (class_expr mode ce) + | Tcl_constraint (ce, _, _, _, _) -> + class_expr mode ce + | Tcl_open (_, ce) -> + class_expr mode ce + in + match Env.unguarded (class_expr Return ce) idlist with + | [] -> true + | _ :: _ -> false diff --git a/ocamlmerlin_mlx/ocaml/typing/rec_check.mli b/ocamlmerlin_mlx/ocaml/typing/rec_check.mli new file mode 100644 index 0000000..aa5c1ca --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/rec_check.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremy Yallop, University of Cambridge *) +(* *) +(* Copyright 2017 Jeremy Yallop *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +exception Illegal_expr + +val is_valid_recursive_expression : Ident.t list -> Typedtree.expression -> bool + +val is_valid_class_expr : Ident.t list -> Typedtree.class_expr -> bool diff --git a/ocamlmerlin_mlx/ocaml/typing/saved_parts.ml b/ocamlmerlin_mlx/ocaml/typing/saved_parts.ml new file mode 100644 index 0000000..47f980b --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/saved_parts.ml @@ -0,0 +1,27 @@ +let attribute = Location.mknoloc "merlin.saved-parts" + +module H = Ephemeron.K1.Make(struct + type t = string + let hash = Hashtbl.hash + let equal (a : t) (b : t) = a = b + end) + +let table = H.create 7 + +let gensym = + let counter = ref 0 in + fun () -> incr counter; !counter + +let store parts = + let id = string_of_int (gensym ()) in + let key = Parsetree.Pconst_integer (id, None) in + H.add table id parts; + key + +let find = function + | Parsetree.Pconst_integer (id, None) -> + begin + try H.find table id + with Not_found -> [] + end + | _ -> assert false diff --git a/ocamlmerlin_mlx/ocaml/typing/saved_parts.mli b/ocamlmerlin_mlx/ocaml/typing/saved_parts.mli new file mode 100644 index 0000000..be1a206 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/saved_parts.mli @@ -0,0 +1,3 @@ +val attribute : string Location.loc +val store : Cmt_format.binary_part list -> Parsetree.constant +val find : Parsetree.constant -> Cmt_format.binary_part list diff --git a/ocamlmerlin_mlx/ocaml/typing/shape.ml b/ocamlmerlin_mlx/ocaml/typing/shape.ml new file mode 100644 index 0000000..fb89660 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/shape.ml @@ -0,0 +1,580 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Uid = struct + type t = + | Compilation_unit of string + | Item of { comp_unit: string; id: int } + | Internal + | Predef of string + + include Identifiable.Make(struct + type nonrec t = t + + let equal (x : t) y = x = y + let compare (x : t) y = compare x y + let hash (x : t) = Hashtbl.hash x + + let print fmt = function + | Internal -> Format.pp_print_string fmt "" + | Predef name -> Format.fprintf fmt "" name + | Compilation_unit s -> Format.pp_print_string fmt s + | Item { comp_unit; id } -> Format.fprintf fmt "%s.%d" comp_unit id + + let output oc t = + let fmt = Format.formatter_of_out_channel oc in + print fmt t + end) + + let id = ref (-1) + + let reinit () = id := (-1) + + let mk ~current_unit = + incr id; + Item { comp_unit = current_unit; id = !id } + + let of_compilation_unit_id id = + if not (Ident.persistent id) then + Misc.fatal_errorf "Types.Uid.of_compilation_unit_id %S" (Ident.name id); + Compilation_unit (Ident.name id) + + let of_predef_id id = + if not (Ident.is_predef id) then + Misc.fatal_errorf "Types.Uid.of_predef_id %S" (Ident.name id); + Predef (Ident.name id) + + let internal_not_actually_unique = Internal + + let for_actual_declaration = function + | Item _ -> true + | _ -> false +end + +module Sig_component_kind = struct + type t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + let to_string = function + | Value -> "value" + | Type -> "type" + | Module -> "module" + | Module_type -> "module type" + | Extension_constructor -> "extension constructor" + | Class -> "class" + | Class_type -> "class type" + + let can_appear_in_types = function + | Value + | Extension_constructor -> + false + | Type + | Module + | Module_type + | Class + | Class_type -> + true +end + +module Item = struct + module T = struct + type t = string * Sig_component_kind.t + let compare = compare + + let make str ns = str, ns + + let value id = Ident.name id, Sig_component_kind.Value + let type_ id = Ident.name id, Sig_component_kind.Type + let module_ id = Ident.name id, Sig_component_kind.Module + let module_type id = Ident.name id, Sig_component_kind.Module_type + let extension_constructor id = + Ident.name id, Sig_component_kind.Extension_constructor + let class_ id = + Ident.name id, Sig_component_kind.Class + let class_type id = + Ident.name id, Sig_component_kind.Class_type + + let print fmt (name, ns) = + Format.fprintf fmt "%S[%s]" + name + (Sig_component_kind.to_string ns) + end + + include T + + module Map = Map.Make(T) +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + +let print fmt = + let print_uid_opt = + Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print) + in + let rec aux fmt { uid; desc } = + match desc with + | Var id -> + Format.fprintf fmt "%a%a" Ident.print id print_uid_opt uid + | Abs (id, t) -> + let rec collect_idents = function + | { uid = None; desc = Abs(id, t) } -> + let (ids, body) = collect_idents t in + id :: ids, body + | body -> + ([], body) + in + let (other_idents, body) = collect_idents t in + let pp_idents fmt idents = + let pp_sep fmt () = Format.fprintf fmt ",@ " in + Format.pp_print_list ~pp_sep Ident.print fmt idents + in + Format.fprintf fmt "Abs@[%a@,(@[%a,@ @[%a@]@])@]" + print_uid_opt uid pp_idents (id :: other_idents) aux body + | App (t1, t2) -> + Format.fprintf fmt "@[%a(@,%a)%a@]" aux t1 aux t2 + print_uid_opt uid + | Leaf -> + Format.fprintf fmt "<%a>" (Format.pp_print_option Uid.print) uid + | Proj (t, item) -> + begin match uid with + | None -> + Format.fprintf fmt "@[%a@ .@ %a@]" + aux t + Item.print item + | Some uid -> + Format.fprintf fmt "@[(%a@ .@ %a)<%a>@]" + aux t + Item.print item + Uid.print uid + end + | Comp_unit name -> Format.fprintf fmt "CU %s" name + | Struct map -> + let print_map fmt = + Item.Map.iter (fun item t -> + Format.fprintf fmt "@[%a ->@ %a;@]@," + Item.print item + aux t + ) + in + Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + in + Format.fprintf fmt"@[%a@]@;" aux + +let fresh_var ?(name="shape-var") uid = + let var = Ident.create_local name in + var, { uid = Some uid; desc = Var var } + +let for_unnamed_functor_param = Ident.create_local "()" + +let var uid id = + { uid = Some uid; desc = Var id } + +let abs ?uid var body = + { uid; desc = Abs (var, body) } + +let str ?uid map = + { uid; desc = Struct map } + +let leaf uid = + { uid = Some uid; desc = Leaf } + +let proj ?uid t item = + match t.desc with + | Leaf -> + (* When stuck projecting in a leaf we propagate the leaf + as a best effort *) + t + | Struct map -> + begin try Item.Map.find item map + with Not_found -> t (* ill-typed program *) + end + | _ -> + { uid; desc = Proj (t, item) } + +let app ?uid f ~arg = + { uid; desc = App (f, arg) } + +let decompose_abs t = + match t.desc with + | Abs (x, t) -> Some (x, t) + | _ -> None + +module Make_reduce(Params : sig + type env + val fuel : int + val read_unit_shape : unit_name:string -> t option + val find_shape : env -> Ident.t -> t +end) = struct + (* We implement a strong call-by-need reduction, following an + evaluator from Nathanaelle Courant. *) + + type nf = { uid: Uid.t option; desc: nf_desc } + and nf_desc = + | NVar of var + | NApp of nf * nf + | NAbs of local_env * var * t * delayed_nf + | NStruct of delayed_nf Item.Map.t + | NProj of nf * Item.t + | NLeaf + | NComp_unit of string + | NoFuelLeft of desc + (* A type of normal forms for strong call-by-need evaluation. + The normal form of an abstraction + Abs(x, t) + is a closure + NAbs(env, x, t, dnf) + when [env] is the local environment, and [dnf] is a delayed + normal form of [t]. + + A "delayed normal form" is morally equivalent to (nf Lazy.t), but + we use a different representation that is compatible with + memoization (lazy values are not hashable/comparable by default + comparison functions): we represent a delayed normal form as + just a not-yet-computed pair [local_env * t] of a term in a + local environment -- we could also see this as a term under + an explicit substitution. This delayed thunked is "forced" + by calling the normalization function as usual, but duplicate + computations are precisely avoided by memoization. + *) + and delayed_nf = Thunk of local_env * t + + and local_env = delayed_nf option Ident.Map.t + (* When reducing in the body of an abstraction [Abs(x, body)], we + bind [x] to [None] in the environment. [Some v] is used for + actual substitutions, for example in [App(Abs(x, body), t)], when + [v] is a thunk that will evaluate to the normal form of [t]. *) + + let improve_uid uid (nf : nf) = + match nf.uid with + | Some _ -> nf + | None -> { nf with uid } + + let in_memo_table memo_table memo_key f arg = + match Hashtbl.find memo_table memo_key with + | res -> res + | exception Not_found -> + let res = f arg in + Hashtbl.replace memo_table memo_key res; + res + + type env = { + fuel: int ref; + global_env: Params.env; + local_env: local_env; + reduce_memo_table: (local_env * t, nf) Hashtbl.t; + read_back_memo_table: (nf, t) Hashtbl.t; + } + + let bind env var shape = + { env with local_env = Ident.Map.add var shape env.local_env } + + let rec reduce_ env t = + let memo_key = (env.local_env, t) in + in_memo_table env.reduce_memo_table memo_key (reduce__ env) t + (* Memoization is absolutely essential for performance on this + problem, because the normal forms we build can in some real-world + cases contain an exponential amount of redundancy. Memoization + can avoid the repeated evaluation of identical subterms, + providing a large speedup, but even more importantly it + implicitly shares the memory of the repeated results, providing + much smaller normal forms (that blow up again if printed back + as trees). A functor-heavy file from Irmin has its shape normal + form decrease from 100Mio to 2.5Mio when memoization is enabled. + + Note: the local environment is part of the memoization key, while + it is defined using a type Ident.Map.t of non-canonical balanced + trees: two maps could have exactly the same items, but be + balanced differently and therefore hash differently, reducing + the effectivenss of memoization. + This could in theory happen, say, with the two programs + (fun x -> fun y -> ...) + and + (fun y -> fun x -> ...) + having "the same" local environments, with additions done in + a different order, giving non-structurally-equal trees. Should we + define our own hash functions to provide robust hashing on + environments? + + We believe that the answer is "no": this problem does not occur + in practice. We can assume that identifiers are unique on valid + typedtree fragments (identifier "stamps" distinguish + binding positions); in particular the two program fragments above + in fact bind *distinct* identifiers x (with different stamps) and + different identifiers y, so the environments are distinct. If two + environments are structurally the same, they must correspond to + the evaluation evnrionments of two sub-terms that are under + exactly the same scope of binders. So the two environments were + obtained by the same term traversal, adding binders in the same + order, giving the same balanced trees: the environments have the + same hash. +*) + + and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) = + let reduce env t = reduce_ env t in + let delay_reduce env t = Thunk (env.local_env, t) in + let force (Thunk (local_env, t)) = + reduce { env with local_env } t in + let return desc : nf = { uid = t.uid; desc } in + if !fuel < 0 then return (NoFuelLeft t.desc) + else + match t.desc with + | Comp_unit unit_name -> + begin match Params.read_unit_shape ~unit_name with + | Some t -> reduce env t + | None -> return (NComp_unit unit_name) + end + | App(f, arg) -> + let f = reduce env f in + begin match f.desc with + | NAbs(clos_env, var, body, _body_nf) -> + let arg = delay_reduce env arg in + let env = bind { env with local_env = clos_env } var (Some arg) in + reduce env body + |> improve_uid t.uid + | _ -> + let arg = reduce env arg in + return (NApp(f, arg)) + end + | Proj(str, item) -> + let str = reduce env str in + let nored () = return (NProj(str, item)) in + begin match str.desc with + | NStruct (items) -> + begin match Item.Map.find item items with + | exception Not_found -> nored () + | nf -> + force nf + |> improve_uid t.uid + end + | _ -> + nored () + end + | Abs(var, body) -> + let body_nf = delay_reduce (bind env var None) body in + return (NAbs(local_env, var, body, body_nf)) + | Var id -> + begin match Ident.Map.find id local_env with + (* Note: instead of binding abstraction-bound variables to + [None], we could unify it with the [Some v] case by + binding the bound variable [x] to [NVar x]. + + One reason to distinguish the situations is that we can + provide a different [Uid.t] location; for bound + variables, we use the [Uid.t] of the bound occurrence + (not the binding site), whereas for bound values we use + their binding-time [Uid.t]. *) + | None -> return (NVar id) + | Some def -> force def + | exception Not_found -> + match Params.find_shape global_env id with + | exception Not_found -> return (NVar id) + | res when res = t -> return (NVar id) + | res -> + decr fuel; + reduce env res + end + | Leaf -> return NLeaf + | Struct m -> + let mnf = Item.Map.map (delay_reduce env) m in + return (NStruct mnf) + + let rec read_back env (nf : nf) : t = + in_memo_table env.read_back_memo_table nf (read_back_ env) nf + (* The [nf] normal form we receive may contain a lot of internal + sharing due to the use of memoization in the evaluator. We have + to memoize here again, otherwise the sharing is lost by mapping + over the term as a tree. *) + + and read_back_ env (nf : nf) : t = + { uid = nf.uid; desc = read_back_desc env nf.desc } + + and read_back_desc env desc = + let read_back nf = read_back env nf in + let read_back_force (Thunk (local_env, t)) = + read_back (reduce_ { env with local_env } t) in + match desc with + | NVar v -> + Var v + | NApp (nft, nfu) -> + App(read_back nft, read_back nfu) + | NAbs (_env, x, _t, nf) -> + Abs(x, read_back_force nf) + | NStruct nstr -> + Struct (Item.Map.map read_back_force nstr) + | NProj (nf, item) -> + Proj (read_back nf, item) + | NLeaf -> Leaf + | NComp_unit s -> Comp_unit s + | NoFuelLeft t -> t + + (* When in Merlin we don't need to perform full shape reduction since we are + only interested by uid's stored at the "top-level" of the shape once the + projections have been done. *) + let weak_read_back env (nf : nf) : t = + let cache = Hashtbl.create 42 in + let rec weak_read_back env nf = + let memo_key = (env.local_env, nf) in + in_memo_table cache memo_key (weak_read_back_ env) nf + and weak_read_back_ env nf : t = + { uid = nf.uid; desc = weak_read_back_desc env nf.desc } + and weak_read_back_desc env desc : desc = + let weak_read_back_no_force (Thunk (_local_env, t)) = t in + match desc with + | NVar v -> + Var v + | NApp (nft, nfu) -> + App(weak_read_back env nft, weak_read_back env nfu) + | NAbs (_env, x, _t, nf) -> + Abs(x, weak_read_back_no_force nf) + | NStruct nstr -> + Struct (Item.Map.map weak_read_back_no_force nstr) + | NProj (nf, item) -> + Proj (read_back env nf, item) + | NLeaf -> Leaf + | NComp_unit s -> Comp_unit s + | NoFuelLeft t -> t + in weak_read_back env nf + + let reduce global_env t = + let fuel = ref Params.fuel in + let reduce_memo_table = Hashtbl.create 42 in + let read_back_memo_table = Hashtbl.create 42 in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table; + read_back_memo_table; + local_env; + } in + reduce_ env t |> read_back env + + let weak_reduce global_env t = + let fuel = ref Params.fuel in + let reduce_memo_table = Hashtbl.create 42 in + let read_back_memo_table = Hashtbl.create 42 in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table; + read_back_memo_table; + local_env; + } in + reduce_ env t |> weak_read_back env +end + +module Local_reduce = + (* Note: this definition with [type env = unit] is only suitable for + reduction of toplevel shapes -- shapes of compilation units, + where free variables are only Comp_unit names. If we wanted to + reduce shapes inside module signatures, we would need to take + a typing environment as parameter. *) + Make_reduce(struct + type env = unit + let fuel = 10 + let read_unit_shape ~unit_name:_ = None + let find_shape _env _id = raise Not_found + end) + +let local_reduce shape = + Local_reduce.reduce () shape + +let dummy_mod = { uid = None; desc = Struct Item.Map.empty } + +let of_path ~find_shape ~namespace = + let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function + | Pident id -> find_shape ns id + | Pdot (path, name) -> proj (aux Module path) (name, ns) + | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) + | Pextra_ty (path, extra) -> begin + match extra with + Pcstr_ty _ -> aux Type path + | Pext_ty -> aux Extension_constructor path + end + in + aux namespace + +let for_persistent_unit s = + { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s)); + desc = Comp_unit s } + +let leaf_for_unpack = { uid = None; desc = Leaf } + +let set_uid_if_none t uid = + match t.uid with + | None -> { t with uid = Some uid } + | _ -> t + +module Map = struct + type shape = t + type nonrec t = t Item.Map.t + + let empty = Item.Map.empty + + let add t item shape = Item.Map.add item shape t + + let add_value t id uid = Item.Map.add (Item.value id) (leaf uid) t + let add_value_proj t id shape = + let item = Item.value id in + Item.Map.add item (proj shape item) t + + let add_type t id uid = Item.Map.add (Item.type_ id) (leaf uid) t + let add_type_proj t id shape = + let item = Item.type_ id in + Item.Map.add item (proj shape item) t + + let add_module t id shape = Item.Map.add (Item.module_ id) shape t + let add_module_proj t id shape = + let item = Item.module_ id in + Item.Map.add item (proj shape item) t + + let add_module_type t id uid = + Item.Map.add (Item.module_type id) (leaf uid) t + let add_module_type_proj t id shape = + let item = Item.module_type id in + Item.Map.add item (proj shape item) t + + let add_extcons t id uid = + Item.Map.add (Item.extension_constructor id) (leaf uid) t + let add_extcons_proj t id shape = + let item = Item.extension_constructor id in + Item.Map.add item (proj shape item) t + + let add_class t id uid = Item.Map.add (Item.class_ id) (leaf uid) t + let add_class_proj t id shape = + let item = Item.class_ id in + Item.Map.add item (proj shape item) t + + let add_class_type t id uid = Item.Map.add (Item.class_type id) (leaf uid) t + let add_class_type_proj t id shape = + let item = Item.class_type id in + Item.Map.add item (proj shape item) t +end diff --git a/ocamlmerlin_mlx/ocaml/typing/shape.mli b/ocamlmerlin_mlx/ocaml/typing/shape.mli new file mode 100644 index 0000000..9740a3a --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/shape.mli @@ -0,0 +1,158 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Uid : sig + type t = private + | Compilation_unit of string + | Item of { comp_unit: string; id: int } + | Internal + | Predef of string + + val reinit : unit -> unit + + val mk : current_unit:string -> t + val of_compilation_unit_id : Ident.t -> t + val of_predef_id : Ident.t -> t + val internal_not_actually_unique : t + + val for_actual_declaration : t -> bool + + include Identifiable.S with type t := t +end + +module Sig_component_kind : sig + type t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + val to_string : t -> string + + (** Whether the name of a component of that kind can appear in a type. *) + val can_appear_in_types : t -> bool +end + +module Item : sig + type t + + val make : string -> Sig_component_kind.t -> t + + val value : Ident.t -> t + val type_ : Ident.t -> t + val module_ : Ident.t -> t + val module_type : Ident.t -> t + val extension_constructor : Ident.t -> t + val class_ : Ident.t -> t + val class_type : Ident.t -> t + + module Map : Map.S with type key = t +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + +val print : Format.formatter -> t -> unit + +(* Smart constructors *) + +val for_unnamed_functor_param : var +val fresh_var : ?name:string -> Uid.t -> var * t + +val var : Uid.t -> Ident.t -> t +val abs : ?uid:Uid.t -> var -> t -> t +val app : ?uid:Uid.t -> t -> arg:t -> t +val str : ?uid:Uid.t -> t Item.Map.t -> t +val proj : ?uid:Uid.t -> t -> Item.t -> t +val leaf : Uid.t -> t + +val decompose_abs : t -> (var * t) option + +val for_persistent_unit : string -> t +val leaf_for_unpack : t + +module Map : sig + type shape = t + type nonrec t = t Item.Map.t + + val empty : t + + val add : t -> Item.t -> shape -> t + + val add_value : t -> Ident.t -> Uid.t -> t + val add_value_proj : t -> Ident.t -> shape -> t + + val add_type : t -> Ident.t -> Uid.t -> t + val add_type_proj : t -> Ident.t -> shape -> t + + val add_module : t -> Ident.t -> shape -> t + val add_module_proj : t -> Ident.t -> shape -> t + + val add_module_type : t -> Ident.t -> Uid.t -> t + val add_module_type_proj : t -> Ident.t -> shape -> t + + val add_extcons : t -> Ident.t -> Uid.t -> t + val add_extcons_proj : t -> Ident.t -> shape -> t + + val add_class : t -> Ident.t -> Uid.t -> t + val add_class_proj : t -> Ident.t -> shape -> t + + val add_class_type : t -> Ident.t -> Uid.t -> t + val add_class_type_proj : t -> Ident.t -> shape -> t +end + +val dummy_mod : t + +val of_path : + find_shape:(Sig_component_kind.t -> Ident.t -> t) -> + namespace:Sig_component_kind.t -> Path.t -> t + +val set_uid_if_none : t -> Uid.t -> t + +(** The [Make_reduce] functor is used to generate a reduction function for + shapes. + + It is parametrized by: + - an environment and a function to find shapes by path in that environment + - a function to load the shape of an external compilation unit + - some fuel, which is used to bound recursion when dealing with recursive + shapes introduced by recursive modules. (FTR: merlin currently uses a + fuel of 10, which seems to be enough for most practical examples) +*) +module Make_reduce(Context : sig + type env + + val fuel : int + + val read_unit_shape : unit_name:string -> t option + + val find_shape : env -> Ident.t -> t + end) : sig + val reduce : Context.env -> t -> t + val weak_reduce : Context.env -> t -> t +end + +val local_reduce : t -> t diff --git a/ocamlmerlin_mlx/ocaml/typing/short_paths.ml b/ocamlmerlin_mlx/ocaml/typing/short_paths.ml new file mode 100644 index 0000000..9493afb --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/short_paths.ml @@ -0,0 +1,1933 @@ + +open Short_paths_graph + +module Desc = Desc + +module Rev_deps : sig + + type t + + val create : unit -> t + + val extend_up_to : t -> Dependency.t -> unit + + val get : t -> Dependency.t -> Dependency.Set.t + + val add : t -> source:Dependency.t -> target:Dependency.t -> unit + + val add_alias : t -> source:Dependency.t -> target:Dependency.t -> unit + + val before : t -> Origin.t -> Origin.t -> bool + +end = struct + + module Stamp = Natural.Make() + + type item = + { mutable set : Dependency.Set.t; + mutable edges : Dependency.t list; + mutable alias_edges : Dependency.t list; + mutable last : Stamp.t; } + + type t = + { mutable stamp : Stamp.t; + mutable items : item Dependency.Array.t; } + + let create () = + { stamp = Stamp.one; + items = Dependency.Array.empty; } + + let extend_up_to t next = + match Dependency.pred next with + | None -> () + | Some curr -> + if not (Dependency.Array.contains t.items curr) then begin + let items = + Dependency.Array.extend t.items curr + (fun _ -> { set = Dependency.Set.empty; + edges = []; + alias_edges = []; + last = Stamp.zero; }) + in + t.items <- items + end + + let add t ~source ~target = + let item = Dependency.Array.get t.items source in + item.edges <- target :: item.edges; + t.stamp <- Stamp.succ t.stamp + + let add_alias t ~source ~target = + let item = Dependency.Array.get t.items source in + item.alias_edges <- target :: item.alias_edges; + t.stamp <- Stamp.succ t.stamp + + let update t dep item = + if Stamp.less_than item.last t.stamp then begin + let rec add_edges t item acc = + let rec loop t acc added = function + | [] -> + List.fold_left + (fun acc dep -> + let item = Dependency.Array.get t.items dep in + add_alias_edges t item acc) + acc added + | dep :: rest -> + if Dependency.Set.mem dep acc then loop t acc added rest + else begin + let acc = Dependency.Set.add dep acc in + let added = dep :: added in + loop t acc added rest + end + in + loop t acc [] item.edges + and add_alias_edges t item acc = + List.fold_left + (fun acc dep -> + if Dependency.Set.mem dep acc then acc + else begin + let acc = Dependency.Set.add dep acc in + let item = Dependency.Array.get t.items dep in + let acc = add_edges t item acc in + add_alias_edges t item acc + end) + acc item.alias_edges + in + let set = Dependency.Set.singleton dep in + let set = add_edges t item set in + let set = add_alias_edges t item set in + item.set <- set; + item.last <- t.stamp + end + + let get t dep = + let item = Dependency.Array.get t.items dep in + update t dep item; + item.set + + let before t origin1 origin2 = + let open Origin in + match origin1, origin2 with + | Environment age1, Environment age2 -> Age.less_than age1 age2 + | Environment _, Dependency _ -> false + | Environment _, Dependencies _ -> false + | Dependency _, Environment _ -> true + | Dependency dep1, Dependency dep2 -> + let rev_dep = get t dep1 in + Dependency.Set.mem dep2 rev_dep + | Dependency dep1, Dependencies deps2 -> + let rev_dep = get t dep1 in + List.exists + (fun dep2 -> Dependency.Set.mem dep2 rev_dep) + deps2 + | Dependencies _, Environment _ -> true + | Dependencies deps1, Dependency dep2 -> + List.for_all + (fun dep1 -> Dependency.Set.mem dep2 (get t dep1)) + deps1 + | Dependencies deps1, Dependencies deps2 -> + let rev_dep = + match deps1 with + | [] -> failwith "Rev_deps.before: invalid origin" + | dep1 :: deps1 -> + List.fold_left + (fun acc dep1 -> Dependency.Set.inter acc (get t dep1)) + (get t dep1) deps1 + in + List.exists + (fun dep2 -> Dependency.Set.mem dep2 rev_dep) + deps2 + +end + +module Origin_range_tbl = struct + + type 'a t = + { mutable envs : 'a list Age.Map.t; + mutable dep_keys : Dependency.Set.t; + deps : 'a list Dependency.Tbl.t; } + + let create () = + { envs = Age.Map.empty; + dep_keys = Dependency.Set.empty; + deps = Dependency.Tbl.create 0; } + + let add_dependency dep data t = + t.dep_keys <- Dependency.Set.add dep t.dep_keys; + let prev = + match Dependency.Tbl.find t.deps dep with + | exception Not_found -> [] + | prev -> prev + in + Dependency.Tbl.replace t.deps dep (data :: prev) + + let add_age age data t = + let prev = + match Age.Map.find age t.envs with + | exception Not_found -> [] + | prev -> prev + in + t.envs <- Age.Map.add age (data :: prev) t.envs + + let add rev_deps origin data t = + match origin with + | Origin.Dependency dep -> add_dependency dep data t + | Origin.Environment age -> add_age age data t + | Origin.Dependencies deps -> begin + let rev_dep_opt = + List.fold_left + (fun acc dep -> + let rev_dep = Rev_deps.get rev_deps dep in + match acc with + | None -> Some rev_dep + | Some acc -> Some (Dependency.Set.inter acc rev_dep)) + None deps + in + let rev_dep = + match rev_dep_opt with + | None -> failwith "Origin_range_tbl.add: invalid origin" + | Some rev_dep -> rev_dep + in + match + List.find + (fun dep -> Dependency.Set.mem dep rev_dep) + deps + with + | dep -> add_dependency dep data t + | exception Not_found -> + match Dependency.Set.choose rev_dep with + | dep -> add_dependency dep data t + | exception Not_found -> add_age Age.zero data t + end + + let pop_dependency rev_dep t = + let matching = Dependency.Set.inter rev_dep t.dep_keys in + t.dep_keys <- Dependency.Set.diff t.dep_keys matching; + let items = + Dependency.Set.fold + (fun dep acc -> + let data = Dependency.Tbl.find t.deps dep in + Dependency.Tbl.remove t.deps dep; + List.rev_append data acc) + matching + [] + in + let items = + Age.Map.fold + (fun _ data acc -> List.rev_append data acc) + t.envs items + in + t.envs <- Age.Map.empty; + items + + let pop_age age t = + let envs, first, matching = Age.Map.split age t.envs in + let items = + match first with + | None -> [] + | Some first -> first + in + let items = + Age.Map.fold + (fun _ data acc -> List.rev_append data acc) + matching items + in + t.envs <- envs; + items + + let pop rev_deps origin t = + match origin with + | Origin.Dependency dep -> + let rev_dep = Rev_deps.get rev_deps dep in + pop_dependency rev_dep t + | Origin.Dependencies deps -> + let rev_dep_opt = + List.fold_left + (fun acc dep -> + let rev_dep = Rev_deps.get rev_deps dep in + match acc with + | None -> Some rev_dep + | Some acc -> Some (Dependency.Set.inter acc rev_dep)) + None deps + in + let rev_dep = + match rev_dep_opt with + | None -> failwith "Origin_range_tbl.pop: invalid origin" + | Some rev_dep -> rev_dep + in + pop_dependency rev_dep t + | Origin.Environment age -> + pop_age age t + + let is_origin_empty rev_deps origin t = + match origin with + | Origin.Dependency dep -> + if not (Age.Map.is_empty t.envs) then false + else begin + let rev_dep = Rev_deps.get rev_deps dep in + let matching = Dependency.Set.inter rev_dep t.dep_keys in + Dependency.Set.is_empty matching + end + | Origin.Dependencies deps -> + if not (Age.Map.is_empty t.envs) then false + else begin + let rev_dep_opt = + List.fold_left + (fun acc dep -> + let rev_dep = Rev_deps.get rev_deps dep in + match acc with + | None -> Some rev_dep + | Some acc -> Some (Dependency.Set.inter acc rev_dep)) + None deps + in + let rev_dep = + match rev_dep_opt with + | None -> + failwith "Origin_range_tbl.is_origin_empty: invalid origin" + | Some rev_dep -> rev_dep + in + let matching = Dependency.Set.inter rev_dep t.dep_keys in + Dependency.Set.is_empty matching + end + | Origin.Environment age -> + match Age.Map.max_binding t.envs with + | exception Not_found -> true + | (max, _) -> Age.less_than max age + + let is_completely_empty t = + Age.Map.is_empty t.envs + && Dependency.Set.is_empty t.dep_keys + +end + +module Height = Natural.Make_no_zero() + +module Todo = struct + + module Item = struct + + type t = + | Base of Diff.Item.t + | Children of + { md : Module.t; + path : Path.t; + seen : Path_set.t; } + | Update of + { id : Ident.t; + origin : Origin.t; } + | Forward of + { id : Ident.t; + decl : Origin.t; + origin : Origin.t; } + + end + + type t = + { mutable table : Item.t Origin_range_tbl.t Height.Array.t } + + let create graph rev_deps diff = + let tbl = Origin_range_tbl.create () in + List.iter + (fun item -> + let origin = Diff.Item.origin graph item in + match Diff.Item.previous graph item with + | None -> + Origin_range_tbl.add rev_deps origin (Item.Base item) tbl; + | Some decl -> + let id = Diff.Item.id graph item in + let item = Item.Forward { id; decl; origin } in + Origin_range_tbl.add rev_deps origin item tbl) + diff; + let table = Height.Array.singleton tbl in + { table } + + let get_table t height = + if not (Height.Array.contains t.table height) then begin + t.table <- Height.Array.extend t.table height + (fun _ -> Origin_range_tbl.create ()); + end; + Height.Array.get t.table height + + let get_table_opt t height = + if Height.Array.contains t.table height then + Some (Height.Array.get t.table height) + else None + + let retract_empty t = + let rec loop height = + match Height.pred height with + | None -> + t.table <- Height.Array.empty + | Some prev -> + let tbl = Height.Array.get t.table prev in + if Origin_range_tbl.is_completely_empty tbl then loop prev + else begin + t.table <- Height.Array.retract t.table height + end + in + match Height.Array.last t.table with + | None -> () + | Some last -> + let tbl = Height.Array.get t.table last in + if Origin_range_tbl.is_completely_empty tbl then loop last + else () + + let merge graph rev_deps t diff = + let tbl = get_table t Height.one in + List.iter + (fun item -> + match Diff.Item.previous graph item with + | None -> () + | Some origin -> + let id = Diff.Item.id graph item in + let item = Item.Update { id; origin } in + Origin_range_tbl.add rev_deps origin item tbl) + diff + + let mutate graph rev_deps t diff = + let tbl = get_table t Height.one in + List.iter + (fun item -> + match Diff.Item.previous graph item with + | None -> + let origin = Diff.Item.origin graph item in + Origin_range_tbl.add rev_deps origin (Item.Base item) tbl; + | Some origin -> + let id = Diff.Item.id graph item in + let item = Item.Update { id; origin } in + Origin_range_tbl.add rev_deps origin item tbl) + diff + + let add_children graph rev_deps t height md path seen = + let height = Height.succ height in + let tbl = get_table t height in + let origin = Module.origin graph md in + Origin_range_tbl.add rev_deps origin (Item.Children{md; path; seen}) tbl + + let add_next_update rev_deps t height origin id = + let height = Height.succ height in + let tbl = get_table t height in + let item = Item.Update { id; origin } in + Origin_range_tbl.add rev_deps origin item tbl + + let add_next_forward rev_deps t height origin id decl = + let height = Height.succ height in + let tbl = get_table t height in + let item = Item.Forward { id; decl; origin } in + Origin_range_tbl.add rev_deps origin item tbl + + let rec is_empty_from rev_deps t height origin = + match get_table_opt t height with + | None -> true + | Some tbl -> + Origin_range_tbl.is_origin_empty rev_deps origin tbl + && is_empty_from rev_deps t (Height.succ height) origin + + let pop rev_deps t height origin = + match get_table_opt t height with + | None -> + retract_empty t; + None + | Some tbl -> + match Origin_range_tbl.pop rev_deps origin tbl with + | [] -> + let empty_from = + is_empty_from rev_deps t (Height.succ height) origin + in + if not empty_from then Some [] + else begin + retract_empty t; + None + end + | _ :: _ as todo -> Some todo + +end + +module Forward_path_map : sig + + type 'a t + + val empty : 'a t + + val add : 'a t -> Sort.t -> Path.t -> 'a -> 'a t + + val find : 'a t -> Path.t -> 'a list + + val rebase : 'a t -> 'a t -> 'a t + + val iter_forwards : (Path.t -> 'a -> unit) -> 'a t -> Ident.t -> unit + + val iter_updates : (Path.t -> 'a -> unit) -> 'a t -> Ident.t -> unit + +end = struct + + type 'a t = + { new_paths : 'a list Path_map.t; + old_paths : 'a list Path_map.t; + updates : Path_set.t Ident_map.t; + forwards : Path_set.t Ident_map.t; } + + let empty = + { new_paths = Path_map.empty; + old_paths = Path_map.empty; + forwards = Ident_map.empty; + updates = Ident_map.empty; } + + let add t sort path data = + let new_paths = t.new_paths in + let prev = + match Path_map.find path new_paths with + | prev -> prev + | exception Not_found -> [] + in + let new_paths = Path_map.add path (data :: prev) new_paths in + let updates = t.updates in + let updates = + match sort with + | Sort.Defined -> updates + | Sort.Declared ids -> + Ident_set.fold + (fun id acc -> + let prev = + match Ident_map.find id updates with + | prev -> prev + | exception Not_found -> Path_set.empty + in + Ident_map.add id (Path_set.add path prev) acc) + ids updates + in + { t with new_paths; updates } + + let find t path = + match Path_map.find path t.new_paths with + | exception Not_found -> Path_map.find path t.old_paths + | new_paths -> + match Path_map.find path t.old_paths with + | exception Not_found -> new_paths + | old_paths -> new_paths @ old_paths + + let rebase t base = + let old_paths = + Path_map.union + (fun _ paths1 paths2 -> Some (paths1 @ paths2)) + base.new_paths base.old_paths + in + let forwards = + Ident_map.union + (fun _ pset1 pset2 -> Some (Path_set.union pset1 pset2)) + base.updates base.forwards + in + { t with old_paths; forwards } + + let iter_updates f t id = + match Ident_map.find id t.updates with + | exception Not_found -> () + | pset -> + Path_set.iter + (fun path -> + match Path_map.find path t.new_paths with + | exception Not_found -> () + | paths -> List.iter (f path) paths) + pset + + let iter_forwards f t id = + match Ident_map.find id t.forwards with + | exception Not_found -> () + | pset -> + Path_set.iter + (fun path -> + match Path_map.find path t.old_paths with + | exception Not_found -> () + | paths -> List.iter (f path) paths) + pset + +end + +module Origin_tbl = Hashtbl.Make(Origin) + +module History : sig + + module Stamp : Natural.S + + module Revision : sig + + type t + + val stamp : t -> Stamp.t + + val diff : t -> Diff.t + + val rev_deps : t -> Rev_deps.t + + val next : t -> t option + + end + + type t + + val init : Rev_deps.t -> Diff.t -> t + + val head : t -> Revision.t + + val commit : t -> Rev_deps.t -> Diff.t -> unit + +end = struct + + module Stamp = Natural.Make() + + module Revision = struct + + type t = + { stamp : Stamp.t; + diff : Diff.t; + rev_deps : Rev_deps.t; + mutable next : t option; } + + let stamp t = t.stamp + + let diff t = t.diff + + let rev_deps t = t.rev_deps + + let next t = t.next + + end + + type t = + { mutable head : Revision.t; } + + let init rev_deps diff = + let stamp = Stamp.zero in + let next = None in + let head = { Revision.stamp; diff; rev_deps; next } in + { head } + + let head t = t.head + + let commit t rev_deps diff = + let head = t.head in + let stamp = Stamp.succ head.Revision.stamp in + let next = None in + let rev = { Revision.stamp; diff; rev_deps; next } in + head.Revision.next <- Some rev; + t.head <- rev + +end + +type type_resolution = + | Nth of int + | Subst of int list + | Id + +type type_result = + | Nth of int + | Path of int list option * Path.t + +type class_type_result = int list option * Path.t + +module Shortest = struct + + module Section = struct + + type t = + { mutable types : Path.t Forward_path_map.t; + mutable class_types : Path.t Forward_path_map.t; + mutable module_types : Path.t Forward_path_map.t; + mutable modules : (Path.t * Path_set.t) Forward_path_map.t; } + + let create () = + let types = Forward_path_map.empty in + let class_types = Forward_path_map.empty in + let module_types = Forward_path_map.empty in + let modules = Forward_path_map.empty in + { types; class_types; module_types; modules } + + let add_type graph t typ path = + let canonical = Type.path graph typ in + let sort = Type.sort graph typ in + t.types <- Forward_path_map.add t.types sort canonical path + + let add_class_type graph t mty path = + let canonical = Class_type.path graph mty in + let sort = Class_type.sort graph mty in + t.class_types <- Forward_path_map.add t.class_types sort canonical path + + let add_module_type graph t mty path = + let canonical = Module_type.path graph mty in + let sort = Module_type.sort graph mty in + t.module_types <- Forward_path_map.add t.module_types sort canonical path + + let add_module graph t md path = + let canonical = Module.path graph md in + let sort = Module.sort graph md in + t.modules <- Forward_path_map.add t.modules sort canonical path + + let rebase t parent = + t.types <- Forward_path_map.rebase t.types parent.types; + t.class_types <- Forward_path_map.rebase t.class_types parent.class_types; + t.module_types <- Forward_path_map.rebase t.module_types parent.module_types; + t.modules <- Forward_path_map.rebase t.modules parent.modules + + let iter_updates ~type_ ~class_type ~module_type ~module_ t id = + Forward_path_map.iter_updates type_ t.types id; + Forward_path_map.iter_updates class_type t.class_types id; + Forward_path_map.iter_updates module_type t.module_types id; + Forward_path_map.iter_updates module_ t.modules id + + let iter_forwards ~type_ ~class_type ~module_type ~module_ t id = + Forward_path_map.iter_forwards type_ t.types id; + Forward_path_map.iter_forwards class_type t.class_types id; + Forward_path_map.iter_forwards module_type t.module_types id; + Forward_path_map.iter_forwards module_ t.modules id + + let find_type graph t typ = + let canonical = Type.path graph typ in + Forward_path_map.find t.types canonical + + let find_class_type graph t mty = + let canonical = Class_type.path graph mty in + Forward_path_map.find t.class_types canonical + + let find_module_type graph t mty = + let canonical = Module_type.path graph mty in + Forward_path_map.find t.module_types canonical + + let find_module graph t md = + let canonical = Module.path graph md in + Forward_path_map.find t.modules canonical + + end + + module Sections = struct + + type range = + | Until of Height.t + | All + + type versioning = + | Unversioned + | Initialisation of History.Stamp.t + | Completion of History.Stamp.t + + type t = + { mutable sections : Section.t Height.Array.t; + mutable initialised : range; + mutable completed : range; + mutable versioning : versioning; } + + let create age origin = + let sections = Height.Array.empty in + let completed = Until Height.one in + let initialised, versioning = + if Age.equal age Age.zero then begin + All, Completion History.Stamp.zero + end else begin + match origin with + | Origin.Environment age' -> + let initialised = + if Age.less_than_or_equal age age' then All + else Until Height.one + in + initialised, Unversioned + | Origin.Dependency _ | Origin.Dependencies _ -> + Until Height.one, Initialisation History.Stamp.zero + end + in + { sections; initialised; completed; versioning; } + + let update t stamp = + match t.versioning with + | Unversioned -> () + | Initialisation initialised -> + if History.Stamp.less_than initialised stamp then begin + t.initialised <- Until Height.one; + t.versioning <- Initialisation stamp + end + | Completion completed -> + if History.Stamp.less_than completed stamp then begin + t.completed <- Until Height.one; + t.versioning <- Completion stamp + end + + let expand t height = + let sections = t.sections in + if not (Height.Array.contains sections height) then begin + let sections = + Height.Array.extend sections height + (fun _ -> Section.create ()) + in + t.sections <- sections; + sections + end else begin + sections + end + + let is_initialised t height = + match t.initialised with + | All -> true + | Until until -> Height.less_than height until + + let set_initialised t height = + match t.initialised with + | All -> + failwith "Section.set_initialised: already initialised" + | Until until -> + if not (Height.equal until height) then begin + if Height.less_than until height then + failwith "Section.set_initialised: initialised early" + else + failwith "Section.set_initialised: already initialised" + end; + t.initialised <- Until (Height.succ until) + + let set_initialised_from t height = + match t.initialised with + | All -> + failwith "Section.set_initialised: already initialised" + | Until until -> + if not (Height.equal until height) then begin + if Height.less_than until height then + failwith "Section.set_initialised: initialised early" + else + failwith "Section.set_initialised: already initialised" + end; + t.initialised <- All + + let is_completed t height = + match t.completed with + | All -> true + | Until until -> Height.less_than height until + + let set_completed t height = + match t.completed with + | All -> + failwith "Section.set_completed: already completed" + | Until until -> + if not (Height.equal until height) then begin + if Height.less_than until height then + failwith "Section.set_completed: completed early" + else + failwith "Section.set_completed: already completed" + end; + t.completed <- Until (Height.succ until) + + let set_completed_from t height = + match t.completed with + | All -> + failwith "Section.set_completed: already completed" + | Until until -> + if not (Height.equal until height) then begin + if Height.less_than until height then + failwith "Section.set_completed: completed early" + else + failwith "Section.set_completed: already completed" + end; + t.completed <- All + + let is_finished t = + match t.initialised, t.completed with + | All, All -> true + | _, _ -> false + + let get t height = + let sections = t.sections in + if Height.Array.contains sections height then + Some (Height.Array.get sections height) + else None + + let check_initialised t height = + match t.initialised with + | All -> () + | Until until -> + if not (Height.less_than height until) then + failwith "Sections: section not initialised" + + let check_completed t height = + match t.completed with + | All -> () + | Until until -> + if not (Height.less_than height until) then + failwith "Sections: section not completed" + + let check_versions t parent = + match t.versioning, parent.versioning with + | Unversioned, _ | _, Unversioned -> () + | (Completion stamp | Initialisation stamp), + (Completion parent_stamp | Initialisation parent_stamp) -> + if not (History.Stamp.equal stamp parent_stamp) then + failwith "Sections: version mismatch" + + let initialise t height parent = + check_versions t parent; + check_completed parent height; + match get parent height with + | Some parent -> + let sections = expand t height in + let section = Height.Array.get sections height in + Section.rebase section parent; + set_initialised t height + | None -> + if is_finished parent then + set_initialised_from t height + else + set_initialised t height + + let add_type graph t height typ path = + let sections = expand t height in + let section = Height.Array.get sections height in + Section.add_type graph section typ path + + let add_class_type graph t height mty path = + let sections = expand t height in + let section = Height.Array.get sections height in + Section.add_class_type graph section mty path + + let add_module_type graph t height mty path = + let sections = expand t height in + let section = Height.Array.get sections height in + Section.add_module_type graph section mty path + + let add_module graph t height md path = + let sections = expand t height in + let section = Height.Array.get sections height in + Section.add_module graph section md path + + (* returns [true] if there might be updated paths at a greater height. *) + let iter_updates ~type_ ~class_type ~module_type ~module_ t height id = + match get t height with + | Some section -> + Section.iter_updates ~type_ ~class_type + ~module_type ~module_ section id; + true + | None -> false + + (* returns [true] if there might be forward paths at a greater height. *) + let iter_forwards ~type_ ~class_type ~module_type ~module_ t height id = + let all_initialised = + match t.initialised with + | All -> true + | Until until -> + if not (Height.less_than height until) then + failwith "Sections.iter_forwards: section not initialised"; + false + in + match get t height with + | Some section -> + Section.iter_forwards ~type_ ~class_type + ~module_type ~module_ section id; + true + | None -> not all_initialised + + type result = + | Not_found_here + | Not_found_here_or_later + | Found of Path.t + + let rec get_visible_type graph = function + | [] -> None + | path :: rest -> + let visible = Graph.is_type_path_visible graph path in + if visible then Some path + else get_visible_type graph rest + + let rec get_visible_class_type graph = function + | [] -> None + | path :: rest -> + let visible = Graph.is_class_type_path_visible graph path in + if visible then Some path + else get_visible_class_type graph rest + + let rec get_visible_module_type graph = function + | [] -> None + | path :: rest -> + let visible = Graph.is_module_type_path_visible graph path in + if visible then Some path + else get_visible_module_type graph rest + + let rec get_visible_module graph = function + | [] -> None + | (path, _) :: rest -> + let visible = Graph.is_module_path_visible graph path in + if visible then Some path + else get_visible_module graph rest + + let find_type graph t height typ = + check_initialised t height; + check_completed t height; + match get t height with + | Some section -> begin + match Section.find_type graph section typ with + | exception Not_found -> Not_found_here + | paths -> begin + match get_visible_type graph paths with + | None -> Not_found_here + | Some path -> Found path + end + end + | None -> + if is_finished t then Not_found_here_or_later + else Not_found_here + + let find_class_type graph t height mty = + check_initialised t height; + check_completed t height; + match get t height with + | Some section -> begin + match Section.find_class_type graph section mty with + | exception Not_found -> Not_found_here + | paths -> begin + match get_visible_class_type graph paths with + | None -> Not_found_here + | Some path -> Found path + end + end + | None -> + if is_finished t then Not_found_here_or_later + else Not_found_here + + let find_module_type graph t height mty = + check_initialised t height; + check_completed t height; + match get t height with + | Some section -> begin + match Section.find_module_type graph section mty with + | exception Not_found -> Not_found_here + | paths -> begin + match get_visible_module_type graph paths with + | None -> Not_found_here + | Some path -> Found path + end + end + | None -> + if is_finished t then Not_found_here_or_later + else Not_found_here + + let find_module graph t height md = + check_initialised t height; + check_completed t height; + match get t height with + | Some section -> begin + match Section.find_module graph section md with + | exception Not_found -> Not_found_here + | paths -> begin + match get_visible_module graph paths with + | None -> Not_found_here + | Some path -> Found path + end + end + | None -> + if is_finished t then Not_found_here_or_later + else Not_found_here + + end + + type basis + + type env + + type _ kind = + | Basis : + { history : History.t; } + -> basis kind + | Env : + { mutable revision : History.Revision.t; + parent : 'a t; + age : Age.t; } + -> env kind + + and 'a t = + { kind : 'a kind; + mutable graph : Graph.t; + sections: Sections.t Origin_tbl.t; + todos: Todo.t; } + + let age (type k) (t : k t) = + match t.kind with + | Basis _ -> Age.zero + | Env { age; _ } -> age + + let revision (type k) (t : k t) = + match t.kind with + | Basis { history } -> History.head history + | Env { revision; _ } -> revision + + let stamp t = + History.Revision.stamp (revision t) + + let rev_deps t = + History.Revision.rev_deps (revision t) + + let update (type kind) (t : kind t) = + match t.kind with + | Basis _ -> () + | Env ({ revision } as e) -> + let rec loop graph revision = + let next = History.Revision.next revision in + match next with + | None -> revision, graph + | Some revision -> + let diff = History.Revision.diff revision in + let graph = Graph.merge graph diff in + let rev_deps = History.Revision.rev_deps revision in + Todo.merge graph rev_deps t.todos diff; + loop graph revision + in + let revision, graph = loop t.graph revision in + t.graph <- graph; + e.revision <- revision + + let basis rev_deps components = + let graph, diff = Graph.add Graph.empty components in + let history = History.init rev_deps diff in + let kind = Basis { history } in + let sections = Origin_tbl.create 0 in + let todos = Todo.create graph rev_deps diff in + { kind; graph; sections; todos } + + let local_or_open conc = + match conc with + | Desc.Local -> Component.Local + | Desc.Open -> Component.Open + + let env parent desc = + update parent; + let age = Age.succ (age parent) in + let origin = Origin.Environment age in + let components = + List.map + (fun desc -> + match desc with + | Desc.Type(id, desc, conc, dpr) -> + Component.Type(origin, id, desc, local_or_open conc, dpr) + | Desc.Class_type(id, desc, conc, dpr) -> + Component.Class_type(origin, id, desc, local_or_open conc, dpr) + | Desc.Module_type(id, desc, conc, dpr) -> + Component.Module_type(origin, id, desc, local_or_open conc, dpr) + | Desc.Module(id, desc, conc, dpr) -> + Component.Module(origin, id, desc, local_or_open conc, dpr) + | Desc.Declare_type id -> + Component.Declare_type(origin, id) + | Desc.Declare_class_type id -> + Component.Declare_class_type(origin, id) + | Desc.Declare_module_type id -> + Component.Declare_module_type(origin, id) + | Desc.Declare_module id -> + Component.Declare_module(origin, id)) + desc + in + let graph, diff = Graph.add parent.graph components in + let revision = revision parent in + let kind = Env { revision; parent; age } in + let sections = Origin_tbl.create 0 in + let rev_deps = History.Revision.rev_deps revision in + let todos = Todo.create graph rev_deps diff in + { kind; graph; sections; todos } + + let mutate (t : basis t) rev_deps components = + let graph, diff = Graph.add t.graph components in + let Basis { history } = t.kind in + History.commit history rev_deps diff; + t.graph <- graph; + Todo.mutate graph rev_deps t.todos diff + + let sections t origin = + match Origin_tbl.find t.sections origin with + | exception Not_found -> + let sections = Sections.create (age t) origin in + Origin_tbl.add t.sections origin sections; + sections + | sections -> sections + + let update_seen t seen = + Path_set.fold + (fun path acc -> + match acc with + | None -> None + | Some acc -> + let md = Graph.find_module t.graph path in + let path = Module.path t.graph md in + if Path_set.mem path acc then None + else Some (Path_set.add path acc)) + seen (Some Path_set.empty) + + let process_type t height path typ = + let canonical_path = Type.path t.graph typ in + if not (Path.equal canonical_path path) then begin + let origin = Type.origin t.graph typ in + let sections = sections t origin in + Sections.add_type t.graph sections height typ path + end + + let process_module_type t height path mty = + let canonical_path = Module_type.path t.graph mty in + if not (Path.equal canonical_path path) then begin + let origin = Module_type.origin t.graph mty in + let sections = sections t origin in + Sections.add_module_type t.graph sections height mty path + end + + let process_class_type t height path mty = + let canonical_path = Class_type.path t.graph mty in + if not (Path.equal canonical_path path) then begin + let origin = Class_type.origin t.graph mty in + let sections = sections t origin in + Sections.add_class_type t.graph sections height mty path + end + + let process_module t height path seen md = + let canonical_path = Module.path t.graph md in + if not (Path.equal canonical_path path) then begin + let origin = Module.origin t.graph md in + let sections = sections t origin in + Sections.add_module t.graph sections height md (path, seen); + end; + if not (Path_set.mem canonical_path seen) then begin + let seen = Path_set.add canonical_path seen in + Todo.add_children t.graph (rev_deps t) t.todos height md path seen + end + + let process_children t height path seen md = + let types = + match Module.types t.graph md with + | Some types -> types + | None -> String_map.empty + in + let class_types = + match Module.class_types t.graph md with + | Some class_types -> class_types + | None -> String_map.empty + in + let module_types = + match Module.module_types t.graph md with + | Some module_types -> module_types + | None -> String_map.empty + in + let modules = + match Module.modules t.graph md with + | Some modules -> modules + | None -> String_map.empty + in + String_map.iter + (fun name typ -> + if not (Type.hidden typ) then begin + let path = Path.Pdot(path, name) in + process_type t height path typ + end) + types; + String_map.iter + (fun name clty -> + if not (Class_type.hidden clty) then begin + let path = Path.Pdot(path, name) in + process_class_type t height path clty + end) + class_types; + String_map.iter + (fun name mty -> + if not (Module_type.hidden mty) then begin + let path = Path.Pdot(path, name) in + process_module_type t height path mty + end) + module_types; + String_map.iter + (fun name md -> + if not (Module.hidden md) then begin + let path = Path.Pdot(path, name) in + process_module t height path seen md + end) + modules + + let rec process : 'k . 'k t -> _ = + fun t origin height -> + let todo = Todo.pop (rev_deps t) t.todos height origin in + match todo with + | None -> true + | Some items -> + List.iter + (function + | Todo.Item.Base (Diff.Item.Type(id, typ, _)) -> + if not (Type.hidden typ) then begin + let path = Path.Pident id in + process_type t height path typ + end + | Todo.Item.Base (Diff.Item.Class_type(id, clty, _)) -> + if not (Class_type.hidden clty) then begin + let path = Path.Pident id in + process_class_type t height path clty + end + | Todo.Item.Base (Diff.Item.Module_type(id, mty, _)) -> + if not (Module_type.hidden mty) then begin + let path = Path.Pident id in + process_module_type t height path mty + end + | Todo.Item.Base (Diff.Item.Module(id, md, _)) -> + if not (Module.hidden md) then begin + let path = Path.Pident id in + process_module t height path Path_set.empty md + end + | Todo.Item.Children{md; path; seen} -> + process_children t height path seen md + | Todo.Item.Update{ id; origin } -> + process_update t origin height id + | Todo.Item.Forward{ id; decl; origin } -> + process_forward t origin height id decl) + items; + false + + and process_update : 'k . 'k t -> _ = + fun t origin height id -> + let sections = sections t origin in + let more = + Sections.iter_updates sections height id + ~type_:(fun canon path -> + let typ = Graph.find_type t.graph canon in + process_type t height path typ) + ~class_type:(fun canon path -> + let clty = Graph.find_class_type t.graph canon in + process_class_type t height path clty) + ~module_type:(fun canon path -> + let mty = Graph.find_module_type t.graph canon in + process_module_type t height path mty) + ~module_:(fun canon (path, seen) -> + let md = Graph.find_module t.graph canon in + match update_seen t seen with + | None -> () + | Some seen -> + process_module t height path seen md); + in + if more then begin + Todo.add_next_update (rev_deps t) t.todos height origin id + end + + + and process_forward : 'k . 'k t -> _ = + fun t origin height id decl -> + let sections = init t decl height in + let more = + Sections.iter_forwards sections height id + ~type_:(fun canon path -> + let typ = Graph.find_type t.graph canon in + process_type t height path typ) + ~class_type:(fun canon path -> + let clty = Graph.find_class_type t.graph canon in + process_class_type t height path clty) + ~module_type:(fun canon path -> + let mty = Graph.find_module_type t.graph canon in + process_module_type t height path mty) + ~module_:(fun canon (path, seen) -> + let md = Graph.find_module t.graph canon in + match update_seen t seen with + | None -> () + | Some seen -> + process_module t height path seen md); + in + if more then begin + Todo.add_next_forward (rev_deps t) t.todos height origin id decl + end + + and initialise : type k. k t -> _ = + fun t sections origin height -> + if not (Sections.is_initialised sections height) then begin + begin match Height.pred height with + | None -> () + | Some pred -> initialise t sections origin pred + end; + let parent = + match t.kind with + | Basis _ -> assert false + | Env { parent; _ } -> + update parent; + force parent origin height + in + Sections.initialise sections height parent + end + + and init : 'k . 'k t -> _ = + fun t origin height -> + let sections = sections t origin in + Sections.update sections (stamp t); + initialise t sections origin height; + sections + + and complete : 'k. 'k t -> _ = + fun t sections origin height -> + if not (Sections.is_completed sections height) then begin + begin match Height.pred height with + | None -> () + | Some pred -> ignore (complete t sections origin pred) + end; + let finished = process t origin height in + if finished then Sections.set_completed_from sections height + else Sections.set_completed sections height + end + + and force : 'k. 'k t -> _ = + fun t origin height -> + let sections = sections t origin in + Sections.update sections (stamp t); + initialise t sections origin height; + complete t sections origin height; + sections + + module Search = struct + + type 'a shortest = 'a t + + type _ kind = + | Type : Type.t kind + | Class_type : Class_type.t kind + | Module_type : Module_type.t kind + | Module : Module.t kind + + type name = + { name : string; + height : Height.t; } + + type 'a t = + | Ident of + { kind : 'a kind; + node : 'a; + origin : Origin.t; + best : Path.t; + min: Height.t; + max: Height.t; + finished : bool; } + | Dot of + { kind : 'a kind; + node : 'a; + origin : Origin.t; + best : Path.t; + min: Height.t; + max: Height.t; + parent : Module.t t; + name : name; + searched : bool; + finished : bool; } + | Application of + { kind : 'a kind; + node : 'a; + origin : Origin.t; + best : Path.t; + min: Height.t; + max: Height.t; + func : Module.t t; + arg : Module.t t; + func_first : bool; + searched : bool; + finished : bool; } + + let min_height = function + | Ident { min; _ } -> min + | Dot { min; _ } -> min + | Application { min; _ } -> min + + let max_height = function + | Ident { max; _ } -> max + | Dot { max; _ } -> max + | Application { max; _ } -> max + + let search_origin = function + | Ident { origin; _ } -> origin + | Dot { origin; _ } -> origin + | Application { origin; _ } -> origin + + let finished = function + | Ident { finished; _ } -> finished + | Dot { finished; _ } -> finished + | Application { finished; _ } -> finished + + let best = function + | Ident { best; _ } -> best + | Dot { best; _ } -> best + | Application { best; _ } -> best + + let min_application fst snd = + Height.plus (min_height fst) (min_height snd) + + let max_application fst snd = + Height.plus (max_height fst) (max_height snd) + + let min_dot parent name = + let base = min_height parent in + Height.plus base name.height + + let path_application fst snd = + Path.Papply(best fst, best snd) + + let path_dot parent name = + Path.Pdot(best parent, name.name) + + let is_visible_ident (type k) graph (kind : k kind) id = + match kind with + | Type -> Graph.is_type_ident_visible graph id + | Class_type -> Graph.is_class_type_ident_visible graph id + | Module_type -> Graph.is_module_type_ident_visible graph id + | Module -> Graph.is_module_ident_visible graph id + + let create (type k) shortest (kind : k kind) canonical_path = + let rec loop : type k. k kind -> Path.t -> k t = + fun kind path -> + let graph = shortest.graph in + let (node : k), origin, hidden = + match kind with + | Type -> + let node = Graph.find_type graph path in + let origin = Type.origin graph node in + let hidden = Type.hidden node in + node, origin, hidden + | Class_type -> + let node = Graph.find_class_type graph path in + let origin = Class_type.origin graph node in + let hidden = Class_type.hidden node in + node, origin, hidden + | Module_type -> + let node = Graph.find_module_type graph path in + let origin = Module_type.origin graph node in + let hidden = Module_type.hidden node in + node, origin, hidden + | Module -> + let node = Graph.find_module graph path in + let origin = Module.origin graph node in + let hidden = Module.hidden node in + node, origin, hidden + in + let best = path in + match path with + | Path.Pident id -> + let max = + if is_visible_ident graph kind id && not hidden then + Height.one + else + Height.maximum + in + let min = Height.one in + let finished = false in + Ident { kind; node; origin; best; min; max; finished } + | Path.Pdot(parent, name) -> + let parent = loop Module parent in + let finished = false in + let name_height = + if not hidden then Height.one + else Height.maximum + in + let name = { name; height = name_height } in + let searched = false in + let max = Height.plus (max_height parent) name_height in + let min = Height.one in + Dot + { kind; node; origin; best; min; max; + parent; name; searched; finished } + | Path.Papply(func, arg) -> + let func = loop Module func in + let arg = loop Module arg in + let func_first = + Rev_deps.before (rev_deps shortest) + (search_origin arg) (search_origin func) + in + let finished = false in + (* There are no module aliases containing extended paths *) + let searched = true in + let max = max_application func arg in + let min = min_application func arg in + Application + { kind; node; origin; best; min; max; + func; arg; func_first; searched; finished } + | Path.Pextra_ty _ -> raise Not_found + in + loop kind canonical_path + + let find (type k) shortest origin height (kind : k kind) (node : k) = + let sections = force shortest origin height in + match kind with + | Type -> + Sections.find_type shortest.graph sections height node + | Class_type -> + Sections.find_class_type shortest.graph sections height node + | Module_type -> + Sections.find_module_type shortest.graph sections height node + | Module -> + Sections.find_module shortest.graph sections height node + + let rec step : type k . _ shortest -> k t -> k t = + fun shortest search -> + if finished search then search + else begin + match search with + | Ident r -> begin + match find shortest r.origin r.min r.kind r.node with + | Sections.Not_found_here -> + if Height.equal r.min r.max then + Ident { r with finished = true } + else + Ident { r with min = Height.succ r.min } + | Sections.Not_found_here_or_later -> + Ident { r with finished = true; min = r.max } + | Sections.Found path -> + let best = path in + let max = r.min in + let finished = true in + Ident { r with best; max; finished } + end + | Dot r -> + let parent = r.parent in + let parent = + let should_try_dot = + Height.equal + (min_dot parent r.name) r.min + in + if not should_try_dot then parent + else step shortest parent + in + let found = + finished parent + && Height.equal (min_dot parent r.name) r.min + in + if found then begin + let best = path_dot parent r.name in + let max = r.min in + let finished = true in + Dot + { r with best; parent; max; finished } + end else begin + let best, max, searched, finished = + if r.searched then r.best, r.max, r.searched, r.finished + else begin + match find shortest r.origin r.min r.kind r.node with + | Sections.Not_found_here -> + r.best, r.max, (Height.equal r.min r.max), r.finished + | Sections.Not_found_here_or_later -> + r.best, r.max, true, r.finished + | Sections.Found path -> + path, r.min, true, true + end + in + let finished = + finished || + (searched + && Height.less_than_or_equal + r.max (min_dot parent r.name)) + in + let min = if finished then max else Height.succ r.min in + Dot { r with best; parent; min; max; searched; finished } + end + | Application r -> + let try_app searched = + let fst, snd = + if r.func_first then r.func, r.arg + else r.arg, r.func + in + let fst, snd = + let should_try_app = + Height.equal (min_application fst snd) r.min + in + if not should_try_app then fst, snd + else begin + let fst = step shortest fst in + let should_try_app = + Height.equal (min_application fst snd) r.min + in + if not should_try_app then fst, snd + else fst, step shortest snd + end + in + let func, arg = + if r.func_first then fst, snd + else snd, fst + in + let found = + finished func && finished arg + && Height.equal (min_application fst snd) r.min + in + if found then begin + let best = path_application func arg in + let max = r.min in + let finished = true in + Application + { r with best; func; arg; max; searched; finished } + end else begin + let finished = + searched + && Height.less_than_or_equal + r.max (min_application fst snd) + in + let min = if finished then r.max else Height.succ r.min in + Application + { r with func; arg; min; searched; finished } + end + in + if r.searched then try_app true + else begin + match find shortest r.origin r.min r.kind r.node with + | Sections.Not_found_here -> + try_app (Height.equal r.min r.max) + | Sections.Not_found_here_or_later -> + try_app true + | Sections.Found path -> + let best = path in + let max = r.min in + let searched = true in + let finished = true in + Application { r with best; max; searched; finished } + end + end + + let rec perform shortest search = + if finished search then best search + else perform shortest (step shortest search) + + end + + let find_type t path = + update t; + let typ = Graph.find_type t.graph path in + match Type.resolve t.graph typ with + | Type.Nth n -> Nth n + | Type.Path(subst, typ) -> + let canonical_path = Type.path t.graph typ in + let search = Search.create t Search.Type canonical_path in + let path = Search.perform t search in + Path(subst, path) + + let find_type_resolution t path : type_resolution = + update t; + let typ = Graph.find_type t.graph path in + match Type.resolve t.graph typ with + | Type.Nth n -> Nth n + | Type.Path(Some ns, _) -> Subst ns + | Type.Path(None, _) -> Id + + let find_type_simple t path = + update t; + let typ = Graph.find_type t.graph path in + let canonical_path = Type.path t.graph typ in + let search = Search.create t Search.Type canonical_path in + Search.perform t search + + let find_class_type t path = + update t; + let clty = Graph.find_class_type t.graph path in + let subst, clty = Class_type.resolve t.graph clty in + let canonical_path = Class_type.path t.graph clty in + let search = Search.create t Search.Class_type canonical_path in + let path = Search.perform t search in + (subst, path) + + let find_class_type_simple t path = + update t; + let clty = Graph.find_class_type t.graph path in + let canonical_path = Class_type.path t.graph clty in + let search = Search.create t Search.Class_type canonical_path in + Search.perform t search + + let find_module_type t path = + update t; + let mty = Graph.find_module_type t.graph path in + let canonical_path = Module_type.path t.graph mty in + let search = Search.create t Search.Module_type canonical_path in + Search.perform t search + + let find_module t path = + update t; + let md = Graph.find_module t.graph path in + let canonical_path = Module.path t.graph md in + let search = Search.create t Search.Module canonical_path in + Search.perform t search + +end + +module String_set = Set.Make(String) + +module Basis = struct + + type load = + { name : string; + depends : string list; + alias_depends : string list; + desc : Desc.Module.t; + deprecated : Desc.deprecated; } + + type t = + { mutable next_dep : Dependency.t; + mutable pending_additions : String_set.t; + mutable pending_loads : load list; + mutable assignment : Dependency.t String_map.t; + rev_deps : Rev_deps.t; + mutable shortest : Shortest.basis Shortest.t option; } + + let create () = + { next_dep = Dependency.zero; + pending_additions = String_set.empty; + pending_loads = []; + assignment = String_map.empty; + rev_deps = Rev_deps.create (); + shortest = None; } + + let update_assignments t additions = + String_set.iter + (fun name -> + if not (String_map.mem name t.assignment) then begin + t.assignment <- String_map.add name t.next_dep t.assignment; + t.next_dep <- Dependency.succ t.next_dep + end) + additions + + let update_rev_deps t loads = + Rev_deps.extend_up_to t.rev_deps t.next_dep; + List.iter + (fun { name; depends; alias_depends; _ } -> + let index = String_map.find name t.assignment in + List.iter + (fun dep_name -> + let dep_index = String_map.find dep_name t.assignment in + Rev_deps.add t.rev_deps ~source:dep_index ~target:index) + depends; + List.iter + (fun dep_name -> + let dep_index = String_map.find dep_name t.assignment in + Rev_deps.add_alias t.rev_deps ~source:dep_index ~target:index) + alias_depends) + loads + + let update_shortest t additions loads = + let components = + List.map + (fun { name; desc; deprecated; _ } -> + let index = String_map.find name t.assignment in + let origin = Origin.Dependency index in + let id = Ident.global name in + Component.Module(origin, id, desc, Component.Global, deprecated)) + loads + in + let components = + String_set.fold + (fun name acc -> + let index = String_map.find name t.assignment in + let origin = Origin.Dependency index in + let id = Ident.global name in + Component.Declare_module(origin, id) :: acc) + additions + components + in + match t.shortest with + | None -> + t.shortest <- Some (Shortest.basis t.rev_deps components) + | Some shortest -> + Shortest.mutate shortest t.rev_deps components + + let update t = + let loads = t.pending_loads in + let additions = t.pending_additions in + match loads, String_set.is_empty additions with + | [], true -> () + | _, _ -> + t.pending_loads <- []; + t.pending_additions <- String_set.empty; + let loads = List.rev loads in + update_assignments t additions; + update_rev_deps t loads; + update_shortest t additions loads + + let shortest t = + update t; + match t.shortest with + | None -> + let shortest = Shortest.basis t.rev_deps [] in + t.shortest <- Some shortest; + shortest + | Some shortest -> shortest + + let add t name = + t.pending_additions <- String_set.add name t.pending_additions + + let load t name depends alias_depends desc deprecated = + let load = { name; depends; alias_depends; desc; deprecated } in + t.pending_loads <- load :: t.pending_loads + +end + +type state = + | Initial of Basis.t + | Unforced of + { parent : t; + desc : Desc.t list Lazy.t; } + | Forced of + { basis : Basis.t; + shortest : Shortest.env Shortest.t; } + +and t = state ref + +let rec force t = + match !t with + | Initial _ | Forced _ as state -> state + | Unforced { parent; desc } -> + let desc = Lazy.force desc in + let state = + match force parent with + | Unforced _ -> assert false + | Initial basis -> + let shortest = Shortest.env (Basis.shortest basis) desc in + Forced { basis; shortest } + | Forced { basis; shortest } -> + let shortest = Shortest.env shortest desc in + Forced { basis; shortest } + in + t := state; + state + +let initial basis = ref (Initial basis) + +let add parent desc = + ref (Unforced { parent; desc }) + +type ext_shortest = Shortest : 'k Shortest.t -> ext_shortest + +let shortest t = + match force t with + | Unforced _ -> assert false + | Initial basis -> + Basis.update basis; + Shortest (Basis.shortest basis) + | Forced { basis; shortest } -> + Basis.update basis; + Shortest shortest + +let find_type t path = + let Shortest shortest = shortest t in + match Shortest.find_type shortest path with + | exception Not_found -> Path(None, path) + | result -> result + +let find_type_resolution t path : type_resolution = + let Shortest shortest = shortest t in + match Shortest.find_type_resolution shortest path with + | exception Not_found -> Id + | subst -> subst + +let find_type_simple t path = + let Shortest shortest = shortest t in + match Shortest.find_type_simple shortest path with + | exception Not_found -> path + | path -> path + +let find_class_type t path = + let Shortest shortest = shortest t in + match Shortest.find_class_type shortest path with + | exception Not_found -> (None, path) + | result -> result + +let find_class_type_simple t path = + let Shortest shortest = shortest t in + match Shortest.find_class_type_simple shortest path with + | exception Not_found -> path + | path -> path + +let find_module_type t path = + let Shortest shortest = shortest t in + match Shortest.find_module_type shortest path with + | exception Not_found -> path + | path -> path + +let find_module t path = + let Shortest shortest = shortest t in + match Shortest.find_module shortest path with + | exception Not_found -> path + | path -> path diff --git a/ocamlmerlin_mlx/ocaml/typing/short_paths.mli b/ocamlmerlin_mlx/ocaml/typing/short_paths.mli new file mode 100644 index 0000000..1cc7608 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/short_paths.mli @@ -0,0 +1,46 @@ + +module Desc = Short_paths_graph.Desc + +module Basis : sig + + type t + + val create : unit -> t + + val add : t -> string -> unit + + val load : t -> string -> string list -> string list -> + Desc.Module.t -> Desc.deprecated -> unit + +end + +type t + +val initial : Basis.t -> t + +val add : t -> Desc.t list Lazy.t -> t + +type type_result = + | Nth of int + | Path of int list option * Path.t + +val find_type : t -> Path.t -> type_result + +type type_resolution = + | Nth of int + | Subst of int list + | Id + +val find_type_resolution : t -> Path.t -> type_resolution + +val find_type_simple : t -> Path.t -> Path.t + +type class_type_result = int list option * Path.t + +val find_class_type : t -> Path.t -> class_type_result + +val find_class_type_simple : t -> Path.t -> Path.t + +val find_module_type : t -> Path.t -> Path.t + +val find_module : t -> Path.t -> Path.t diff --git a/ocamlmerlin_mlx/ocaml/typing/short_paths_graph.ml b/ocamlmerlin_mlx/ocaml/typing/short_paths_graph.ml new file mode 100644 index 0000000..c3d9d8b --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/short_paths_graph.ml @@ -0,0 +1,1511 @@ + +module String_map = Misc.String.Map + +module Ident = struct + + type t = Ident.t + + let equal t1 t2 = Ident.equal t1 t2 + + let compare t1 t2 = Ident.compare t1 t2 + + let name = Ident.name + + let global name = + Ident.create_persistent name + +end + +module Ident_map = Map.Make(Ident) +module Ident_set = Set.Make(Ident) + +module Path = struct + + type t = Path.t = + | Pident of Ident.t + | Pdot of t * string + | Papply of t * t + | Pextra_ty of t * Path.extra_ty + + (* open Path *) + + let equal t1 t2 = Path.same t1 t2 + + let compare t1 t2 = Path.compare t1 t2 + +end + +module Path_map = Map.Make(Path) +module Path_set = Set.Make(Path) + +module Desc = struct + + type deprecated = + | Deprecated + | Not_deprecated + + module Type = struct + + type t = + | Fresh + | Nth of int + | Subst of Path.t * int list + | Alias of Path.t + + end + + module Module_type = struct + + type t = + | Fresh + | Alias of Path.t + + end + + module Class_type = struct + + type t = + | Fresh + | Subst of Path.t * int list + | Alias of Path.t + + end + + module Module = struct + + type component = + | Type of string * Type.t * deprecated + | Class_type of string * Class_type.t * deprecated + | Module_type of string * Module_type.t * deprecated + | Module of string * t * deprecated + + and components = component list + + and kind = + | Signature of components Lazy.t + | Functor of (Path.t -> t) + + and t = + | Fresh of kind + | Alias of Path.t + + end + + type source = + | Local + | Open + + type t = + | Type of Ident.t * Type.t * source * deprecated + | Class_type of Ident.t * Class_type.t * source * deprecated + | Module_type of Ident.t * Module_type.t * source * deprecated + | Module of Ident.t * Module.t * source * deprecated + | Declare_type of Ident.t + | Declare_class_type of Ident.t + | Declare_module_type of Ident.t + | Declare_module of Ident.t + +end + +module Sort = struct + + type t = + | Defined + | Declared of Ident_set.t + + let application t1 t2 = + match t1, t2 with + | Defined, Defined -> Defined + | Defined, Declared _ -> t2 + | Declared _, Defined -> t1 + | Declared ids1, Declared ids2 -> Declared (Ident_set.union ids1 ids2) + +end + +module Age = Natural.Make() + +module Dependency = Natural.Make() + +module Origin = struct + + type t = + | Dependency of Dependency.t + | Dependencies of Dependency.t list + | Environment of Age.t + + let rec deps_add dep deps = + match deps with + | [] -> [dep] + | dep' :: rest -> + if Dependency.equal dep dep' then + deps + else if Dependency.less_than dep dep' then + dep :: deps + else + dep' :: deps_add dep rest + + let rec deps_union deps1 deps2 = + match deps1, deps2 with + | [], _ -> deps2 + | _, [] -> deps1 + | dep1 :: rest1, dep2 :: rest2 -> + if Dependency.equal dep1 dep2 then + dep1 :: deps_union rest1 rest2 + else if Dependency.less_than dep1 dep2 then + dep1 :: deps_union rest1 deps2 + else + dep2 :: deps_union deps1 rest2 + + let rec deps_equal deps1 deps2 = + match deps1, deps2 with + | [], [] -> true + | [], _ :: _ -> false + | _ :: _, [] -> false + | dep1 :: rest1, dep2 :: rest2 -> + Dependency.equal dep1 dep2 + && deps_equal rest1 rest2 + + let application t1 t2 = + match t1, t2 with + | Dependency dep1, Dependency dep2 -> + if Dependency.equal dep1 dep2 then t1 + else if Dependency.less_than dep1 dep2 then + Dependencies [dep1; dep2] + else + Dependencies [dep2; dep1] + | Dependency dep1, Dependencies deps2 -> + Dependencies (deps_add dep1 deps2) + | Dependency _, Environment _ -> t2 + | Dependencies deps1, Dependency dep2 -> + Dependencies (deps_add dep2 deps1) + | Dependencies deps1, Dependencies deps2 -> + Dependencies (deps_union deps1 deps2) + | Dependencies _, Environment _ -> t2 + | Environment _, Dependency _ -> t1 + | Environment _, Dependencies _ -> t1 + | Environment age1, Environment age2 -> + Environment (Age.max age1 age2) + + let equal t1 t2 = + match t1, t2 with + | Dependency dep1, Dependency dep2 -> Dependency.equal dep1 dep2 + | Dependency _, Dependencies _ -> false + | Dependency _, Environment _ -> false + | Dependencies _, Dependency _ -> false + | Dependencies deps1, Dependencies deps2 -> deps_equal deps1 deps2 + | Dependencies _, Environment _ -> false + | Environment _, Dependency _ -> false + | Environment _, Dependencies _ -> false + | Environment env1, Environment env2 -> Age.equal env1 env2 + + let hash = Hashtbl.hash + +end + +let hidden_name name = + if name <> "" && name.[0] = '_' then true + else + try + for i = 1 to String.length name - 2 do + if name.[i] = '_' && name.[i + 1] = '_' then + raise Exit + done; + false + with Exit -> true + +let hidden_ident id = + (* if !Clflags.unsafe_string && Ident.equal id Predef.ident_bytes then true + else + + Since 5.0.0 unsafe_string is always false *) + hidden_name (Ident.name id) + +let hidden_definition deprecated name = + match deprecated with + | Desc.Deprecated -> true + | Desc.Not_deprecated -> hidden_name name + +let hidden_base_definition deprecated id = + match deprecated with + | Desc.Deprecated -> true + | Desc.Not_deprecated -> hidden_ident id + +module rec Type : sig + + type t + + val base : Origin.t -> Ident.t -> Desc.Type.t option -> Desc.deprecated -> t + + val child : + Module.normalized -> string -> Desc.Type.t option -> Desc.deprecated -> t + + val declare : Origin.t -> Ident.t -> t + + val declaration : t -> Origin.t option + + val origin : Graph.t -> t -> Origin.t + + val path : Graph.t -> t -> Path.t + + val hidden : t -> bool + + val sort : Graph.t -> t -> Sort.t + + type resolved = + | Nth of int + | Path of int list option * t + + val resolve : Graph.t -> t -> resolved + +end = struct + + open Desc.Type + + type definition = + | Alias of Path.t + | Defined + | Nth of int + | Subst of Path.t * int list + | Unknown + + type t = + | Declaration of + { origin : Origin.t; + id : Ident.t; + hidden : bool; } + | Definition of + { origin : Origin.t; + path : Path.t; + hidden : bool; + sort : Sort.t; + definition : definition; } + + let definition_of_desc (desc : Desc.Type.t option) = + match desc with + | None -> Unknown + | Some Fresh -> Defined + | Some (Nth n) -> Nth n + | Some (Subst(p, ns)) -> Subst(p, ns) + | Some (Alias alias) -> Alias alias + + let base origin id desc deprecated = + let path = Path.Pident id in + let hidden = hidden_base_definition deprecated id in + let sort = Sort.Defined in + let definition = definition_of_desc desc in + Definition { origin; path; hidden; sort; definition } + + let child md name desc deprecated = + let origin = Module.raw_origin md in + let sort = Module.raw_sort md in + let path = Path.Pdot(Module.raw_path md, name) in + let hidden = hidden_definition deprecated name in + let definition = definition_of_desc desc in + Definition { origin; path; hidden; sort; definition } + + let declare origin id = + let hidden = hidden_ident id in + Declaration { origin; id; hidden } + + let declaration t = + match t with + | Definition _ -> None + | Declaration { origin; _} -> Some origin + + let hidden t = + match t with + | Definition { hidden; _ } -> hidden + | Declaration { hidden; _ } -> hidden + + let raw_origin t = + match t with + | Declaration { origin; _ } + | Definition { origin; _ } -> origin + + let raw_path t = + match t with + | Declaration { id; _ } -> Path.Pident id + | Definition { path; _ } -> path + + let raw_sort t = + match t with + | Declaration { id; _ } -> Sort.Declared (Ident_set.singleton id) + | Definition { sort; _ } -> sort + + let rec normalize_loop root t = + match t with + | Declaration _ -> t + | Definition { definition = Defined | Unknown | Nth _ | Subst _ } -> t + | Definition ({ definition = Alias alias } as r) -> begin + match Graph.find_type root alias with + | exception Not_found -> Definition { r with definition = Unknown } + | aliased -> normalize_loop root aliased + end + + let normalize root t = + match t with + | Definition { sort = Sort.Defined } -> normalize_loop root t + | Definition { sort = Sort.Declared _ } | Declaration _ -> + match Graph.find_type root (raw_path t) with + | exception Not_found -> normalize_loop root t + | t -> normalize_loop root t + + let origin root t = + raw_origin (normalize root t) + + let path root t = + raw_path (normalize root t) + + let sort root t = + raw_sort (normalize root t) + + type resolved = + | Nth of int + | Path of int list option * t + + let subst ns = function + | Nth n -> Nth (List.nth ns n) + | Path(None, p) -> Path(Some ns, p) + | Path(Some ms, p) -> Path(Some (List.map (List.nth ns) ms), p) + + let rec resolve root t = + match normalize root t with + | Declaration _ -> Path(None, t) + | Definition { definition = Defined | Unknown } -> Path(None, t) + | Definition { definition = Nth n } -> Nth n + | Definition { definition = Subst(p, ns) } -> begin + match Graph.find_type root p with + | exception Not_found -> Path(None, t) + | aliased -> subst ns (resolve root aliased) + end + | Definition { definition = Alias _ } -> assert false + +end + +and Class_type : sig + + type t + + val base : + Origin.t -> Ident.t -> Desc.Class_type.t option -> Desc.deprecated -> t + + val child : + Module.normalized -> string -> + Desc.Class_type.t option -> Desc.deprecated -> t + + val declare : Origin.t -> Ident.t -> t + + val declaration : t -> Origin.t option + + val origin : Graph.t -> t -> Origin.t + + val path : Graph.t -> t -> Path.t + + val hidden : t -> bool + + val sort : Graph.t -> t -> Sort.t + + type resolved = int list option * t + + val resolve : Graph.t -> t -> resolved + +end = struct + + open Desc.Class_type + + type definition = + | Alias of Path.t + | Defined + | Subst of Path.t * int list + | Unknown + + type t = + | Declaration of + { origin : Origin.t; + id : Ident.t; + hidden : bool; } + | Definition of + { origin : Origin.t; + path : Path.t; + hidden : bool; + sort : Sort.t; + definition : definition; } + + let definition_of_desc (desc : Desc.Class_type.t option) = + match desc with + | None -> Unknown + | Some Fresh -> Defined + | Some (Subst(p, ns)) -> Subst(p, ns) + | Some (Alias alias) -> Alias alias + + let base origin id desc deprecated = + let path = Path.Pident id in + let hidden = hidden_base_definition deprecated id in + let sort = Sort.Defined in + let definition = definition_of_desc desc in + Definition { origin; path; hidden; sort; definition } + + let child md name desc deprecated = + let origin = Module.raw_origin md in + let sort = Module.raw_sort md in + let path = Path.Pdot(Module.raw_path md, name) in + let hidden = hidden_definition deprecated name in + let definition = definition_of_desc desc in + Definition { origin; path; hidden; sort; definition } + + let declare origin id = + let hidden = hidden_ident id in + Declaration { origin; id; hidden } + + let declaration t = + match t with + | Definition _ -> None + | Declaration { origin; _} -> Some origin + + let hidden t = + match t with + | Definition { hidden; _ } -> hidden + | Declaration { hidden; _ } -> hidden + + let raw_origin t = + match t with + | Declaration { origin; _ } + | Definition { origin; _ } -> origin + + let raw_path t = + match t with + | Declaration { id; _ } -> Path.Pident id + | Definition { path; _ } -> path + + let raw_sort t = + match t with + | Declaration { id; _ } -> Sort.Declared (Ident_set.singleton id) + | Definition { sort; _ } -> sort + + let rec normalize_loop root t = + match t with + | Declaration _ -> t + | Definition { definition = Defined | Unknown | Subst _ } -> t + | Definition ({ definition = Alias alias } as r) -> begin + match Graph.find_class_type root alias with + | exception Not_found -> Definition { r with definition = Unknown } + | aliased -> normalize_loop root aliased + end + + let normalize root t = + match t with + | Definition { sort = Sort.Defined } -> normalize_loop root t + | Definition { sort = Sort.Declared _ } | Declaration _ -> + match Graph.find_class_type root (raw_path t) with + | exception Not_found -> normalize_loop root t + | t -> normalize_loop root t + + let origin root t = + raw_origin (normalize root t) + + let path root t = + raw_path (normalize root t) + + let sort root t = + raw_sort (normalize root t) + + type resolved = int list option * t + + let subst ns = function + | (None, p) -> (Some ns, p) + | (Some ms, p) -> (Some (List.map (List.nth ns) ms), p) + + let rec resolve root t = + match normalize root t with + | Declaration _ -> (None, t) + | Definition { definition = Defined | Unknown } -> (None, t) + | Definition { definition = Subst(p, ns) } -> begin + match Graph.find_class_type root p with + | exception Not_found -> (None, t) + | aliased -> subst ns (resolve root aliased) + end + | Definition { definition = Alias _ } -> assert false + +end + +and Module_type : sig + + type t + + val base : + Origin.t -> Ident.t -> Desc.Module_type.t option -> Desc.deprecated -> t + + val child : + Module.normalized -> string -> + Desc.Module_type.t option -> Desc.deprecated -> t + + val declare : Origin.t -> Ident.t -> t + + val declaration : t -> Origin.t option + + val origin : Graph.t -> t -> Origin.t + + val path : Graph.t -> t -> Path.t + + val hidden : t -> bool + + val sort : Graph.t -> t -> Sort.t + +end = struct + + open Desc.Module_type + + type definition = + | Alias of Path.t + | Defined + | Unknown + + type t = + | Declaration of + { origin : Origin.t; + id : Ident.t; + hidden : bool; } + | Definition of + { origin : Origin.t; + path : Path.t; + hidden : bool; + sort : Sort.t; + definition : definition; } + + let base origin id desc deprecated = + let path = Path.Pident id in + let hidden = hidden_base_definition deprecated id in + let sort = Sort.Defined in + let definition = + match desc with + | None -> Unknown + | Some Fresh -> Defined + | Some (Alias alias) -> Alias alias + in + Definition { origin; path; hidden; sort; definition } + + let child md name desc deprecated = + let origin = Module.raw_origin md in + let sort = Module.raw_sort md in + let path = Path.Pdot (Module.raw_path md, name) in + let hidden = hidden_definition deprecated name in + let definition = + match desc with + | None -> Unknown + | Some Fresh -> Defined + | Some (Alias alias) -> Alias alias + in + Definition { origin; path; hidden; sort; definition } + + let declare origin id = + let hidden = hidden_ident id in + Declaration { origin; id; hidden } + + let declaration t = + match t with + | Definition _ -> None + | Declaration { origin; _} -> Some origin + + let hidden t = + match t with + | Definition { hidden; _ } -> hidden + | Declaration { hidden; _ } -> hidden + + let raw_origin t = + match t with + | Declaration { origin; _ } | Definition { origin; _ } -> + origin + + let raw_path t = + match t with + | Declaration { id; _ } -> Path.Pident id + | Definition { path; _ } -> path + + let raw_sort t = + match t with + | Declaration { id; _ } -> Sort.Declared (Ident_set.singleton id) + | Definition { sort; _ } -> sort + + let rec normalize_loop root t = + match t with + | Declaration _ -> t + | Definition { definition = Defined | Unknown } -> t + | Definition ({ definition = Alias alias } as r) -> begin + match Graph.find_module_type root alias with + | exception Not_found -> Definition { r with definition = Unknown } + | aliased -> normalize_loop root aliased + end + + let normalize root t = + match t with + | Definition { sort = Sort.Defined } -> normalize_loop root t + | Definition { sort = Sort.Declared _ } | Declaration _ -> + match Graph.find_module_type root (raw_path t) with + | exception Not_found -> normalize_loop root t + | t -> normalize_loop root t + + let origin root t = + raw_origin (normalize root t) + + let path root t = + raw_path (normalize root t) + + let sort root t = + raw_sort (normalize root t) + +end + +and Module : sig + + type t + + type normalized + + val base : + Origin.t -> Ident.t -> Desc.Module.t option -> Desc.deprecated -> t + + val child : + normalized -> string -> Desc.Module.t option -> Desc.deprecated -> t + + val application : normalized -> t -> Desc.Module.t option -> t + + val declare : Origin.t -> Ident.t -> t + + val declaration : t -> Origin.t option + + val origin : Graph.t -> t -> Origin.t + + val path : Graph.t -> t -> Path.t + + val hidden : t -> bool + + val sort : Graph.t -> t -> Sort.t + + val types : Graph.t -> t -> Type.t String_map.t option + + val class_types : Graph.t -> t -> Class_type.t String_map.t option + + val module_types : Graph.t -> t -> Module_type.t String_map.t option + + val modules : Graph.t -> t -> Module.t String_map.t option + + val find_type : Graph.t -> t -> string -> Type.t + + val find_class_type : Graph.t -> t -> string -> Class_type.t + + val find_module_type : Graph.t -> t -> string -> Module_type.t + + val find_module : Graph.t -> t -> string -> Module.t + + val find_application : Graph.t -> t -> Path.t -> Module.t + + val normalize : Graph.t -> t -> normalized + + val unnormalize : normalized -> t + + val raw_origin : normalized -> Origin.t + + val raw_path : normalized -> Path.t + + val raw_sort : normalized -> Sort.t + +end = struct + + open Desc.Module + + type components = + | Unforced of Desc.Module.components Lazy.t + | Forced of + { types : Type.t String_map.t; + class_types : Class_type.t String_map.t; + module_types : Module_type.t String_map.t; + modules : t String_map.t; } + + and definition = + | Alias of Path.t + | Signature of + { mutable components : components } + | Functor of + { apply : Path.t -> Desc.Module.t; + mutable applications : t Path_map.t; } + | Unknown + + and t = + | Declaration of + { origin : Origin.t; + id : Ident.t; + hidden : bool; } + | Definition of + { origin : Origin.t; + path : Path.t; + hidden : bool; + sort : Sort.t; + definition : definition; } + + let base origin id desc deprecated = + let path = Path.Pident id in + let hidden = hidden_base_definition deprecated id in + let sort = Sort.Defined in + let definition = + match desc with + | None -> Unknown + | Some (Fresh (Signature components)) -> + let components = Unforced components in + Signature { components } + | Some (Fresh (Functor apply)) -> + let applications = Path_map.empty in + Functor { apply; applications } + | Some (Alias alias) -> + Alias alias + in + Definition { origin; path; hidden; sort; definition } + + let child md name desc deprecated = + let origin = Module.raw_origin md in + let sort = Module.raw_sort md in + let path = Path.Pdot(Module.raw_path md, name) in + let hidden = hidden_definition deprecated name in + let definition = + match desc with + | None -> Unknown + | Some (Fresh (Signature components)) -> + let components = Unforced components in + Signature { components } + | Some (Fresh (Functor apply)) -> + let applications = Path_map.empty in + Functor { apply; applications } + | Some (Alias alias) -> + Alias alias + in + Definition { origin; path; hidden; sort; definition } + + let application func arg desc = + let func_origin = Module.raw_origin func in + let arg_origin = Module.raw_origin arg in + let origin = Origin.application func_origin arg_origin in + let func_sort = Module.raw_sort func in + let arg_sort = Module.raw_sort arg in + let sort = Sort.application func_sort arg_sort in + let func_path = Module.raw_path func in + let arg_path = Module.raw_path arg in + let path = Path.Papply(func_path, arg_path) in + let hidden = false in + let definition = + match desc with + | None -> Unknown + | Some (Fresh (Signature components)) -> + let components = Unforced components in + Signature { components } + | Some (Fresh (Functor apply)) -> + let applications = Path_map.empty in + Functor { apply; applications } + | Some (Alias alias) -> + Alias alias + in + Definition { origin; path; hidden; sort; definition } + + let declare origin id = + let hidden = hidden_ident id in + Declaration { origin; id; hidden } + + let declaration t = + match t with + | Definition _ -> None + | Declaration { origin; _} -> Some origin + + let hidden t = + match t with + | Definition { hidden; _ } -> hidden + | Declaration { hidden; _ } -> hidden + + let raw_origin t = + match t with + | Declaration { origin; _ } | Definition { origin; _ } -> + origin + + let raw_path t = + match t with + | Declaration { id; _ } -> Path.Pident id + | Definition { path; _ } -> path + + let raw_sort t = + match t with + | Declaration { id; _ } -> Sort.Declared (Ident_set.singleton id) + | Definition { sort; _ } -> sort + + type normalized = t + + let rec normalize_loop root t = + match t with + | Declaration _ -> t + | Definition { definition = Signature _ | Functor _ | Unknown } -> t + | Definition ({ definition = Alias alias } as r) -> begin + match Graph.find_module root alias with + | exception Not_found -> Definition { r with definition = Unknown } + | aliased -> normalize_loop root aliased + end + + let normalize root t = + match t with + | Definition { sort = Sort.Defined } -> normalize_loop root t + | Definition { sort = Sort.Declared _ } | Declaration _ -> + match Graph.find_module root (raw_path t) with + | exception Not_found -> normalize_loop root t + | t -> normalize_loop root t + + let unnormalize t = t + + let origin root t = + raw_origin (normalize root t) + + let path root t = + raw_path (normalize root t) + + let sort root t = + raw_sort (normalize root t) + + let definition t = + match Module.unnormalize t with + | Declaration _ -> Unknown + | Definition { definition; _ } -> definition + + let force root t = + let t = Module.normalize root t in + match definition t with + | Alias _ -> assert false + | Unknown + | Functor _ + | Signature { components = Forced _ } -> t + | Signature ({ components = Unforced components; _} as r) -> begin + let rec loop types class_types module_types modules = function + | [] -> Forced { types; class_types; module_types; modules } + | Type(name, desc, dpr) :: rest -> + let typ = Type.child t name (Some desc) dpr in + let types = String_map.add name typ types in + loop types class_types module_types modules rest + | Class_type(name, desc, dpr) :: rest -> + let clty = Class_type.child t name (Some desc) dpr in + let class_types = String_map.add name clty class_types in + loop types class_types module_types modules rest + | Module_type(name, desc, dpr) :: rest -> + let mty = Module_type.child t name (Some desc) dpr in + let module_types = String_map.add name mty module_types in + loop types class_types module_types modules rest + | Module(name, desc, dpr) :: rest -> + let md = Module.child t name (Some desc) dpr in + let modules = String_map.add name md modules in + loop types class_types module_types modules rest + in + let empty = String_map.empty in + let components = loop empty empty empty empty (Lazy.force components) in + r.components <- components; + t + end + + let types root t = + let t = force root t in + match definition t with + | Alias _ | Signature { components = Unforced _ } -> + assert false + | Unknown | Functor _ -> + None + | Signature { components = Forced { types; _ }; _ } -> + Some types + + let class_types root t = + let t = force root t in + match definition t with + | Alias _ | Signature { components = Unforced _ } -> + assert false + | Unknown | Functor _ -> + None + | Signature { components = Forced { class_types; _ } } -> + Some class_types + + let module_types root t = + let t = force root t in + match definition t with + | Alias _ | Signature { components = Unforced _ } -> + assert false + | Unknown | Functor _ -> + None + | Signature { components = Forced { module_types; _ } } -> + Some module_types + + let modules root t = + let t = force root t in + match definition t with + | Alias _ | Signature { components = Unforced _ } -> + assert false + | Unknown | Functor _ -> + None + | Signature { components = Forced { modules; _ } } -> + Some modules + + let find_type root t name = + let t = force root t in + match definition t with + | Alias _ + | Signature { components = Unforced _ } -> + assert false + | Unknown -> + Type.child t name None Not_deprecated + | Functor _ -> + raise Not_found + | Signature { components = Forced { types; _ }; _ } -> + String_map.find name types + + let find_class_type root t name = + let t = force root t in + match definition t with + | Alias _ + | Signature { components = Unforced _ } -> + assert false + | Unknown -> + Class_type.child t name None Not_deprecated + | Functor _ -> + raise Not_found + | Signature { components = Forced { class_types; _ }; _ } -> + String_map.find name class_types + + let find_module_type root t name = + let t = force root t in + match definition t with + | Alias _ + | Signature { components = Unforced _ } -> + assert false + | Unknown -> + Module_type.child t name None Not_deprecated + | Functor _ -> + raise Not_found + | Signature { components = Forced { module_types; _ }; _ } -> + String_map.find name module_types + + let find_module root t name = + let t = force root t in + match definition t with + | Alias _ + | Signature { components = Unforced _ } -> + assert false + | Unknown -> + Module.child t name None Not_deprecated + | Functor _ -> + raise Not_found + | Signature { components = Forced { modules; _ }; _ } -> + String_map.find name modules + + let find_application root t path = + let t = Module.normalize root t in + match definition t with + | Alias _ -> assert false + | Signature _ -> raise Not_found + | Unknown -> + let arg = Graph.find_module root path in + Module.application t arg None + | Functor ({ apply; applications } as r)-> + let arg = Graph.find_module root path in + let arg_path = Module.path root arg in + match Path_map.find arg_path applications with + | md -> md + | exception Not_found -> + let md = Module.application t arg (Some (apply arg_path)) in + r.applications <- Path_map.add arg_path md applications; + md + +end + +and Diff : sig + + module Item : sig + + type t = + | Type of Ident.t * Type.t * Origin.t option + | Class_type of Ident.t * Class_type.t * Origin.t option + | Module_type of Ident.t * Module_type.t * Origin.t option + | Module of Ident.t * Module.t * Origin.t option + + val origin : Graph.t -> t -> Origin.t + + val id : Graph.t -> t -> Ident.t + + val previous : Graph.t -> t -> Origin.t option + + end + + type t = Item.t list + +end = struct + + module Item = struct + + type t = + | Type of Ident.t * Type.t * Origin.t option + | Class_type of Ident.t * Class_type.t * Origin.t option + | Module_type of Ident.t * Module_type.t * Origin.t option + | Module of Ident.t * Module.t * Origin.t option + + let origin root = function + | Type(_, typ, _) -> Type.origin root typ + | Class_type(_, clty, _) -> Class_type.origin root clty + | Module_type(_, mty, _) -> Module_type.origin root mty + | Module(_, md, _) -> Module.origin root md + + let id _root = function + | Type(id, _, _) -> id + | Class_type(id, _, _) -> id + | Module_type(id, _, _) -> id + | Module(id, _, _) -> id + + let previous _root = function + | Type(_, _, prev) -> prev + | Class_type(_, _, prev) -> prev + | Module_type(_, _, prev) -> prev + | Module(_, _, prev) -> prev + + end + + type t = Item.t list + +end + +and Component : sig + + type source = + | Global + | Local + | Open + + type t = + | Type of + Origin.t * Ident.t * Desc.Type.t * source * Desc.deprecated + | Class_type of + Origin.t * Ident.t * Desc.Class_type.t * source * Desc.deprecated + | Module_type of + Origin.t * Ident.t * Desc.Module_type.t * source * Desc.deprecated + | Module of + Origin.t * Ident.t * Desc.Module.t * source * Desc.deprecated + | Declare_type of Origin.t * Ident.t + | Declare_class_type of Origin.t * Ident.t + | Declare_module_type of Origin.t * Ident.t + | Declare_module of Origin.t * Ident.t + +end = Component + +and Graph : sig + + type t + + val empty : t + + val add : t -> Component.t list -> t * Diff.t + + val merge : t -> Diff.t -> t + + val find_type : t -> Path.t -> Type.t + + val find_class_type : t -> Path.t -> Class_type.t + + val find_module_type : t -> Path.t -> Module_type.t + + val find_module : t -> Path.t -> Module.t + + val is_type_path_visible : t -> Path.t -> bool + + val is_class_type_path_visible : t -> Path.t -> bool + + val is_module_type_path_visible : t -> Path.t -> bool + + val is_module_path_visible : t -> Path.t -> bool + + val is_type_ident_visible : t -> Ident.t -> bool + + val is_class_type_ident_visible : t -> Ident.t -> bool + + val is_module_type_ident_visible : t -> Ident.t -> bool + + val is_module_ident_visible : t -> Ident.t -> bool + +end = struct + + type defs = + | Global of Ident.t + | Local of Ident.t + | Unambiguous of Ident.t + | Ambiguous of Ident.t * Ident.t list + + type t = + { types : Type.t Ident_map.t; + class_types : Class_type.t Ident_map.t; + module_types : Module_type.t Ident_map.t; + modules : Module.t Ident_map.t; + type_names : defs String_map.t; + class_type_names : defs String_map.t; + module_type_names : defs String_map.t; + module_names : defs String_map.t; } + + let empty = + { types = Ident_map.empty; + class_types = Ident_map.empty; + module_types = Ident_map.empty; + modules = Ident_map.empty; + type_names = String_map.empty; + class_type_names = String_map.empty; + module_type_names = String_map.empty; + module_names = String_map.empty; } + + let previous_type t id = + match Ident_map.find id t.types with + | exception Not_found -> None + | prev -> + match Type.declaration prev with + | None -> failwith "Graph.add: type already defined" + | Some _ as o -> o + + let previous_class_type t id = + match Ident_map.find id t.class_types with + | exception Not_found -> None + | prev -> + match Class_type.declaration prev with + | None -> failwith "Graph.add: class type already defined" + | Some _ as o -> o + + let previous_module_type t id = + match Ident_map.find id t.module_types with + | exception Not_found -> None + | prev -> + match Module_type.declaration prev with + | None -> failwith "Graph.add: module type already defined" + | Some _ as o -> o + + let previous_module t id = + match Ident_map.find id t.modules with + | exception Not_found -> None + | prev -> + match Module.declaration prev with + | None -> failwith "Graph.add: module already defined" + | Some _ as o -> o + + let add_name source id names = + let name = Ident.name id in + let defs = + match source with + | Component.Global -> Global id + | Component.Local -> Local id + | Component.Open -> begin + match String_map.find name names with + | exception Not_found -> Unambiguous id + | Global id' -> Unambiguous id' + | Local id' -> Ambiguous(id, [id']) + | Unambiguous id' -> Ambiguous(id, [id']) + | Ambiguous(id', ids) -> Ambiguous(id, id' :: ids) + end + in + String_map.add name defs names + + let merge_name id names = + let name = Ident.name id in + match String_map.find name names with + | exception Not_found -> + String_map.add name (Global id) names + | _ -> names + + let add t descs = + let rec loop acc diff declarations = function + | [] -> loop_declarations acc diff declarations + | Component.Type(origin, id, desc, source, dpr) :: rest -> + let prev = previous_type acc id in + let typ = Type.base origin id (Some desc) dpr in + let types = Ident_map.add id typ acc.types in + let type_names = add_name source id acc.type_names in + let item = Diff.Item.Type(id, typ, prev) in + let diff = item :: diff in + let acc = { acc with types; type_names } in + loop acc diff declarations rest + | Component.Class_type(origin,id, desc, source, dpr) :: rest -> + let prev = previous_class_type acc id in + let clty = Class_type.base origin id (Some desc) dpr in + let class_types = Ident_map.add id clty acc.class_types in + let class_type_names = add_name source id acc.class_type_names in + let item = Diff.Item.Class_type(id, clty, prev) in + let diff = item :: diff in + let acc = { acc with class_types; class_type_names } in + loop acc diff declarations rest + | Component.Module_type(origin,id, desc, source, dpr) :: rest -> + let prev = previous_module_type acc id in + let mty = Module_type.base origin id (Some desc) dpr in + let module_types = Ident_map.add id mty acc.module_types in + let module_type_names = add_name source id acc.module_type_names in + let item = Diff.Item.Module_type(id, mty, prev) in + let diff = item :: diff in + let acc = { acc with module_types; module_type_names } in + loop acc diff declarations rest + | Component.Module(origin,id, desc, source, dpr) :: rest -> + let prev = previous_module acc id in + let md = Module.base origin id (Some desc) dpr in + let modules = Ident_map.add id md acc.modules in + let module_names = add_name source id acc.module_names in + let item = Diff.Item.Module(id, md, prev) in + let diff = item :: diff in + let acc = { acc with modules; module_names } in + loop acc diff declarations rest + | Component.Declare_type(_, id) as decl :: rest -> + let declarations = decl :: declarations in + let type_names = + (* CR lwhite: This should probably not always be [Global] *) + add_name Component.Global id acc.type_names + in + let acc = { acc with type_names } in + loop acc diff declarations rest + | Component.Declare_class_type(_, id) as decl :: rest -> + let declarations = decl :: declarations in + let class_type_names = + (* CR lwhite: This should probably not always be [Global] *) + add_name Component.Global id acc.class_type_names + in + let acc = { acc with class_type_names } in + loop acc diff declarations rest + | Component.Declare_module_type(_, id) as decl :: rest -> + let declarations = decl :: declarations in + let module_type_names = + (* CR lwhite: This should probably not always be [Global] *) + add_name Component.Global id acc.module_type_names + in + let acc = { acc with module_type_names } in + loop acc diff declarations rest + | Component.Declare_module(_, id) as decl :: rest -> + let declarations = decl :: declarations in + let module_names = + (* CR lwhite: This should probably not always be [Global] *) + add_name Component.Global id acc.module_names + in + let acc = { acc with module_names } in + loop acc diff declarations rest + and loop_declarations acc diff = function + | [] -> acc, diff + | Component.Declare_type(origin, id) :: rest -> + if Ident_map.mem id acc.types then begin + loop_declarations acc diff rest + end else begin + let typ = Type.declare origin id in + let types = Ident_map.add id typ acc.types in + let acc = { acc with types } in + loop_declarations acc diff rest + end + | Component.Declare_class_type(origin, id) :: rest -> + if Ident_map.mem id acc.class_types then begin + loop_declarations acc diff rest + end else begin + let clty = Class_type.declare origin id in + let class_types = Ident_map.add id clty acc.class_types in + let acc = { acc with class_types } in + loop_declarations acc diff rest + end + | Component.Declare_module_type(origin, id) :: rest -> + if Ident_map.mem id acc.module_types then begin + loop_declarations acc diff rest + end else begin + let mty = Module_type.declare origin id in + let module_types = Ident_map.add id mty acc.module_types in + let acc = { acc with module_types } in + loop_declarations acc diff rest + end + | Component.Declare_module(origin, id) :: rest -> + if Ident_map.mem id acc.modules then begin + loop_declarations acc diff rest + end else begin + let md = Module.declare origin id in + let modules = Ident_map.add id md acc.modules in + let acc = { acc with modules } in + loop_declarations acc diff rest + end + | ( Component.Type _ + | Component.Class_type _ + | Component.Module_type _ + | Component.Module _) :: _ -> assert false + in + loop t [] [] descs + + let merge t diff = + let rec loop acc = function + | [] -> acc + | Diff.Item.Type(id, typ, _) :: rest -> + let types = Ident_map.add id typ acc.types in + let type_names = merge_name id acc.type_names in + let acc = { acc with types; type_names } in + loop acc rest + | Diff.Item.Class_type(id, clty, _) :: rest -> + let class_types = Ident_map.add id clty acc.class_types in + let class_type_names = merge_name id acc.class_type_names in + let acc = { acc with class_types; class_type_names } in + loop acc rest + | Diff.Item.Module_type(id, mty, _) :: rest -> + let module_types = Ident_map.add id mty acc.module_types in + let module_type_names = merge_name id acc.module_type_names in + let acc = { acc with module_types; module_type_names } in + loop acc rest + | Diff.Item.Module(id, md, _) :: rest -> + let modules = Ident_map.add id md acc.modules in + let module_names = merge_name id acc.module_names in + let acc = { acc with modules; module_names } in + loop acc rest + in + loop t diff + + let rec find_module t path = + match path with + | Path.Pident id -> + Ident_map.find id t.modules + | Path.Pdot(p, name) -> + let md = find_module t p in + Module.find_module t md name + | Path.Papply(p, arg) -> + let md = find_module t p in + Module.find_application t md arg + | Path.Pextra_ty _ -> + raise Not_found + + let find_type t path = + match path with + | Path.Pident id -> + Ident_map.find id t.types + | Path.Pdot(p, name) -> + let md = find_module t p in + Module.find_type t md name + | Path.Papply _ | Path.Pextra_ty _ -> + raise Not_found + + let find_class_type t path = + match path with + | Path.Pident id -> + Ident_map.find id t.class_types + | Path.Pdot(p, name) -> + let md = find_module t p in + Module.find_class_type t md name + | Path.Papply _ | Path.Pextra_ty _ -> + raise Not_found + + let find_module_type t path = + match path with + | Path.Pident id -> + Ident_map.find id t.module_types + | Path.Pdot(p, name) -> + let md = find_module t p in + Module.find_module_type t md name + | Path.Papply _ | Path.Pextra_ty _ -> + raise Not_found + + let canonical_type_path t id = + match Ident_map.find id t.types with + | exception Not_found -> Path.Pident id + | md -> Type.path t md + + let canonical_class_type_path t id = + match Ident_map.find id t.class_types with + | exception Not_found -> Path.Pident id + | md -> Class_type.path t md + + let canonical_module_type_path t id = + match Ident_map.find id t.module_types with + | exception Not_found -> Path.Pident id + | md -> Module_type.path t md + + let canonical_module_path t id = + match Ident_map.find id t.modules with + | exception Not_found -> Path.Pident id + | md -> Module.path t md + + let is_module_ident_visible t id = + let name = Ident.name id in + match String_map.find name t.module_names with + | exception Not_found -> false + | Local id' -> Ident.equal id id' + | Global id' -> Ident.equal id id' + | Unambiguous id' -> Ident.equal id id' + | Ambiguous(id', ids) -> + if not (Ident.equal id id') then false + else begin + let paths = List.map (canonical_module_path t) ids in + let path = canonical_module_path t id in + List.for_all (Path.equal path) paths + end + + let rec is_module_path_visible t = function + | Path.Pident id -> is_module_ident_visible t id + | Path.Pdot(path, _) | Pextra_ty (path, _) -> + is_module_path_visible t path + | Path.Papply(path1, path2) -> + is_module_path_visible t path1 + && is_module_path_visible t path2 + + let is_type_ident_visible t id = + let name = Ident.name id in + match String_map.find name t.type_names with + | exception Not_found -> false + | Local id' -> Ident.equal id id' + | Global id' -> Ident.equal id id' + | Unambiguous id' -> Ident.equal id id' + | Ambiguous(id', ids) -> + if not (Ident.equal id id') then false + else begin + let paths = List.map (canonical_type_path t) ids in + let path = canonical_type_path t id in + List.for_all (Path.equal path) paths + end + + let is_type_path_visible t = function + | Path.Pident id -> is_type_ident_visible t id + | Path.Pdot(path, _) | Pextra_ty (path, _) -> is_module_path_visible t path + | Path.Papply _ -> + failwith + "Short_paths_graph.Graph.is_type_path_visible: \ + invalid type path" + + let is_class_type_ident_visible t id = + let name = Ident.name id in + match String_map.find name t.class_type_names with + | exception Not_found -> false + | Local id' -> Ident.equal id id' + | Global id' -> Ident.equal id id' + | Unambiguous id' -> Ident.equal id id' + | Ambiguous(id', ids) -> + if not (Ident.equal id id') then false + else begin + let paths = List.map (canonical_class_type_path t) ids in + let path = canonical_class_type_path t id in + List.for_all (Path.equal path) paths + end + + let is_class_type_path_visible t = function + | Path.Pident id -> is_class_type_ident_visible t id + | Path.Pdot(path, _) -> is_module_path_visible t path + | Path.Papply _ | Path.Pextra_ty _ -> + failwith + "Short_paths_graph.Graph.is_class_type_path_visible: \ + invalid class type path" + + let is_module_type_ident_visible t id = + let name = Ident.name id in + match String_map.find name t.module_type_names with + | exception Not_found -> false + | Local id' -> Ident.equal id id' + | Global id' -> Ident.equal id id' + | Unambiguous id' -> Ident.equal id id' + | Ambiguous(id', ids) -> + if not (Ident.equal id id') then false + else begin + let paths = List.map (canonical_module_type_path t) ids in + let path = canonical_module_type_path t id in + List.for_all (Path.equal path) paths + end + + let is_module_type_path_visible t = function + | Path.Pident id -> is_module_type_ident_visible t id + | Path.Pdot(path, _) -> is_module_path_visible t path + | Path.Papply _ | Path.Pextra_ty _ -> + failwith + "Short_paths_graph.Graph.is_module_type_path_visible: \ + invalid module type path" + +end + +type graph = Graph.t diff --git a/ocamlmerlin_mlx/ocaml/typing/short_paths_graph.mli b/ocamlmerlin_mlx/ocaml/typing/short_paths_graph.mli new file mode 100644 index 0000000..82d02b0 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/short_paths_graph.mli @@ -0,0 +1,309 @@ +(** [Short_path_graph] is a representation of the environment (as a graph, + using [Graph.t]) that is more suitable to answer short path queries. + + The only structures shared with the typechecker are [Ident.t] and [Path.t]. + [Graph.t] is pure and doesn't hook into the [Env.t]. + Context has to be rebuilt by outside code using [Graph.add]. +*) + +(* Generic definitions *) + +module String_map : Map.S with type key = string + +module Ident : sig + + type t = Ident.t + + val equal : t -> t -> bool + + val compare : t -> t -> int + + val name : t -> string + + val global : string -> t + +end + +module Ident_map : Map.S with type key = Ident.t + +module Ident_set : Set.S with type elt = Ident.t + +module Path : sig + + type t = Path.t = + | Pident of Ident.t + | Pdot of t * string + | Papply of t * t + | Pextra_ty of t * Path.extra_ty + + val equal : t -> t -> bool + + val compare : t -> t -> int + +end + +module Path_map : Map.S with type key = Path.t + +module Path_set : Set.S with type elt = Path.t + +(* Subset of the type algebra that is relevant to short path *) + +module Desc : sig + + type deprecated = + | Deprecated + | Not_deprecated + + module Type : sig + + type t = + | Fresh + (** type t *) + | Nth of int + (** The n'th projection of type parameters. + E.g. for n < m, [type ('x_0,'x_1,...,'x_m-1) t = 'x_n] + is represented as [Nth n]. *) + | Subst of Path.t * int list + (** An alias to some other type after substitution of type parameters. + E.g. [type ('x_0, 'x_1', 'x_2, 'x_3) t = ('x_3, 'x_2) p] + is represented as [Subst (p, [3,2])]. *) + | Alias of Path.t + (** A direct alias to another type, preserving parameters. + E.g [type t = p], [type 'a t = 'a p], ... + are represented as [Alias p]. *) + end + + module Class_type : sig + + type t = + | Fresh + | Subst of Path.t * int list + | Alias of Path.t + + end + + module Module_type : sig + + type t = + | Fresh + | Alias of Path.t + + end + + module Module : sig + + type component = + | Type of string * Type.t * deprecated + | Class_type of string * Class_type.t * deprecated + | Module_type of string * Module_type.t * deprecated + | Module of string * t * deprecated + + and components = component list + + and kind = + | Signature of components Lazy.t + | Functor of (Path.t -> t) + + and t = + | Fresh of kind + | Alias of Path.t + + end + + type source = + | Local + | Open + + type t = + | Type of Ident.t * Type.t * source * deprecated + | Class_type of Ident.t * Class_type.t * source * deprecated + | Module_type of Ident.t * Module_type.t * source * deprecated + | Module of Ident.t * Module.t * source * deprecated + | Declare_type of Ident.t + | Declare_class_type of Ident.t + | Declare_module_type of Ident.t + | Declare_module of Ident.t + +end + +module Sort : sig + + type t = + | Defined + | Declared of Ident_set.t + +end + +module Age : Natural.S + +module Dependency : Natural.S + +module Origin : sig + + type t = + | Dependency of Dependency.t + | Dependencies of Dependency.t list + | Environment of Age.t + + val equal : t -> t -> bool + + val hash : t -> int + +end + +type graph + +module Type : sig + + type t + + val origin : graph -> t -> Origin.t + + val path : graph -> t -> Path.t + + val hidden : t -> bool + + val sort : graph -> t -> Sort.t + + type resolved = + | Nth of int + | Path of int list option * t + + val resolve : graph -> t -> resolved + +end + +module Class_type : sig + + type t + + val origin : graph -> t -> Origin.t + + val path : graph -> t -> Path.t + + val hidden : t -> bool + + val sort : graph -> t -> Sort.t + + type resolved = int list option * t + + val resolve : graph -> t -> resolved + +end + +module Module_type : sig + + type t + + val origin : graph -> t -> Origin.t + + val path : graph -> t -> Path.t + + val hidden : t -> bool + + val sort : graph -> t -> Sort.t + +end + +module Module : sig + + type t + + val origin : graph -> t -> Origin.t + + val path : graph -> t -> Path.t + + val hidden : t -> bool + + val sort : graph -> t -> Sort.t + + val types : graph -> t -> Type.t String_map.t option + + val class_types : graph -> t -> Class_type.t String_map.t option + + val module_types : graph -> t -> Module_type.t String_map.t option + + val modules : graph -> t -> t String_map.t option + +end + +module Diff : sig + + module Item : sig + + type t = + | Type of Ident.t * Type.t * Origin.t option + | Class_type of Ident.t * Class_type.t * Origin.t option + | Module_type of Ident.t * Module_type.t * Origin.t option + | Module of Ident.t * Module.t * Origin.t option + + val origin : graph -> t -> Origin.t + + val id : graph -> t -> Ident.t + + val previous : graph -> t -> Origin.t option + + end + + type t = Item.t list + +end + +module Component : sig + + type source = + | Global + | Local + | Open + + type t = + | Type of + Origin.t * Ident.t * Desc.Type.t * source * Desc.deprecated + | Class_type of + Origin.t * Ident.t * Desc.Class_type.t * source * Desc.deprecated + | Module_type of + Origin.t * Ident.t * Desc.Module_type.t * source * Desc.deprecated + | Module of + Origin.t * Ident.t * Desc.Module.t * source * Desc.deprecated + | Declare_type of Origin.t * Ident.t + | Declare_class_type of Origin.t * Ident.t + | Declare_module_type of Origin.t * Ident.t + | Declare_module of Origin.t * Ident.t + +end + +module Graph : sig + + type t = graph + + val empty : t + + val add : t -> Component.t list -> t * Diff.t + + val merge : t -> Diff.t -> t + + val find_type : t -> Path.t -> Type.t + + val find_class_type : t -> Path.t -> Class_type.t + + val find_module_type : t -> Path.t -> Module_type.t + + val find_module : t -> Path.t -> Module.t + + val is_type_path_visible : t -> Path.t -> bool + + val is_class_type_path_visible : t -> Path.t -> bool + + val is_module_type_path_visible : t -> Path.t -> bool + + val is_module_path_visible : t -> Path.t -> bool + + val is_type_ident_visible : t -> Ident.t -> bool + + val is_class_type_ident_visible : t -> Ident.t -> bool + + val is_module_type_ident_visible : t -> Ident.t -> bool + + val is_module_ident_visible : t -> Ident.t -> bool + +end diff --git a/ocamlmerlin_mlx/ocaml/typing/signature_group.ml b/ocamlmerlin_mlx/ocaml/typing/signature_group.ml new file mode 100644 index 0000000..b98a9eb --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/signature_group.ml @@ -0,0 +1,155 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Fold on a signature by syntactic group of items *) + +(** Classes and class types generate ghosts signature items, we group them + together before printing *) +type sig_item = + { + src: Types.signature_item; + post_ghosts: Types.signature_item list + (** ghost classes types are post-declared *); + } +let flatten x = x.src :: x.post_ghosts + +type core_rec_group = + | Not_rec of sig_item + | Rec_group of sig_item list + +let rec_items = function + | Not_rec x -> [x] + | Rec_group x -> x + +(** Private row types are manifested as a sequence of definitions + preceding a recursive group, we collect them and separate them from the + syntactic recursive group. *) +type rec_group = + { pre_ghosts: Types.signature_item list; group:core_rec_group } + +let next_group = function + | [] -> None + | src :: q -> + let ghosts, q = + match src with + | Types.Sig_class _ -> + (* a class declaration for [c] is followed by the ghost + declarations of class type [c], and type [c] *) + begin match q with + | ct::t::q -> [ct;t], q + | _ -> assert false + end + | Types.Sig_class_type _ -> + (* a class type declaration for [ct] is followed by the ghost + declaration of type [ct] *) + begin match q with + | t::q -> [t], q + | _ -> assert false + end + | Types.(Sig_module _ | Sig_value _ | Sig_type _ | Sig_typext _ + | Sig_modtype _) -> + [],q + in + Some({src; post_ghosts=ghosts}, q) + +let recursive_sigitem = function + | Types.Sig_type(ident, _, rs, _) + | Types.Sig_class(ident,_,rs,_) + | Types.Sig_class_type (ident,_,rs,_) + | Types.Sig_module(ident, _, _, rs, _) -> Some (ident,rs) + | Types.(Sig_value _ | Sig_modtype _ | Sig_typext _ ) -> None + +let next x = + let cons_group pre group q = + let group = Rec_group (List.rev group) in + Some({ pre_ghosts=List.rev pre; group },q) + in + let rec not_in_group pre l = match next_group l with + | None -> + assert (pre=[]); + None + | Some(elt, q) -> + match recursive_sigitem elt.src with + | Some (id, _) when Btype.is_row_name (Ident.name id) -> + not_in_group (elt.src::pre) q + | None | Some (_, Types.Trec_not) -> + let sgroup = { pre_ghosts=List.rev pre; group=Not_rec elt } in + Some (sgroup,q) + | Some (id, Types.(Trec_first | Trec_next) ) -> + in_group ~pre ~ids:[id] ~group:[elt] q + and in_group ~pre ~ids ~group rem = match next_group rem with + | None -> cons_group pre group [] + | Some (elt,next) -> + match recursive_sigitem elt.src with + | Some (id, Types.Trec_next) -> + in_group ~pre ~ids:(id::ids) ~group:(elt::group) next + | None | Some (_, Types.(Trec_not|Trec_first)) -> + cons_group pre group rem + in + not_in_group [] x + +let seq l = Seq.unfold next l +let iter f l = Seq.iter f (seq l) +let fold f acc l = Seq.fold_left f acc (seq l) + +let update_rec_next rs rem = + match rs with + | Types.Trec_next -> rem + | Types.(Trec_first | Trec_not) -> + match rem with + | Types.Sig_type (id, decl, Trec_next, priv) :: rem -> + Types.Sig_type (id, decl, rs, priv) :: rem + | Types.Sig_module (id, pres, mty, Trec_next, priv) :: rem -> + Types.Sig_module (id, pres, mty, rs, priv) :: rem + | _ -> rem + +type in_place_patch = { + ghosts: Types.signature; + replace_by: Types.signature_item option; +} + + +let replace_in_place f sg = + let rec next_group f before signature = + match next signature with + | None -> None + | Some(item,sg) -> + core_group f ~before ~ghosts:item.pre_ghosts ~before_group:[] + (rec_items item.group) ~sg + and core_group f ~before ~ghosts ~before_group current ~sg = + let commit ghosts = before_group @ List.rev_append ghosts before in + match current with + | [] -> next_group f (commit ghosts) sg + | a :: q -> + match f ~ghosts a.src with + | Some (info, {ghosts; replace_by}) -> + let after = List.concat_map flatten q @ sg in + let after = match recursive_sigitem a.src, replace_by with + | None, _ | _, Some _ -> after + | Some (_,rs), None -> update_rec_next rs after + in + let before = match replace_by with + | None -> commit ghosts + | Some x -> x :: commit ghosts + in + let sg = List.rev_append before after in + Some(info, sg) + | None -> + let before_group = + List.rev_append a.post_ghosts (a.src :: before_group) + in + core_group f ~before ~ghosts ~before_group q ~sg + in + next_group f [] sg diff --git a/ocamlmerlin_mlx/ocaml/typing/signature_group.mli b/ocamlmerlin_mlx/ocaml/typing/signature_group.mli new file mode 100644 index 0000000..0b736a5 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/signature_group.mli @@ -0,0 +1,85 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Iterate on signature by syntactic group of items + + Classes, class types and private row types adds ghost components to + the signature where they are defined. + + When editing or printing a signature it is therefore important to + identify those ghost components. + + This module provides type grouping together ghost components + with the corresponding core item (or recursive group) and + the corresponding iterators. +*) + +(** Classes and class types generate ghosts signature items, we group them + together before printing *) +type sig_item = + { + src: Types.signature_item (** the syntactic item *) +; + post_ghosts: Types.signature_item list + (** ghost classes types are post-declared *); + } + +(** [flatten sig_item] is [x.src :: x.post_ghosts] *) +val flatten: sig_item -> Types.signature + +(** A group of mutually recursive definition *) +type core_rec_group = + | Not_rec of sig_item + | Rec_group of sig_item list + +(** [rec_items group] is the list of sig_items in the group *) +val rec_items: core_rec_group -> sig_item list + +(** Private #row types are manifested as a sequence of definitions + preceding a recursive group, we collect them and separate them from the + syntactic recursive group. *) +type rec_group = + { pre_ghosts: Types.signature_item list; group:core_rec_group } + +(** The sequence [seq signature] iterates over [signature] {!rec_group} by + {!rec_group}. + The second element of the tuple in the {!full_seq} case is the not-yet + traversed part of the signature. +*) +val next: Types.signature -> (rec_group * Types.signature) option +val seq: Types.signature -> rec_group Seq.t + +val iter: (rec_group -> unit) -> Types.signature -> unit +val fold: ('acc -> rec_group -> 'acc) -> 'acc -> Types.signature -> 'acc + +(** Describe how to amend one element of a signature *) +type in_place_patch = { + ghosts: Types.signature; (** updated list of ghost items *) + replace_by: Types.signature_item option; + (** replacement for the selected item *) +} + +(** + [!replace_in_place patch sg] replaces the first element of the signature + for which [patch ~rec_group ~ghosts component] returns [Some (value,patch)]. + The [rec_group] argument is the remaining part of the mutually + recursive group of [component]. + The [ghosts] list is the current prefix of ghost components associated to + [component] +*) +val replace_in_place: + ( ghosts:Types.signature -> Types.signature_item + -> ('a * in_place_patch) option ) + -> Types.signature -> ('a * Types.signature) option diff --git a/ocamlmerlin_mlx/ocaml/typing/stypes.ml b/ocamlmerlin_mlx/ocaml/typing/stypes.ml new file mode 100644 index 0000000..9d4a2ff --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/stypes.ml @@ -0,0 +1,196 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2003 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Recording and dumping (partial) type information *) + +(* + We record all types in a list as they are created. + This means we can dump type information even if type inference fails, + which is extremely important, since type information is most + interesting in case of errors. +*) + +open Annot +open Lexing +open Location +open Typedtree + +let output_int oc i = output_string oc (Int.to_string i) + +type annotation = + | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation + | Ti_expr of expression + | Ti_class of class_expr + | Ti_mod of module_expr + | An_call of Location.t * Annot.call + | An_ident of Location.t * string * Annot.ident + +let get_location ti = + match ti with + | Ti_pat (_, p) -> p.pat_loc + | Ti_expr e -> e.exp_loc + | Ti_class c -> c.cl_loc + | Ti_mod m -> m.mod_loc + | An_call (l, _k) -> l + | An_ident (l, _s, _k) -> l + +let annotations = ref ([] : annotation list) +let phrases = ref ([] : Location.t list) + +let record ti = + if !Clflags.annotations && not (get_location ti).Location.loc_ghost then + annotations := ti :: !annotations + +let record_phrase loc = + if !Clflags.annotations then phrases := loc :: !phrases + +(* comparison order: + the intervals are sorted by order of increasing upper bound + same upper bound -> sorted by decreasing lower bound +*) +let cmp_loc_inner_first loc1 loc2 = + match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with + | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum + | x -> x + +let cmp_ti_inner_first ti1 ti2 = + cmp_loc_inner_first (get_location ti1) (get_location ti2) + +let print_position pp pos = + if pos = dummy_pos then + output_string pp "--" + else begin + output_char pp '\"'; + output_string pp (String.escaped pos.pos_fname); + output_string pp "\" "; + output_int pp pos.pos_lnum; + output_char pp ' '; + output_int pp pos.pos_bol; + output_char pp ' '; + output_int pp pos.pos_cnum; + end + +let print_location pp loc = + print_position pp loc.loc_start; + output_char pp ' '; + print_position pp loc.loc_end + +let sort_filter_phrases () = + let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in + let rec loop accu cur l = + match l with + | [] -> accu + | loc :: t -> + if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum + && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum + then loop accu cur t + else loop (loc :: accu) loc t + in + phrases := loop [] Location.none ph + +let rec printtyp_reset_maybe loc = + match !phrases with + | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum -> + Printtyp.reset (); + phrases := t; + printtyp_reset_maybe loc; + | _ -> () + +let call_kind_string k = + match k with + | Tail -> "tail" + | Stack -> "stack" + | Inline -> "inline" + +let print_ident_annot pp str k = + match k with + | Idef l -> + output_string pp "def "; + output_string pp str; + output_char pp ' '; + print_location pp l; + output_char pp '\n' + | Iref_internal l -> + output_string pp "int_ref "; + output_string pp str; + output_char pp ' '; + print_location pp l; + output_char pp '\n' + | Iref_external -> + output_string pp "ext_ref "; + output_string pp str; + output_char pp '\n' + +(* The format of the annotation file is documented in emacs/caml-types.el. *) + +let print_info pp prev_loc ti = + match ti with + | Ti_class _ | Ti_mod _ -> prev_loc + | Ti_pat (_, {pat_loc = loc; pat_type = typ; pat_env = env}) + | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} -> + if loc <> prev_loc then begin + print_location pp loc; + output_char pp '\n' + end; + output_string pp "type(\n"; + printtyp_reset_maybe loc; + Format.pp_print_string Format.str_formatter " "; + Printtyp.wrap_printing_env ~error:false env + (fun () -> Printtyp.shared_type_scheme Format.str_formatter typ); + (* (fun () -> Printtyp.shared_type_scheme Format.str_formatter typ); *) + Format.pp_print_newline Format.str_formatter (); + let s = Format.flush_str_formatter () in + output_string pp s; + output_string pp ")\n"; + loc + | An_call (loc, k) -> + if loc <> prev_loc then begin + print_location pp loc; + output_char pp '\n' + end; + output_string pp "call(\n "; + output_string pp (call_kind_string k); + output_string pp "\n)\n"; + loc + | An_ident (loc, str, k) -> + if loc <> prev_loc then begin + print_location pp loc; + output_char pp '\n' + end; + output_string pp "ident(\n "; + print_ident_annot pp str k; + output_string pp ")\n"; + loc + +let get_info () = + let info = List.fast_sort cmp_ti_inner_first !annotations in + annotations := []; + info + +let dump filename = + if !Clflags.annotations then begin + let do_dump _temp_filename pp = + let info = get_info () in + sort_filter_phrases (); + ignore (List.fold_left (print_info pp) Location.none info) in + begin match filename with + | None -> do_dump "" stdout + | Some filename -> + Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump + end; + phrases := []; + end else begin + annotations := []; + end diff --git a/ocamlmerlin_mlx/ocaml/typing/stypes.mli b/ocamlmerlin_mlx/ocaml/typing/stypes.mli new file mode 100644 index 0000000..3a86d27 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/stypes.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2003 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Recording and dumping (partial) type information *) + +(* Clflags.save_types must be true *) + +open Typedtree + +type annotation = + | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation + | Ti_expr of expression + | Ti_class of class_expr + | Ti_mod of module_expr + | An_call of Location.t * Annot.call + | An_ident of Location.t * string * Annot.ident + +val record : annotation -> unit +val record_phrase : Location.t -> unit +val dump : string option -> unit + +val get_location : annotation -> Location.t +val get_info : unit -> annotation list diff --git a/ocamlmerlin_mlx/ocaml/typing/subst.ml b/ocamlmerlin_mlx/ocaml/typing/subst.ml new file mode 100644 index 0000000..deef667 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/subst.ml @@ -0,0 +1,782 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Substitutions *) + +open Misc +open Path +open Types +open Btype + +open Local_store + +type type_replacement = + | Path of Path.t + | Type_function of { params : type_expr list; body : type_expr } + +type t = + { types: type_replacement Path.Map.t; + modules: Path.t Path.Map.t; + modtypes: module_type Path.Map.t; + for_saving: bool; + loc: Location.t option; + make_loc_ghost: bool; + } + +let identity = + { types = Path.Map.empty; + modules = Path.Map.empty; + modtypes = Path.Map.empty; + for_saving = false; + loc = None; + make_loc_ghost = false; + } + +let add_type_path id p s = { s with types = Path.Map.add id (Path p) s.types } +let add_type id p s = add_type_path (Pident id) p s + +let add_type_function id ~params ~body s = + { s with types = Path.Map.add id (Type_function { params; body }) s.types } + +let add_module_path id p s = { s with modules = Path.Map.add id p s.modules } +let add_module id p s = add_module_path (Pident id) p s + +let add_modtype_path p ty s = { s with modtypes = Path.Map.add p ty s.modtypes } +let add_modtype id ty s = add_modtype_path (Pident id) ty s + +let for_saving s = { s with for_saving = true } +let change_locs s loc = { s with loc = Some loc } +let make_loc_ghost s = { s with make_loc_ghost = true } + +let loc s x = + match s.loc with + | Some l -> l + | None -> + if s.for_saving && not !Clflags.keep_locs then Location.none + else if s.make_loc_ghost then { x with loc_ghost = true } + else x + +let remove_loc = + let open Ast_mapper in + {default_mapper with location = (fun _this _loc -> Location.none)} + +let is_not_doc = function + | {Parsetree.attr_name = {Location.txt = "ocaml.doc"}; _} -> false + | {Parsetree.attr_name = {Location.txt = "ocaml.text"}; _} -> false + | {Parsetree.attr_name = {Location.txt = "doc"}; _} -> false + | {Parsetree.attr_name = {Location.txt = "text"}; _} -> false + | _ -> true + +let attrs s x = + let x = + if s.for_saving && not !Clflags.keep_docs then + List.filter is_not_doc x + else x + in + if s.for_saving && not !Clflags.keep_locs + then remove_loc.Ast_mapper.attributes remove_loc x + else x + +let rec module_path s path = + try Path.Map.find path s.modules + with Not_found -> + match path with + | Pident _ -> path + | Pdot(p, n) -> + Pdot(module_path s p, n) + | Papply(p1, p2) -> + Papply(module_path s p1, module_path s p2) + | Pextra_ty _ -> + fatal_error "Subst.module_path" + +let modtype_path s path = + match Path.Map.find path s.modtypes with + | Mty_ident p -> p + | Mty_alias _ | Mty_signature _ | Mty_functor _ | Mty_for_hole -> + fatal_error "Subst.modtype_path" + | exception Not_found -> + match path with + | Pdot(p, n) -> + Pdot(module_path s p, n) + | Papply _ | Pextra_ty _ -> + fatal_error "Subst.modtype_path" + | Pident _ -> path + +(* For values, extension constructors, classes and class types *) +let value_path s path = + match path with + | Pident _ -> path + | Pdot(p, n) -> Pdot(module_path s p, n) + | Papply _ | Pextra_ty _ -> fatal_error "Subst.value_path" + +let rec type_path s path = + match Path.Map.find path s.types with + | Path p -> p + | Type_function _ -> assert false + | exception Not_found -> + match path with + | Pident _ -> path + | Pdot(p, n) -> + Pdot(module_path s p, n) + | Papply _ -> + fatal_error "Subst.type_path" + | Pextra_ty (p, extra) -> + match extra with + | Pcstr_ty _ -> Pextra_ty (type_path s p, extra) + | Pext_ty -> Pextra_ty (value_path s p, extra) + +let to_subst_by_type_function s p = + match Path.Map.find p s.types with + | Path _ -> false + | Type_function _ -> true + | exception Not_found -> false + +(* Special type ids for saved signatures *) + +let new_id = s_ref (-1) +let reset_for_saving () = new_id := -1 + +let newpersty desc = + decr new_id; + create_expr + desc ~level:generic_level ~scope:Btype.lowest_level ~id:!new_id + +(* ensure that all occurrences of 'Tvar None' are physically shared *) +let tvar_none = Tvar None +let tunivar_none = Tunivar None +let norm = function + | Tvar None -> tvar_none + | Tunivar None -> tunivar_none + | d -> d + +let ctype_apply_env_empty = ref (fun _ -> assert false) + +(* Similar to [Ctype.nondep_type_rec]. *) +let rec typexp copy_scope s ty = + let desc = get_desc ty in + match desc with + Tvar _ | Tunivar _ -> + if s.for_saving || get_id ty < 0 then + let ty' = + if s.for_saving then newpersty (norm desc) + else newty2 ~level:(get_level ty) desc + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + ty' + else ty + | Tsubst (ty, _) -> + ty + | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method + && field_kind_repr k <> Fabsent && get_level ty < generic_level -> + (* do not copy the type of self when it is not generalized *) + ty +(* cannot do it, since it would omit substitution + | Tvariant row when not (static_row row) -> + ty +*) + | _ -> + let tm = row_of_type ty in + let has_fixed_row = + not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in + (* Make a stub *) + let ty' = + if s.for_saving then newpersty (Tvar None) + else newgenstub ~scope:(get_scope ty) + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + let desc = + if has_fixed_row then + match get_desc tm with (* PR#7348 *) + Tconstr (Pdot(m,i), tl, _abbrev) -> + let i' = String.sub i 0 (String.length i - 4) in + Tconstr(type_path s (Pdot(m,i')), tl, ref Mnil) + | _ -> assert false + else match desc with + | Tconstr (p, args, _abbrev) -> + let args = List.map (typexp copy_scope s) args in + begin match Path.Map.find p s.types with + | exception Not_found -> Tconstr(type_path s p, args, ref Mnil) + | Path _ -> Tconstr(type_path s p, args, ref Mnil) + | Type_function { params; body } -> + Tlink (!ctype_apply_env_empty params body args) + end + | Tpackage(p, fl) -> + Tpackage(modtype_path s p, + List.map (fun (n, ty) -> (n, typexp copy_scope s ty)) fl) + | Tobject (t1, name) -> + let t1' = typexp copy_scope s t1 in + let name' = + match !name with + | None -> None + | Some (p, tl) -> + if to_subst_by_type_function s p + then None + else Some (type_path s p, List.map (typexp copy_scope s) tl) + in + Tobject (t1', ref name') + | Tvariant row -> + let more = row_more row in + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + begin match mored with + Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + let dup = + s.for_saving || get_level more = generic_level || + static_row row || is_Tconstr more in + (* Various cases for the row variable *) + let more' = + match mored with + Tsubst (ty, None) -> ty + | Tconstr _ | Tnil -> typexp copy_scope s more + | Tunivar _ | Tvar _ -> + if s.for_saving then newpersty (norm mored) + else if dup && is_Tvar more then newgenty mored + else more + | _ -> assert false + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope more + (Tsubst (more', Some ty')); + (* TODO: check if more' can be eliminated *) + (* Return a new copy *) + let row = + copy_row (typexp copy_scope s) true row (not dup) more' in + match row_name row with + | Some (p, tl) -> + let name = + if to_subst_by_type_function s p then None + else Some (type_path s p, tl) + in + Tvariant (set_row_name row name) + | None -> + Tvariant row + end + | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> + Tlink (typexp copy_scope s t2) + | _ -> copy_type_desc (typexp copy_scope s) desc + in + Transient_expr.set_stub_desc ty' desc; + ty' + +(* + Always make a copy of the type. If this is not done, type levels + might not be correct. +*) +let type_expr s ty = + For_copy.with_scope (fun copy_scope -> typexp copy_scope s ty) + +let label_declaration copy_scope s l = + { + ld_id = l.ld_id; + ld_mutable = l.ld_mutable; + ld_type = typexp copy_scope s l.ld_type; + ld_loc = loc s l.ld_loc; + ld_attributes = attrs s l.ld_attributes; + ld_uid = l.ld_uid; + } + +let constructor_arguments copy_scope s = function + | Cstr_tuple l -> + Cstr_tuple (List.map (typexp copy_scope s) l) + | Cstr_record l -> + Cstr_record (List.map (label_declaration copy_scope s) l) + +let constructor_declaration copy_scope s c = + { + cd_id = c.cd_id; + cd_args = constructor_arguments copy_scope s c.cd_args; + cd_res = Option.map (typexp copy_scope s) c.cd_res; + cd_loc = loc s c.cd_loc; + cd_attributes = attrs s c.cd_attributes; + cd_uid = c.cd_uid; + } + +let type_declaration' copy_scope s decl = + { type_params = List.map (typexp copy_scope s) decl.type_params; + type_arity = decl.type_arity; + type_kind = + begin match decl.type_kind with + Type_abstract -> Type_abstract + | Type_variant (cstrs, rep) -> + Type_variant (List.map (constructor_declaration copy_scope s) cstrs, + rep) + | Type_record(lbls, rep) -> + Type_record (List.map (label_declaration copy_scope s) lbls, rep) + | Type_open -> Type_open + end; + type_manifest = + begin + match decl.type_manifest with + None -> None + | Some ty -> Some(typexp copy_scope s ty) + end; + type_private = decl.type_private; + type_variance = decl.type_variance; + type_separability = decl.type_separability; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = loc s decl.type_loc; + type_attributes = attrs s decl.type_attributes; + type_immediate = decl.type_immediate; + type_unboxed_default = decl.type_unboxed_default; + type_uid = decl.type_uid; + } + +let type_declaration s decl = + For_copy.with_scope (fun copy_scope -> type_declaration' copy_scope s decl) + +let class_signature copy_scope s sign = + { csig_self = typexp copy_scope s sign.csig_self; + csig_self_row = typexp copy_scope s sign.csig_self_row; + csig_vars = + Vars.map + (function (m, v, t) -> (m, v, typexp copy_scope s t)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, t) -> (p, v, typexp copy_scope s t)) + sign.csig_meths; + } + +let rec class_type copy_scope s = function + | Cty_constr (p, tyl, cty) -> + let p' = type_path s p in + let tyl' = List.map (typexp copy_scope s) tyl in + let cty' = class_type copy_scope s cty in + Cty_constr (p', tyl', cty') + | Cty_signature sign -> + Cty_signature (class_signature copy_scope s sign) + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, typexp copy_scope s ty, class_type copy_scope s cty) + +let class_declaration' copy_scope s decl = + { cty_params = List.map (typexp copy_scope s) decl.cty_params; + cty_variance = decl.cty_variance; + cty_type = class_type copy_scope s decl.cty_type; + cty_path = type_path s decl.cty_path; + cty_new = + begin match decl.cty_new with + | None -> None + | Some ty -> Some (typexp copy_scope s ty) + end; + cty_loc = loc s decl.cty_loc; + cty_attributes = attrs s decl.cty_attributes; + cty_uid = decl.cty_uid; + } + +let class_declaration s decl = + For_copy.with_scope (fun copy_scope -> class_declaration' copy_scope s decl) + +let cltype_declaration' copy_scope s decl = + { clty_params = List.map (typexp copy_scope s) decl.clty_params; + clty_variance = decl.clty_variance; + clty_type = class_type copy_scope s decl.clty_type; + clty_path = type_path s decl.clty_path; + clty_hash_type = type_declaration' copy_scope s decl.clty_hash_type ; + clty_loc = loc s decl.clty_loc; + clty_attributes = attrs s decl.clty_attributes; + clty_uid = decl.clty_uid; + } + +let cltype_declaration s decl = + For_copy.with_scope (fun copy_scope -> cltype_declaration' copy_scope s decl) + +let class_type s cty = + For_copy.with_scope (fun copy_scope -> class_type copy_scope s cty) + +let value_description' copy_scope s descr = + { val_type = typexp copy_scope s descr.val_type; + val_kind = descr.val_kind; + val_loc = loc s descr.val_loc; + val_attributes = attrs s descr.val_attributes; + val_uid = descr.val_uid; + } + +let value_description s descr = + For_copy.with_scope (fun copy_scope -> value_description' copy_scope s descr) + +let extension_constructor' copy_scope s ext = + { ext_type_path = type_path s ext.ext_type_path; + ext_type_params = List.map (typexp copy_scope s) ext.ext_type_params; + ext_args = constructor_arguments copy_scope s ext.ext_args; + ext_ret_type = Option.map (typexp copy_scope s) ext.ext_ret_type; + ext_private = ext.ext_private; + ext_attributes = attrs s ext.ext_attributes; + ext_loc = if s.for_saving then Location.none else ext.ext_loc; + ext_uid = ext.ext_uid; + } + +let extension_constructor s ext = + For_copy.with_scope + (fun copy_scope -> extension_constructor' copy_scope s ext) + + +(* For every binding k |-> d of m1, add k |-> f d to m2 + and return resulting merged map. *) + +let merge_path_maps f m1 m2 = + Path.Map.fold (fun k d accu -> Path.Map.add k (f d) accu) m1 m2 + +let keep_latest_loc l1 l2 = + match l2 with + | None -> l1 + | Some _ -> l2 + +let type_replacement s = function + | Path p -> Path (type_path s p) + | Type_function { params; body } -> + For_copy.with_scope (fun copy_scope -> + let params = List.map (typexp copy_scope s) params in + let body = typexp copy_scope s body in + Type_function { params; body }) + +type scoping = + | Keep + | Make_local + | Rescope of int + +module Lazy_types = struct + + type module_decl = + { + mdl_type: modtype; + mdl_attributes: Parsetree.attributes; + mdl_loc: Location.t; + mdl_uid: Uid.t; + } + + and modtype = + | MtyL_ident of Path.t + | MtyL_signature of signature + | MtyL_functor of functor_parameter * modtype + | MtyL_alias of Path.t + | MtyL_for_hole + + and modtype_declaration = + { + mtdl_type: modtype option; + mtdl_attributes: Parsetree.attributes; + mtdl_loc: Location.t; + mtdl_uid: Uid.t; + } + + and signature' = + | S_eager of Types.signature + | S_lazy of signature_item list + + and signature = + (scoping * t * signature', signature') Lazy_backtrack.t + + and signature_item = + SigL_value of Ident.t * value_description * visibility + | SigL_type of Ident.t * type_declaration * rec_status * visibility + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility + | SigL_module of + Ident.t * module_presence * module_decl * rec_status * visibility + | SigL_modtype of Ident.t * modtype_declaration * visibility + | SigL_class of Ident.t * class_declaration * rec_status * visibility + | SigL_class_type of Ident.t * class_type_declaration * + rec_status * visibility + + and functor_parameter = + | Unit + | Named of Ident.t option * modtype + +end +open Lazy_types + +let rename_bound_idents scoping s sg = + let rename = + let open Ident in + match scoping with + | Keep -> (fun id -> create_scoped ~scope:(scope id) (name id)) + | Make_local -> Ident.rename + | Rescope scope -> (fun id -> create_scoped ~scope (name id)) + in + let rec rename_bound_idents s sg = function + | [] -> sg, s + | SigL_type(id, td, rs, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_type id (Pident id') s) + (SigL_type(id', td, rs, vis) :: sg) + rest + | SigL_module(id, pres, md, rs, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_module id (Pident id') s) + (SigL_module (id', pres, md, rs, vis) :: sg) + rest + | SigL_modtype(id, mtd, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_modtype id (Mty_ident(Pident id')) s) + (SigL_modtype(id', mtd, vis) :: sg) + rest + | SigL_class(id, cd, rs, vis) :: rest -> + (* cheat and pretend they are types cf. PR#6650 *) + let id' = rename id in + rename_bound_idents + (add_type id (Pident id') s) + (SigL_class(id', cd, rs, vis) :: sg) + rest + | SigL_class_type(id, ctd, rs, vis) :: rest -> + (* cheat and pretend they are types cf. PR#6650 *) + let id' = rename id in + rename_bound_idents + (add_type id (Pident id') s) + (SigL_class_type(id', ctd, rs, vis) :: sg) + rest + | SigL_value(id, vd, vis) :: rest -> + (* scope doesn't matter for value identifiers. *) + let id' = Ident.rename id in + rename_bound_idents s (SigL_value(id', vd, vis) :: sg) rest + | SigL_typext(id, ec, es, vis) :: rest -> + let id' = rename id in + rename_bound_idents s (SigL_typext(id',ec,es,vis) :: sg) rest + in + rename_bound_idents s [] sg + + let rec lazy_module_decl md = + { mdl_type = lazy_modtype md.md_type; + mdl_attributes = md.md_attributes; + mdl_loc = md.md_loc; + mdl_uid = md.md_uid } + +and subst_lazy_module_decl scoping s md = + let mdl_type = subst_lazy_modtype scoping s md.mdl_type in + { mdl_type; + mdl_attributes = attrs s md.mdl_attributes; + mdl_loc = loc s md.mdl_loc; + mdl_uid = md.mdl_uid } + +and force_module_decl md = + let md_type = force_modtype md.mdl_type in + { md_type; + md_attributes = md.mdl_attributes; + md_loc = md.mdl_loc; + md_uid = md.mdl_uid } + +and lazy_modtype = function + | Mty_ident p -> MtyL_ident p + | Mty_signature sg -> + MtyL_signature (Lazy_backtrack.create_forced (S_eager sg)) + | Mty_functor (Unit, mty) -> MtyL_functor (Unit, lazy_modtype mty) + | Mty_functor (Named (id, arg), res) -> + MtyL_functor (Named (id, lazy_modtype arg), lazy_modtype res) + | Mty_alias p -> MtyL_alias p + | Mty_for_hole -> MtyL_for_hole + +and subst_lazy_modtype scoping s = function + | MtyL_ident p -> + begin match Path.Map.find p s.modtypes with + | mty -> lazy_modtype mty + | exception Not_found -> + begin match p with + | Pident _ -> MtyL_ident p + | Pdot(p, n) -> + MtyL_ident(Pdot(module_path s p, n)) + | Papply _ | Pextra_ty _ -> + fatal_error "Subst.modtype" + end + end + | MtyL_signature sg -> + MtyL_signature(subst_lazy_signature scoping s sg) + | MtyL_functor(Unit, res) -> + MtyL_functor(Unit, subst_lazy_modtype scoping s res) + | MtyL_functor(Named (None, arg), res) -> + MtyL_functor(Named (None, (subst_lazy_modtype scoping s) arg), + subst_lazy_modtype scoping s res) + | MtyL_functor(Named (Some id, arg), res) -> + let id' = Ident.rename id in + MtyL_functor(Named (Some id', (subst_lazy_modtype scoping s) arg), + subst_lazy_modtype scoping (add_module id (Pident id') s) res) + | MtyL_alias p -> + MtyL_alias (module_path s p) + | MtyL_for_hole -> MtyL_for_hole + +and force_modtype = function + | MtyL_ident p -> Mty_ident p + | MtyL_signature sg -> Mty_signature (force_signature sg) + | MtyL_functor (param, res) -> + let param : Types.functor_parameter = + match param with + | Unit -> Unit + | Named (id, mty) -> Named (id, force_modtype mty) in + Mty_functor (param, force_modtype res) + | MtyL_alias p -> Mty_alias p + | MtyL_for_hole -> Mty_for_hole + +and lazy_modtype_decl mtd = + let mtdl_type = Option.map lazy_modtype mtd.mtd_type in + { mtdl_type; + mtdl_attributes = mtd.mtd_attributes; + mtdl_loc = mtd.mtd_loc; + mtdl_uid = mtd.mtd_uid } + +and subst_lazy_modtype_decl scoping s mtd = + { mtdl_type = Option.map (subst_lazy_modtype scoping s) mtd.mtdl_type; + mtdl_attributes = attrs s mtd.mtdl_attributes; + mtdl_loc = loc s mtd.mtdl_loc; + mtdl_uid = mtd.mtdl_uid } + +and force_modtype_decl mtd = + let mtd_type = Option.map force_modtype mtd.mtdl_type in + { mtd_type; + mtd_attributes = mtd.mtdl_attributes; + mtd_loc = mtd.mtdl_loc; + mtd_uid = mtd.mtdl_uid } + +and subst_lazy_signature scoping s sg = + match Lazy_backtrack.get_contents sg with + | Left (scoping', s', sg) -> + let scoping = + match scoping', scoping with + | sc, Keep -> sc + | _, (Make_local|Rescope _) -> scoping + in + let s = compose s' s in + Lazy_backtrack.create (scoping, s, sg) + | Right sg -> + Lazy_backtrack.create (scoping, s, sg) + +and force_signature sg = + List.map force_signature_item (force_signature_once sg) + +and force_signature_once sg = + lazy_signature' (Lazy_backtrack.force force_signature_once' sg) + +and lazy_signature' = function + | S_lazy sg -> sg + | S_eager sg -> List.map lazy_signature_item sg + +and force_signature_once' (scoping, s, sg) = + let sg = lazy_signature' sg in + (* Components of signature may be mutually recursive (e.g. type declarations + or class and type declarations), so first build global renaming + substitution... *) + let (sg', s') = rename_bound_idents scoping s sg in + (* ... then apply it to each signature component in turn *) + For_copy.with_scope (fun copy_scope -> + S_lazy (List.rev_map (subst_lazy_signature_item' copy_scope scoping s') sg') + ) + +and lazy_signature_item = function + | Sig_value(id, d, vis) -> + SigL_value(id, d, vis) + | Sig_type(id, d, rs, vis) -> + SigL_type(id, d, rs, vis) + | Sig_typext(id, ext, es, vis) -> + SigL_typext(id, ext, es, vis) + | Sig_module(id, res, d, rs, vis) -> + SigL_module(id, res, lazy_module_decl d, rs, vis) + | Sig_modtype(id, d, vis) -> + SigL_modtype(id, lazy_modtype_decl d, vis) + | Sig_class(id, d, rs, vis) -> + SigL_class(id, d, rs, vis) + | Sig_class_type(id, d, rs, vis) -> + SigL_class_type(id, d, rs, vis) + +and subst_lazy_signature_item' copy_scope scoping s comp = + match comp with + SigL_value(id, d, vis) -> + SigL_value(id, value_description' copy_scope s d, vis) + | SigL_type(id, d, rs, vis) -> + SigL_type(id, type_declaration' copy_scope s d, rs, vis) + | SigL_typext(id, ext, es, vis) -> + SigL_typext(id, extension_constructor' copy_scope s ext, es, vis) + | SigL_module(id, pres, d, rs, vis) -> + SigL_module(id, pres, subst_lazy_module_decl scoping s d, rs, vis) + | SigL_modtype(id, d, vis) -> + SigL_modtype(id, subst_lazy_modtype_decl scoping s d, vis) + | SigL_class(id, d, rs, vis) -> + SigL_class(id, class_declaration' copy_scope s d, rs, vis) + | SigL_class_type(id, d, rs, vis) -> + SigL_class_type(id, cltype_declaration' copy_scope s d, rs, vis) + +and force_signature_item = function + | SigL_value(id, vd, vis) -> Sig_value(id, vd, vis) + | SigL_type(id, d, rs, vis) -> Sig_type(id, d, rs, vis) + | SigL_typext(id, ext, es, vis) -> Sig_typext(id, ext, es, vis) + | SigL_module(id, pres, d, rs, vis) -> + Sig_module(id, pres, force_module_decl d, rs, vis) + | SigL_modtype(id, d, vis) -> + Sig_modtype (id, force_modtype_decl d, vis) + | SigL_class(id, d, rs, vis) -> Sig_class(id, d, rs, vis) + | SigL_class_type(id, d, rs, vis) -> Sig_class_type(id, d, rs, vis) + +and modtype scoping s t = + t |> lazy_modtype |> subst_lazy_modtype scoping s |> force_modtype + +(* Composition of substitutions: + apply (compose s1 s2) x = apply s2 (apply s1 x) *) + +and compose s1 s2 = + if s1 == identity then s2 else + if s2 == identity then s1 else + { types = merge_path_maps (type_replacement s2) s1.types s2.types; + modules = merge_path_maps (module_path s2) s1.modules s2.modules; + modtypes = merge_path_maps (modtype Keep s2) s1.modtypes s2.modtypes; + for_saving = s1.for_saving || s2.for_saving; + loc = keep_latest_loc s1.loc s2.loc; + make_loc_ghost = s1.make_loc_ghost || s2.make_loc_ghost; + } + + +let subst_lazy_signature_item scoping s comp = + For_copy.with_scope + (fun copy_scope -> subst_lazy_signature_item' copy_scope scoping s comp) + +module Lazy = struct + include Lazy_types + + let of_module_decl = lazy_module_decl + let of_modtype = lazy_modtype + let of_modtype_decl = lazy_modtype_decl + let of_signature sg = Lazy_backtrack.create_forced (S_eager sg) + let of_signature_items sg = Lazy_backtrack.create_forced (S_lazy sg) + let of_signature_item = lazy_signature_item + + let module_decl = subst_lazy_module_decl + let modtype = subst_lazy_modtype + let modtype_decl = subst_lazy_modtype_decl + let signature = subst_lazy_signature + let signature_item = subst_lazy_signature_item + + let force_module_decl = force_module_decl + let force_modtype = force_modtype + let force_modtype_decl = force_modtype_decl + let force_signature = force_signature + let force_signature_once = force_signature_once + let force_signature_item = force_signature_item +end + +let signature sc s sg = + Lazy.(sg |> of_signature |> signature sc s |> force_signature) + +let signature_item sc s comp = + Lazy.(comp|> of_signature_item |> signature_item sc s |> force_signature_item) + +let modtype_declaration sc s decl = + Lazy.(decl |> of_modtype_decl |> modtype_decl sc s |> force_modtype_decl) + +let module_declaration scoping s decl = + Lazy.(decl |> of_module_decl |> module_decl scoping s |> force_module_decl) diff --git a/ocamlmerlin_mlx/ocaml/typing/subst.mli b/ocamlmerlin_mlx/ocaml/typing/subst.mli new file mode 100644 index 0000000..3a1c85c --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/subst.mli @@ -0,0 +1,154 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Substitutions *) + +open Types + +type t + +(* + Substitutions are used to translate a type from one context to + another. This requires substituting paths for identifiers, and + possibly also lowering the level of non-generic variables so that + they are inferior to the maximum level of the new context. + + Substitutions can also be used to create a "clean" copy of a type. + Indeed, non-variable node of a type are duplicated, with their + levels set to generic level. That way, the resulting type is + well-formed (decreasing levels), even if the original one was not. +*) + +val identity: t + +val add_type: Ident.t -> Path.t -> t -> t +val add_type_path: Path.t -> Path.t -> t -> t +val add_type_function: + Path.t -> params:type_expr list -> body:type_expr -> t -> t +val add_module: Ident.t -> Path.t -> t -> t +val add_module_path: Path.t -> Path.t -> t -> t +val add_modtype: Ident.t -> module_type -> t -> t +val add_modtype_path: Path.t -> module_type -> t -> t + +val for_saving: t -> t +val make_loc_ghost: t -> t +val reset_for_saving: unit -> unit +val change_locs: t -> Location.t -> t + +val module_path: t -> Path.t -> Path.t +val type_path: t -> Path.t -> Path.t +val modtype_path: t -> Path.t -> Path.t + +val type_expr: t -> type_expr -> type_expr +val class_type: t -> class_type -> class_type +val value_description: t -> value_description -> value_description +val type_declaration: t -> type_declaration -> type_declaration +val extension_constructor: + t -> extension_constructor -> extension_constructor +val class_declaration: t -> class_declaration -> class_declaration +val cltype_declaration: t -> class_type_declaration -> class_type_declaration + +(* + When applied to a signature item, a substitution not only modifies the types + present in its declaration, but also refreshes the identifier of the item. + Effectively this creates new declarations, and so one should decide what the + scope of this new declaration should be. + + This is decided by the [scoping] argument passed to the following functions. +*) + +type scoping = + | Keep + | Make_local + | Rescope of int + +val modtype: scoping -> t -> module_type -> module_type +val signature: scoping -> t -> signature -> signature +val signature_item: scoping -> t -> signature_item -> signature_item +val modtype_declaration: + scoping -> t -> modtype_declaration -> modtype_declaration +val module_declaration: scoping -> t -> module_declaration -> module_declaration + +(* Composition of substitutions: + apply (compose s1 s2) x = apply s2 (apply s1 x) *) +val compose: t -> t -> t + +(* A forward reference to be filled in ctype.ml. *) +val ctype_apply_env_empty: + (type_expr list -> type_expr -> type_expr list -> type_expr) ref + + +module Lazy : sig + type module_decl = + { + mdl_type: modtype; + mdl_attributes: Parsetree.attributes; + mdl_loc: Location.t; + mdl_uid: Uid.t; + } + + and modtype = + | MtyL_ident of Path.t + | MtyL_signature of signature + | MtyL_functor of functor_parameter * modtype + | MtyL_alias of Path.t + | MtyL_for_hole + + and modtype_declaration = + { + mtdl_type: modtype option; (* Note: abstract *) + mtdl_attributes: Parsetree.attributes; + mtdl_loc: Location.t; + mtdl_uid: Uid.t; + } + + and signature + + and signature_item = + SigL_value of Ident.t * value_description * visibility + | SigL_type of Ident.t * type_declaration * rec_status * visibility + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility + | SigL_module of + Ident.t * module_presence * module_decl * rec_status * visibility + | SigL_modtype of Ident.t * modtype_declaration * visibility + | SigL_class of Ident.t * class_declaration * rec_status * visibility + | SigL_class_type of Ident.t * class_type_declaration * + rec_status * visibility + + and functor_parameter = + | Unit + | Named of Ident.t option * modtype + + + val of_module_decl : Types.module_declaration -> module_decl + val of_modtype : Types.module_type -> modtype + val of_modtype_decl : Types.modtype_declaration -> modtype_declaration + val of_signature : Types.signature -> signature + val of_signature_items : signature_item list -> signature + val of_signature_item : Types.signature_item -> signature_item + + val module_decl : scoping -> t -> module_decl -> module_decl + val modtype : scoping -> t -> modtype -> modtype + val modtype_decl : scoping -> t -> modtype_declaration -> modtype_declaration + val signature : scoping -> t -> signature -> signature + val signature_item : scoping -> t -> signature_item -> signature_item + + val force_module_decl : module_decl -> Types.module_declaration + val force_modtype : modtype -> Types.module_type + val force_modtype_decl : modtype_declaration -> Types.modtype_declaration + val force_signature : signature -> Types.signature + val force_signature_once : signature -> signature_item list + val force_signature_item : signature_item -> Types.signature_item +end diff --git a/ocamlmerlin_mlx/ocaml/typing/tast_iterator.ml b/ocamlmerlin_mlx/ocaml/typing/tast_iterator.ml new file mode 100644 index 0000000..049dded --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/tast_iterator.ml @@ -0,0 +1,651 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Isaac "Izzy" Avram *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +type iterator = + { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attributes -> unit; + binding_op: iterator -> binding_op -> unit; + case: 'k . iterator -> 'k case -> unit; + class_declaration: iterator -> class_declaration -> unit; + class_description: iterator -> class_description -> unit; + class_expr: iterator -> class_expr -> unit; + class_field: iterator -> class_field -> unit; + class_signature: iterator -> class_signature -> unit; + class_structure: iterator -> class_structure -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + env: iterator -> Env.t -> unit; + expr: iterator -> expression -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_coercion: iterator -> module_coercion -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_substitution: iterator -> module_substitution -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + package_type: iterator -> package_type -> unit; + pat: 'k . iterator -> 'k general_pattern -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + open_declaration: iterator -> open_declaration -> unit; + open_description: iterator -> open_description -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_declarations: iterator -> (rec_flag * type_declaration list) -> unit; + type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> (rec_flag * value_binding list) -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; + } + +let iter_snd f (_, y) = f y +let iter_loc sub {loc; _} = sub.location sub loc + +let location _sub _l = () + +let attribute sub x = + let iterator = { + Ast_iterator.default_iterator + with location = fun _this x -> sub.location sub x + } in + iter_loc sub x.Parsetree.attr_name; + iterator.payload iterator x.Parsetree.attr_payload; + sub.location sub x.Parsetree.attr_loc + +let attributes sub l = List.iter (attribute sub) l + +let structure sub {str_items; str_final_env; _} = + List.iter (sub.structure_item sub) str_items; + sub.env sub str_final_env + +let class_infos sub f x = + sub.location sub x.ci_loc; + sub.attributes sub x.ci_attributes; + iter_loc sub x.ci_id_name; + List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params; + f x.ci_expr + +let module_type_declaration sub x = + sub.location sub x.mtd_loc; + sub.attributes sub x.mtd_attributes; + iter_loc sub x.mtd_name; + Option.iter (sub.module_type sub) x.mtd_type + +let module_declaration sub {md_loc; md_name; md_type; md_attributes; _} = + sub.location sub md_loc; + sub.attributes sub md_attributes; + iter_loc sub md_name; + sub.module_type sub md_type + +let module_substitution sub {ms_loc; ms_name; ms_txt; ms_attributes; _} = + sub.location sub ms_loc; + sub.attributes sub ms_attributes; + iter_loc sub ms_name; + iter_loc sub ms_txt + +let include_infos sub f {incl_loc; incl_mod; incl_attributes; _} = + sub.location sub incl_loc; + sub.attributes sub incl_attributes; + f incl_mod + +let class_type_declaration sub x = + class_infos sub (sub.class_type sub) x + +let class_declaration sub x = + class_infos sub (sub.class_expr sub) x + +let structure_item sub {str_loc; str_desc; str_env; _} = + sub.location sub str_loc; + sub.env sub str_env; + match str_desc with + | Tstr_eval (exp, attrs) -> sub.expr sub exp; sub.attributes sub attrs + | Tstr_value (rec_flag, list) -> sub.value_bindings sub (rec_flag, list) + | Tstr_primitive v -> sub.value_description sub v + | Tstr_type (rec_flag, list) -> sub.type_declarations sub (rec_flag, list) + | Tstr_typext te -> sub.type_extension sub te + | Tstr_exception ext -> sub.type_exception sub ext + | Tstr_module mb -> sub.module_binding sub mb + | Tstr_recmodule list -> List.iter (sub.module_binding sub) list + | Tstr_modtype x -> sub.module_type_declaration sub x + | Tstr_class list -> + List.iter (fun (cls,_) -> sub.class_declaration sub cls) list + | Tstr_class_type list -> + List.iter (fun (_, s, cltd) -> + iter_loc sub s; sub.class_type_declaration sub cltd) list + | Tstr_include incl -> include_infos sub (sub.module_expr sub) incl + | Tstr_open od -> sub.open_declaration sub od + | Tstr_attribute attr -> sub.attribute sub attr + +let value_description sub x = + sub.location sub x.val_loc; + sub.attributes sub x.val_attributes; + iter_loc sub x.val_name; + sub.typ sub x.val_desc + +let label_decl sub {ld_loc; ld_name; ld_type; ld_attributes; _} = + sub.location sub ld_loc; + sub.attributes sub ld_attributes; + iter_loc sub ld_name; + sub.typ sub ld_type + +let constructor_args sub = function + | Cstr_tuple l -> List.iter (sub.typ sub) l + | Cstr_record l -> List.iter (label_decl sub) l + +let constructor_decl sub x = + sub.location sub x.cd_loc; + sub.attributes sub x.cd_attributes; + iter_loc sub x.cd_name; + List.iter (iter_loc sub) x.cd_vars; + constructor_args sub x.cd_args; + Option.iter (sub.typ sub) x.cd_res + +let type_kind sub = function + | Ttype_abstract -> () + | Ttype_variant list -> List.iter (constructor_decl sub) list + | Ttype_record list -> List.iter (label_decl sub) list + | Ttype_open -> () + +let type_declaration sub x = + sub.location sub x.typ_loc; + sub.attributes sub x.typ_attributes; + iter_loc sub x.typ_name; + List.iter + (fun (c1, c2, loc) -> + sub.typ sub c1; + sub.typ sub c2; + sub.location sub loc) + x.typ_cstrs; + sub.type_kind sub x.typ_kind; + Option.iter (sub.typ sub) x.typ_manifest; + List.iter (fun (c, _) -> sub.typ sub c) x.typ_params + +let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list + +let type_extension sub x = + sub.location sub x.tyext_loc; + sub.attributes sub x.tyext_attributes; + iter_loc sub x.tyext_txt; + List.iter (fun (c, _) -> sub.typ sub c) x.tyext_params; + List.iter (sub.extension_constructor sub) x.tyext_constructors + +let type_exception sub {tyexn_loc; tyexn_constructor; tyexn_attributes; _} = + sub.location sub tyexn_loc; + sub.attributes sub tyexn_attributes; + sub.extension_constructor sub tyexn_constructor + +let extension_constructor sub {ext_loc; ext_name; ext_kind; ext_attributes; _} = + sub.location sub ext_loc; + sub.attributes sub ext_attributes; + iter_loc sub ext_name; + match ext_kind with + | Text_decl (ids, ctl, cto) -> + List.iter (iter_loc sub) ids; + constructor_args sub ctl; + Option.iter (sub.typ sub) cto + | Text_rebind (_, lid) -> iter_loc sub lid + +let pat_extra sub (e, loc, attrs) = + sub.location sub loc; + sub.attributes sub attrs; + match e with + | Tpat_type (_, lid) -> iter_loc sub lid + | Tpat_unpack -> () + | Tpat_open (_, lid, env) -> iter_loc sub lid; sub.env sub env + | Tpat_constraint ct -> sub.typ sub ct + +let pat + : type k . iterator -> k general_pattern -> unit + = fun sub {pat_loc; pat_extra=extra; pat_desc; pat_env; pat_attributes; _} -> + sub.location sub pat_loc; + sub.attributes sub pat_attributes; + sub.env sub pat_env; + List.iter (pat_extra sub) extra; + match pat_desc with + | Tpat_any -> () + | Tpat_var (_, s) -> iter_loc sub s + | Tpat_constant _ -> () + | Tpat_tuple l -> List.iter (sub.pat sub) l + | Tpat_construct (lid, _, l, vto) -> + iter_loc sub lid; + List.iter (sub.pat sub) l; + Option.iter (fun (ids, ct) -> + List.iter (iter_loc sub) ids; sub.typ sub ct) vto + | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po + | Tpat_record (l, _) -> + List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l + | Tpat_array l -> List.iter (sub.pat sub) l + | Tpat_alias (p, _, s) -> sub.pat sub p; iter_loc sub s + | Tpat_lazy p -> sub.pat sub p + | Tpat_value p -> sub.pat sub (p :> pattern) + | Tpat_exception p -> sub.pat sub p + | Tpat_or (p1, p2, _) -> + sub.pat sub p1; + sub.pat sub p2 + +let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = + let extra = function + | Texp_constraint cty -> sub.typ sub cty + | Texp_coerce (cty1, cty2) -> + Option.iter (sub.typ sub) cty1; + sub.typ sub cty2 + | Texp_newtype _ -> () + | Texp_newtype' _ -> () + | Texp_poly cto -> Option.iter (sub.typ sub) cto + in + sub.location sub exp_loc; + sub.attributes sub exp_attributes; + List.iter (fun (e, loc, _) -> extra e; sub.location sub loc) exp_extra; + sub.env sub exp_env; + match exp_desc with + | Texp_ident (_, lid, _) -> iter_loc sub lid + | Texp_constant _ -> () + | Texp_let (rec_flag, list, exp) -> + sub.value_bindings sub (rec_flag, list); + sub.expr sub exp + | Texp_function {cases; _} -> + List.iter (sub.case sub) cases + | Texp_apply (exp, list) -> + sub.expr sub exp; + List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list + | Texp_match (exp, cases, _) -> + sub.expr sub exp; + List.iter (sub.case sub) cases + | Texp_try (exp, cases) -> + sub.expr sub exp; + List.iter (sub.case sub) cases + | Texp_tuple list -> List.iter (sub.expr sub) list + | Texp_construct (lid, _, args) -> + iter_loc sub lid; + List.iter (sub.expr sub) args + | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo + | Texp_record { fields; extended_expression; _} -> + Array.iter (function + | _, Kept _ -> () + | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp) + fields; + Option.iter (sub.expr sub) extended_expression; + | Texp_field (exp, lid, _) -> + iter_loc sub lid; + sub.expr sub exp + | Texp_setfield (exp1, lid, _, exp2) -> + iter_loc sub lid; + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_array list -> List.iter (sub.expr sub) list + | Texp_ifthenelse (exp1, exp2, expo) -> + sub.expr sub exp1; + sub.expr sub exp2; + Option.iter (sub.expr sub) expo + | Texp_sequence (exp1, exp2) -> + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_while (exp1, exp2) -> + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_for (_, _, exp1, exp2, _, exp3) -> + sub.expr sub exp1; + sub.expr sub exp2; + sub.expr sub exp3 + | Texp_send (exp, _) -> + sub.expr sub exp + | Texp_new (_, lid, _) -> iter_loc sub lid + | Texp_instvar (_, _, s) -> iter_loc sub s + | Texp_setinstvar (_, _, s, exp) -> + iter_loc sub s; + sub.expr sub exp + | Texp_override (_, list) -> + List.iter (fun (_, s, e) -> iter_loc sub s; sub.expr sub e) list + | Texp_letmodule (_, s, _, mexpr, exp) -> + iter_loc sub s; + sub.module_expr sub mexpr; + sub.expr sub exp + | Texp_letexception (cd, exp) -> + sub.extension_constructor sub cd; + sub.expr sub exp + | Texp_assert (exp, _) -> sub.expr sub exp + | Texp_lazy exp -> sub.expr sub exp + | Texp_object (cl, _) -> sub.class_structure sub cl + | Texp_pack mexpr -> sub.module_expr sub mexpr + | Texp_letop {let_ = l; ands; body; _} -> + sub.binding_op sub l; + List.iter (sub.binding_op sub) ands; + sub.case sub body + | Texp_unreachable -> () + | Texp_extension_constructor (lid, _) -> iter_loc sub lid + | Texp_open (od, e) -> + sub.open_declaration sub od; + sub.expr sub e + | Texp_hole -> () + + +let package_type sub {pack_fields; pack_txt; _} = + List.iter (fun (lid, p) -> iter_loc sub lid; sub.typ sub p) pack_fields; + iter_loc sub pack_txt + +let binding_op sub {bop_loc; bop_op_name; bop_exp; _} = + sub.location sub bop_loc; + iter_loc sub bop_op_name; + sub.expr sub bop_exp + +let signature sub {sig_items; sig_final_env; _} = + sub.env sub sig_final_env; + List.iter (sub.signature_item sub) sig_items + +let signature_item sub {sig_loc; sig_desc; sig_env; _} = + sub.location sub sig_loc; + sub.env sub sig_env; + match sig_desc with + | Tsig_value v -> sub.value_description sub v + | Tsig_type (rf, tdl) -> sub.type_declarations sub (rf, tdl) + | Tsig_typesubst list -> sub.type_declarations sub (Nonrecursive, list) + | Tsig_typext te -> sub.type_extension sub te + | Tsig_exception ext -> sub.type_exception sub ext + | Tsig_module x -> sub.module_declaration sub x + | Tsig_modsubst x -> sub.module_substitution sub x + | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list + | Tsig_modtype x -> sub.module_type_declaration sub x + | Tsig_modtypesubst x -> sub.module_type_declaration sub x + | Tsig_include incl -> include_infos sub (sub.module_type sub) incl + | Tsig_class list -> List.iter (sub.class_description sub) list + | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list + | Tsig_open od -> sub.open_description sub od + | Tsig_attribute _ -> () + +let class_description sub x = + class_infos sub (sub.class_type sub) x + +let functor_parameter sub = function + | Unit -> () + | Named (_, s, mtype) -> iter_loc sub s; sub.module_type sub mtype + +let module_type sub {mty_loc; mty_desc; mty_env; mty_attributes; _} = + sub.location sub mty_loc; + sub.attributes sub mty_attributes; + sub.env sub mty_env; + match mty_desc with + | Tmty_ident (_, lid) -> iter_loc sub lid + | Tmty_alias (_, lid) -> iter_loc sub lid + | Tmty_signature sg -> sub.signature sub sg + | Tmty_functor (arg, mtype2) -> + functor_parameter sub arg; + sub.module_type sub mtype2 + | Tmty_with (mtype, list) -> + sub.module_type sub mtype; + List.iter (fun (_, lid, e) -> + iter_loc sub lid; sub.with_constraint sub e) list + | Tmty_typeof mexpr -> sub.module_expr sub mexpr + +let with_constraint sub = function + | Twith_type decl -> sub.type_declaration sub decl + | Twith_typesubst decl -> sub.type_declaration sub decl + | Twith_module (_, lid) -> iter_loc sub lid + | Twith_modsubst (_, lid) -> iter_loc sub lid + | Twith_modtype mty -> sub.module_type sub mty + | Twith_modtypesubst mty -> sub.module_type sub mty + + +let open_description sub {open_loc; open_expr; open_env; open_attributes; _} = + sub.location sub open_loc; + sub.attributes sub open_attributes; + iter_snd (iter_loc sub) open_expr; + sub.env sub open_env + +let open_declaration sub {open_loc; open_expr; open_env; open_attributes; _} = + sub.location sub open_loc; + sub.attributes sub open_attributes; + sub.module_expr sub open_expr; + sub.env sub open_env + +let module_coercion sub = function + | Tcoerce_none -> () + | Tcoerce_functor (c1,c2) -> + sub.module_coercion sub c1; + sub.module_coercion sub c2 + | Tcoerce_alias (env, _, c1) -> + sub.env sub env; + sub.module_coercion sub c1 + | Tcoerce_structure (l1, l2) -> + List.iter (fun (_, c) -> sub.module_coercion sub c) l1; + List.iter (fun (_, _ ,c) -> sub.module_coercion sub c) l2 + | Tcoerce_primitive {pc_loc; pc_env; _} -> + sub.location sub pc_loc; + sub.env sub pc_env + +let module_expr sub {mod_loc; mod_desc; mod_env; mod_attributes; _} = + sub.location sub mod_loc; + sub.attributes sub mod_attributes; + sub.env sub mod_env; + match mod_desc with + | Tmod_hole -> () + | Tmod_ident (_, lid) -> iter_loc sub lid + | Tmod_structure st -> sub.structure sub st + | Tmod_functor (arg, mexpr) -> + functor_parameter sub arg; + sub.module_expr sub mexpr + | Tmod_apply (mexp1, mexp2, c) -> + sub.module_expr sub mexp1; + sub.module_expr sub mexp2; + sub.module_coercion sub c + | Tmod_apply_unit mexp1 -> + sub.module_expr sub mexp1; + | Tmod_constraint (mexpr, _, Tmodtype_implicit, c) -> + sub.module_expr sub mexpr; + sub.module_coercion sub c + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, c) -> + sub.module_expr sub mexpr; + sub.module_type sub mtype; + sub.module_coercion sub c + | Tmod_unpack (exp, _) -> sub.expr sub exp + +let module_binding sub {mb_loc; mb_name; mb_expr; mb_attributes; _} = + sub.location sub mb_loc; + sub.attributes sub mb_attributes; + iter_loc sub mb_name; + sub.module_expr sub mb_expr + +let class_expr sub {cl_loc; cl_desc; cl_env; cl_attributes; _} = + sub.location sub cl_loc; + sub.attributes sub cl_attributes; + sub.env sub cl_env; + match cl_desc with + | Tcl_constraint (cl, clty, _, _, _) -> + sub.class_expr sub cl; + Option.iter (sub.class_type sub) clty + | Tcl_structure clstr -> sub.class_structure sub clstr + | Tcl_fun (_, pat, priv, cl, _) -> + sub.pat sub pat; + List.iter (fun (_, e) -> sub.expr sub e) priv; + sub.class_expr sub cl + | Tcl_apply (cl, args) -> + sub.class_expr sub cl; + List.iter (fun (_, e) -> Option.iter (sub.expr sub) e) args + | Tcl_let (rec_flag, value_bindings, ivars, cl) -> + sub.value_bindings sub (rec_flag, value_bindings); + List.iter (fun (_, e) -> sub.expr sub e) ivars; + sub.class_expr sub cl + | Tcl_ident (_, lid, tyl) -> + iter_loc sub lid; + List.iter (sub.typ sub) tyl + | Tcl_open (od, e) -> + sub.open_description sub od; + sub.class_expr sub e + +let class_type sub {cltyp_loc; cltyp_desc; cltyp_env; cltyp_attributes; _} = + sub.location sub cltyp_loc; + sub.attributes sub cltyp_attributes; + sub.env sub cltyp_env; + match cltyp_desc with + | Tcty_signature csg -> sub.class_signature sub csg + | Tcty_constr (_, lid, list) -> + iter_loc sub lid; + List.iter (sub.typ sub) list + | Tcty_arrow (_, ct, cl) -> + sub.typ sub ct; + sub.class_type sub cl + | Tcty_open (od, e) -> + sub.open_description sub od; + sub.class_type sub e + +let class_signature sub {csig_self; csig_fields; _} = + sub.typ sub csig_self; + List.iter (sub.class_type_field sub) csig_fields + +let class_type_field sub {ctf_loc; ctf_desc; ctf_attributes; _} = + sub.location sub ctf_loc; + sub.attributes sub ctf_attributes; + match ctf_desc with + | Tctf_inherit ct -> sub.class_type sub ct + | Tctf_val (_, _, _, ct) -> sub.typ sub ct + | Tctf_method (_, _, _, ct) -> sub.typ sub ct + | Tctf_constraint (ct1, ct2) -> + sub.typ sub ct1; + sub.typ sub ct2 + | Tctf_attribute attr -> sub.attribute sub attr + +let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = + sub.location sub ctyp_loc; + sub.attributes sub ctyp_attributes; + sub.env sub ctyp_env; + match ctyp_desc with + | Ttyp_any -> () + | Ttyp_var _ -> () + | Ttyp_arrow (_, ct1, ct2) -> + sub.typ sub ct1; + sub.typ sub ct2 + | Ttyp_tuple list -> List.iter (sub.typ sub) list + | Ttyp_constr (_, lid, list) -> + iter_loc sub lid; + List.iter (sub.typ sub) list + | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list + | Ttyp_class (_, lid, list) -> + iter_loc sub lid; + List.iter (sub.typ sub) list + | Ttyp_alias (ct, _) -> sub.typ sub ct + | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list + | Ttyp_poly (_, ct) -> sub.typ sub ct + | Ttyp_package pack -> sub.package_type sub pack + +let class_structure sub {cstr_self; cstr_fields; _} = + sub.pat sub cstr_self; + List.iter (sub.class_field sub) cstr_fields + +let row_field sub {rf_loc; rf_desc; rf_attributes; _} = + sub.location sub rf_loc; + sub.attributes sub rf_attributes; + match rf_desc with + | Ttag (s, _, list) -> iter_loc sub s; List.iter (sub.typ sub) list + | Tinherit ct -> sub.typ sub ct + +let object_field sub {of_loc; of_desc; of_attributes; _} = + sub.location sub of_loc; + sub.attributes sub of_attributes; + match of_desc with + | OTtag (s, ct) -> iter_loc sub s; sub.typ sub ct + | OTinherit ct -> sub.typ sub ct + +let class_field_kind sub = function + | Tcfk_virtual ct -> sub.typ sub ct + | Tcfk_concrete (_, e) -> sub.expr sub e + +let class_field sub {cf_loc; cf_desc; cf_attributes; _} = + sub.location sub cf_loc; + sub.attributes sub cf_attributes; + match cf_desc with + | Tcf_inherit (_, cl, _, _, _) -> sub.class_expr sub cl + | Tcf_constraint (cty1, cty2) -> + sub.typ sub cty1; + sub.typ sub cty2 + | Tcf_val (s, _, _, k, _) -> iter_loc sub s; class_field_kind sub k + | Tcf_method (s, _, k) -> iter_loc sub s;class_field_kind sub k + | Tcf_initializer exp -> sub.expr sub exp + | Tcf_attribute attr -> sub.attribute sub attr + +let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list + +let case sub {c_lhs; c_guard; c_rhs} = + sub.pat sub c_lhs; + Option.iter (sub.expr sub) c_guard; + sub.expr sub c_rhs + +let value_binding sub {vb_loc; vb_pat; vb_expr; vb_attributes; _} = + sub.location sub vb_loc; + sub.attributes sub vb_attributes; + sub.pat sub vb_pat; + sub.expr sub vb_expr + +let env _sub _ = () + +let default_iterator = + { + attribute; + attributes; + binding_op; + case; + class_declaration; + class_description; + class_expr; + class_field; + class_signature; + class_structure; + class_type; + class_type_declaration; + class_type_field; + env; + expr; + extension_constructor; + location; + module_binding; + module_coercion; + module_declaration; + module_substitution; + module_expr; + module_type; + module_type_declaration; + package_type; + pat; + row_field; + object_field; + open_declaration; + open_description; + signature; + signature_item; + structure; + structure_item; + typ; + type_declaration; + type_declarations; + type_extension; + type_exception; + type_kind; + value_binding; + value_bindings; + value_description; + with_constraint; + } diff --git a/ocamlmerlin_mlx/ocaml/typing/tast_iterator.mli b/ocamlmerlin_mlx/ocaml/typing/tast_iterator.mli new file mode 100644 index 0000000..96352fc --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/tast_iterator.mli @@ -0,0 +1,71 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Isaac "Izzy" Avram *) +(* *) +(* Copyright 2019 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** +Allows the implementation of typed tree inspection using open recursion +*) + +open Asttypes +open Typedtree + +type iterator = + { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attributes -> unit; + binding_op: iterator -> binding_op -> unit; + case: 'k . iterator -> 'k case -> unit; + class_declaration: iterator -> class_declaration -> unit; + class_description: iterator -> class_description -> unit; + class_expr: iterator -> class_expr -> unit; + class_field: iterator -> class_field -> unit; + class_signature: iterator -> class_signature -> unit; + class_structure: iterator -> class_structure -> unit; + class_type: iterator -> class_type -> unit; + class_type_declaration: iterator -> class_type_declaration -> unit; + class_type_field: iterator -> class_type_field -> unit; + env: iterator -> Env.t -> unit; + expr: iterator -> expression -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_coercion: iterator -> module_coercion -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_substitution: iterator -> module_substitution -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + package_type: iterator -> package_type -> unit; + pat: 'k . iterator -> 'k general_pattern -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + open_declaration: iterator -> open_declaration -> unit; + open_description: iterator -> open_description -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_declarations: iterator -> (rec_flag * type_declaration list) -> unit; + type_extension: iterator -> type_extension -> unit; + type_exception: iterator -> type_exception -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> (rec_flag * value_binding list) -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; + } + +val default_iterator: iterator diff --git a/ocamlmerlin_mlx/ocaml/typing/tast_mapper.ml b/ocamlmerlin_mlx/ocaml/typing/tast_mapper.ml new file mode 100644 index 0000000..500c07c --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/tast_mapper.ml @@ -0,0 +1,878 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +(* TODO: add 'methods' for extension, + include_declaration, include_description *) + +type mapper = + { + attribute : mapper -> attribute -> attribute; + attributes : mapper -> attributes -> attributes; + binding_op: mapper -> binding_op -> binding_op; + case: 'k . mapper -> 'k case -> 'k case; + class_declaration: mapper -> class_declaration -> class_declaration; + class_description: mapper -> class_description -> class_description; + class_expr: mapper -> class_expr -> class_expr; + class_field: mapper -> class_field -> class_field; + class_signature: mapper -> class_signature -> class_signature; + class_structure: mapper -> class_structure -> class_structure; + class_type: mapper -> class_type -> class_type; + class_type_declaration: mapper -> class_type_declaration -> + class_type_declaration; + class_type_field: mapper -> class_type_field -> class_type_field; + env: mapper -> Env.t -> Env.t; + expr: mapper -> expression -> expression; + extension_constructor: mapper -> extension_constructor -> + extension_constructor; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> module_binding; + module_coercion: mapper -> module_coercion -> module_coercion; + module_declaration: mapper -> module_declaration -> module_declaration; + module_substitution: mapper -> module_substitution -> module_substitution; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; + package_type: mapper -> package_type -> package_type; + pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern; + row_field: mapper -> row_field -> row_field; + object_field: mapper -> object_field -> object_field; + open_declaration: mapper -> open_declaration -> open_declaration; + open_description: mapper -> open_description -> open_description; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_declarations: mapper -> (rec_flag * type_declaration list) + -> (rec_flag * type_declaration list); + type_extension: mapper -> type_extension -> type_extension; + type_exception: mapper -> type_exception -> type_exception; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_bindings: mapper -> (rec_flag * value_binding list) -> + (rec_flag * value_binding list); + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; + } + +let id x = x +let tuple2 f1 f2 (x, y) = (f1 x, f2 y) +let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let map_loc sub {loc; txt} = {loc=sub.location sub loc; txt} + +let location _sub l = l + +let attribute sub x = + let mapper = { + Ast_mapper.default_mapper + with location = fun _this x -> sub.location sub x + } in + Parsetree.{ + attr_name = map_loc sub x.attr_name; + attr_payload = mapper.payload mapper x.attr_payload; + attr_loc = sub.location sub x.attr_loc + } + +let attributes sub l = List.map (attribute sub) l + +let structure sub {str_items; str_type; str_final_env} = + { + str_items = List.map (sub.structure_item sub) str_items; + str_final_env = sub.env sub str_final_env; + str_type; + } + +let class_infos sub f x = + {x with + ci_loc = sub.location sub x.ci_loc; + ci_id_name = map_loc sub x.ci_id_name; + ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params; + ci_expr = f x.ci_expr; + ci_attributes = sub.attributes sub x.ci_attributes; + } + +let module_type_declaration sub x = + let mtd_loc = sub.location sub x.mtd_loc in + let mtd_name = map_loc sub x.mtd_name in + let mtd_type = Option.map (sub.module_type sub) x.mtd_type in + let mtd_attributes = sub.attributes sub x.mtd_attributes in + {x with mtd_loc; mtd_name; mtd_type; mtd_attributes} + +let module_declaration sub x = + let md_loc = sub.location sub x.md_loc in + let md_name = map_loc sub x.md_name in + let md_type = sub.module_type sub x.md_type in + let md_attributes = sub.attributes sub x.md_attributes in + {x with md_loc; md_name; md_type; md_attributes} + +let module_substitution sub x = + let ms_loc = sub.location sub x.ms_loc in + let ms_name = map_loc sub x.ms_name in + let ms_txt = map_loc sub x.ms_txt in + let ms_attributes = sub.attributes sub x.ms_attributes in + {x with ms_loc; ms_name; ms_txt; ms_attributes} + +let include_infos sub f x = + let incl_loc = sub.location sub x.incl_loc in + let incl_attributes = sub.attributes sub x.incl_attributes in + {x with incl_loc; incl_attributes; incl_mod = f x.incl_mod} + +let class_type_declaration sub x = + class_infos sub (sub.class_type sub) x + +let class_declaration sub x = + class_infos sub (sub.class_expr sub) x + +let structure_item sub {str_loc; str_desc; str_env} = + let str_loc = sub.location sub str_loc in + let str_env = sub.env sub str_env in + let str_desc = + match str_desc with + | Tstr_eval (exp, attrs) -> + Tstr_eval (sub.expr sub exp, sub.attributes sub attrs) + | Tstr_value (rec_flag, list) -> + let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in + Tstr_value (rec_flag, list) + | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v) + | Tstr_type (rec_flag, list) -> + let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in + Tstr_type (rec_flag, list) + | Tstr_typext te -> Tstr_typext (sub.type_extension sub te) + | Tstr_exception ext -> Tstr_exception (sub.type_exception sub ext) + | Tstr_module mb -> Tstr_module (sub.module_binding sub mb) + | Tstr_recmodule list -> + Tstr_recmodule (List.map (sub.module_binding sub) list) + | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x) + | Tstr_class list -> + Tstr_class + (List.map (tuple2 (sub.class_declaration sub) id) list) + | Tstr_class_type list -> + Tstr_class_type + (List.map (tuple3 + id (map_loc sub) (sub.class_type_declaration sub)) list) + | Tstr_include incl -> + Tstr_include (include_infos sub (sub.module_expr sub) incl) + | Tstr_open od -> Tstr_open (sub.open_declaration sub od) + | Tstr_attribute attr -> Tstr_attribute (sub.attribute sub attr) + in + {str_desc; str_env; str_loc} + +let value_description sub x = + let val_loc = sub.location sub x.val_loc in + let val_name = map_loc sub x.val_name in + let val_desc = sub.typ sub x.val_desc in + let val_attributes = sub.attributes sub x.val_attributes in + {x with val_loc; val_name; val_desc; val_attributes} + +let label_decl sub x = + let ld_loc = sub.location sub x.ld_loc in + let ld_name = map_loc sub x.ld_name in + let ld_type = sub.typ sub x.ld_type in + let ld_attributes = sub.attributes sub x.ld_attributes in + {x with ld_loc; ld_name; ld_type; ld_attributes} + +let constructor_args sub = function + | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l) + | Cstr_record l -> Cstr_record (List.map (label_decl sub) l) + +let constructor_decl sub cd = + let cd_loc = sub.location sub cd.cd_loc in + let cd_name = map_loc sub cd.cd_name in + let cd_vars = List.map (map_loc sub) cd.cd_vars in + let cd_args = constructor_args sub cd.cd_args in + let cd_res = Option.map (sub.typ sub) cd.cd_res in + let cd_attributes = sub.attributes sub cd.cd_attributes in + {cd with cd_loc; cd_name; cd_vars; cd_args; cd_res; cd_attributes} + +let type_kind sub = function + | Ttype_abstract -> Ttype_abstract + | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list) + | Ttype_record list -> Ttype_record (List.map (label_decl sub) list) + | Ttype_open -> Ttype_open + +let type_declaration sub x = + let typ_loc = sub.location sub x.typ_loc in + let typ_name = map_loc sub x.typ_name in + let typ_cstrs = + List.map + (tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + x.typ_cstrs + in + let typ_kind = sub.type_kind sub x.typ_kind in + let typ_manifest = Option.map (sub.typ sub) x.typ_manifest in + let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in + let typ_attributes = sub.attributes sub x.typ_attributes in + {x with typ_loc; typ_name; typ_cstrs; typ_kind; typ_manifest; typ_params; + typ_attributes} + +let type_declarations sub (rec_flag, list) = + (rec_flag, List.map (sub.type_declaration sub) list) + +let type_extension sub x = + let tyext_loc = sub.location sub x.tyext_loc in + let tyext_txt = map_loc sub x.tyext_txt in + let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in + let tyext_constructors = + List.map (sub.extension_constructor sub) x.tyext_constructors + in + let tyext_attributes = sub.attributes sub x.tyext_attributes in + {x with tyext_loc; tyext_txt; tyext_constructors; tyext_params; + tyext_attributes} + +let type_exception sub x = + let tyexn_loc = sub.location sub x.tyexn_loc in + let tyexn_constructor = + sub.extension_constructor sub x.tyexn_constructor + in + let tyexn_attributes = sub.attributes sub x.tyexn_attributes in + {tyexn_loc; tyexn_constructor; tyexn_attributes} + +let extension_constructor sub x = + let ext_loc = sub.location sub x.ext_loc in + let ext_name = map_loc sub x.ext_name in + let ext_kind = + match x.ext_kind with + Text_decl(ids, ctl, cto) -> + Text_decl( + List.map (map_loc sub) ids, + constructor_args sub ctl, + Option.map (sub.typ sub) cto + ) + | Text_rebind (path, lid) -> + Text_rebind (path, map_loc sub lid) + in + let ext_attributes = sub.attributes sub x.ext_attributes in + {x with ext_loc; ext_name; ext_kind; ext_attributes} + +let pat_extra sub = function + | Tpat_unpack as d -> d + | Tpat_type (path,loc) -> Tpat_type (path, map_loc sub loc) + | Tpat_open (path,loc,env) -> + Tpat_open (path, map_loc sub loc, sub.env sub env) + | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct) + +let pat + : type k . mapper -> k general_pattern -> k general_pattern + = fun sub x -> + let pat_loc = sub.location sub x.pat_loc in + let pat_env = sub.env sub x.pat_env in + let pat_extra = + List.map (tuple3 (pat_extra sub) id (sub.attributes sub)) x.pat_extra in + let pat_desc : k pattern_desc = + match x.pat_desc with + | Tpat_any + | Tpat_constant _ -> x.pat_desc + | Tpat_var (id, s) -> Tpat_var (id, map_loc sub s) + | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) + | Tpat_construct (loc, cd, l, vto) -> + let vto = Option.map (fun (vl,cty) -> + List.map (map_loc sub) vl, sub.typ sub cty) vto in + Tpat_construct (map_loc sub loc, cd, List.map (sub.pat sub) l, vto) + | Tpat_variant (l, po, rd) -> + Tpat_variant (l, Option.map (sub.pat sub) po, rd) + | Tpat_record (l, closed) -> + Tpat_record (List.map (tuple3 (map_loc sub) id (sub.pat sub)) l, closed) + | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) + | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, map_loc sub s) + | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) + | Tpat_value p -> + (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc + | Tpat_exception p -> + Tpat_exception (sub.pat sub p) + | Tpat_or (p1, p2, rd) -> + Tpat_or (sub.pat sub p1, sub.pat sub p2, rd) + in + let pat_attributes = sub.attributes sub x.pat_attributes in + {x with pat_loc; pat_extra; pat_desc; pat_env; pat_attributes} + +let expr sub x = + let extra = function + | Texp_constraint cty -> + Texp_constraint (sub.typ sub cty) + | Texp_coerce (cty1, cty2) -> + Texp_coerce (Option.map (sub.typ sub) cty1, sub.typ sub cty2) + | Texp_newtype _ as d -> d + | Texp_newtype' _ as d -> d + | Texp_poly cto -> Texp_poly (Option.map (sub.typ sub) cto) + in + let exp_loc = sub.location sub x.exp_loc in + let exp_extra = List.map (tuple3 extra (sub.location sub) id) x.exp_extra in + let exp_env = sub.env sub x.exp_env in + let exp_desc = + match x.exp_desc with + | Texp_ident (path, lid, vd) -> + Texp_ident (path, map_loc sub lid, vd) + | Texp_constant _ as d -> d + | Texp_let (rec_flag, list, exp) -> + let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in + Texp_let (rec_flag, list, sub.expr sub exp) + | Texp_function { arg_label; param; cases; partial; } -> + let cases = List.map (sub.case sub) cases in + Texp_function { arg_label; param; cases; partial; } + | Texp_apply (exp, list) -> + Texp_apply ( + sub.expr sub exp, + List.map (tuple2 id (Option.map (sub.expr sub))) list + ) + | Texp_match (exp, cases, p) -> + Texp_match ( + sub.expr sub exp, + List.map (sub.case sub) cases, + p + ) + | Texp_try (exp, cases) -> + Texp_try ( + sub.expr sub exp, + List.map (sub.case sub) cases + ) + | Texp_tuple list -> + Texp_tuple (List.map (sub.expr sub) list) + | Texp_construct (lid, cd, args) -> + Texp_construct (map_loc sub lid, cd, List.map (sub.expr sub) args) + | Texp_variant (l, expo) -> + Texp_variant (l, Option.map (sub.expr sub) expo) + | Texp_record { fields; representation; extended_expression } -> + let fields = Array.map (function + | label, Kept (t, mut) -> label, Kept (t, mut) + | label, Overridden (lid, exp) -> + label, Overridden (map_loc sub lid, sub.expr sub exp)) + fields + in + Texp_record { + fields; representation; + extended_expression = Option.map (sub.expr sub) extended_expression; + } + | Texp_field (exp, lid, ld) -> + Texp_field (sub.expr sub exp, map_loc sub lid, ld) + | Texp_setfield (exp1, lid, ld, exp2) -> + Texp_setfield ( + sub.expr sub exp1, + map_loc sub lid, + ld, + sub.expr sub exp2 + ) + | Texp_array list -> + Texp_array (List.map (sub.expr sub) list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Texp_ifthenelse ( + sub.expr sub exp1, + sub.expr sub exp2, + Option.map (sub.expr sub) expo + ) + | Texp_sequence (exp1, exp2) -> + Texp_sequence ( + sub.expr sub exp1, + sub.expr sub exp2 + ) + | Texp_while (exp1, exp2) -> + Texp_while ( + sub.expr sub exp1, + sub.expr sub exp2 + ) + | Texp_for (id, p, exp1, exp2, dir, exp3) -> + Texp_for ( + id, + p, + sub.expr sub exp1, + sub.expr sub exp2, + dir, + sub.expr sub exp3 + ) + | Texp_send (exp, meth) -> + Texp_send + ( + sub.expr sub exp, + meth + ) + | Texp_new (path, lid, cd) -> + Texp_new ( + path, + map_loc sub lid, + cd + ) + | Texp_instvar (path1, path2, id) -> + Texp_instvar ( + path1, + path2, + map_loc sub id + ) + | Texp_setinstvar (path1, path2, id, exp) -> + Texp_setinstvar ( + path1, + path2, + map_loc sub id, + sub.expr sub exp + ) + | Texp_override (path, list) -> + Texp_override ( + path, + List.map (tuple3 id (map_loc sub) (sub.expr sub)) list + ) + | Texp_letmodule (id, s, pres, mexpr, exp) -> + Texp_letmodule ( + id, + map_loc sub s, + pres, + sub.module_expr sub mexpr, + sub.expr sub exp + ) + | Texp_letexception (cd, exp) -> + Texp_letexception ( + sub.extension_constructor sub cd, + sub.expr sub exp + ) + | Texp_assert (exp, loc) -> + Texp_assert (sub.expr sub exp, loc) + | Texp_lazy exp -> + Texp_lazy (sub.expr sub exp) + | Texp_object (cl, sl) -> + Texp_object (sub.class_structure sub cl, sl) + | Texp_pack mexpr -> + Texp_pack (sub.module_expr sub mexpr) + | Texp_letop {let_; ands; param; body; partial} -> + Texp_letop{ + let_ = sub.binding_op sub let_; + ands = List.map (sub.binding_op sub) ands; + param; + body = sub.case sub body; + partial; + } + | Texp_unreachable -> + Texp_unreachable + | Texp_extension_constructor (lid, path) -> + Texp_extension_constructor (map_loc sub lid, path) + | Texp_open (od, e) -> + Texp_open (sub.open_declaration sub od, sub.expr sub e) + | Texp_hole -> + Texp_hole + in + let exp_attributes = sub.attributes sub x.exp_attributes in + {x with exp_loc; exp_extra; exp_desc; exp_env; exp_attributes} + + +let package_type sub x = + let pack_txt = map_loc sub x.pack_txt in + let pack_fields = List.map + (tuple2 (map_loc sub) (sub.typ sub)) x.pack_fields in + {x with pack_txt; pack_fields} + +let binding_op sub x = + let bop_loc = sub.location sub x.bop_loc in + let bop_op_name = map_loc sub x.bop_op_name in + { x with bop_loc; bop_op_name; bop_exp = sub.expr sub x.bop_exp } + +let signature sub x = + let sig_final_env = sub.env sub x.sig_final_env in + let sig_items = List.map (sub.signature_item sub) x.sig_items in + {x with sig_items; sig_final_env} + +let signature_item sub x = + let sig_loc = sub.location sub x.sig_loc in + let sig_env = sub.env sub x.sig_env in + let sig_desc = + match x.sig_desc with + | Tsig_value v -> + Tsig_value (sub.value_description sub v) + | Tsig_type (rec_flag, list) -> + let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in + Tsig_type (rec_flag, list) + | Tsig_typesubst list -> + let (_, list) = sub.type_declarations sub (Nonrecursive, list) in + Tsig_typesubst list + | Tsig_typext te -> + Tsig_typext (sub.type_extension sub te) + | Tsig_exception ext -> + Tsig_exception (sub.type_exception sub ext) + | Tsig_module x -> + Tsig_module (sub.module_declaration sub x) + | Tsig_modsubst x -> + Tsig_modsubst (sub.module_substitution sub x) + | Tsig_recmodule list -> + Tsig_recmodule (List.map (sub.module_declaration sub) list) + | Tsig_modtype x -> + Tsig_modtype (sub.module_type_declaration sub x) + | Tsig_modtypesubst x -> + Tsig_modtypesubst (sub.module_type_declaration sub x) + | Tsig_include incl -> + Tsig_include (include_infos sub (sub.module_type sub) incl) + | Tsig_class list -> + Tsig_class (List.map (sub.class_description sub) list) + | Tsig_class_type list -> + Tsig_class_type + (List.map (sub.class_type_declaration sub) list) + | Tsig_open od -> Tsig_open (sub.open_description sub od) + | Tsig_attribute attr -> Tsig_attribute (sub.attribute sub attr) + in + {sig_loc; sig_desc; sig_env} + +let class_description sub x = + class_infos sub (sub.class_type sub) x + +let functor_parameter sub = function + | Unit -> Unit + | Named (id, s, mtype) -> Named (id, map_loc sub s, sub.module_type sub mtype) + +let module_type sub x = + let mty_loc = sub.location sub x.mty_loc in + let mty_env = sub.env sub x.mty_env in + let mty_desc = + match x.mty_desc with + | Tmty_ident (path, lid) -> Tmty_ident (path, map_loc sub lid) + | Tmty_alias (path, lid) -> Tmty_alias (path, map_loc sub lid) + | Tmty_signature sg -> Tmty_signature (sub.signature sub sg) + | Tmty_functor (arg, mtype2) -> + Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2) + | Tmty_with (mtype, list) -> + Tmty_with ( + sub.module_type sub mtype, + List.map (tuple3 id (map_loc sub) (sub.with_constraint sub)) list + ) + | Tmty_typeof mexpr -> + Tmty_typeof (sub.module_expr sub mexpr) + in + let mty_attributes = sub.attributes sub x.mty_attributes in + {x with mty_loc; mty_desc; mty_env; mty_attributes} + +let with_constraint sub = function + | Twith_type decl -> Twith_type (sub.type_declaration sub decl) + | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl) + | Twith_modtype mty -> Twith_modtype (sub.module_type sub mty) + | Twith_modtypesubst mty -> Twith_modtypesubst (sub.module_type sub mty) + | Twith_module (path, lid) -> Twith_module (path, map_loc sub lid) + | Twith_modsubst (path, lid) -> Twith_modsubst (path, map_loc sub lid) + +let open_description sub od = + {od with open_loc = sub.location sub od.open_loc; + open_expr = tuple2 id (map_loc sub) od.open_expr; + open_env = sub.env sub od.open_env; + open_attributes = sub.attributes sub od.open_attributes} + +let open_declaration sub od = + {od with open_loc = sub.location sub od.open_loc; + open_expr = sub.module_expr sub od.open_expr; + open_env = sub.env sub od.open_env; + open_attributes = sub.attributes sub od.open_attributes} + +let module_coercion sub = function + | Tcoerce_none -> Tcoerce_none + | Tcoerce_functor (c1,c2) -> + Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2) + | Tcoerce_alias (env, p, c1) -> + Tcoerce_alias (sub.env sub env, p, sub.module_coercion sub c1) + | Tcoerce_structure (l1, l2) -> + let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in + let l2' = + List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2 + in + Tcoerce_structure (l1', l2') + | Tcoerce_primitive pc -> + Tcoerce_primitive {pc with pc_loc = sub.location sub pc.pc_loc; + pc_env = sub.env sub pc.pc_env} + +let module_expr sub x = + let mod_loc = sub.location sub x.mod_loc in + let mod_env = sub.env sub x.mod_env in + let mod_desc = + match x.mod_desc with + | Tmod_ident (path, lid) -> Tmod_ident (path, map_loc sub lid) + | Tmod_hole -> Tmod_hole + | Tmod_structure st -> Tmod_structure (sub.structure sub st) + | Tmod_functor (arg, mexpr) -> + Tmod_functor (functor_parameter sub arg, sub.module_expr sub mexpr) + | Tmod_apply (mexp1, mexp2, c) -> + Tmod_apply ( + sub.module_expr sub mexp1, + sub.module_expr sub mexp2, + sub.module_coercion sub c + ) + | Tmod_apply_unit mexp1 -> + Tmod_apply_unit (sub.module_expr sub mexp1) + | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) -> + Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit, + sub.module_coercion sub c) + | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) -> + Tmod_constraint ( + sub.module_expr sub mexpr, + mt, + Tmodtype_explicit (sub.module_type sub mtype), + sub.module_coercion sub c + ) + | Tmod_unpack (exp, mty) -> + Tmod_unpack + ( + sub.expr sub exp, + mty + ) + in + let mod_attributes = sub.attributes sub x.mod_attributes in + {x with mod_loc; mod_desc; mod_env; mod_attributes} + +let module_binding sub x = + let mb_loc = sub.location sub x.mb_loc in + let mb_name = map_loc sub x.mb_name in + let mb_expr = sub.module_expr sub x.mb_expr in + let mb_attributes = sub.attributes sub x.mb_attributes in + {x with mb_loc; mb_name; mb_expr; mb_attributes} + +let class_expr sub x = + let cl_loc = sub.location sub x.cl_loc in + let cl_env = sub.env sub x.cl_env in + let cl_desc = + match x.cl_desc with + | Tcl_constraint (cl, clty, vals, meths, concrs) -> + Tcl_constraint ( + sub.class_expr sub cl, + Option.map (sub.class_type sub) clty, + vals, + meths, + concrs + ) + | Tcl_structure clstr -> + Tcl_structure (sub.class_structure sub clstr) + | Tcl_fun (label, pat, priv, cl, partial) -> + Tcl_fun ( + label, + sub.pat sub pat, + List.map (tuple2 id (sub.expr sub)) priv, + sub.class_expr sub cl, + partial + ) + | Tcl_apply (cl, args) -> + Tcl_apply ( + sub.class_expr sub cl, + List.map (tuple2 id (Option.map (sub.expr sub))) args + ) + | Tcl_let (rec_flag, value_bindings, ivars, cl) -> + let (rec_flag, value_bindings) = + sub.value_bindings sub (rec_flag, value_bindings) + in + Tcl_let ( + rec_flag, + value_bindings, + List.map (tuple2 id (sub.expr sub)) ivars, + sub.class_expr sub cl + ) + | Tcl_ident (path, lid, tyl) -> + Tcl_ident (path, map_loc sub lid, List.map (sub.typ sub) tyl) + | Tcl_open (od, e) -> + Tcl_open (sub.open_description sub od, sub.class_expr sub e) + in + let cl_attributes = sub.attributes sub x.cl_attributes in + {x with cl_loc; cl_desc; cl_env; cl_attributes} + +let class_type sub x = + let cltyp_loc = sub.location sub x.cltyp_loc in + let cltyp_env = sub.env sub x.cltyp_env in + let cltyp_desc = + match x.cltyp_desc with + | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg) + | Tcty_constr (path, lid, list) -> + Tcty_constr ( + path, + map_loc sub lid, + List.map (sub.typ sub) list + ) + | Tcty_arrow (label, ct, cl) -> + Tcty_arrow + (label, + sub.typ sub ct, + sub.class_type sub cl + ) + | Tcty_open (od, e) -> + Tcty_open (sub.open_description sub od, sub.class_type sub e) + in + let cltyp_attributes = sub.attributes sub x.cltyp_attributes in + {x with cltyp_loc; cltyp_desc; cltyp_env; cltyp_attributes} + +let class_signature sub x = + let csig_self = sub.typ sub x.csig_self in + let csig_fields = List.map (sub.class_type_field sub) x.csig_fields in + {x with csig_self; csig_fields} + +let class_type_field sub x = + let ctf_loc = sub.location sub x.ctf_loc in + let ctf_desc = + match x.ctf_desc with + | Tctf_inherit ct -> + Tctf_inherit (sub.class_type sub ct) + | Tctf_val (s, mut, virt, ct) -> + Tctf_val (s, mut, virt, sub.typ sub ct) + | Tctf_method (s, priv, virt, ct) -> + Tctf_method (s, priv, virt, sub.typ sub ct) + | Tctf_constraint (ct1, ct2) -> + Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2) + | Tctf_attribute attr -> + Tctf_attribute (sub.attribute sub attr) + in + let ctf_attributes = sub.attributes sub x.ctf_attributes in + {ctf_loc; ctf_desc; ctf_attributes} + +let typ sub x = + let ctyp_loc = sub.location sub x.ctyp_loc in + let ctyp_env = sub.env sub x.ctyp_env in + let ctyp_desc = + match x.ctyp_desc with + | Ttyp_any + | Ttyp_var _ as d -> d + | Ttyp_arrow (label, ct1, ct2) -> + Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list) + | Ttyp_constr (path, lid, list) -> + Ttyp_constr (path, map_loc sub lid, List.map (sub.typ sub) list) + | Ttyp_object (list, closed) -> + Ttyp_object ((List.map (sub.object_field sub) list), closed) + | Ttyp_class (path, lid, list) -> + Ttyp_class + (path, + map_loc sub lid, + List.map (sub.typ sub) list + ) + | Ttyp_alias (ct, s) -> + Ttyp_alias (sub.typ sub ct, s) + | Ttyp_variant (list, closed, labels) -> + Ttyp_variant (List.map (sub.row_field sub) list, closed, labels) + | Ttyp_poly (sl, ct) -> + Ttyp_poly (sl, sub.typ sub ct) + | Ttyp_package pack -> + Ttyp_package (sub.package_type sub pack) + in + let ctyp_attributes = sub.attributes sub x.ctyp_attributes in + {x with ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes} + +let class_structure sub x = + let cstr_self = sub.pat sub x.cstr_self in + let cstr_fields = List.map (sub.class_field sub) x.cstr_fields in + {x with cstr_self; cstr_fields} + +let row_field sub x = + let rf_loc = sub.location sub x.rf_loc in + let rf_desc = match x.rf_desc with + | Ttag (label, b, list) -> + Ttag (map_loc sub label, b, List.map (sub.typ sub) list) + | Tinherit ct -> Tinherit (sub.typ sub ct) + in + let rf_attributes = sub.attributes sub x.rf_attributes in + {rf_loc; rf_desc; rf_attributes} + +let object_field sub x = + let of_loc = sub.location sub x.of_loc in + let of_desc = match x.of_desc with + | OTtag (label, ct) -> + OTtag (map_loc sub label, (sub.typ sub ct)) + | OTinherit ct -> OTinherit (sub.typ sub ct) + in + let of_attributes = sub.attributes sub x.of_attributes in + {of_loc; of_desc; of_attributes} + +let class_field_kind sub = function + | Tcfk_virtual ct -> Tcfk_virtual (sub.typ sub ct) + | Tcfk_concrete (ovf, e) -> Tcfk_concrete (ovf, sub.expr sub e) + +let class_field sub x = + let cf_loc = sub.location sub x.cf_loc in + let cf_desc = + match x.cf_desc with + | Tcf_inherit (ovf, cl, super, vals, meths) -> + Tcf_inherit (ovf, sub.class_expr sub cl, super, vals, meths) + | Tcf_constraint (cty, cty') -> + Tcf_constraint ( + sub.typ sub cty, + sub.typ sub cty' + ) + | Tcf_val (s, mf, id, k, b) -> + Tcf_val (map_loc sub s, mf, id, class_field_kind sub k, b) + | Tcf_method (s, priv, k) -> + Tcf_method (map_loc sub s, priv, class_field_kind sub k) + | Tcf_initializer exp -> + Tcf_initializer (sub.expr sub exp) + | Tcf_attribute attr -> + Tcf_attribute (sub.attribute sub attr) + in + let cf_attributes = sub.attributes sub x.cf_attributes in + {cf_loc; cf_desc; cf_attributes} + +let value_bindings sub (rec_flag, list) = + (rec_flag, List.map (sub.value_binding sub) list) + +let case + : type k . mapper -> k case -> k case + = fun sub {c_lhs; c_guard; c_rhs} -> + { + c_lhs = sub.pat sub c_lhs; + c_guard = Option.map (sub.expr sub) c_guard; + c_rhs = sub.expr sub c_rhs; + } + +let value_binding sub x = + let vb_loc = sub.location sub x.vb_loc in + let vb_pat = sub.pat sub x.vb_pat in + let vb_expr = sub.expr sub x.vb_expr in + let vb_attributes = sub.attributes sub x.vb_attributes in + {vb_loc; vb_pat; vb_expr; vb_attributes} + +let env _sub x = x + +let default = + { + attribute; + attributes; + binding_op; + case; + class_declaration; + class_description; + class_expr; + class_field; + class_signature; + class_structure; + class_type; + class_type_declaration; + class_type_field; + env; + expr; + extension_constructor; + location; + module_binding; + module_coercion; + module_declaration; + module_substitution; + module_expr; + module_type; + module_type_declaration; + package_type; + pat; + row_field; + object_field; + open_declaration; + open_description; + signature; + signature_item; + structure; + structure_item; + typ; + type_declaration; + type_declarations; + type_extension; + type_exception; + type_kind; + value_binding; + value_bindings; + value_description; + with_constraint; + } diff --git a/ocamlmerlin_mlx/ocaml/typing/tast_mapper.mli b/ocamlmerlin_mlx/ocaml/typing/tast_mapper.mli new file mode 100644 index 0000000..f54cef2 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/tast_mapper.mli @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +(** {1 A generic Typedtree mapper} *) + +type mapper = + { + attribute : mapper -> attribute -> attribute; + attributes : mapper -> attributes -> attributes; + binding_op: mapper -> binding_op -> binding_op; + case: 'k . mapper -> 'k case -> 'k case; + class_declaration: mapper -> class_declaration -> class_declaration; + class_description: mapper -> class_description -> class_description; + class_expr: mapper -> class_expr -> class_expr; + class_field: mapper -> class_field -> class_field; + class_signature: mapper -> class_signature -> class_signature; + class_structure: mapper -> class_structure -> class_structure; + class_type: mapper -> class_type -> class_type; + class_type_declaration: mapper -> class_type_declaration -> + class_type_declaration; + class_type_field: mapper -> class_type_field -> class_type_field; + env: mapper -> Env.t -> Env.t; + expr: mapper -> expression -> expression; + extension_constructor: mapper -> extension_constructor -> + extension_constructor; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> module_binding; + module_coercion: mapper -> module_coercion -> module_coercion; + module_declaration: mapper -> module_declaration -> module_declaration; + module_substitution: mapper -> module_substitution -> module_substitution; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; + package_type: mapper -> package_type -> package_type; + pat: 'k . mapper -> 'k general_pattern -> 'k general_pattern; + row_field: mapper -> row_field -> row_field; + object_field: mapper -> object_field -> object_field; + open_declaration: mapper -> open_declaration -> open_declaration; + open_description: mapper -> open_description -> open_description; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_declarations: mapper -> (rec_flag * type_declaration list) + -> (rec_flag * type_declaration list); + type_extension: mapper -> type_extension -> type_extension; + type_exception: mapper -> type_exception -> type_exception; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_bindings: mapper -> (rec_flag * value_binding list) -> + (rec_flag * value_binding list); + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; + } + + +val default: mapper diff --git a/ocamlmerlin_mlx/ocaml/typing/type_immediacy.ml b/ocamlmerlin_mlx/ocaml/typing/type_immediacy.ml new file mode 100644 index 0000000..557ed42 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/type_immediacy.ml @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2019 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + | Unknown + | Always + | Always_on_64bits + +module Violation = struct + type t = + | Not_always_immediate + | Not_always_immediate_on_64bits +end + +let coerce t ~as_ = + match t, as_ with + | _, Unknown + | Always, Always + | (Always | Always_on_64bits), Always_on_64bits -> Ok () + | (Unknown | Always_on_64bits), Always -> + Error Violation.Not_always_immediate + | Unknown, Always_on_64bits -> + Error Violation.Not_always_immediate_on_64bits + +let of_attributes attrs = + match + Builtin_attributes.immediate attrs, + Builtin_attributes.immediate64 attrs + with + | true, _ -> Always + | false, true -> Always_on_64bits + | false, false -> Unknown diff --git a/ocamlmerlin_mlx/ocaml/typing/type_immediacy.mli b/ocamlmerlin_mlx/ocaml/typing/type_immediacy.mli new file mode 100644 index 0000000..3fc2e3b --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/type_immediacy.mli @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2019 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Immediacy status of a type *) + +type t = + | Unknown + (** We don't know anything *) + | Always + (** We know for sure that values of this type are always immediate *) + | Always_on_64bits + (** We know for sure that values of this type are always immediate + on 64 bit platforms. For other platforms, we know nothing. *) + +module Violation : sig + type t = + | Not_always_immediate + | Not_always_immediate_on_64bits +end + +(** [coerce t ~as_] returns [Ok ()] iff [t] can be seen as type + immediacy [as_]. For instance, [Always] can be seen as + [Always_on_64bits] but the opposite is not true. Return [Error _] + if the coercion is not possible. *) +val coerce : t -> as_:t -> (unit, Violation.t) result + +(** Return the immediateness of a type as indicated by the user via + attributes *) +val of_attributes : Parsetree.attributes -> t diff --git a/ocamlmerlin_mlx/ocaml/typing/typeclass.ml b/ocamlmerlin_mlx/ocaml/typing/typeclass.ml new file mode 100644 index 0000000..82b8c55 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typeclass.ml @@ -0,0 +1,2178 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Parsetree +open Asttypes +open Path +open Types +open Typecore +open Typetexp +open Format + +type 'a class_info = { + cls_id : Ident.t; + cls_id_loc : string loc; + cls_decl : class_declaration; + cls_ty_id : Ident.t; + cls_ty_decl : class_type_declaration; + cls_obj_id : Ident.t; + cls_obj_abbr : type_declaration; + cls_abbr : type_declaration; + cls_arity : int; + cls_pub_methods : string list; + cls_info : 'a; +} + +type class_type_info = { + clsty_ty_id : Ident.t; + clsty_id_loc : string loc; + clsty_ty_decl : class_type_declaration; + clsty_obj_id : Ident.t; + clsty_obj_abbr : type_declaration; + clsty_abbr : type_declaration; + clsty_info : Typedtree.class_type_declaration; +} + +type 'a full_class = { + id : Ident.t; + id_loc : tag loc; + clty: class_declaration; + ty_id: Ident.t; + cltydef: class_type_declaration; + obj_id: Ident.t; + obj_abbr: type_declaration; + arity: int; + pub_meths: string list; + coe: Warnings.loc list; + req: 'a Typedtree.class_infos; +} + +type kind = + | Object + | Class + | Class_type + +type final = + | Final + | Not_final + +let kind_of_final = function + | Final -> Object + | Not_final -> Class + +type error = + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string + | Structure_expected of class_type + | Cannot_apply of class_type + | Apply_wrong_label of arg_label + | Pattern_type_clash of type_expr + | Repeated_parameter + | Unbound_class_2 of Longident.t + | Unbound_class_type_2 of Longident.t + | Abbrev_type_clash of type_expr * type_expr * type_expr + | Constructor_type_mismatch of string * Errortrace.unification_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of Errortrace.unification_error + | Bad_parameters of Ident.t * type_expr list * type_expr list + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list + | Class_match_failure of Ctype.class_match_failure list + | Unbound_val of string + | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure + | Non_generalizable_class of + { id : Ident.t + ; clty : Types.class_declaration + ; nongen_vars : type_expr list + } + | Cannot_coerce_self of type_expr + | Non_collapsable_conjunction of + Ident.t * Types.class_declaration * Errortrace.unification_error + | Self_clash of Errortrace.unification_error + | Mutability_mismatch of string * mutable_flag + | No_overriding of string * string + | Duplicate of string * string + | Closing_self_type of class_signature + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +open Typedtree + +let type_open_descr : + (?used_slot:bool ref -> Env.t -> Parsetree.open_description + -> open_description * Env.t) ref = + ref (fun ?used_slot:_ _ -> assert false) + +let ctyp desc typ env loc = + { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; + ctyp_attributes = [] } + +(* + Path associated to the temporary class type of a class being typed + (its constructor is not available). +*) +let unbound_class = + Env.unbound_class + + + (************************************) + (* Some operations on class types *) + (************************************) + +let extract_constraints cty = + let sign = Btype.signature_of_class_type cty in + (Btype.instance_vars sign, + Btype.methods sign, + Btype.concrete_methods sign) + +(* Record a class type *) +let rc node = + Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); + node + +let update_class_signature loc env ~warn_implicit_public virt kind sign = + let implicit_public, implicit_declared = + Ctype.update_class_signature env sign + in + if implicit_declared <> [] then begin + match virt with + | Virtual -> () (* Should perhaps emit warning 17 here *) + | Concrete -> + raise (Error(loc, env, Undeclared_methods(kind, implicit_declared))) + end; + if warn_implicit_public && implicit_public <> [] then begin + Location.prerr_warning + loc (Warnings.Implicit_public_methods implicit_public) + end + +let complete_class_signature loc env virt kind sign = + update_class_signature loc env ~warn_implicit_public:false virt kind sign; + Ctype.hide_private_methods env sign + +let complete_class_type loc env virt kind typ = + let sign = Btype.signature_of_class_type typ in + complete_class_signature loc env virt kind sign + +let check_virtual loc env virt kind sign = + match virt with + | Virtual -> () + | Concrete -> + match Btype.virtual_methods sign, Btype.virtual_instance_vars sign with + | [], [] -> () + | meths, vars -> + raise(Error(loc, env, Virtual_class(kind, meths, vars))) + +let rec check_virtual_clty loc env virt kind clty = + match clty with + | Cty_constr(_, _, clty) | Cty_arrow(_, _, clty) -> + check_virtual_clty loc env virt kind clty + | Cty_signature sign -> + check_virtual loc env virt kind sign + +(* Return the constructor type associated to a class type *) +let rec constructor_type constr cty = + match cty with + Cty_constr (_, _, cty) -> + constructor_type constr cty + | Cty_signature _ -> + constr + | Cty_arrow (l, ty, cty) -> + Ctype.newty (Tarrow (l, ty, constructor_type constr cty, commu_ok)) + + (***********************************) + (* Primitives for typing classes *) + (***********************************) + +let raise_add_method_failure loc env label sign failure = + match (failure : Ctype.add_method_failure) with + | Ctype.Unexpected_method -> + raise(Error(loc, env, Unexpected_field (sign.Types.csig_self, label))) + | Ctype.Type_mismatch trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +let raise_add_instance_variable_failure loc env label failure = + match (failure : Ctype.add_instance_variable_failure) with + | Ctype.Mutability_mismatch mut -> + raise (Error(loc, env, Mutability_mismatch(label, mut))) + | Ctype.Type_mismatch trace -> + raise (Error(loc, env, + Field_type_mismatch("instance variable", label, trace))) + +let raise_inherit_class_signature_failure loc env sign = function + | Ctype.Self_type_mismatch trace -> + raise(Error(loc, env, Self_clash trace)) + | Ctype.Method(label, failure) -> + raise_add_method_failure loc env label sign failure + | Ctype.Instance_variable(label, failure) -> + raise_add_instance_variable_failure loc env label failure + +let add_method loc env label priv virt ty sign = + match Ctype.add_method env label priv virt ty sign with + | () -> () + | exception Ctype.Add_method_failed failure -> + raise_add_method_failure loc env label sign failure + +let add_instance_variable ~strict loc env label mut virt ty sign = + match Ctype.add_instance_variable ~strict env label mut virt ty sign with + | () -> () + | exception Ctype.Add_instance_variable_failed failure -> + raise_add_instance_variable_failure loc env label failure + +let inherit_class_signature ~strict loc env sign1 sign2 = + match Ctype.inherit_class_signature ~strict env sign1 sign2 with + | () -> () + | exception Ctype.Inherit_class_signature_failed failure -> + raise_inherit_class_signature_failure loc env sign1 failure + +let inherit_class_type ~strict loc env sign1 cty2 = + let sign2 = + match Btype.scrape_class_type cty2 with + | Cty_signature sign2 -> sign2 + | _ -> + raise(Error(loc, env, Structure_expected cty2)) + in + inherit_class_signature ~strict loc env sign1 sign2 + +let unify_delayed_method_type loc env label ty expected_ty= + match Ctype.unify env ty expected_ty with + | () -> () + | exception Ctype.Unify trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +let type_constraint val_env sty sty' loc = + let cty = transl_simple_type val_env ~closed:false sty in + let ty = cty.ctyp_type in + let cty' = transl_simple_type val_env ~closed:false sty' in + let ty' = cty'.ctyp_type in + begin + try Ctype.unify val_env ty ty' with Ctype.Unify err -> + raise(Error(loc, val_env, Unconsistent_constraint err)); + end; + (cty, cty') + +let make_method loc cl_num expr = + let open Ast_helper in + let mkid s = mkloc s loc in + Exp.fun_ ~loc:expr.pexp_loc Nolabel None + (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num))) + expr + +(*******************************) + +let delayed_meth_specs = ref [] + +let rec class_type_field env sign self_scope ctf = + let loc = ctf.pctf_loc in + let mkctf desc = + { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } + in + let mkctf_with_attrs f = + Builtin_attributes.warning_scope ctf.pctf_attributes + (fun () -> mkctf (f ())) + in + match ctf.pctf_desc with + | Pctf_inherit sparent -> + mkctf_with_attrs + (fun () -> + let parent = class_type env Virtual self_scope sparent in + complete_class_type parent.cltyp_loc + env Virtual Class_type parent.cltyp_type; + inherit_class_type ~strict:false loc env sign parent.cltyp_type; + Tctf_inherit parent) + | Pctf_val ({txt=lab}, mut, virt, sty) -> + mkctf_with_attrs + (fun () -> + let cty = transl_simple_type env ~closed:false sty in + let ty = cty.ctyp_type in + add_instance_variable ~strict:false loc env lab mut virt ty sign; + Tctf_val (lab, mut, virt, cty)) + + | Pctf_method ({txt=lab}, priv, virt, sty) -> + mkctf_with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + match sty.ptyp_desc, priv with + | Ptyp_poly ([],sty'), Public -> + let expected_ty = Ctype.newvar () in + add_method loc env lab priv virt expected_ty sign; + let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) env loc in + delayed_meth_specs := + Warnings.mk_lazy (fun () -> + let cty = transl_simple_type_univars env sty' in + let ty = cty.ctyp_type in + unify_delayed_method_type loc env lab ty expected_ty; + returned_cty.ctyp_desc <- Ttyp_poly ([], cty); + returned_cty.ctyp_type <- ty; + ) :: !delayed_meth_specs; + Tctf_method (lab, priv, virt, returned_cty) + | _ -> + let cty = transl_simple_type env ~closed:false sty in + let ty = cty.ctyp_type in + add_method loc env lab priv virt ty sign; + Tctf_method (lab, priv, virt, cty)) + + | Pctf_constraint (sty, sty') -> + mkctf_with_attrs + (fun () -> + let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in + Tctf_constraint (cty, cty')) + + | Pctf_attribute x -> + Builtin_attributes.warning_attribute x; + mkctf (Tctf_attribute x) + + | Pctf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_signature virt env pcsig self_scope loc = + let {pcsig_self=sty; pcsig_fields=psign} = pcsig in + let sign = Ctype.new_class_signature () in + (* Introduce a dummy method preventing self type from being closed. *) + Ctype.add_dummy_method env ~scope:self_scope sign; + + let self_cty = transl_simple_type env ~closed:false sty in + let self_type = self_cty.ctyp_type in + begin try + Ctype.unify env self_type sign.csig_self + with Ctype.Unify _ -> + raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type)) + end; + + (* Class type fields *) + let fields = + Builtin_attributes.warning_scope [] + (fun () -> List.map (class_type_field env sign self_scope) psign) + in + check_virtual loc env virt Class_type sign; + { csig_self = self_cty; + csig_fields = fields; + csig_type = sign; } + +and class_type env virt self_scope scty = + Builtin_attributes.warning_scope scty.pcty_attributes + (fun () -> class_type_aux env virt self_scope scty) + +and class_type_aux env virt self_scope scty = + let cltyp desc typ = + { + cltyp_desc = desc; + cltyp_type = typ; + cltyp_loc = scty.pcty_loc; + cltyp_env = env; + cltyp_attributes = scty.pcty_attributes; + } + in + match scty.pcty_desc with + | Pcty_constr (lid, styl) -> + let (path, decl) = Env.lookup_cltype ~loc:scty.pcty_loc lid.txt env in + if Path.same decl.clty_path unbound_class then + raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); + let (params, clty) = + Ctype.instance_class decl.clty_params decl.clty_type + in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method env ~scope:self_scope + (Btype.signature_of_class_type clty); + if List.length params <> List.length styl then + raise(Error(scty.pcty_loc, env, + Parameter_arity_mismatch (lid.txt, List.length params, + List.length styl))); + let ctys = List.map2 + (fun sty ty -> + let cty' = transl_simple_type env ~closed:false sty in + let ty' = cty'.ctyp_type in + begin + try Ctype.unify env ty' ty with Ctype.Unify err -> + raise(Error(sty.ptyp_loc, env, Parameter_mismatch err)) + end; + cty' + ) styl params + in + let typ = Cty_constr (path, params, clty) in + (* Check for unexpected virtual methods *) + check_virtual_clty scty.pcty_loc env virt Class_type typ; + cltyp (Tcty_constr ( path, lid , ctys)) typ + + | Pcty_signature pcsig -> + let clsig = class_signature virt env pcsig self_scope scty.pcty_loc in + let typ = Cty_signature clsig.csig_type in + cltyp (Tcty_signature clsig) typ + + | Pcty_arrow (l, sty, scty) -> + let cty = transl_simple_type env ~closed:false sty in + let ty = cty.ctyp_type in + let ty = + if Btype.is_optional l + then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil)) + else ty in + let clty = class_type env virt self_scope scty in + let typ = Cty_arrow (l, ty, clty.cltyp_type) in + cltyp (Tcty_arrow (l, cty, clty)) typ + + | Pcty_open (od, e) -> + let (od, newenv) = !type_open_descr env od in + let clty = class_type newenv virt self_scope e in + cltyp (Tcty_open (od, clty)) clty.cltyp_type + + | Pcty_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +let class_type env virt self_scope scty = + delayed_meth_specs := []; + let cty = class_type env virt self_scope scty in + List.iter Lazy.force (List.rev !delayed_meth_specs); + delayed_meth_specs := []; + cty + +(*******************************) + +let enter_ancestor_val name val_env = + Env.enter_unbound_value name Val_unbound_ancestor val_env + +let enter_self_val name val_env = + Env.enter_unbound_value name Val_unbound_self val_env + +let enter_instance_var_val name val_env = + Env.enter_unbound_value name Val_unbound_instance_variable val_env + +let enter_ancestor_met ~loc name ~sign ~meths ~cl_num ~ty ~attrs met_env = + let check s = Warnings.Unused_ancestor s in + let kind = Val_anc (sign, meths, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.enter_value ~check name desc met_env + +let add_self_met loc id sign self_var_kind vars cl_num + as_var ty attrs met_env = + let check = + if as_var then (fun s -> Warnings.Unused_var s) + else (fun s -> Warnings.Unused_var_strict s) + in + let kind = Val_self (sign, self_var_kind, vars, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.add_value ~check id desc met_env + +let add_instance_var_met loc label id sign cl_num attrs met_env = + let mut, ty = + match Vars.find label sign.csig_vars with + | (mut, _, ty) -> mut, ty + | exception Not_found -> assert false + in + let kind = Val_ivar (mut, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.add_value id desc met_env + +let add_instance_vars_met loc vars sign cl_num met_env = + List.fold_left + (fun met_env (label, id) -> + add_instance_var_met loc label id sign cl_num [] met_env) + met_env vars + +type intermediate_class_field = + | Inherit of + { override : override_flag; + parent : class_expr; + super : string option; + inherited_vars : (string * Ident.t) list; + super_meths : (string * Ident.t) list; + loc : Location.t; + attributes : attribute list; } + | Virtual_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + cty : core_type; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Concrete_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + override : override_flag; + definition : expression; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Virtual_method of + { label : string loc; + priv : private_flag; + cty : core_type; + loc : Location.t; + attributes : attribute list; } + | Concrete_method of + { label : string loc; + priv : private_flag; + override : override_flag; + sdefinition : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Constraint of + { cty1 : core_type; + cty2 : core_type; + loc : Location.t; + attributes : attribute list; } + | Initializer of + { sexpr : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Attribute of + { attribute : attribute; + loc : Location.t; + attributes : attribute list; } + +type first_pass_accummulater = + { rev_fields : intermediate_class_field list; + val_env : Env.t; + par_env : Env.t; + concrete_meths : MethSet.t; + concrete_vals : VarSet.t; + local_meths : MethSet.t; + local_vals : VarSet.t; + vars : Ident.t Vars.t; } + +let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = + let { rev_fields; val_env; par_env; concrete_meths; concrete_vals; + local_meths; local_vals; vars } = acc + in + let loc = cf.pcf_loc in + let attributes = cf.pcf_attributes in + let with_attrs f = Builtin_attributes.warning_scope attributes f in + match cf.pcf_desc with + | Pcf_inherit (override, sparent, super) -> + with_attrs + (fun () -> + let parent = + class_expr cl_num val_env par_env + Virtual self_scope sparent + in + complete_class_type parent.cl_loc + par_env Virtual Class parent.cl_type; + inherit_class_type ~strict:true loc val_env sign parent.cl_type; + let parent_sign = Btype.signature_of_class_type parent.cl_type in + let new_concrete_meths = Btype.concrete_methods parent_sign in + let new_concrete_vals = Btype.concrete_instance_vars parent_sign in + let over_meths = MethSet.inter new_concrete_meths concrete_meths in + let over_vals = VarSet.inter new_concrete_vals concrete_vals in + begin match override with + | Fresh -> + let cname = + match parent.cl_type with + | Cty_constr (p, _, _) -> Path.name p + | _ -> "inherited" + in + if not (MethSet.is_empty over_meths) then + Location.prerr_warning loc + (Warnings.Method_override + (cname :: MethSet.elements over_meths)); + if not (VarSet.is_empty over_vals) then + Location.prerr_warning loc + (Warnings.Instance_variable_override + (cname :: VarSet.elements over_vals)); + | Override -> + if MethSet.is_empty over_meths && VarSet.is_empty over_vals then + raise (Error(loc, val_env, No_overriding ("",""))) + end; + let concrete_vals = VarSet.union new_concrete_vals concrete_vals in + let concrete_meths = + MethSet.union new_concrete_meths concrete_meths + in + let val_env, par_env, inherited_vars, vars = + Vars.fold + (fun label _ (val_env, par_env, inherited_vars, vars) -> + let val_env = enter_instance_var_val label val_env in + let par_env = enter_instance_var_val label par_env in + let id = Ident.create_local label in + let inherited_vars = (label, id) :: inherited_vars in + let vars = Vars.add label id vars in + (val_env, par_env, inherited_vars, vars)) + parent_sign.csig_vars (val_env, par_env, [], vars) + in + (* Methods available through super *) + let super_meths = + MethSet.fold + (fun label acc -> (label, Ident.create_local label) :: acc) + new_concrete_meths [] + in + (* Super *) + let (val_env, par_env, super) = + match super with + | None -> (val_env, par_env, None) + | Some {txt=name} -> + let val_env = enter_ancestor_val name val_env in + let par_env = enter_ancestor_val name par_env in + (val_env, par_env, Some name) + in + let field = + Inherit + { override; parent; super; inherited_vars; + super_meths; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; + concrete_meths; concrete_vals; vars }) + | Pcf_val (label, mut, Cfk_virtual styp) -> + with_attrs + (fun () -> + let cty = + Ctype.with_local_level_if_principal + (fun () -> Typetexp.transl_simple_type val_env + ~closed:false styp) + ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type) + in + add_instance_variable ~strict:true loc val_env + label.txt mut Virtual cty.ctyp_type sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Virtual_val + { label; mut; id; cty; already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; vars }) + | Pcf_val (label, mut, Cfk_concrete (override, sdefinition)) -> + with_attrs + (fun () -> + if VarSet.mem label.txt local_vals then + raise(Error(loc, val_env, + Duplicate ("instance variable", label.txt))); + if VarSet.mem label.txt concrete_vals then begin + if override = Fresh then + Location.prerr_warning label.loc + (Warnings.Instance_variable_override[label.txt]) + end else begin + if override = Override then + raise(Error(loc, val_env, + No_overriding ("instance variable", label.txt))) + end; + let definition = + Ctype.with_local_level_if_principal + ~post:Typecore.generalize_structure_exp + (fun () -> type_exp val_env sdefinition) + in + add_instance_variable ~strict:true loc val_env + label.txt mut Concrete definition.exp_type sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Concrete_val + { label; mut; id; override; definition; + already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_vals = VarSet.add label.txt concrete_vals in + let local_vals = VarSet.add label.txt local_vals in + { acc with rev_fields; val_env; par_env; + concrete_vals; local_vals; vars }) + + | Pcf_method (label, priv, Cfk_virtual sty) -> + with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = transl_simple_type val_env ~closed:false sty in + let ty = cty.ctyp_type in + add_method loc val_env label.txt priv Virtual ty sign; + let field = + Virtual_method { label; priv; cty; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_method (label, priv, Cfk_concrete (override, expr)) -> + with_attrs + (fun () -> + if MethSet.mem label.txt local_meths then + raise(Error(loc, val_env, Duplicate ("method", label.txt))); + if MethSet.mem label.txt concrete_meths then begin + if override = Fresh then begin + Location.prerr_warning loc + (Warnings.Method_override [label.txt]) + end + end else begin + if override = Override then begin + raise(Error(loc, val_env, No_overriding("method", label.txt))) + end + end; + let expr = + match expr.pexp_desc with + | Pexp_poly _ -> expr + | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None + in + let sbody, sty = + match expr.pexp_desc with + | Pexp_poly (sbody, sty) -> sbody, sty + | _ -> assert false + in + let ty = + match sty with + | None -> Ctype.newvar () + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty' = + Typetexp.transl_simple_type val_env ~closed:false sty + in + cty'.ctyp_type + in + add_method loc val_env label.txt priv Concrete ty sign; + begin + try + match get_desc ty with + | Tvar _ -> + let ty' = Ctype.newvar () in + Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty; + Ctype.unify val_env (type_approx val_env sbody) ty' + | Tpoly (ty1, tl) -> + let _, ty1' = Ctype.instance_poly false tl ty1 in + let ty2 = type_approx val_env sbody in + Ctype.unify val_env ty2 ty1' + | _ -> assert false + with Ctype.Unify err -> + raise(Error(loc, val_env, + Field_type_mismatch ("method", label.txt, err))) + end; + let sdefinition = make_method self_loc cl_num expr in + let warning_state = Warnings.backup () in + let field = + Concrete_method + { label; priv; override; sdefinition; + warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_meths = MethSet.add label.txt concrete_meths in + let local_meths = MethSet.add label.txt local_meths in + { acc with rev_fields; concrete_meths; local_meths }) + + | Pcf_constraint (sty1, sty2) -> + with_attrs + (fun () -> + let (cty1, cty2) = type_constraint val_env sty1 sty2 loc in + let field = + Constraint { cty1; cty2; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_initializer sexpr -> + with_attrs + (fun () -> + let sexpr = make_method self_loc cl_num sexpr in + let warning_state = Warnings.backup () in + let field = + Initializer { sexpr; warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + | Pcf_attribute attribute -> + Builtin_attributes.warning_attribute attribute; + let field = Attribute { attribute; loc; attributes } in + let rev_fields = field :: rev_fields in + { acc with rev_fields } + | Pcf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env cfs = + let rev_fields = [] in + let concrete_meths = MethSet.empty in + let concrete_vals = VarSet.empty in + let local_meths = MethSet.empty in + let local_vals = VarSet.empty in + let vars = Vars.empty in + let init_acc = + { rev_fields; val_env; par_env; + concrete_meths; concrete_vals; + local_meths; local_vals; vars } + in + let acc = + Builtin_attributes.warning_scope [] + (fun () -> + List.fold_left + (class_field_first_pass self_loc cl_num sign self_scope) + init_acc cfs) + in + List.rev acc.rev_fields, acc.vars + +and class_field_second_pass cl_num sign met_env field = + let mkcf desc loc attrs = + { cf_desc = desc; cf_loc = loc; cf_attributes = attrs } + in + match field with + | Inherit { override; parent; super; + inherited_vars; super_meths; loc; attributes } -> + let met_env = + add_instance_vars_met loc inherited_vars sign cl_num met_env + in + let met_env = + match super with + | None -> met_env + | Some name -> + let meths = + List.fold_left + (fun acc (label, id) -> Meths.add label id acc) + Meths.empty super_meths + in + let ty = Btype.self_type parent.cl_type in + let attrs = [] in + let _id, met_env = + enter_ancestor_met ~loc name ~sign ~meths + ~cl_num ~ty ~attrs met_env + in + met_env + in + let desc = + Tcf_inherit(override, parent, super, inherited_vars, super_meths) + in + met_env, mkcf desc loc attributes + | Virtual_val { label; mut; id; cty; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end + in + let kind = Tcfk_virtual cty in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Concrete_val { label; mut; id; override; + definition; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end + in + let kind = Tcfk_concrete(override, definition) in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Virtual_method { label; priv; cty; loc; attributes } -> + let kind = Tcfk_virtual cty in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes + | Concrete_method { label; priv; override; + sdefinition; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + let ty = Btype.method_type label.txt sign in + let self_type = sign.Types.csig_self in + let meth_type = + mk_expected + (Btype.newgenty (Tarrow(Nolabel, self_type, ty, commu_ok))) + in + let texp = + Ctype.with_raised_nongen_level + (fun () -> type_expect met_env sdefinition meth_type) in + let kind = Tcfk_concrete (override, texp) in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes) + | Constraint { cty1; cty2; loc; attributes } -> + let desc = Tcf_constraint(cty1, cty2) in + met_env, mkcf desc loc attributes + | Initializer { sexpr; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + let unit_type = Ctype.instance Predef.type_unit in + let self_type = sign.Types.csig_self in + let meth_type = + mk_expected + (Ctype.newty (Tarrow (Nolabel, self_type, unit_type, commu_ok))) + in + let texp = + Ctype.with_raised_nongen_level + (fun () -> type_expect met_env sexpr meth_type) in + let desc = Tcf_initializer texp in + met_env, mkcf desc loc attributes) + | Attribute { attribute; loc; attributes; } -> + let desc = Tcf_attribute attribute in + met_env, mkcf desc loc attributes + +and class_fields_second_pass cl_num sign met_env fields = + let _, rev_cfs = + List.fold_left + (fun (met_env, cfs) field -> + let met_env, cf = + class_field_second_pass cl_num sign met_env field + in + met_env, cf :: cfs) + (met_env, []) fields + in + List.rev rev_cfs + +(* N.B. the self type of a final object type doesn't contain a dummy method in + the beginning. + We only explicitly add a dummy method to class definitions (and class (type) + declarations)), which are later removed (made absent) by [final_decl]. + + If we ever find a dummy method in a final object self type, it means that + somehow we've unified the self type of the object with the self type of a not + yet finished class. + When this happens, we cannot close the object type and must error. *) +and class_structure cl_num virt self_scope final val_env met_env loc + { pcstr_self = spat; pcstr_fields = str } = + (* Environment for substructures *) + let par_env = met_env in + + (* Location of self. Used for locations of self arguments *) + let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in + + let sign = Ctype.new_class_signature () in + + (* Adding a dummy method to the signature prevents it from being closed / + escaping. That isn't needed for objects though. *) + begin match final with + | Not_final -> Ctype.add_dummy_method val_env ~scope:self_scope sign; + | Final -> () + end; + + (* Self binder *) + let (self_pat, self_pat_vars) = type_self_pattern val_env spat in + let val_env, par_env = + List.fold_right + (fun {pv_id; _} (val_env, par_env) -> + let name = Ident.name pv_id in + let val_env = enter_self_val name val_env in + let par_env = enter_self_val name par_env in + val_env, par_env) + self_pat_vars (val_env, par_env) + in + + (* Check that the binder has a correct type *) + begin try Ctype.unify val_env self_pat.pat_type sign.csig_self with + Ctype.Unify _ -> + raise(Error(spat.ppat_loc, val_env, + Pattern_type_clash self_pat.pat_type)) + end; + + (* Typing of class fields *) + let (fields, vars) = + class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env str + in + let kind = kind_of_final final in + + (* Check for unexpected virtual methods *) + check_virtual loc val_env virt kind sign; + + (* Update the class signature *) + update_class_signature loc val_env + ~warn_implicit_public:false virt kind sign; + + let meths = + Meths.fold + (fun label _ meths -> + Meths.add label (Ident.create_local label) meths) + sign.csig_meths Meths.empty + in + + (* Close the signature if it is final *) + begin match final with + | Not_final -> () + | Final -> + if not (Ctype.close_class_signature val_env sign) then + raise(Error(loc, val_env, Closing_self_type sign)); + end; + (* Typing of method bodies *) + Ctype.generalize_class_signature_spine val_env sign; + let self_var_kind = + match virt with + | Virtual -> Self_virtual(ref meths) + | Concrete -> Self_concrete meths + in + let met_env = + List.fold_right + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} met_env -> + add_self_met pv_loc pv_id sign self_var_kind vars + cl_num pv_as_var pv_type pv_attributes met_env) + self_pat_vars met_env + in + let fields = + class_fields_second_pass cl_num sign met_env fields + in + + (* Update the class signature and warn about public methods made private *) + update_class_signature loc val_env + ~warn_implicit_public:true virt kind sign; + + let meths = + match self_var_kind with + | Self_virtual meths_ref -> !meths_ref + | Self_concrete meths -> meths + in + { cstr_self = self_pat; + cstr_fields = fields; + cstr_type = sign; + cstr_meths = meths; } + +and class_expr cl_num val_env met_env virt self_scope scl = + Builtin_attributes.warning_scope scl.pcl_attributes + (fun () -> class_expr_aux cl_num val_env met_env virt self_scope scl) + +and class_expr_aux cl_num val_env met_env virt self_scope scl = + match scl.pcl_desc with + | Pcl_constr (lid, styl) -> + let (path, decl) = Env.lookup_class ~loc:scl.pcl_loc lid.txt val_env in + if Path.same decl.cty_path unbound_class then + raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt)); + let tyl = List.map + (fun sty -> transl_simple_type val_env ~closed:false sty) + styl + in + let (params, clty) = + Ctype.instance_class decl.cty_params decl.cty_type + in + let clty' = Btype.abbreviate_class_type path params clty in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type clty'); + if List.length params <> List.length tyl then + raise(Error(scl.pcl_loc, val_env, + Parameter_arity_mismatch (lid.txt, List.length params, + List.length tyl))); + List.iter2 + (fun cty' ty -> + let ty' = cty'.ctyp_type in + try Ctype.unify val_env ty' ty with Ctype.Unify err -> + raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch err))) + tyl params; + (* Check for unexpected virtual methods *) + check_virtual_clty scl.pcl_loc val_env virt Class clty'; + let cl = + rc {cl_desc = Tcl_ident (path, lid, tyl); + cl_loc = scl.pcl_loc; + cl_type = clty'; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + in + let (vals, meths, concrs) = extract_constraints clty in + rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs); + cl_loc = scl.pcl_loc; + cl_type = clty'; + cl_env = val_env; + cl_attributes = []; (* attributes are kept on the inner cl node *) + } + | Pcl_structure cl_str -> + let desc = + class_structure cl_num virt self_scope Not_final + val_env met_env scl.pcl_loc cl_str + in + rc {cl_desc = Tcl_structure desc; + cl_loc = scl.pcl_loc; + cl_type = Cty_signature desc.cstr_type; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_fun (l, Some default, spat, sbody) -> + let loc = default.pexp_loc in + let open Ast_helper in + let scases = [ + Exp.case + (Pat.construct ~loc + (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) + (Some ([], Pat.var ~loc (mknoloc "*sth*")))) + (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*"))); + + Exp.case + (Pat.construct ~loc + (mknoloc (Longident.(Ldot (Lident "*predef*", "None")))) + None) + default; + ] + in + let smatch = + Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) + scases + in + let sfun = + Cl.fun_ ~loc:scl.pcl_loc + l None + (Pat.var ~loc (mknoloc "*opt*")) + (Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody) + (* Note: we don't put the '#default' attribute, as it + is not detected for class-level let bindings. See #5975.*) + in + class_expr cl_num val_env met_env virt self_scope sfun + | Pcl_fun (l, None, spat, scl') -> + let (pat, pv, val_env', met_env) = + Ctype.with_local_level_if_principal + (fun () -> + Typecore.type_class_arg_pattern cl_num val_env met_env l spat) + ~post: begin fun (pat, _, _, _) -> + let gen {pat_type = ty} = Ctype.generalize_structure ty in + iter_pattern gen pat + end + in + let pv = + List.map + begin fun (id, id', _ty) -> + let path = Pident id' in + (* do not mark the value as being used *) + let vd = Env.find_value path val_env' in + (id, + {exp_desc = + Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd); + exp_loc = Location.none; exp_extra = []; + exp_type = Ctype.instance vd.val_type; + exp_attributes = []; (* check *) + exp_env = val_env'}) + end + pv + in + let rec not_nolabel_function = function + | Cty_arrow(Nolabel, _, _) -> false + | Cty_arrow(_, _, cty) -> not_nolabel_function cty + | _ -> true + in + let partial = + let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in + Typecore.check_partial Modules_rejected val_env pat.pat_type pat.pat_loc + [{c_lhs = pat; c_guard = None; c_rhs = dummy}] + in + let cl = + Ctype.with_raised_nongen_level + (fun () -> class_expr cl_num val_env' met_env virt self_scope scl') in + if Btype.is_optional l && not_nolabel_function cl.cl_type then + Location.prerr_warning pat.pat_loc + Warnings.Unerasable_optional_argument; + rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial); + cl_loc = scl.pcl_loc; + cl_type = Cty_arrow + (l, Ctype.instance pat.pat_type, cl.cl_type); + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_apply (scl', sargs) -> + assert (sargs <> []); + let cl = + Ctype.with_local_level_if_principal + (fun () -> class_expr cl_num val_env met_env virt self_scope scl') + ~post:(fun cl -> Ctype.generalize_class_type_structure cl.cl_type) + in + let rec nonopt_labels ls ty_fun = + match ty_fun with + | Cty_arrow (l, _, ty_res) -> + if Btype.is_optional l then nonopt_labels ls ty_res + else nonopt_labels (l::ls) ty_res + | _ -> ls + in + let ignore_labels = + !Clflags.classic || + let labels = nonopt_labels [] cl.cl_type in + List.length labels = List.length sargs && + List.for_all (fun (l,_) -> l = Nolabel) sargs && + List.exists (fun l -> l <> Nolabel) labels && + begin + Location.prerr_warning + cl.cl_loc + (Warnings.Labels_omitted + (List.map Printtyp.string_of_label + (List.filter ((<>) Nolabel) labels))); + true + end + in + let rec type_args args omitted ty_fun ty_fun0 sargs = + match ty_fun, ty_fun0 with + | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0) + when sargs <> [] -> + let name = Btype.label_name l + and optional = Btype.is_optional l in + let use_arg sarg l' = + Some ( + if not optional || Btype.is_optional l' then + type_argument val_env sarg ty ty0 + else + let ty' = extract_option_type val_env ty + and ty0' = extract_option_type val_env ty0 in + let arg = type_argument val_env sarg ty' ty0' in + option_some val_env arg + ) + in + let eliminate_optional_arg () = + Some (option_none val_env ty0 Location.none) + in + let remaining_sargs, arg = + if ignore_labels then begin + match sargs with + | [] -> assert false + | (l', sarg) :: remaining_sargs -> + if name = Btype.label_name l' || + (not optional && l' = Nolabel) + then + (remaining_sargs, use_arg sarg l') + else if + optional && + not (List.exists (fun (l, _) -> name = Btype.label_name l) + remaining_sargs) + then + (sargs, eliminate_optional_arg ()) + else + raise(Error(sarg.pexp_loc, val_env, Apply_wrong_label l')) + end else + match Btype.extract_label name sargs with + | Some (l', sarg, _, remaining_sargs) -> + if not optional && Btype.is_optional l' then + Location.prerr_warning sarg.pexp_loc + (Warnings.Nonoptional_label + (Printtyp.string_of_label l)); + remaining_sargs, use_arg sarg l' + | None -> + sargs, + if Btype.is_optional l && List.mem_assoc Nolabel sargs then + eliminate_optional_arg () + else + None + in + let omitted = if arg = None then (l,ty0) :: omitted else omitted in + type_args ((l,arg)::args) omitted ty_fun ty_fun0 remaining_sargs + | _ -> + match sargs with + (l, sarg0)::_ -> + if omitted <> [] then + raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l)) + else + raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type)) + | [] -> + (List.rev args, + List.fold_left + (fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun)) + ty_fun0 omitted) + in + let (args, cty) = + let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in + type_args [] [] cl.cl_type ty_fun0 sargs + in + rc {cl_desc = Tcl_apply (cl, args); + cl_loc = scl.pcl_loc; + cl_type = cty; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_let (rec_flag, sdefs, scl') -> + let (defs, val_env) = + Typecore.type_let In_class_def val_env rec_flag sdefs in + let (vals, met_env) = + List.fold_right + (fun (id, _id_loc, _typ) (vals, met_env) -> + let path = Pident id in + (* do not mark the value as used *) + let vd = Env.find_value path val_env in + let ty = + Ctype.with_local_level ~post:Ctype.generalize + (fun () -> Ctype.instance vd.val_type) + in + let expr = + {exp_desc = + Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd); + exp_loc = Location.none; exp_extra = []; + exp_type = ty; + exp_attributes = []; + exp_env = val_env; + } + in + let desc = + {val_type = expr.exp_type; + val_kind = Val_ivar (Immutable, cl_num); + val_attributes = []; + Types.val_loc = vd.Types.val_loc; + val_uid = vd.val_uid; + } + in + let id' = Ident.create_local (Ident.name id) in + ((id', expr) + :: vals, + Env.add_value id' desc met_env)) + (let_bound_idents_full defs) + ([], met_env) + in + let cl = class_expr cl_num val_env met_env virt self_scope scl' in + let () = if rec_flag = Recursive then + check_recursive_bindings val_env defs + in + rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl); + cl_loc = scl.pcl_loc; + cl_type = cl.cl_type; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_constraint (scl', scty) -> + let cl, clty = + Ctype.with_local_level_for_class begin fun () -> + let cl = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let cl = class_expr cl_num val_env met_env virt self_scope scl' in + complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type; + cl + end + and clty = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let clty = class_type val_env virt self_scope scty in + complete_class_type + clty.cltyp_loc val_env virt Class clty.cltyp_type; + clty + end + in + cl, clty + end + ~post: begin fun ({cl_type=cl}, {cltyp_type=clty}) -> + Ctype.limited_generalize_class_type (Btype.self_type_row cl) cl; + Ctype.limited_generalize_class_type (Btype.self_type_row clty) clty; + end + in + begin match + Includeclass.class_types val_env cl.cl_type clty.cltyp_type + with + [] -> () + | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error)) + end; + let (vals, meths, concrs) = extract_constraints clty.cltyp_type in + let ty = snd (Ctype.instance_class [] clty.cltyp_type) in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type ty); + rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); + cl_loc = scl.pcl_loc; + cl_type = ty; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_open (pod, e) -> + let used_slot = ref false in + let (od, new_val_env) = !type_open_descr ~used_slot val_env pod in + let ( _, new_met_env) = !type_open_descr ~used_slot met_env pod in + let cl = class_expr cl_num new_val_env new_met_env virt self_scope e in + rc {cl_desc = Tcl_open (od, cl); + cl_loc = scl.pcl_loc; + cl_type = cl.cl_type; + cl_env = val_env; + cl_attributes = scl.pcl_attributes; + } + | Pcl_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +(*******************************) + +(* Approximate the type of the constructor to allow recursive use *) +(* of optional parameters *) + +let var_option = Predef.type_option (Btype.newgenvar ()) + +let rec approx_declaration cl = + match cl.pcl_desc with + Pcl_fun (l, _, _, cl) -> + let arg = + if Btype.is_optional l then Ctype.instance var_option + else Ctype.newvar () in + Ctype.newty (Tarrow (l, arg, approx_declaration cl, commu_ok)) + | Pcl_let (_, _, cl) -> + approx_declaration cl + | Pcl_constraint (cl, _) -> + approx_declaration cl + | _ -> Ctype.newvar () + +let rec approx_description ct = + match ct.pcty_desc with + Pcty_arrow (l, _, ct) -> + let arg = + if Btype.is_optional l then Ctype.instance var_option + else Ctype.newvar () in + Ctype.newty (Tarrow (l, arg, approx_description ct, commu_ok)) + | _ -> Ctype.newvar () + +(*******************************) + +let temp_abbrev loc arity uid = + let params = ref [] in + for _i = 1 to arity do + params := Ctype.newvar () :: !params + done; + let ty = Ctype.newobj (Ctype.newvar ()) in + let ty_td = + {type_params = !params; + type_arity = arity; + type_kind = Type_abstract; + type_private = Public; + type_manifest = Some ty; + type_variance = Variance.unknown_signature ~injective:false ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = loc; + type_attributes = []; (* or keep attrs from the class decl? *) + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = uid; + } + in + (!params, ty, ty_td) + +let initial_env define_class approx + (res, env) (cl, id, ty_id, obj_id, uid) = + (* Temporary abbreviations *) + let arity = List.length cl.pci_params in + let (obj_params, obj_ty, obj_td) = temp_abbrev cl.pci_loc arity uid in + let env = Env.add_type ~check:true obj_id obj_td env in + let (cl_params, cl_ty, cl_td) = temp_abbrev cl.pci_loc arity uid in + + (* Temporary type for the class constructor *) + let constr_type = + Ctype.with_local_level_if_principal (fun () -> approx cl.pci_expr) + ~post:Ctype.generalize_structure + in + let dummy_cty = Cty_signature (Ctype.new_class_signature ()) in + let dummy_class = + {Types.cty_params = []; (* Dummy value *) + cty_variance = []; + cty_type = dummy_cty; (* Dummy value *) + cty_path = unbound_class; + cty_new = + begin match cl.pci_virt with + | Virtual -> None + | Concrete -> Some constr_type + end; + cty_loc = Location.none; + cty_attributes = []; + cty_uid = uid; + } + in + let env = + Env.add_cltype ty_id + {clty_params = []; (* Dummy value *) + clty_variance = []; + clty_type = dummy_cty; (* Dummy value *) + clty_path = unbound_class; + clty_hash_type = cl_td; (* Dummy value *) + clty_loc = Location.none; + clty_attributes = []; + clty_uid = uid; + } + ( + if define_class then + Env.add_class id dummy_class env + else + env + ) + in + ((cl, id, ty_id, + obj_id, obj_params, obj_ty, + cl_params, cl_ty, cl_td, + constr_type, + dummy_class)::res, + env) + +let class_infos define_class kind + (cl, id, ty_id, + obj_id, obj_params, obj_ty, + cl_params, cl_ty, cl_td, + constr_type, + dummy_class) + (res, env) = + + let ci_params, params, coercion_locs, expr, typ, sign = + Ctype.with_local_level_for_class begin fun () -> + TyVarEnv.reset (); + (* Introduce class parameters *) + let ci_params = + let make_param (sty, v) = + try + (transl_type_param env sty, v) + with Already_bound -> + raise(Error(sty.ptyp_loc, env, Repeated_parameter)) + in + List.map make_param cl.pci_params + in + let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in + + (* Allow self coercions (only for class declarations) *) + let coercion_locs = ref [] in + + (* Type the class expression *) + let (expr, typ) = + try + Typecore.self_coercion := + (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion; + let res = kind env cl.pci_virt cl.pci_expr in + Typecore.self_coercion := List.tl !Typecore.self_coercion; + res + with exn -> + Typecore.self_coercion := []; raise exn + in + let sign = Btype.signature_of_class_type typ in + (ci_params, params, coercion_locs, expr, typ, sign) + end + ~post: begin fun (_, params, _, _, typ, sign) -> + (* Generalize the row variable *) + List.iter (Ctype.limited_generalize sign.csig_self_row) params; + Ctype.limited_generalize_class_type sign.csig_self_row typ; + end + in + (* Check the abbreviation for the object type *) + let (obj_params', obj_type) = Ctype.instance_class params typ in + let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in + begin + let row = Btype.self_type_row obj_type in + Ctype.unify env row (Ctype.newty Tnil); + begin try + List.iter2 (Ctype.unify env) obj_params obj_params' + with Ctype.Unify _ -> + raise(Error(cl.pci_loc, env, + Bad_parameters (obj_id, obj_params, obj_params'))) + end; + let ty = Btype.self_type obj_type in + begin try + Ctype.unify env ty constr + with Ctype.Unify _ -> + raise(Error(cl.pci_loc, env, + Abbrev_type_clash (constr, ty, Ctype.expand_head env constr))) + end + end; + + Ctype.set_object_name obj_id params (Btype.self_type typ); + + (* Check the other temporary abbreviation (#-type) *) + begin + let (cl_params', cl_type) = Ctype.instance_class params typ in + let ty = Btype.self_type cl_type in + begin try + List.iter2 (Ctype.unify env) cl_params cl_params' + with Ctype.Unify _ -> + raise(Error(cl.pci_loc, env, + Bad_class_type_parameters (ty_id, cl_params, cl_params'))) + end; + begin try + Ctype.unify env ty cl_ty + with Ctype.Unify _ -> + let ty_expanded = Ctype.object_fields ty in + raise(Error(cl.pci_loc, env, Abbrev_type_clash (ty, ty_expanded, cl_ty))) + end + end; + + (* Type of the class constructor *) + begin try + Ctype.unify env + (constructor_type constr obj_type) + (Ctype.instance constr_type) + with Ctype.Unify err -> + raise(Error(cl.pci_loc, env, + Constructor_type_mismatch (cl.pci_name.txt, err))) + end; + + (* Class and class type temporary definitions *) + let cty_variance = + Variance.unknown_signature ~injective:false ~arity:(List.length params) in + let cltydef = + {clty_params = params; clty_type = Btype.class_body typ; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_hash_type = cl_td; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; + clty_uid = dummy_class.cty_uid; + } + and clty = + {cty_params = params; cty_type = typ; + cty_variance = cty_variance; + cty_path = Path.Pident obj_id; + cty_new = + begin match cl.pci_virt with + | Virtual -> None + | Concrete -> Some constr_type + end; + cty_loc = cl.pci_loc; + cty_attributes = cl.pci_attributes; + cty_uid = dummy_class.cty_uid; + } + in + dummy_class.cty_type <- typ; + let env = + Env.add_cltype ty_id cltydef ( + if define_class then Env.add_class id clty env else env) + in + + (* Misc. *) + let arity = Btype.class_type_arity typ in + let pub_meths = Btype.public_methods sign in + + (* Final definitions *) + let (params', typ') = Ctype.instance_class params typ in + let clty = + {cty_params = params'; cty_type = typ'; + cty_variance = cty_variance; + cty_path = Path.Pident obj_id; + cty_new = + begin match cl.pci_virt with + | Virtual -> None + | Concrete -> Some (Ctype.instance constr_type) + end; + cty_loc = cl.pci_loc; + cty_attributes = cl.pci_attributes; + cty_uid = dummy_class.cty_uid; + } + in + let obj_abbr = + let arity = List.length obj_params in + { + type_params = obj_params; + type_arity = arity; + type_kind = Type_abstract; + type_private = Public; + type_manifest = Some obj_ty; + type_variance = Variance.unknown_signature ~injective:false ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = cl.pci_loc; + type_attributes = []; (* or keep attrs from cl? *) + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = dummy_class.cty_uid; + } + in + let (cl_params, cl_ty) = + Ctype.instance_parameterized_type params (Btype.self_type typ) + in + Ctype.set_object_name obj_id cl_params cl_ty; + let cl_abbr = + { cl_td with + type_params = cl_params; + type_manifest = Some cl_ty + } + in + let cltydef = + {clty_params = params'; clty_type = Btype.class_body typ'; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_hash_type = cl_abbr; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; + clty_uid = dummy_class.cty_uid; + } + in + ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, ci_params, + arity, pub_meths, List.rev !coercion_locs, expr) :: res, + env) + +let final_decl env define_class + (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, ci_params, + arity, pub_meths, coe, expr) = + let cl_abbr = cltydef.clty_hash_type in + + begin try Ctype.collapse_conj_params env clty.cty_params + with Ctype.Unify err -> + raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, err))) + end; + + List.iter Ctype.generalize clty.cty_params; + Ctype.generalize_class_type clty.cty_type; + Option.iter Ctype.generalize clty.cty_new; + List.iter Ctype.generalize obj_abbr.type_params; + Option.iter Ctype.generalize obj_abbr.type_manifest; + List.iter Ctype.generalize cl_abbr.type_params; + Option.iter Ctype.generalize cl_abbr.type_manifest; + + Ctype.nongen_vars_in_class_declaration clty + |> Option.iter (fun vars -> + let nongen_vars = Btype.TypeSet.elements vars in + raise(Error(cl.pci_loc, env + , Non_generalizable_class { id; clty; nongen_vars })); + ); + + begin match + Ctype.closed_class clty.cty_params + (Btype.signature_of_class_type clty.cty_type) + with + None -> () + | Some reason -> + let printer = + if define_class + then function ppf -> Printtyp.class_declaration id ppf clty + else function ppf -> Printtyp.cltype_declaration id ppf cltydef + in + raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason))) + end; + { id; clty; ty_id; cltydef; obj_id; obj_abbr; arity; + pub_meths; coe; + id_loc = cl.pci_name; + req = { ci_loc = cl.pci_loc; + ci_virt = cl.pci_virt; + ci_params = ci_params; + (* TODO : check that we have the correct use of identifiers *) + ci_id_name = cl.pci_name; + ci_id_class = id; + ci_id_class_type = ty_id; + ci_id_object = obj_id; + ci_expr = expr; + ci_decl = clty; + ci_type_decl = cltydef; + ci_attributes = cl.pci_attributes; + } + } +(* (cl.pci_variance, cl.pci_loc)) *) + +let class_infos define_class kind + (cl, id, ty_id, + obj_id, obj_params, obj_ty, + cl_params, cl_ty, cl_td, + constr_type, + dummy_class) + (res, env) = + Builtin_attributes.warning_scope cl.pci_attributes + (fun () -> + class_infos define_class kind + (cl, id, ty_id, + obj_id, obj_params, obj_ty, + cl_params, cl_ty, cl_td, + constr_type, + dummy_class) + (res, env) + ) + +let extract_type_decls { clty; cltydef; obj_id; obj_abbr; req} decls = + (obj_id, obj_abbr, clty, cltydef, req) :: decls + +let merge_type_decls decl (obj_abbr, clty, cltydef) = + {decl with obj_abbr; clty; cltydef} + +let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_abbr; } = + (* Add definitions after cleaning them *) + Env.add_type ~check:true obj_id + (Subst.type_declaration Subst.identity obj_abbr) ( + Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) ( + if define_class then + Env.add_class id (Subst.class_declaration Subst.identity clty) env + else env)) + +(* Check that #c is coercible to c if there is a self-coercion *) +let check_coercions env { id; id_loc; clty; ty_id; cltydef; obj_id; obj_abbr; + arity; pub_meths; coe; req } = + let cl_abbr = cltydef.clty_hash_type in + begin match coe with [] -> () + | loc :: _ -> + let cl_ty, obj_ty = + match cl_abbr.type_manifest, obj_abbr.type_manifest with + Some cl_ab, Some obj_ab -> + let cl_params, cl_ty = + Ctype.instance_parameterized_type cl_abbr.type_params cl_ab + and obj_params, obj_ty = + Ctype.instance_parameterized_type obj_abbr.type_params obj_ab + in + List.iter2 (Ctype.unify env) cl_params obj_params; + cl_ty, obj_ty + | _ -> assert false + in + begin try Ctype.subtype env cl_ty obj_ty () + with Ctype.Subtype err -> + raise(Typecore.Error(loc, env, Typecore.Not_subtype err)) + end; + if not (Ctype.opened_object cl_ty) then + raise(Error(loc, env, Cannot_coerce_self obj_ty)) + end; + {cls_id = id; + cls_id_loc = id_loc; + cls_decl = clty; + cls_ty_id = ty_id; + cls_ty_decl = cltydef; + cls_obj_id = obj_id; + cls_obj_abbr = obj_abbr; + cls_abbr = cl_abbr; + cls_arity = arity; + cls_pub_methods = pub_meths; + cls_info=req} + +(*******************************) + +let type_classes define_class approx kind env cls = + let scope = Ctype.create_scope () in + let cls = + List.map + (function cl -> + (cl, + Ident.create_scoped ~scope cl.pci_name.txt, + Ident.create_scoped ~scope cl.pci_name.txt, + Ident.create_scoped ~scope cl.pci_name.txt, + Uid.mk ~current_unit:(Env.get_unit_name ()) + )) + cls + in + let res, newenv = + Ctype.with_local_level_for_class begin fun () -> + let (res, env) = + List.fold_left (initial_env define_class approx) ([], env) cls + in + let (res, env) = + List.fold_right (class_infos define_class kind) res ([], env) + in + res, env + end + in + let res = List.rev_map (final_decl newenv define_class) res in + let decls = List.fold_right extract_type_decls res [] in + let decls = + try Typedecl_variance.update_class_decls newenv decls + with Typedecl_variance.Error(loc, err) -> + raise (Typedecl.Error(loc, Typedecl.Variance err)) + in + let res = List.map2 merge_type_decls res decls in + let env = List.fold_left (final_env define_class) env res in + let res = List.map (check_coercions env) res in + (res, env) + +let class_num = ref 0 +let class_declaration env virt sexpr = + incr class_num; + let self_scope = Ctype.get_current_level () in + let expr = + class_expr (Int.to_string !class_num) env env virt self_scope sexpr + in + complete_class_type expr.cl_loc env virt Class expr.cl_type; + (expr, expr.cl_type) + +let class_description env virt sexpr = + let self_scope = Ctype.get_current_level () in + let expr = class_type env virt self_scope sexpr in + complete_class_type expr.cltyp_loc env virt Class_type expr.cltyp_type; + (expr, expr.cltyp_type) + +let class_declarations env cls = + let info, env = + type_classes true approx_declaration class_declaration env cls + in + let ids, exprs = + List.split + (List.map + (fun ci -> ci.cls_id, ci.cls_info.ci_expr) + info) + in + check_recursive_class_bindings env ids exprs; + info, env + +let class_descriptions env cls = + type_classes true approx_description class_description env cls + +let class_type_declarations env cls = + let (decls, env) = + type_classes false approx_description class_description env cls + in + (List.map + (fun decl -> + {clsty_ty_id = decl.cls_ty_id; + clsty_id_loc = decl.cls_id_loc; + clsty_ty_decl = decl.cls_ty_decl; + clsty_obj_id = decl.cls_obj_id; + clsty_obj_abbr = decl.cls_obj_abbr; + clsty_abbr = decl.cls_abbr; + clsty_info = decl.cls_info}) + decls, + env) + +let type_object env loc s = + incr class_num; + let desc = + class_structure (Int.to_string !class_num) + Concrete Btype.lowest_level Final env env loc s + in + complete_class_signature loc env Concrete Object desc.cstr_type; + let meths = Btype.public_methods desc.cstr_type in + (desc, meths) + +let () = + Typecore.type_object := type_object + +(*******************************) + +(* Check that there is no references through recursive modules (GPR#6491) *) +let rec check_recmod_class_type env cty = + match cty.pcty_desc with + | Pcty_constr(lid, _) -> + ignore (Env.lookup_cltype ~use:false ~loc:lid.loc lid.txt env) + | Pcty_extension _ -> () + | Pcty_arrow(_, _, cty) -> + check_recmod_class_type env cty + | Pcty_open(od, cty) -> + let _, env = !type_open_descr env od in + check_recmod_class_type env cty + | Pcty_signature csig -> + check_recmod_class_sig env csig + +and check_recmod_class_sig env csig = + List.iter + (fun ctf -> + match ctf.pctf_desc with + | Pctf_inherit cty -> check_recmod_class_type env cty + | Pctf_val _ | Pctf_method _ + | Pctf_constraint _ | Pctf_attribute _ | Pctf_extension _ -> ()) + csig.pcsig_fields + +let check_recmod_decl env sdecl = + check_recmod_class_type env sdecl.pci_expr + +(* Approximate the class declaration as class ['params] id = object end *) +let approx_class sdecl = + let open Ast_helper in + let self' = Typ.any () in + let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in + { sdecl with pci_expr = clty' } + +let approx_class_declarations env sdecls = + let decls, env = class_type_declarations env (List.map approx_class sdecls) in + List.iter (check_recmod_decl env) sdecls; + decls, env + +(*******************************) + +(* Error report *) + +open Format + +let non_virtual_string_of_kind = function + | Object -> "object" + | Class -> "non-virtual class" + | Class_type -> "non-virtual class type" + +let report_error env ppf = function + | Repeated_parameter -> + fprintf ppf "A type parameter occurs several times" + | Unconsistent_constraint err -> + fprintf ppf "@[The class constraints are not consistent.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type"); + fprintf ppf "@]" + | Field_type_mismatch (k, m, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The %s %s@ has type" k m) + (function ppf -> + fprintf ppf "but is expected to have type") + | Unexpected_field (ty, lab) -> + fprintf ppf + "@[@[<2>This object is expected to have type :@ %a@]\ + @ This type does not have a method %s." + Printtyp.type_expr ty lab + | Structure_expected clty -> + fprintf ppf + "@[This class expression is not a class structure; it has type@ %a@]" + Printtyp.class_type clty + | Cannot_apply _ -> + fprintf ppf + "This class expression is not a class function, it cannot be applied" + | Apply_wrong_label l -> + let mark_label = function + | Nolabel -> "out label" + | l -> sprintf " label %s" (Btype.prefixed_label_name l) in + fprintf ppf "This argument cannot be applied with%s" (mark_label l) + | Pattern_type_clash ty -> + (* XXX Trace *) + (* XXX Revoir message d'erreur | Improve error message *) + fprintf ppf "@[%s@ %a@]" + "This pattern cannot match self: it only matches values of type" + Printtyp.type_expr ty + | Unbound_class_2 cl -> + fprintf ppf "@[The class@ %a@ is not yet completely defined@]" + Printtyp.longident cl + | Unbound_class_type_2 cl -> + fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" + Printtyp.longident cl + | Abbrev_type_clash (abbrev, actual, expected) -> + (* XXX Afficher une trace ? | Print a trace? *) + Printtyp.prepare_for_printing [abbrev; actual; expected]; + fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ + but is used with type@ %a@]" + !Oprint.out_type (Printtyp.tree_of_typexp Type abbrev) + !Oprint.out_type (Printtyp.tree_of_typexp Type actual) + !Oprint.out_type (Printtyp.tree_of_typexp Type expected) + | Constructor_type_mismatch (c, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The expression \"new %s\" has type" c) + (function ppf -> + fprintf ppf "but is used with type") + | Virtual_class (kind, mets, vals) -> + let kind = non_virtual_string_of_kind kind in + let missings = + match mets, vals with + [], _ -> "variables" + | _, [] -> "methods" + | _ -> "methods and variables" + in + fprintf ppf + "@[This %s has virtual %s.@ \ + @[<2>The following %s are virtual : %a@]@]" + kind missings missings + (pp_print_list ~pp_sep:pp_print_space pp_print_string) (mets @ vals) + | Undeclared_methods(kind, mets) -> + let kind = non_virtual_string_of_kind kind in + fprintf ppf + "@[This %s has undeclared virtual methods.@ \ + @[<2>The following methods were not declared : %a@]@]" + kind (pp_print_list ~pp_sep:pp_print_space pp_print_string) mets + | Parameter_arity_mismatch(lid, expected, provided) -> + fprintf ppf + "@[The class constructor %a@ expects %i type argument(s),@ \ + but is here applied to %i type argument(s)@]" + Printtyp.longident lid expected provided + | Parameter_mismatch err -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The type parameter") + (function ppf -> + fprintf ppf "does not meet its constraint: it should be") + | Bad_parameters (id, params, cstrs) -> + Printtyp.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The abbreviation %a@ is used with parameter(s)@ %a@ \ + which are incompatible with constraint(s)@ %a@]" + Printtyp.ident id + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) params) + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) cstrs) + | Bad_class_type_parameters (id, params, cstrs) -> + Printtyp.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The class type #%a@ is used with parameter(s)@ %a,@ \ + whereas the class type definition@ constrains@ \ + those parameters to be@ %a@]" + Printtyp.ident id + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) params) + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) cstrs) + | Class_match_failure error -> + Includeclass.report_error Type ppf error + | Unbound_val lab -> + fprintf ppf "Unbound instance variable %s" lab + | Unbound_type_var (printer, reason) -> + let print_reason ppf { Ctype.free_variable; meth; meth_ty; } = + let (ty0, kind) = free_variable in + let ty1 = + match kind with + | Type_variable -> ty0 + | Row_variable -> Btype.newgenty(Tobject(ty0, ref None)) + in + Printtyp.add_type_to_preparation meth_ty; + Printtyp.add_type_to_preparation ty1; + fprintf ppf + "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound" + meth + !Oprint.out_type (Printtyp.tree_of_typexp Type meth_ty) + !Oprint.out_type (Printtyp.tree_of_typexp Type ty0) + in + fprintf ppf + "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ + @[%a@]@]" + printer print_reason reason + | Non_generalizable_class {id; clty; nongen_vars } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in + Printtyp.prepare_for_printing nongen_vars; + fprintf ppf + "@[The type of this class,@ %a,@ \ + contains the non-generalizable type variable(s): %a.@ %a@]" + (Printtyp.class_declaration id) clty + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + Printtyp.prepared_type_scheme) nongen_vars + Misc.print_see_manual manual_ref + + | Cannot_coerce_self ty -> + fprintf ppf + "@[The type of self cannot be coerced to@ \ + the type of the current class:@ %a.@.\ + Some occurrences are contravariant@]" + Printtyp.type_scheme ty + | Non_collapsable_conjunction (id, clty, err) -> + fprintf ppf + "@[The type of this class,@ %a,@ \ + contains non-collapsible conjunctive types in constraints.@ %t@]" + (Printtyp.class_declaration id) clty + (fun ppf -> Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type") + ) + | Self_clash err -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "This object is expected to have type") + (function ppf -> + fprintf ppf "but actually has type") + | Mutability_mismatch (_lab, mut) -> + let mut1, mut2 = + if mut = Immutable then "mutable", "immutable" + else "immutable", "mutable" in + fprintf ppf + "@[The instance variable is %s;@ it cannot be redefined as %s@]" + mut1 mut2 + | No_overriding (_, "") -> + fprintf ppf "@[This inheritance does not override any method@ %s@]" + "instance variable" + | No_overriding (kind, name) -> + fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name + | Duplicate (kind, name) -> + fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]" + kind name + | Closing_self_type sign -> + fprintf ppf + "@[Cannot close type of object literal:@ %a@,\ + it has been unified with the self type of a class that is not yet@ \ + completely defined.@]" + Printtyp.type_scheme sign.csig_self + +let report_error env ppf err = + Printtyp.wrap_printing_env ~error:true + env (fun () -> report_error env ppf err) + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (Location.error_of_printer ~loc (report_error env) err) + | Error_forward err -> + Some err + | _ -> + None + ) diff --git a/ocamlmerlin_mlx/ocaml/typing/typeclass.mli b/ocamlmerlin_mlx/ocaml/typing/typeclass.mli new file mode 100644 index 0000000..cdecc8d --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typeclass.mli @@ -0,0 +1,138 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Types +open Format + +type 'a class_info = { + cls_id : Ident.t; + cls_id_loc : string loc; + cls_decl : class_declaration; + cls_ty_id : Ident.t; + cls_ty_decl : class_type_declaration; + cls_obj_id : Ident.t; + cls_obj_abbr : type_declaration; + cls_abbr : type_declaration; + cls_arity : int; + cls_pub_methods : string list; + cls_info : 'a; +} + +type class_type_info = { + clsty_ty_id : Ident.t; + clsty_id_loc : string loc; + clsty_ty_decl : class_type_declaration; + clsty_obj_id : Ident.t; + clsty_obj_abbr : type_declaration; + clsty_abbr : type_declaration; + clsty_info : Typedtree.class_type_declaration; +} + +val class_declarations: + Env.t -> Parsetree.class_declaration list -> + Typedtree.class_declaration class_info list * Env.t + +(* +and class_declaration = + (class_expr, Types.class_declaration) class_infos +*) + +val class_descriptions: + Env.t -> Parsetree.class_description list -> + Typedtree.class_description class_info list * Env.t + +(* +and class_description = + (class_type, unit) class_infos +*) + +val class_type_declarations: + Env.t -> Parsetree.class_description list -> class_type_info list * Env.t + +(* +and class_type_declaration = + (class_type, Types.class_type_declaration) class_infos +*) + +val approx_class_declarations: + Env.t -> Parsetree.class_description list -> class_type_info list * Env.t + +(* +val type_classes : + bool -> + ('a -> Types.type_expr) -> + (Env.t -> 'a -> 'b * Types.class_type) -> + Env.t -> + 'a Parsetree.class_infos list -> + ( Ident.t * Types.class_declaration * + Ident.t * Types.class_type_declaration * + Ident.t * Types.type_declaration * + Ident.t * Types.type_declaration * + int * string list * 'b * 'b Typedtree.class_infos) + list * Env.t +*) + +type kind = + | Object + | Class + | Class_type + +type error = + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string + | Structure_expected of class_type + | Cannot_apply of class_type + | Apply_wrong_label of arg_label + | Pattern_type_clash of type_expr + | Repeated_parameter + | Unbound_class_2 of Longident.t + | Unbound_class_type_2 of Longident.t + | Abbrev_type_clash of type_expr * type_expr * type_expr + | Constructor_type_mismatch of string * Errortrace.unification_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of Errortrace.unification_error + | Bad_parameters of Ident.t * type_expr list * type_expr list + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list + | Class_match_failure of Ctype.class_match_failure list + | Unbound_val of string + | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure + | Non_generalizable_class of + { id : Ident.t + ; clty : Types.class_declaration + ; nongen_vars : type_expr list + } + | Cannot_coerce_self of type_expr + | Non_collapsable_conjunction of + Ident.t * Types.class_declaration * Errortrace.unification_error + | Self_clash of Errortrace.unification_error + | Mutability_mismatch of string * mutable_flag + | No_overriding of string * string + | Duplicate of string * string + | Closing_self_type of class_signature + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +val report_error : Env.t -> formatter -> error -> unit + +(* Forward decl filled in by Typemod.type_open_descr *) +val type_open_descr : + (?used_slot:bool ref -> + Env.t -> Parsetree.open_description -> Typedtree.open_description * Env.t) + ref diff --git a/ocamlmerlin_mlx/ocaml/typing/typecore.ml b/ocamlmerlin_mlx/ocaml/typing/typecore.ml new file mode 100644 index 0000000..5240dd0 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typecore.ml @@ -0,0 +1,6485 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Typechecking for the core language *) + +open Misc +open Asttypes +open Parsetree +open Types +open Typedtree +open Btype +open Ctype + +let raise_error = Msupport.raise_error + +type type_forcing_context = + | If_conditional + | If_no_else_branch + | While_loop_conditional + | While_loop_body + | For_loop_start_index + | For_loop_stop_index + | For_loop_body + | Assert_condition + | Sequence_left_hand_side + | When_guard + +type type_expected = { + ty: type_expr; + explanation: type_forcing_context option; +} + +module Datatype_kind = struct + type t = Record | Variant + + let type_name = function + | Record -> "record" + | Variant -> "variant" + + let label_name = function + | Record -> "field" + | Variant -> "constructor" +end + +type wrong_name = { + type_path: Path.t; + kind: Datatype_kind.t; + name: string loc; + valid_names: string list; +} + +type wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +let wrong_kind_sort_of_constructor (lid : Longident.t) = + match lid with + | Lident "true" | Lident "false" | Ldot(_, "true") | Ldot(_, "false") -> + Boolean + | Lident "[]" | Lident "::" | Ldot(_, "[]") | Ldot(_, "::") -> List + | Lident "()" | Ldot(_, "()") -> Unit + | _ -> Constructor + +type existential_restriction = + | At_toplevel (** no existential types at the toplevel *) + | In_group (** nor with let ... and ... *) + | In_rec (** or recursive definition *) + | With_attributes (** or let[@any_attribute] = ... *) + | In_class_args (** or in class arguments *) + | In_class_def (** or in [class c = let ... in ...] *) + | In_self_pattern (** or in self pattern *) + +type error = + | Constructor_arity_mismatch of Longident.t * int * int + | Label_mismatch of Longident.t * Errortrace.unification_error + | Pattern_type_clash : + Errortrace.unification_error * Parsetree.pattern_desc option -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * type_forcing_context option + * Parsetree.expression_desc option + | Apply_non_function of { + funct : Typedtree.expression; + func_ty : type_expr; + res_ty : type_expr; + previous_arg_loc : Location.t; + extra_arg_loc : Location.t; + } + | Apply_wrong_label of arg_label * type_expr * bool + | Label_multiply_defined of string + | Label_missing of Ident.t list + | Label_not_mutable of Longident.t + | Wrong_name of string * type_expected * wrong_name + | Name_type_mismatch of + Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list + | Invalid_format of string + | Not_an_object of type_expr * type_forcing_context option + | Undefined_method of type_expr * string * string list option + | Undefined_self_method of string * string list + | Virtual_class of Longident.t + | Private_type of type_expr + | Private_label of Longident.t * type_expr + | Private_constructor of constructor_description * type_expr + | Unbound_instance_variable of string * string list + | Instance_variable_not_mutable of string + | Not_subtype of Errortrace.Subtype.error + | Outside_class + | Value_multiply_overridden of string + | Coercion_failure of + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } + | Scoping_let_module of string * type_expr + | Not_a_polymorphic_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * Errortrace.unification_error + | Modules_not_allowed + | Cannot_infer_signature + | Not_a_packed_module of type_expr + | Unexpected_existential of existential_restriction * string * string list + | Invalid_interval + | Invalid_for_loop_index + | No_value_clauses + | Exception_pattern_disallowed + | Mixed_value_and_exception_patterns_under_guard + | Inlined_record_escape + | Inlined_record_expected + | Unrefuted_pattern of pattern + | Invalid_extension_constructor_payload + | Not_an_extension_constructor + | Literal_overflow of string + | Unknown_literal of string * char + | Illegal_letrec_pat + | Illegal_letrec_expr + | Illegal_class_expr + | Letop_type_clash of string * Errortrace.unification_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +(* merlin: deep copy types in errors, to keep them meaningful after + backtracking *) +let deep_copy () = + let table = TypeHash.create 7 in + let rec copy ty : type_expr = + try TypeHash.find table ty + with Not_found -> + let ty' = + let {Types. level; id; desc; scope} = Transient_expr.repr ty in + create_expr ~level ~id ~scope desc + in + TypeHash.add table ty ty'; + let desc = + match get_desc ty with + | Tvar _ | Tnil | Tunivar _ as desc -> desc + | Tvariant _ as desc -> (* fixme *) desc + | Tarrow (l,t1,t2,c) -> Tarrow (l, copy t1, copy t2, c) + | Ttuple tl -> Ttuple (List.map copy tl) + | Tconstr (p, tl, _) -> Tconstr (p, List.map copy tl, ref Mnil) + | Tobject (t1, r) -> + let r = match !r with + | None -> None + | Some (p,tl) -> Some (p, List.map copy tl) + in + Tobject (copy t1, ref r) + | Tfield (s,fk,t1,t2) -> Tfield (s, fk, copy t1, copy t2) + | Tpoly (t,tl) -> Tpoly (copy t, List.map copy tl) + | Tpackage (p,ltl) -> + Tpackage (p, List.map (fun (l, tl) -> l, copy tl) ltl) + | Tlink _ | Tsubst _ -> assert false + in + Transient_expr.(set_desc (repr ty') desc); + ty' + in + copy + +let trace_copy_raw ?(copy=deep_copy ()) + (trace : Errortrace.unification Errortrace.error) = + Errortrace.map_types copy trace + +let trace_copy ?copy + ({ trace } : Errortrace.unification_error) = + Errortrace.unification_error ~trace:(trace_copy_raw ?copy trace) + +let trace_subtype_copy ?(copy=deep_copy ()) + (error_trace : Errortrace.Subtype.error_trace) = + Errortrace.Subtype.map_types copy error_trace + +let copy_expanded_type copy ({ ty; expanded } : Errortrace.expanded_type) = + Errortrace.{ ty = copy ty; expanded = copy expanded } + +let error (loc, env, err) = + let err = match err with + | Label_mismatch (li, unification_error) -> + Label_mismatch (li, trace_copy unification_error) + | Pattern_type_clash (trace, popt) -> + Pattern_type_clash (trace_copy trace, popt) + | Or_pattern_type_clash (i, trace) -> + Or_pattern_type_clash (i, trace_copy trace) + | Expr_type_clash (trace, ctx_opt, eopt) -> + Expr_type_clash (trace_copy trace, ctx_opt, eopt) + | Apply_non_function t -> + Apply_non_function { t with + func_ty = deep_copy () t.func_ty; + res_ty = deep_copy () t.res_ty } + | Apply_wrong_label (l, t, b) -> + Apply_wrong_label (l, deep_copy () t, b) + | Wrong_name (s1, t, wn) -> + Wrong_name (s1, { t with ty = deep_copy () t.ty }, wn) + | Undefined_method (t, s, l) -> + Undefined_method (deep_copy () t, s, l) + | Private_type t -> + Private_type (deep_copy () t) + | Private_label (li, t) -> + Private_label (li, deep_copy () t) + | Not_subtype { trace; unification_trace} -> + let copy = deep_copy () in + let trace = trace_subtype_copy ~copy trace in + let unification_trace = trace_copy_raw ~copy unification_trace in + Not_subtype (Errortrace.Subtype.error ~trace ~unification_trace) + | Coercion_failure (exptype, ts, b) -> + let copy = deep_copy () in + Coercion_failure (copy_expanded_type copy exptype, trace_copy ~copy ts, b) + | Too_many_arguments (t, ctx_opt) -> + Too_many_arguments (deep_copy () t, ctx_opt) + | Abstract_wrong_label ({ expected_type; _} as awl) -> + Abstract_wrong_label + { awl with expected_type = deep_copy () expected_type } + | Scoping_let_module (s, t) -> + Scoping_let_module (s, deep_copy () t) + | Less_general (s, tr) -> + Less_general (s, trace_copy tr) + | Not_a_packed_module t -> + Not_a_packed_module (deep_copy () t) + | err -> err + in + Error (loc, env, err) + +(* Forward declaration, to be filled in by Typemod.type_module *) + +let type_module = + ref ((fun _env _md -> assert false) : + Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t) + +(* Forward declaration, to be filled in by Typemod.type_open *) + +let type_open : + (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> + Longident.t loc -> Path.t * Env.t) + ref = + ref (fun ?used_slot:_ _ -> assert false) + +let type_open_decl : + (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration + -> open_declaration * Types.signature * Env.t) + ref = + ref (fun ?used_slot:_ _ -> assert false) + +(* Forward declaration, to be filled in by Typemod.type_package *) + +let type_package = + ref (fun _ -> assert false) + +(* Forward declaration, to be filled in by Typeclass.class_structure *) +let type_object = + ref (fun _env _s -> assert false : + Env.t -> Location.t -> Parsetree.class_structure -> + Typedtree.class_structure * string list) + +(* + Saving and outputting type information. + We keep these function names short, because they have to be + called each time we create a record of type [Typedtree.expression] + or [Typedtree.pattern] that will end up in the typed AST. +*) +let re node = + Cmt_format.add_saved_type (Cmt_format.Partial_expression node); + node + +let rp node = + Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Value, node)); + node + +let rcp node = + Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Computation, node)); + node + + + +(* Context for inline record arguments; see [type_ident] *) + +type recarg = + | Allowed + | Required + | Rejected + +(* Whether or not patterns of the form (module M) are accepted. (If they are, + the idents will be created at the provided scope.) When module patterns are + allowed, the caller should take care to check that the introduced module + bindings' types don't escape their scope; see the callsites in [type_let] + and [type_cases] for examples. +*) +type module_patterns_restriction = + | Modules_allowed of { scope : int } + | Modules_rejected + +let mk_expected ?explanation ty = { ty; explanation; } + +let case lhs rhs = + {c_lhs = lhs; c_guard = None; c_rhs = rhs} + +(* Typing of constants *) + +let type_constant = function + Const_int _ -> instance Predef.type_int + | Const_char _ -> instance Predef.type_char + | Const_string _ -> instance Predef.type_string + | Const_float _ -> instance Predef.type_float + | Const_int32 _ -> instance Predef.type_int32 + | Const_int64 _ -> instance Predef.type_int64 + | Const_nativeint _ -> instance Predef.type_nativeint + +let constant : Parsetree.constant -> (Asttypes.constant, error) result = + function + | Pconst_integer (i,None) -> + begin + try Ok (Const_int (Misc.Int_literal_converter.int i)) + with Failure _ -> Error (Literal_overflow "int") + end + | Pconst_integer (i,Some 'l') -> + begin + try Ok (Const_int32 (Misc.Int_literal_converter.int32 i)) + with Failure _ -> Error (Literal_overflow "int32") + end + | Pconst_integer (i,Some 'L') -> + begin + try Ok (Const_int64 (Misc.Int_literal_converter.int64 i)) + with Failure _ -> Error (Literal_overflow "int64") + end + | Pconst_integer (i,Some 'n') -> + begin + try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i)) + with Failure _ -> Error (Literal_overflow "nativeint") + end + | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c)) + | Pconst_char c -> Ok (Const_char c) + | Pconst_string (s,loc,d) -> Ok (Const_string (s,loc,d)) + | Pconst_float (f,None)-> Ok (Const_float f) + | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c)) + +let constant_or_raise env loc cst = + match constant cst with + | Ok c -> c + | Error err -> raise (error (loc, env, err)) + +(* Specific version of type_option, using newty rather than newgenty *) + +let type_option ty = + newty (Tconstr(Predef.path_option,[ty], ref Mnil)) + +let mkexp exp_desc exp_type exp_loc exp_env = + { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] } + +let option_none env ty loc = + let lid = Longident.Lident "None" in + let cnone = Env.find_ident_constructor Predef.ident_none env in + mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env + +let option_some env texp = + let lid = Longident.Lident "Some" in + let csome = Env.find_ident_constructor Predef.ident_some env in + mkexp ( Texp_construct(mknoloc lid , csome, [texp]) ) + (type_option texp.exp_type) texp.exp_loc texp.exp_env + +let extract_option_type env ty = + match get_desc (expand_head env ty) with + Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty + | _ -> assert false + +let protect_expansion env ty = + if Env.has_local_constraints env then generic_instance ty else ty + +type record_extraction_result = + | Record_type of Path.t * Path.t * Types.label_declaration list + | Not_a_record_type + | Maybe_a_record_type + +let extract_concrete_typedecl_protected env ty = + extract_concrete_typedecl env (protect_expansion env ty) + +let extract_concrete_record env ty = + match extract_concrete_typedecl_protected env ty with + | Typedecl(p0, p, {type_kind=Type_record (fields, _)}) -> + Record_type (p0, p, fields) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_record_type + | May_have_typedecl -> Maybe_a_record_type + +type variant_extraction_result = + | Variant_type of Path.t * Path.t * Types.constructor_declaration list + | Not_a_variant_type + | Maybe_a_variant_type + +let extract_concrete_variant env ty = + match extract_concrete_typedecl_protected env ty with + | Typedecl(p0, p, {type_kind=Type_variant (cstrs, _)}) -> + Variant_type (p0, p, cstrs) + | Typedecl(p0, p, {type_kind=Type_open}) -> + Variant_type (p0, p, []) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_variant_type + | May_have_typedecl -> Maybe_a_variant_type + +let extract_label_names env ty = + match extract_concrete_record env ty with + | Record_type (_, _,fields) -> List.map (fun l -> l.Types.ld_id) fields + | Not_a_record_type | Maybe_a_record_type -> assert false + +let is_principal ty = + not !Clflags.principal || get_level ty = generic_level + +(* Typing of patterns *) + +(* unification inside type_exp and type_expect *) +let unify_exp_types loc env ty expected_ty = + (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type + Printtyp.raw_type_expr expected_ty; *) + try + unify env ty expected_ty + with + Unify err -> + raise(error(loc, env, Expr_type_clash(err, None, None))) + | Tags(l1,l2) -> + raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) + +(* level at which to create the local type declarations *) +let gadt_equations_level = ref None +let get_gadt_equations_level () = + match !gadt_equations_level with + Some y -> y + | None -> assert false + +let nothing_equated = TypePairs.create 0 + +(* unification inside type_pat*) +let unify_pat_types_return_equated_pairs ?(refine = None) loc env ty ty' = + try + match refine with + | Some allow_recursive_equations -> + unify_gadt ~equations_level:(get_gadt_equations_level ()) + ~allow_recursive_equations env ty ty' + | None -> + unify !env ty ty'; + nothing_equated + with + | Unify err -> + raise(error(loc, !env, Pattern_type_clash(err, None))) + | Tags(l1,l2) -> + raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2))) + +let unify_pat_types ?refine loc env ty ty' = + ignore (unify_pat_types_return_equated_pairs ?refine loc env ty ty') + + + +(** [sdesc_for_hint] is used by error messages to report literals in their + original formatting *) +let unify_pat ?refine ?sdesc_for_hint env pat expected_ty = + try unify_pat_types ?refine pat.pat_loc env pat.pat_type expected_ty + with Error (loc, env, Pattern_type_clash(err, None)) -> + raise(error(loc, env, Pattern_type_clash(err, sdesc_for_hint))) + +(* unification of a type with a Tconstr with freshly created arguments *) +let unify_head_only ~refine loc env ty constr = + let path = cstr_type_path constr in + let decl = Env.find_type path !env in + let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in + unify_pat_types ~refine loc env ty' ty + +(* Creating new conjunctive types is not allowed when typing patterns *) +(* make all Reither present in open variants *) +let finalize_variant pat tag opat r = + let row = + match get_desc (expand_head pat.pat_env pat.pat_type) with + Tvariant row -> r := row; row + | _ -> assert false + in + let f = get_row_field tag row in + begin match row_field_repr f with + | Rabsent -> () (* assert false *) + | Reither (true, [], _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present None) + | Reither (false, ty::tl, _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present (Some ty)); + begin match opat with None -> assert false + | Some pat -> + let env = ref pat.pat_env in List.iter (unify_pat env pat) (ty::tl) + end + | Reither (c, _l, true) when not (has_fixed_explanation row) -> + link_row_field_ext ~inside:f (rf_either [] ~no_arg:c ~matched:false) + | _ -> () + end + (* Force check of well-formedness WHY? *) + (* unify_pat pat.pat_env pat + (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; + row_bound=(); row_fixed=false; row_name=None})); *) + +let has_variants p = + exists_general_pattern + { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with + | (Tpat_variant _) -> true + | _ -> false } p + +let finalize_variants p = + iter_general_pattern + { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with + | Tpat_variant(tag, opat, r) -> + finalize_variant p tag opat r + | _ -> () } p + +(* pattern environment *) +type pattern_variable = + { + pv_id: Ident.t; + pv_type: type_expr; + pv_loc: Location.t; + pv_as_var: bool; + pv_attributes: attributes; + } + +type module_variable = + { + mv_id: Ident.t; + mv_name: string Location.loc; + mv_loc: Location.t; + mv_uid: Uid.t + } + +let pattern_variables = ref ([] : pattern_variable list) +let pattern_force = ref ([] : (unit -> unit) list) +let allow_modules = ref Modules_rejected +let module_variables = ref ([] : module_variable list) +let reset_pattern allow = + pattern_variables := []; + pattern_force := []; + allow_modules := allow; + module_variables := [] + +let maybe_add_pattern_variables_ghost loc_let env pv = + List.fold_right + (fun {pv_id; _} env -> + let name = Ident.name pv_id in + if Env.bound_value name env then env + else begin + Env.enter_unbound_value name + (Val_unbound_ghost_recursive loc_let) env + end + ) pv env + +let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty + attrs = + if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt) + !pattern_variables + then raise(error(loc, Env.empty, Multiply_bound_variable name.txt)); + let id = + if is_module then begin + (* Unpack patterns result in both a module declaration and a value + variable of the same name being entered into the environment. (The + module is via [module_variables], and the variable is via + [pattern_variables].) *) + match !allow_modules with + | Modules_rejected -> + raise (error (loc, Env.empty, Modules_not_allowed)); + | Modules_allowed { scope } -> + let id = Ident.create_scoped name.txt ~scope in + module_variables := + { mv_id = id; + mv_name = name; + mv_loc = loc; + mv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } :: !module_variables; + id + end else + Ident.create_local name.txt + in + pattern_variables := + {pv_id = id; + pv_type = ty; + pv_loc = loc; + pv_as_var = is_as_variable; + pv_attributes = attrs} :: !pattern_variables; + id + +let sort_pattern_variables vs = + List.sort + (fun {pv_id = x; _} {pv_id = y; _} -> + Stdlib.compare (Ident.name x) (Ident.name y)) + vs + +let enter_orpat_variables loc env p1_vs p2_vs = + (* unify_vars operate on sorted lists *) + + let p1_vs = sort_pattern_variables p1_vs + and p2_vs = sort_pattern_variables p2_vs in + + let rec unify_vars p1_vs p2_vs = + let vars vs = List.map (fun {pv_id; _} -> pv_id) vs in + match p1_vs, p2_vs with + | {pv_id = x1; pv_type = t1; _}::rem1, {pv_id = x2; pv_type = t2; _}::rem2 + when Ident.equal x1 x2 -> + if x1==x2 then + unify_vars rem1 rem2 + else begin + begin try + unify_var env (newvar ()) t1; + unify env t1 t2 + with + | Unify err -> + raise(error(loc, env, Or_pattern_type_clash(x1, err))) + end; + (x2,x1)::unify_vars rem1 rem2 + end + | [],[] -> [] + | {pv_id; _}::_, [] | [],{pv_id; _}::_ -> + raise (error (loc, env, Orpat_vars (pv_id, []))) + | {pv_id = x; _}::_, {pv_id = y; _}::_ -> + let err = + if Ident.name x < Ident.name y + then Orpat_vars (x, vars p2_vs) + else Orpat_vars (y, vars p1_vs) in + raise (error (loc, env, err)) in + unify_vars p1_vs p2_vs + +let rec build_as_type ~refine (env : Env.t ref) p = + let as_ty = build_as_type_aux ~refine env p in + (* Cf. #1655 *) + List.fold_left (fun as_ty (extra, _loc, _attrs) -> + match extra with + | Tpat_type _ | Tpat_open _ | Tpat_unpack -> as_ty + | Tpat_constraint cty -> + (* [generic_instance] can only be used if the variables of the original + type ([cty.ctyp_type] here) are not at [generic_level], which they are + here. + If we used [generic_instance] we would lose the sharing between + [instance ty] and [ty]. *) + let ty = + with_local_level ~post:generalize_structure + (fun () -> instance cty.ctyp_type) + in + (* This call to unify can't fail since the pattern is well typed. *) + unify_pat_types ~refine p.pat_loc env (instance as_ty) (instance ty); + ty + ) as_ty p.pat_extra + +and build_as_type_aux ~refine (env : Env.t ref) p = + let build_as_type = build_as_type ~refine in + match p.pat_desc with + Tpat_alias(p1,_, _) -> build_as_type env p1 + | Tpat_tuple pl -> + let tyl = List.map (build_as_type env) pl in + newty (Ttuple tyl) + | Tpat_construct(_, cstr, pl, vto) -> + let keep = + cstr.cstr_private = Private || cstr.cstr_existentials <> [] || + vto <> None (* be lazy and keep the type for node constraints *) in + if keep then p.pat_type else + let tyl = List.map (build_as_type env) pl in + let ty_args, ty_res, _ = + instance_constructor Keep_existentials_flexible cstr + in + List.iter2 (fun (p,ty) -> unify_pat ~refine env {p with pat_type = ty}) + (List.combine pl tyl) ty_args; + ty_res + | Tpat_variant(l, p', _) -> + let ty = Option.map (build_as_type env) p' in + let fields = [l, rf_present ty] in + newty (Tvariant (create_row ~fields ~more:(newvar()) + ~name:None ~fixed:None ~closed:false)) + | Tpat_record (lpl,_) -> + let lbl = snd3 (List.hd lpl) in + if lbl.lbl_private = Private then p.pat_type else + let ty = newvar () in + let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in + let do_label lbl = + let _, ty_arg, ty_res = instance_label false lbl in + unify_pat ~refine env {p with pat_type = ty} ty_res; + let refinable = + lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && + match get_desc lbl.lbl_arg with Tpoly _ -> false | _ -> true in + if refinable then begin + let arg = List.assoc lbl.lbl_pos ppl in + unify_pat ~refine env + {arg with pat_type = build_as_type env arg} ty_arg + end else begin + let _, ty_arg', ty_res' = instance_label false lbl in + unify_pat_types ~refine p.pat_loc env ty_arg ty_arg'; + unify_pat ~refine env p ty_res' + end in + Array.iter do_label lbl.lbl_all; + ty + | Tpat_or(p1, p2, row) -> + begin match row with + None -> + let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in + unify_pat ~refine env {p2 with pat_type = ty2} ty1; + ty1 + | Some row -> + let Row {fields; fixed; name} = row_repr row in + newty (Tvariant (create_row ~fields ~fixed ~name + ~closed:false ~more:(newvar()))) + end + | Tpat_any | Tpat_var _ | Tpat_constant _ + | Tpat_array _ | Tpat_lazy _ -> p.pat_type + +(* Constraint solving during typing of patterns *) + +let solve_Ppat_poly_constraint ~refine env loc sty expected_ty = + let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in + unify_pat_types ~refine loc env ty (instance expected_ty); + pattern_force := force :: !pattern_force; + match get_desc ty with + | Tpoly (body, tyl) -> + let _, ty' = + with_level ~level:generic_level + (fun () -> instance_poly ~keep_names:true false tyl body) + in + (cty, ty, ty') + | _ -> assert false + +let solve_Ppat_alias ~refine env pat = + with_local_level ~post:generalize (fun () -> build_as_type ~refine env pat) + +let solve_Ppat_tuple (type a) ~refine loc env (args : a list) expected_ty = + let vars = List.map (fun _ -> newgenvar ()) args in + let ty = newgenty (Ttuple vars) in + let expected_ty = generic_instance expected_ty in + unify_pat_types ~refine loc env ty expected_ty; + vars + +let solve_constructor_annotation env name_list sty ty_args ty_ex = + let expansion_scope = get_gadt_equations_level () in + let ids = + List.map + (fun name -> + let decl = new_local_type ~loc:name.loc () in + let (id, new_env) = + Env.enter_type ~scope:expansion_scope name.txt decl !env in + env := new_env; + {name with txt = id}) + name_list + in + let cty, ty, force = + with_local_level ~post:(fun (_,ty,_) -> generalize_structure ty) + (fun () -> Typetexp.transl_simple_type_delayed !env sty) + in + pattern_force := force :: !pattern_force; + let ty_args = + let ty1 = instance ty and ty2 = instance ty in + match ty_args with + [] -> assert false + | [ty_arg] -> + unify_pat_types cty.ctyp_loc env ty1 ty_arg; + [ty2] + | _ -> + unify_pat_types cty.ctyp_loc env ty1 (newty (Ttuple ty_args)); + match get_desc (expand_head !env ty2) with + Ttuple tyl -> tyl + | _ -> assert false + in + if ids <> [] then ignore begin + let ids = List.map (fun x -> x.txt) ids in + let rem = + List.fold_left + (fun rem tv -> + match get_desc tv with + Tconstr(Path.Pident id, [], _) when List.mem id rem -> + list_remove id rem + | _ -> + raise (Error (cty.ctyp_loc, !env, + Unbound_existential (ids, ty)))) + ids ty_ex + in + if rem <> [] then + raise (Error (cty.ctyp_loc, !env, + Unbound_existential (ids, ty))) + end; + ty_args, Some (ids, cty) + +let solve_Ppat_construct ~refine env loc constr no_existentials + existential_styp expected_ty = + (* if constructor is gadt, we must verify that the expected type has the + correct head *) + if constr.cstr_generalized then + unify_head_only ~refine loc env (instance expected_ty) constr; + + (* PR#7214: do not use gadt unification for toplevel lets *) + let unify_res ty_res expected_ty = + let refine = + match refine, no_existentials with + | None, None when constr.cstr_generalized -> Some false + | _ -> refine + in + unify_pat_types_return_equated_pairs ~refine loc env ty_res expected_ty + in + + let ty_args, equated_types, existential_ctyp = + with_local_level_iter ~post: generalize_structure begin fun () -> + let expected_ty = instance expected_ty in + let expansion_scope = get_gadt_equations_level () in + let ty_args, ty_res, equated_types, existential_ctyp = + match existential_styp with + None -> + let ty_args, ty_res, _ = + instance_constructor + (Make_existentials_abstract { env; scope = expansion_scope }) + constr + in + ty_args, ty_res, unify_res ty_res expected_ty, None + | Some (name_list, sty) -> + let existential_treatment = + if name_list = [] then + Make_existentials_abstract { env; scope = expansion_scope } + else + (* we will unify them (in solve_constructor_annotation) with the + local types provided by the user *) + Keep_existentials_flexible + in + let ty_args, ty_res, ty_ex = + instance_constructor existential_treatment constr + in + let equated_types = unify_res ty_res expected_ty in + let ty_args, existential_ctyp = + solve_constructor_annotation env name_list sty ty_args ty_ex in + ty_args, ty_res, equated_types, existential_ctyp + in + if constr.cstr_existentials <> [] then + lower_variables_only !env expansion_scope ty_res; + ((ty_args, equated_types, existential_ctyp), + expected_ty :: ty_res :: ty_args) + end + in + if !Clflags.principal && refine = None then begin + (* Do not warn for counter-examples *) + let exception Warn_only_once in + try + TypePairs.iter + (fun (t1, t2) -> + generalize_structure t1; + generalize_structure t2; + if not (fully_generic t1 && fully_generic t2) then + let msg = + Format.asprintf + "typing this pattern requires considering@ %a@ and@ %a@ as \ + equal.@,\ + But the knowledge of these types" + Printtyp.type_expr t1 + Printtyp.type_expr t2 + in + Location.prerr_warning loc (Warnings.Not_principal msg); + raise Warn_only_once) + equated_types + with Warn_only_once -> () + end; + (ty_args, existential_ctyp) + +let solve_Ppat_record_field ~refine loc env label label_lid record_ty = + with_local_level_iter ~post:generalize_structure begin fun () -> + let (_, ty_arg, ty_res) = instance_label false label in + begin try + unify_pat_types ~refine loc env ty_res (instance record_ty) + with Error(_loc, _env, Pattern_type_clash(err, _)) -> + raise(error(label_lid.loc, !env, + Label_mismatch(label_lid.txt, err))) + end; + (ty_arg, [ty_res; ty_arg]) + end + +let solve_Ppat_array ~refine loc env expected_ty = + let ty_elt = newgenvar() in + let expected_ty = generic_instance expected_ty in + unify_pat_types ~refine + loc env (Predef.type_array ty_elt) expected_ty; + ty_elt + +let solve_Ppat_lazy ~refine loc env expected_ty = + let nv = newgenvar () in + unify_pat_types ~refine loc env (Predef.type_lazy_t nv) + (generic_instance expected_ty); + nv + +let solve_Ppat_constraint ~refine loc env sty expected_ty = + let cty, ty, force = + with_local_level ~post:(fun (_, ty, _) -> generalize_structure ty) + (fun () -> Typetexp.transl_simple_type_delayed !env sty) + in + pattern_force := force :: !pattern_force; + let ty, expected_ty' = instance ty, ty in + unify_pat_types ~refine loc env ty (instance expected_ty); + (cty, ty, expected_ty') + +let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = + let arg_type = if no_arg then [] else [newgenvar()] in + let fields = [tag, rf_either ~no_arg arg_type ~matched:true] in + let make_row more = + create_row ~fields ~closed:false ~more ~fixed:None ~name:None + in + let row = make_row (newgenvar ()) in + let expected_ty = generic_instance expected_ty in + (* PR#7404: allow some_private_tag blindly, as it would not unify with + the abstract row variable *) + if tag <> Parmatch.some_private_tag then + unify_pat_types ~refine loc env (newgenty(Tvariant row)) expected_ty; + (arg_type, make_row (newvar ()), instance expected_ty) + +(* Building the or-pattern corresponding to a polymorphic variant type *) +let build_or_pat env loc lid = + let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in + let tyl = List.map (fun _ -> newvar()) decl.type_params in + let row0 = + let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in + match get_desc ty with + Tvariant row when static_row row -> row + | _ -> raise(error(lid.loc, env, Not_a_polymorphic_variant_type lid.txt)) + in + let pats, fields = + List.fold_left + (fun (pats,fields) (l,f) -> + match row_field_repr f with + Rpresent None -> + let f = rf_either [] ~no_arg:true ~matched:true in + (l,None) :: pats, + (l, f) :: fields + | Rpresent (Some ty) -> + let f = rf_either [ty] ~no_arg:false ~matched:true in + (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; + pat_type=ty; pat_extra=[]; pat_attributes=[]}) + :: pats, + (l, f) :: fields + | _ -> pats, fields) + ([],[]) (row_fields row0) in + let fields = List.rev fields in + let name = Some (path, tyl) in + let make_row more = + create_row ~fields ~more ~closed:false ~fixed:None ~name in + let ty = newty (Tvariant (make_row (newvar()))) in + let gloc = {loc with Location.loc_ghost=true} in + let row' = ref (make_row (newvar())) in + let pats = + List.map + (fun (l,p) -> + {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; + pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]}) + pats + in + match pats with + [] -> + (* empty polymorphic variants: not possible with the concrete language + but valid at the ast level *) + raise(error(lid.loc, env, Not_a_polymorphic_variant_type lid.txt)) + | pat :: pats -> + let r = + List.fold_left + (fun pat pat0 -> + {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[]; + pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]}) + pat pats in + (path, rp { r with pat_loc = loc }) + +let split_cases env cases = + let add_case lst case = function + | None -> lst + | Some c_lhs -> { case with c_lhs } :: lst + in + List.fold_right (fun ({ c_lhs; c_guard } as case) (vals, exns) -> + match split_pattern c_lhs with + | Some _, Some _ when c_guard <> None -> + raise (error (c_lhs.pat_loc, env, + Mixed_value_and_exception_patterns_under_guard)) + | vp, ep -> add_case vals case vp, add_case exns case ep + ) cases ([], []) + +(* Type paths *) + +let rec expand_path env p = + let decl = + try Some (Env.find_type p env) with Not_found -> None + in + match decl with + Some {type_manifest = Some ty} -> + begin match get_desc ty with + Tconstr(p,_,_) -> expand_path env p + | _ -> assert false + end + | _ -> + let p' = Env.normalize_type_path None env p in + if Path.same p p' then p else expand_path env p' + +let compare_type_path env tpath1 tpath2 = + Path.same (expand_path env tpath1) (expand_path env tpath2) + +(* Records *) +exception Wrong_name_disambiguation of Env.t * wrong_name + +let get_constr_type_path ty = + match get_desc ty with + | Tconstr(p, _, _) -> p + | _ -> assert false + +module NameChoice(Name : sig + type t + type usage + val kind: Datatype_kind.t + val get_name: t -> string + val get_type: t -> type_expr + val lookup_all_from_type: + Location.t -> usage -> Path.t -> Env.t -> (t * (unit -> unit)) list + + (** Some names (for example the fields of inline records) are not + in the typing environment -- they behave as structural labels + rather than nominal labels.*) + val in_env: t -> bool +end) = struct + open Name + + let get_type_path d = get_constr_type_path (get_type d) + + let lookup_from_type env type_path usage lid = + let descrs = lookup_all_from_type lid.loc usage type_path env in + match lid.txt with + | Longident.Lident name -> begin + match + List.find (fun (nd, _) -> get_name nd = name) descrs + with + | descr, use -> + use (); + descr + | exception Not_found -> + let valid_names = List.map (fun (nd, _) -> get_name nd) descrs in + raise (Wrong_name_disambiguation (env, { + type_path; + name = { lid with txt = name }; + kind; + valid_names; + })) + end + | _ -> raise Not_found + + let rec unique eq acc = function + [] -> List.rev acc + | x :: rem -> + if List.exists (eq x) acc then unique eq acc rem + else unique eq (x :: acc) rem + + let ambiguous_types env lbl others = + let tpath = get_type_path lbl in + let others = + List.map (fun (lbl, _) -> get_type_path lbl) others in + let tpaths = unique (compare_type_path env) [tpath] others in + match tpaths with + [_] -> [] + | _ -> let open Printtyp in + wrap_printing_env ~error:true env (fun () -> + reset(); strings_of_paths (Some Type) tpaths) + + let disambiguate_by_type env tpath lbls = + match lbls with + | (Error _ : _ result) -> raise Not_found + | Ok lbls -> + let check_type (lbl, _) = + let lbl_tpath = get_type_path lbl in + compare_type_path env tpath lbl_tpath + in + List.find check_type lbls + + (* warn if there are several distinct candidates in scope *) + let warn_if_ambiguous warn lid env lbl rest = + if Warnings.is_active (Ambiguous_name ([],[],false,"")) then begin + Printtyp.Conflicts.reset (); + let paths = ambiguous_types env lbl rest in + let expansion = + Format.asprintf "%t" Printtyp.Conflicts.print_explanations in + if paths <> [] then + warn lid.loc + (Warnings.Ambiguous_name ([Longident.last lid.txt], + paths, false, expansion)) + end + + (* a non-principal type was used for disambiguation *) + let warn_non_principal warn lid = + let name = Datatype_kind.label_name kind in + warn lid.loc + (Warnings.Not_principal + ("this type-based " ^ name ^ " disambiguation")) + + (* we selected a name out of the lexical scope *) + let warn_out_of_scope warn lid env tpath = + if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin + let path_s = + Printtyp.wrap_printing_env ~error:true env + (fun () -> Printtyp.string_of_path tpath) in + warn lid.loc + (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false)) + end + + (* warn if the selected name is not the last introduced in scope + -- in these cases the resolution is different from pre-disambiguation OCaml + (this warning is not enabled by default, it is specifically for people + wishing to write backward-compatible code). + *) + let warn_if_disambiguated_name warn lid lbl scope = + match scope with + | Ok ((lab1,_) :: _) when lab1 == lbl -> () + | _ -> + warn lid.loc + (Warnings.Disambiguated_name (get_name lbl)) + + let force_error : ('a, _) result -> 'a = function + | Ok lbls -> lbls + | Error (loc', env', err) -> + Env.lookup_error loc' env' err + + type candidate = t * (unit -> unit) + type nonempty_candidate_filter = + candidate list -> (candidate list, candidate list) result + (** This type is used for candidate filtering functions. + Filtering typically proceeds in several passes, filtering + candidates through increasingly precise conditions. + + We assume that the input list is non-empty, and the output is one of + - [Ok result] for a non-empty list [result] of valid candidates + - [Error candidates] with there are no valid candidates, + and [candidates] is a non-empty subset of the input, typically + the result of the last non-empty filtering step. + *) + + (** [disambiguate] selects a concrete description for [lid] using + some contextual information: + - An optional [expected_type]. + - A list of candidates labels in the current lexical scope, + [candidates_in_scope], that is actually at the type + [(label_descr list, lookup_error) result] so that the + lookup error is only raised when necessary. + - A filtering criterion on candidates in scope [filter_candidates], + representing extra contextual information that can help + candidate selection (see [disambiguate_label_by_ids]). + *) + let disambiguate + ?(warn=Location.prerr_warning) + ?(filter : nonempty_candidate_filter = Result.ok) + usage lid env + expected_type + candidates_in_scope = + let lbl = match expected_type with + | None -> + (* no expected type => no disambiguation *) + begin match filter (force_error candidates_in_scope) with + | Ok [] | Error [] -> assert false + | Error((lbl, _use) :: _rest) -> lbl (* will fail later *) + | Ok((lbl, use) :: rest) -> + use (); + warn_if_ambiguous warn lid env lbl rest; + lbl + end + | Some(tpath0, tpath, principal) -> + (* If [expected_type] is available, the candidate selected + will correspond to the type-based resolution. + There are two reasons to still check the lexical scope: + - for warning purposes + - for extension types, the type environment does not contain + a list of constructors, so using only type-based selection + would fail. + *) + (* note that [disambiguate_by_type] does not + force [candidates_in_scope]: we just skip this case if there + are no candidates in scope *) + begin match disambiguate_by_type env tpath candidates_in_scope with + | lbl, use -> + use (); + if not principal then begin + (* Check if non-principal type is affecting result *) + match (candidates_in_scope : _ result) with + | Error _ -> warn_non_principal warn lid + | Ok lbls -> + match filter lbls with + | Error _ -> warn_non_principal warn lid + | Ok [] -> assert false + | Ok ((lbl', _use') :: rest) -> + let lbl_tpath = get_type_path lbl' in + (* no principality warning if the non-principal + type-based selection corresponds to the last + definition in scope *) + if not (compare_type_path env tpath lbl_tpath) + then warn_non_principal warn lid + else warn_if_ambiguous warn lid env lbl rest; + end; + lbl + | exception Not_found -> + (* look outside the lexical scope *) + match lookup_from_type env tpath usage lid with + | lbl -> + (* warn only on nominal labels; + structural labels cannot be qualified anyway *) + if in_env lbl then warn_out_of_scope warn lid env tpath; + if not principal then warn_non_principal warn lid; + lbl + | exception Not_found -> + match filter (force_error candidates_in_scope) with + | Ok lbls | Error lbls -> + let tp = (tpath0, expand_path env tpath) in + let tpl = + List.map + (fun (lbl, _) -> + let tp0 = get_type_path lbl in + let tp = expand_path env tp0 in + (tp0, tp)) + lbls + in + raise (error (lid.loc, env, + Name_type_mismatch (kind, lid.txt, tp, tpl))); + end + in + (* warn only on nominal labels *) + if in_env lbl then + warn_if_disambiguated_name warn lid lbl candidates_in_scope; + lbl +end + +let wrap_disambiguate msg ty f x = + try f x with + | Wrong_name_disambiguation (env, wrong_name) -> + raise (error (wrong_name.name.loc, env, Wrong_name (msg, ty, wrong_name))) + +module Label = NameChoice (struct + type t = label_description + type usage = Env.label_usage + let kind = Datatype_kind.Record + let get_name lbl = lbl.lbl_name + let get_type lbl = lbl.lbl_res + let lookup_all_from_type loc usage path env = + Env.lookup_all_labels_from_type ~loc usage path env + let in_env lbl = + match lbl.lbl_repres with + | Record_regular | Record_float | Record_unboxed false -> true + | Record_unboxed true | Record_inlined _ | Record_extension _ -> false +end) + +(* In record-construction expressions and patterns, we have many labels + at once; find a candidate type in the intersection of the candidates + of each label. In the [closed] expression case, this candidate must + contain exactly all the labels. + + If our successive refinements result in an empty list, + return [Error] with the last non-empty list of candidates + for use in error messages. +*) +let disambiguate_label_by_ids closed ids labels : (_, _) result = + let check_ids (lbl, _) = + let lbls = Hashtbl.create 8 in + Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all; + List.for_all (Hashtbl.mem lbls) ids + and check_closed (lbl, _) = + (not closed || List.length ids = Array.length lbl.lbl_all) + in + match List.filter check_ids labels with + | [] -> Error labels + | labels -> + match List.filter check_closed labels with + | [] -> Error labels + | labels -> + Ok labels + +(* Only issue warnings once per record constructor/pattern *) +let disambiguate_lid_a_list loc closed env usage expected_type lid_a_list = + let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in + let w_pr = ref false and w_amb = ref [] + and w_scope = ref [] and w_scope_ty = ref "" in + let warn loc msg = + let open Warnings in + match msg with + | Not_principal _ -> w_pr := true + | Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb + | Name_out_of_scope(ty, [s], _) -> + w_scope := s :: !w_scope; w_scope_ty := ty + | _ -> Location.prerr_warning loc msg + in + let process_label lid = + let scope = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in + let filter : Label.nonempty_candidate_filter = + disambiguate_label_by_ids closed ids in + Label.disambiguate ~warn ~filter usage lid env expected_type scope in + let lbl_a_list = + (* If one label is qualified [{ foo = ...; M.bar = ... }], + we will disambiguate all labels using one of the qualifying modules, + as if the user had written [{ M.foo = ...; M.bar = ... }]. + + #11630: It is important to process first the + user-qualified labels, instead of processing all labels in + order, so that error messages coming from the lookup of + M (maybe no such module/path exists) are shown to the user + in context of a qualified field [M.bar] they wrote + themselves, instead of the "ghost" qualification [M.foo] + that does not come from the source program. *) + let lbl_list = + List.map (fun (lid, _) -> + match lid.txt with + | Longident.Ldot _ -> Some (process_label lid) + | _ -> None + ) lid_a_list + in + (* Find a module prefix (if any) to qualify unqualified labels *) + let qual = + List.find_map (function + | {txt = Longident.Ldot (modname, _); _}, _ -> Some modname + | _ -> None + ) lid_a_list + in + (* Prefix unqualified labels with [qual] and resolve them. + + Prefixing unqualified labels does not change the final + disambiguation result, it restricts the set of candidates + without removing any valid choice. + It matters if users activated warnings for ambiguous or + out-of-scope resolutions -- they get less warnings by + qualifying at least one of the fields. *) + List.map2 (fun lid_a lbl -> + match lbl, lid_a with + | Some lbl, (lid, a) -> lid, lbl, a + | None, (lid, a) -> + let qual_lid = + match qual, lid.txt with + | Some modname, Longident.Lident s -> + {lid with txt = Longident.Ldot (modname, s)} + | _ -> lid + in + lid, process_label qual_lid, a + ) lid_a_list lbl_list + in + if !w_pr then + Location.prerr_warning loc + (Warnings.Not_principal "this type-based record disambiguation") + else begin + match List.rev !w_amb with + (_,types,ex)::_ as amb -> + let paths = + List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in + let path = List.hd paths in + let fst3 (x,_,_) = x in + if List.for_all (compare_type_path env path) (List.tl paths) then + Location.prerr_warning loc + (Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex)) + else + List.iter + (fun (s,l,ex) -> Location.prerr_warning loc + (Warnings.Ambiguous_name ([s],l,false, ex))) + amb + | _ -> () + end; + if !w_scope <> [] then + Location.prerr_warning loc + (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true)); + lbl_a_list + +let map_fold_cont f xs k = + List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys))) + xs (fun ys -> k (List.rev ys)) [] + +let type_label_a_list loc closed env usage type_lbl_a expected_type lid_a_list = + let lbl_a_list = + disambiguate_lid_a_list loc closed env usage expected_type lid_a_list + in + (* Invariant: records are sorted in the typed tree *) + let lbl_a_list = + List.sort + (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) + lbl_a_list + in + List.map type_lbl_a lbl_a_list + +(* Checks over the labels mentioned in a record pattern: + no duplicate definitions (error); properly closed (warning) *) + +let check_recordpat_labels loc lbl_pat_list closed = + match lbl_pat_list with + | [] -> () (* should not happen *) + | (_, label1, _) :: _ -> + let all = label1.lbl_all in + let defined = Array.make (Array.length all) false in + let check_defined (_, label, _) = + if defined.(label.lbl_pos) + then raise(error(loc, Env.empty, Label_multiply_defined label.lbl_name)) + else defined.(label.lbl_pos) <- true in + List.iter check_defined lbl_pat_list; + if closed = Closed + && Warnings.is_active (Warnings.Missing_record_field_pattern "") + then begin + let undefined = ref [] in + for i = 0 to Array.length all - 1 do + if not defined.(i) then undefined := all.(i).lbl_name :: !undefined + done; + if !undefined <> [] then begin + let u = String.concat ", " (List.rev !undefined) in + Location.prerr_warning loc (Warnings.Missing_record_field_pattern u) + end + end + +(* Constructors *) + +module Constructor = NameChoice (struct + type t = constructor_description + type usage = Env.constructor_usage + let kind = Datatype_kind.Variant + let get_name cstr = cstr.cstr_name + let get_type cstr = cstr.cstr_res + let lookup_all_from_type loc usage path env = + match Env.lookup_all_constructors_from_type ~loc usage path env with + | _ :: _ as x -> x + | [] -> + match (Env.find_type path env).type_kind with + | Type_open -> + (* Extension constructors cannot be found by looking at the type + declaration. + We scan the whole environment to get an accurate spellchecking + hint in the subsequent error message *) + let filter lbl = + compare_type_path env + path (get_constr_type_path @@ get_type lbl) in + let add_valid x acc = if filter x then (x,ignore)::acc else acc in + Env.fold_constructors add_valid None env [] + | _ -> [] + let in_env _ = true +end) + +(* Typing of patterns *) + +(* "half typed" cases are produced in [type_cases] when we've just typechecked + the pattern but haven't type-checked the body yet. + At this point we might have added some type equalities to the environment, + but haven't yet added identifiers bound by the pattern. *) +type 'case_pattern half_typed_case = + { typed_pat: 'case_pattern; + pat_type_for_unif: type_expr; + untyped_case: Parsetree.case; + branch_env: Env.t; + pat_vars: pattern_variable list; + module_vars: module_variable list; + contains_gadt: bool; } + +let rec has_literal_pattern p = match p.ppat_desc with + | Ppat_constant _ + | Ppat_interval _ -> + true + | Ppat_any + | Ppat_variant (_, None) + | Ppat_construct (_, None) + | Ppat_type _ + | Ppat_var _ + | Ppat_unpack _ + | Ppat_extension _ -> + false + | Ppat_exception p + | Ppat_variant (_, Some p) + | Ppat_construct (_, Some (_, p)) + | Ppat_constraint (p, _) + | Ppat_alias (p, _) + | Ppat_lazy p + | Ppat_open (_, p) -> + has_literal_pattern p + | Ppat_tuple ps + | Ppat_array ps -> + List.exists has_literal_pattern ps + | Ppat_record (ps, _) -> + List.exists (fun (_,p) -> has_literal_pattern p) ps + | Ppat_or (p, q) -> + has_literal_pattern p || has_literal_pattern q + +let check_scope_escape loc env level ty = + try Ctype.check_scope_escape env level ty + with Escape esc -> + (* We don't expand the type here because if we do, we might expand to the + type that escaped, leading to confusing error messages. *) + let trace = Errortrace.[Escape (map_escape trivial_expansion esc)] in + raise (error(loc, + env, + Pattern_type_clash(Errortrace.unification_error ~trace, None))) + + +(** The typedtree has two distinct syntactic categories for patterns, + "value" patterns, matching on values, and "computation" patterns + that match on the effect of a computation -- typically, exception + patterns (exception p). + + On the other hand, the parsetree has an unstructured representation + where all categories of patterns are mixed together. The + decomposition according to the value/computation structure has to + happen during type-checking. + + We don't want to duplicate the type-checking logic in two different + functions, depending on the kind of pattern to be produced. In + particular, there are both value and computation or-patterns, and + the type-checking logic for or-patterns is horribly complex; having + it in two different places would be twice as horirble. + + The solution is to pass a GADT tag to [type_pat] to indicate whether + a value or computation pattern is expected. This way, there is a single + place where [Ppat_or] nodes are type-checked, the checking logic is shared, + and only at the end do we inspect the tag to decide to produce a value + or computation pattern. +*) +let pure + : type k . k pattern_category -> value general_pattern -> k general_pattern + = fun category pat -> + match category with + | Value -> pat + | Computation -> as_computation_pattern pat + +let only_impure + : type k . k pattern_category -> + computation general_pattern -> k general_pattern + = fun category pat -> + match category with + | Value -> + (* LATER: this exception could be renamed/generalized *) + raise (error (pat.pat_loc, pat.pat_env, + Exception_pattern_disallowed)) + | Computation -> pat + +let as_comp_pattern + : type k . k pattern_category -> + k general_pattern -> computation general_pattern + = fun category pat -> + match category with + | Value -> as_computation_pattern pat + | Computation -> pat + +(** [type_pat] propagates the expected type, and + unification may update the typing environment. *) +let rec type_pat + : type k . k pattern_category -> + no_existentials: existential_restriction option -> + env: Env.t ref -> Parsetree.pattern -> type_expr -> k general_pattern + = fun category ~no_existentials ~env sp expected_ty -> + Msupport.with_saved_types + ~warning_attribute:sp.ppat_attributes ?save_part:None + (fun () -> + let saved = save_levels () in + try + type_pat_aux category ~no_existentials ~env sp expected_ty + with Error _ as exn -> + (* We only want to catch error, not internal exceptions such as + [Need_backtrack], etc. *) + Msupport.erroneous_type_register expected_ty; + raise_error exn; + set_levels saved; + let loc = sp.ppat_loc in + let pat = + { + pat_desc = Tpat_any; + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_env = !env; + pat_attributes = Msupport.recovery_attributes sp.ppat_attributes; + } + in + (match category with + | Value -> pat + | Computation -> as_computation_pattern pat) + ) + +and type_pat_aux + : type k . k pattern_category -> no_existentials:_ -> + env:_ -> _ -> _ -> k general_pattern + = fun category ~no_existentials ~env sp expected_ty -> + let type_pat category ?(env=env) = + type_pat category ~no_existentials ~env + in + let loc = sp.ppat_loc in + let refine = None in + let solve_expected (x : pattern) : pattern = + unify_pat ~refine ~sdesc_for_hint:sp.ppat_desc env x (instance expected_ty); + x + in + let crp (x : k general_pattern) : k general_pattern = + match category with + | Value -> rp x + | Computation -> rcp x + in + (* record {general,value,computation} pattern *) + let rp = crp + and rvp x = crp (pure category x) + and rcp x = crp (only_impure category x) in + match sp.ppat_desc with + Ppat_any -> + rvp { + pat_desc = Tpat_any; + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_var name -> + let ty = instance expected_ty in + let id = enter_variable loc name ty sp.ppat_attributes in + rvp { + pat_desc = Tpat_var (id, name); + pat_loc = loc; pat_extra=[]; + pat_type = ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_unpack name -> + let t = instance expected_ty in + begin match name.txt with + | None -> + rvp { + pat_desc = Tpat_any; + pat_loc = sp.ppat_loc; + pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes]; + pat_type = t; + pat_attributes = []; + pat_env = !env } + | Some s -> + let v = { name with txt = s } in + (* We're able to pass ~is_module:true here without an error because + [Ppat_unpack] is a case identified by [may_contain_modules]. See + the comment on [may_contain_modules]. *) + let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in + rvp { + pat_desc = Tpat_var (id, v); + pat_loc = sp.ppat_loc; + pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; + pat_type = t; + pat_attributes = []; + pat_env = !env } + end + | Ppat_constraint( + {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs}, + ({ptyp_desc=Ptyp_poly _} as sty)) -> + (* explicitly polymorphic type *) + let cty, ty, ty' = + solve_Ppat_poly_constraint ~refine env lloc sty expected_ty in + let id = enter_variable lloc name ty' attrs in + rvp { pat_desc = Tpat_var (id, name); + pat_loc = lloc; + pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes]; + pat_type = ty; + pat_attributes = []; + pat_env = !env } + | Ppat_alias(sq, name) -> + let q = type_pat Value sq expected_ty in + let ty_var = solve_Ppat_alias ~refine env q in + let id = + enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes + in + rvp { pat_desc = Tpat_alias(q, id, name); + pat_loc = loc; pat_extra=[]; + pat_type = q.pat_type; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_constant cst -> + let cst = constant_or_raise !env loc cst in + rvp @@ solve_expected { + pat_desc = Tpat_constant cst; + pat_loc = loc; pat_extra=[]; + pat_type = type_constant cst; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_interval (Pconst_char c1, Pconst_char c2) -> + let open Ast_helper.Pat in + let gloc = {loc with Location.loc_ghost=true} in + let rec loop c1 c2 = + if c1 = c2 then constant ~loc:gloc (Pconst_char c1) + else + or_ ~loc:gloc + (constant ~loc:gloc (Pconst_char c1)) + (loop (Char.chr(Char.code c1 + 1)) c2) + in + let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in + let p = {p with ppat_loc=loc} in + type_pat category p expected_ty + (* TODO: record 'extra' to remember about interval *) + | Ppat_interval _ -> + raise (error (loc, !env, Invalid_interval)) + | Ppat_tuple spl -> + assert (List.length spl >= 2); + let expected_tys = solve_Ppat_tuple ~refine loc env spl expected_ty in + let pl = List.map2 (type_pat Value) spl expected_tys in + rvp { + pat_desc = Tpat_tuple pl; + pat_loc = loc; pat_extra=[]; + pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl)); + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_construct(lid, sarg) -> + let expected_type = + match extract_concrete_variant !env expected_ty with + | Variant_type(p0, p, _) -> + Some (p0, p, is_principal expected_ty) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let err = Wrong_expected_kind(srt, Pattern, expected_ty) in + raise (error (loc, !env, err)) + in + let constr = + let candidates = + Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env in + wrap_disambiguate "This variant pattern is expected to have" + (mk_expected expected_ty) + (Constructor.disambiguate Env.Pattern lid !env expected_type) + candidates + in + begin match no_existentials, constr.cstr_existentials with + | None, _ | _, [] -> () + | Some r, (_ :: _ as exs) -> + let exs = List.map (Ctype.existential_name constr) exs in + let name = constr.cstr_name in + raise (error (loc, !env, Unexpected_existential (r, name, exs))) + end; + let sarg', existential_styp = + match sarg with + None -> None, None + | Some (vl, {ppat_desc = Ppat_constraint (sp, sty)}) + when vl <> [] || constr.cstr_arity > 1 -> + Some sp, Some (vl, sty) + | Some ([], sp) -> + Some sp, None + | Some (_, sp) -> + raise (error (sp.ppat_loc, !env, Missing_type_constraint)) + in + let sargs = + match sarg' with + None -> [] + | Some {ppat_desc = Ppat_tuple spl} when + constr.cstr_arity > 1 || + Builtin_attributes.explicit_arity sp.ppat_attributes + -> spl + | Some({ppat_desc = Ppat_any} as sp) when + constr.cstr_arity = 0 && existential_styp = None + -> + Location.prerr_warning sp.ppat_loc + Warnings.Wildcard_arg_to_constant_constr; + [] + | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 -> + replicate_list sp constr.cstr_arity + | Some sp -> [sp] in + if Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes then + begin match List.filter has_literal_pattern sargs with + | sp :: _ -> + Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern + | _ -> () + end; + if List.length sargs <> constr.cstr_arity then + raise(error(loc, !env, Constructor_arity_mismatch(lid.txt, + constr.cstr_arity, List.length sargs))); + + let (ty_args, existential_ctyp) = + solve_Ppat_construct ~refine env loc constr no_existentials + existential_styp expected_ty + in + + let rec check_non_escaping p = + match p.ppat_desc with + | Ppat_or (p1, p2) -> + check_non_escaping p1; + check_non_escaping p2 + | Ppat_alias (p, _) -> + check_non_escaping p + | Ppat_constraint _ -> + raise (error (p.ppat_loc, !env, Inlined_record_escape)) + | _ -> + () + in + if constr.cstr_inlined <> None then begin + List.iter check_non_escaping sargs; + Option.iter (fun (_, sarg) -> check_non_escaping sarg) sarg + end; + + let args = List.map2 (type_pat Value) sargs ty_args in + rvp { pat_desc=Tpat_construct(lid, constr, args, existential_ctyp); + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_variant(tag, sarg) -> + assert (tag <> Parmatch.some_private_tag); + let constant = (sarg = None) in + let arg_type, row, pat_type = + solve_Ppat_variant ~refine loc env tag constant expected_ty in + let arg = + (* PR#6235: propagate type information *) + match sarg, arg_type with + Some sp, [ty] -> Some (type_pat Value sp ty) + | _ -> None + in + rvp { + pat_desc = Tpat_variant(tag, arg, ref row); + pat_loc = loc; pat_extra = []; + pat_type = pat_type; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_record(lid_sp_list, closed) -> + assert (lid_sp_list <> []); + let expected_type, record_ty = + match extract_concrete_record !env expected_ty with + | Record_type(p0, p, _) -> + let ty = generic_instance expected_ty in + Some (p0, p, is_principal expected_ty), ty + | Maybe_a_record_type -> None, newvar () + | Not_a_record_type -> + let err = Wrong_expected_kind(Record, Pattern, expected_ty) in + raise (error (loc, !env, err)) + in + let type_label_pat (label_lid, label, sarg) = + let ty_arg = + solve_Ppat_record_field ~refine loc env label label_lid record_ty in + (label_lid, label, type_pat Value sarg ty_arg) + in + let make_record_pat lbl_pat_list = + check_recordpat_labels loc lbl_pat_list closed; + { + pat_desc = Tpat_record (lbl_pat_list, closed); + pat_loc = loc; pat_extra=[]; + pat_type = instance record_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + } + in + let lbl_a_list = + wrap_disambiguate "This record pattern is expected to have" + (mk_expected expected_ty) + (type_label_a_list loc false !env Env.Projection + type_label_pat expected_type) + lid_sp_list + in + rvp @@ solve_expected (make_record_pat lbl_a_list) + | Ppat_array spl -> + let ty_elt = solve_Ppat_array ~refine loc env expected_ty in + let pl = List.map (fun p -> type_pat Value p ty_elt) spl in + rvp { + pat_desc = Tpat_array pl; + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_or(sp1, sp2) -> + let initial_pattern_variables = !pattern_variables in + let initial_module_variables = !module_variables in + let equation_level = !gadt_equations_level in + let outter_lev = get_current_level () in + (* Introduce a new scope using with_local_level without generalizations *) + let env1, p1, p1_variables, p1_module_variables, env2, p2 = + with_local_level begin fun () -> + let lev = get_current_level () in + gadt_equations_level := Some lev; + let type_pat_rec env sp = type_pat category sp expected_ty ~env in + let env1 = ref !env in + let p1 = type_pat_rec env1 sp1 in + let p1_variables = !pattern_variables in + let p1_module_variables = !module_variables in + pattern_variables := initial_pattern_variables; + module_variables := initial_module_variables; + let env2 = ref !env in + let p2 = type_pat_rec env2 sp2 in + (env1, p1, p1_variables, p1_module_variables, env2, p2) + end + in + gadt_equations_level := equation_level; + let p2_variables = !pattern_variables in + (* Make sure no variable with an ambiguous type gets added to the + environment. *) + List.iter (fun { pv_type; pv_loc; _ } -> + check_scope_escape pv_loc !env1 outter_lev pv_type + ) p1_variables; + List.iter (fun { pv_type; pv_loc; _ } -> + check_scope_escape pv_loc !env2 outter_lev pv_type + ) p2_variables; + let alpha_env = + enter_orpat_variables loc !env p1_variables p2_variables in + let p2 = alpha_pat alpha_env p2 in + pattern_variables := p1_variables; + module_variables := p1_module_variables; + rp { pat_desc = Tpat_or (p1, p2, None); + pat_loc = loc; pat_extra = []; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_lazy sp1 -> + let nv = solve_Ppat_lazy ~refine loc env expected_ty in + let p1 = type_pat Value sp1 nv in + rvp { + pat_desc = Tpat_lazy p1; + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_constraint(sp, sty) -> + (* Pretend separate = true *) + let cty, ty, expected_ty' = + solve_Ppat_constraint ~refine loc env sty expected_ty in + let p = type_pat category sp expected_ty' in + let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in + begin match category, (p : k general_pattern) with + | Value, {pat_desc = Tpat_var (id,s); _} -> + { p with + pat_type = ty; + pat_desc = + Tpat_alias + ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s); + pat_extra = [extra]; + } + | _, p -> + { p with pat_type = ty; pat_extra = extra::p.pat_extra } + end + | Ppat_type lid -> + let (path, p) = build_or_pat !env loc lid in + pure category @@ solve_expected + { p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) + :: p.pat_extra } + | Ppat_open (lid,p) -> + let path, new_env = + !type_open Asttypes.Fresh !env sp.ppat_loc lid in + env := new_env; + let p = type_pat category ~env p expected_ty in + let new_env = !env in + begin match Env.remove_last_open path new_env with + | None -> assert false + | Some closed_env -> env := closed_env + end; + { p with pat_extra = (Tpat_open (path,lid,new_env), + loc, sp.ppat_attributes) :: p.pat_extra } + | Ppat_exception p -> + let p_exn = type_pat Value p Predef.type_exn in + rcp { + pat_desc = Tpat_exception p_exn; + pat_loc = sp.ppat_loc; + pat_extra = []; + pat_type = expected_ty; + pat_env = !env; + pat_attributes = sp.ppat_attributes; + } + | Ppat_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +let type_pat category ?no_existentials + ?(lev=get_current_level()) env sp expected_ty = + Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] + (fun () -> type_pat category ~no_existentials ~env sp expected_ty) + +let iter_pattern_variables_type f : pattern_variable list -> unit = + List.iter (fun {pv_type; _} -> f pv_type) + +let add_pattern_variables ?check ?check_as env pv = + List.fold_right + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env -> + let check = if pv_as_var then check_as else check in + Env.add_value ?check pv_id + {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc; + val_attributes = pv_attributes; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } env + ) + pv env + +let add_module_variables env module_variables = + List.fold_left (fun env { mv_id; mv_loc; mv_name; mv_uid } -> + Typetexp.TyVarEnv.with_local_scope begin fun () -> + (* This code is parallel to the typing of Pexp_letmodule. However we + omit the call to [Mtype.lower_nongen] as it's not necessary here. + For Pexp_letmodule, the call to [type_module] is done in a raised + level and so needs to be modified to have the correct, outer level. + Here, on the other hand, we're calling [type_module] outside the + raised level, so there's no extra step to take. + *) + let modl, md_shape = + !type_module env + Ast_helper.( + Mod.unpack ~loc:mv_loc + (Exp.ident ~loc:mv_name.loc + (mkloc (Longident.Lident mv_name.txt) + mv_name.loc))) + in + let pres = + match modl.mod_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let md = + { md_type = modl.mod_type; md_attributes = []; + md_loc = mv_name.loc; + md_uid = mv_uid; } + in + Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md env + end + ) env module_variables + +let type_pattern category ~lev env spat expected_ty allow_modules = + reset_pattern allow_modules; + let new_env = ref env in + let pat = type_pat category ~lev new_env spat expected_ty in + let pvs = get_ref pattern_variables in + let mvs = get_ref module_variables in + (pat, !new_env, get_ref pattern_force, pvs, mvs) + +let type_pattern_list + category no_existentials env spatl expected_tys allow_modules + = + reset_pattern allow_modules; + let new_env = ref env in + let type_pat (attrs, pat) ty = + Builtin_attributes.warning_scope ~ppwarning:false attrs + (fun () -> + type_pat category ~no_existentials new_env pat ty + ) + in + let patl = List.map2 type_pat spatl expected_tys in + let pvs = get_ref pattern_variables in + let mvs = get_ref module_variables in + (patl, !new_env, get_ref pattern_force, pvs, mvs) + +let type_class_arg_pattern cl_num val_env met_env l spat = + reset_pattern Modules_rejected; + let nv = newvar () in + let pat = + type_pat Value ~no_existentials:In_class_args (ref val_env) spat nv in + if has_variants pat then begin + Parmatch.pressure_variants val_env [pat]; + finalize_variants pat; + end; + List.iter (fun f -> f()) (get_ref pattern_force); + if is_optional l then unify_pat (ref val_env) pat (type_option (newvar ())); + let (pv, val_env, met_env) = + List.fold_right + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} + (pv, val_env, met_env) -> + let check s = + if pv_as_var then Warnings.Unused_var s + else Warnings.Unused_var_strict s in + let id' = Ident.rename pv_id in + let val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let val_env = + Env.add_value pv_id + { val_type = pv_type + ; val_kind = Val_reg + ; val_attributes = pv_attributes + ; val_loc = pv_loc + ; val_uid + } + val_env + in + let met_env = + Env.add_value id' ~check + { val_type = pv_type + ; val_kind = Val_ivar (Immutable, cl_num) + ; val_attributes = pv_attributes + ; val_loc = pv_loc + ; val_uid + } + met_env + in + ((id', pv_id, pv_type)::pv, val_env, met_env)) + !pattern_variables ([], val_env, met_env) + in + (pat, pv, val_env, met_env) + +let type_self_pattern env spat = + let open Ast_helper in + let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in + reset_pattern Modules_rejected; + let nv = newvar() in + let pat = + type_pat Value ~no_existentials:In_self_pattern (ref env) spat nv in + List.iter (fun f -> f()) (get_ref pattern_force); + let pv = !pattern_variables in + pattern_variables := []; + pat, pv + +type delayed_check = ((unit -> unit) * Warnings.state) + + +(** In [check_counter_example_pat], we will check a counter-example candidate + produced by Parmatch. This is a pattern that represents a set of values by + using or-patterns (p_1 | ... | p_n) to enumerate all alternatives in the + counter-example search. These or-patterns occur at every choice point, + possibly deep inside the pattern. + + Parmatch does not use type information, so this pattern may + exhibit two issues: + - some parts of the pattern may be ill-typed due to GADTs, and + - some wildcard patterns may not match any values: their type is + empty. + + The aim of [check_counter_example_pat] is to refine this untyped pattern + into a well-typed pattern, and ensure that it matches at least one + concrete value. + - It filters ill-typed branches of or-patterns. + (see {!splitting_mode} below) + - It tries to check that wildcard patterns are non-empty. + (see {!explosion_fuel}) + *) + +type counter_example_checking_info = { + explosion_fuel: int; + splitting_mode: splitting_mode; + } +(** + [explosion_fuel] controls the checking of wildcard patterns. We + eliminate potentially-empty wildcard patterns by exploding them + into concrete sub-patterns, for example (K1 _ | K2 _) or + { l1: _; l2: _ }. [explosion_fuel] is the depth limit on wildcard + explosion. Such depth limit is required to avoid non-termination + and compilation-time blowups. + + [splitting_mode] controls the handling of or-patterns. In + [Counter_example] mode, we only need to select one branch that + leads to a well-typed pattern. Checking all branches is expensive, + we use different search strategies (see {!splitting_mode}) to + reduce the number of explored alternatives. + *) + +(** Due to GADT constraints, an or-pattern produced within + a counter-example may have ill-typed branches. Consider for example + + {[ + type _ tag = Int : int tag | Bool : bool tag + ]} + + then [Parmatch] will propose the or-pattern [Int | Bool] whenever + a pattern of type [tag] is required to form a counter-example. For + example, a function expects a (int tag option) and only [None] is + handled by the user-written pattern. [Some (Int | Bool)] is not + well-typed in this context, only the sub-pattern [Some Int] is. + In this example, the expected type coming from the context + suffices to know which or-pattern branch must be chosen. + + In the general case, choosing a branch can have non-local effects + on the typability of the term. For example, consider a tuple type + ['a tag * ...'a...], where the first component is a GADT. All + constructor choices for this GADT lead to a well-typed branch in + isolation (['a] is unconstrained), but choosing one of them adds + a constraint on ['a] that may make the other tuple elements + ill-typed. + + In general, after choosing each possible branch of the or-pattern, + [check_counter_example_pat] has to check the rest of the pattern to + tell if this choice leads to a well-typed term. This may lead to an + explosion of typing/search work -- the rest of the term may in turn + contain alternatives. + + We use careful strategies to try to limit counterexample-checking + time; [splitting_mode] represents those strategies. +*) +and splitting_mode = + | Backtrack_or + (** Always backtrack in or-patterns. + + [Backtrack_or] selects a single alternative from an or-pattern + by using backtracking, trying to choose each branch in turn, and + to complete it into a valid sub-pattern. We call this + "splitting" the or-pattern. + + We use this mode when looking for unused patterns or sub-patterns, + in particular to check a refutation clause (p -> .). + *) + | Refine_or of { inside_nonsplit_or: bool; } + (** Only backtrack when needed. + + [Refine_or] tries another approach for refining or-pattern. + + Instead of always splitting each or-pattern, It first attempts to + find branches that do not introduce new constraints (because they + do not contain GADT constructors). Those branches are such that, + if they fail, all other branches will fail. + + If we find one such branch, we attempt to complete the subpattern + (checking what's outside the or-pattern), ignoring other + branches -- we never consider another branch choice again. If all + branches are constrained, it falls back to splitting the + or-pattern. + + We use this mode when checking exhaustivity of pattern matching. + *) + +(** This exception is only used internally within [check_counter_example_pat], + to jump back to the parent or-pattern in the [Refine_or] strategy. + + Such a parent exists precisely when [inside_nonsplit_or = true]; + it's an invariant that we always setup an exception handler for + [Need_backtrack] when we set this flag. *) +exception Need_backtrack + +(** This exception is only used internally within [check_counter_example_pat]. + We use it to discard counter-example candidates that do not match any + value. *) +exception Empty_branch + +type abort_reason = Adds_constraints | Empty + +(** Remember current typing state for backtracking. + No variable information, as we only backtrack on + patterns without variables (cf. assert statements). + In the GADT mode, [env] may be extended by unification, + and therefore it needs to be saved along with a [snapshot]. *) +type unification_state = + { snapshot: snapshot; + env: Env.t; } +let save_state env = + { snapshot = Btype.snapshot (); + env = !env; } +let set_state s env = + Btype.backtrack s.snapshot; + env := s.env + +(** Find the first alternative in the tree of or-patterns for which + [f] does not raise an error. If all fail, the last error is + propagated *) +let rec find_valid_alternative f pat = + match pat.pat_desc with + | Tpat_or(p1,p2,_) -> + (try find_valid_alternative f p1 with + | Empty_branch | Error _ -> find_valid_alternative f p2 + ) + | _ -> f pat + +let no_explosion info = { info with explosion_fuel = 0 } + +let enter_nonsplit_or info = + let splitting_mode = match info.splitting_mode with + | Backtrack_or -> + (* in Backtrack_or mode, or-patterns are always split *) + assert false + | Refine_or _ -> + Refine_or {inside_nonsplit_or = true} + in { info with splitting_mode } + +let rec check_counter_example_pat ~info ~env tp expected_ty k = + let check_rec ?(info=info) ?(env=env) = + check_counter_example_pat ~info ~env in + let loc = tp.pat_loc in + let refine = Some true in + let solve_expected (x : pattern) : pattern = + unify_pat ~refine env x (instance expected_ty); + x + in + (* "make pattern" and "make pattern then continue" *) + let mp ?(pat_type = expected_ty) desc = + { pat_desc = desc; pat_loc = loc; pat_extra=[]; + pat_type = instance pat_type; pat_attributes = []; pat_env = !env } in + let mkp k ?pat_type desc = k (mp ?pat_type desc) in + let must_backtrack_on_gadt = + match info.splitting_mode with + | Backtrack_or -> false + | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or + in + match tp.pat_desc with + Tpat_any | Tpat_var _ -> + let k' () = mkp k tp.pat_desc in + if info.explosion_fuel <= 0 then k' () else + let decrease n = {info with explosion_fuel = info.explosion_fuel - n} in + begin match Parmatch.pats_of_type !env expected_ty with + | [] -> raise Empty_branch + | [{pat_desc = Tpat_any}] -> k' () + | [tp] -> check_rec ~info:(decrease 1) tp expected_ty k + | tp :: tpl -> + if must_backtrack_on_gadt then raise Need_backtrack; + let tp = + List.fold_left + (fun tp tp' -> {tp with pat_desc = Tpat_or (tp, tp', None)}) + tp tpl + in + check_rec ~info:(decrease 5) tp expected_ty k + end + | Tpat_alias (p, _, _) -> check_rec ~info p expected_ty k + | Tpat_constant cst -> + let cst = constant_or_raise !env loc (Untypeast.constant cst) in + k @@ solve_expected (mp (Tpat_constant cst) ~pat_type:(type_constant cst)) + | Tpat_tuple tpl -> + assert (List.length tpl >= 2); + let expected_tys = solve_Ppat_tuple ~refine loc env tpl expected_ty in + let tpl_ann = List.combine tpl expected_tys in + map_fold_cont (fun (p,t) -> check_rec p t) tpl_ann (fun pl -> + mkp k (Tpat_tuple pl) + ~pat_type:(newty (Ttuple(List.map (fun p -> p.pat_type) pl)))) + | Tpat_construct(cstr_lid, constr, targs, _) -> + if constr.cstr_generalized && must_backtrack_on_gadt then + raise Need_backtrack; + let (ty_args, existential_ctyp) = + solve_Ppat_construct ~refine env loc constr None None expected_ty + in + map_fold_cont + (fun (p,t) -> check_rec p t) + (List.combine targs ty_args) + (fun args -> + mkp k (Tpat_construct(cstr_lid, constr, args, existential_ctyp))) + | Tpat_variant(tag, targ, _) -> + let constant = (targ = None) in + let arg_type, row, pat_type = + solve_Ppat_variant ~refine loc env tag constant expected_ty in + let k arg = + mkp k ~pat_type (Tpat_variant(tag, arg, ref row)) + in begin + (* PR#6235: propagate type information *) + match targ, arg_type with + Some p, [ty] -> check_rec p ty (fun p -> k (Some p)) + | _ -> k None + end + | Tpat_record(fields, closed) -> + let record_ty = generic_instance expected_ty in + let type_label_pat (label_lid, label, targ) k = + let ty_arg = + solve_Ppat_record_field ~refine loc env label label_lid record_ty in + check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) + in + map_fold_cont type_label_pat fields + (fun fields -> mkp k (Tpat_record (fields, closed))) + | Tpat_array tpl -> + let ty_elt = solve_Ppat_array ~refine loc env expected_ty in + map_fold_cont (fun p -> check_rec p ty_elt) tpl + (fun pl -> mkp k (Tpat_array pl)) + | Tpat_or(tp1, tp2, _) -> + (* We are in counter-example mode, but try to avoid backtracking *) + let must_split = + match info.splitting_mode with + | Backtrack_or -> true + | Refine_or _ -> false in + let state = save_state env in + let split_or tp = + let type_alternative pat = + set_state state env; check_rec pat expected_ty k in + find_valid_alternative type_alternative tp + in + if must_split then split_or tp else + let check_rec_result env tp : (_, abort_reason) result = + let info = enter_nonsplit_or info in + match check_rec ~info tp expected_ty ~env (fun x -> x) with + | res -> Ok res + | exception Need_backtrack -> Error Adds_constraints + | exception Empty_branch -> Error Empty + in + let p1 = check_rec_result (ref !env) tp1 in + let p2 = check_rec_result (ref !env) tp2 in + begin match p1, p2 with + | Error Empty, Error Empty -> + raise Empty_branch + | Error Adds_constraints, Error _ + | Error _, Error Adds_constraints -> + let inside_nonsplit_or = + match info.splitting_mode with + | Backtrack_or -> false + | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or in + if inside_nonsplit_or + then raise Need_backtrack + else split_or tp + | Ok p, Error _ + | Error _, Ok p -> + k p + | Ok p1, Ok p2 -> + mkp k (Tpat_or (p1, p2, None)) + end + | Tpat_lazy tp1 -> + let nv = solve_Ppat_lazy ~refine loc env expected_ty in + (* do not explode under lazy: PR#7421 *) + check_rec ~info:(no_explosion info) tp1 nv + (fun p1 -> mkp k (Tpat_lazy p1)) + +let check_counter_example_pat ~counter_example_args + ?(lev=get_current_level()) env tp expected_ty = + Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () -> + check_counter_example_pat + ~info:counter_example_args ~env tp expected_ty (fun x -> x) + ) + +(* this function is passed to Partial.parmatch + to type check gadt nonexhaustiveness *) +let partial_pred ~lev ~allow_modules ~splitting_mode ?(explode=0) + env expected_ty p = + let env = ref env in + let state = save_state env in + let counter_example_args = + { + splitting_mode; + explosion_fuel = explode; + } in + try + reset_pattern allow_modules; + let typed_p = + check_counter_example_pat ~lev ~counter_example_args env p expected_ty in + set_state state env; + (* types are invalidated but we don't need them here *) + Some typed_p + with Error _ | Empty_branch -> + set_state state env; + None + +let check_partial + ?(lev=get_current_level ()) allow_modules env expected_ty loc cases + = + let explode = match cases with [_] -> 5 | _ -> 0 in + let splitting_mode = Refine_or {inside_nonsplit_or = false} in + Parmatch.check_partial + (partial_pred ~lev ~allow_modules ~splitting_mode ~explode env expected_ty) + loc cases + +let check_unused + ?(lev=get_current_level ()) allow_modules env expected_ty cases + = + Parmatch.check_unused + (fun refute pat -> + match + partial_pred ~lev ~allow_modules ~splitting_mode:Backtrack_or ~explode:5 + env expected_ty pat + with + Some pat' when refute -> + raise_error (error (pat.pat_loc, env, Unrefuted_pattern pat')); + Some pat + | r -> r) + cases + +(** Some delayed checks, to be executed after typing the whole + compilation unit or toplevel phrase *) +let delayed_checks = ref [] +let reset_delayed_checks () = delayed_checks := [] +let add_delayed_check f = + delayed_checks := (f, Warnings.backup ()) :: !delayed_checks + +let force_delayed_checks () = + (* checks may change type levels *) + let snap = Btype.snapshot () in + let w_old = Warnings.backup () in + List.iter + (fun (f, w) -> Warnings.restore w; + try f () with exn -> Msupport.raise_error exn) + (List.rev !delayed_checks); + Warnings.restore w_old; + reset_delayed_checks (); + Btype.backtrack snap + +let rec final_subexpression exp = + match exp.exp_desc with + Texp_let (_, _, e) + | Texp_sequence (_, e) + | Texp_try (e, _) + | Texp_ifthenelse (_, e, _) + | Texp_match (_, {c_rhs=e} :: _, _) + | Texp_letmodule (_, _, _, _, e) + | Texp_letexception (_, e) + | Texp_open (_, e) + -> final_subexpression e + | _ -> exp + +(* Generalization criterion for expressions *) + +let rec is_nonexpansive exp = + match exp.exp_desc with + | Texp_ident _ + | Texp_constant _ + | Texp_unreachable + | Texp_function _ + | Texp_array [] + | Texp_hole -> true + | Texp_let(_rec_flag, pat_exp_list, body) -> + List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list && + is_nonexpansive body + | Texp_apply(e, (_,None)::el) -> + is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) + | Texp_match(e, cases, _) -> + (* Not sure this is necessary, if [e] is nonexpansive then we shouldn't + care if there are exception patterns. But the previous version enforced + that there be none, so... *) + let contains_exception_pat pat = + exists_general_pattern { f = fun (type k) (p : k general_pattern) -> + match p.pat_desc with + | Tpat_exception _ -> true + | _ -> false } pat + in + is_nonexpansive e && + List.for_all + (fun {c_lhs; c_guard; c_rhs} -> + is_nonexpansive_opt c_guard && is_nonexpansive c_rhs + && not (contains_exception_pat c_lhs) + ) cases + | Texp_tuple el -> + List.for_all is_nonexpansive el + | Texp_construct( _, _, el) -> + List.for_all is_nonexpansive el + | Texp_variant(_, arg) -> is_nonexpansive_opt arg + | Texp_record { fields; extended_expression } -> + Array.for_all + (fun (lbl, definition) -> + match definition with + | Overridden (_, exp) -> + lbl.lbl_mut = Immutable && is_nonexpansive exp + | Kept _ -> true) + fields + && is_nonexpansive_opt extended_expression + | Texp_field(exp, _, _) -> is_nonexpansive exp + | Texp_ifthenelse(_cond, ifso, ifnot) -> + is_nonexpansive ifso && is_nonexpansive_opt ifnot + | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *) + | Texp_new (_, _, cl_decl) -> Btype.class_type_arity cl_decl.cty_type > 0 + (* Note: nonexpansive only means no _observable_ side effects *) + | Texp_lazy e -> is_nonexpansive e + | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) -> + let count = ref 0 in + List.for_all + (fun field -> match field.cf_desc with + Tcf_method _ -> true + | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) -> + incr count; is_nonexpansive e + | Tcf_val (_, _, _, Tcfk_virtual _, _) -> + incr count; true + | Tcf_initializer e -> is_nonexpansive e + | Tcf_constraint _ -> true + | Tcf_inherit _ -> false + | Tcf_attribute _ -> true) + fields && + Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable) + vars true && + !count = 0 + | Texp_letmodule (_, _, _, mexp, e) + | Texp_open ({ open_expr = mexp; _}, e) -> + is_nonexpansive_mod mexp && is_nonexpansive e + | Texp_pack mexp -> + is_nonexpansive_mod mexp + (* Computations which raise exceptions are nonexpansive, since (raise e) is + equivalent to (raise e; diverge), and a nonexpansive "diverge" can be + produced using lazy values or the relaxed value restriction. + See GPR#1142 *) + | Texp_assert (exp, _) -> + is_nonexpansive exp + | Texp_apply ( + { exp_desc = Texp_ident (_, _, {val_kind = + Val_prim {Primitive.prim_name = + ("%raise" | "%reraise" | "%raise_notrace")}}) }, + [Nolabel, Some e]) -> + is_nonexpansive e + | Texp_array (_ :: _) + | Texp_apply _ + | Texp_try _ + | Texp_setfield _ + | Texp_while _ + | Texp_for _ + | Texp_send _ + | Texp_instvar _ + | Texp_setinstvar _ + | Texp_override _ + | Texp_letexception _ + | Texp_letop _ + | Texp_extension_constructor _ -> + false + +and is_nonexpansive_mod mexp = + match mexp.mod_desc with + | Tmod_ident _ + | Tmod_functor _ + | Tmod_hole -> true + | Tmod_unpack (e, _) -> is_nonexpansive e + | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m + | Tmod_structure str -> + List.for_all + (fun item -> match item.str_desc with + | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ + | Tstr_modtype _ | Tstr_class_type _ -> true + | Tstr_value (_, pat_exp_list) -> + List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list + | Tstr_module {mb_expr=m;_} + | Tstr_open {open_expr=m;_} + | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m + | Tstr_recmodule id_mod_list -> + List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m) + id_mod_list + | Tstr_exception {tyexn_constructor = {ext_kind = Text_decl _}} -> + false (* true would be unsound *) + | Tstr_exception {tyexn_constructor = {ext_kind = Text_rebind _}} -> + true + | Tstr_typext te -> + List.for_all + (function {ext_kind = Text_decl _} -> false + | {ext_kind = Text_rebind _} -> true) + te.tyext_constructors + | Tstr_class _ -> false (* could be more precise *) + | Tstr_attribute _ -> true + ) + str.str_items + | Tmod_apply _ | Tmod_apply_unit _ -> false + +and is_nonexpansive_opt = function + | None -> true + | Some e -> is_nonexpansive e + +let maybe_expansive e = not (is_nonexpansive e) + +let check_recursive_bindings env valbinds = + let ids = let_bound_idents valbinds in + List.iter + (fun {vb_expr} -> + if not (Rec_check.is_valid_recursive_expression ids vb_expr) then + raise(error(vb_expr.exp_loc, env, Illegal_letrec_expr)) + ) + valbinds + +let check_recursive_class_bindings env ids exprs = + List.iter + (fun expr -> + if not (Rec_check.is_valid_class_expr ids expr) then + raise(error(expr.cl_loc, env, Illegal_class_expr))) + exprs + +let is_prim ~name funct = + match funct.exp_desc with + | Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name; _}}) -> + prim_name = name + | _ -> false +(* Approximate the type of an expression, for better recursion *) + +let rec approx_type env sty = + match sty.ptyp_desc with + Ptyp_arrow (p, _, sty) -> + let ty1 = if is_optional p then type_option (newvar ()) else newvar () in + newty (Tarrow (p, ty1, approx_type env sty, commu_ok)) + | Ptyp_tuple args -> + newty (Ttuple (List.map (approx_type env) args)) + | Ptyp_constr (lid, ctl) -> + let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in + if List.length ctl <> decl.type_arity then newvar () + else begin + let tyl = List.map (approx_type env) ctl in + newconstr path tyl + end + | Ptyp_poly (_, sty) -> + approx_type env sty + | _ -> newvar () + +let rec type_approx env sexp = + match sexp.pexp_desc with + Pexp_let (_, _, e) -> type_approx env e + | Pexp_fun (p, _, _, e) -> + let ty = if is_optional p then type_option (newvar ()) else newvar () in + newty (Tarrow(p, ty, type_approx env e, commu_ok)) + | Pexp_function ({pc_rhs=e}::_) -> + newty (Tarrow(Nolabel, newvar (), type_approx env e, commu_ok)) + | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e + | Pexp_try (e, _) -> type_approx env e + | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l)) + | Pexp_ifthenelse (_,e,_) -> type_approx env e + | Pexp_sequence (_,e) -> type_approx env e + | Pexp_constraint (e, sty) -> + let ty = type_approx env e in + let ty1 = approx_type env sty in + begin try unify env ty ty1 with Unify err -> + raise(error(sexp.pexp_loc, env, Expr_type_clash (err, None, None))) + end; + ty1 + | Pexp_coerce (e, sty1, sty2) -> + let approx_ty_opt = function + | None -> newvar () + | Some sty -> approx_type env sty + in + let ty = type_approx env e + and ty1 = approx_ty_opt sty1 + and ty2 = approx_type env sty2 in + begin try unify env ty ty1 with Unify err -> + raise(error(sexp.pexp_loc, env, Expr_type_clash (err, None, None))) + end; + ty2 + | _ -> newvar () + +(* List labels in a function type, and whether return type is a variable *) +let rec list_labels_aux env visited ls ty_fun = + let ty = expand_head env ty_fun in + if TypeSet.mem ty visited then + List.rev ls, false + else match get_desc ty with + Tarrow (l, _, ty_res, _) -> + list_labels_aux env (TypeSet.add ty visited) (l::ls) ty_res + | _ -> + List.rev ls, is_Tvar ty + +let list_labels env ty = + wrap_trace_gadt_instances env (list_labels_aux env TypeSet.empty []) ty + +(* Check that all univars are safe in a type. Both exp.exp_type and + ty_expected should already be generalized. *) +let check_univars env kind exp ty_expected vars = + let pty = instance ty_expected in + let exp_ty, vars = + with_local_level_iter ~post:generalize begin fun () -> + match get_desc pty with + Tpoly (body, tl) -> + (* Enforce scoping for type_let: + since body is not generic, instance_poly only makes + copies of nodes that have a Tunivar as descendant *) + let _, ty' = instance_poly true tl body in + let vars, exp_ty = instance_parameterized_type vars exp.exp_type in + unify_exp_types exp.exp_loc env exp_ty ty'; + ((exp_ty, vars), exp_ty::vars) + | _ -> assert false + end + in + let ty, complete = polyfy env exp_ty vars in + if not complete then + let ty_expected = instance ty_expected in + raise (error(exp.exp_loc, + env, + Less_general(kind, + Errortrace.unification_error + ~trace:[Ctype.expanded_diff env + ~got:ty ~expected:ty_expected]))) + +let generalize_and_check_univars env kind exp ty_expected vars = + generalize exp.exp_type; + generalize ty_expected; + List.iter generalize vars; + check_univars env kind exp ty_expected vars + +(* [check_statement] implements the [non-unit-statement] check. + + This check is called in contexts where the value of the expression is known + to be discarded (eg. the lhs of a sequence). We check that [exp] has type + unit, or has an explicit type annotation; otherwise we raise the + [non-unit-statement] warning. *) + +let check_statement exp = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () + | Tvar _ -> () + | _ -> + let rec loop {exp_loc; exp_desc; exp_extra; _} = + match exp_desc with + | Texp_let (_, _, e) + | Texp_sequence (_, e) + | Texp_letexception (_, e) + | Texp_letmodule (_, _, _, _, e) -> + loop e + | _ -> + let loc = + match List.find_opt (function + | (Texp_constraint _, _, _) -> true + | _ -> false) exp_extra + with + | Some (_, loc, _) -> loc + | None -> exp_loc + in + Location.prerr_warning loc Warnings.Non_unit_statement + in + loop exp + + +(* [check_partial_application] implements the [ignored-partial-application] + warning (and if [statement] is [true], also [non-unit-statement]). + + If [exp] has a function type, we check that it is not syntactically the + result of a function application, as this is often a bug in certain contexts + (eg the rhs of a let-binding or in the argument of [ignore]). For example, + [ignore (List.map print_int)] written by mistake instead of [ignore (List.map + print_int li)]. + + The check can be disabled by explicitly annotating the expression with a type + constraint, eg [(e : _ -> _)]. + + If [statement] is [true] and the [ignored-partial-application] is {em not} + triggered, then the [non-unit-statement] check is performed (see + [check_statement]). + + If the type of [exp] is not known at the time this function is called, the + check is retried again after typechecking. *) + +let check_partial_application ~statement exp = + let check_statement () = if statement then check_statement exp in + let doit () = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tarrow _ -> + let rec check {exp_desc; exp_loc; exp_extra; _} = + if List.exists (function + | (Texp_constraint _, _, _) -> true + | _ -> false) exp_extra then check_statement () + else begin + match exp_desc with + | Texp_ident _ | Texp_constant _ | Texp_tuple _ + | Texp_construct _ | Texp_variant _ | Texp_record _ + | Texp_field _ | Texp_setfield _ | Texp_array _ + | Texp_while _ | Texp_for _ | Texp_instvar _ + | Texp_setinstvar _ | Texp_override _ | Texp_assert _ + | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable + | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None) + | Texp_function _ -> + check_statement () + | Texp_match (_, cases, _) -> + List.iter (fun {c_rhs; _} -> check c_rhs) cases + | Texp_try (e, cases) -> + check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases + | Texp_ifthenelse (_, e1, Some e2) -> + check e1; check e2 + | Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_open (_, e) + | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) -> + check e + | Texp_apply _ | Texp_send _ | Texp_new _ | Texp_letop _ -> + Location.prerr_warning exp_loc + Warnings.Ignored_partial_application + | Texp_hole -> () + end + in + check exp + | _ -> + check_statement () + in + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tvar _ -> + (* The type of [exp] is not known. Delay the check until after + typechecking in order to give a chance for the type to become known + through unification. *) + add_delayed_check doit + | _ -> + doit () + +let pattern_needs_partial_application_check p = + let rec check : type a. a general_pattern -> bool = fun p -> + not (List.exists (function (Tpat_constraint _, _, _) -> true | _ -> false) + p.pat_extra) && + match p.pat_desc with + | Tpat_any -> true + | Tpat_exception _ -> true + | Tpat_or (p1, p2, _) -> check p1 && check p2 + | Tpat_value p -> check (p :> value general_pattern) + | _ -> false + in + check p + +(* Check that a type is generalizable at some level *) +let generalizable level ty = + let rec check ty = + if not_marked_node ty then + if get_level ty <= level then raise Exit else + (flip_mark_node ty; iter_type_expr check ty) + in + try check ty; unmark_type ty; true + with Exit -> unmark_type ty; false + +(* Hack to allow coercion of self. Will clean-up later. *) +let self_coercion = ref ([] : (Path.t * Location.t list ref) list) + +(* Helpers for type_cases *) + +let contains_variant_either ty = + let rec loop ty = + if try_mark_node ty then + begin match get_desc ty with + Tvariant row -> + if not (is_fixed row) then + List.iter + (fun (_,f) -> + match row_field_repr f with Reither _ -> raise Exit | _ -> ()) + (row_fields row); + iter_row loop row + | _ -> + iter_type_expr loop ty + end + in + try loop ty; unmark_type ty; false + with Exit -> unmark_type ty; true + +let shallow_iter_ppat f p = + match p.ppat_desc with + | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _ + | Ppat_construct (_, None) + | Ppat_extension _ + | Ppat_type _ | Ppat_unpack _ -> () + | Ppat_array pats -> List.iter f pats + | Ppat_or (p1,p2) -> f p1; f p2 + | Ppat_variant (_, arg) -> Option.iter f arg + | Ppat_tuple lst -> List.iter f lst + | Ppat_construct (_, Some (_, p)) + | Ppat_exception p | Ppat_alias (p,_) + | Ppat_open (_,p) + | Ppat_constraint (p,_) | Ppat_lazy p -> f p + | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args + +let exists_ppat f p = + let exception Found in + let rec loop p = + if f p then raise Found else (); + shallow_iter_ppat loop p in + match loop p with + | exception Found -> true + | () -> false + +let contains_polymorphic_variant p = + exists_ppat + (function + | {ppat_desc = (Ppat_variant _ | Ppat_type _)} -> true + | _ -> false) + p + +let contains_gadt p = + exists_general_pattern { f = fun (type k) (p : k general_pattern) -> + match p.pat_desc with + | Tpat_construct (_, cd, _, _) when cd.cstr_generalized -> true + | _ -> false } p + +(* There are various things that we need to do in presence of GADT constructors + that aren't required if there are none. + However, because of disambiguation, we can't know for sure whether the + patterns contain some GADT constructors. So we conservatively assume that + any constructor might be a GADT constructor. *) +let may_contain_gadts p = + exists_ppat + (function + | {ppat_desc = Ppat_construct _} -> true + | _ -> false) + p + +(* There are various things that we need to do in presence of module patterns + that aren't required if there are none. Most notably, we need to ensure the + modules are entered at the appropriate scope. The caller should use + [may_contain_modules] as an indication to set up the proper scope handling + code (via [allow_modules]) to permit module patterns. + The class of patterns identified here should stay in sync with the patterns + whose typing involves [enter_variable ~is_module:true], as these calls + will error if the scope handling isn't set up. +*) +let may_contain_modules p = + exists_ppat + (function + | {ppat_desc = Ppat_unpack _} -> true + | _ -> false) + p + +let check_absent_variant env = + iter_general_pattern { f = fun (type k) (pat : k general_pattern) -> + match pat.pat_desc with + | Tpat_variant (s, arg, row) -> + let row = !row in + if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent) + (row_fields row) + || not (is_fixed row) && not (static_row row) (* same as Ctype.poly *) + then () else + let ty_arg = + match arg with None -> [] | Some p -> [correct_levels p.pat_type] in + let fields = [s, rf_either ty_arg ~no_arg:(arg=None) ~matched:true] in + let row' = + create_row ~fields + ~more:(newvar ()) ~closed:false ~fixed:None ~name:None in + (* Should fail *) + unify_pat (ref env) {pat with pat_type = newty (Tvariant row')} + (correct_levels pat.pat_type) + | _ -> () } + +(* Getting proper location of already typed expressions. + + Used to avoid confusing locations on type error messages in presence of + type constraints. + For example: + + (* Before patch *) + # let x : string = (5 : int);; + ^ + (* After patch *) + # let x : string = (5 : int);; + ^^^^^^^^^ +*) +let proper_exp_loc exp = + let rec aux = function + | [] -> exp.exp_loc + | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc + | _ :: rest -> aux rest + in + aux exp.exp_extra + +(* To find reasonable names for let-bound and lambda-bound idents *) + +let rec name_pattern default = function + [] -> Ident.create_local default + | p :: rem -> + match p.pat_desc with + Tpat_var (id, _) -> id + | Tpat_alias(_, id, _) -> id + | _ -> name_pattern default rem + +let name_cases default lst = + name_pattern default (List.map (fun c -> c.c_lhs) lst) + +(* Typing of expressions *) + +(** [sdesc_for_hint] is used by error messages to report literals in their + original formatting *) +let unify_exp ?sdesc_for_hint env exp expected_ty = + let loc = proper_exp_loc exp in + try + unify_exp_types loc env exp.exp_type expected_ty + with Error(loc, env, Expr_type_clash(err, tfc, None)) -> + raise (error(loc, env, Expr_type_clash(err, tfc, sdesc_for_hint))) + +(* If [is_inferred e] is true, [e] will be typechecked without using + the "expected type" provided by the context. *) + +let rec is_inferred sexp = + match sexp.pexp_desc with + | Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _ + | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true + | Pexp_sequence (_, e) | Pexp_open (_, e) -> is_inferred e + | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2 + | _ -> false + +(* check if the type of %apply or %revapply matches the type expected by + the specialized typing rule for those primitives. +*) +type apply_prim = + | Apply + | Revapply +let check_apply_prim_type prim typ = + match get_desc typ with + | Tarrow (Nolabel,a,b,_) -> + begin match get_desc b with + | Tarrow(Nolabel,c,d,_) -> + let f, x, res = + match prim with + | Apply -> a, c, d + | Revapply -> c, a, d + in + begin match get_desc f with + | Tarrow(Nolabel,fl,fr,_) -> + is_Tvar fl && is_Tvar fr && is_Tvar x && is_Tvar res + && Types.eq_type fl x && Types.eq_type fr res + | _ -> false + end + | _ -> false + end + | _ -> false + +(* Merge explanation to type clash error *) + +let with_explanation explanation f = + match explanation with + | None -> f () + | Some explanation -> + try f () + with Error (loc', env', Expr_type_clash(err', None, exp')) + when not loc'.Location.loc_ghost -> + let err = Expr_type_clash(err', Some explanation, exp') in + raise (error (loc', env', err)) + +(* Generalize expressions *) +let generalize_structure_exp exp = generalize_structure exp.exp_type +let may_lower_contravariant_then_generalize env exp = + if maybe_expansive exp then lower_contravariant env exp.exp_type; + generalize exp.exp_type + +(* value binding elaboration *) + +let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; _ } = + let open Ast_helper in + match ct with + | None -> expr + | Some (Pvc_constraint { locally_abstract_univars=[]; typ }) -> + begin match typ.ptyp_desc with + | Ptyp_poly _ -> expr + | _ -> + let loc = { expr.pexp_loc with Location.loc_ghost = true } in + Exp.constraint_ ~loc expr typ + end + | Some (Pvc_coercion { ground; coercion}) -> + let loc = { expr.pexp_loc with Location.loc_ghost = true } in + Exp.coerce ~loc expr ground coercion + | Some (Pvc_constraint { locally_abstract_univars=vars;typ}) -> + let loc_start = pat.ppat_loc.Location.loc_start in + let loc = { expr.pexp_loc with loc_start; loc_ghost=true } in + let expr = Exp.constraint_ ~loc expr typ in + List.fold_right (Exp.newtype ~loc) vars expr + +let vb_pat_constraint ({pvb_pat=pat; pvb_expr = exp; _ } as vb) = + vb.pvb_attributes, + let open Ast_helper in + match vb.pvb_constraint, pat.ppat_desc, exp.pexp_desc with + | Some (Pvc_constraint {locally_abstract_univars=[]; typ} + | Pvc_coercion { coercion=typ; _ }), + _, _ -> + Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat typ + | Some (Pvc_constraint {locally_abstract_univars=vars; typ }), _, _ -> + let varified = Typ.varify_constructors vars typ in + let t = Typ.poly ~loc:typ.ptyp_loc vars varified in + let loc_end = typ.ptyp_loc.Location.loc_end in + let loc = { pat.ppat_loc with loc_end; loc_ghost=true } in + Pat.constraint_ ~loc pat t + | None, (Ppat_any | Ppat_constraint _), _ -> pat + | None, _, Pexp_coerce (_, _, sty) + | None, _, Pexp_constraint (_, sty) when !Clflags.principal -> + (* propagate type annotation to pattern, + to allow it to be generalized in -principal mode *) + Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat sty + | _ -> pat + +let rec type_exp ?recarg env sexp = + (* We now delegate everything to type_expect *) + type_expect ?recarg env sexp (mk_expected (newvar ())) + +(* Typing of an expression with an expected type. + This provide better error messages, and allows controlled + propagation of return type information. + In the principal case, structural nodes of [type_expected_explained] may be + at [generic_level] (but its variables no higher than [!current_level]). + *) + +and type_expect ?in_function ?recarg env sexp ty_expected_explained = + Msupport.with_saved_types + ~warning_attribute:sexp.pexp_attributes ?save_part:None + (fun () -> + let saved = save_levels () in + try + type_expect_ ?in_function ?recarg env sexp ty_expected_explained + with exn -> + Msupport.erroneous_type_register ty_expected_explained.ty; + raise_error exn; + set_levels saved; + let loc = sexp.pexp_loc in + { + exp_desc = Texp_ident + (Path.Pident (Ident.create_local "*type-error*"), + Location.mkloc (Longident.Lident "*type-error*") loc, + { Types. + val_type = ty_expected_explained.ty; + val_kind = Val_reg; + val_loc = loc; + val_attributes = []; + val_uid = Uid.internal_not_actually_unique; + }); + exp_loc = loc; + exp_extra = []; + exp_type = ty_expected_explained.ty; + exp_env = env; + exp_attributes = Msupport.recovery_attributes sexp.pexp_attributes; + }) + +and type_expect_ + ?in_function ?(recarg=Rejected) + env sexp ty_expected_explained = + let { ty = ty_expected; explanation } = ty_expected_explained in + let loc = sexp.pexp_loc in + let desc = sexp.pexp_desc in + (* Record the expression type before unifying it with the expected type *) + let with_explanation = with_explanation explanation in + (* Unify the result with [ty_expected], enforcing the current level *) + let rue exp = + with_explanation (fun () -> + unify_exp ~sdesc_for_hint:desc env (re exp) (instance ty_expected)); + exp + in + match desc with + | Pexp_ident lid -> + let path, desc = type_ident env ~recarg lid in + let exp_desc = + match desc.val_kind with + | Val_ivar (_, cl_num) -> + let (self_path, _) = + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env + in + Texp_instvar(self_path, path, + match lid.txt with + Longident.Lident txt -> { txt; loc = lid.loc } + | _ -> assert false) + | Val_self (_, _, _, cl_num) -> + let (path, _) = + Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env + in + Texp_ident(path, lid, desc) + | _ -> + Texp_ident(path, lid, desc) + in + rue { + exp_desc; exp_loc = loc; exp_extra = []; + exp_type = instance desc.val_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_constant(Pconst_string (str, _, _) as cst) -> ( + let cst = constant_or_raise env loc cst in + (* Terrible hack for format strings *) + let ty_exp = expand_head env (protect_expansion env ty_expected) in + let fmt6_path = + Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"), + "format6")) + in + let is_format = match get_desc ty_exp with + | Tconstr(path, _, _) when Path.same path fmt6_path -> + if !Clflags.principal && get_level ty_exp <> generic_level then + Location.prerr_warning loc + (Warnings.Not_principal "this coercion to format6"); + true + | _ -> false + in + if is_format then + let format_parsetree = + { (type_format loc str env) with pexp_loc = sexp.pexp_loc } in + type_expect ?in_function env format_parsetree ty_expected_explained + else + rue { + exp_desc = Texp_constant cst; + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_string; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + ) + | Pexp_constant cst -> + let cst = constant_or_raise env loc cst in + rue { + exp_desc = Texp_constant cst; + exp_loc = loc; exp_extra = []; + exp_type = type_constant cst; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_let(Nonrecursive, + [{pvb_pat=spat; pvb_attributes=[]; _ } as vb], sbody) + when may_contain_gadts spat -> + (* TODO: allow non-empty attributes? *) + let sval = vb_exp_constraint vb in + type_expect ?in_function env + {sexp with + pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])} + ty_expected_explained + | Pexp_let(rec_flag, spat_sexp_list, sbody) -> + let existential_context = + if rec_flag = Recursive then In_rec + else if List.compare_length_with spat_sexp_list 1 > 0 then In_group + else With_attributes in + let may_contain_modules = + List.exists (fun pvb -> may_contain_modules pvb.pvb_pat) spat_sexp_list + in + let outer_level = get_current_level () in + let (pat_exp_list, body, _new_env) = + (* If the patterns contain module unpacks, there is a possibility that + the types of the let body or bound expressions mention types + introduced by those unpacks. The below code checks for scope escape + via both of these pathways (body, bound expressions). + *) + with_local_level_if may_contain_modules begin fun () -> + let allow_modules = + if may_contain_modules + then + let scope = create_scope () in + Modules_allowed { scope } + else Modules_rejected + in + let (pat_exp_list, new_env) = + type_let existential_context env rec_flag spat_sexp_list + allow_modules + in + let body = type_expect new_env sbody ty_expected_explained in + let () = + if rec_flag = Recursive then + check_recursive_bindings env pat_exp_list + in + (* The "bound expressions" component of the scope escape check. + + This kind of scope escape is relevant only for recursive + module definitions. + *) + if rec_flag = Recursive && may_contain_modules then begin + List.iter + (fun vb -> + (* [type_let] already generalized bound expressions' types + in-place. We first take an instance before checking scope + escape at the outer level to avoid losing generality of + types added to [new_env]. + *) + let bound_exp = vb.vb_expr in + generalize_structure_exp bound_exp; + let bound_exp_type = Ctype.instance bound_exp.exp_type in + let loc = proper_exp_loc bound_exp in + let outer_var = newvar2 outer_level in + (* Checking unification within an environment extended with the + module bindings allows us to correctly accept more programs. + This environment allows unification to identify more cases + where a type introduced by the module is equal to a type + introduced at an outer scope. *) + unify_exp_types loc new_env bound_exp_type outer_var) + pat_exp_list + end; + (pat_exp_list, body, new_env) + end + ~post:(fun (_pat_exp_list, body, new_env) -> + (* The "body" component of the scope escape check. *) + unify_exp new_env body (newvar ())) + in + re { + exp_desc = Texp_let(rec_flag, pat_exp_list, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_fun (l, Some default, spat, sbody) -> + assert(is_optional l); (* default allowed only with optional argument *) + let open Ast_helper in + let default_loc = default.pexp_loc in + let default_ghost = {default.pexp_loc with loc_ghost = true} in + let scases = [ + Exp.case + (Pat.construct ~loc:default_ghost + (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) + (Some ([], Pat.var ~loc:default_ghost (mknoloc "*sth*")))) + (Exp.ident ~loc:default_ghost (mknoloc (Longident.Lident "*sth*"))); + + Exp.case + (Pat.construct ~loc:default_loc + (mknoloc (Longident.(Ldot (Lident "*predef*", "None")))) + None) + default; + ] + in + let sloc = + { Location.loc_start = spat.ppat_loc.Location.loc_start; + loc_end = default_loc.Location.loc_end; + loc_ghost = true } + in + let smatch = + Exp.match_ ~loc:sloc + (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) + scases + in + let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in + let body = + Exp.let_ ~loc Nonrecursive + ~attrs:[Attr.mk (mknoloc "#default") (PStr [])] + [Vb.mk spat smatch] sbody + in + type_function ?in_function loc sexp.pexp_attributes env + ty_expected_explained l [Exp.case pat body] + | Pexp_fun (l, None, spat, sbody) -> + type_function ?in_function loc sexp.pexp_attributes env + ty_expected_explained l [Ast_helper.Exp.case spat sbody] + | Pexp_function caselist -> + type_function ?in_function + loc sexp.pexp_attributes env ty_expected_explained Nolabel caselist + | Pexp_apply(sfunct, sargs) -> + assert (sargs <> []); + let rec lower_args seen ty_fun = + let ty = expand_head env ty_fun in + if TypeSet.mem ty seen then () else + match get_desc ty with + Tarrow (_l, ty_arg, ty_fun, _com) -> + (try enforce_current_level env ty_arg + with Unify _ -> assert false); + lower_args (TypeSet.add ty seen) ty_fun + | _ -> () + in + let type_sfunct sfunct = + (* one more level for warning on non-returning functions *) + with_local_level_iter + begin fun () -> + let funct = + with_local_level_if_principal (fun () -> type_exp env sfunct) + ~post: generalize_structure_exp + in + let ty = instance funct.exp_type in + (funct, [ty]) + end + ~post:(wrap_trace_gadt_instances env (lower_args TypeSet.empty)) + in + let funct, sargs = + let funct = type_sfunct sfunct in + match funct.exp_desc, sargs with + | Texp_ident (_, _, + {val_kind = Val_prim {prim_name="%revapply"}; val_type}), + [Nolabel, sarg; Nolabel, actual_sfunct] + when is_inferred actual_sfunct + && check_apply_prim_type Revapply val_type -> + type_sfunct actual_sfunct, [Nolabel, sarg] + | Texp_ident (_, _, + {val_kind = Val_prim {prim_name="%apply"}; val_type}), + [Nolabel, actual_sfunct; Nolabel, sarg] + when check_apply_prim_type Apply val_type -> + type_sfunct actual_sfunct, [Nolabel, sarg] + | _ -> + funct, sargs + in + let (args, ty_res) = type_application env funct sargs in + rue { + exp_desc = Texp_apply(funct, args); + exp_loc = loc; exp_extra = []; + exp_type = ty_res; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_match(sarg, caselist) -> + let arg = + with_local_level (fun () -> type_exp env sarg) + ~post:(may_lower_contravariant_then_generalize env) + in + let cases, partial = + type_cases Computation env + arg.exp_type ty_expected_explained true loc caselist in + if + List.for_all (fun c -> pattern_needs_partial_application_check c.c_lhs) + cases + then check_partial_application ~statement:false arg; + re { + exp_desc = Texp_match(arg, cases, partial); + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_try(sbody, caselist) -> + let body = type_expect env sbody ty_expected_explained in + let cases, _ = + type_cases Value env + Predef.type_exn ty_expected_explained false loc caselist in + re { + exp_desc = Texp_try(body, cases); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_tuple sexpl -> + assert (List.length sexpl >= 2); + let subtypes = List.map (fun _ -> newgenvar ()) sexpl in + let to_unify = newgenty (Ttuple subtypes) in + with_explanation (fun () -> + unify_exp_types loc env to_unify (generic_instance ty_expected)); + let expl = + List.map2 (fun body ty -> type_expect env body (mk_expected ty)) + sexpl subtypes + in + re { + exp_desc = Texp_tuple expl; + exp_loc = loc; exp_extra = []; + (* Keep sharing *) + exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl)); + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_construct(lid, sarg) -> + type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes + | Pexp_variant(l, sarg) -> + (* Keep sharing *) + let ty_expected1 = protect_expansion env ty_expected in + let ty_expected0 = instance ty_expected in + begin try match + sarg, get_desc (expand_head env ty_expected1), + get_desc (expand_head env ty_expected0) + with + | Some sarg, Tvariant row, Tvariant row0 -> + begin match + row_field_repr (get_row_field l row), + row_field_repr (get_row_field l row0) + with + Rpresent (Some ty), Rpresent (Some ty0) -> + let arg = type_argument env sarg ty ty0 in + re { exp_desc = Texp_variant(l, Some arg); + exp_loc = loc; exp_extra = []; + exp_type = ty_expected0; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> raise Exit + end + | _ -> raise Exit + with Exit -> + let arg = Option.map (type_exp env) sarg in + let arg_type = Option.map (fun arg -> arg.exp_type) arg in + let row = + create_row + ~fields: [l, rf_present arg_type] + ~more: (newvar ()) + ~closed: false + ~fixed: None + ~name: None + in + rue { + exp_desc = Texp_variant(l, arg); + exp_loc = loc; exp_extra = []; + exp_type = newty (Tvariant row); + exp_attributes = sexp.pexp_attributes; + exp_env = env } + end + | Pexp_record(lid_sexp_list, opt_sexp) -> + let saved_levels = save_levels () in + begin try + assert (lid_sexp_list <> []); + let opt_exp = + match opt_sexp with + None -> None + | Some sexp -> + let exp = + with_local_level_if_principal + (fun () -> type_exp ~recarg env sexp) + ~post: generalize_structure_exp + in + Some exp + in + let ty_record, expected_type = + let expected_opath = + match extract_concrete_record env ty_expected with + | Record_type (p0, p, _) -> Some (p0, p, is_principal ty_expected) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let err = + Wrong_expected_kind(Record, Expression explanation, ty_expected) + in + raise (error (loc, env, err)) + in + let opt_exp_opath = + match opt_exp with + | None -> None + | Some exp -> + match extract_concrete_record env exp.exp_type with + | Record_type (p0, p, _) -> Some (p0, p, is_principal exp.exp_type) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let err = Expr_not_a_record_type exp.exp_type in + raise (error (exp.exp_loc, env, err)) + in + match expected_opath, opt_exp_opath with + | None, None -> newvar (), None + | Some _, None -> ty_expected, expected_opath + | Some(_, _, true), Some _ -> ty_expected, expected_opath + | (None | Some (_, _, false)), Some (_, p', _) -> + let decl = Env.find_type p' env in + let ty = + with_local_level ~post:generalize_structure + (fun () -> newconstr p' (instance_list decl.type_params)) + in + ty, opt_exp_opath + in + let closed = (opt_sexp = None) in + let lbl_exp_list = + wrap_disambiguate "This record expression is expected to have" + (mk_expected ty_record) + (type_label_a_list loc closed env Env.Construct + (type_label_exp true env loc ty_record) + expected_type) + lid_sexp_list + in + with_explanation (fun () -> + unify_exp_types loc env (instance ty_record) (instance ty_expected)); + + (* type_label_a_list returns a list of labels sorted by lbl_pos *) + (* note: check_duplicates would better be implemented in + type_label_a_list directly *) + let rec check_duplicates = function + | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos -> + raise(error(loc, env, Label_multiply_defined lbl1.lbl_name)) + | _ :: rem -> + check_duplicates rem + | [] -> () + in + check_duplicates lbl_exp_list; + let opt_exp, label_definitions = + let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in + let matching_label lbl = + List.find + (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos) + lbl_exp_list + in + match opt_exp with + None -> + let label_definitions = + Array.map (fun lbl -> + match matching_label lbl with + | (lid, _lbl, lbl_exp) -> + Overridden (lid, lbl_exp) + | exception Not_found -> + let present_indices = + List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list + in + let label_names = extract_label_names env ty_expected in + let rec missing_labels n = function + [] -> [] + | lbl :: rem -> + if List.mem n present_indices + then missing_labels (n + 1) rem + else lbl :: missing_labels (n + 1) rem + in + let missing = missing_labels 0 label_names in + raise(error(loc, env, Label_missing missing))) + lbl.lbl_all + in + None, label_definitions + | Some exp -> + let ty_exp = instance exp.exp_type in + let unify_kept lbl = + let _, ty_arg1, ty_res1 = instance_label false lbl in + unify_exp_types exp.exp_loc env ty_exp ty_res1; + match matching_label lbl with + | lid, _lbl, lbl_exp -> + (* do not connect result types for overridden labels *) + Overridden (lid, lbl_exp) + | exception Not_found -> begin + let _, ty_arg2, ty_res2 = instance_label false lbl in + unify_exp_types loc env ty_arg1 ty_arg2; + with_explanation (fun () -> + unify_exp_types loc env (instance ty_expected) ty_res2); + Kept (ty_arg1, lbl.lbl_mut) + end + in + let label_definitions = Array.map unify_kept lbl.lbl_all in + Some {exp with exp_type = ty_exp}, label_definitions + in + let num_fields = + match lbl_exp_list with [] -> assert false + | (_, lbl,_)::_ -> Array.length lbl.lbl_all in + if opt_sexp <> None && List.length lid_sexp_list = num_fields then + Location.prerr_warning loc Warnings.Useless_record_with; + let label_descriptions, representation = + let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in + lbl_all, lbl_repres + in + let fields = + Array.map2 (fun descr def -> descr, def) + label_descriptions label_definitions + in + re { + exp_desc = Texp_record { + fields; representation; + extended_expression = opt_exp + }; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + with exn -> + raise_error exn; + set_levels saved_levels; + re { + exp_desc = Texp_record { + fields = [||]; representation = Record_regular; + extended_expression = None; + }; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = Msupport.recovery_attributes sexp.pexp_attributes; + exp_env = env } + end + | Pexp_field(srecord, lid) -> + let (record, label, _) = + type_label_access env srecord Env.Projection lid + in + let (_, ty_arg, ty_res) = instance_label false label in + unify_exp env record ty_res; + rue { + exp_desc = Texp_field(record, lid, label); + exp_loc = loc; exp_extra = []; + exp_type = ty_arg; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_setfield(srecord, lid, snewval) -> + let (record, label, expected_type) = + type_label_access env srecord Env.Mutation lid in + let ty_record = + if expected_type = None then newvar () else record.exp_type in + let (label_loc, label, newval) = + type_label_exp false env loc ty_record (lid, label, snewval) in + unify_exp env record ty_record; + if label.lbl_mut = Immutable then + raise(error(loc, env, Label_not_mutable lid.txt)); + rue { + exp_desc = Texp_setfield(record, label_loc, label, newval); + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_array(sargl) -> + let ty = newgenvar() in + let to_unify = Predef.type_array ty in + with_explanation (fun () -> + unify_exp_types loc env to_unify (generic_instance ty_expected)); + let argl = + List.map (fun sarg -> type_expect env sarg (mk_expected ty)) sargl in + re { + exp_desc = Texp_array argl; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_ifthenelse(scond, sifso, sifnot) -> + let cond = type_expect env scond + (mk_expected ~explanation:If_conditional Predef.type_bool) in + begin match sifnot with + None -> + let ifso = type_expect env sifso + (mk_expected ~explanation:If_no_else_branch Predef.type_unit) in + rue { + exp_desc = Texp_ifthenelse(cond, ifso, None); + exp_loc = loc; exp_extra = []; + exp_type = ifso.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Some sifnot -> + let ifso = type_expect env sifso ty_expected_explained in + let ifnot = type_expect env sifnot ty_expected_explained in + (* Keep sharing *) + unify_exp env ifnot ifso.exp_type; + re { + exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); + exp_loc = loc; exp_extra = []; + exp_type = ifso.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + end + | Pexp_sequence(sexp1, sexp2) -> + let exp1 = type_statement ~explanation:Sequence_left_hand_side + env sexp1 in + let exp2 = type_expect env sexp2 ty_expected_explained in + re { + exp_desc = Texp_sequence(exp1, exp2); + exp_loc = loc; exp_extra = []; + exp_type = exp2.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_while(scond, sbody) -> + let cond = type_expect env scond + (mk_expected ~explanation:While_loop_conditional Predef.type_bool) in + let body = type_statement ~explanation:While_loop_body env sbody in + rue { + exp_desc = Texp_while(cond, body); + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_for(param, slow, shigh, dir, sbody) -> + let low = type_expect env slow + (mk_expected ~explanation:For_loop_start_index Predef.type_int) in + let high = type_expect env shigh + (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in + let id, new_env = + match param.ppat_desc with + | Ppat_any -> Ident.create_local "_for", env + | Ppat_var {txt} -> + Env.enter_value txt + {val_type = instance Predef.type_int; + val_attributes = []; + val_kind = Val_reg; + val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } env + ~check:(fun s -> Warnings.Unused_for_index s) + | _ -> + raise (error (param.ppat_loc, env, Invalid_for_loop_index)) + in + let body = type_statement ~explanation:For_loop_body new_env sbody in + rue { + exp_desc = Texp_for(id, param, low, high, dir, body); + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_constraint (sarg, sty) -> + (* Pretend separate = true, 1% slowdown for lablgtk *) + let cty = + with_local_level begin fun () -> + Typetexp.transl_simple_type env ~closed:false sty + end + ~post:(fun cty -> generalize_structure cty.ctyp_type) + in + let ty = cty.ctyp_type in + let (arg, ty') = (type_argument env sarg ty (instance ty), instance ty) in + rue { + exp_desc = arg.exp_desc; + exp_loc = arg.exp_loc; + exp_type = ty'; + exp_attributes = arg.exp_attributes; + exp_env = env; + exp_extra = + (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra; + } + | Pexp_coerce(sarg, sty, sty') -> + (* Pretend separate = true, 1% slowdown for lablgtk *) + (* Also see PR#7199 for a problem with the following: + let separate = !Clflags.principal || Env.has_local_constraints env in*) + let (arg, ty',cty,cty') = + match sty with + | None -> + let (cty', ty', force) = + Typetexp.transl_simple_type_delayed env sty' + in + let arg, gen = + let lv = get_current_level () in + with_local_level begin fun () -> + let arg = type_exp env sarg in + (arg, generalizable lv arg.exp_type) + end + ~post:(fun (arg,_) -> enforce_current_level env arg.exp_type) + in + begin match arg.exp_desc, !self_coercion, get_desc ty' with + Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _, + Tconstr(path',_,_) when Path.same path path' -> + (* prerr_endline "self coercion"; *) + r := loc :: !r; + force () + | _ when free_variables ~env arg.exp_type = [] + && free_variables ~env ty' = [] -> + if not gen && (* first try a single coercion *) + let snap = snapshot () in + let ty, _b = enlarge_type env ty' in + try + force (); Ctype.unify env arg.exp_type ty; true + with Unify _ -> + backtrack snap; false + then () + else begin try + let force' = subtype env arg.exp_type ty' in + force (); force' (); + if not gen && !Clflags.principal then + Location.prerr_warning loc + (Warnings.Not_principal "this ground coercion"); + with Subtype err -> + (* prerr_endline "coercion failed"; *) + raise(error(loc, env, Not_subtype err)) + end; + | _ -> + let ty, b = enlarge_type env ty' in + force (); + begin try Ctype.unify env arg.exp_type ty with Unify err -> + let expanded = full_expand ~may_forget_scope:true env ty' in + raise(error(sarg.pexp_loc, env, + Coercion_failure({ty = ty'; expanded}, err, b))) + end + end; + (arg, ty', None, cty') + | Some sty -> + let cty, ty, force, cty', ty', force' = + with_local_level_iter ~post:generalize_structure begin fun () -> + let (cty, ty, force) = + Typetexp.transl_simple_type_delayed env sty + and (cty', ty', force') = + Typetexp.transl_simple_type_delayed env sty' + in + ((cty, ty, force, cty', ty', force'), + [ty; ty']) + end + in + begin try + let force'' = subtype env (instance ty) (instance ty') in + force (); force' (); force'' () + with Subtype err -> + raise(error(loc, env, Not_subtype err)) + end; + (type_argument env sarg ty (instance ty), + instance ty', Some cty, cty') + in + rue { + exp_desc = arg.exp_desc; + exp_loc = arg.exp_loc; + exp_type = ty'; + exp_attributes = arg.exp_attributes; + exp_env = env; + exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) :: + arg.exp_extra; + } + | Pexp_send (e, {txt=met}) -> + let obj = type_exp env e in + begin try + let (obj,meth,typ) = + with_local_level_if_principal + (fun () -> type_send env loc explanation e met) + ~post:(fun (_,_,typ) -> generalize_structure typ) + in + let typ = + match get_desc typ with + | Tpoly (ty, []) -> + instance ty + | Tpoly (ty, tl) -> + if !Clflags.principal && get_level typ <> generic_level then + Location.prerr_warning loc + (Warnings.Not_principal "this use of a polymorphic method"); + snd (instance_poly false tl ty) + | Tvar _ -> + let ty' = newvar () in + unify env (instance typ) (newty(Tpoly(ty',[]))); + (* if not !Clflags.nolabels then + Location.prerr_warning loc (Warnings.Unknown_method met); *) + ty' + | _ -> + assert false + in + rue { + exp_desc = Texp_send(obj, meth); + exp_loc = loc; exp_extra = []; + exp_type = typ; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + with Error (_, _, Undefined_method (_, _, valid_methods)) -> + let valid_methods = + match valid_methods with + | Some meths -> Some meths + | None -> + match get_desc (expand_head env obj.exp_type) with + | Tobject (fields, _) -> + let (fields, _) = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if field_kind_repr meth_kind = Fpublic then meth::li else li in + Some (List.fold_left collect_fields [] fields) + | _ -> None + in + Msupport.erroneous_type_register ty_expected; + raise_error + (error(e.pexp_loc, env, + Undefined_method (obj.exp_type, met, valid_methods))); + rue { + exp_desc = Texp_send(obj, Tmeth_name met); + exp_loc = loc; exp_extra = []; + exp_type = ty_expected; + exp_attributes = Msupport.recovery_attributes sexp.pexp_attributes; + exp_env = env; + } + end + | Pexp_new cl -> + let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in + begin match cl_decl.cty_new with + None -> + raise(error(loc, env, Virtual_class cl.txt)) + | Some ty -> + rue { + exp_desc = Texp_new (cl_path, cl, cl_decl); + exp_loc = loc; exp_extra = []; + exp_type = instance ty; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + end + | Pexp_setinstvar (lab, snewval) -> begin + let (path, mut, cl_num, ty) = + Env.lookup_instance_variable ~loc lab.txt env + in + match mut with + | Mutable -> + let newval = + type_expect env snewval (mk_expected (instance ty)) + in + let (path_self, _) = + Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env + in + rue { + exp_desc = Texp_setinstvar(path_self, path, lab, newval); + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> + raise(error(loc, env, Instance_variable_not_mutable lab.txt)) + end + | Pexp_override lst -> + let _ = + List.fold_right + (fun (lab, _) l -> + if List.exists (fun l -> l.txt = lab.txt) l then + raise(error(loc, env, + Value_multiply_overridden lab.txt)); + lab::l) + lst + [] in + begin match + try + Env.find_value_by_name (Longident.Lident "selfpat-*") env, + Env.find_value_by_name (Longident.Lident "self-*") env + with Not_found -> + raise(error(loc, env, Outside_class)) + with + (_, {val_type = self_ty; val_kind = Val_self (sign, _, vars, _)}), + (path_self, _) -> + let type_override (lab, snewval) = + begin try + let id = Vars.find lab.txt vars in + let ty = Btype.instance_variable_type lab.txt sign in + (id, lab, type_expect env snewval (mk_expected (instance ty))) + with + Not_found -> + let vars = Vars.fold (fun var _ li -> var::li) vars [] in + raise(error(loc, env, + Unbound_instance_variable (lab.txt, vars))) + end + in + let modifs = List.map type_override lst in + rue { + exp_desc = Texp_override(path_self, modifs); + exp_loc = loc; exp_extra = []; + exp_type = self_ty; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> + assert false + end + | Pexp_letmodule(name, smodl, sbody) -> + let lv = get_current_level () in + let (id, pres, modl, _, body) = + with_local_level begin fun () -> + let modl, pres, id, new_env = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let modl, md_shape = !type_module env smodl in + Mtype.lower_nongen lv modl.mod_type; + let pres = + match modl.mod_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let scope = create_scope () in + let md = + { md_type = modl.mod_type; md_attributes = []; + md_loc = name.loc; + md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } + in + let (id, new_env) = + match name.txt with + | None -> None, env + | Some name -> + let id, env = + Env.enter_module_declaration + ~scope ~shape:md_shape name pres md env + in + Some id, env + in + modl, pres, id, new_env + end + in + (* Ideally, we should catch Expr_type_clash errors + in type_expect triggered by escaping identifiers + from the local module and refine them into + Scoping_let_module errors + *) + let body = type_expect new_env sbody ty_expected_explained in + (id, pres, modl, new_env, body) + end + ~post: begin fun (_id, _pres, _modl, new_env, body) -> + (* Ensure that local definitions do not leak. *) + (* required for implicit unpack *) + enforce_current_level new_env body.exp_type + end + in + re { + exp_desc = Texp_letmodule(id, name, pres, modl, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_letexception(cd, sbody) -> + let (cd, newenv) = Typedecl.transl_exception env cd in + let body = type_expect newenv sbody ty_expected_explained in + re { + exp_desc = Texp_letexception(cd, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + + | Pexp_assert (e) -> + let cond = type_expect env e + (mk_expected ~explanation:Assert_condition Predef.type_bool) in + let exp_type = + match cond.exp_desc with + | Texp_construct(_, {cstr_name="false"}, _) -> + instance ty_expected + | _ -> + instance Predef.type_unit + in + let rec innermost_location loc_stack = + match loc_stack with + | [] -> loc + | [l] -> l + | _ :: s -> innermost_location s + in + rue { + exp_desc = Texp_assert (cond, innermost_location sexp.pexp_loc_stack); + exp_loc = loc; exp_extra = []; + exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_lazy e -> + let ty = newgenvar () in + let to_unify = Predef.type_lazy_t ty in + with_explanation (fun () -> + unify_exp_types loc env to_unify (generic_instance ty_expected)); + let arg = type_expect env e (mk_expected ty) in + re { + exp_desc = Texp_lazy arg; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_object s -> + let desc, meths = !type_object env loc s in + rue { + exp_desc = Texp_object (desc, meths); + exp_loc = loc; exp_extra = []; + exp_type = desc.cstr_type.csig_self; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_poly(sbody, sty) -> + let ty, cty = + with_local_level_if_principal + ~post:(fun (ty,_) -> generalize_structure ty) + begin fun () -> + match sty with None -> protect_expansion env ty_expected, None + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = Typetexp.transl_simple_type env ~closed:false sty in + cty.ctyp_type, Some cty + end + in + if sty <> None then + with_explanation (fun () -> + unify_exp_types loc env (instance ty) (instance ty_expected)); + let exp = + match get_desc (expand_head env ty) with + Tpoly (ty', []) -> + let exp = type_expect env sbody (mk_expected ty') in + { exp with exp_type = instance ty } + | Tpoly (ty', tl) -> + (* One more level to generalize locally *) + let (exp,_) = + with_local_level begin fun () -> + let vars, ty'' = + with_local_level_if_principal + (fun () -> instance_poly true tl ty') + ~post:(fun (_,ty'') -> generalize_structure ty'') + in + let exp = type_expect env sbody (mk_expected ty'') in + (exp, vars) + end + ~post: begin fun (exp,vars) -> + generalize_and_check_univars env "method" exp ty_expected vars + end + in + { exp with exp_type = instance ty } + | Tvar _ -> + let exp = type_exp env sbody in + let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in + unify_exp env exp ty; + exp + | _ -> assert false + in + re { exp with exp_extra = + (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } + | Pexp_newtype({txt=name} as label_loc, sbody) -> + let ty = + if Typetexp.valid_tyvar_name name then + newvar ~name () + else + newvar () + in + (* Use [with_local_level] just for scoping *) + let body, ety, id = with_local_level begin fun () -> + (* Create a fake abstract type declaration for [name]. *) + let decl = new_local_type ~loc () in + let scope = create_scope () in + let (id, new_env) = Env.enter_type ~scope name decl env in + + let body = type_exp new_env sbody in + (* Replace every instance of this type constructor in the resulting + type. *) + let seen = Hashtbl.create 8 in + let rec replace t = + if Hashtbl.mem seen (get_id t) then () + else begin + Hashtbl.add seen (get_id t) (); + match get_desc t with + | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty + | _ -> Btype.iter_type_expr replace t + end + in + let ety = Subst.type_expr Subst.identity body.exp_type in + replace ety; + (body, ety, id) + end + in + (* non-expansive if the body is non-expansive, so we don't introduce + any new extra node in the typed AST. *) + rue { body with exp_loc = loc; exp_type = ety; + exp_extra = + (Texp_newtype' (id, label_loc), loc, sexp.pexp_attributes) :: body.exp_extra } + | Pexp_pack m -> + let (p, fl) = + match get_desc (Ctype.expand_head env (instance ty_expected)) with + Tpackage (p, fl) -> + if !Clflags.principal && + get_level (Ctype.expand_head env + (protect_expansion env ty_expected)) + < Btype.generic_level + then + Location.prerr_warning loc + (Warnings.Not_principal "this module packing"); + (p, fl) + | Tvar _ -> + raise (error (loc, env, Cannot_infer_signature)) + | _ -> + raise (error (loc, env, Not_a_packed_module ty_expected)) + in + let (modl, fl') = !type_package env m p fl in + rue { + exp_desc = Texp_pack modl; + exp_loc = loc; exp_extra = []; + exp_type = newty (Tpackage (p, fl')); + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_open (od, e) -> + let tv = newvar () in + begin match !type_open_decl env od with + | (od, _, newenv) -> + let exp = type_expect newenv e ty_expected_explained in + (* Force the return type to be well-formed in the original + environment. *) + unify_var newenv tv exp.exp_type; + re { + exp_desc = Texp_open (od, exp); + exp_type = exp.exp_type; + exp_loc = loc; + exp_extra = []; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | exception exn -> + raise_error exn; + (* We're dropping the local open node and keeping only its body. + We also don't report any error in the body, as there's no way to + tell if it is due to the failed open. *) + Msupport.catch_errors (Warnings.backup ()) (ref []) + (fun () -> type_expect env e ty_expected_explained) + end + | Pexp_letop{ let_ = slet; ands = sands; body = sbody } -> + let rec loop spat_acc ty_acc sands = + match sands with + | [] -> spat_acc, ty_acc + | { pbop_pat = spat; _} :: rest -> + let ty = newvar () in + let loc = { slet.pbop_op.loc with Location.loc_ghost = true } in + let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in + let ty_acc = newty (Ttuple [ty_acc; ty]) in + loop spat_acc ty_acc rest + in + let op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops = + with_local_level_iter_if_principal + ~post:generalize_structure begin fun () -> + let let_loc = slet.pbop_op.loc in + let op_path, op_desc = type_binding_op_ident env slet.pbop_op in + let op_type = instance op_desc.val_type in + let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in + let ty_func_result = newvar () in + let ty_func = + newty (Tarrow(Nolabel, ty_params, ty_func_result, commu_ok)) in + let ty_result = newvar () in + let ty_andops = newvar () in + let ty_op = + newty (Tarrow(Nolabel, ty_andops, + newty (Tarrow(Nolabel, ty_func, ty_result, commu_ok)), commu_ok)) + in + begin try + unify env op_type ty_op + with Unify err -> + raise(error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err))) + end; + ((op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops), + [ty_andops; ty_params; ty_func_result; ty_result]) + end + in + let exp, ands = type_andops env slet.pbop_exp sands ty_andops in + let scase = Ast_helper.Exp.case spat_params sbody in + let cases, partial = + type_cases Value env + ty_params (mk_expected ty_func_result) true loc [scase] + in + let body = + match cases with + | [case] -> case + | _ -> assert false + in + let param = name_cases "param" cases in + let let_ = + { bop_op_name = slet.pbop_op; + bop_op_path = op_path; + bop_op_val = op_desc; + bop_op_type = op_type; + bop_exp = exp; + bop_loc = slet.pbop_loc; } + in + let desc = + Texp_letop{let_; ands; param; body; partial} + in + rue { exp_desc = desc; + exp_loc = sexp.pexp_loc; + exp_extra = []; + exp_type = instance ty_result; + exp_env = env; + exp_attributes = sexp.pexp_attributes; } + + | Pexp_extension ({ txt = ("ocaml.extension_constructor" + |"extension_constructor"); _ }, + payload) -> + begin match payload with + | PStr [ { pstr_desc = + Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _) + } ] -> + let path = + let cd = + Env.lookup_constructor Env.Positive ~loc:lid.loc lid.txt env + in + match cd.cstr_tag with + | Cstr_extension (path, _) -> path + | _ -> raise (error (lid.loc, env, Not_an_extension_constructor)) + in + rue { + exp_desc = Texp_extension_constructor (lid, path); + exp_loc = loc; exp_extra = []; + exp_type = instance Predef.type_extension_constructor; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> + raise (error (loc, env, Invalid_extension_constructor_payload)) + end + + | Pexp_extension ({ txt; _ } as s, payload) when txt = Ast_helper.hole_txt -> + let attr = Ast_helper.Attr.mk s payload in + re { exp_desc = Texp_hole; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = attr :: sexp.pexp_attributes; + exp_env = env } + + | Pexp_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + + | Pexp_unreachable -> + re { exp_desc = Texp_unreachable; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + +and type_ident env ?(recarg=Rejected) lid = + let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in + let is_recarg = + match get_desc desc.val_type with + | Tconstr(p, _, _) -> Path.is_constructor_typath p + | _ -> false + in + begin match is_recarg, recarg, get_desc desc.val_type with + | _, Allowed, _ + | true, Required, _ + | false, Rejected, _ -> () + | true, Rejected, _ + | false, Required, (Tvar _ | Tconstr _) -> + raise (error (lid.loc, env, Inlined_record_escape)) + | false, Required, _ -> () (* will fail later *) + end; + path, desc + +and type_binding_op_ident env s = + let loc = s.loc in + let lid = Location.mkloc (Longident.Lident s.txt) loc in + let path, desc = type_ident env lid in + let path = + match desc.val_kind with + | Val_ivar _ -> + fatal_error "Illegal name for instance variable" + | Val_self (_, _, _, cl_num) -> + let path, _ = + Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env + in + path + | _ -> path + in + path, desc + +and type_function ?(in_function : (Location.t * type_expr) option) + loc attrs env ty_expected_explained arg_label caselist = + let { ty = ty_expected; explanation } = ty_expected_explained in + let (loc_fun, ty_fun) = + match in_function with Some p -> p + | None -> (loc, instance ty_expected) + in + let separate = !Clflags.principal || Env.has_local_constraints env in + let ty_arg, ty_res = + with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + let (ty_arg, ty_res) = + try filter_arrow env (instance ty_expected) arg_label + with Filter_arrow_failed err -> + let err = match err with + | Unification_error unif_err -> + Expr_type_clash(unif_err, explanation, None) + | Label_mismatch { got; expected; expected_type} -> + Abstract_wrong_label { got; expected; expected_type; explanation } + | Not_a_function -> begin + match in_function with + | Some _ -> Too_many_arguments(ty_fun, explanation) + | None -> Not_a_function(ty_fun, explanation) + end + in + (* Merlin: we recover with an expected type of 'a -> 'b *) + let level = get_level (instance ty_expected) in + raise_error (error(loc_fun, env, err)); + (newvar2 level, newvar2 level) + in + let ty_arg = + if is_optional arg_label then + let tv = newvar() in + begin + try unify env ty_arg (type_option tv) + with Unify _ -> assert false + end; + type_option tv + else ty_arg + in + ((ty_arg, ty_res), [ty_arg; ty_res]) + end + in + let cases, partial = + type_cases Value ~in_function:(loc_fun,ty_fun) env + ty_arg (mk_expected ty_res) true loc caselist in + let not_nolabel_function ty = + let ls, tvar = list_labels env ty in + List.for_all ((<>) Nolabel) ls && not tvar + in + if is_optional arg_label && not_nolabel_function ty_res then + Location.prerr_warning (List.hd cases).c_lhs.pat_loc + Warnings.Unerasable_optional_argument; + let param = name_cases "param" cases in + re { + exp_desc = Texp_function { arg_label; param; cases; partial; }; + exp_loc = loc; exp_extra = []; + exp_type = + instance (newgenty (Tarrow(arg_label, ty_arg, ty_res, commu_ok))); + exp_attributes = attrs; + exp_env = env } + + +and type_label_access env srecord usage lid = + let record = + with_local_level_if_principal ~post:generalize_structure_exp + (fun () -> type_exp ~recarg:Allowed env srecord) + in + let ty_exp = record.exp_type in + let expected_type = + match extract_concrete_record env ty_exp with + | Record_type(p0, p, _) -> + Some(p0, p, is_principal ty_exp) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let err = Expr_not_a_record_type ty_exp in + raise (error (record.exp_loc, env, err)) + in + try + let labels = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in + let label = + wrap_disambiguate "This expression has" (mk_expected ty_exp) + (Label.disambiguate usage lid env expected_type) labels in + (record, label, expected_type) + with exn -> + raise_error exn; + let fake_label = { + lbl_name = ""; + lbl_res = ty_exp; + lbl_arg = newvar (); + lbl_mut = Mutable; + lbl_pos = 0; + lbl_all = [||]; + lbl_repres = Record_regular; + lbl_private = Public; + lbl_loc = lid.loc; + lbl_attributes = []; + lbl_uid = Uid.internal_not_actually_unique; + } in + (record, fake_label, expected_type) + +(* Typing format strings for printing or reading. + These formats are used by functions in modules Printf, Format, and Scanf. + (Handling of * modifiers contributed by Thorsten Ohl.) *) + +and type_format loc str env = + let loc = {loc with Location.loc_ghost = true} in + try + CamlinternalFormatBasics.(CamlinternalFormat.( + let mk_exp_loc pexp_desc = { + pexp_desc = pexp_desc; + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = []; + } and mk_lid_loc lid = { + txt = lid; + loc = loc; + } in + let mk_constr name args = + let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in + let arg = match args with + | [] -> None + | [ e ] -> Some e + | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in + mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in + let mk_cst cst = mk_exp_loc (Pexp_constant cst) in + let mk_int n = mk_cst (Pconst_integer (Int.to_string n, None)) + and mk_string str = mk_cst (Pconst_string (str, loc, None)) + and mk_char chr = mk_cst (Pconst_char chr) in + let rec mk_formatting_lit fmting = match fmting with + | Close_box -> + mk_constr "Close_box" [] + | Close_tag -> + mk_constr "Close_tag" [] + | Break (org, ns, ni) -> + mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ] + | FFlush -> + mk_constr "FFlush" [] + | Force_newline -> + mk_constr "Force_newline" [] + | Flush_newline -> + mk_constr "Flush_newline" [] + | Magic_size (org, sz) -> + mk_constr "Magic_size" [ mk_string org; mk_int sz ] + | Escaped_at -> + mk_constr "Escaped_at" [] + | Escaped_percent -> + mk_constr "Escaped_percent" [] + | Scan_indic c -> + mk_constr "Scan_indic" [ mk_char c ] + and mk_formatting_gen : type a b c d e f . + (a, b, c, d, e, f) formatting_gen -> Parsetree.expression = + fun fmting -> match fmting with + | Open_tag (Format (fmt', str')) -> + mk_constr "Open_tag" [ mk_format fmt' str' ] + | Open_box (Format (fmt', str')) -> + mk_constr "Open_box" [ mk_format fmt' str' ] + and mk_format : type a b c d e f . + (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string -> + Parsetree.expression = fun fmt str -> + mk_constr "Format" [ mk_fmt fmt; mk_string str ] + and mk_side side = match side with + | Left -> mk_constr "Left" [] + | Right -> mk_constr "Right" [] + | Zeros -> mk_constr "Zeros" [] + and mk_iconv iconv = match iconv with + | Int_d -> mk_constr "Int_d" [] | Int_pd -> mk_constr "Int_pd" [] + | Int_sd -> mk_constr "Int_sd" [] | Int_i -> mk_constr "Int_i" [] + | Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" [] + | Int_x -> mk_constr "Int_x" [] | Int_Cx -> mk_constr "Int_Cx" [] + | Int_X -> mk_constr "Int_X" [] | Int_CX -> mk_constr "Int_CX" [] + | Int_o -> mk_constr "Int_o" [] | Int_Co -> mk_constr "Int_Co" [] + | Int_u -> mk_constr "Int_u" [] | Int_Cd -> mk_constr "Int_Cd" [] + | Int_Ci -> mk_constr "Int_Ci" [] | Int_Cu -> mk_constr "Int_Cu" [] + and mk_fconv fconv = + let flag = match fst fconv with + | Float_flag_ -> mk_constr "Float_flag_" [] + | Float_flag_p -> mk_constr "Float_flag_p" [] + | Float_flag_s -> mk_constr "Float_flag_s" [] in + let kind = match snd fconv with + | Float_f -> mk_constr "Float_f" [] + | Float_e -> mk_constr "Float_e" [] + | Float_E -> mk_constr "Float_E" [] + | Float_g -> mk_constr "Float_g" [] + | Float_G -> mk_constr "Float_G" [] + | Float_h -> mk_constr "Float_h" [] + | Float_H -> mk_constr "Float_H" [] + | Float_F -> mk_constr "Float_F" [] + | Float_CF -> mk_constr "Float_CF" [] in + mk_exp_loc (Pexp_tuple [flag; kind]) + and mk_counter cnt = match cnt with + | Line_counter -> mk_constr "Line_counter" [] + | Char_counter -> mk_constr "Char_counter" [] + | Token_counter -> mk_constr "Token_counter" [] + and mk_int_opt n_opt = match n_opt with + | None -> + let lid_loc = mk_lid_loc (Longident.Lident "None") in + mk_exp_loc (Pexp_construct (lid_loc, None)) + | Some n -> + let lid_loc = mk_lid_loc (Longident.Lident "Some") in + mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n))) + and mk_fmtty : type a b c d e f g h i j k l . + (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression + = + fun fmtty -> match fmtty with + | Char_ty rest -> mk_constr "Char_ty" [ mk_fmtty rest ] + | String_ty rest -> mk_constr "String_ty" [ mk_fmtty rest ] + | Int_ty rest -> mk_constr "Int_ty" [ mk_fmtty rest ] + | Int32_ty rest -> mk_constr "Int32_ty" [ mk_fmtty rest ] + | Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ] + | Int64_ty rest -> mk_constr "Int64_ty" [ mk_fmtty rest ] + | Float_ty rest -> mk_constr "Float_ty" [ mk_fmtty rest ] + | Bool_ty rest -> mk_constr "Bool_ty" [ mk_fmtty rest ] + | Alpha_ty rest -> mk_constr "Alpha_ty" [ mk_fmtty rest ] + | Theta_ty rest -> mk_constr "Theta_ty" [ mk_fmtty rest ] + | Any_ty rest -> mk_constr "Any_ty" [ mk_fmtty rest ] + | Reader_ty rest -> mk_constr "Reader_ty" [ mk_fmtty rest ] + | Ignored_reader_ty rest -> + mk_constr "Ignored_reader_ty" [ mk_fmtty rest ] + | Format_arg_ty (sub_fmtty, rest) -> + mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ] + | Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) -> + mk_constr "Format_subst_ty" + [ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ] + | End_of_fmtty -> mk_constr "End_of_fmtty" [] + and mk_ignored : type a b c d e f . + (a, b, c, d, e, f) ignored -> Parsetree.expression = + fun ign -> match ign with + | Ignored_char -> + mk_constr "Ignored_char" [] + | Ignored_caml_char -> + mk_constr "Ignored_caml_char" [] + | Ignored_string pad_opt -> + mk_constr "Ignored_string" [ mk_int_opt pad_opt ] + | Ignored_caml_string pad_opt -> + mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ] + | Ignored_int (iconv, pad_opt) -> + mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_int32 (iconv, pad_opt) -> + mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_nativeint (iconv, pad_opt) -> + mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_int64 (iconv, pad_opt) -> + mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_float (pad_opt, prec_opt) -> + mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ] + | Ignored_bool pad_opt -> + mk_constr "Ignored_bool" [ mk_int_opt pad_opt ] + | Ignored_format_arg (pad_opt, fmtty) -> + mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ] + | Ignored_format_subst (pad_opt, fmtty) -> + mk_constr "Ignored_format_subst" [ + mk_int_opt pad_opt; mk_fmtty fmtty ] + | Ignored_reader -> + mk_constr "Ignored_reader" [] + | Ignored_scan_char_set (width_opt, char_set) -> + mk_constr "Ignored_scan_char_set" [ + mk_int_opt width_opt; mk_string char_set ] + | Ignored_scan_get_counter counter -> + mk_constr "Ignored_scan_get_counter" [ + mk_counter counter + ] + | Ignored_scan_next_char -> + mk_constr "Ignored_scan_next_char" [] + and mk_padding : type x y . (x, y) padding -> Parsetree.expression = + fun pad -> match pad with + | No_padding -> mk_constr "No_padding" [] + | Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ] + | Arg_padding s -> mk_constr "Arg_padding" [ mk_side s ] + and mk_precision : type x y . (x, y) precision -> Parsetree.expression = + fun prec -> match prec with + | No_precision -> mk_constr "No_precision" [] + | Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ] + | Arg_precision -> mk_constr "Arg_precision" [] + and mk_fmt : type a b c d e f . + (a, b, c, d, e, f) fmt -> Parsetree.expression = + fun fmt -> match fmt with + | Char rest -> + mk_constr "Char" [ mk_fmt rest ] + | Caml_char rest -> + mk_constr "Caml_char" [ mk_fmt rest ] + | String (pad, rest) -> + mk_constr "String" [ mk_padding pad; mk_fmt rest ] + | Caml_string (pad, rest) -> + mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ] + | Int (iconv, pad, prec, rest) -> + mk_constr "Int" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Int32 (iconv, pad, prec, rest) -> + mk_constr "Int32" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Nativeint (iconv, pad, prec, rest) -> + mk_constr "Nativeint" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Int64 (iconv, pad, prec, rest) -> + mk_constr "Int64" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Float (fconv, pad, prec, rest) -> + mk_constr "Float" [ + mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Bool (pad, rest) -> + mk_constr "Bool" [ mk_padding pad; mk_fmt rest ] + | Flush rest -> + mk_constr "Flush" [ mk_fmt rest ] + | String_literal (s, rest) -> + mk_constr "String_literal" [ mk_string s; mk_fmt rest ] + | Char_literal (c, rest) -> + mk_constr "Char_literal" [ mk_char c; mk_fmt rest ] + | Format_arg (pad_opt, fmtty, rest) -> + mk_constr "Format_arg" [ + mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ] + | Format_subst (pad_opt, fmtty, rest) -> + mk_constr "Format_subst" [ + mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ] + | Alpha rest -> + mk_constr "Alpha" [ mk_fmt rest ] + | Theta rest -> + mk_constr "Theta" [ mk_fmt rest ] + | Formatting_lit (fmting, rest) -> + mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ] + | Formatting_gen (fmting, rest) -> + mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ] + | Reader rest -> + mk_constr "Reader" [ mk_fmt rest ] + | Scan_char_set (width_opt, char_set, rest) -> + mk_constr "Scan_char_set" [ + mk_int_opt width_opt; mk_string char_set; mk_fmt rest ] + | Scan_get_counter (cnt, rest) -> + mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ] + | Scan_next_char rest -> + mk_constr "Scan_next_char" [ mk_fmt rest ] + | Ignored_param (ign, rest) -> + mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ] + | End_of_format -> + mk_constr "End_of_format" [] + | Custom _ -> + (* Custom formatters have no syntax so they will never appear + in formats parsed from strings. *) + assert false + in + let legacy_behavior = not !Clflags.strict_formats in + let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in + mk_constr "Format" [ mk_fmt fmt; mk_string str ] + )) + with Failure msg -> + raise (error (loc, env, Invalid_format msg)) + +and type_label_exp create env loc ty_expected + (lid, label, sarg) = + (* Here also ty_expected may be at generic_level *) + let separate = !Clflags.principal || Env.has_local_constraints env in + (* #4682: we try two type-checking approaches for [arg] using backtracking: + - first try: we try with [ty_arg] as expected type; + - second try; if that fails, we backtrack and try without + *) + let (vars, ty_arg, snap, arg) = + (* try the first approach *) + with_local_level begin fun () -> + let (vars, ty_arg) = + with_local_level_iter_if separate begin fun () -> + let (vars, ty_arg, ty_res) = + with_local_level_iter_if separate ~post:generalize_structure + begin fun () -> + let ((_, ty_arg, ty_res) as r) = instance_label true label in + (r, [ty_arg; ty_res]) + end + in + begin try + unify env (instance ty_res) (instance ty_expected) + with Unify err -> + raise (error(lid.loc, env, Label_mismatch(lid.txt, err))) + end; + (* Instantiate so that we can generalize internal nodes *) + let ty_arg = instance ty_arg in + ((vars, ty_arg), [ty_arg]) + end + ~post:generalize_structure + in + + if label.lbl_private = Private then + if create then + raise (error(loc, env, Private_type ty_expected)) + else + raise (error(lid.loc, env, Private_label(lid.txt, ty_expected))); + let snap = if vars = [] then None else Some (Btype.snapshot ()) in + let arg = type_argument env sarg ty_arg (instance ty_arg) in + (vars, ty_arg, snap, arg) + end + (* Note: there is no generalization logic here as could be expected, + because it is part of the backtracking logic below. *) + in + let arg = + try + if (vars = []) then arg + else begin + (* We detect if the first try failed here, + during generalization. *) + if maybe_expansive arg then + lower_contravariant env arg.exp_type; + generalize_and_check_univars env "field value" arg label.lbl_arg vars; + {arg with exp_type = instance arg.exp_type} + end + with first_try_exn when maybe_expansive arg -> try + (* backtrack and try the second approach *) + Option.iter Btype.backtrack snap; + let arg = with_local_level (fun () -> type_exp env sarg) + ~post:(fun arg -> lower_contravariant env arg.exp_type) + in + let arg = + with_local_level begin fun () -> + let arg = {arg with exp_type = instance arg.exp_type} in + unify_exp env arg (instance ty_arg); + arg + end + ~post: begin fun arg -> + generalize_and_check_univars env "field value" arg label.lbl_arg vars + end + in + {arg with exp_type = instance arg.exp_type} + with Error (_, _, Less_general _) as e -> raise e + | _ -> raise first_try_exn + in + (lid, label, arg) + +and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = + (* ty_expected' may be generic *) + let no_labels ty = + let ls, tvar = list_labels env ty in + not tvar && List.for_all ((=) Nolabel) ls + in + let may_coerce = + if not (is_inferred sarg) then None else + let work () = + let te = expand_head env ty_expected' in + match get_desc te with + Tarrow(Nolabel,_,ty_res0,_) -> + Some (no_labels ty_res0, get_level te) + | _ -> None + in + (* Need to be careful not to expand local constraints here *) + if Env.has_local_constraints env then + let snap = Btype.snapshot () in + try_finally ~always:(fun () -> Btype.backtrack snap) work + else work () + in + match may_coerce with + Some (safe_expect, lv) -> + (* apply optional arguments when expected type is "" *) + (* we must be very careful about not breaking the semantics *) + let texp = + with_local_level_if_principal ~post:generalize_structure_exp + (fun () -> type_exp env sarg) + in + let rec make_args args ty_fun = + match get_desc (expand_head env ty_fun) with + | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> + let ty = option_none env (instance ty_arg) sarg.pexp_loc in + make_args ((l, Some ty) :: args) ty_fun + | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic -> + List.rev args, ty_fun, no_labels ty_res' + | Tvar _ -> List.rev args, ty_fun, false + | _ -> [], texp.exp_type, false + in + let args, ty_fun', simple_res = make_args [] texp.exp_type + and texp = {texp with exp_type = instance texp.exp_type} in + if not (simple_res || safe_expect) then begin + unify_exp env texp ty_expected; + texp + end else begin + let warn = !Clflags.principal && + (lv <> generic_level || get_level ty_fun' <> generic_level) + and ty_fun = instance ty_fun' in + let ty_arg, ty_res = + match get_desc (expand_head env ty_expected) with + Tarrow(Nolabel,ty_arg,ty_res,_) -> ty_arg, ty_res + | _ -> assert false + in + unify_exp env {texp with exp_type = ty_fun} ty_expected; + if args = [] then texp else + (* eta-expand to avoid side effects *) + let var_pair name ty = + let id = Ident.create_local name in + let desc = + { val_type = ty; val_kind = Val_reg; + val_attributes = []; + val_loc = Location.none; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + in + let exp_env = Env.add_value id desc env in + {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; + pat_attributes = []; + pat_loc = Location.none; pat_env = env}, + {exp_type = ty; exp_loc = Location.none; exp_env = exp_env; + exp_extra = []; exp_attributes = []; + exp_desc = + Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), desc)} + in + let eta_pat, eta_var = var_pair "eta" ty_arg in + let func texp = + let e = + {texp with exp_type = ty_res; exp_desc = + Texp_apply + (texp, + args @ [Nolabel, Some eta_var])} + in + let cases = [case eta_pat e] in + let param = name_cases "param" cases in + { texp with exp_type = ty_fun; exp_desc = + Texp_function { arg_label = Nolabel; param; cases; + partial = Total; } } + in + Location.prerr_warning texp.exp_loc + (Warnings.Eliminated_optional_arguments + (List.map (fun (l, _) -> Printtyp.string_of_label l) args)); + if warn then Location.prerr_warning texp.exp_loc + (Warnings.Non_principal_labels "eliminated optional argument"); + (* let-expand to have side effects *) + let let_pat, let_var = var_pair "arg" texp.exp_type in + re { texp with exp_type = ty_fun; exp_desc = + Texp_let (Nonrecursive, + [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]; + vb_loc=Location.none; + }], + func let_var) } + end + | None -> + let texp = type_expect ?recarg env sarg + (mk_expected ?explanation ty_expected') in + unify_exp env texp ty_expected; + texp + +and type_application env funct sargs = + (* funct.exp_type may be generic *) + let result_type omitted ty_fun = + List.fold_left + (fun ty_fun (l,ty,lv) -> newty2 ~level:lv (Tarrow(l,ty,ty_fun,commu_ok))) + ty_fun omitted + in + let has_label l ty_fun = + let ls, tvar = list_labels env ty_fun in + tvar || List.mem l ls + in + let eliminated_optional_arguments = ref [] in + let omitted_parameters = ref [] in + let type_unknown_arg (ty_fun, typed_args) (lbl, sarg) = + let (ty_arg, ty_res) = + try + let ty_fun = expand_head env ty_fun in + match get_desc ty_fun with + | Tvar _ -> + let t1 = newvar () and t2 = newvar () in + if get_level ty_fun >= get_level t1 && + not (is_prim ~name:"%identity" funct) && + not (Msupport.erroneous_expr_check funct) + then + Location.prerr_warning sarg.pexp_loc + Warnings.Ignored_extra_argument; + unify env ty_fun (newty (Tarrow(lbl,t1,t2,commu_var ()))); + (t1, t2) + | Tarrow (l,t1,t2,_) when l = lbl + || !Clflags.classic && lbl = Nolabel && not (is_optional l) -> + (t1, t2) + | td -> + let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in + let ty_res = + result_type (!omitted_parameters @ !eliminated_optional_arguments) + ty_fun + in + match get_desc ty_res with + | Tarrow _ -> + if !Clflags.classic || not (has_label lbl ty_fun) then + Msupport.resume_raise + (error(sarg.pexp_loc, env, + Apply_wrong_label(lbl, ty_res, false))) + else + Msupport.resume_raise + (error(funct.exp_loc, env, Incoherent_label_order)) + | _ -> + let previous_arg_loc = + (* [typed_args] is the arguments typed until now, in reverse + order of appearance. Not all arguments have a location + attached (eg. an optional argument that is not passed). *) + typed_args + |> List.find_map + (function (_, Some (_, loc)) -> loc | _ -> None) + |> Option.value ~default:funct.exp_loc + in + Msupport.resume_raise + (error(funct.exp_loc, env, Apply_non_function { + funct; + func_ty = expand_head env funct.exp_type; + res_ty = expand_head env ty_res; + previous_arg_loc; + extra_arg_loc = sarg.pexp_loc; })) + with Msupport.Resume -> + newvar(), ty_fun + in + let arg () = + let arg = type_expect env sarg (mk_expected ty_arg) in + if is_optional lbl then + unify_exp env arg (type_option(newvar())); + arg + in + (ty_res, (lbl, Some (arg, Some sarg.pexp_loc)) :: typed_args) + in + let ignore_labels = + !Clflags.classic || + begin + let ls, tvar = list_labels env funct.exp_type in + not tvar && + let labels = List.filter (fun l -> not (is_optional l)) ls in + List.length labels = List.length sargs && + List.for_all (fun (l,_) -> l = Nolabel) sargs && + List.exists (fun l -> l <> Nolabel) labels && + (Location.prerr_warning + funct.exp_loc + (Warnings.Labels_omitted + (List.map Printtyp.string_of_label + (List.filter ((<>) Nolabel) labels))); + true) + end + in + let warned = ref false in + (* [args] remember the location of each argument in sources. *) + let rec type_args args ty_fun ty_fun0 sargs = + let type_unknown_args () = + (* We're not looking at a *known* function type anymore, or there are no + arguments left. *) + let ty_fun, typed_args = + List.fold_left type_unknown_arg (ty_fun0, args) sargs + in + let args = + (* Force typing of arguments. + Careful: the order matters here. Using [List.rev_map] would be + incorrect. *) + List.map + (function + | l, None -> l, None + | l, Some (f, _loc) -> l, Some (f ())) + (List.rev typed_args) + in + let result_ty = instance (result_type !omitted_parameters ty_fun) in + args, result_ty + in + if sargs = [] then type_unknown_args () else + let ty_fun' = expand_head env ty_fun in + match get_desc ty_fun', get_desc (expand_head env ty_fun0) with + | Tarrow (l, ty, ty_fun, com), Tarrow (_, ty0, ty_fun0, _) + when is_commu_ok com -> + let lv = get_level ty_fun' in + let may_warn loc w = + if not !warned && !Clflags.principal && lv <> generic_level + then begin + warned := true; + Location.prerr_warning loc w + end + in + let name = label_name l + and optional = is_optional l in + let use_arg sarg l' = + if not optional || is_optional l' then + (fun () -> type_argument env sarg ty ty0) + else begin + may_warn sarg.pexp_loc + (Warnings.Not_principal "using an optional argument here"); + (fun () -> option_some env (type_argument env sarg + (extract_option_type env ty) + (extract_option_type env ty0))) + end + in + let eliminate_optional_arg () = + may_warn funct.exp_loc + (Warnings.Non_principal_labels "eliminated optional argument"); + eliminated_optional_arguments := + (l,ty,lv) :: !eliminated_optional_arguments; + (fun () -> option_none env (instance ty) Location.none) + in + let remaining_sargs, arg = + if ignore_labels then begin + (* No reordering is allowed, process arguments in order *) + match sargs with + | [] -> assert false + | (l', sarg) :: remaining_sargs -> + if name = label_name l' || (not optional && l' = Nolabel) then + (remaining_sargs, Some (use_arg sarg l', Some sarg.pexp_loc)) + else if + optional && + not (List.exists (fun (l, _) -> name = label_name l) + remaining_sargs) && + List.exists (function (Nolabel, _) -> true | _ -> false) + sargs + then + (sargs, Some (eliminate_optional_arg (), Some sarg.pexp_loc)) + else + raise(error(sarg.pexp_loc, env, + Apply_wrong_label(l', ty_fun', optional))) + end else + (* Arguments can be commuted, try to fetch the argument + corresponding to the first parameter. *) + match extract_label name sargs with + | Some (l', sarg, commuted, remaining_sargs) -> + if commuted then begin + may_warn sarg.pexp_loc + (Warnings.Not_principal "commuting this argument") + end; + if not optional && is_optional l' then + Location.prerr_warning sarg.pexp_loc + (Warnings.Nonoptional_label (Printtyp.string_of_label l)); + remaining_sargs, Some (use_arg sarg l', Some sarg.pexp_loc) + | None -> + sargs, + if optional && List.mem_assoc Nolabel sargs then + Some (eliminate_optional_arg (), None) + else begin + (* No argument was given for this parameter, we abstract over + it. *) + may_warn funct.exp_loc + (Warnings.Non_principal_labels "commuted an argument"); + omitted_parameters := (l,ty,lv) :: !omitted_parameters; + None + end + in + type_args ((l,arg)::args) ty_fun ty_fun0 remaining_sargs + | _ -> + type_unknown_args () + in + let is_ignore funct = + is_prim ~name:"%ignore" funct && + (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true + with Filter_arrow_failed _ -> false) + in + (* Extra scope to check for non-returning functions *) + with_local_level begin fun () -> + match sargs with + | (* Special case for ignore: avoid discarding warning *) + [Nolabel, sarg] when is_ignore funct -> + let ty_arg, ty_res = + filter_arrow env (instance funct.exp_type) Nolabel in + let exp = type_expect env sarg (mk_expected ty_arg) in + check_partial_application ~statement:false exp; + ([Nolabel, Some exp], ty_res) + | _ -> + let ty = funct.exp_type in + type_args [] ty (instance ty) sargs + end + +and type_construct env loc lid sarg ty_expected_explained attrs = + let { ty = ty_expected; explanation } = ty_expected_explained in + let expected_type = + match extract_concrete_variant env ty_expected with + | Variant_type(p0, p,_) -> + Some(p0, p, is_principal ty_expected) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let ctx = Expression explanation in + let err = Wrong_expected_kind(srt, ctx, ty_expected) in + raise (error (loc, env, err)) + in + let constrs = + Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env + in + let constr = + wrap_disambiguate "This variant expression is expected to have" + ty_expected_explained + (Constructor.disambiguate Env.Positive lid env expected_type) constrs + in + let sargs = + match sarg with + None -> [] + | Some {pexp_desc = Pexp_tuple sel} when + constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs + -> sel + | Some se -> [se] in + if List.length sargs <> constr.cstr_arity then + raise(error(loc, env, Constructor_arity_mismatch + (lid.txt, constr.cstr_arity, List.length sargs))); + let separate = !Clflags.principal || Env.has_local_constraints env in + let ty_args, ty_res, texp = + with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + let ty_args, ty_res, texp = + with_local_level_if separate begin fun () -> + let (ty_args, ty_res, _) = + instance_constructor Keep_existentials_flexible constr + in + let texp = + re { + exp_desc = Texp_construct(lid, constr, []); + exp_loc = loc; exp_extra = []; + exp_type = ty_res; + exp_attributes = attrs; + exp_env = env } in + (ty_args, ty_res, texp) + end + ~post: begin fun (_, ty_res, texp) -> + generalize_structure ty_res; + with_explanation explanation (fun () -> + unify_exp env {texp with exp_type = instance ty_res} + (instance ty_expected)); + end + in + ((ty_args, ty_res, texp), ty_res::ty_args) + end + in + let ty_args0, ty_res = + match instance_list (ty_res :: ty_args) with + t :: tl -> tl, t + | _ -> assert false + in + let texp = {texp with exp_type = ty_res} in + if not separate then unify_exp env texp (instance ty_expected); + let recarg = + match constr.cstr_inlined with + | None -> Rejected + | Some _ -> + begin match sargs with + | [{pexp_desc = Pexp_extension ({ txt; _ }, _); _ }] + when txt = Ast_helper.hole_txt -> Required + | [{pexp_desc = + Pexp_ident _ | + Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] -> + Required + | _ -> + raise (error(loc, env, Inlined_record_expected)) + end + in + let args = + List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs + (List.combine ty_args ty_args0) in + if constr.cstr_private = Private then + begin match constr.cstr_tag with + | Cstr_extension _ -> + raise_error (error(loc, env, Private_constructor (constr, ty_res))) + | Cstr_constant _ | Cstr_block _ | Cstr_unboxed -> + raise_error (error(loc, env, Private_type ty_res)); + end; + (* NOTE: shouldn't we call "re" on this final expression? -- AF *) + { texp with + exp_desc = Texp_construct(lid, constr, args) } + +(* Typing of statements (expressions whose values are discarded) *) + +and type_statement ?explanation env sexp = + let has_errors = Msupport.monitor_errors () in + (* Raise the current level to detect non-returning functions *) + let exp = with_local_level (fun () -> type_exp env sexp) in + let ty = expand_head env exp.exp_type in + if is_Tvar ty && get_level ty > get_current_level () && not !has_errors then + Location.prerr_warning + (final_subexpression exp).exp_loc + Warnings.Nonreturning_statement; + if !Clflags.strict_sequence then + let expected_ty = instance Predef.type_unit in + with_explanation explanation (fun () -> + unify_exp env exp expected_ty); + exp + else begin + if not !has_errors then check_partial_application ~statement:true exp; + enforce_current_level env ty; + exp + end + +(* Typing of match cases *) +and type_cases + : type k . k pattern_category -> + ?in_function:_ -> _ -> _ -> _ -> _ -> _ -> Parsetree.case list -> + k case list * partial + = fun category ?in_function env + ty_arg ty_res_explained partial_flag loc caselist -> + let has_errors = Msupport.monitor_errors () in + (* ty_arg is _fully_ generalized *) + let { ty = ty_res; explanation } = ty_res_explained in + let patterns = List.map (fun {pc_lhs=p} -> p) caselist in + let contains_polyvars = List.exists contains_polymorphic_variant patterns in + let erase_either = contains_polyvars && contains_variant_either ty_arg in + let may_contain_gadts = List.exists may_contain_gadts patterns in + let may_contain_modules = List.exists may_contain_modules patterns in + let create_inner_level = may_contain_gadts || may_contain_modules in + let ty_arg = + if (may_contain_gadts || erase_either) && not !Clflags.principal + then correct_levels ty_arg else ty_arg + in + let rec is_var spat = + match spat.ppat_desc with + Ppat_any | Ppat_var _ -> true + | Ppat_alias (spat, _) -> is_var spat + | _ -> false in + let needs_exhaust_check = + match caselist with + [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true + | [{pc_lhs}] when is_var pc_lhs -> false + | _ -> true + in + let outer_level = get_current_level () in + with_local_level_iter_if create_inner_level begin fun () -> + let lev = get_current_level () in + let allow_modules = + if may_contain_modules + then + (* The corresponding check for scope escape is done together with + the check for GADT-induced existentials by + [with_local_level_iter_if create_inner_level]. + *) + Modules_allowed { scope = lev } + else Modules_rejected + in + let take_partial_instance = + if erase_either + then Some false else None + in + let half_typed_cases, ty_res, do_copy_types, ty_arg' = + (* propagation of the argument *) + with_local_level begin fun () -> + let pattern_force = ref [] in + (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_arg; *) + let half_typed_cases = + List.map + (fun ({pc_lhs; pc_guard = _; pc_rhs = _} as case) -> + let htc = + with_local_level_if_principal begin fun () -> + let ty_arg = + (* propagation of pattern *) + with_local_level ~post:generalize_structure + (fun () -> instance ?partial:take_partial_instance ty_arg) + in + let (pat, ext_env, force, pvs, mvs) = + type_pattern category ~lev env pc_lhs ty_arg allow_modules + in + pattern_force := force @ !pattern_force; + { typed_pat = pat; + pat_type_for_unif = ty_arg; + untyped_case = case; + branch_env = ext_env; + pat_vars = pvs; + module_vars = mvs; + contains_gadt = contains_gadt (as_comp_pattern category pat); } + end + ~post: begin fun htc -> + iter_pattern_variables_type generalize_structure htc.pat_vars; + end + in + (* Ensure that no ambivalent pattern type escapes its branch *) + check_scope_escape htc.typed_pat.pat_loc env outer_level + htc.pat_type_for_unif; + let pat = htc.typed_pat in + {htc with typed_pat = { pat with pat_type = instance pat.pat_type }} + ) + caselist in + let patl = + List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in + let does_contain_gadt = + List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases + in + let ty_res, do_copy_types = + if does_contain_gadt && not !Clflags.principal then + correct_levels ty_res, Env.make_copy_of_types env + else ty_res, (fun env -> env) + in + (* Unify all cases (delayed to keep it order-free) *) + let ty_arg' = newvar () in + let unify_pats ty = + List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } -> + unify_pat_types pat.pat_loc (ref env) pat_ty ty + ) half_typed_cases + in + unify_pats ty_arg'; + (* Check for polymorphic variants to close *) + if List.exists has_variants patl then begin + Parmatch.pressure_variants_in_computation_pattern env + (List.map (as_comp_pattern category) patl); + List.iter finalize_variants patl + end; + (* `Contaminating' unifications start here *) + List.iter (fun f -> f()) !pattern_force; + (* Post-processing and generalization *) + if take_partial_instance <> None then unify_pats (instance ty_arg); + List.iter (fun { pat_vars; _ } -> + iter_pattern_variables_type (enforce_current_level env) pat_vars + ) half_typed_cases; + (half_typed_cases, ty_res, do_copy_types, ty_arg') + end + ~post: begin fun (half_typed_cases, _, _, ty_arg') -> + generalize ty_arg'; + List.iter (fun { pat_vars; _ } -> + iter_pattern_variables_type generalize pat_vars + ) half_typed_cases + end + in + (* type bodies *) + let in_function = if List.length caselist = 1 then in_function else None in + let ty_res' = instance ty_res in + let cases = with_local_level_if_principal ~post:ignore begin fun () -> + List.map + (fun { typed_pat = pat; branch_env = ext_env; + pat_vars = pvs; module_vars = mvs; + untyped_case = {pc_lhs = _; pc_guard; pc_rhs}; + contains_gadt; _ } -> + let ext_env = + if contains_gadt then + do_copy_types ext_env + else + ext_env + in + let ext_env = + add_pattern_variables ext_env pvs + ~check:(fun s -> Warnings.Unused_var_strict s) + ~check_as:(fun s -> Warnings.Unused_var s) + in + let ext_env = add_module_variables ext_env mvs in + let ty_expected = + if contains_gadt && not !Clflags.principal then + (* Take a generic copy of [ty_res] again to allow propagation of + type information from preceding branches *) + correct_levels ty_res + else ty_res in + let guard = + match pc_guard with + | None -> None + | Some scond -> + Some + (type_expect ext_env scond + (mk_expected ~explanation:When_guard Predef.type_bool)) + in + let exp = + type_expect ?in_function ext_env + pc_rhs (mk_expected ?explanation ty_expected) + in + { + c_lhs = pat; + c_guard = guard; + c_rhs = {exp with exp_type = ty_res'} + } + ) + half_typed_cases + end in + let do_init = may_contain_gadts || needs_exhaust_check in + let ty_arg_check = + if do_init then + (* Hack: use for_saving to copy variables too *) + Subst.type_expr (Subst.for_saving Subst.identity) ty_arg' + else ty_arg' + in + let val_cases, exn_cases = + match category with + | Value -> (cases : value case list), [] + | Computation -> split_cases env cases in + if val_cases = [] && exn_cases <> [] then + raise (error (loc, env, No_value_clauses)); + let partial = + if partial_flag then + check_partial ~lev allow_modules env ty_arg_check loc val_cases + else + Partial + in + let unused_check delayed = + List.iter (fun { typed_pat; branch_env; _ } -> + check_absent_variant branch_env (as_comp_pattern category typed_pat) + ) half_typed_cases; + with_level_if delayed ~level:lev begin fun () -> + check_unused ~lev allow_modules env ty_arg_check val_cases ; + check_unused ~lev allow_modules env Predef.type_exn exn_cases ; + end; + Parmatch.check_ambiguous_bindings val_cases ; + Parmatch.check_ambiguous_bindings exn_cases + in + if not !has_errors then ( + if contains_polyvars then + add_delayed_check (fun () -> unused_check true) + else + (* Check for unused cases, do not delay because of gadts *) + unused_check false + ); + ((cases, partial), [ty_res']) + end + (* Ensure that existential types do not escape *) + ~post:(fun ty_res' -> unify_exp_types loc env ty_res' (newvar ())) + +(* Typing of let bindings *) + +and type_let ?check ?check_strict + existential_context env rec_flag spat_sexp_list allow_modules = + let spatl = List.map vb_pat_constraint spat_sexp_list in + let attrs_list = List.map fst spatl in + let is_recursive = (rec_flag = Recursive) in + + let (pat_list, exp_list, new_env, mvs, _pvs) = + with_local_level begin fun () -> + if existential_context = At_toplevel then Typetexp.TyVarEnv.reset (); + let (pat_list, new_env, force, pvs, mvs) = + with_local_level_if_principal begin fun () -> + let nvs = List.map (fun _ -> newvar ()) spatl in + let (pat_list, _new_env, _force, _pvs, _mvs as res) = + type_pattern_list + Value existential_context env spatl nvs allow_modules in + (* If recursive, first unify with an approximation of the + expression *) + if is_recursive then + List.iter2 + (fun pat binding -> + let pat = + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + {pat with pat_type = + snd (instance_poly ~keep_names:true false tl ty)} + | _ -> pat + in + let bound_expr = vb_exp_constraint binding in + unify_pat (ref env) pat (type_approx env bound_expr)) + pat_list spat_sexp_list; + (* Polymorphic variant processing *) + List.iter + (fun pat -> + if has_variants pat then begin + Parmatch.pressure_variants env [pat]; + finalize_variants pat + end) + pat_list; + res + end + ~post: begin fun (pat_list, _, _, pvs, _) -> + (* Generalize the structure *) + iter_pattern_variables_type generalize_structure pvs; + List.iter (fun pat -> generalize_structure pat.pat_type) pat_list + end + in + (* Note [add_module_variables after checking expressions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Don't call [add_module_variables] here, because its use of + [type_module] will fail until after we have type-checked the expression + of the let. Example: [let m : (module S) = ... in let (module M) = m in + ...] We learn the signature [S] from the type of [m] in the RHS of the + second let, and we need that knowledge for [type_module] to succeed. If + we type-checked expressions before patterns, then we could call + [add_module_variables] here. + *) + let new_env = add_pattern_variables new_env pvs in + let pat_list = + List.map + (fun pat -> {pat with pat_type = instance pat.pat_type}) + pat_list + in + (* Only bind pattern variables after generalizing *) + List.iter (fun f -> f()) force; + + let exp_list = + (* See Note [add_module_variables after checking expressions] + We can't defer type-checking module variables with recursive + definitions, so things like [let rec (module M) = m in ...] always + fail, even if the type of [m] is known. + *) + let exp_env = + if is_recursive then add_module_variables new_env mvs else env + in + type_let_def_wrap_warnings ?check ?check_strict ~is_recursive + ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs + (fun exp_env ({pvb_attributes; _} as vb) pat -> + let sexp = vb_exp_constraint vb in + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + let vars, ty' = + with_local_level_if_principal + ~post:(fun (_,ty') -> generalize_structure ty') + (fun () -> instance_poly ~keep_names:true true tl ty) + in + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp (mk_expected ty')) + in + exp, Some vars + | _ -> + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp (mk_expected pat.pat_type)) + in + exp, None) + in + List.iter2 + (fun pat (attrs, exp) -> + Builtin_attributes.warning_scope ~ppwarning:false attrs + (fun () -> + ignore(check_partial allow_modules env pat.pat_type pat.pat_loc + [case pat exp] : Typedtree.partial) + ) + ) + pat_list + (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list); + (pat_list, exp_list, new_env, mvs, + List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs) + end + ~post: begin fun (pat_list, exp_list, _, _, pvs) -> + List.iter2 + (fun pat (exp, _) -> + if maybe_expansive exp then lower_contravariant env pat.pat_type) + pat_list exp_list; + iter_pattern_variables_type generalize pvs; + List.iter2 + (fun pat (exp, vars) -> + match vars with + | None -> + (* We generalize expressions even if they are not bound to a variable + and do not have an expliclit polymorphic type annotation. This is + not needed in general, however those types may be shown by the + interactive toplevel, for example: + {[ + let _ = Array.get;; + - : 'a array -> int -> 'a = + ]} + so we do it anyway. *) + generalize exp.exp_type + | Some vars -> + if maybe_expansive exp then + lower_contravariant env exp.exp_type; + generalize_and_check_univars env "definition" + exp pat.pat_type vars) + pat_list exp_list + end + in + let l = List.combine pat_list exp_list in + let l = + List.map2 + (fun (p, (e, _)) pvb -> + {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes; + vb_loc=pvb.pvb_loc; + }) + l spat_sexp_list + in + if is_recursive then + List.iter + (fun {vb_pat=pat} -> match pat.pat_desc with + Tpat_var _ -> () + | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> () + | _ -> raise(error(pat.pat_loc, env, Illegal_letrec_pat))) + l; + List.iter (fun vb -> + if pattern_needs_partial_application_check vb.vb_pat then + check_partial_application ~statement:false vb.vb_expr + ) l; + (* See Note [add_module_variables after checking expressions] *) + let new_env = add_module_variables new_env mvs in + (l, new_env) + +and type_let_def_wrap_warnings + ?(check = fun s -> Warnings.Unused_var s) + ?(check_strict = fun s -> Warnings.Unused_var_strict s) + ~is_recursive ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs + type_def = + let is_fake_let = + match spat_sexp_list with + | [{pvb_expr={pexp_desc=Pexp_match( + {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] -> + true (* the fake let-declaration introduced by fun ?(x = e) -> ... *) + | _ -> + false + in + let check = if is_fake_let then check_strict else check in + let warn_about_unused_bindings = + List.exists + (fun attrs -> + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + Warnings.is_active (check "") || Warnings.is_active (check_strict "") + || (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag)))) + attrs_list + in + let sexp_is_fun { pvb_expr = sexp; _ } = + match sexp.pexp_desc with + | Pexp_fun _ | Pexp_function _ -> true + | _ -> false + in + let exp_env = + if not is_recursive && List.for_all sexp_is_fun spat_sexp_list then begin + (* Add ghost bindings to help detecting missing "rec" keywords. + + We only add those if the body of the definition is obviously a + function. The rationale is that, in other cases, the hint is probably + wrong (and the user is using "advanced features" anyway (lazy, + recursive values...)). + + [pvb_loc] (below) is the location of the first let-binding (in case of + a let .. and ..), and is where the missing "rec" hint suggests to add a + "rec" keyword. *) + match spat_sexp_list with + | {pvb_loc; _} :: _ -> + maybe_add_pattern_variables_ghost pvb_loc exp_env pvs + | _ -> assert false + end + else exp_env + in + (* Algorithm to detect unused declarations in recursive bindings: + - During type checking of the definitions, we capture the 'value_used' + events on the bound identifiers and record them in a slot corresponding + to the current definition (!current_slot). + In effect, this creates a dependency graph between definitions. + + - After type checking the definition (!current_slot = None), + when one of the bound identifier is effectively used, we trigger + again all the events recorded in the corresponding slot. + The effect is to traverse the transitive closure of the graph created + in the first step. + + We also keep track of whether *all* variables in a given pattern + are unused. If this is the case, for local declarations, the issued + warning is 26, not 27. + *) + let current_slot = ref None in + let rec_needed = ref false in + let pat_slot_list = + List.map2 + (fun attrs pat -> + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + if not warn_about_unused_bindings then pat, None + else + let some_used = ref false in + (* has one of the identifier of this pattern been used? *) + let slot = ref [] in + List.iter + (fun id -> + let vd = Env.find_value (Path.Pident id) new_env in + (* note: Env.find_value does not trigger the value_used + event *) + let name = Ident.name id in + let used = ref false in + if not (name = "" || name.[0] = '_' || name.[0] = '#') then + add_delayed_check + (fun () -> + if not !used then + Location.prerr_warning vd.Types.val_loc + ((if !some_used then check_strict else check) name) + ); + Env.set_value_used_callback + vd + (fun () -> + match !current_slot with + | Some slot -> + slot := vd.val_uid :: !slot; rec_needed := true + | None -> + List.iter Env.mark_value_used (get_ref slot); + used := true; + some_used := true + ) + ) + (Typedtree.pat_bound_idents pat); + pat, Some slot + )) + attrs_list + pat_list + in + let exp_list = + List.map2 + (fun case (pat, slot) -> + if is_recursive then current_slot := slot; + type_def exp_env case pat) + spat_sexp_list pat_slot_list + in + current_slot := None; + if is_recursive && not !rec_needed then begin + let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in + (* See PR#6677 *) + Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes + (fun () -> + Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag + ) + end; + exp_list + +and type_andops env sarg sands expected_ty = + let rec loop env let_sarg rev_sands expected_ty = + match rev_sands with + | [] -> type_expect env let_sarg (mk_expected expected_ty), [] + | { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest -> + let op_path, op_desc, op_type, ty_arg, ty_rest, ty_result = + with_local_level_iter_if_principal begin fun () -> + let op_path, op_desc = type_binding_op_ident env sop in + let op_type = instance op_desc.val_type in + let ty_arg = newvar () in + let ty_rest = newvar () in + let ty_result = newvar() in + let ty_rest_fun = + newty (Tarrow(Nolabel, ty_arg, ty_result, commu_ok)) in + let ty_op = + newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, commu_ok)) in + begin try + unify env op_type ty_op + with Unify err -> + raise(error(sop.loc, env, Andop_type_clash(sop.txt, err))) + end; + ((op_path, op_desc, op_type, ty_arg, ty_rest, ty_result), + [ty_rest; ty_arg; ty_result]) + end + ~post:generalize_structure + in + let let_arg, rest = loop env let_sarg rest ty_rest in + let exp = type_expect env sexp (mk_expected ty_arg) in + begin try + unify env (instance ty_result) (instance expected_ty) + with Unify err -> + raise(error(loc, env, Bindings_type_clash(err))) + end; + let andop = + { bop_op_name = sop; + bop_op_path = op_path; + bop_op_val = op_desc; + bop_op_type = op_type; + bop_exp = exp; + bop_loc = loc } + in + let_arg, andop :: rest + in + let let_arg, rev_ands = loop env sarg (List.rev sands) expected_ty in + let_arg, List.rev rev_ands + +(* Typing of method call *) +and type_send env loc explanation e met = + let obj = type_exp env e in + let (meth, typ) = + match obj.exp_desc with + | Texp_ident(_, _, {val_kind = Val_self(sign, meths, _, _)}) -> + let id, typ = + match meths with + | Self_concrete meths -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + id, typ + | Self_virtual meths_ref -> begin + match Meths.find met !meths_ref with + | id -> id, Btype.method_type met sign + | exception Not_found -> + let id = Ident.create_local met in + let ty = newvar () in + meths_ref := Meths.add met id !meths_ref; + add_method env met Private Virtual ty sign; + Location.prerr_warning loc + (Warnings.Undeclared_virtual_method met); + id, ty + end + in + Tmeth_val id, typ + | Texp_ident(_, _, {val_kind = Val_anc (sign, meths, cl_num)}) -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + let (self_path, _) = + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env + in + Tmeth_ancestor(id, self_path), typ + | _ -> + let ty = + match filter_method env met obj.exp_type with + | ty -> ty + | exception Filter_method_failed err -> + let error_ = + match err with + | Unification_error err -> + Expr_type_clash(err, explanation, None) + | Not_an_object ty -> + Not_an_object(ty, explanation) + | Not_a_method -> + let valid_methods = + match get_desc (expand_head env obj.exp_type) with + | Tobject (fields, _) -> + let (fields, _) = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if field_kind_repr meth_kind = Fpublic + then meth::li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None + in + Undefined_method(obj.exp_type, met, valid_methods) + in + raise (error(e.pexp_loc, env, error_)) + in + Tmeth_name met, ty + in + (obj,meth,typ) + +(* Typing of toplevel bindings *) + +let type_binding env rec_flag spat_sexp_list = + let (pat_exp_list, new_env) = + type_let + ~check:(fun s -> Warnings.Unused_value_declaration s) + ~check_strict:(fun s -> Warnings.Unused_value_declaration s) + At_toplevel + env rec_flag spat_sexp_list Modules_rejected + in + (pat_exp_list, new_env) + +let type_let existential_ctx env rec_flag spat_sexp_list = + let (pat_exp_list, new_env) = + type_let existential_ctx env rec_flag spat_sexp_list Modules_rejected in + (pat_exp_list, new_env) + +(* Typing of toplevel expressions *) + +let type_expression env sexp = + let exp = + with_local_level begin fun () -> + Typetexp.TyVarEnv.reset(); + type_exp env sexp + end + ~post:(may_lower_contravariant_then_generalize env) + in + match sexp.pexp_desc with + Pexp_ident lid -> + let loc = sexp.pexp_loc in + (* Special case for keeping type variables when looking-up a variable *) + let (_path, desc) = Env.lookup_value ~use:false ~loc lid.txt env in + {exp with exp_type = desc.val_type} + | _ -> exp + +(* Error report *) + +let spellcheck ppf unbound_name valid_names = + Misc.did_you_mean ppf (fun () -> + Misc.spellcheck valid_names unbound_name + ) + +let spellcheck_idents ppf unbound valid_idents = + spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents) + +open Format + +let longident = Printtyp.longident + +(* Returns the first diff of the trace *) +let type_clash_of_trace trace = + Errortrace.(explain trace (fun ~prev:_ -> function + | Diff diff -> Some diff + | _ -> None + )) + +(* Hint on type error on integer literals + To avoid confusion, it is disabled on float literals + and when the expected type is `int` *) +let report_literal_type_constraint expected_type const = + let const_str = match const with + | Pconst_integer (s, _) -> Some s + | _ -> None + in + let suffix = + if Path.same expected_type Predef.path_int32 then + Some 'l' + else if Path.same expected_type Predef.path_int64 then + Some 'L' + else if Path.same expected_type Predef.path_nativeint then + Some 'n' + else if Path.same expected_type Predef.path_float then + Some '.' + else None + in + match const_str, suffix with + | Some c, Some s -> [ Location.msg "@[@{Hint@}: Did you \ + mean `%s%c'?@]" c s ] + | _, _ -> [] + +let report_literal_type_constraint const = function + | Some tr -> + begin match get_desc Errortrace.(tr.expected.ty) with + Tconstr (typ, [], _) -> + report_literal_type_constraint typ const + | _ -> [] + end + | None -> [] + +let report_partial_application = function + | Some tr -> begin + match get_desc tr.Errortrace.got.Errortrace.expanded with + | Tarrow _ -> + [ Location.msg + "@[@{Hint@}: This function application is partial,@ \ + maybe some arguments are missing.@]" ] + | _ -> [] + end + | None -> [] + +let report_expr_type_clash_hints exp diff = + match exp with + | Some (Pexp_constant const) -> report_literal_type_constraint const diff + | Some (Pexp_apply _) -> report_partial_application diff + | _ -> [] + +let report_pattern_type_clash_hints pat diff = + match pat with + | Some (Ppat_constant const) -> report_literal_type_constraint const diff + | _ -> [] + +let report_type_expected_explanation expl ppf = + let because expl_str = fprintf ppf "@ because it is in %s" expl_str in + match expl with + | If_conditional -> + because "the condition of an if-statement" + | If_no_else_branch -> + because "the result of a conditional with no else branch" + | While_loop_conditional -> + because "the condition of a while-loop" + | While_loop_body -> + because "the body of a while-loop" + | For_loop_start_index -> + because "a for-loop start index" + | For_loop_stop_index -> + because "a for-loop stop index" + | For_loop_body -> + because "the body of a for-loop" + | Assert_condition -> + because "the condition of an assertion" + | Sequence_left_hand_side -> + because "the left-hand side of a sequence" + | When_guard -> + because "a when-guard" + +let report_type_expected_explanation_opt expl ppf = + match expl with + | None -> () + | Some expl -> report_type_expected_explanation expl ppf + +let report_unification_error ~loc ?sub env err + ?type_expected_explanation txt1 txt2 = + Location.error_of_printer ~loc ?sub (fun ppf () -> + Printtyp.report_unification_error ppf env err + ?type_expected_explanation txt1 txt2 + ) () + +let report_this_function ppf funct = + if Typedtree.exp_is_nominal funct then + let pexp = Untypeast.untype_expression funct in + Format.fprintf ppf "The function '%a'" Pprintast.expression pexp + else Format.fprintf ppf "This function" + +let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc = + let open Location in + let cnum_offset off (pos : Lexing.position) = + { pos with pos_cnum = pos.pos_cnum + off } + in + let app_loc = + (* Span the application, including the extra argument. *) + { loc_start = loc.loc_start; + loc_end = extra_arg_loc.loc_end; + loc_ghost = false } + and tail_loc = + (* Possible location for a ';'. The location is widened to overlap the end + of the argument. *) + let arg_end = previous_arg_loc.loc_end in + { loc_start = cnum_offset ~-1 arg_end; + loc_end = cnum_offset ~+1 arg_end; + loc_ghost = false } + in + let hint_semicolon = if returns_unit then [ + msg ~loc:tail_loc "@{Hint@}: Did you forget a ';'?"; + ] else [] in + let sub = hint_semicolon @ [ + msg ~loc:extra_arg_loc "This extra argument is not expected."; + ] in + errorf ~loc:app_loc ~sub + "@[@[<2>%a has type@ %a@]\ + @ It is applied to too many arguments@]" + report_this_function funct Printtyp.type_expr func_ty + +let report_error ~loc env = function + | Constructor_arity_mismatch(lid, expected, provided) -> + Location.errorf ~loc + "@[The constructor %a@ expects %i argument(s),@ \ + but is applied here to %i argument(s)@]" + longident lid expected provided + | Label_mismatch(lid, err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "The record field %a@ belongs to the type" + longident lid) + (function ppf -> + fprintf ppf "but is mixed here with fields of type") + | Pattern_type_clash (err, pat) -> + let diff = type_clash_of_trace err.trace in + let sub = report_pattern_type_clash_hints pat diff in + report_unification_error ~loc ~sub env err + (function ppf -> + fprintf ppf "This pattern matches values of type") + (function ppf -> + fprintf ppf "but a pattern was expected which matches values of \ + type"); + | Or_pattern_type_clash (id, err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "The variable %s on the left-hand side of this \ + or-pattern has type" (Ident.name id)) + (function ppf -> + fprintf ppf "but on the right-hand side it has type") + | Multiply_bound_variable name -> + Location.errorf ~loc + "Variable %s is bound several times in this matching" + name + | Orpat_vars (id, valid_idents) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf + "Variable %s must occur on both sides of this | pattern" + (Ident.name id); + spellcheck_idents ppf id valid_idents + ) () + | Expr_type_clash (err, explanation, exp) -> + let diff = type_clash_of_trace err.trace in + let sub = report_expr_type_clash_hints exp diff in + report_unification_error ~loc ~sub env err + ~type_expected_explanation: + (report_type_expected_explanation_opt explanation) + (function ppf -> + fprintf ppf "This expression has type") + (function ppf -> + fprintf ppf "but an expression was expected of type"); + | Apply_non_function { + funct; func_ty; res_ty; previous_arg_loc; extra_arg_loc + } -> + begin match get_desc func_ty with + Tarrow _ -> + let returns_unit = match get_desc res_ty with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + in + report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc + | _ -> + Location.errorf ~loc "@[@[<2>This expression has type@ %a@]@ %s@]" + Printtyp.type_expr func_ty + "This is not a function; it cannot be applied." + end + | Apply_wrong_label (l, ty, extra_info) -> + let print_label ppf = function + | Nolabel -> fprintf ppf "without label" + | l -> fprintf ppf "with label %s" (prefixed_label_name l) + in + let extra_info = + if not extra_info then + [] + else + [ Location.msg + "Since OCaml 4.11, optional arguments do not commute when \ + -nolabels is given" ] + in + Location.errorf ~loc ~sub:extra_info + "@[@[<2>The function applied to this argument has type@ %a@]@.\ + This argument cannot be applied %a@]" + Printtyp.type_expr ty print_label l + | Label_multiply_defined s -> + Location.errorf ~loc "The record field label %s is defined several times" + s + | Label_missing labels -> + let print_labels ppf = + List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in + Location.errorf ~loc "@[Some record fields are undefined:%a@]" + print_labels labels + | Label_not_mutable lid -> + Location.errorf ~loc "The record field %a is not mutable" longident lid + | Wrong_name (eorp, ty_expected, { type_path; kind; name; valid_names; }) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.wrap_printing_env ~error:true env (fun () -> + let { ty; explanation } = ty_expected in + if Path.is_constructor_typath type_path then begin + fprintf ppf + "@[The field %s is not part of the record \ + argument for the %a constructor@]" + name.txt + Printtyp.type_path type_path; + end else begin + fprintf ppf + "@[@[<2>%s type@ %a%t@]@ \ + There is no %s %s within type %a@]" + eorp Printtyp.type_expr ty + (report_type_expected_explanation_opt explanation) + (Datatype_kind.label_name kind) + name.txt (*kind*) Printtyp.type_path type_path; + end; + spellcheck ppf name.txt valid_names + )) () + | Name_type_mismatch (kind, lid, tp, tpl) -> + let type_name = Datatype_kind.type_name kind in + let name = Datatype_kind.label_name kind in + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.report_ambiguous_type_error ppf env tp tpl + (function ppf -> + fprintf ppf "The %s %a@ belongs to the %s type" + name longident lid type_name) + (function ppf -> + fprintf ppf "The %s %a@ belongs to one of the following %s types:" + name longident lid type_name) + (function ppf -> + fprintf ppf "but a %s was expected belonging to the %s type" + name type_name) + ) () + | Invalid_format msg -> + Location.errorf ~loc "%s" msg + | Not_an_object (ty, explanation) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "This expression is not an object;@ \ + it has type %a" + Printtyp.type_expr ty; + report_type_expected_explanation_opt explanation ppf + ) () + | Undefined_method (ty, me, valid_methods) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.wrap_printing_env ~error:true env (fun () -> + fprintf ppf + "@[@[This expression has type@;<1 2>%a@]@,\ + It has no method %s@]" Printtyp.type_expr ty me; + begin match valid_methods with + | None -> () + | Some valid_methods -> spellcheck ppf me valid_methods + end + )) () + | Undefined_self_method (me, valid_methods) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "This expression has no method %s" me; + spellcheck ppf me valid_methods; + ) () + | Virtual_class cl -> + Location.errorf ~loc "Cannot instantiate the virtual class %a" + longident cl + | Unbound_instance_variable (var, valid_vars) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "Unbound instance variable %s" var; + spellcheck ppf var valid_vars; + ) () + | Instance_variable_not_mutable v -> + Location.errorf ~loc "The instance variable %s is not mutable" v + | Not_subtype err -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.Subtype.report_error ppf env err "is not a subtype of" + ) () + | Outside_class -> + Location.errorf ~loc + "This object duplication occurs outside a method definition" + | Value_multiply_overridden v -> + Location.errorf ~loc + "The instance variable %s is overridden several times" + v + | Coercion_failure (ty_exp, err, b) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.report_unification_error ppf env err + (function ppf -> + let ty_exp = Printtyp.prepare_expansion ty_exp in + fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \ + it has type" + (Printtyp.type_expansion Type) ty_exp) + (function ppf -> + fprintf ppf "but is here used with type"); + if b then + fprintf ppf ".@.@[%s@ @{Hint@}: Consider using a fully \ + explicit coercion@ %s@]" + "This simple coercion was not fully general." + "of the form: `(foo : ty1 :> ty2)'." + ) () + | Not_a_function (ty, explanation) -> + Location.errorf ~loc + "This expression should not be a function,@ \ + the expected type is@ %a%t" + Printtyp.type_expr ty + (report_type_expected_explanation_opt explanation) + | Too_many_arguments (ty, explanation) -> + Location.errorf ~loc + "This function expects too many arguments,@ \ + it should have type@ %a%t" + Printtyp.type_expr ty + (report_type_expected_explanation_opt explanation) + | Abstract_wrong_label {got; expected; expected_type; explanation} -> + let label ~long = function + | Nolabel -> "unlabeled" + | l -> (if long then "labeled " else "") ^ prefixed_label_name l + in + let second_long = match got, expected with + | Nolabel, _ | _, Nolabel -> true + | _ -> false + in + Location.errorf ~loc + "@[@[<2>This function should have type@ %a%t@]@,\ + @[but its first argument is %s@ instead of %s%s@]@]" + Printtyp.type_expr expected_type + (report_type_expected_explanation_opt explanation) + (label ~long:true got) + (if second_long then "being " else "") + (label ~long:second_long expected) + | Scoping_let_module(id, ty) -> + Location.errorf ~loc + "This `let module' expression has type@ %a@ \ + In this type, the locally bound module name %s escapes its scope" + Printtyp.type_expr ty id + | Private_type ty -> + Location.errorf ~loc "Cannot create values of the private type %a" + Printtyp.type_expr ty + | Private_label (lid, ty) -> + Location.errorf ~loc "Cannot assign field %a of the private type %a" + longident lid Printtyp.type_expr ty + | Private_constructor (constr, ty) -> + Location.errorf ~loc + "Cannot use private constructor %s to create values of type %a" + constr.cstr_name Printtyp.type_expr ty + | Not_a_polymorphic_variant_type lid -> + Location.errorf ~loc "The type %a@ is not a variant type" longident lid + | Incoherent_label_order -> + Location.errorf ~loc + "This function is applied to arguments@ \ + in an order different from other calls.@ \ + This is only allowed when the real type is known." + | Less_general (kind, err) -> + report_unification_error ~loc env err + (fun ppf -> fprintf ppf "This %s has type" kind) + (fun ppf -> fprintf ppf "which is less general than") + | Modules_not_allowed -> + Location.errorf ~loc "Modules are not allowed in this pattern." + | Cannot_infer_signature -> + Location.errorf ~loc + "The signature for this packaged module couldn't be inferred." + | Not_a_packed_module ty -> + Location.errorf ~loc + "This expression is packed module, but the expected type is@ %a" + Printtyp.type_expr ty + | Unexpected_existential (reason, name, types) -> + let reason_str = + match reason with + | In_class_args -> + "Existential types are not allowed in class arguments" + | In_class_def -> + "Existential types are not allowed in bindings inside \ + class definition" + | In_self_pattern -> + "Existential types are not allowed in self patterns" + | At_toplevel -> + "Existential types are not allowed in toplevel bindings" + | In_group -> + "Existential types are not allowed in \"let ... and ...\" bindings" + | In_rec -> + "Existential types are not allowed in recursive bindings" + | With_attributes -> + "Existential types are not allowed in presence of attributes" + in + begin match List.find (fun ty -> ty <> "$" ^ name) types with + | example -> + Location.errorf ~loc + "%s,@ but this pattern introduces the existential type %s." + reason_str example + | exception Not_found -> + Location.errorf ~loc + "%s,@ but the constructor %s introduces existential types." + reason_str name + end + | Invalid_interval -> + Location.errorf ~loc + "@[Only character intervals are supported in patterns.@]" + | Invalid_for_loop_index -> + Location.errorf ~loc + "@[Invalid for-loop index: only variables and _ are allowed.@]" + | No_value_clauses -> + Location.errorf ~loc + "None of the patterns in this 'match' expression match values." + | Exception_pattern_disallowed -> + Location.errorf ~loc + "@[Exception patterns are not allowed in this position.@]" + | Mixed_value_and_exception_patterns_under_guard -> + Location.errorf ~loc + "@[Mixing value and exception patterns under when-guards is not \ + supported.@]" + | Inlined_record_escape -> + Location.errorf ~loc + "@[This form is not allowed as the type of the inlined record could \ + escape.@]" + | Inlined_record_expected -> + Location.errorf ~loc + "@[This constructor expects an inlined record argument.@]" + | Unrefuted_pattern pat -> + Location.errorf ~loc + "@[%s@ %s@ %a@]" + "This match case could not be refuted." + "Here is an example of a value that would reach it:" + Printpat.top_pretty pat + | Invalid_extension_constructor_payload -> + Location.errorf ~loc + "Invalid [%%extension_constructor] payload, a constructor is expected." + | Not_an_extension_constructor -> + Location.errorf ~loc + "This constructor is not an extension constructor." + | Literal_overflow ty -> + Location.errorf ~loc + "Integer literal exceeds the range of representable integers of type %s" + ty + | Unknown_literal (n, m) -> + Location.errorf ~loc "Unknown modifier '%c' for literal %s%c" m n m + | Illegal_letrec_pat -> + Location.errorf ~loc + "Only variables are allowed as left-hand side of `let rec'" + | Illegal_letrec_expr -> + Location.errorf ~loc + "This kind of expression is not allowed as right-hand side of `let rec'" + | Illegal_class_expr -> + Location.errorf ~loc + "This kind of recursive class expression is not allowed" + | Letop_type_clash(name, err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "The operator %s has type" name) + (function ppf -> + fprintf ppf "but it was expected to have type") + | Andop_type_clash(name, err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "The operator %s has type" name) + (function ppf -> + fprintf ppf "but it was expected to have type") + | Bindings_type_clash(err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "These bindings have type") + (function ppf -> + fprintf ppf "but bindings were expected of type") + | Unbound_existential (ids, ty) -> + Location.errorf ~loc + "@[<2>%s:@ @[type %s.@ %a@]@]" + "This type does not bind all existentials in the constructor" + (String.concat " " (List.map Ident.name ids)) + Printtyp.type_expr ty + | Missing_type_constraint -> + Location.errorf ~loc + "@[%s@ %s@]" + "Existential types introduced in a constructor pattern" + "must be bound by a type constraint on the argument." + | Wrong_expected_kind(sort, ctx, ty) -> + let ctx, explanation = + match ctx with + | Expression explanation -> "expression", explanation + | Pattern -> "pattern", None + in + let sort = + match sort with + | Constructor -> "constructor" + | Boolean -> "boolean literal" + | List -> "list literal" + | Unit -> "unit literal" + | Record -> "record" + in + Location.errorf ~loc + "This %s should not be a %s,@ \ + the expected type is@ %a%t" + ctx sort Printtyp.type_expr ty + (report_type_expected_explanation_opt explanation) + | Expr_not_a_record_type ty -> + Location.errorf ~loc + "This expression has type %a@ \ + which is not a record type." + Printtyp.type_expr ty + +let report_error ~loc env err = + Printtyp.wrap_printing_env ~error:true env + (fun () -> report_error ~loc env err) + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (report_error ~loc env err) + | Error_forward err -> + Some err + | _ -> + None + ) + +let () = + Persistent_env.add_delayed_check_forward := add_delayed_check; + Env.add_delayed_check_forward := add_delayed_check; + () + +(* drop ?recarg argument from the external API *) +let type_expect ?in_function env e ty = type_expect ?in_function env e ty +let type_exp env e = type_exp env e +let type_argument env e t1 t2 = type_argument env e t1 t2 + +(* Merlin specific *) +let partial_pred ~lev = + let splitting_mode = Refine_or {inside_nonsplit_or = false} in + partial_pred ~allow_modules:(Modules_allowed { scope = lev }) ~splitting_mode ~lev diff --git a/ocamlmerlin_mlx/ocaml/typing/typecore.mli b/ocamlmerlin_mlx/ocaml/typing/typecore.mli new file mode 100644 index 0000000..1c6374c --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typecore.mli @@ -0,0 +1,272 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Type inference for the core language *) + +open Asttypes +open Types + +(* This variant is used to print improved error messages, and does not affect + the behavior of the typechecker itself. + + It describes possible explanation for types enforced by a keyword of the + language; e.g. "if" requires the condition to be of type bool, and the + then-branch to be of type unit if there is no else branch; "for" requires + indices to be of type int, and the body to be of type unit. +*) +type type_forcing_context = + | If_conditional + | If_no_else_branch + | While_loop_conditional + | While_loop_body + | For_loop_start_index + | For_loop_stop_index + | For_loop_body + | Assert_condition + | Sequence_left_hand_side + | When_guard + +(* The combination of a type and a "type forcing context". The intent is that it + describes a type that is "expected" (required) by the context. If unifying + with such a type fails, then the "explanation" field explains why it was + required, in order to display a more enlightening error message. +*) +type type_expected = private { + ty: type_expr; + explanation: type_forcing_context option; +} + +(* Variables in patterns *) +type pattern_variable = + { + pv_id: Ident.t; + pv_type: type_expr; + pv_loc: Location.t; + pv_as_var: bool; + pv_attributes: Typedtree.attributes; + } + +val mk_expected: + ?explanation:type_forcing_context -> + type_expr -> + type_expected + +val is_nonexpansive: Typedtree.expression -> bool + +module Datatype_kind : sig + type t = Record | Variant + val type_name : t -> string + val label_name : t -> string +end + +type wrong_name = { + type_path: Path.t; + kind: Datatype_kind.t; + name: string loc; + valid_names: string list; +} + +type wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +type existential_restriction = + | At_toplevel (** no existential types at the toplevel *) + | In_group (** nor with [let ... and ...] *) + | In_rec (** or recursive definition *) + | With_attributes (** or [let[@any_attribute] = ...] *) + | In_class_args (** or in class arguments [class c (...) = ...] *) + | In_class_def (** or in [class c = let ... in ...] *) + | In_self_pattern (** or in self pattern *) + +type module_patterns_restriction = + | Modules_allowed of { scope : int } + | Modules_rejected + +val type_binding: + Env.t -> rec_flag -> + Parsetree.value_binding list -> + Typedtree.value_binding list * Env.t +val type_let: + existential_restriction -> Env.t -> rec_flag -> + Parsetree.value_binding list -> + Typedtree.value_binding list * Env.t +val type_expression: + Env.t -> Parsetree.expression -> Typedtree.expression +val type_class_arg_pattern: + string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern -> + Typedtree.pattern * + (Ident.t * Ident.t * type_expr) list * + Env.t * Env.t +val type_self_pattern: + Env.t -> Parsetree.pattern -> + Typedtree.pattern * pattern_variable list +val check_partial: + ?lev:int -> module_patterns_restriction -> Env.t -> type_expr -> + Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial +val type_expect: + ?in_function:(Location.t * type_expr) -> + Env.t -> Parsetree.expression -> type_expected -> Typedtree.expression +val type_exp: + Env.t -> Parsetree.expression -> Typedtree.expression +val type_approx: + Env.t -> Parsetree.expression -> type_expr +val type_argument: + Env.t -> Parsetree.expression -> + type_expr -> type_expr -> Typedtree.expression + +val option_some: Env.t -> Typedtree.expression -> Typedtree.expression +val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression +val extract_option_type: Env.t -> type_expr -> type_expr +val generalizable: int -> type_expr -> bool +val generalize_structure_exp: Typedtree.expression -> unit +type delayed_check +val delayed_checks: delayed_check list ref +val reset_delayed_checks: unit -> unit +val force_delayed_checks: unit -> unit + +val name_pattern : string -> Typedtree.pattern list -> Ident.t +val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t + +val self_coercion : (Path.t * Location.t list ref) list ref + +type error = + | Constructor_arity_mismatch of Longident.t * int * int + | Label_mismatch of Longident.t * Errortrace.unification_error + | Pattern_type_clash : + Errortrace.unification_error * Parsetree.pattern_desc option + -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * type_forcing_context option + * Parsetree.expression_desc option + | Apply_non_function of { + funct : Typedtree.expression; + func_ty : type_expr; + res_ty : type_expr; + previous_arg_loc : Location.t; + extra_arg_loc : Location.t; + } + | Apply_wrong_label of arg_label * type_expr * bool + | Label_multiply_defined of string + | Label_missing of Ident.t list + | Label_not_mutable of Longident.t + | Wrong_name of string * type_expected * wrong_name + | Name_type_mismatch of + Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list + | Invalid_format of string + | Not_an_object of type_expr * type_forcing_context option + | Undefined_method of type_expr * string * string list option + | Undefined_self_method of string * string list + | Virtual_class of Longident.t + | Private_type of type_expr + | Private_label of Longident.t * type_expr + | Private_constructor of constructor_description * type_expr + | Unbound_instance_variable of string * string list + | Instance_variable_not_mutable of string + | Not_subtype of Errortrace.Subtype.error + | Outside_class + | Value_multiply_overridden of string + | Coercion_failure of + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } + | Scoping_let_module of string * type_expr + | Not_a_polymorphic_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * Errortrace.unification_error + | Modules_not_allowed + | Cannot_infer_signature + | Not_a_packed_module of type_expr + | Unexpected_existential of existential_restriction * string * string list + | Invalid_interval + | Invalid_for_loop_index + | No_value_clauses + | Exception_pattern_disallowed + | Mixed_value_and_exception_patterns_under_guard + | Inlined_record_escape + | Inlined_record_expected + | Unrefuted_pattern of Typedtree.pattern + | Invalid_extension_constructor_payload + | Not_an_extension_constructor + | Literal_overflow of string + | Unknown_literal of string * char + | Illegal_letrec_pat + | Illegal_letrec_expr + | Illegal_class_expr + | Letop_type_clash of string * Errortrace.unification_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +val report_error: loc:Location.t -> Env.t -> error -> Location.error + (** @deprecated. Use {!Location.error_of_exn}, {!Location.print_report}. *) + +(* Forward declaration, to be filled in by Typemod.type_module *) +val type_module: + (Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t) ref +(* Forward declaration, to be filled in by Typemod.type_open *) +val type_open: + (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> + Longident.t loc -> Path.t * Env.t) + ref +(* Forward declaration, to be filled in by Typemod.type_open_decl *) +val type_open_decl: + (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration -> + Typedtree.open_declaration * Types.signature * Env.t) + ref +(* Forward declaration, to be filled in by Typeclass.class_structure *) +val type_object: + (Env.t -> Location.t -> Parsetree.class_structure -> + Typedtree.class_structure * string list) ref +val type_package: + (Env.t -> Parsetree.module_expr -> Path.t -> (Longident.t * type_expr) list -> + Typedtree.module_expr * (Longident.t * type_expr) list) ref + +val constant: Parsetree.constant -> (Asttypes.constant, error) result + +val check_recursive_bindings : Env.t -> Typedtree.value_binding list -> unit +val check_recursive_class_bindings : + Env.t -> Ident.t list -> Typedtree.class_expr list -> unit + +(* Merlin specific *) +val partial_pred : + lev:int -> + ?explode:int -> + Env.t -> + type_expr -> + Typedtree.pattern -> + Typedtree.pattern option diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl.ml b/ocamlmerlin_mlx/ocaml/typing/typedecl.ml new file mode 100644 index 0000000..c3820f3 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl.ml @@ -0,0 +1,2219 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(**** Typing of type definitions ****) + +open Misc +open Asttypes +open Parsetree +open Primitive +open Types +open Typetexp + +module String = Misc.String + +type native_repr_kind = Unboxed | Untagged + +(* Our static analyses explore the set of type expressions "reachable" + from a type declaration, by expansion of definitions or by the + subterm relation (a type expression is syntactically contained + in another). *) +type reaching_type_path = reaching_type_step list +and reaching_type_step = + | Expands_to of type_expr * type_expr + | Contains of type_expr * type_expr + +type error = + Repeated_parameter + | Duplicate_constructor of string + | Too_many_constructors + | Duplicate_label of string + | Recursive_abbrev of string * Env.t * reaching_type_path + | Cycle_in_def of string * Env.t * reaching_type_path + | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error + | Non_regular of { + definition: Path.t; + used_as: type_expr; + defined_as: type_expr; + reaching_path: reaching_type_path; + } + | Null_arity_external + | Missing_native_external + | Unbound_type_var of type_expr * type_declaration + | Cannot_extend_private_type of Path.t + | Not_extensible_type of Path.t + | Extension_mismatch of Path.t * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error + | Rebind_mismatch of Longident.t * Path.t * Path.t + | Rebind_private of Longident.t + | Variance of Typedecl_variance.error + | Unavailable_type_constructor of Path.t + | Unbound_type_var_ext of type_expr * extension_constructor + | Val_in_structure + | Multiple_native_repr_attributes + | Cannot_unbox_or_untag_type of native_repr_kind + | Deep_unbox_or_untag_attribute of native_repr_kind + | Immediacy of Typedecl_immediacy.error + | Separability of Typedecl_separability.error + | Bad_unboxed_attribute of string + | Boxed_and_unboxed + | Nonrec_gadt + | Invalid_private_row_declaration of type_expr + +open Typedtree + +exception Error of Location.t * error + +let get_unboxed_from_attributes sdecl = + let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in + let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in + match boxed, unboxed with + | true, true -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed)) + | true, false -> Some false + | false, true -> Some true + | false, false -> None + +(* Enter all declared types in the environment as abstract types *) + +let add_type ~long_path ~check id decl env = + Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes + (fun () -> + match long_path with + | true -> Env.add_type_long_path ~check id decl env + | false -> Env.add_type ~check id decl env) + +(* Add a dummy type declaration to the environment, with the given arity. + The [type_kind] is [Type_abstract], but there is a generic [type_manifest] + for abbreviations, to allow polymorphic expansion, except if + [abstract_abbrevs] is [true]. + This function is only used in [transl_type_decl]. *) +let enter_type ~abstract_abbrevs rec_flag env sdecl (id, uid) = + let needed = + match rec_flag with + | Asttypes.Nonrecursive -> + begin match sdecl.ptype_kind with + | Ptype_variant scds -> + List.iter (fun cd -> + if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt))) + scds + | _ -> () + end; + Btype.is_row_name (Ident.name id) + | Asttypes.Recursive -> true + in + let arity = List.length sdecl.ptype_params in + if not needed then env else + let type_manifest = match sdecl.ptype_manifest, abstract_abbrevs with + | None, _ | Some _, true -> None + | Some _, false -> Some(Ctype.newvar ()) + in + let decl = + { type_params = + List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; + type_arity = arity; + type_kind = Type_abstract; + type_private = sdecl.ptype_private; + type_manifest; + type_variance = Variance.unknown_signature ~injective:false ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = uid; + } + in + add_type ~long_path:true ~check:true id decl env + +let update_type temp_env env id loc = + let path = Path.Pident id in + let decl = Env.find_type path temp_env in + match decl.type_manifest with None -> () + | Some ty -> + let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in + try Ctype.unify env (Ctype.newconstr path params) ty + with Ctype.Unify err -> + raise (Error(loc, Type_clash (env, err))) + +(* Determine if a type's values are represented by floats at run-time. *) +let is_float env ty = + match Typedecl_unboxed.get_unboxed_type_representation env ty with + Some ty' -> + begin match get_desc ty' with + Tconstr(p, _, _) -> Path.same p Predef.path_float + | _ -> false + end + | _ -> false + +(* Determine if a type definition defines a fixed type. (PW) *) +let is_fixed_type sd = + let rec has_row_var sty = + match sty.ptyp_desc with + Ptyp_alias (sty, _) -> has_row_var sty + | Ptyp_class _ + | Ptyp_object (_, Open) + | Ptyp_variant (_, Open, _) + | Ptyp_variant (_, Closed, Some _) -> true + | _ -> false + in + match sd.ptype_manifest with + None -> false + | Some sty -> + sd.ptype_kind = Ptype_abstract && + sd.ptype_private = Private && + has_row_var sty + +(* Set the row variable to a fixed type in a private row type declaration. + (e.g. [ type t = private [< `A | `B ] ] or [type u = private < .. > ]) + Require [is_fixed_type decl] as a precondition +*) +let set_private_row env loc p decl = + let tm = + match decl.type_manifest with + None -> assert false + | Some t -> Ctype.expand_head env t + in + let rv = + match get_desc tm with + Tvariant row -> + let Row {fields; more; closed; name} = row_repr row in + set_type_desc tm + (Tvariant (create_row ~fields ~more ~closed ~name + ~fixed:(Some Fixed_private))); + if Btype.static_row row then + (* the syntax hinted at the existence of a row variable, + but there is in fact no row variable to make private, e.g. + [ type t = private [< `A > `A] ] *) + raise (Error(loc, Invalid_private_row_declaration tm)) + else more + | Tobject (ty, _) -> + let r = snd (Ctype.flatten_fields ty) in + if not (Btype.is_Tvar r) then + (* a syntactically open object was closed by a constraint *) + raise (Error(loc, Invalid_private_row_declaration tm)); + r + | _ -> assert false + in + set_type_desc rv (Tconstr (p, decl.type_params, ref Mnil)) + +(* Translate one type declaration *) + +let make_params env params = + let make_param (sty, v) = + try + (transl_type_param env sty, v) + with Already_bound -> + raise(Error(sty.ptyp_loc, Repeated_parameter)) + in + List.map make_param params + +let transl_labels env univars closed lbls = + assert (lbls <> []); + let all_labels = ref String.Set.empty in + List.iter + (fun {pld_name = {txt=name; loc}} -> + if String.Set.mem name !all_labels then + raise(Error(loc, Duplicate_label name)); + all_labels := String.Set.add name !all_labels) + lbls; + let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc; + pld_attributes=attrs} = + Builtin_attributes.warning_scope attrs + (fun () -> + let arg = Ast_helper.Typ.force_poly arg in + let cty = transl_simple_type env ?univars ~closed arg in + {ld_id = Ident.create_local name.txt; + ld_name = name; ld_mutable = mut; + ld_type = cty; ld_loc = loc; ld_attributes = attrs} + ) + in + let lbls = List.map mk lbls in + let lbls' = + List.map + (fun ld -> + let ty = ld.ld_type.ctyp_type in + let ty = match get_desc ty with Tpoly(t,[]) -> t | _ -> ty in + let ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + Env.register_uid ld_uid ld.ld_loc; + {Types.ld_id = ld.ld_id; + ld_mutable = ld.ld_mutable; + ld_type = ty; + ld_loc = ld.ld_loc; + ld_attributes = ld.ld_attributes; + ld_uid; + } + ) + lbls in + lbls, lbls' + +let transl_constructor_arguments env univars closed = function + | Pcstr_tuple l -> + let l = List.map (transl_simple_type env ?univars ~closed) l in + Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), + Cstr_tuple l + | Pcstr_record l -> + let lbls, lbls' = transl_labels env univars closed l in + Types.Cstr_record lbls', + Cstr_record lbls + +let make_constructor env loc type_path type_params svars sargs sret_type = + match sret_type with + | None -> + let args, targs = + transl_constructor_arguments env None true sargs + in + targs, None, args, None + | Some sret_type -> + (* if it's a generalized constructor we must first narrow and + then widen so as to not introduce any new constraints *) + (* narrow and widen are now invoked through wrap_type_variable_scope *) + TyVarEnv.with_local_scope begin fun () -> + let closed = svars <> [] in + let targs, tret_type, args, ret_type, _univars = + Ctype.with_local_level_if closed begin fun () -> + TyVarEnv.reset (); + let univar_list = + TyVarEnv.make_poly_univars (List.map (fun v -> v.txt) svars) in + let univars = if closed then Some univar_list else None in + let args, targs = + transl_constructor_arguments env univars closed sargs + in + let tret_type = + transl_simple_type env ?univars ~closed sret_type in + let ret_type = tret_type.ctyp_type in + (* TODO add back type_path as a parameter ? *) + begin match get_desc ret_type with + | Tconstr (p', _, _) when Path.same type_path p' -> () + | _ -> + let trace = + (* Expansion is not helpful here -- the restriction on GADT + return types is purely syntactic. (In the worst case, + expansion produces gibberish.) *) + [Ctype.unexpanded_diff + ~got:ret_type + ~expected:(Ctype.newconstr type_path type_params)] + in + raise (Error(sret_type.ptyp_loc, + Constraint_failed( + env, Errortrace.unification_error ~trace))) + end; + (targs, tret_type, args, ret_type, univar_list) + end + ~post: begin fun (_, _, args, ret_type, univars) -> + Btype.iter_type_expr_cstr_args Ctype.generalize args; + Ctype.generalize ret_type; + let _vars = TyVarEnv.instance_poly_univars env loc univars in + let set_level t = Ctype.enforce_current_level env t in + Btype.iter_type_expr_cstr_args set_level args; + set_level ret_type; + end + in + targs, Some tret_type, args, Some ret_type + end + +let transl_declaration env sdecl (id, uid) = + (* Bind type parameters *) + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + let tparams = make_params env sdecl.ptype_params in + let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in + let cstrs = List.map + (fun (sty, sty', loc) -> + transl_simple_type env ~closed:false sty, + transl_simple_type env ~closed:false sty', loc) + sdecl.ptype_cstrs + in + let unboxed_attr = get_unboxed_from_attributes sdecl in + begin match unboxed_attr with + | (None | Some false) -> () + | Some true -> + let bad msg = raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute msg)) in + match sdecl.ptype_kind with + | Ptype_abstract -> bad "it is abstract" + | Ptype_open -> bad "extensible variant types cannot be unboxed" + | Ptype_record fields -> begin match fields with + | [] -> bad "it has no fields" + | _::_::_ -> bad "it has more than one field" + | [{pld_mutable = Mutable}] -> bad "it is mutable" + | [{pld_mutable = Immutable}] -> () + end + | Ptype_variant constructors -> begin match constructors with + | [] -> bad "it has no constructor" + | (_::_::_) -> bad "it has more than one constructor" + | [c] -> begin match c.pcd_args with + | Pcstr_tuple [] -> + bad "its constructor has no argument" + | Pcstr_tuple (_::_::_) -> + bad "its constructor has more than one argument" + | Pcstr_tuple [_] -> + () + | Pcstr_record [] -> + bad "its constructor has no fields" + | Pcstr_record (_::_::_) -> + bad "its constructor has more than one field" + | Pcstr_record [{pld_mutable = Mutable}] -> + bad "it is mutable" + | Pcstr_record [{pld_mutable = Immutable}] -> + () + end + end + end; + let unbox, unboxed_default = + match sdecl.ptype_kind with + | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}] + | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Immutable; _}]; _}] + | Ptype_record [{pld_mutable=Immutable; _}] -> + Option.value unboxed_attr ~default:!Clflags.unboxed_types, + Option.is_none unboxed_attr + | _ -> false, false (* Not unboxable, mark as boxed *) + in + let (tkind, kind) = + match sdecl.ptype_kind with + | Ptype_abstract -> Ttype_abstract, Type_abstract + | Ptype_variant scstrs -> + if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin + match cstrs with + [] -> () + | (_,_,loc)::_ -> + Location.prerr_warning loc Warnings.Constraint_on_gadt + end; + let all_constrs = ref String.Set.empty in + List.iter + (fun {pcd_name = {txt = name}} -> + if String.Set.mem name !all_constrs then + raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); + all_constrs := String.Set.add name !all_constrs) + scstrs; + if List.length + (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs) + > (Config.max_tag + 1) then + raise(Error(sdecl.ptype_loc, Too_many_constructors)); + let make_cstr scstr = + let name = Ident.create_local scstr.pcd_name.txt in + let targs, tret_type, args, ret_type = + make_constructor env scstr.pcd_loc (Path.Pident id) params + scstr.pcd_vars scstr.pcd_args scstr.pcd_res + in + let tcstr = + { cd_id = name; + cd_name = scstr.pcd_name; + cd_vars = scstr.pcd_vars; + cd_args = targs; + cd_res = tret_type; + cd_loc = scstr.pcd_loc; + cd_attributes = scstr.pcd_attributes } + in + let cstr = + let cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + Env.register_uid cd_uid scstr.pcd_loc; + { Types.cd_id = name; + cd_args = args; + cd_res = ret_type; + cd_loc = scstr.pcd_loc; + cd_attributes = scstr.pcd_attributes; + cd_uid; } + in + tcstr, cstr + in + let make_cstr scstr = + Builtin_attributes.warning_scope scstr.pcd_attributes + (fun () -> make_cstr scstr) + in + let rep = if unbox then Variant_unboxed else Variant_regular in + let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in + Ttype_variant tcstrs, Type_variant (cstrs, rep) + | Ptype_record lbls -> + let lbls, lbls' = transl_labels env None true lbls in + let rep = + if unbox then Record_unboxed false + else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' + then Record_float + else Record_regular + in + Ttype_record lbls, Type_record(lbls', rep) + | Ptype_open -> Ttype_open, Type_open + in + let (tman, man) = match sdecl.ptype_manifest with + None -> None, None + | Some sty -> + let no_row = not (is_fixed_type sdecl) in + let cty = transl_simple_type env ~closed:no_row sty in + Some cty, Some cty.ctyp_type + in + let arity = List.length params in + let decl = + { type_params = params; + type_arity = arity; + type_kind = kind; + type_private = sdecl.ptype_private; + type_manifest = man; + type_variance = Variance.unknown_signature ~injective:false ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = Unknown; + type_unboxed_default = unboxed_default; + type_uid = uid; + } in + + (* Check constraints *) + List.iter + (fun (cty, cty', loc) -> + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + try Ctype.unify env ty ty' with Ctype.Unify err -> + raise(Error(loc, Inconsistent_constraint (env, err)))) + cstrs; + (* Add abstract row *) + if is_fixed_type sdecl then begin + let p, _ = + try Env.find_type_by_name + (Longident.Lident(Ident.name id ^ "#row")) env + with Not_found -> assert false + in + set_private_row env sdecl.ptype_loc p decl + end; + { + typ_id = id; + typ_name = sdecl.ptype_name; + typ_params = tparams; + typ_type = decl; + typ_cstrs = cstrs; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = tkind; + typ_private = sdecl.ptype_private; + typ_attributes = sdecl.ptype_attributes; + } + end + +(* Generalize a type declaration *) + +let generalize_decl decl = + List.iter Ctype.generalize decl.type_params; + Btype.iter_type_expr_kind Ctype.generalize decl.type_kind; + begin match decl.type_manifest with + | None -> () + | Some ty -> Ctype.generalize ty + end + +(* Check that all constraints are enforced *) + +module TypeSet = Btype.TypeSet +module TypeMap = Btype.TypeMap + +let rec check_constraints_rec env loc visited ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty with + | Tconstr (path, args, _) -> + let decl = + try Env.find_type path env + with Not_found -> + raise (Error(loc, Unavailable_type_constructor path)) in + let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in + begin + (* We don't expand the error trace because that produces types that + *already* violate the constraints -- we need to report a problem with + the unexpanded types, or we get errors that talk about the same type + twice. This is generally true for constraint errors. *) + try Ctype.matches ~expand_error_trace:false env ty ty' + with Ctype.Matches_failure (env, err) -> + raise (Error(loc, Constraint_failed (env, err))) + end; + List.iter (check_constraints_rec env loc visited) args + | Tpoly (ty, tl) -> + let _, ty = Ctype.instance_poly false tl ty in + check_constraints_rec env loc visited ty + | _ -> + Btype.iter_type_expr (check_constraints_rec env loc visited) ty + end + +let check_constraints_labels env visited l pl = + let rec get_loc name = function + [] -> assert false + | pld :: tl -> + if name = pld.pld_name.txt then pld.pld_type.ptyp_loc + else get_loc name tl + in + List.iter + (fun {Types.ld_id=name; ld_type=ty} -> + check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) + l + +let check_constraints env sdecl (_, decl) = + let visited = ref TypeSet.empty in + List.iter2 + (fun (sty, _) ty -> check_constraints_rec env sty.ptyp_loc visited ty) + sdecl.ptype_params decl.type_params; + begin match decl.type_kind with + | Type_abstract -> () + | Type_variant (l, _rep) -> + let find_pl = function + Ptype_variant pl -> pl + | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false + in + let pl = find_pl sdecl.ptype_kind in + let pl_index = + let foldf acc x = + String.Map.add x.pcd_name.txt x acc + in + List.fold_left foldf String.Map.empty pl + in + List.iter + (fun {Types.cd_id=name; cd_args; cd_res} -> + let {pcd_args; pcd_res; _} = + try String.Map.find (Ident.name name) pl_index + with Not_found -> assert false in + begin match cd_args, pcd_args with + | Cstr_tuple tyl, Pcstr_tuple styl -> + List.iter2 + (fun sty ty -> + check_constraints_rec env sty.ptyp_loc visited ty) + styl tyl + | Cstr_record tyl, Pcstr_record styl -> + check_constraints_labels env visited tyl styl + | _ -> assert false + end; + match pcd_res, cd_res with + | Some sr, Some r -> + check_constraints_rec env sr.ptyp_loc visited r + | _ -> + () ) + l + | Type_record (l, _) -> + let find_pl = function + Ptype_record pl -> pl + | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false + in + let pl = find_pl sdecl.ptype_kind in + check_constraints_labels env visited l pl + | Type_open -> () + end; + begin match decl.type_manifest with + | None -> () + | Some ty -> + let sty = + match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false + in + check_constraints_rec env sty.ptyp_loc visited ty + end + +(* + If both a variant/record definition and a type equation are given, + need to check that the equation refers to a type of the same kind + with the same constructors and labels. +*) +let check_coherence env loc dpath decl = + match decl with + { type_kind = (Type_variant _ | Type_record _| Type_open); + type_manifest = Some ty } -> + begin match get_desc ty with + Tconstr(path, args, _) -> + begin try + let decl' = Env.find_type path env in + let err = + if List.length args <> List.length decl.type_params + then Some Includecore.Arity + else begin + match Ctype.equal env false args decl.type_params with + | exception Ctype.Equality err -> + Some (Includecore.Constraint err) + | () -> + Includecore.type_declarations ~loc ~equality:true env + ~mark:true + (Path.last path) + decl' + dpath + (Subst.type_declaration + (Subst.add_type_path dpath path Subst.identity) decl) + end + in + if err <> None then + raise(Error(loc, Definition_mismatch (ty, env, err))) + with Not_found -> + raise(Error(loc, Unavailable_type_constructor path)) + end + | _ -> raise(Error(loc, Definition_mismatch (ty, env, None))) + end + | _ -> () + +let check_abbrev env sdecl (id, decl) = + check_coherence env sdecl.ptype_loc (Path.Pident id) decl + + +(* Note: Well-foundedness for OCaml types + + We want to guarantee that all cycles within OCaml types are + "guarded". + + More precisly, we consider a reachability relation + "[t] is reachable [guarded|unguarded] from [u]" + defined as follows: + + - [t1, t2...] are reachable guarded from object types + [< m1 : t1; m2 : t2; ... >] + or polymorphic variants + [[`A of t1 | `B of t2 | ...]]. + + - [t1, t2...] are reachable rectypes-guarded from + [t1 -> t2], [t1 * t2 * ...], and all other built-in + contractive type constructors. + + (By rectypes-guarded we mean: guarded if -rectypes is set, + unguarded if it is not set.) + + - If [(t1, t2...) c] is a datatype (variant or record), + then [t1, t2...] are reachable rectypes-guarded from it. + + - If [(t1, t2...) c] is an abstract type, + then [t1, t2...] are reachable unguarded from it. + + - If [(t1, t2...) c] is an (expandable) abbreviation, + then its expansion is reachable unguarded from it. + Note that we do not define [t1, t2...] as reachable. + + - The relation is transitive and guardedness of a composition + is the disjunction of each guardedness: + if t1 is reachable from t2 and t2 is reachable from t3; + then t1 is reachable guarded from t3 if t1 is guarded in t2 + or t2 is guarded in t3, and reachable unguarded otherwise. + + A type [t] is not well-founded if and only if [t] is reachable + unguarded in [t]. + + Notice that, in the case of datatypes, the arguments of + a parametrized datatype are reachable (they must not contain + recursive occurrences of the type), but the definition of the + datatype is not defined as reachable. + + (* well-founded *) + type t = Foo of u + and u = t + + (* ill-founded *) + type 'a t = Foo of 'a + and u = u t + > Error: The type abbreviation u is cyclic + + Indeed, in the second example [u] is reachable unguarded in [u t] + -- its own definition. +*) + +(* Note: Forms of ill-foundedness + + Several OCaml language constructs could introduce ill-founded + types, and there are several distinct checks that forbid different + sources of ill-foundedness. + + 1. Type aliases. + + (* well-founded *) + type t = < x : 'a > as 'a + + (* ill-founded, unless -rectypes is used *) + type t = (int * 'a) as 'a + > Error: This alias is bound to type int * 'a + > but is used as an instance of type 'a + > The type variable 'a occurs inside int * 'a + + Ill-foundedness coming from type aliases is detected by the "occur check" + used by our type unification algorithm. See typetexp.ml. + + 2. Type abbreviations. + + (* well-founded *) + type t = < x : t > + + (* ill-founded, unless -rectypes is used *) + type t = (int * t) + > Error: The type abbreviation t is cyclic + + Ill-foundedness coming from type abbreviations is detected by + [check_well_founded] below. + + 3. Recursive modules. + + (* well-founded *) + module rec M : sig type t = < x : M.t > end = M + + (* ill-founded, unless -rectypes is used *) + module rec M : sig type t = int * M.t end = M + > Error: The definition of M.t contains a cycle: + > int * M.t + + This is also checked by [check_well_founded] below, + as called from [check_recmod_typedecl]. + + 4. Functor application + + A special case of (3) is that a type can be abstract + in a functor definition, and be instantiated with + an abbreviation in an application of the functor. + This can introduce ill-foundedness, so functor applications + must be checked by re-checking the type declarations of their result. + + module type T = sig type t end + module Fix(F:(T -> T)) = struct + (* this recursive definition is well-founded + as F(Fixed).t contains no reachable type expression. *) + module rec Fixed : T with type t = F(Fixed).t = F(Fixed) + end + + (* well-founded *) + Module M = Fix(functor (M:T) -> struct type t = < x : M.t > end) + + (* ill-founded *) + module M = Fix(functor (M:T) -> struct type t = int * M.t end);; + > Error: In the signature of this functor application: + > The definition of Fixed.t contains a cycle: + > F(Fixed).t +*) + +(* Check that a type expression is well-founded: + - if -rectypes is used, we must prevent non-contractive fixpoints + ('a as 'a) + - if -rectypes is not used, we only allow cycles in the type graph + if they go through an object or polymorphic variant type *) + +let check_well_founded ~abs_env env loc path to_check visited ty0 = + let rec check parents trace ty = + if TypeSet.mem ty parents then begin + (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) + let err = + let reaching_path, rec_abbrev = + (* The reaching trace is accumulated in reverse order, we + reverse it to get a reaching path. *) + match trace with + | [] -> assert false + | Expands_to (ty1, _) :: trace when (match get_desc ty1 with + Tconstr (p,_,_) -> Path.same p path | _ -> false) -> + List.rev trace, true + | trace -> List.rev trace, false + in + if rec_abbrev + then Recursive_abbrev (Path.name path, abs_env, reaching_path) + else Cycle_in_def (Path.name path, abs_env, reaching_path) + in raise (Error (loc, err)) + end; + let (fini, parents) = + try + (* Map each node to the set of its already checked parents *) + let prev = TypeMap.find ty !visited in + if TypeSet.subset parents prev then (true, parents) else + let parents = TypeSet.union parents prev in + visited := TypeMap.add ty parents !visited; + (false, parents) + with Not_found -> + visited := TypeMap.add ty parents !visited; + (false, parents) + in + if fini then () else + let rec_ok = + match get_desc ty with + | Tconstr(p,_,_) -> + !Clflags.recursive_types && Ctype.is_contractive env p + | Tobject _ | Tvariant _ -> true + | _ -> !Clflags.recursive_types + in + if rec_ok then () else + let parents = TypeSet.add ty parents in + match get_desc ty with + | Tconstr(p, tyl, _) -> + let to_check = to_check p in + if to_check then List.iter (check_subtype parents trace ty) tyl; + begin match Ctype.try_expand_once_opt env ty with + | ty' -> check parents (Expands_to (ty, ty') :: trace) ty' + | exception Ctype.Cannot_expand -> + if not to_check then List.iter (check_subtype parents trace ty) tyl + end + | _ -> + Btype.iter_type_expr (check_subtype parents trace ty) ty + and check_subtype parents trace outer_ty inner_ty = + check parents (Contains (outer_ty, inner_ty) :: trace) inner_ty + in + let snap = Btype.snapshot () in + try Ctype.wrap_trace_gadt_instances env (check TypeSet.empty []) ty0 + with Ctype.Escape _ -> + (* Will be detected by check_regularity *) + Btype.backtrack snap + +let check_well_founded_manifest ~abs_env env loc path decl = + if decl.type_manifest = None then () else + let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in + let visited = ref TypeMap.empty in + check_well_founded ~abs_env env loc path (Path.same path) visited + (Ctype.newconstr path args) + +(* Given a new type declaration [type t = ...] (potentially mutually-recursive), + we check that accepting the declaration does not introduce ill-founded types. + + Note: we check that the types at the toplevel of the declaration + are not reachable unguarded from themselves, that is, we check that + there is no cycle going through the "root" of the declaration. But + we *also* check that all the type sub-expressions reachable from + the root even those that are guarded, are themselves + well-founded. (So we check the absence of cycles, even for cycles + going through inner type subexpressions but not the root. + + We are not actually sure that this "deep check" is necessary + (we don't have an example at hand where it is necessary), but we + are doing it anyway out of caution. +*) +let check_well_founded_decl ~abs_env env loc path decl to_check = + let open Btype in + (* We iterate on all subexpressions of the declaration to check + "in depth" that no ill-founded type exists. *) + let it = + let checked = + (* [checked] remembers the types that the iterator already + checked, to avoid looping on cyclic types. *) + ref TypeSet.empty in + let visited = + (* [visited] remembers the inner visits performed by + [check_well_founded] on each type expression reachable from + this declaration. This avoids unnecessary duplication of + [check_well_founded] work when invoked on two parts of the + type declaration that have common subexpressions. *) + ref TypeMap.empty in + {type_iterators with it_type_expr = + (fun self ty -> + if TypeSet.mem ty !checked then () else begin + check_well_founded ~abs_env env loc path to_check visited ty; + checked := TypeSet.add ty !checked; + self.it_do_type_expr self ty + end)} in + it.it_type_declaration it (Ctype.generic_instance_declaration decl) + +(* Check for non-regular abbreviations; an abbreviation + [type 'a t = ...] is non-regular if the expansion of [...] + contains instances [ty t] where [ty] is not equal to ['a]. + + Note: in the case of a constrained type definition + [type 'a t = ... constraint 'a = ...], we require + that all instances in [...] be equal to the constrainted type. +*) + +let check_regularity ~orig_env env loc path decl to_check = + (* to_check is true for potentially mutually recursive paths. + (path, decl) is the type declaration to be checked. *) + + if decl.type_params = [] then () else + + let visited = ref TypeSet.empty in + + let rec check_regular cpath args prev_exp trace ty = + if not (TypeSet.mem ty !visited) then begin + visited := TypeSet.add ty !visited; + match get_desc ty with + | Tconstr(path', args', _) -> + if Path.same path path' then begin + if not (Ctype.is_equal orig_env false args args') then + raise (Error(loc, + Non_regular { + definition=path; + used_as=ty; + defined_as=Ctype.newconstr path args; + reaching_path=List.rev trace; + })) + end + (* Attempt to expand a type abbreviation if: + 1- [to_check path'] holds + (otherwise the expansion cannot involve [path]); + 2- we haven't expanded this type constructor before + (otherwise we could loop if [path'] is itself + a non-regular abbreviation). *) + else if to_check path' && not (List.mem path' prev_exp) then begin + try + (* Attempt expansion *) + let (params0, body0, _) = Env.find_type_expansion path' env in + let (params, body) = + Ctype.instance_parameterized_type params0 body0 in + begin + try List.iter2 (Ctype.unify orig_env) params args' + with Ctype.Unify err -> + raise (Error(loc, Constraint_failed (orig_env, err))); + end; + check_regular path' args + (path' :: prev_exp) (Expands_to (ty,body) :: trace) + body + with Not_found -> () + end; + List.iter (check_subtype cpath args prev_exp trace ty) args' + | Tpoly (ty, tl) -> + let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in + check_regular cpath args prev_exp trace ty + | _ -> + Btype.iter_type_expr + (check_subtype cpath args prev_exp trace ty) ty + end + and check_subtype cpath args prev_exp trace outer_ty inner_ty = + let trace = Contains (outer_ty, inner_ty) :: trace in + check_regular cpath args prev_exp trace inner_ty + in + + Option.iter + (fun body -> + let (args, body) = + Ctype.instance_parameterized_type + ~keep_names:true decl.type_params body in + List.iter (check_regular path args [] []) args; + check_regular path args [] [] body) + decl.type_manifest + +let check_abbrev_regularity ~orig_env env id_loc_list to_check tdecl = + let decl = tdecl.typ_type in + let id = tdecl.typ_id in + check_regularity ~orig_env env (List.assoc id id_loc_list) (Path.Pident id) + decl to_check + +let check_duplicates sdecl_list = + let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in + List.iter + (fun sdecl -> match sdecl.ptype_kind with + Ptype_variant cl -> + List.iter + (fun pcd -> + try + let name' = Hashtbl.find constrs pcd.pcd_name.txt in + Location.prerr_warning pcd.pcd_loc + (Warnings.Duplicate_definitions + ("constructor", pcd.pcd_name.txt, name', + sdecl.ptype_name.txt)) + with Not_found -> + Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt) + cl + | Ptype_record fl -> + List.iter + (fun {pld_name=cname;pld_loc=loc} -> + try + let name' = Hashtbl.find labels cname.txt in + Location.prerr_warning loc + (Warnings.Duplicate_definitions + ("label", cname.txt, name', sdecl.ptype_name.txt)) + with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt) + fl + | Ptype_abstract -> () + | Ptype_open -> ()) + sdecl_list + +(* Force recursion to go through id for private types*) +let name_recursion sdecl id decl = + match decl with + | { type_kind = Type_abstract; + type_manifest = Some ty; + type_private = Private; } when is_fixed_type sdecl -> + let ty' = newty2 ~level:(get_level ty) (get_desc ty) in + if Ctype.deep_occur ty ty' then + let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in + link_type ty (newty2 ~level:(get_level ty) td); + {decl with type_manifest = Some ty'} + else decl + | _ -> decl + +let name_recursion_decls sdecls decls = + List.map2 (fun sdecl (id, decl) -> (id, name_recursion sdecl id decl)) + sdecls decls + +(* Warn on definitions of type "type foo = ()" which redefine a different unit + type and are likely a mistake. *) +let check_redefined_unit (td: Parsetree.type_declaration) = + let open Parsetree in + let is_unit_constructor cd = cd.pcd_name.txt = "()" in + match td with + | { ptype_name = { txt = name }; + ptype_manifest = None; + ptype_kind = Ptype_variant [ cd ] } + when is_unit_constructor cd -> + Location.prerr_warning td.ptype_loc (Warnings.Redefining_unit name) + | _ -> + () + +let add_types_to_env decls env = + List.fold_right + (fun (id, decl) env -> add_type ~long_path:false ~check:true id decl env) + decls env + +(* Translate a set of type declarations, mutually recursive or not *) +let transl_type_decl env rec_flag sdecl_list = + List.iter check_redefined_unit sdecl_list; + (* Add dummy types for fixed rows *) + let fixed_types = List.filter is_fixed_type sdecl_list in + let sdecl_list = + List.map + (fun sdecl -> + let ptype_name = + let loc = { sdecl.ptype_name.loc with Location.loc_ghost = true } in + mkloc (sdecl.ptype_name.txt ^"#row") loc + in + let ptype_kind = Ptype_abstract in + let ptype_manifest = None in + let ptype_loc = { sdecl.ptype_loc with Location.loc_ghost = true } in + {sdecl with + ptype_name; ptype_kind; ptype_manifest; ptype_loc }) + fixed_types + @ sdecl_list + in + + (* Create identifiers. *) + let scope = Ctype.create_scope () in + let ids_list = + List.map (fun sdecl -> + Ident.create_scoped ~scope sdecl.ptype_name.txt, + Uid.mk ~current_unit:(Env.get_unit_name ()) + ) sdecl_list + in + let tdecls, decls, new_env = + Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> + (* Enter types. *) + let temp_env = + List.fold_left2 (enter_type ~abstract_abbrevs:false rec_flag) + env sdecl_list ids_list in + (* Translate each declaration. *) + let current_slot = ref None in + let warn_unused = + Warnings.is_active (Warnings.Unused_type_declaration "") in + let ids_slots (id, _uid as ids) = + match rec_flag with + | Asttypes.Recursive when warn_unused -> + (* See typecore.ml for a description of the algorithm used to + detect unused declarations in a set of recursive definitions. *) + let slot = ref [] in + let td = Env.find_type (Path.Pident id) temp_env in + Env.set_type_used_callback + td + (fun old_callback -> + match !current_slot with + | Some slot -> slot := td.type_uid :: !slot + | None -> + List.iter Env.mark_type_used (get_ref slot); + old_callback () + ); + ids, Some slot + | Asttypes.Recursive | Asttypes.Nonrecursive -> + ids, None + in + let transl_declaration name_sdecl (id, slot) = + current_slot := slot; + Builtin_attributes.warning_scope + name_sdecl.ptype_attributes + (fun () -> transl_declaration temp_env name_sdecl id) + in + let tdecls = + List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in + let decls = + List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in + current_slot := None; + (* Check for duplicates *) + check_duplicates sdecl_list; + (* Build the final env. *) + let new_env = add_types_to_env decls env in + (* Update stubs *) + begin match rec_flag with + | Asttypes.Nonrecursive -> () + | Asttypes.Recursive -> + List.iter2 + (fun (id, _) sdecl -> + update_type temp_env new_env id sdecl.ptype_loc) + ids_list sdecl_list + end; + ((tdecls, decls, new_env), List.map snd decls) + end + in + (* Check for ill-formed abbrevs *) + let id_loc_list = + List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc)) + ids_list sdecl_list + in + (* Error messages cannot use the new environment, as this might result in + non-termination. Instead we use a completely abstract version of the + temporary environment, giving a reason for why abbreviations cannot be + expanded (#12645, #12649) *) + let abs_env = + List.fold_left2 + (enter_type ~abstract_abbrevs:true rec_flag) + env sdecl_list ids_list in + List.iter (fun (id, decl) -> + check_well_founded_manifest ~abs_env new_env (List.assoc id id_loc_list) + (Path.Pident id) decl) + decls; + let to_check = + function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in + List.iter (fun (id, decl) -> + check_well_founded_decl ~abs_env new_env (List.assoc id id_loc_list) + (Path.Pident id) + decl to_check) + decls; + List.iter + (check_abbrev_regularity ~orig_env:env new_env id_loc_list to_check) tdecls; + (* Check that all type variables are closed *) + List.iter2 + (fun sdecl tdecl -> + let decl = tdecl.typ_type in + match Ctype.closed_type_decl decl with + Some ty -> + if not (Msupport.erroneous_type_check ty) then + raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) + | None -> ()) + sdecl_list tdecls; + (* Check that constraints are enforced *) + List.iter2 (check_constraints new_env) sdecl_list decls; + (* Add type properties to declarations *) + let decls = + try + decls + |> name_recursion_decls sdecl_list + |> Typedecl_variance.update_decls env sdecl_list + |> Typedecl_immediacy.update_decls env + |> Typedecl_separability.update_decls env + with + | Typedecl_variance.Error (loc, err) -> + raise (Error (loc, Variance err)) + | Typedecl_immediacy.Error (loc, err) -> + raise (Error (loc, Immediacy err)) + | Typedecl_separability.Error (loc, err) -> + raise (Error (loc, Separability err)) + in + (* Compute the final environment with variance and immediacy *) + let final_env = add_types_to_env decls env in + (* Check re-exportation *) + List.iter2 (check_abbrev final_env) sdecl_list decls; + (* Keep original declaration *) + let final_decls = + List.map2 + (fun tdecl (_id2, decl) -> + { tdecl with typ_type = decl } + ) tdecls decls + in + (* Done *) + (final_decls, final_env) + +(* Translating type extensions *) + +let transl_extension_constructor ~scope env type_path type_params + typext_params priv sext = + let id = Ident.create_scoped ~scope sext.pext_name.txt in + let args, ret_type, kind = + match sext.pext_kind with + Pext_decl(svars, sargs, sret_type) -> + let targs, tret_type, args, ret_type = + make_constructor env sext.pext_loc type_path typext_params + svars sargs sret_type + in + args, ret_type, Text_decl(svars, targs, tret_type) + | Pext_rebind lid -> + let usage : Env.constructor_usage = + if priv = Public then Env.Exported else Env.Exported_private + in + let cdescr = Env.lookup_constructor ~loc:lid.loc usage lid.txt env in + let (args, cstr_res, _ex) = + Ctype.instance_constructor Keep_existentials_flexible cdescr + in + let res, ret_type = + if cdescr.cstr_generalized then + let params = Ctype.instance_list type_params in + let res = Ctype.newconstr type_path params in + let ret_type = Some (Ctype.newconstr type_path params) in + res, ret_type + else (Ctype.newconstr type_path typext_params), None + in + begin + try + Ctype.unify env cstr_res res + with Ctype.Unify err -> + raise (Error(lid.loc, + Rebind_wrong_type(lid.txt, env, err))) + end; + (* Remove "_" names from parameters used in the constructor *) + if not cdescr.cstr_generalized then begin + let vars = + Ctype.free_variables (Btype.newgenty (Ttuple args)) + in + List.iter + (fun ty -> + if get_desc ty = Tvar (Some "_") + && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + typext_params + end; + (* Ensure that constructor's type matches the type being extended *) + let cstr_type_path = Btype.cstr_type_path cdescr in + let cstr_type_params = (Env.find_type cstr_type_path env).type_params in + let cstr_types = + (Btype.newgenty + (Tconstr(cstr_type_path, cstr_type_params, ref Mnil))) + :: cstr_type_params + in + let ext_types = + (Btype.newgenty + (Tconstr(type_path, type_params, ref Mnil))) + :: type_params + in + if not (Ctype.is_equal env true cstr_types ext_types) then + raise (Error(lid.loc, + Rebind_mismatch(lid.txt, cstr_type_path, type_path))); + (* Disallow rebinding private constructors to non-private *) + begin + match cdescr.cstr_private, priv with + Private, Public -> + raise (Error(lid.loc, Rebind_private lid.txt)) + | _ -> () + end; + let path = + match cdescr.cstr_tag with + Cstr_extension(path, _) -> path + | _ -> assert false + in + let args = + match cdescr.cstr_inlined with + | None -> + Types.Cstr_tuple args + | Some decl -> + let tl = + match List.map get_desc args with + | [ Tconstr(_, tl, _) ] -> tl + | _ -> assert false + in + let decl = Ctype.instance_declaration decl in + assert (List.length decl.type_params = List.length tl); + List.iter2 (Ctype.unify env) decl.type_params tl; + let lbls = + match decl.type_kind with + | Type_record (lbls, Record_extension _) -> lbls + | _ -> assert false + in + Types.Cstr_record lbls + in + args, ret_type, Text_rebind(path, lid) + in + let ext = + { ext_type_path = type_path; + ext_type_params = typext_params; + ext_args = args; + ext_ret_type = ret_type; + ext_private = priv; + Types.ext_loc = sext.pext_loc; + Types.ext_attributes = sext.pext_attributes; + ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + in + { ext_id = id; + ext_name = sext.pext_name; + ext_type = ext; + ext_kind = kind; + Typedtree.ext_loc = sext.pext_loc; + Typedtree.ext_attributes = sext.pext_attributes; } + +let transl_extension_constructor ~scope env type_path type_params + typext_params priv sext = + Builtin_attributes.warning_scope sext.pext_attributes + (fun () -> transl_extension_constructor ~scope env type_path type_params + typext_params priv sext) + +let is_rebind ext = + match ext.ext_kind with + | Text_rebind _ -> true + | Text_decl _ -> false + +let transl_type_extension extend env loc styext = + let type_path, type_decl = + let lid = styext.ptyext_path in + Env.lookup_type ~loc:lid.loc lid.txt env + in + begin + match type_decl.type_kind with + | Type_open -> begin + match type_decl.type_private with + | Private when extend -> begin + match + List.find + (function {pext_kind = Pext_decl _} -> true + | {pext_kind = Pext_rebind _} -> false) + styext.ptyext_constructors + with + | {pext_loc} -> + raise (Error(pext_loc, Cannot_extend_private_type type_path)) + | exception Not_found -> () + end + | _ -> () + end + | _ -> + raise (Error(loc, Not_extensible_type type_path)) + end; + let type_variance = + List.map (fun v -> + let (co, cn) = Variance.get_upper v in + (not cn, not co, false)) + type_decl.type_variance + in + let err = + if type_decl.type_arity <> List.length styext.ptyext_params then + Some Includecore.Arity + else + if List.for_all2 + (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1)) + type_variance + (Typedecl_variance.variance_of_params styext.ptyext_params) + then None else Some Includecore.Variance + in + begin match err with + | None -> () + | Some err -> raise (Error(loc, Extension_mismatch (type_path, env, err))) + end; + let ttype_params, _type_params, constructors = + (* Note: it would be incorrect to call [create_scope] *after* + [TyVarEnv.reset] or after [with_local_level] (see #10010). *) + let scope = Ctype.create_scope () in + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + let ttype_params = make_params env styext.ptyext_params in + let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in + List.iter2 (Ctype.unify_var env) + (Ctype.instance_list type_decl.type_params) + type_params; + let constructors = + List.map (transl_extension_constructor ~scope env type_path + type_decl.type_params type_params styext.ptyext_private) + styext.ptyext_constructors + in + (ttype_params, type_params, constructors) + end + ~post: begin fun (_, type_params, constructors) -> + (* Generalize types *) + List.iter Ctype.generalize type_params; + List.iter + (fun ext -> + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; + Option.iter Ctype.generalize ext.ext_type.ext_ret_type) + constructors; + end + in + (* Check that all type variables are closed *) + List.iter + (fun ext -> + match Ctype.closed_extension_constructor ext.ext_type with + Some ty -> + raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) + | None -> ()) + constructors; + (* Check variances are correct *) + List.iter + (fun ext-> + (* Note that [loc] here is distinct from [type_decl.type_loc], which + makes the [loc] parameter to this function useful. [loc] is the + location of the extension, while [type_decl] points to the original + type declaration being extended. *) + try Typedecl_variance.check_variance_extension + env type_decl ext (type_variance, loc) + with Typedecl_variance.Error (loc, err) -> + raise (Error (loc, Variance err))) + constructors; + (* Add extension constructors to the environment *) + let newenv = + List.fold_left + (fun env ext -> + let rebind = is_rebind ext in + Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env) + env constructors + in + let tyext = + { tyext_path = type_path; + tyext_txt = styext.ptyext_path; + tyext_params = ttype_params; + tyext_constructors = constructors; + tyext_private = styext.ptyext_private; + tyext_loc = styext.ptyext_loc; + tyext_attributes = styext.ptyext_attributes; } + in + (tyext, newenv) + +let transl_type_extension extend env loc styext = + Builtin_attributes.warning_scope styext.ptyext_attributes + (fun () -> transl_type_extension extend env loc styext) + +let transl_exception env sext = + let ext = + let scope = Ctype.create_scope () in + Ctype.with_local_level + (fun () -> + TyVarEnv.reset(); + transl_extension_constructor ~scope env + Predef.path_exn [] [] Asttypes.Public sext) + ~post: begin fun ext -> + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; + Option.iter Ctype.generalize ext.ext_type.ext_ret_type; + end + in + (* Check that all type variables are closed *) + begin match Ctype.closed_extension_constructor ext.ext_type with + Some ty -> + raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) + | None -> () + end; + let rebind = is_rebind ext in + let newenv = + Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env + in + ext, newenv + +let transl_type_exception env t = + Builtin_attributes.check_no_alert t.ptyexn_attributes; + let contructor, newenv = + Builtin_attributes.warning_scope t.ptyexn_attributes + (fun () -> + transl_exception env t.ptyexn_constructor + ) + in + {tyexn_constructor = contructor; + tyexn_loc = t.ptyexn_loc; + tyexn_attributes = t.ptyexn_attributes}, newenv + + +type native_repr_attribute = + | Native_repr_attr_absent + | Native_repr_attr_present of native_repr_kind + +let get_native_repr_attribute attrs ~global_repr = + match + Attr_helper.get_no_payload_attribute ["unboxed"; "ocaml.unboxed"] attrs, + Attr_helper.get_no_payload_attribute ["untagged"; "ocaml.untagged"] attrs, + global_repr + with + | None, None, None -> Native_repr_attr_absent + | None, None, Some repr -> Native_repr_attr_present repr + | Some _, None, None -> Native_repr_attr_present Unboxed + | None, Some _, None -> Native_repr_attr_present Untagged + | Some { Location.loc }, _, _ + | _, Some { Location.loc }, _ -> + raise (Error (loc, Multiple_native_repr_attributes)) + +let native_repr_of_type env kind ty = + match kind, get_desc (Ctype.expand_head_opt env ty) with + | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int -> + Some Untagged_int + | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float -> + Some Unboxed_float + | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 -> + Some (Unboxed_integer Pint32) + | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 -> + Some (Unboxed_integer Pint64) + | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint -> + Some (Unboxed_integer Pnativeint) + | _ -> + None + +(* Raises an error when [core_type] contains an [@unboxed] or [@untagged] + attribute in a strict sub-term. *) +let error_if_has_deep_native_repr_attributes core_type = + let open Ast_iterator in + let this_iterator = + { default_iterator with typ = fun iterator core_type -> + begin + match + get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None + with + | Native_repr_attr_present kind -> + raise (Error (core_type.ptyp_loc, + Deep_unbox_or_untag_attribute kind)) + | Native_repr_attr_absent -> () + end; + default_iterator.typ iterator core_type } + in + default_iterator.typ this_iterator core_type + +let make_native_repr env core_type ty ~global_repr = + error_if_has_deep_native_repr_attributes core_type; + match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with + | Native_repr_attr_absent -> + Same_as_ocaml_repr + | Native_repr_attr_present kind -> + begin match native_repr_of_type env kind ty with + | None -> + raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind)) + | Some repr -> repr + end + +let rec parse_native_repr_attributes env core_type ty ~global_repr = + match core_type.ptyp_desc, get_desc ty, + get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None + with + | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind -> + raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind)) + | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ -> + let repr_arg = make_native_repr env ct1 t1 ~global_repr in + let repr_args, repr_res = + parse_native_repr_attributes env ct2 t2 ~global_repr + in + (repr_arg :: repr_args, repr_res) + | (Ptyp_poly (_, t) | Ptyp_alias (t, _)), _, _ -> + parse_native_repr_attributes env t ty ~global_repr + | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false + | _ -> ([], make_native_repr env core_type ty ~global_repr) + + +let check_unboxable env loc ty = + let check_type acc ty : Path.Set.t = + let ty = Ctype.expand_head_opt env ty in + try match get_desc ty with + | Tconstr (p, _, _) -> + let tydecl = Env.find_type p env in + if tydecl.type_unboxed_default then + Path.Set.add p acc + else acc + | _ -> acc + with Not_found -> acc + in + let all_unboxable_types = Btype.fold_type_expr check_type Path.Set.empty ty in + Path.Set.fold + (fun p () -> + let p = Printtyp.shorten_type_path env p in + Location.prerr_warning loc + (Warnings.Unboxable_type_in_prim_decl (Path.name p)) + ) + all_unboxable_types + () + +(* Translate a value declaration *) +let transl_value_decl env loc valdecl = + let cty = Typetexp.transl_type_scheme env valdecl.pval_type in + let ty = cty.ctyp_type in + let v = + match valdecl.pval_prim with + [] when Env.is_in_signature env -> + { val_type = ty; val_kind = Val_reg; Types.val_loc = loc; + val_attributes = valdecl.pval_attributes; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + | [] -> + raise (Error(valdecl.pval_loc, Val_in_structure)) + | _ -> + let global_repr = + match + get_native_repr_attribute valdecl.pval_attributes ~global_repr:None + with + | Native_repr_attr_present repr -> Some repr + | Native_repr_attr_absent -> None + in + let native_repr_args, native_repr_res = + parse_native_repr_attributes env valdecl.pval_type ty ~global_repr + in + let prim = + Primitive.parse_declaration valdecl + ~native_repr_args + ~native_repr_res + in + (* + if prim.prim_arity = 0 && + (prim.prim_name = "" || prim.prim_name.[0] <> '%') then + raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); + *) + if !Clflags.native_code + && prim.prim_arity > 5 + && prim.prim_native_name = "" + then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external)); + check_unboxable env loc ty; + { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc; + val_attributes = valdecl.pval_attributes; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + in + let (id, newenv) = + Env.enter_value valdecl.pval_name.txt v env + ~check:(fun s -> Warnings.Unused_value_declaration s) + in + let desc = + { + val_id = id; + val_name = valdecl.pval_name; + val_desc = cty; val_val = v; + val_prim = valdecl.pval_prim; + val_loc = valdecl.pval_loc; + val_attributes = valdecl.pval_attributes; + } + in + desc, newenv + +let transl_value_decl env loc valdecl = + Builtin_attributes.warning_scope valdecl.pval_attributes + (fun () -> transl_value_decl env loc valdecl) + +(* Translate a "with" constraint -- much simplified version of + transl_type_decl. For a constraint [Sig with t = sdecl], + there are two declarations of interest in two environments: + - [sig_decl] is the declaration of [t] in [Sig], + in the environment [sig_env] (containing the declarations + of [Sig] before [t]) + - [sdecl] is the new syntactic declaration, to be type-checked + in the current, outer environment [with_env]. + + In particular, note that [sig_env] is an extension of + [outer_env]. +*) +let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env + sdecl = + Env.mark_type_used sig_decl.type_uid; + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + (* In the first part of this function, we typecheck the syntactic + declaration [sdecl] in the outer environment [outer_env]. *) + let env = outer_env in + let loc = sdecl.ptype_loc in + let tparams = make_params env sdecl.ptype_params in + let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in + let arity = List.length params in + let constraints = + List.map (fun (ty, ty', loc) -> + let cty = transl_simple_type env ~closed:false ty in + let cty' = transl_simple_type env ~closed:false ty' in + (* Note: We delay the unification of those constraints + after the unification of parameters, so that clashing + constraints report an error on the constraint location + rather than the parameter location. *) + (cty, cty', loc) + ) sdecl.ptype_cstrs + in + let no_row = not (is_fixed_type sdecl) in + let (tman, man) = match sdecl.ptype_manifest with + None -> None, None + | Some sty -> + let cty = transl_simple_type env ~closed:no_row sty in + Some cty, Some cty.ctyp_type + in + (* In the second part, we check the consistency between the two + declarations and compute a "merged" declaration; we now need to + work in the larger signature environment [sig_env], because + [sig_decl.type_params] and [sig_decl.type_kind] are only valid + there. *) + let env = sig_env in + let sig_decl = Ctype.instance_declaration sig_decl in + let arity_ok = arity = sig_decl.type_arity in + if arity_ok then + List.iter2 (fun (cty, _) tparam -> + try Ctype.unify_var env cty.ctyp_type tparam + with Ctype.Unify err -> + raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, err))) + ) tparams sig_decl.type_params; + List.iter (fun (cty, cty', loc) -> + (* Note: constraints must also be enforced in [sig_env] because + they may contain parameter variables from [tparams] + that have now be unified in [sig_env]. *) + try Ctype.unify env cty.ctyp_type cty'.ctyp_type + with Ctype.Unify err -> + raise(Error(loc, Inconsistent_constraint (env, err))) + ) constraints; + let priv = + if sdecl.ptype_private = Private then Private else + if arity_ok && sig_decl.type_kind <> Type_abstract + then sig_decl.type_private else sdecl.ptype_private + in + if arity_ok && sig_decl.type_kind <> Type_abstract + && sdecl.ptype_private = Private then + Location.deprecated loc "spurious use of private"; + let type_kind, type_unboxed_default = + if arity_ok && man <> None then + sig_decl.type_kind, sig_decl.type_unboxed_default + else + Type_abstract, false + in + let new_sig_decl = + { type_params = params; + type_arity = arity; + type_kind; + type_private = priv; + type_manifest = man; + type_variance = []; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = Unknown; + type_unboxed_default; + type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + in + Option.iter (fun p -> set_private_row env sdecl.ptype_loc p new_sig_decl) + fixed_row_path; + begin match Ctype.closed_type_decl new_sig_decl with None -> () + | Some ty -> raise(Error(loc, Unbound_type_var(ty, new_sig_decl))) + end; + let new_sig_decl = name_recursion sdecl id new_sig_decl in + let new_type_variance = + let required = Typedecl_variance.variance_of_sdecl sdecl in + try + Typedecl_variance.compute_decl env ~check:(Some id) new_sig_decl required + with Typedecl_variance.Error (loc, err) -> + raise (Error (loc, Variance err)) in + let new_type_immediate = + (* Typedecl_immediacy.compute_decl never raises *) + Typedecl_immediacy.compute_decl env new_sig_decl in + let new_type_separability = + try Typedecl_separability.compute_decl env new_sig_decl + with Typedecl_separability.Error (loc, err) -> + raise (Error (loc, Separability err)) in + let new_sig_decl = + (* we intentionally write this without a fragile { decl with ... } + to ensure that people adding new fields to type declarations + consider whether they need to recompute it here; for an example + of bug caused by the previous approach, see #9607 *) + { + type_params = new_sig_decl.type_params; + type_arity = new_sig_decl.type_arity; + type_kind = new_sig_decl.type_kind; + type_private = new_sig_decl.type_private; + type_manifest = new_sig_decl.type_manifest; + type_unboxed_default = new_sig_decl.type_unboxed_default; + type_is_newtype = new_sig_decl.type_is_newtype; + type_expansion_scope = new_sig_decl.type_expansion_scope; + type_loc = new_sig_decl.type_loc; + type_attributes = new_sig_decl.type_attributes; + type_uid = new_sig_decl.type_uid; + + type_variance = new_type_variance; + type_immediate = new_type_immediate; + type_separability = new_type_separability; + } in + { + typ_id = id; + typ_name = sdecl.ptype_name; + typ_params = tparams; + typ_type = new_sig_decl; + typ_cstrs = constraints; + typ_loc = loc; + typ_manifest = tman; + typ_kind = Ttype_abstract; + typ_private = sdecl.ptype_private; + typ_attributes = sdecl.ptype_attributes; + } + end + ~post:(fun ttyp -> generalize_decl ttyp.typ_type) + +(* Approximate a type declaration: just make all types abstract *) + +let abstract_type_decl ~injective arity = + let rec make_params n = + if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in + Ctype.with_local_level ~post:generalize_decl begin fun () -> + { type_params = make_params arity; + type_arity = arity; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + type_variance = Variance.unknown_signature ~injective ~arity; + type_separability = Types.Separability.default_signature ~arity; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = Location.none; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.internal_not_actually_unique; + } + end + +let approx_type_decl sdecl_list = + let scope = Ctype.create_scope () in + List.map + (fun sdecl -> + let injective = sdecl.ptype_kind <> Ptype_abstract in + (Ident.create_scoped ~scope sdecl.ptype_name.txt, + abstract_type_decl ~injective (List.length sdecl.ptype_params))) + sdecl_list + +(* Check the well-formedness conditions on type abbreviations defined + within recursive modules. *) + +let check_recmod_typedecl env loc recmod_ids path decl = + (* recmod_ids is the list of recursively-defined module idents. + (path, decl) is the type declaration to be checked. *) + let to_check path = Path.exists_free recmod_ids path in + check_well_founded_decl ~abs_env:env env loc path decl to_check; + check_regularity ~orig_env:env env loc path decl to_check; + (* additionally check coherece, as one might build an incoherent signature, + and use it to build an incoherent module, cf. #7851 *) + check_coherence env loc path decl + + +(**** Error report ****) + +open Format + +let explain_unbound_gen ppf tv tl typ kwd pr = + try + let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in + let ty0 = (* Hack to force aliasing when needed *) + Btype.newgenty (Tobject(tv, ref None)) in + Printtyp.prepare_for_printing [typ ti; ty0]; + fprintf ppf + ".@ @[In %s@ %a@;<1 -2>the variable %a is unbound@]" + kwd pr ti Printtyp.prepared_type_expr tv + (* kwd pr ti Printtyp.prepared_type_expr tv *) + with Not_found -> () + +let explain_unbound ppf tv tl typ kwd lab = + explain_unbound_gen ppf tv tl typ kwd + (fun ppf ti -> + fprintf ppf "%s%a" (lab ti) Printtyp.prepared_type_expr (typ ti) + ) + +let explain_unbound_single ppf tv ty = + let trivial ty = + explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in + match get_desc ty with + Tobject(fi,_) -> + let (tl, rv) = Ctype.flatten_fields fi in + if eq_type rv tv then trivial ty else + explain_unbound ppf tv tl (fun (_,_,t) -> t) + "method" (fun (lab,_,_) -> lab ^ ": ") + | Tvariant row -> + if eq_type (row_more row) tv then trivial ty else + explain_unbound ppf tv (row_fields row) + (fun (_l,f) -> match row_field_repr f with + Rpresent (Some t) -> t + | Reither (_,[t],_) -> t + | Reither (_,tl,_) -> Btype.newgenty (Ttuple tl) + | _ -> Btype.newgenty (Ttuple[])) + "case" (fun (lab,_) -> "`" ^ lab ^ " of ") + | _ -> trivial ty + + +let tys_of_constr_args = function + | Types.Cstr_tuple tl -> tl + | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls + +module Reaching_path = struct + type t = reaching_type_path + + (* Simplify a reaching path before showing it in error messages. *) + let simplify path = + let rec simplify : t -> t = function + | Contains (ty1, _ty2) :: Contains (_ty2', ty3) :: rest -> + (* If t1 contains t2 and t2 contains t3, then t1 contains t3 + and we don't need to show t2. *) + simplify (Contains (ty1, ty3) :: rest) + | hd :: rest -> hd :: simplify rest + | [] -> [] + in simplify path + + (* See Printtyp.add_type_to_preparation. + + Note: it is better to call this after [simplify], otherwise some + type variable names may be used for types that are removed + by simplification and never actually shown to the user. + *) + let add_to_preparation path = + List.iter (function + | Contains (ty1, ty2) | Expands_to (ty1, ty2) -> + List.iter Printtyp.add_type_to_preparation [ty1; ty2] + ) path + + let pp ppf reaching_path = + let pp_step ppf = function + | Expands_to (ty, body) -> + Format.fprintf ppf "%a = %a" + Printtyp.prepared_type_expr ty + Printtyp.prepared_type_expr body + | Contains (outer, inner) -> + Format.fprintf ppf "%a contains %a" + Printtyp.prepared_type_expr outer + Printtyp.prepared_type_expr inner + in + let comma ppf () = Format.fprintf ppf ",@ " in + Format.(pp_print_list ~pp_sep:comma pp_step) ppf reaching_path + + let pp_colon ppf path = + Format.fprintf ppf ":@;<1 2>@[%a@]" + pp path +end + +let report_error ppf = function + | Repeated_parameter -> + fprintf ppf "A type parameter occurs several times" + | Duplicate_constructor s -> + fprintf ppf "Two constructors are named %s" s + | Too_many_constructors -> + fprintf ppf + "@[Too many non-constant constructors@ -- maximum is %i %s@]" + (Config.max_tag + 1) "non-constant constructors" + | Duplicate_label s -> + fprintf ppf "Two labels are named %s" s + | Recursive_abbrev (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Printtyp.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The type abbreviation %s is cyclic%a@]" + s + Reaching_path.pp_colon reaching_path + | Cycle_in_def (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Printtyp.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The definition of %s contains a cycle%a@]" + s + Reaching_path.pp_colon reaching_path + | Definition_mismatch (ty, _env, None) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" + "This variant or record definition" "does not match that of type" + Printtyp.type_expr ty + | Definition_mismatch (ty, env, Some err) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" + "This variant or record definition" "does not match that of type" + Printtyp.type_expr ty + (Includecore.report_type_mismatch + "the original" "this" "definition" env) + err + | Constraint_failed (env, err) -> + fprintf ppf "@[Constraints are not satisfied in this type.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "should be an instance of"); + fprintf ppf "@]" + | Non_regular { definition; used_as; defined_as; reaching_path } -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.prepare_for_printing [used_as; defined_as]; + Reaching_path.add_to_preparation reaching_path; + fprintf ppf + "@[This recursive type is not regular.@ \ + The type constructor %s is defined as@;<1 2>type %a@ \ + but it is used as@;<1 2>%a%t\ + All uses need to match the definition for the recursive type \ + to be regular.@]" + (Path.name definition) + !Oprint.out_type (Printtyp.tree_of_typexp Type defined_as) + !Oprint.out_type (Printtyp.tree_of_typexp Type used_as) + (fun pp -> + let is_expansion = function Expands_to _ -> true | _ -> false in + if List.exists is_expansion reaching_path then + fprintf pp "@ after the following expansion(s)%a@ " + Reaching_path.pp_colon reaching_path + else fprintf pp ".@ ") + | Inconsistent_constraint (env, err) -> + fprintf ppf "@[The type constraints are not consistent.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type"); + fprintf ppf "@]" + | Type_clash (env, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "This type constructor expands to type") + (function ppf -> + fprintf ppf "but is used here with type") + | Null_arity_external -> + fprintf ppf "External identifiers must be functions" + | Missing_native_external -> + fprintf ppf "@[An external function with more than 5 arguments \ + requires a second stub function@ \ + for native-code compilation@]" + | Unbound_type_var (ty, decl) -> + fprintf ppf "@[A type variable is unbound in this type declaration"; + begin match decl.type_kind, decl.type_manifest with + | Type_variant (tl, _rep), _ -> + explain_unbound_gen ppf ty tl (fun c -> + let tl = tys_of_constr_args c.Types.cd_args in + Btype.newgenty (Ttuple tl) + ) + "case" (fun ppf c -> + fprintf ppf + "%a of %a" Printtyp.ident c.Types.cd_id + Printtyp.constructor_arguments c.Types.cd_args) + | Type_record (tl, _), _ -> + explain_unbound ppf ty tl (fun l -> l.Types.ld_type) + "field" (fun l -> Ident.name l.Types.ld_id ^ ": ") + | Type_abstract, Some ty' -> + explain_unbound_single ppf ty ty' + | _ -> () + end; + fprintf ppf "@]" + | Unbound_type_var_ext (ty, ext) -> + fprintf ppf "@[A type variable is unbound in this extension constructor"; + let args = tys_of_constr_args ext.ext_args in + explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> ""); + fprintf ppf "@]" + | Cannot_extend_private_type path -> + fprintf ppf "@[%s@ %a@]" + "Cannot extend private type definition" + Printtyp.path path + | Not_extensible_type path -> + fprintf ppf "@[%s@ %a@ %s@]" + "Type definition" + Printtyp.path path + "is not extensible" + | Extension_mismatch (path, env, err) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%s@]%a@]" + "This extension" "does not match the definition of type" + (Path.name path) + (Includecore.report_type_mismatch + "the type" "this extension" "definition" env) + err + | Rebind_wrong_type (lid, env, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The constructor %a@ has type" + Printtyp.longident lid) + (function ppf -> + fprintf ppf "but was expected to be of type") + | Rebind_mismatch (lid, p, p') -> + fprintf ppf + "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]" + "The constructor" Printtyp.longident lid + "extends type" (Path.name p) + "whose declaration does not match" + "the declaration of type" (Path.name p') + | Rebind_private lid -> + fprintf ppf "@[%s@ %a@ %s@]" + "The constructor" + Printtyp.longident lid + "is private" + | Variance (Typedecl_variance.Bad_variance (n, v1, v2)) -> + let variance (p,n,i) = + let inj = if i then "injective " else "" in + match p, n with + true, true -> inj ^ "invariant" + | true, false -> inj ^ "covariant" + | false, true -> inj ^ "contravariant" + | false, false -> if inj = "" then "unrestricted" else inj + in + (match n with + | Variance_variable_error { error; variable; context } -> + Printtyp.prepare_for_printing [ variable ]; + begin match context with + | Type_declaration (id, decl) -> + Printtyp.add_type_declaration_to_preparation id decl; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the definition" + (Printtyp.prepared_type_declaration id) + decl + | Gadt_constructor c -> + Printtyp.add_constructor_to_preparation c; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the GADT constructor" + Printtyp.prepared_constructor + c + | Extension_constructor (id, e) -> + Printtyp.add_extension_constructor_to_preparation e; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the extension constructor" + (Printtyp.prepared_extension_constructor id) + e + end; + begin match error with + | Variance_not_reflected -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" + Printtyp.prepared_type_expr variable + "has a variance that" + "is not reflected by its occurrence in type parameters." + | No_variable -> + fprintf ppf "@[%s@ %a@ %s@ %s@]@]" + "the type variable" + Printtyp.prepared_type_expr variable + "cannot be deduced" + "from the type parameters." + | Variance_not_deducible -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" + Printtyp.prepared_type_expr variable + "has a variance that" + "cannot be deduced from the type parameters." + end + | Variance_not_satisfied n -> + fprintf ppf "@[@[%s@ %s@ The %d%s type parameter" + "In this definition, expected parameter" + "variances are not satisfied." + n (Misc.ordinal_suffix n)); + (match n with + | Variance_variable_error { error = No_variable; _ } -> () + | _ -> + fprintf ppf " was expected to be %s,@ but it is %s.@]@]" + (variance v2) (variance v1)) + | Unavailable_type_constructor p -> + fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p + | Variance Typedecl_variance.Varying_anonymous -> + fprintf ppf "@[%s@ %s@ %s@]" + "In this GADT definition," "the variance of some parameter" + "cannot be checked" + | Val_in_structure -> + fprintf ppf "Value declarations are only allowed in signatures" + | Multiple_native_repr_attributes -> + fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes" + | Cannot_unbox_or_untag_type Unboxed -> + fprintf ppf "@[Don't know how to unbox this type.@ \ + Only float, int32, int64 and nativeint can be unboxed.@]" + | Cannot_unbox_or_untag_type Untagged -> + fprintf ppf "@[Don't know how to untag this type.@ \ + Only int can be untagged.@]" + | Deep_unbox_or_untag_attribute kind -> + fprintf ppf + "@[The attribute '%s' should be attached to@ \ + a direct argument or result of the primitive,@ \ + it should not occur deeply into its type.@]" + (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged") + | Immediacy (Typedecl_immediacy.Bad_immediacy_attribute violation) -> + fprintf ppf "@[%a@]" Format.pp_print_text + (match violation with + | Type_immediacy.Violation.Not_always_immediate -> + "Types marked with the immediate attribute must be \ + non-pointer types like int or bool." + | Type_immediacy.Violation.Not_always_immediate_on_64bits -> + "Types marked with the immediate64 attribute must be \ + produced using the Stdlib.Sys.Immediate64.Make functor.") + | Bad_unboxed_attribute msg -> + fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg + | Separability (Typedecl_separability.Non_separable_evar evar) -> + let pp_evar ppf = function + | None -> + fprintf ppf "an unnamed existential variable" + | Some str -> + fprintf ppf "the existential variable %a" + Pprintast.tyvar str in + fprintf ppf "@[This type cannot be unboxed because@ \ + it might contain both float and non-float values,@ \ + depending on the instantiation of %a.@ \ + You should annotate it with [%@%@ocaml.boxed].@]" + pp_evar evar + | Boxed_and_unboxed -> + fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]" + | Nonrec_gadt -> + fprintf ppf + "@[GADT case syntax cannot be used in a 'nonrec' block.@]" + | Invalid_private_row_declaration ty -> + Format.fprintf ppf + "@[This private row type declaration is invalid.@ \ + The type expression on the right-hand side reduces to@;<1 2>%a@ \ + which does not have a free row type variable.@]@,\ + @[@[@{Hint@}: If you intended to define a private \ + type abbreviation,@ \ + write explicitly@]@;<1 2>private %a@]" + Printtyp.type_expr ty Printtyp.type_expr ty + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error err) + | _ -> + None + ) diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl.mli b/ocamlmerlin_mlx/ocaml/typing/typedecl.mli new file mode 100644 index 0000000..013fae4 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl.mli @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Typing of type definitions and primitive definitions *) + +open Types +open Format + +val transl_type_decl: + Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> + Typedtree.type_declaration list * Env.t + +val transl_exception: + Env.t -> Parsetree.extension_constructor -> + Typedtree.extension_constructor * Env.t + +val transl_type_exception: + Env.t -> + Parsetree.type_exception -> Typedtree.type_exception * Env.t + +val transl_type_extension: + bool -> Env.t -> Location.t -> Parsetree.type_extension -> + Typedtree.type_extension * Env.t + +val transl_value_decl: + Env.t -> Location.t -> + Parsetree.value_description -> Typedtree.value_description * Env.t + +(* If the [fixed_row_path] optional argument is provided, + the [Parsetree.type_declaration] argument should satisfy [is_fixed_type] *) +val transl_with_constraint: + Ident.t -> ?fixed_row_path:Path.t -> + sig_env:Env.t -> sig_decl:Types.type_declaration -> + outer_env:Env.t -> Parsetree.type_declaration -> + Typedtree.type_declaration + +val abstract_type_decl: injective:bool -> int -> type_declaration +val approx_type_decl: + Parsetree.type_declaration list -> + (Ident.t * type_declaration) list +val check_recmod_typedecl: + Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit +val check_coherence: + Env.t -> Location.t -> Path.t -> type_declaration -> unit + +(* for fixed types *) +val is_fixed_type : Parsetree.type_declaration -> bool + +type native_repr_kind = Unboxed | Untagged + +type reaching_type_path = reaching_type_step list +and reaching_type_step = + | Expands_to of type_expr * type_expr + | Contains of type_expr * type_expr + +type error = + Repeated_parameter + | Duplicate_constructor of string + | Too_many_constructors + | Duplicate_label of string + | Recursive_abbrev of string * Env.t * reaching_type_path + | Cycle_in_def of string * Env.t * reaching_type_path + | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error + | Non_regular of { + definition: Path.t; + used_as: type_expr; + defined_as: type_expr; + reaching_path: reaching_type_path; + } + | Null_arity_external + | Missing_native_external + | Unbound_type_var of type_expr * type_declaration + | Cannot_extend_private_type of Path.t + | Not_extensible_type of Path.t + | Extension_mismatch of Path.t * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error + | Rebind_mismatch of Longident.t * Path.t * Path.t + | Rebind_private of Longident.t + | Variance of Typedecl_variance.error + | Unavailable_type_constructor of Path.t + | Unbound_type_var_ext of type_expr * extension_constructor + | Val_in_structure + | Multiple_native_repr_attributes + | Cannot_unbox_or_untag_type of native_repr_kind + | Deep_unbox_or_untag_attribute of native_repr_kind + | Immediacy of Typedecl_immediacy.error + | Separability of Typedecl_separability.error + | Bad_unboxed_attribute of string + | Boxed_and_unboxed + | Nonrec_gadt + | Invalid_private_row_declaration of type_expr + +exception Error of Location.t * error + +val report_error: formatter -> error -> unit diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl_immediacy.ml b/ocamlmerlin_mlx/ocaml/typing/typedecl_immediacy.ml new file mode 100644 index 0000000..f1f0594 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl_immediacy.ml @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +type error = Bad_immediacy_attribute of Type_immediacy.Violation.t +exception Error of Location.t * error + +let compute_decl env tdecl = + match (tdecl.type_kind, tdecl.type_manifest) with + | (Type_variant ([{cd_args = Cstr_tuple [arg] + | Cstr_record [{ld_type = arg; _}]; _}], + Variant_unboxed) + | Type_record ([{ld_type = arg; _}], Record_unboxed _)), _ -> + begin match Typedecl_unboxed.get_unboxed_type_representation env arg with + | None -> Type_immediacy.Unknown + | Some argrepr -> Ctype.immediacy env argrepr + end + | (Type_variant (cstrs, _), _) -> + if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs) + then + Type_immediacy.Always + else + Type_immediacy.Unknown + | (Type_abstract, Some(typ)) -> Ctype.immediacy env typ + | (Type_abstract, None) -> Type_immediacy.of_attributes tdecl.type_attributes + | _ -> Type_immediacy.Unknown + +let property : (Type_immediacy.t, unit) Typedecl_properties.property = + let open Typedecl_properties in + let eq = (=) in + let merge ~prop:_ ~new_prop = new_prop in + let default _decl = Type_immediacy.Unknown in + let compute env decl () = compute_decl env decl in + let update_decl decl immediacy = { decl with type_immediate = immediacy } in + let check _env _id decl () = + let written_by_user = Type_immediacy.of_attributes decl.type_attributes in + match Type_immediacy.coerce decl.type_immediate ~as_:written_by_user with + | Ok () -> () + | Error violation -> + raise (Error (decl.type_loc, + Bad_immediacy_attribute violation)) + in + { + eq; + merge; + default; + compute; + update_decl; + check; + } + +let update_decls env decls = + Typedecl_properties.compute_property_noreq property env decls diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl_immediacy.mli b/ocamlmerlin_mlx/ocaml/typing/typedecl_immediacy.mli new file mode 100644 index 0000000..17fb985 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl_immediacy.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type error = Bad_immediacy_attribute of Type_immediacy.Violation.t +exception Error of Location.t * error + +val compute_decl : Env.t -> Types.type_declaration -> Type_immediacy.t + +val property : (Type_immediacy.t, unit) Typedecl_properties.property + +val update_decls : + Env.t -> + (Ident.t * Typedecl_properties.decl) list -> + (Ident.t * Typedecl_properties.decl) list diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl_properties.ml b/ocamlmerlin_mlx/ocaml/typing/typedecl_properties.ml new file mode 100644 index 0000000..28a1bb6 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl_properties.ml @@ -0,0 +1,73 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type decl = Types.type_declaration + +type ('prop, 'req) property = { + eq : 'prop -> 'prop -> bool; + merge : prop:'prop -> new_prop:'prop -> 'prop; + + default : decl -> 'prop; + compute : Env.t -> decl -> 'req -> 'prop; + update_decl : decl -> 'prop -> decl; + + check : Env.t -> Ident.t -> decl -> 'req -> unit; +} + +let add_type ~check id decl env = + let open Types in + Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes + (fun () -> Env.add_type ~check id decl env) + +let add_types_to_env decls env = + List.fold_right + (fun (id, decl) env -> add_type ~check:true id decl env) + decls env + +let compute_property +: ('prop, 'req) property -> Env.t -> + (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list += fun property env decls required -> + (* [decls] and [required] must be lists of the same size, + with [required] containing the requirement for the corresponding + declaration in [decls]. *) + let props = List.map (fun (_id, decl) -> property.default decl) decls in + let rec compute_fixpoint props = + let new_decls = + List.map2 (fun (id, decl) prop -> + (id, property.update_decl decl prop)) + decls props in + let new_env = add_types_to_env new_decls env in + let new_props = + List.map2 + (fun (_id, decl) (prop, req) -> + let new_prop = property.compute new_env decl req in + property.merge ~prop ~new_prop) + new_decls (List.combine props required) in + if not (List.for_all2 property.eq props new_props) + then compute_fixpoint new_props + else begin + List.iter2 + (fun (id, decl) req -> property.check new_env id decl req) + new_decls required; + new_decls + end + in + compute_fixpoint props + +let compute_property_noreq property env decls = + let req = List.map (fun _ -> ()) decls in + compute_property property env decls req diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl_properties.mli b/ocamlmerlin_mlx/ocaml/typing/typedecl_properties.mli new file mode 100644 index 0000000..153c3f7 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl_properties.mli @@ -0,0 +1,55 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type decl = Types.type_declaration + +(** An abstract interface for properties of type definitions, such as + variance and immediacy, that are computed by a fixpoint on + mutually-recursive type declarations. This interface contains all + the operations needed to initialize and run the fixpoint + computation, and then (optionally) check that the result is + consistent with the declaration or user expectations. *) + +type ('prop, 'req) property = { + eq : 'prop -> 'prop -> bool; + merge : prop:'prop -> new_prop:'prop -> 'prop; + + default : decl -> 'prop; + compute : Env.t -> decl -> 'req -> 'prop; + update_decl : decl -> 'prop -> decl; + + check : Env.t -> Ident.t -> decl -> 'req -> unit; +} +(** ['prop] represents the type of property values + ({!Types.Variance.t}, just 'bool' for immediacy, etc). + + ['req] represents the property value required by the author of the + declaration, if they gave an expectation: [type +'a t = ...]. + + Some properties have no natural notion of user requirement, or + their requirement is global, or already stored in + [type_declaration]; they can just use [unit] as ['req] parameter. *) + + +(** [compute_property prop env decls req] performs a fixpoint computation + to determine the final values of a property on a set of mutually-recursive + type declarations. The [req] argument must be a list of the same size as + [decls], providing the user requirement for each declaration. *) +val compute_property : ('prop, 'req) property -> Env.t -> + (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list + +val compute_property_noreq : ('prop, unit) property -> Env.t -> + (Ident.t * decl) list -> (Ident.t * decl) list diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl_separability.ml b/ocamlmerlin_mlx/ocaml/typing/typedecl_separability.ml new file mode 100644 index 0000000..c6ded4c --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl_separability.ml @@ -0,0 +1,668 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +type type_definition = type_declaration +(* We should use 'declaration' for interfaces, and 'definition' for + implementations. The name type_declaration in types.ml is improper + for our usage -- although for OCaml types the declaration and + definition languages are the same. *) + +(** assuming that a datatype has a single constructor/label with + a single argument, [argument_to_unbox] represents the + information we need to check the argument for separability. *) +type argument_to_unbox = { + argument_type: type_expr; + result_type_parameter_instances: type_expr list; + (** result_type_parameter_instances represents the domain of the + constructor; usually it is just a list of the datatype parameter + ('a, 'b, ...), but when using GADTs or constraints it could + contain arbitrary type expressions. + + For example, [type 'a t = 'b constraint 'a = 'b * int] has + [['b * int]] as [result_type_parameter_instances], and so does + [type _ t = T : 'b -> ('b * int) t]. *) +} + +(** Summarize the right-hand-side of a type declaration, + for separability-checking purposes. See {!structure} below. *) +type type_structure = + | Synonym of type_expr + | Abstract + | Open + | Algebraic + | Unboxed of argument_to_unbox + +let structure : type_definition -> type_structure = fun def -> + match def.type_kind with + | Type_open -> Open + | Type_abstract -> + begin match def.type_manifest with + | None -> Abstract + | Some type_expr -> Synonym type_expr + end + + | ( Type_record ([{ld_type = ty; _}], Record_unboxed _) + | Type_variant ([{cd_args = Cstr_tuple [ty]; _}], Variant_unboxed) + | Type_variant ([{cd_args = Cstr_record [{ld_type = ty; _}]; _}], + Variant_unboxed)) -> + let params = + match def.type_kind with + | Type_variant ([{cd_res = Some ret_type}], _) -> + begin match get_desc ret_type with + | Tconstr (_, tyl, _) -> tyl + | _ -> assert false + end + | _ -> def.type_params + in + Unboxed { argument_type = ty; result_type_parameter_instances = params } + + | Type_record _ | Type_variant _ -> Algebraic + +type error = + | Non_separable_evar of string option + +exception Error of Location.t * error + +(* see the .mli file for explanations on the modes *) +module Sep = Types.Separability +type mode = Sep.t = Ind | Sep | Deepsep + +let rank = Sep.rank +let max_mode = Sep.max + +(** If the type context [e(_)] imposes the mode [m] on its hole [_], + and the type context [e'(_)] imposes the mode [m'] on its hole [_], + then the mode on [_] imposed by the context composition [e(e'(_))] + is [compose m m']. + + This operation differs from [max_mode]: [max_mode Ind Sep] is [Sep], + but [compose Ind Sep] is [Ind]. *) +let compose + : mode -> mode -> mode + = fun m1 m2 -> + match m1 with + | Deepsep -> Deepsep + | Sep -> m2 + | Ind -> Ind + +type type_var = { + text: string option; (** the user name of the type variable, None for '_' *) + id: int; (** the identifier of the type node (type_expr.id) of the variable *) +} + +module TVarMap = Map.Make(struct + type t = type_var + let compare v1 v2 = compare v1.id v2.id + end) +type context = mode TVarMap.t +let (++) = TVarMap.union (fun _ m1 m2 -> Some(max_mode m1 m2)) +let empty = TVarMap.empty + + +(** [immediate_subtypes ty] returns the list of all the + immediate sub-type-expressions of [ty]. They represent the biggest + sub-components that may be extracted using a constraint. For + example, the immediate sub-type-expressions of [int * (bool * 'a)] + are [int] and [bool * 'a]. + + Smaller components are extracted recursively in [check_type]. *) +let rec immediate_subtypes : type_expr -> type_expr list = fun ty -> + (* Note: Btype.fold_type_expr is not suitable here: + - it does not do the right thing on Tpoly, iterating on type + parameters as well as the subtype + - it performs a shallow traversal of object types, + while our implementation collects all method types *) + match get_desc ty with + (* these are the important cases, + on which immediate_subtypes is called from [check_type] *) + | Tarrow(_,ty1,ty2,_) -> + [ty1; ty2] + | Ttuple(tys) -> tys + | Tpackage(_, fl) -> (snd (List.split fl)) + | Tobject(row,class_ty) -> + let class_subtys = + match !class_ty with + | None -> [] + | Some(_,tys) -> tys + in + immediate_subtypes_object_row class_subtys row + | Tvariant(row) -> + immediate_subtypes_variant_row [] row + + (* the cases below are not called from [check_type], + they are here for completeness *) + | Tnil | Tfield _ -> + (* these should only occur under Tobject and not at the toplevel, + but "better safe than sorry" *) + immediate_subtypes_object_row [] ty + | Tlink _ | Tsubst _ -> assert false (* impossible due to Ctype.repr *) + | Tvar _ | Tunivar _ -> [] + | Tpoly (pty, _) -> [pty] + | Tconstr (_path, tys, _) -> tys + +and immediate_subtypes_object_row acc ty = match get_desc ty with + | Tnil -> acc + | Tfield (_label, _kind, ty, rest) -> + let acc = ty :: acc in + immediate_subtypes_object_row acc rest + | _ -> ty :: acc + +and immediate_subtypes_variant_row acc desc = + let add_subtypes acc = + let add_subtype acc (_l, rf) = + immediate_subtypes_variant_row_field acc rf in + List.fold_left add_subtype acc (row_fields desc) in + let add_row acc = + let row = row_more desc in + match get_desc row with + | Tvariant more -> immediate_subtypes_variant_row acc more + | _ -> row :: acc + in + add_row (add_subtypes acc) + +and immediate_subtypes_variant_row_field acc f = + match row_field_repr f with + | Rpresent(None) + | Rabsent -> acc + | Rpresent(Some(ty)) -> ty :: acc + | Reither(_,field_types,_) -> + List.rev_append field_types acc + +let free_variables ty = + Ctype.free_variables ty + |> List.map (fun ty -> + match get_desc ty with + Tvar text -> {text; id = get_id ty} + | _ -> + (* Ctype.free_variables only returns Tvar nodes *) + assert false) + +(** Coinductive hypotheses to handle equi-recursive types + + OCaml allows infinite/cyclic types, such as + (int * 'a) as 'a + whose infinite unfolding is (int * (int * (int * (int * ...)))). + + Remark: this specific type is only accepted if the -rectypes option + is passed, but such "equi-recursive types" are accepted by + default if the cycle goes through an object type or polymorphic + variant type: + [ `int | `other of 'a ] as 'a + < head : int; rest : 'a > as 'a + + We have to take those infinite types in account in our + separability-checking program: a naive implementation would loop + infinitely when trying to prove that one of them is Deepsep. + + After type-checking, the cycle-introducing form (... as 'a) does + not appear explicitly in the syntax of types: types are graphs/trees + with cycles in them, and we have to use the type_expr.id field, + an identifier for each node in the graph/tree, to detect cycles. + + We avoid looping by remembering the set of separability queries + that we have already asked ourselves (in the current + search branch). For example, if we are asked to check + + (int * 'a) : Deepsep + + our algorithm will check both (int : Deepsep) and ('a : Deepsep), + but it will remember in these sub-checks that it is in the process + of checking (int * 'a) : Deepsep, adding it to a list of "active + goals", or "coinductive hypotheses". + + Each new sub-query will start by checking whether the query + already appears as a coinductive hypothesis; in our example, this + can happen if 'a and (int * 'a) are in fact the same node in the + cyclic tree. In that case, we return immediately (instead of looping): + we reason that, assuming that 'a is indeed Deepsep, then it is + the case that (int * 'a) is also Deepsep. + + This kind of cyclic reasoning can be dangerous: it would be wrong + to argue that an arbitrary 'a type is Deepsep by saying: + "assuming that 'a is Deepsep, then it is the case that 'a is + also Deepsep". In the first case, we made an assumption on 'a, + and used it on a type (int * 'a) which has 'a as a strict sub-component; + in the second, we use it on the same type 'a directly, which is invalid. + + Now consider a type of the form (('a t) as 'a): while 'a is a sub-component + of ('a t), it may still be wrong to reason coinductively about it, + as ('a t) may be defined as (type 'a t = 'a). + + When moving from (int * 'a) to a subcomponent (int) or ('a), we + say that the coinductive hypothesis on (int * 'a : m) is "safe": + it can be used immediately to prove the subcomponents, because we + made progress moving to a strict subcomponent (we are guarded + under a computational type constructor). On the other hand, when + moving from ('a t) to ('a), we say that the coinductive hypothesis + ('a t : m) is "unsafe" for the subgoal, as we don't know whether + we have made strict progress. In the general case, we keep track + of a set of safe and unsafe hypotheses made in the past, and we + use them to terminate checking if we encounter them again, + ensuring termination. + + If we encounter a (ty : m) goal that is exactly a safe hypothesis, + we terminate with a success. In fact, we can use mode subtyping here: + if (ty : m') appears as a hypothesis with (m' >= m), then we would + succeed for (ty : m'), so (ty : m) should succeed as well. + + On the other hand, if we encounter a (ty : m) goal that is an + *unsafe* hypothesis, we terminate the check with a failure. In this case, + we cannot work modulo mode subtyping: if (ty : m') appears with + (m' >= m), then the check (ty : m') would have failed, but it is still + possible that the weaker current query (ty : m) would succeed. + + In usual coinductive-reasoning systems, unsafe hypotheses are turned + into safe hypotheses each time strict progress is made (for each + guarded sub-goal). Consider ((int * 'a) t as 'a : deepsep) for example: + the idea is that the ((int * 'a) t : deepsep) hypothesis would be + unsafe when checking ((int * 'a) : deepsep), but that the progress + step from (int * 'a : deepsep) to ('a : deepsep) would turn all + past unsafe hypotheses into safe hypotheses. There is a problem + with this, though, due to constraints: what if (_ t) is defined as + + type 'b t = 'a constraint 'b = (int * 'a) + + ? + + In that case, then 'a is precisely the one-step unfolding + of the ((int * 'a) t) definition, and it would be an invalid, + cyclic reasoning to prove ('a : deepsep) from the now-safe + hypothesis ((int * 'a) t : deepsep). + + Surprisingly-fortunately, we have exactly the information we need + to know whether (_ t) may or may not pull a constraint trick of + this nature: we can look at its mode signature, where constraints + are marked by a Deepsep mode. If we see Deepsep, we know that a + constraint exists, but we don't know what the constraint is: + we cannot tell at which point, when decomposing the parameter type, + a sub-component can be considered safe again. To model this, + we add a third category of co-inductive hypotheses: to "safe" and + "unsafe" we add the category of "poison" hypotheses, which remain + poisonous during the remaining of the type decomposition, + even in presence of safe, computational types constructors: + + - when going under a computational constructor, + "unsafe" hypotheses become "safe" + - when going under a constraining type (more precisely, under + a type parameter that is marked Deepsep in the mode signature), + "unsafe" hypotheses become "poison" + + The mode signature tells us even a bit more: if a parameter + is marked "Ind", we know that the type constructor cannot unfold + to this parameter (otherwise it would be Sep), so going under + this parameter can be considered a safe/guarded move: if + we have to check (foo t : m) with ((_ : Ind) t) in the signature, + we can recursively check (foo : Ind) with (foo t : m) marked + as "safe", rather than "unsafe". +*) +module TypeMap = Btype.TypeMap +module ModeSet = Set.Make(Types.Separability) + +type coinductive_hyps = { + safe: ModeSet.t TypeMap.t; + unsafe: ModeSet.t TypeMap.t; + poison: ModeSet.t TypeMap.t; +} + +module Hyps : sig + type t = coinductive_hyps + val empty : t + val add : type_expr -> mode -> t -> t + val guard : t -> t + val poison : t -> t + val safe : type_expr -> mode -> t -> bool + val unsafe : type_expr -> mode -> t -> bool +end = struct + type t = coinductive_hyps + + let empty = { + safe = TypeMap.empty; + unsafe = TypeMap.empty; + poison = TypeMap.empty; + } + + let of_opt = function + | Some ms -> ms + | None -> ModeSet.empty + + let merge map1 map2 = + TypeMap.merge (fun _k ms1 ms2 -> + Some (ModeSet.union (of_opt ms1) (of_opt ms2)) + ) map1 map2 + + let guard {safe; unsafe; poison;} = { + safe = merge safe unsafe; + unsafe = TypeMap.empty; + poison; + } + + let poison {safe; unsafe; poison;} = { + safe; + unsafe = TypeMap.empty; + poison = merge poison unsafe; + } + + let add ty m hyps = + let m_map = TypeMap.singleton ty (ModeSet.singleton m) in + { hyps with unsafe = merge m_map hyps.unsafe; } + + let find ty map = try TypeMap.find ty map with Not_found -> ModeSet.empty + + let safe ty m hyps = + match ModeSet.max_elt_opt (find ty hyps.safe) with + | None -> false + | Some best_safe -> rank best_safe >= rank m + + let unsafe ty m {safe = _; unsafe; poison} = + let in_map s = ModeSet.mem m (find ty s) in + List.exists in_map [unsafe; poison] +end + +(** For a type expression [ty] (without constraints and existentials), + any mode checking [ty : m] is satisfied in the "worse case" context + that maps all free variables of [ty] to the most demanding mode, + Deepsep. *) +let worst_case ty = + let add ctx tvar = TVarMap.add tvar Deepsep ctx in + List.fold_left add TVarMap.empty (free_variables ty) + + +(** [check_type env sigma ty m] returns the most permissive context [gamma] + such that [ty] is separable at mode [m] in [gamma], under + the signature [sigma]. *) +let check_type + : Env.t -> type_expr -> mode -> context + = fun env ty m -> + let rec check_type hyps ty m = + if Hyps.safe ty m hyps then empty + else if Hyps.unsafe ty m hyps then worst_case ty + else + let hyps = Hyps.add ty m hyps in + match (get_desc ty, m) with + (* Impossible case due to the call to [Ctype.repr]. *) + | (Tlink _ , _ ) -> assert false + (* Impossible case (according to comment in [typing/types.mli]. *) + | (Tsubst(_) , _ ) -> assert false + (* "Indifferent" case, the empty context is sufficient. *) + | (_ , Ind ) -> empty + (* Variable case, add constraint. *) + | (Tvar(alpha) , m ) -> + TVarMap.singleton {text = alpha; id = get_id ty} m + (* "Separable" case for constructors with known memory representation. *) + | (Tarrow _ , Sep ) + | (Ttuple _ , Sep ) + | (Tvariant(_) , Sep ) + | (Tobject(_,_) , Sep ) + | ((Tnil | Tfield _) , Sep ) + | (Tpackage(_,_) , Sep ) -> empty + (* "Deeply separable" case for these same constructors. *) + | (Tarrow _ , Deepsep) + | (Ttuple _ , Deepsep) + | (Tvariant(_) , Deepsep) + | (Tobject(_,_) , Deepsep) + | ((Tnil | Tfield _) , Deepsep) + | (Tpackage(_,_) , Deepsep) -> + let tys = immediate_subtypes ty in + let on_subtype context ty = + context ++ check_type (Hyps.guard hyps) ty Deepsep in + List.fold_left on_subtype empty tys + (* Polymorphic type, and corresponding polymorphic variable. + + In theory, [Tpoly] (forall alpha. tau) would add a new variable + (alpha) in scope, check its body (tau) recursively, and then + remove the new variable from the resulting context. Because the + rule accepts any mode for this variable, the removal never + fails. + + In practice the implementation is simplified by ignoring the + new variable, and always returning the [empty] context + (instead of (alpha : m) in the [Tunivar] case: the constraint + on the variable is removed/ignored at the variable occurrence + site, rather than at the variable-introduction site. *) + (* Note: that we are semantically incomplete in the Deepsep case + (following the syntactic typing rules): the semantics only + requires that *closed* sub-type-expressions be (deeply) + separable; sub-type-expressions containing the quantified + variable cannot be extracted by constraints (this would be + a scope violation), so they could be ignored if they occur + under a separating type constructor. *) + | (Tpoly(pty,_) , m ) -> + check_type hyps pty m + | (Tunivar(_) , _ ) -> empty + (* Type constructor case. *) + | (Tconstr(path,tys,_), m ) -> + let msig = (Env.find_type path env).type_separability in + let on_param context (ty, m_param) = + let hyps = match m_param with + | Ind -> Hyps.guard hyps + | Sep -> hyps + | Deepsep -> Hyps.poison hyps in + context ++ check_type hyps ty (compose m m_param) in + List.fold_left on_param empty (List.combine tys msig) + in + check_type Hyps.empty ty m + +let best_msig decl = List.map (fun _ -> Ind) decl.type_params +let worst_msig decl = List.map (fun _ -> Deepsep) decl.type_params + +(** [msig_of_external_type decl] infers the mode signature of an + abstract/external type. We must assume the worst, namely that this + type may be defined as an unboxed algebraic datatype imposing deep + separability of its parameters. + + One exception is when the type is marked "immediate", which + guarantees that its representation is only integers. Immediate + types are always separable, so [Ind] suffices for their + parameters. + + Note: this differs from {!Types.Separability.default_signature}, + which does not have access to the declaration and its immediacy. *) +let msig_of_external_type decl = + match decl.type_immediate with + | Always | Always_on_64bits -> best_msig decl + | Unknown -> worst_msig decl + +(** [msig_of_context ~decl_loc constructor context] returns the + separability signature of a single-constructor type whose + definition is valid in the mode context [context]. + + Note: A GADT constructor introduces existential type variables, and + may also introduce some equalities between its return type + parameters and type expressions containing universal and + existential variables. In other words, it introduces new type + variables in scope, and restricts existing variables by adding + equality constraints. + + [msig_of_context] performs the reverse transformation: the context + [ctx] computed from the argument of the constructor mentions + existential variables, and the function returns a context over the + (universal) type parameters only. (Type constraints do not + introduce existential variables, but they do introduce equalities; + they are handled as GADTs equalities by this function.) + + The transformation is separability-preserving in the following + sense: for any valid instance of the result mode signature + (replacing the universal type parameters with ground types + respecting the variable's separability mode), any possible + extension of this context instance with ground instances for the + existential variables of [parameter] that respects the equation + constraints will validate the separability requirements of the + modes in the input context [ctx]. + + Sometimes no such universal context exists, as an existential type + cannot be safely introduced, then this function raises an [Error] + exception with a [Non_separable_evar] payload. *) +let msig_of_context : decl_loc:Location.t -> parameters:type_expr list + -> context -> Sep.signature = + fun ~decl_loc ~parameters context -> + let handle_equation (acc, context) param_instance = + (* In the theory, GADT equations are of the form + ('a = ) + for each type parameter 'a of the type constructor. For each + such equation, we should "strengthen" the current context in + the following way: + - if is another variable 'b, + the mode of 'a is set to the mode of 'b, + and 'b is set to Ind + - if is a type expression whose variables are all Ind, + set 'a to Ind and discard the equation + - otherwise (one of the variable of 'b is not Ind), + set 'a to Deepsep and set all variables of to Ind + + In practice, type parameters are determined by their position + in a list, they do not necessarily have a corresponding type variable. + Instead of "setting 'a" in the context as in the description above, + we build a list of modes by repeated consing into + an accumulator variable [acc], setting existential variables + to Ind as we go. *) + let get context var = + try TVarMap.find var context with Not_found -> Ind in + let set_ind context var = + TVarMap.add var Ind context in + let is_ind context var = match get context var with + | Ind -> true + | Sep | Deepsep -> false in + match get_desc param_instance with + | Tvar text -> + let var = {text; id = get_id param_instance} in + (get context var) :: acc, (set_ind context var) + | _ -> + let instance_exis = free_variables param_instance in + if List.for_all (is_ind context) instance_exis then + Ind :: acc, context + else + Deepsep :: acc, List.fold_left set_ind context instance_exis + in + let mode_signature, context = + let (mode_signature_rev, ctx) = + List.fold_left handle_equation ([], context) parameters in + (* Note: our inference system is not principal, because the + inference result depends on the order in which those + equations are processed. (To our knowledge this is the only + source of non-principality.) If two parameters ('a, 'b) are + forced to be equal to each other, and also separable, then + either modes (Sep, Ind) and (Ind, Sep) are correct, allow + more declarations than (Sep, Sep), but (Ind, Ind) would be + unsound. + + Such a non-principal example is the following: + + type ('a, 'b) almost_eq = + | Almost_refl : 'c -> ('c, 'c) almost_eq + + (This example looks strange: GADT equations are typically + either on only one parameter, or on two parameters that are + not used to classify constructor arguments. Indeed, we have + not found non-principal declarations in real-world code.) + + In a non-principal system, it is important the our choice of + non-unique solution be at least predictable. We find it more + natural, when either ('a : Sep, 'b : Ind) and ('a : Ind, + 'b : Sep) are correct because 'a = 'b, to choose to make the + first/leftmost parameter more constrained. We read this as + saying that 'a must be Sep, and 'b = 'a so 'b can be + Ind. (We define the second parameter as equal of the first, + already-seen parameter; instead of saying that the first + parameter is equal to the not-yet-seen second one.) + + This is achieved by processing the equations from left to + right with List.fold_left, instead of using + List.fold_right. The code is slightly more awkward as it + needs a List.rev on the accumulated modes, but it gives + a more predictable/natural (non-principal) behavior. + *) + (List.rev mode_signature_rev, ctx) in + (* After all variables determined by the parameters have been set to Ind + by [handle_equation], all variables remaining in the context are + purely existential and should not require a stronger mode than Ind. *) + let check_existential evar mode = + if rank mode > rank Ind then + raise (Error (decl_loc, Non_separable_evar evar.text)) + in + TVarMap.iter check_existential context; + mode_signature + +(** [check_def env def] returns the signature required + for the type definition [def] in the typing environment [env]. + + The exception [Error] is raised if we discover that + no such signature exists -- the definition will always be invalid. + This only happens when the definition is marked to be unboxed. *) + +let check_def + : Env.t -> type_definition -> Sep.signature + = fun env def -> + match structure def with + | Abstract -> + msig_of_external_type def + | Synonym type_expr -> + check_type env type_expr Sep + |> msig_of_context ~decl_loc:def.type_loc ~parameters:def.type_params + | Open | Algebraic -> + best_msig def + | Unboxed constructor -> + check_type env constructor.argument_type Sep + |> msig_of_context ~decl_loc:def.type_loc + ~parameters:constructor.result_type_parameter_instances + +let compute_decl env decl = + if Config.flat_float_array then check_def env decl + else + (* Hack: in -no-flat-float-array mode, instead of always returning + [best_msig], we first compute the separability signature -- + falling back to [best_msig] if it fails. + + This discipline is conservative: it never + rejects -no-flat-float-array programs. At the same time it + guarantees that, for any program that is also accepted + in -flat-float-array mode, the same separability will be + inferred in the two modes. In particular, the same .cmi files + and digests will be produced. + + Before we introduced this hack, the production of different + .cmi files would break the build system of the compiler itself, + when trying to build a -no-flat-float-array system from + a bootstrap compiler itself using -flat-float-array. See #9291. + *) + try check_def env decl with + | Error _ -> + (* It could be nice to emit a warning here, so that users know + that their definition would be rejected in -flat-float-array mode *) + best_msig decl + +(** Separability as a generic property *) +type prop = Types.Separability.signature + +let property : (prop, unit) Typedecl_properties.property = + let open Typedecl_properties in + let eq ts1 ts2 = + List.length ts1 = List.length ts2 + && List.for_all2 Sep.eq ts1 ts2 in + let merge ~prop:_ ~new_prop = + (* the update function is monotonous: ~new_prop is always + more informative than ~prop, which can be ignored *) + new_prop in + let default decl = best_msig decl in + let compute env decl () = compute_decl env decl in + let update_decl decl type_separability = { decl with type_separability } in + let check _env _id _decl () = () in (* FIXME run final check? *) + { eq; merge; default; compute; update_decl; check; } + +(* Definition using the fixpoint infrastructure. *) +let update_decls env decls = + Typedecl_properties.compute_property_noreq property env decls diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl_separability.mli b/ocamlmerlin_mlx/ocaml/typing/typedecl_separability.mli new file mode 100644 index 0000000..079e640 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl_separability.mli @@ -0,0 +1,132 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** The OCaml runtime assumes for type-directed optimizations that all types + are "separable". A type is "separable" if either all its inhabitants + (the values of this type) are floating-point numbers, or none of them are. + + (Note: This assumption is required for the dynamic float array optimization; + it is only made if Config.flat_float_array is set, + otherwise the code in this module becomes trivial + -- see {!compute_decl}.) + + This soundness requirement could be broken by type declarations mixing + existentials and the "[@@unboxed]" annotation. Consider the declaration + + {[ + type any = Any : 'a -> any [@@unboxed] + ]} + + which corresponds to the existential type "exists a. a". If this type is + allowed to be unboxed, then it is inhabited by both [float] values + and non-[float] values. On the contrary, if unboxing is disallowed, the + inhabitants are all blocks with the [Any] constructors pointing to its + parameter: they may point to a float, but they are not floats. + + The present module contains a static analysis ensuring that declarations + annotated with "[@@unboxed]" can be safely unboxed. The idea is to check + the "separability" (in the above sense) of the argument type that would + be unboxed, and reject the unboxed declaration if it would create a + non-separable type. + + Checking mutually-recursive type declarations is a bit subtle. + Consider, for example, the following declarations. + + {[ + type foo = Foo : 'a t -> foo [@@unboxed] + and 'a t = ... + ]} + + Deciding whether the type [foo] should be accepted requires inspecting + the declaration of ['a t], which may itself refer to [foo] in turn. + In general, the analysis performs a fixpoint computation. It is somewhat + similar to what is done for inferring the variance of type parameters. + + Our analysis is defined using inference rules for our judgment + [Def; Gamma |- t : m], in which a type expression [t] is checked + against a "mode" [m]. This "mode" describes the separability + requirement on the type expression (see below for + more details). The mode [Gamma] maps type variables to modes and + [Def] records the "mode signature" of the mutually-recursive type + declarations that are being checked. + + The "mode signature" of a type with parameters [('a, 'b) t] is of the + form [('a : m1, 'b : m2) t], where [m1] and [m2] are modes. Its meaning + is the following: a concrete instance [(foo, bar) t] of the type is + separable if [foo] has mode [m1] and [bar] has mode [m2]. *) + +type error = + | Non_separable_evar of string option +exception Error of Location.t * error +(** Exception raised when a type declaration is not separable, or when its + separability cannot be established. *) + +type mode = Types.Separability.t = Ind | Sep | Deepsep +(** The mode [Sep] ("separable") characterizes types that are indeed separable: + either they only contain floating-point values, or none of the values + at this type are floating-point values. + On a type parameter, it indicates that this parameter must be + separable for the whole type definition to be separable. For + example, the mode signature for the type declaration [type 'a + t = 'a] is [('a : Sep) t]. For the right-hand side to be + separable, the parameter ['a] must be separable. + + The mode [Ind] ("indifferent") characterizes any type -- separable + or not. + On a type parameter, it indicates that this parameter needs not be + separable for the whole type definition to be separable. For + example, [type 'a t = 'a * bool] does not require its parameter + ['a] to be separable as ['a * bool] can never contain [float] + values. Its mode signature is thus [('a : Ind) t]. + + Finally, the mode [Deepsep] ("deeply separable") characterizes + types that are separable, and whose type sub-expressions are also + separable. This advanced feature is only used in the presence of + constraints. + For example, [type 'a t = 'b constraint 'a = 'b * bool] + may not be separable even if ['a] is (its separately depends on 'b, + a fragment of 'a), so its mode signature is [('a : Deepsep) t]. + + The different modes are ordered as [Ind < Sep < Deepsep] (from the least + demanding to the most demanding). *) + +val compute_decl : Env.t -> Types.type_declaration -> mode list +(** [compute_decl env def] returns the signature required + for the type definition [def] in the typing environment [env] + -- including signatures for the current recursive block. + + The {!Error} exception is raised if no such signature exists + -- the definition will always be invalid. This only happens + when the definition is marked to be unboxed. + + Variant (or record) declarations that are not marked with the + "[@@unboxed]" annotation, including those that contain several variants + (or labels), are always separable. In particular, their mode signatures + do not require anything of their type parameters, which are marked [Ind]. + + Finally, if {!Config.flat_float_array} is not set, then separability + is not required anymore; we just use [Ind] as the mode of each parameter + without any check. +*) + +(** Property interface (see {!Typedecl_properties}). These functions + rely on {!compute_decl} and raise the {!Error} exception on error. *) +type prop = Types.Separability.signature +val property : (prop, unit) Typedecl_properties.property +val update_decls : + Env.t -> + (Ident.t * Typedecl_properties.decl) list -> + (Ident.t * Typedecl_properties.decl) list diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl_unboxed.ml b/ocamlmerlin_mlx/ocaml/typing/typedecl_unboxed.ml new file mode 100644 index 0000000..16290f0 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl_unboxed.ml @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +(* We use the Ctype.expand_head_opt version of expand_head to get access + to the manifest type of private abbreviations. *) +let rec get_unboxed_type_representation env ty fuel = + if fuel < 0 then None else + let ty = Ctype.expand_head_opt env ty in + match get_desc ty with + | Tconstr (p, args, _) -> + begin match Env.find_type p env with + | exception Not_found -> Some ty + | {type_params; type_kind = + Type_record ([{ld_type = ty2; _}], Record_unboxed _) + | Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], Variant_unboxed) + | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}], + Variant_unboxed)} + -> + let ty2 = match get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in + get_unboxed_type_representation env + (Ctype.apply env type_params ty2 args) (fuel - 1) + | _ -> Some ty + end + | _ -> Some ty + +let get_unboxed_type_representation env ty = + (* Do not give too much fuel: PR#7424 *) + get_unboxed_type_representation env ty 100 diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl_unboxed.mli b/ocamlmerlin_mlx/ocaml/typing/typedecl_unboxed.mli new file mode 100644 index 0000000..9e860dc --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl_unboxed.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +(* for typeopt.ml *) +val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl_variance.ml b/ocamlmerlin_mlx/ocaml/typing/typedecl_variance.ml new file mode 100644 index 0000000..ca0521a --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl_variance.ml @@ -0,0 +1,438 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Types + +module TypeSet = Btype.TypeSet +module TypeMap = Btype.TypeMap + +type surface_variance = bool * bool * bool + +type variance_variable_context = + | Type_declaration of Ident.t * type_declaration + | Gadt_constructor of constructor_declaration + | Extension_constructor of Ident.t * extension_constructor + +type variance_variable_error = + | No_variable + | Variance_not_reflected + | Variance_not_deducible + +type variance_error = + | Variance_not_satisfied of int + | Variance_variable_error of { + error : variance_variable_error; + context : variance_variable_context; + variable : type_expr + } + +type error = + | Bad_variance of variance_error * surface_variance * surface_variance + | Varying_anonymous + + +exception Error of Location.t * error + +(* Compute variance *) + +let get_variance ty visited = + try TypeMap.find ty !visited with Not_found -> Variance.null + +let compute_variance env visited vari ty = + let rec compute_variance_rec vari ty = + (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *) + let vari' = get_variance ty visited in + if Variance.subset vari vari' then () else + let vari = Variance.union vari vari' in + visited := TypeMap.add ty vari !visited; + let compute_same = compute_variance_rec vari in + match get_desc ty with + Tarrow (_, ty1, ty2, _) -> + compute_variance_rec (Variance.conjugate vari) ty1; + compute_same ty2 + | Ttuple tl -> + List.iter compute_same tl + | Tconstr (path, tl, _) -> + let open Variance in + if tl = [] then () else begin + try + let decl = Env.find_type path env in + List.iter2 + (fun ty v -> compute_variance_rec (compose vari v) ty) + tl decl.type_variance + with Not_found -> + List.iter (compute_variance_rec unknown) tl + end + | Tobject (ty, _) -> + compute_same ty + | Tfield (_, _, ty1, ty2) -> + compute_same ty1; + compute_same ty2 + | Tsubst _ -> + assert false + | Tvariant row -> + List.iter + (fun (_,f) -> + match row_field_repr f with + Rpresent (Some ty) -> + compute_same ty + | Reither (_, tyl, _) -> + let v = Variance.(inter vari unknown) in (* cf PR#7269 *) + List.iter (compute_variance_rec v) tyl + | _ -> ()) + (row_fields row); + compute_same (row_more row) + | Tpoly (ty, _) -> + compute_same ty + | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () + | Tpackage (_, fl) -> + let v = Variance.(compose vari full) in + List.iter (fun (_, ty) -> compute_variance_rec v ty) fl + in + compute_variance_rec vari ty + +let make p n i = + let open Variance in + set_if p May_pos (set_if n May_neg (set_if i Inj null)) + +let injective = Variance.(set Inj null) + +let compute_variance_type env ~check (required, loc) decl tyl = + (* Requirements *) + let check_injectivity = decl.type_kind = Type_abstract in + let required = + List.map + (fun (c,n,i) -> + let i = if check_injectivity then i else false in + if c || n then (c,n,i) else (true,true,i)) + required + in + (* Prepare *) + let params = decl.type_params in + let tvl = ref TypeMap.empty in + (* Compute occurrences in the body *) + let open Variance in + List.iter + (fun (cn,ty) -> + compute_variance env tvl (if cn then full else covariant) ty) + tyl; + (* Infer injectivity of constrained parameters *) + if check_injectivity then + List.iter + (fun ty -> + if Btype.is_Tvar ty || mem Inj (get_variance ty tvl) then () else + let visited = ref TypeSet.empty in + let rec check ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + if mem Inj (get_variance ty tvl) then () else + match get_desc ty with + | Tvar _ -> raise Exit + | Tconstr _ -> + let old = !visited in + begin try + Btype.iter_type_expr check ty + with Exit -> + visited := old; + let ty' = Ctype.expand_head_opt env ty in + if eq_type ty ty' then raise Exit else check ty' + end + | _ -> Btype.iter_type_expr check ty + end + in + try check ty; compute_variance env tvl injective ty + with Exit -> ()) + params; + begin match check with + | None -> () + | Some context -> + (* Check variance of parameters *) + let pos = ref 0 in + List.iter2 + (fun ty (c, n, i) -> + incr pos; + let var = get_variance ty tvl in + let (co,cn) = get_upper var and ij = mem Inj var in + if Btype.is_Tvar ty && (co && not c || cn && not n) || not ij && i + then raise (Error(loc, Bad_variance + (Variance_not_satisfied !pos, + (co,cn,ij), + (c,n,i))))) + params required; + (* Check propagation from constrained parameters *) + let args = Btype.newgenty (Ttuple params) in + let fvl = Ctype.free_variables args in + let fvl = + List.filter (fun v -> not (List.exists (eq_type v) params)) fvl in + (* If there are no extra variables there is nothing to do *) + if fvl = [] then () else + let tvl2 = ref TypeMap.empty in + List.iter2 + (fun ty (p,n,_) -> + if Btype.is_Tvar ty then () else + let v = + if p then if n then full else covariant else conjugate covariant in + compute_variance env tvl2 v ty) + params required; + let visited = ref TypeSet.empty in + let rec check ty = + if TypeSet.mem ty !visited then () else + let visited' = TypeSet.add ty !visited in + visited := visited'; + let v1 = get_variance ty tvl in + let snap = Btype.snapshot () in + let v2 = + TypeMap.fold + (fun t vt v -> + if Ctype.is_equal env false [ty] [t] then union vt v else v) + !tvl2 null in + Btype.backtrack snap; + let (c1,n1) = get_upper v1 and (c2,n2,i2) = get_lower v2 in + if c1 && not c2 || n1 && not n2 then begin + match List.find_opt (eq_type ty) fvl with + | Some variable -> + let error = + if not i2 then + No_variable + else if c2 || n2 then + Variance_not_reflected + else + Variance_not_deducible + in + let variance_error = + Variance_variable_error { error; context; variable } + in + raise + (Error (loc + , Bad_variance ( variance_error + , (c1,n1,false) + , (c2,n2,false)))) + | None -> + Btype.iter_type_expr check ty + end + in + List.iter (fun (_,ty) -> check ty) tyl; + end; + List.map2 + (fun ty (p, n, i) -> + let v = get_variance ty tvl in + let tr = decl.type_private in + (* Use required variance where relevant *) + let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in + let (p, n) = + if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *) + else (false, false) (* only check *) + and i = concr || i && tr = Private in + let v = union v (make p n i) in + if not concr || Btype.is_Tvar ty then v else + union v + (if p then if n then full else covariant else conjugate covariant)) + params required + +let add_false = List.map (fun ty -> false, ty) + +(* A parameter is constrained if it is either instantiated, + or it is a variable appearing in another parameter *) +let constrained vars ty = + match get_desc ty with + | Tvar _ -> List.exists (List.exists (eq_type ty)) vars + | _ -> true + +let for_constr = function + | Types.Cstr_tuple l -> add_false l + | Types.Cstr_record l -> + List.map + (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) + l + +let compute_variance_gadt env ~check (required, loc as rloc) decl + (tl, ret_type_opt) = + match ret_type_opt with + | None -> + compute_variance_type env ~check rloc {decl with type_private = Private} + (for_constr tl) + | Some ret_type -> + match get_desc ret_type with + | Tconstr (_, tyl, _) -> + (* let tyl = List.map (Ctype.expand_head env) tyl in *) + let fvl = List.map (Ctype.free_variables ?env:None) tyl in + let _ = + List.fold_left2 + (fun (fv1,fv2) ty (c,n,_) -> + match fv2 with [] -> assert false + | fv :: fv2 -> + (* fv1 @ fv2 = free_variables of other parameters *) + if (c||n) && constrained (fv1 @ fv2) ty then + raise (Error(loc, Varying_anonymous)); + (fv :: fv1, fv2)) + ([], fvl) tyl required + in + compute_variance_type env ~check rloc + {decl with type_params = tyl; type_private = Private} + (for_constr tl) + | _ -> assert false + +let compute_variance_extension env decl ext rloc = + let check = + Some (Extension_constructor (ext.Typedtree.ext_id, ext.Typedtree.ext_type)) + in + let ext = ext.Typedtree.ext_type in + compute_variance_gadt env ~check rloc + {decl with type_params = ext.ext_type_params} + (ext.ext_args, ext.ext_ret_type) + +let compute_variance_gadt_constructor env ~check rloc decl tl = + let check = + match check with + | Some _ -> Some (Gadt_constructor tl) + | None -> None + in + compute_variance_gadt env ~check rloc decl + (tl.Types.cd_args, tl.Types.cd_res) + +let compute_variance_decl env ~check decl (required, _ as rloc) = + let check = + Option.map (fun id -> Type_declaration (id, decl)) check + in + if (decl.type_kind = Type_abstract || decl.type_kind = Type_open) + && decl.type_manifest = None then + List.map + (fun (c, n, i) -> + make (not n) (not c) (decl.type_kind <> Type_abstract || i)) + required + else begin + let mn = + match decl.type_manifest with + None -> [] + | Some ty -> [ false, ty ] + in + let vari = + match decl.type_kind with + Type_abstract | Type_open -> + compute_variance_type env ~check rloc decl mn + | Type_variant (tll,_rep) -> + if List.for_all (fun c -> c.Types.cd_res = None) tll then + compute_variance_type env ~check rloc decl + (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args) + tll)) + else begin + let vari = + List.map + (fun ty -> + compute_variance_type env ~check rloc + {decl with type_private = Private} + (add_false [ ty ]) + ) + (Option.to_list decl.type_manifest) + in + let constructor_variance = + List.map + (compute_variance_gadt_constructor env ~check rloc decl) + tll + in + match List.append vari constructor_variance with + | vari :: rem -> + List.fold_left (List.map2 Variance.union) vari rem + | _ -> assert false + end + | Type_record (ftl, _) -> + compute_variance_type env ~check rloc decl + (mn @ List.map (fun {Types.ld_mutable; ld_type} -> + (ld_mutable = Mutable, ld_type)) ftl) + in + if mn = [] || decl.type_kind <> Type_abstract then + List.map Variance.strengthen vari + else vari + end + +let is_hash id = + let s = Ident.name id in + String.length s > 0 && s.[0] = '#' + +let check_variance_extension env decl ext rloc = + (* TODO: refactorize compute_variance_extension *) + ignore (compute_variance_extension env decl ext rloc) + +let compute_decl env ~check decl req = + compute_variance_decl env ~check decl (req, decl.type_loc) + +let check_decl env id decl req = + ignore (compute_variance_decl env ~check:(Some id) decl (req, decl.type_loc)) + +type prop = Variance.t list +type req = surface_variance list +let property : (prop, req) Typedecl_properties.property = + let open Typedecl_properties in + let eq li1 li2 = + try List.for_all2 Variance.eq li1 li2 with _ -> false in + let merge ~prop ~new_prop = + List.map2 Variance.union prop new_prop in + let default decl = + List.map (fun _ -> Variance.null) decl.type_params in + let compute env decl req = + compute_decl env ~check:None decl req in + let update_decl decl variance = + { decl with type_variance = variance } in + let check env id decl req = + if is_hash id then () else check_decl env id decl req in + { + eq; + merge; + default; + compute; + update_decl; + check; + } + +let transl_variance (v, i) = + let co, cn = + match v with + | Covariant -> (true, false) + | Contravariant -> (false, true) + | NoVariance -> (false, false) + in + (co, cn, match i with Injective -> true | NoInjectivity -> false) + +let variance_of_params ptype_params = + List.map transl_variance (List.map snd ptype_params) + +let variance_of_sdecl sdecl = + variance_of_params sdecl.Parsetree.ptype_params + +let update_decls env sdecls decls = + let required = List.map variance_of_sdecl sdecls in + Typedecl_properties.compute_property property env decls required + +let update_class_decls env cldecls = + let decls, required = + List.fold_right + (fun (obj_id, obj_abbr, _clty, _cltydef, ci) (decls, req) -> + (obj_id, obj_abbr) :: decls, + variance_of_params ci.Typedtree.ci_params :: req) + cldecls ([],[]) + in + let decls = + Typedecl_properties.compute_property property env decls required in + List.map2 + (fun (_,decl) (_, _, clty, cltydef, _) -> + let variance = decl.type_variance in + (decl, {clty with cty_variance = variance}, + {cltydef with + clty_variance = variance; + clty_hash_type = {cltydef.clty_hash_type with type_variance = variance} + })) + decls cldecls diff --git a/ocamlmerlin_mlx/ocaml/typing/typedecl_variance.mli b/ocamlmerlin_mlx/ocaml/typing/typedecl_variance.mli new file mode 100644 index 0000000..6392e61 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedecl_variance.mli @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types +open Typedecl_properties + +type surface_variance = bool * bool * bool + +val variance_of_params : + (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list -> + surface_variance list +val variance_of_sdecl : + Parsetree.type_declaration -> surface_variance list + +type prop = Variance.t list +type req = surface_variance list +val property : (Variance.t list, req) property + +type variance_variable_context = + | Type_declaration of Ident.t * type_declaration + | Gadt_constructor of constructor_declaration + | Extension_constructor of Ident.t * extension_constructor + +type variance_variable_error = + | No_variable + | Variance_not_reflected + | Variance_not_deducible + +type variance_error = + | Variance_not_satisfied of int + | Variance_variable_error of { + error : variance_variable_error; + context : variance_variable_context; + variable : type_expr + } + +type error = + | Bad_variance of variance_error * surface_variance * surface_variance + | Varying_anonymous + +exception Error of Location.t * error + +val check_variance_extension : + Env.t -> type_declaration -> + Typedtree.extension_constructor -> req * Location.t -> unit + +val compute_decl : + Env.t -> check:Ident.t option -> type_declaration -> req -> prop + +val update_decls : + Env.t -> Parsetree.type_declaration list -> + (Ident.t * type_declaration) list -> + (Ident.t * type_declaration) list + +val update_class_decls : + Env.t -> + (Ident.t * Typedecl_properties.decl * + Types.class_declaration * Types.class_type_declaration * + 'a Typedtree.class_infos) list -> + (Typedecl_properties.decl * + Types.class_declaration * Types.class_type_declaration) list +(* FIXME: improve this horrible interface *) diff --git a/ocamlmerlin_mlx/ocaml/typing/typedtree.ml b/ocamlmerlin_mlx/ocaml/typing/typedtree.ml new file mode 100644 index 0000000..f97d52a --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedtree.ml @@ -0,0 +1,879 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Abstract syntax tree after typing *) + +open Asttypes +open Types + +(* Value expressions for the core language *) + +type partial = Partial | Total + +type attribute = Parsetree.attribute +type attributes = attribute list + +type value = Value_pattern +type computation = Computation_pattern + +type _ pattern_category = +| Value : value pattern_category +| Computation : computation pattern_category + +type pattern = value general_pattern +and 'k general_pattern = 'k pattern_desc pattern_data + +and 'a pattern_data = + { pat_desc: 'a; + pat_loc: Location.t; + pat_extra : (pat_extra * Location.t * attribute list) list; + pat_type: type_expr; + pat_env: Env.t; + pat_attributes: attribute list; + } + +and pat_extra = + | Tpat_constraint of core_type + | Tpat_type of Path.t * Longident.t loc + | Tpat_open of Path.t * Longident.t loc * Env.t + | Tpat_unpack + +and 'k pattern_desc = + (* value patterns *) + | Tpat_any : value pattern_desc + | Tpat_var : Ident.t * string loc -> value pattern_desc + | Tpat_alias : + value general_pattern * Ident.t * string loc -> value pattern_desc + | Tpat_constant : constant -> value pattern_desc + | Tpat_tuple : value general_pattern list -> value pattern_desc + | Tpat_construct : + Longident.t loc * constructor_description * value general_pattern list + * (Ident.t loc list * core_type) option -> + value pattern_desc + | Tpat_variant : + label * value general_pattern option * row_desc ref -> + value pattern_desc + | Tpat_record : + (Longident.t loc * label_description * value general_pattern) list * + closed_flag -> + value pattern_desc + | Tpat_array : value general_pattern list -> value pattern_desc + | Tpat_lazy : value general_pattern -> value pattern_desc + (* computation patterns *) + | Tpat_value : tpat_value_argument -> computation pattern_desc + | Tpat_exception : value general_pattern -> computation pattern_desc + (* generic constructions *) + | Tpat_or : + 'k general_pattern * 'k general_pattern * row_desc option -> + 'k pattern_desc + +and tpat_value_argument = value general_pattern + +and expression = + { exp_desc: expression_desc; + exp_loc: Location.t; + exp_extra: (exp_extra * Location.t * attribute list) list; + exp_type: type_expr; + exp_env: Env.t; + exp_attributes: attribute list; + } + +and exp_extra = + | Texp_constraint of core_type + | Texp_coerce of core_type option * core_type + | Texp_poly of core_type option + | Texp_newtype of string + | Texp_newtype' of Ident.t * label loc + +and expression_desc = + Texp_ident of Path.t * Longident.t loc * Types.value_description + | Texp_constant of constant + | Texp_let of rec_flag * value_binding list * expression + | Texp_function of { arg_label : arg_label; param : Ident.t; + cases : value case list; partial : partial; } + | Texp_apply of expression * (arg_label * expression option) list + | Texp_match of expression * computation case list * partial + | Texp_try of expression * value case list + | Texp_tuple of expression list + | Texp_construct of + Longident.t loc * constructor_description * expression list + | Texp_variant of label * expression option + | Texp_record of { + fields : ( Types.label_description * record_label_definition ) array; + representation : Types.record_representation; + extended_expression : expression option; + } + | Texp_field of expression * Longident.t loc * label_description + | Texp_setfield of + expression * Longident.t loc * label_description * expression + | Texp_array of expression list + | Texp_ifthenelse of expression * expression * expression option + | Texp_sequence of expression * expression + | Texp_while of expression * expression + | Texp_for of + Ident.t * Parsetree.pattern * expression * expression * direction_flag * + expression + | Texp_send of expression * meth + | Texp_new of Path.t * Longident.t loc * Types.class_declaration + | Texp_instvar of Path.t * Path.t * string loc + | Texp_setinstvar of Path.t * Path.t * string loc * expression + | Texp_override of Path.t * (Ident.t * string loc * expression) list + | Texp_letmodule of + Ident.t option * string option loc * Types.module_presence * module_expr * + expression + | Texp_letexception of extension_constructor * expression + | Texp_assert of expression * Location.t + | Texp_lazy of expression + | Texp_object of class_structure * string list + | Texp_pack of module_expr + | Texp_letop of { + let_ : binding_op; + ands : binding_op list; + param : Ident.t; + body : value case; + partial : partial; + } + | Texp_unreachable + | Texp_extension_constructor of Longident.t loc * Path.t + | Texp_open of open_declaration * expression + | Texp_hole + +and meth = + | Tmeth_name of string + | Tmeth_val of Ident.t + | Tmeth_ancestor of Ident.t * Path.t + +and 'k case = + { + c_lhs: 'k general_pattern; + c_guard: expression option; + c_rhs: expression; + } + +and record_label_definition = + | Kept of Types.type_expr * mutable_flag + | Overridden of Longident.t loc * expression + +and binding_op = + { + bop_op_path : Path.t; + bop_op_name : string loc; + bop_op_val : Types.value_description; + bop_op_type : Types.type_expr; + bop_exp : expression; + bop_loc : Location.t; + } + +(* Value expressions for the class language *) + +and class_expr = + { + cl_desc: class_expr_desc; + cl_loc: Location.t; + cl_type: Types.class_type; + cl_env: Env.t; + cl_attributes: attribute list; + } + +and class_expr_desc = + Tcl_ident of Path.t * Longident.t loc * core_type list + | Tcl_structure of class_structure + | Tcl_fun of + arg_label * pattern * (Ident.t * expression) list + * class_expr * partial + | Tcl_apply of class_expr * (arg_label * expression option) list + | Tcl_let of rec_flag * value_binding list * + (Ident.t * expression) list * class_expr + | Tcl_constraint of + class_expr * class_type option * string list * string list * MethSet.t + (* Visible instance variables, methods and concrete methods *) + | Tcl_open of open_description * class_expr + +and class_structure = + { + cstr_self: pattern; + cstr_fields: class_field list; + cstr_type: Types.class_signature; + cstr_meths: Ident.t Meths.t; + } + +and class_field = + { + cf_desc: class_field_desc; + cf_loc: Location.t; + cf_attributes: attribute list; + } + +and class_field_kind = + | Tcfk_virtual of core_type + | Tcfk_concrete of override_flag * expression + +and class_field_desc = + Tcf_inherit of + override_flag * class_expr * string option * (string * Ident.t) list * + (string * Ident.t) list + (* Inherited instance variables and concrete methods *) + | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool + | Tcf_method of string loc * private_flag * class_field_kind + | Tcf_constraint of core_type * core_type + | Tcf_initializer of expression + | Tcf_attribute of attribute + +(* Value expressions for the module language *) + +and module_expr = + { mod_desc: module_expr_desc; + mod_loc: Location.t; + mod_type: Types.module_type; + mod_env: Env.t; + mod_attributes: attribute list; + } + +and module_type_constraint = + Tmodtype_implicit +| Tmodtype_explicit of module_type + +and functor_parameter = + | Unit + | Named of Ident.t option * string option loc * module_type + +and module_expr_desc = + Tmod_ident of Path.t * Longident.t loc + | Tmod_structure of structure + | Tmod_functor of functor_parameter * module_expr + | Tmod_apply of module_expr * module_expr * module_coercion + | Tmod_apply_unit of module_expr + | Tmod_constraint of + module_expr * Types.module_type * module_type_constraint * module_coercion + | Tmod_unpack of expression * Types.module_type + | Tmod_hole + +and structure = { + str_items : structure_item list; + str_type : Types.signature; + str_final_env : Env.t; +} + +and structure_item = + { str_desc : structure_item_desc; + str_loc : Location.t; + str_env : Env.t + } + +and structure_item_desc = + Tstr_eval of expression * attributes + | Tstr_value of rec_flag * value_binding list + | Tstr_primitive of value_description + | Tstr_type of rec_flag * type_declaration list + | Tstr_typext of type_extension + | Tstr_exception of type_exception + | Tstr_module of module_binding + | Tstr_recmodule of module_binding list + | Tstr_modtype of module_type_declaration + | Tstr_open of open_declaration + | Tstr_class of (class_declaration * string list) list + | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list + | Tstr_include of include_declaration + | Tstr_attribute of attribute + +and module_binding = + { + mb_id: Ident.t option; + mb_name: string option loc; + mb_presence: module_presence; + mb_expr: module_expr; + mb_attributes: attribute list; + mb_loc: Location.t; + } + +and value_binding = + { + vb_pat: pattern; + vb_expr: expression; + vb_attributes: attributes; + vb_loc: Location.t; + } + +and module_coercion = + Tcoerce_none + | Tcoerce_structure of (int * module_coercion) list * + (Ident.t * int * module_coercion) list + | Tcoerce_functor of module_coercion * module_coercion + | Tcoerce_primitive of primitive_coercion + | Tcoerce_alias of Env.t * Path.t * module_coercion + +and module_type = + { mty_desc: module_type_desc; + mty_type : Types.module_type; + mty_env : Env.t; + mty_loc: Location.t; + mty_attributes: attribute list; + } + +and module_type_desc = + Tmty_ident of Path.t * Longident.t loc + | Tmty_signature of signature + | Tmty_functor of functor_parameter * module_type + | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list + | Tmty_typeof of module_expr + | Tmty_alias of Path.t * Longident.t loc + +(* Keep primitive type information for type-based lambda-code specialization *) +and primitive_coercion = + { + pc_desc: Primitive.description; + pc_type: type_expr; + pc_env: Env.t; + pc_loc : Location.t; + } + +and signature = { + sig_items : signature_item list; + sig_type : Types.signature; + sig_final_env : Env.t; +} + +and signature_item = + { sig_desc: signature_item_desc; + sig_env : Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t } + +and signature_item_desc = + Tsig_value of value_description + | Tsig_type of rec_flag * type_declaration list + | Tsig_typesubst of type_declaration list + | Tsig_typext of type_extension + | Tsig_exception of type_exception + | Tsig_module of module_declaration + | Tsig_modsubst of module_substitution + | Tsig_recmodule of module_declaration list + | Tsig_modtype of module_type_declaration + | Tsig_modtypesubst of module_type_declaration + | Tsig_open of open_description + | Tsig_include of include_description + | Tsig_class of class_description list + | Tsig_class_type of class_type_declaration list + | Tsig_attribute of attribute + +and module_declaration = + { + md_id: Ident.t option; + md_name: string option loc; + md_presence: module_presence; + md_type: module_type; + md_attributes: attribute list; + md_loc: Location.t; + } + +and module_substitution = + { + ms_id: Ident.t; + ms_name: string loc; + ms_manifest: Path.t; + ms_txt: Longident.t loc; + ms_attributes: attributes; + ms_loc: Location.t; + } + +and module_type_declaration = + { + mtd_id: Ident.t; + mtd_name: string loc; + mtd_type: module_type option; + mtd_attributes: attribute list; + mtd_loc: Location.t; + } + +and 'a open_infos = + { + open_expr: 'a; + open_bound_items: Types.signature; + open_override: override_flag; + open_env: Env.t; + open_loc: Location.t; + open_attributes: attribute list; + } + +and open_description = (Path.t * Longident.t loc) open_infos + +and open_declaration = module_expr open_infos + +and 'a include_infos = + { + incl_mod: 'a; + incl_type: Types.signature; + incl_loc: Location.t; + incl_attributes: attribute list; + } + +and include_description = module_type include_infos + +and include_declaration = module_expr include_infos + +and with_constraint = + Twith_type of type_declaration + | Twith_module of Path.t * Longident.t loc + | Twith_modtype of module_type + | Twith_typesubst of type_declaration + | Twith_modsubst of Path.t * Longident.t loc + | Twith_modtypesubst of module_type + + +and core_type = +(* mutable because of [Typeclass.declare_method] *) + { mutable ctyp_desc : core_type_desc; + mutable ctyp_type : type_expr; + ctyp_env : Env.t; (* BINANNOT ADDED *) + ctyp_loc : Location.t; + ctyp_attributes: attribute list; + } + +and core_type_desc = + Ttyp_any + | Ttyp_var of string + | Ttyp_arrow of arg_label * core_type * core_type + | Ttyp_tuple of core_type list + | Ttyp_constr of Path.t * Longident.t loc * core_type list + | Ttyp_object of object_field list * closed_flag + | Ttyp_class of Path.t * Longident.t loc * core_type list + | Ttyp_alias of core_type * string + | Ttyp_variant of row_field list * closed_flag * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + +and package_type = { + pack_path : Path.t; + pack_fields : (Longident.t loc * core_type) list; + pack_type : Types.module_type; + pack_txt : Longident.t loc; +} + +and row_field = { + rf_desc : row_field_desc; + rf_loc : Location.t; + rf_attributes : attributes; +} + +and row_field_desc = + Ttag of string loc * bool * core_type list + | Tinherit of core_type + +and object_field = { + of_desc : object_field_desc; + of_loc : Location.t; + of_attributes : attributes; +} + +and object_field_desc = + | OTtag of string loc * core_type + | OTinherit of core_type + +and value_description = + { val_id: Ident.t; + val_name: string loc; + val_desc: core_type; + val_val: Types.value_description; + val_prim: string list; + val_loc: Location.t; + val_attributes: attribute list; + } + +and type_declaration = + { typ_id: Ident.t; + typ_name: string loc; + typ_params: (core_type * (variance * injectivity)) list; + typ_type: Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_loc: Location.t; + typ_attributes: attribute list; + } + +and type_kind = + Ttype_abstract + | Ttype_variant of constructor_declaration list + | Ttype_record of label_declaration list + | Ttype_open + +and label_declaration = + { + ld_id: Ident.t; + ld_name: string loc; + ld_mutable: mutable_flag; + ld_type: core_type; + ld_loc: Location.t; + ld_attributes: attribute list; + } + +and constructor_declaration = + { + cd_id: Ident.t; + cd_name: string loc; + cd_vars: string loc list; + cd_args: constructor_arguments; + cd_res: core_type option; + cd_loc: Location.t; + cd_attributes: attribute list; + } + +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + +and type_extension = + { + tyext_path: Path.t; + tyext_txt: Longident.t loc; + tyext_params: (core_type * (variance * injectivity)) list; + tyext_constructors: extension_constructor list; + tyext_private: private_flag; + tyext_loc: Location.t; + tyext_attributes: attribute list; + } + +and type_exception = + { + tyexn_constructor: extension_constructor; + tyexn_loc: Location.t; + tyexn_attributes: attribute list; + } + +and extension_constructor = + { + ext_id: Ident.t; + ext_name: string loc; + ext_type: Types.extension_constructor; + ext_kind: extension_constructor_kind; + ext_loc: Location.t; + ext_attributes: attribute list; + } + +and extension_constructor_kind = + Text_decl of string loc list * constructor_arguments * core_type option + | Text_rebind of Path.t * Longident.t loc + +and class_type = + { + cltyp_desc: class_type_desc; + cltyp_type: Types.class_type; + cltyp_env: Env.t; + cltyp_loc: Location.t; + cltyp_attributes: attribute list; + } + +and class_type_desc = + Tcty_constr of Path.t * Longident.t loc * core_type list + | Tcty_signature of class_signature + | Tcty_arrow of arg_label * core_type * class_type + | Tcty_open of open_description * class_type + +and class_signature = { + csig_self: core_type; + csig_fields: class_type_field list; + csig_type: Types.class_signature; + } + +and class_type_field = { + ctf_desc: class_type_field_desc; + ctf_loc: Location.t; + ctf_attributes: attribute list; + } + +and class_type_field_desc = + | Tctf_inherit of class_type + | Tctf_val of (string * mutable_flag * virtual_flag * core_type) + | Tctf_method of (string * private_flag * virtual_flag * core_type) + | Tctf_constraint of (core_type * core_type) + | Tctf_attribute of attribute + +and class_declaration = + class_expr class_infos + +and class_description = + class_type class_infos + +and class_type_declaration = + class_type class_infos + +and 'a class_infos = + { ci_virt: virtual_flag; + ci_params: (core_type * (variance * injectivity)) list; + ci_id_name: string loc; + ci_id_class: Ident.t; + ci_id_class_type: Ident.t; + ci_id_object: Ident.t; + ci_expr: 'a; + ci_decl: Types.class_declaration; + ci_type_decl: Types.class_type_declaration; + ci_loc: Location.t; + ci_attributes: attribute list; + } + +type implementation = { + structure: structure; + coercion: module_coercion; + signature: Types.signature; + shape: Shape.t; +} + + +(* Auxiliary functions over the a.s.t. *) + +let as_computation_pattern (p : pattern) : computation general_pattern = + { + pat_desc = Tpat_value p; + pat_loc = p.pat_loc; + pat_extra = []; + pat_type = p.pat_type; + pat_env = p.pat_env; + pat_attributes = []; + } + +let rec classify_pattern_desc : type k . k pattern_desc -> k pattern_category = + function + | Tpat_alias _ -> Value + | Tpat_tuple _ -> Value + | Tpat_construct _ -> Value + | Tpat_variant _ -> Value + | Tpat_record _ -> Value + | Tpat_array _ -> Value + | Tpat_lazy _ -> Value + | Tpat_any -> Value + | Tpat_var _ -> Value + | Tpat_constant _ -> Value + + | Tpat_value _ -> Computation + | Tpat_exception _ -> Computation + + | Tpat_or(p1, p2, _) -> + begin match classify_pattern p1, classify_pattern p2 with + | Value, Value -> Value + | Computation, Computation -> Computation + end + +and classify_pattern + : type k . k general_pattern -> k pattern_category + = fun pat -> + classify_pattern_desc pat.pat_desc + +type pattern_action = + { f : 'k . 'k general_pattern -> unit } +let shallow_iter_pattern_desc + : type k . pattern_action -> k pattern_desc -> unit + = fun f -> function + | Tpat_alias(p, _, _) -> f.f p + | Tpat_tuple patl -> List.iter f.f patl + | Tpat_construct(_, _, patl, _) -> List.iter f.f patl + | Tpat_variant(_, pat, _) -> Option.iter f.f pat + | Tpat_record (lbl_pat_list, _) -> + List.iter (fun (_, _, pat) -> f.f pat) lbl_pat_list + | Tpat_array patl -> List.iter f.f patl + | Tpat_lazy p -> f.f p + | Tpat_any + | Tpat_var _ + | Tpat_constant _ -> () + | Tpat_value p -> f.f p + | Tpat_exception p -> f.f p + | Tpat_or(p1, p2, _) -> f.f p1; f.f p2 + +type pattern_transformation = + { f : 'k . 'k general_pattern -> 'k general_pattern } +let shallow_map_pattern_desc + : type k . pattern_transformation -> k pattern_desc -> k pattern_desc + = fun f d -> match d with + | Tpat_alias (p1, id, s) -> + Tpat_alias (f.f p1, id, s) + | Tpat_tuple pats -> + Tpat_tuple (List.map f.f pats) + | Tpat_record (lpats, closed) -> + Tpat_record (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed) + | Tpat_construct (lid, c, pats, ty) -> + Tpat_construct (lid, c, List.map f.f pats, ty) + | Tpat_array pats -> + Tpat_array (List.map f.f pats) + | Tpat_lazy p1 -> Tpat_lazy (f.f p1) + | Tpat_variant (x1, Some p1, x2) -> + Tpat_variant (x1, Some (f.f p1), x2) + | Tpat_var _ + | Tpat_constant _ + | Tpat_any + | Tpat_variant (_,None,_) -> d + | Tpat_value p -> Tpat_value (f.f p) + | Tpat_exception p -> Tpat_exception (f.f p) + | Tpat_or (p1,p2,path) -> + Tpat_or (f.f p1, f.f p2, path) + +let rec iter_general_pattern + : type k . pattern_action -> k general_pattern -> unit + = fun f p -> + f.f p; + shallow_iter_pattern_desc + { f = fun p -> iter_general_pattern f p } + p.pat_desc + +let iter_pattern (f : pattern -> unit) = + iter_general_pattern + { f = fun (type k) (p : k general_pattern) -> + match classify_pattern p with + | Value -> f p + | Computation -> () } + +type pattern_predicate = { f : 'k . 'k general_pattern -> bool } +let exists_general_pattern (f : pattern_predicate) p = + let exception Found in + match + iter_general_pattern + { f = fun p -> if f.f p then raise Found else () } + p + with + | exception Found -> true + | () -> false + +let exists_pattern (f : pattern -> bool) = + exists_general_pattern + { f = fun (type k) (p : k general_pattern) -> + match classify_pattern p with + | Value -> f p + | Computation -> false } + + +(* List the identifiers bound by a pattern or a let *) + +let rec iter_bound_idents + : type k . _ -> k general_pattern -> _ + = fun f pat -> + match pat.pat_desc with + | Tpat_var (id,s) -> + f (id,s,pat.pat_type) + | Tpat_alias(p, id, s) -> + iter_bound_idents f p; + f (id,s,pat.pat_type) + | Tpat_or(p1, _, _) -> + (* Invariant : both arguments bind the same variables *) + iter_bound_idents f p1 + | d -> + shallow_iter_pattern_desc + { f = fun p -> iter_bound_idents f p } + d + +let rev_pat_bound_idents_full pat = + let idents_full = ref [] in + let add id_full = idents_full := id_full :: !idents_full in + iter_bound_idents add pat; + !idents_full + +let rev_only_idents idents_full = + List.rev_map (fun (id,_,_) -> id) idents_full + +let pat_bound_idents_full pat = + List.rev (rev_pat_bound_idents_full pat) + +let pat_bound_idents pat = + rev_only_idents (rev_pat_bound_idents_full pat) + +let rev_let_bound_idents_full bindings = + let idents_full = ref [] in + let add id_full = idents_full := id_full :: !idents_full in + List.iter (fun vb -> iter_bound_idents add vb.vb_pat) bindings; + !idents_full + +let let_bound_idents_full bindings = + List.rev (rev_let_bound_idents_full bindings) +let let_bound_idents pat = + rev_only_idents (rev_let_bound_idents_full pat) + +let alpha_var env id = List.assoc id env + +let rec alpha_pat + : type k . _ -> k general_pattern -> k general_pattern + = fun env p -> match p.pat_desc with + | Tpat_var (id, s) -> (* note the ``Not_found'' case *) + {p with pat_desc = + try Tpat_var (alpha_var env id, s) with + | Not_found -> Tpat_any} + | Tpat_alias (p1, id, s) -> + let new_p : k general_pattern = alpha_pat env p1 in + begin try + {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} + with + | Not_found -> new_p + end + | d -> + let pat_desc = + shallow_map_pattern_desc { f = fun p -> alpha_pat env p } d in + {p with pat_desc} + +let mkloc = Location.mkloc +let mknoloc = Location.mknoloc + +let split_pattern pat = + let combine_opts merge p1 p2 = + match p1, p2 with + | None, None -> None + | Some p, None + | None, Some p -> + Some p + | Some p1, Some p2 -> + Some (merge p1 p2) + in + let into pat p1 p2 = + (* The third parameter of [Tpat_or] is [Some _] only for "#typ" + patterns, which we do *not* expand. Hence we can put [None] here. *) + { pat with pat_desc = Tpat_or (p1, p2, None) } in + let rec split_pattern cpat = + match cpat.pat_desc with + | Tpat_value p -> + Some p, None + | Tpat_exception p -> + None, Some p + | Tpat_or (cp1, cp2, _) -> + let vals1, exns1 = split_pattern cp1 in + let vals2, exns2 = split_pattern cp2 in + combine_opts (into cpat) vals1 vals2, + (* We could change the pattern type for exception patterns to + [Predef.exn], but it doesn't really matter. *) + combine_opts (into cpat) exns1 exns2 + in + split_pattern pat + +(* Expressions are considered nominal if they can be used as the subject of a + sentence or action. In practice, we consider that an expression is nominal + if they satisfy one of: + - Similar to an identifier: words separated by '.' or '#'. + - Do not contain spaces when printed. + *) +let rec exp_is_nominal exp = + match exp.exp_desc with + | _ when exp.exp_attributes <> [] -> false + | Texp_ident _ | Texp_instvar _ | Texp_constant _ + | Texp_variant (_, None) + | Texp_construct (_, _, []) -> + true + | Texp_field (parent, _, _) | Texp_send (parent, _) -> exp_is_nominal parent + | _ -> false + +(* Merlin specific *) + +let unpack_functor_me me = + match me.mod_desc with + | Tmod_functor (fp, mty) -> fp, mty + | _ -> invalid_arg "Typedtree.unpack_functor_me (merlin)" + +let unpack_functor_mty mty = + match mty.mty_desc with + | Tmty_functor (fp, mty) -> fp, mty + | _ -> invalid_arg "Typedtree.unpack_functor_mty (merlin)" diff --git a/ocamlmerlin_mlx/ocaml/typing/typedtree.mli b/ocamlmerlin_mlx/ocaml/typing/typedtree.mli new file mode 100644 index 0000000..4f4ca2b --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typedtree.mli @@ -0,0 +1,845 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Abstract syntax tree after typing *) + + +(** By comparison with {!Parsetree}: + - Every {!Longindent.t} is accompanied by a resolved {!Path.t}. + +*) + +open Asttypes + +(* Value expressions for the core language *) + +type partial = Partial | Total + +(** {1 Extension points} *) + +type attribute = Parsetree.attribute +type attributes = attribute list + +(** {1 Core language} *) + +type value = Value_pattern +type computation = Computation_pattern + +type _ pattern_category = +| Value : value pattern_category +| Computation : computation pattern_category + +type pattern = value general_pattern +and 'k general_pattern = 'k pattern_desc pattern_data + +and 'a pattern_data = + { pat_desc: 'a; + pat_loc: Location.t; + pat_extra : (pat_extra * Location.t * attributes) list; + pat_type: Types.type_expr; + pat_env: Env.t; + pat_attributes: attributes; + } + +and pat_extra = + | Tpat_constraint of core_type + (** P : T { pat_desc = P + ; pat_extra = (Tpat_constraint T, _, _) :: ... } + *) + | Tpat_type of Path.t * Longident.t loc + (** #tconst { pat_desc = disjunction + ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...} + + where [disjunction] is a [Tpat_or _] representing the + branches of [tconst]. + *) + | Tpat_open of Path.t * Longident.t loc * Env.t + | Tpat_unpack + (** (module P) { pat_desc = Tpat_var "P" + ; pat_extra = (Tpat_unpack, _, _) :: ... } + (module _) { pat_desc = Tpat_any + ; pat_extra = (Tpat_unpack, _, _) :: ... } + *) + +and 'k pattern_desc = + (* value patterns *) + | Tpat_any : value pattern_desc + (** _ *) + | Tpat_var : Ident.t * string loc -> value pattern_desc + (** x *) + | Tpat_alias : + value general_pattern * Ident.t * string loc -> value pattern_desc + (** P as a *) + | Tpat_constant : constant -> value pattern_desc + (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Tpat_tuple : value general_pattern list -> value pattern_desc + (** (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Tpat_construct : + Longident.t loc * Types.constructor_description * + value general_pattern list * (Ident.t loc list * core_type) option -> + value pattern_desc + (** C ([], None) + C P ([P], None) + C (P1, ..., Pn) ([P1; ...; Pn], None) + C (P : t) ([P], Some ([], t)) + C (P1, ..., Pn : t) ([P1; ...; Pn], Some ([], t)) + C (type a) (P : t) ([P], Some ([a], t)) + C (type a) (P1, ..., Pn : t) ([P1; ...; Pn], Some ([a], t)) + *) + | Tpat_variant : + label * value general_pattern option * Types.row_desc ref -> + value pattern_desc + (** `A (None) + `A P (Some P) + + See {!Types.row_desc} for an explanation of the last parameter. + *) + | Tpat_record : + (Longident.t loc * Types.label_description * value general_pattern) list * + closed_flag -> + value pattern_desc + (** { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Tpat_array : value general_pattern list -> value pattern_desc + (** [| P1; ...; Pn |] *) + | Tpat_lazy : value general_pattern -> value pattern_desc + (** lazy P *) + (* computation patterns *) + | Tpat_value : tpat_value_argument -> computation pattern_desc + (** P + + Invariant: Tpat_value pattern should not carry + pat_attributes or pat_extra metadata coming from user + syntax, which must be on the inner pattern node -- to + facilitate searching for a certain value pattern + constructor with a specific attributed. + + To enforce this restriction, we made the argument of + the Tpat_value constructor a private synonym of [pattern], + requiring you to use the [as_computation_pattern] function + below instead of using the [Tpat_value] constructor directly. + *) + | Tpat_exception : value general_pattern -> computation pattern_desc + (** exception P *) + (* generic constructions *) + | Tpat_or : + 'k general_pattern * 'k general_pattern * Types.row_desc option -> + 'k pattern_desc + (** P1 | P2 + + [row_desc] = [Some _] when translating [Ppat_type _], + [None] otherwise. + *) + +and tpat_value_argument = private value general_pattern + +and expression = + { exp_desc: expression_desc; + exp_loc: Location.t; + exp_extra: (exp_extra * Location.t * attributes) list; + exp_type: Types.type_expr; + exp_env: Env.t; + exp_attributes: attributes; + } + +and exp_extra = + | Texp_constraint of core_type + (** E : T *) + | Texp_coerce of core_type option * core_type + (** E :> T [Texp_coerce (None, T)] + E : T0 :> T [Texp_coerce (Some T0, T)] + *) + | Texp_poly of core_type option + (** Used for method bodies. *) + | Texp_newtype of string + (** fun (type t) -> *) + | Texp_newtype' of Ident.t * label loc + (** merlin-specific: keep enough information to correctly implement + occurrences for local-types. + Merlin typechecker uses [Texp_newtype'] constructor, while upstream + OCaml still uses [Texp_newtype]. Those can appear when unmarshaling cmt + files. By adding a new constructor, we can still safely uses these. *) + +and expression_desc = + Texp_ident of Path.t * Longident.t loc * Types.value_description + (** x + M.x + *) + | Texp_constant of constant + (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Texp_let of rec_flag * value_binding list * expression + (** let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Texp_function of { arg_label : arg_label; param : Ident.t; + cases : value case list; partial : partial; } + (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function]. + See {!Parsetree} for more details. + + [param] is the identifier that is to be used to name the + parameter of the function. + + partial = + [Partial] if the pattern match is partial + [Total] otherwise. + *) + | Texp_apply of expression * (arg_label * expression option) list + (** E0 ~l1:E1 ... ~ln:En + + The expression can be None if the expression is abstracted over + this argument. It currently appears when a label is applied. + + For example: + let f x ~y = x + y in + f ~y:3 + + The resulting typedtree for the application is: + Texp_apply (Texp_ident "f/1037", + [(Nolabel, None); + (Labelled "y", Some (Texp_constant Const_int 3)) + ]) + *) + | Texp_match of expression * computation case list * partial + (** match E0 with + | P1 -> E1 + | P2 | exception P3 -> E2 + | exception P4 -> E3 + + [Texp_match (E0, [(P1, E1); (P2 | exception P3, E2); + (exception P4, E3)], _)] + *) + | Texp_try of expression * value case list + (** try E with P1 -> E1 | ... | PN -> EN *) + | Texp_tuple of expression list + (** (E1, ..., EN) *) + | Texp_construct of + Longident.t loc * Types.constructor_description * expression list + (** C [] + C E [E] + C (E1, ..., En) [E1;...;En] + *) + | Texp_variant of label * expression option + | Texp_record of { + fields : ( Types.label_description * record_label_definition ) array; + representation : Types.record_representation; + extended_expression : expression option; + } + (** { l1=P1; ...; ln=Pn } (extended_expression = None) + { E0 with l1=P1; ...; ln=Pn } (extended_expression = Some E0) + + Invariant: n > 0 + + If the type is { l1: t1; l2: t2 }, the expression + { E0 with t2=P2 } is represented as + Texp_record + { fields = [| l1, Kept t1; l2 Override P2 |]; representation; + extended_expression = Some E0 } + *) + | Texp_field of expression * Longident.t loc * Types.label_description + | Texp_setfield of + expression * Longident.t loc * Types.label_description * expression + | Texp_array of expression list + | Texp_ifthenelse of expression * expression * expression option + | Texp_sequence of expression * expression + | Texp_while of expression * expression + | Texp_for of + Ident.t * Parsetree.pattern * expression * expression * direction_flag * + expression + | Texp_send of expression * meth + | Texp_new of Path.t * Longident.t loc * Types.class_declaration + | Texp_instvar of Path.t * Path.t * string loc + | Texp_setinstvar of Path.t * Path.t * string loc * expression + | Texp_override of Path.t * (Ident.t * string loc * expression) list + | Texp_letmodule of + Ident.t option * string option loc * Types.module_presence * module_expr * + expression + | Texp_letexception of extension_constructor * expression + | Texp_assert of expression * Location.t + | Texp_lazy of expression + | Texp_object of class_structure * string list + | Texp_pack of module_expr + | Texp_letop of { + let_ : binding_op; + ands : binding_op list; + param : Ident.t; + body : value case; + partial : partial; + } + | Texp_unreachable + | Texp_extension_constructor of Longident.t loc * Path.t + | Texp_open of open_declaration * expression + (** let open[!] M in e *) + | Texp_hole + +and meth = + Tmeth_name of string + | Tmeth_val of Ident.t + | Tmeth_ancestor of Ident.t * Path.t + +and 'k case = + { + c_lhs: 'k general_pattern; + c_guard: expression option; + c_rhs: expression; + } + +and record_label_definition = + | Kept of Types.type_expr * mutable_flag + | Overridden of Longident.t loc * expression + +and binding_op = + { + bop_op_path : Path.t; + bop_op_name : string loc; + bop_op_val : Types.value_description; + bop_op_type : Types.type_expr; + (* This is the type at which the operator was used. + It is always an instance of [bop_op_val.val_type] *) + bop_exp : expression; + bop_loc : Location.t; + } + +(* Value expressions for the class language *) + +and class_expr = + { + cl_desc: class_expr_desc; + cl_loc: Location.t; + cl_type: Types.class_type; + cl_env: Env.t; + cl_attributes: attributes; + } + +and class_expr_desc = + Tcl_ident of Path.t * Longident.t loc * core_type list + | Tcl_structure of class_structure + | Tcl_fun of + arg_label * pattern * (Ident.t * expression) list + * class_expr * partial + | Tcl_apply of class_expr * (arg_label * expression option) list + | Tcl_let of rec_flag * value_binding list * + (Ident.t * expression) list * class_expr + | Tcl_constraint of + class_expr * class_type option * string list * string list + * Types.MethSet.t + (* Visible instance variables, methods and concrete methods *) + | Tcl_open of open_description * class_expr + +and class_structure = + { + cstr_self: pattern; + cstr_fields: class_field list; + cstr_type: Types.class_signature; + cstr_meths: Ident.t Types.Meths.t; + } + +and class_field = + { + cf_desc: class_field_desc; + cf_loc: Location.t; + cf_attributes: attributes; + } + +and class_field_kind = + | Tcfk_virtual of core_type + | Tcfk_concrete of override_flag * expression + +and class_field_desc = + Tcf_inherit of + override_flag * class_expr * string option * (string * Ident.t) list * + (string * Ident.t) list + (* Inherited instance variables and concrete methods *) + | Tcf_val of string loc * mutable_flag * Ident.t * class_field_kind * bool + | Tcf_method of string loc * private_flag * class_field_kind + | Tcf_constraint of core_type * core_type + | Tcf_initializer of expression + | Tcf_attribute of attribute + +(* Value expressions for the module language *) + +and module_expr = + { mod_desc: module_expr_desc; + mod_loc: Location.t; + mod_type: Types.module_type; + mod_env: Env.t; + mod_attributes: attributes; + } + +(** Annotations for [Tmod_constraint]. *) +and module_type_constraint = + | Tmodtype_implicit + (** The module type constraint has been synthesized during typechecking. *) + | Tmodtype_explicit of module_type + (** The module type was in the source file. *) + +and functor_parameter = + | Unit + | Named of Ident.t option * string option loc * module_type + +and module_expr_desc = + Tmod_ident of Path.t * Longident.t loc + | Tmod_structure of structure + | Tmod_functor of functor_parameter * module_expr + | Tmod_apply of module_expr * module_expr * module_coercion + | Tmod_apply_unit of module_expr + | Tmod_constraint of + module_expr * Types.module_type * module_type_constraint * module_coercion + (** ME (constraint = Tmodtype_implicit) + (ME : MT) (constraint = Tmodtype_explicit MT) + *) + | Tmod_unpack of expression * Types.module_type + | Tmod_hole + +and structure = { + str_items : structure_item list; + str_type : Types.signature; + str_final_env : Env.t; +} + +and structure_item = + { str_desc : structure_item_desc; + str_loc : Location.t; + str_env : Env.t + } + +and structure_item_desc = + Tstr_eval of expression * attributes + | Tstr_value of rec_flag * value_binding list + | Tstr_primitive of value_description + | Tstr_type of rec_flag * type_declaration list + | Tstr_typext of type_extension + | Tstr_exception of type_exception + | Tstr_module of module_binding + | Tstr_recmodule of module_binding list + | Tstr_modtype of module_type_declaration + | Tstr_open of open_declaration + | Tstr_class of (class_declaration * string list) list + | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list + | Tstr_include of include_declaration + | Tstr_attribute of attribute + +and module_binding = + { + mb_id: Ident.t option; + mb_name: string option loc; + mb_presence: Types.module_presence; + mb_expr: module_expr; + mb_attributes: attributes; + mb_loc: Location.t; + } + +and value_binding = + { + vb_pat: pattern; + vb_expr: expression; + vb_attributes: attributes; + vb_loc: Location.t; + } + +and module_coercion = + Tcoerce_none + | Tcoerce_structure of (int * module_coercion) list * + (Ident.t * int * module_coercion) list + | Tcoerce_functor of module_coercion * module_coercion + | Tcoerce_primitive of primitive_coercion + | Tcoerce_alias of Env.t * Path.t * module_coercion + +and module_type = + { mty_desc: module_type_desc; + mty_type : Types.module_type; + mty_env : Env.t; + mty_loc: Location.t; + mty_attributes: attributes; + } + +and module_type_desc = + Tmty_ident of Path.t * Longident.t loc + | Tmty_signature of signature + | Tmty_functor of functor_parameter * module_type + | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list + | Tmty_typeof of module_expr + | Tmty_alias of Path.t * Longident.t loc + +and primitive_coercion = + { + pc_desc: Primitive.description; + pc_type: Types.type_expr; + pc_env: Env.t; + pc_loc : Location.t; + } + +and signature = { + sig_items : signature_item list; + sig_type : Types.signature; + sig_final_env : Env.t; +} + +and signature_item = + { sig_desc: signature_item_desc; + sig_env : Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t } + +and signature_item_desc = + Tsig_value of value_description + | Tsig_type of rec_flag * type_declaration list + | Tsig_typesubst of type_declaration list + | Tsig_typext of type_extension + | Tsig_exception of type_exception + | Tsig_module of module_declaration + | Tsig_modsubst of module_substitution + | Tsig_recmodule of module_declaration list + | Tsig_modtype of module_type_declaration + | Tsig_modtypesubst of module_type_declaration + | Tsig_open of open_description + | Tsig_include of include_description + | Tsig_class of class_description list + | Tsig_class_type of class_type_declaration list + | Tsig_attribute of attribute + +and module_declaration = + { + md_id: Ident.t option; + md_name: string option loc; + md_presence: Types.module_presence; + md_type: module_type; + md_attributes: attributes; + md_loc: Location.t; + } + +and module_substitution = + { + ms_id: Ident.t; + ms_name: string loc; + ms_manifest: Path.t; + ms_txt: Longident.t loc; + ms_attributes: attributes; + ms_loc: Location.t; + } + +and module_type_declaration = + { + mtd_id: Ident.t; + mtd_name: string loc; + mtd_type: module_type option; + mtd_attributes: attributes; + mtd_loc: Location.t; + } + +and 'a open_infos = + { + open_expr: 'a; + open_bound_items: Types.signature; + open_override: override_flag; + open_env: Env.t; + open_loc: Location.t; + open_attributes: attribute list; + } + +and open_description = (Path.t * Longident.t loc) open_infos + +and open_declaration = module_expr open_infos + + +and 'a include_infos = + { + incl_mod: 'a; + incl_type: Types.signature; + incl_loc: Location.t; + incl_attributes: attribute list; + } + +and include_description = module_type include_infos + +and include_declaration = module_expr include_infos + +and with_constraint = + Twith_type of type_declaration + | Twith_module of Path.t * Longident.t loc + | Twith_modtype of module_type + | Twith_typesubst of type_declaration + | Twith_modsubst of Path.t * Longident.t loc + | Twith_modtypesubst of module_type + +and core_type = + { mutable ctyp_desc : core_type_desc; + (** mutable because of [Typeclass.declare_method] *) + mutable ctyp_type : Types.type_expr; + (** mutable because of [Typeclass.declare_method] *) + ctyp_env : Env.t; (* BINANNOT ADDED *) + ctyp_loc : Location.t; + ctyp_attributes: attributes; + } + +and core_type_desc = + Ttyp_any + | Ttyp_var of string + | Ttyp_arrow of arg_label * core_type * core_type + | Ttyp_tuple of core_type list + | Ttyp_constr of Path.t * Longident.t loc * core_type list + | Ttyp_object of object_field list * closed_flag + | Ttyp_class of Path.t * Longident.t loc * core_type list + | Ttyp_alias of core_type * string + | Ttyp_variant of row_field list * closed_flag * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + +and package_type = { + pack_path : Path.t; + pack_fields : (Longident.t loc * core_type) list; + pack_type : Types.module_type; + pack_txt : Longident.t loc; +} + +and row_field = { + rf_desc : row_field_desc; + rf_loc : Location.t; + rf_attributes : attributes; +} + +and row_field_desc = + Ttag of string loc * bool * core_type list + | Tinherit of core_type + +and object_field = { + of_desc : object_field_desc; + of_loc : Location.t; + of_attributes : attributes; +} + +and object_field_desc = + | OTtag of string loc * core_type + | OTinherit of core_type + +and value_description = + { val_id: Ident.t; + val_name: string loc; + val_desc: core_type; + val_val: Types.value_description; + val_prim: string list; + val_loc: Location.t; + val_attributes: attributes; + } + +and type_declaration = + { + typ_id: Ident.t; + typ_name: string loc; + typ_params: (core_type * (variance * injectivity)) list; + typ_type: Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_loc: Location.t; + typ_attributes: attributes; + } + +and type_kind = + Ttype_abstract + | Ttype_variant of constructor_declaration list + | Ttype_record of label_declaration list + | Ttype_open + +and label_declaration = + { + ld_id: Ident.t; + ld_name: string loc; + ld_mutable: mutable_flag; + ld_type: core_type; + ld_loc: Location.t; + ld_attributes: attributes; + } + +and constructor_declaration = + { + cd_id: Ident.t; + cd_name: string loc; + cd_vars: string loc list; + cd_args: constructor_arguments; + cd_res: core_type option; + cd_loc: Location.t; + cd_attributes: attributes; + } + +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + +and type_extension = + { + tyext_path: Path.t; + tyext_txt: Longident.t loc; + tyext_params: (core_type * (variance * injectivity)) list; + tyext_constructors: extension_constructor list; + tyext_private: private_flag; + tyext_loc: Location.t; + tyext_attributes: attributes; + } + +and type_exception = + { + tyexn_constructor: extension_constructor; + tyexn_loc: Location.t; + tyexn_attributes: attribute list; + } + +and extension_constructor = + { + ext_id: Ident.t; + ext_name: string loc; + ext_type : Types.extension_constructor; + ext_kind : extension_constructor_kind; + ext_loc : Location.t; + ext_attributes: attributes; + } + +and extension_constructor_kind = + Text_decl of string loc list * constructor_arguments * core_type option + | Text_rebind of Path.t * Longident.t loc + +and class_type = + { + cltyp_desc: class_type_desc; + cltyp_type: Types.class_type; + cltyp_env: Env.t; + cltyp_loc: Location.t; + cltyp_attributes: attributes; + } + +and class_type_desc = + Tcty_constr of Path.t * Longident.t loc * core_type list + | Tcty_signature of class_signature + | Tcty_arrow of arg_label * core_type * class_type + | Tcty_open of open_description * class_type + +and class_signature = { + csig_self : core_type; + csig_fields : class_type_field list; + csig_type : Types.class_signature; + } + +and class_type_field = { + ctf_desc: class_type_field_desc; + ctf_loc: Location.t; + ctf_attributes: attributes; + } + +and class_type_field_desc = + | Tctf_inherit of class_type + | Tctf_val of (string * mutable_flag * virtual_flag * core_type) + | Tctf_method of (string * private_flag * virtual_flag * core_type) + | Tctf_constraint of (core_type * core_type) + | Tctf_attribute of attribute + +and class_declaration = + class_expr class_infos + +and class_description = + class_type class_infos + +and class_type_declaration = + class_type class_infos + +and 'a class_infos = + { ci_virt: virtual_flag; + ci_params: (core_type * (variance * injectivity)) list; + ci_id_name : string loc; + ci_id_class: Ident.t; + ci_id_class_type : Ident.t; + ci_id_object : Ident.t; + ci_expr: 'a; + ci_decl: Types.class_declaration; + ci_type_decl : Types.class_type_declaration; + ci_loc: Location.t; + ci_attributes: attributes; + } + +type implementation = { + structure: structure; + coercion: module_coercion; + signature: Types.signature; + shape: Shape.t; +} +(** A typechecked implementation including its module structure, its exported + signature, and a coercion of the module against that signature. + + If an .mli file is present, the signature will come from that file and be + the exported signature of the module. + + If there isn't one, the signature will be inferred from the module + structure. +*) + +(* Auxiliary functions over the a.s.t. *) + +(** [as_computation_pattern p] is a computation pattern with description + [Tpat_value p], which enforces a correct placement of pat_attributes + and pat_extra metadata (on the inner value pattern, rather than on + the computation pattern). *) +val as_computation_pattern: pattern -> computation general_pattern + +val classify_pattern_desc: 'k pattern_desc -> 'k pattern_category +val classify_pattern: 'k general_pattern -> 'k pattern_category + +type pattern_action = + { f : 'k . 'k general_pattern -> unit } +val shallow_iter_pattern_desc: + pattern_action -> 'k pattern_desc -> unit + +type pattern_transformation = + { f : 'k . 'k general_pattern -> 'k general_pattern } +val shallow_map_pattern_desc: + pattern_transformation -> 'k pattern_desc -> 'k pattern_desc + +val iter_general_pattern: pattern_action -> 'k general_pattern -> unit +val iter_pattern: (pattern -> unit) -> pattern -> unit + +type pattern_predicate = { f : 'k . 'k general_pattern -> bool } +val exists_general_pattern: pattern_predicate -> 'k general_pattern -> bool +val exists_pattern: (pattern -> bool) -> pattern -> bool + +val let_bound_idents: value_binding list -> Ident.t list +val let_bound_idents_full: + value_binding list -> (Ident.t * string loc * Types.type_expr) list + +(** Alpha conversion of patterns *) +val alpha_pat: + (Ident.t * Ident.t) list -> 'k general_pattern -> 'k general_pattern + +val mknoloc: 'a -> 'a Asttypes.loc +val mkloc: 'a -> Location.t -> 'a Asttypes.loc + +val pat_bound_idents: 'k general_pattern -> Ident.t list +val pat_bound_idents_full: + 'k general_pattern -> (Ident.t * string loc * Types.type_expr) list + +(** Splits an or pattern into its value (left) and exception (right) parts. *) +val split_pattern: + computation general_pattern -> pattern option * pattern option + +(** Whether an expression looks nice as the subject of a sentence in a error + message. *) +val exp_is_nominal : expression -> bool + +(* Merlin specific *) + +val unpack_functor_me : module_expr -> functor_parameter * module_expr +val unpack_functor_mty : module_type -> functor_parameter * module_type diff --git a/ocamlmerlin_mlx/ocaml/typing/typemod.ml b/ocamlmerlin_mlx/ocaml/typing/typemod.ml new file mode 100644 index 0000000..201b78c --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typemod.ml @@ -0,0 +1,3614 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc +open Longident +open Path +open Asttypes +open Parsetree +open Types +open Format + +let () = Includemod_errorprinter.register () + +module Sig_component_kind = Shape.Sig_component_kind +module String = Misc.String + +type hiding_error = + | Illegal_shadowing of { + shadowed_item_id: Ident.t; + shadowed_item_kind: Sig_component_kind.t; + shadowed_item_loc: Location.t; + shadower_id: Ident.t; + user_id: Ident.t; + user_kind: Sig_component_kind.t; + user_loc: Location.t; + } + | Appears_in_signature of { + opened_item_id: Ident.t; + opened_item_kind: Sig_component_kind.t; + user_id: Ident.t; + user_kind: Sig_component_kind.t; + user_loc: Location.t; + } + +type error = + Cannot_apply of module_type + | Not_included of Includemod.explanation + | Cannot_eliminate_dependency of module_type + | Signature_expected + | Structure_expected of module_type + | With_no_component of Longident.t + | With_mismatch of Longident.t * Includemod.explanation + | With_makes_applicative_functor_ill_typed of + Longident.t * Path.t * Includemod.explanation + | With_changes_module_alias of Longident.t * Ident.t * Path.t + | With_cannot_remove_constrained_type + | Repeated_name of Sig_component_kind.t * string + | Non_generalizable of { vars : type_expr list; expression : type_expr } + | Non_generalizable_module of + { vars : type_expr list; item : value_description; mty : module_type } + | Implementation_is_required of string + | Interface_not_compiled of string + | Not_allowed_in_functor_body + | Not_a_packed_module of type_expr + | Incomplete_packed_module of type_expr + | Scoping_pack of Longident.t * type_expr + | Recursive_module_require_explicit_type + | Apply_generative + | Cannot_scrape_alias of Path.t + | Cannot_scrape_package_type of Path.t + | Badly_formed_signature of string * Typedecl.error + | Cannot_hide_id of hiding_error + | Invalid_type_subst_rhs + | Unpackable_local_modtype_subst of Path.t + | With_cannot_remove_packed_modtype of Path.t * module_type + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +open Typedtree + +let rec path_concat head p = + match p with + Pident tail -> Pdot (Pident head, Ident.name tail) + | Pdot (pre, s) -> Pdot (path_concat head pre, s) + | Papply _ -> assert false + | Pextra_ty (p, extra) -> Pextra_ty (path_concat head p, extra) + +(* Extract a signature from a module type *) + +let extract_sig env loc mty = + match Env.scrape_alias env mty with + Mty_signature sg -> sg + | Mty_for_hole -> [] + | Mty_alias path -> + raise(Error(loc, env, Cannot_scrape_alias path)) + | _ -> raise(Error(loc, env, Signature_expected)) + +let extract_sig_open env loc mty = + match Env.scrape_alias env mty with + Mty_signature sg -> sg + | Mty_for_hole -> [] + | Mty_alias path -> + raise(Error(loc, env, Cannot_scrape_alias path)) + | mty -> raise(Error(loc, env, Structure_expected mty)) + +(* Compute the environment after opening a module *) + +let type_open_ ?used_slot ?toplevel ovf env loc lid = + let path = Env.lookup_module_path ~load:true ~loc:lid.loc lid.txt env in + match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with + | Ok env -> path, env + | Error _ -> + let md = Env.find_module path env in + ignore (extract_sig_open env lid.loc md.md_type); + assert false + +let initial_env ~loc ~initially_opened_module + ~open_implicit_modules = + let env = Env.initial in + let open_module env m = + let open Asttypes in + let lid = {loc; txt = Longident.parse m } in + try + snd (type_open_ Override env lid.loc lid) + with + | (Typetexp.Error _ | Env.Error _ | Magic_numbers.Cmi.Error _ | Persistent_env.Error _) as exn -> + Msupport.raise_error exn; + env + | exn -> + Printf.ksprintf failwith + "Uncaught exception %s in initial_env.open_module: %s" + Obj.Extension_constructor.(name (of_val exn)) + (Printexc.to_string exn) + in + let add_units env units = + String.Set.fold + (fun name env -> + Env.add_persistent_structure (Ident.create_persistent name) env) + units + env + in + let units = + List.map Env.persistent_structures_of_dir (Load_path.get ()) + in + let env, units = + match initially_opened_module with + | None -> (env, units) + | Some m -> + (* Locate the directory that contains [m], adds the units it + contains to the environment and open [m] in the resulting + environment. *) + let rec loop before after = + match after with + | [] -> None + | units :: after -> + if String.Set.mem m units then + Some (units, List.rev_append before after) + else + loop (units :: before) after + in + let env, units = + match loop [] units with + | None -> + (env, units) + | Some (units_containing_m, other_units) -> + (add_units env units_containing_m, other_units) + in + (open_module env m, units) + in + let env = List.fold_left add_units env units in + List.fold_left open_module env open_implicit_modules + +let type_open_descr ?used_slot ?toplevel env sod = + let (path, newenv) = + Builtin_attributes.warning_scope sod.popen_attributes + (fun () -> + type_open_ ?used_slot ?toplevel sod.popen_override env sod.popen_loc + sod.popen_expr + ) + in + let od = + { + open_expr = (path, sod.popen_expr); + open_bound_items = []; + open_override = sod.popen_override; + open_env = newenv; + open_attributes = sod.popen_attributes; + open_loc = sod.popen_loc; + } + in + (od, newenv) + +(* Forward declaration, to be filled in by type_module_type_of *) +let type_module_type_of_fwd : + (Env.t -> Parsetree.module_expr -> + Typedtree.module_expr * Types.module_type) ref + = ref (fun _env _m -> assert false) + +(* Additional validity checks on type definitions arising from + recursive modules *) + +let check_recmod_typedecls env decls = + let recmod_ids = List.map fst decls in + List.iter + (fun (id, md) -> + List.iter + (fun path -> + Typedecl.check_recmod_typedecl env md.Types.md_loc recmod_ids + path (Env.find_type path env)) + (Mtype.type_paths env (Pident id) md.Types.md_type)) + decls + +(* Merge one "with" constraint in a signature *) + +let check_type_decl env sg loc id row_id newdecl decl = + let fresh_id = Ident.rename id in + let path = Pident fresh_id in + let sub = Subst.add_type id path Subst.identity in + let fresh_row_id, sub = + match row_id with + | None -> None, sub + | Some id -> + let fresh_row_id = Some (Ident.rename id) in + let sub = Subst.add_type id (Pident fresh_id) sub in + fresh_row_id, sub + in + let newdecl = Subst.type_declaration sub newdecl in + let decl = Subst.type_declaration sub decl in + let sg = List.map (Subst.signature_item Keep sub) sg in + let env = Env.add_type ~check:false fresh_id newdecl env in + let env = + match fresh_row_id with + | None -> env + | Some fresh_row_id -> Env.add_type ~check:false fresh_row_id newdecl env + in + let env = Env.add_signature sg env in + Includemod.type_declarations ~mark:Mark_both ~loc env fresh_id newdecl decl; + Typedecl.check_coherence env loc path newdecl + +let make_variance p n i = + let open Variance in + set_if p May_pos (set_if n May_neg (set_if i Inj null)) + +let rec iter_path_apply p ~f = + match p with + | Pident _ -> () + | Pdot (p, _) -> iter_path_apply p ~f + | Papply (p1, p2) -> + iter_path_apply p1 ~f; + iter_path_apply p2 ~f; + f p1 p2 (* after recursing, so we know both paths are well typed *) + | Pextra_ty _ -> assert false + +let path_is_strict_prefix = + let rec list_is_strict_prefix l ~prefix = + match l, prefix with + | [], [] -> false + | _ :: _, [] -> true + | [], _ :: _ -> false + | s1 :: t1, s2 :: t2 -> + String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2 + in + fun path ~prefix -> + match Path.flatten path, Path.flatten prefix with + | `Contains_apply, _ | _, `Contains_apply -> false + | `Ok (ident1, l1), `Ok (ident2, l2) -> + Ident.same ident1 ident2 + && list_is_strict_prefix l1 ~prefix:l2 + +let iterator_with_env env = + let env = ref (lazy env) in + let super = Btype.type_iterators in + env, { super with + Btype.it_signature = (fun self sg -> + (* add all items to the env before recursing down, to handle recursive + definitions *) + let env_before = !env in + env := lazy (Env.add_signature sg (Lazy.force env_before)); + super.Btype.it_signature self sg; + env := env_before + ); + Btype.it_module_type = (fun self -> function + | Mty_functor (param, mty_body) -> + let env_before = !env in + begin match param with + | Unit -> () + | Named (param, mty_arg) -> + self.Btype.it_module_type self mty_arg; + match param with + | None -> () + | Some id -> + env := lazy (Env.add_module ~arg:true id Mp_present + mty_arg (Lazy.force env_before)) + end; + self.Btype.it_module_type self mty_body; + env := env_before; + | mty -> + super.Btype.it_module_type self mty + ) + } + +let retype_applicative_functor_type ~loc env funct arg = + let mty_functor = (Env.find_module funct env).md_type in + let mty_arg = (Env.find_module arg env).md_type in + let mty_param = + match Env.scrape_alias env mty_functor with + | Mty_functor (Named (_, mty_param), _) -> mty_param + | _ -> assert false (* could trigger due to MPR#7611 *) + in + Includemod.check_modtype_inclusion ~loc env mty_arg arg mty_param + +(* When doing a deep destructive substitution with type M.N.t := .., we change M + and M.N and so we have to check that uses of the modules other than just + extracting components from them still make sense. There are only two such + kinds of uses: + - applicative functor types: F(M).t might not be well typed anymore + - aliases: module A = M still makes sense but it doesn't mean the same thing + anymore, so it's forbidden until it's clear what we should do with it. + This function would be called with M.N.t and N.t to check for these uses. *) +let check_usage_of_path_of_substituted_item paths ~loc ~lid env super = + { super with + Btype.it_signature_item = (fun self -> function + | Sig_module (id, _, { md_type = Mty_alias aliased_path; _ }, _, _) + when List.exists + (fun path -> path_is_strict_prefix path ~prefix:aliased_path) + paths + -> + let e = With_changes_module_alias (lid.txt, id, aliased_path) in + raise(Error(loc, Lazy.force !env, e)) + | sig_item -> + super.Btype.it_signature_item self sig_item + ); + Btype.it_path = (fun referenced_path -> + iter_path_apply referenced_path ~f:(fun funct arg -> + if List.exists + (fun path -> path_is_strict_prefix path ~prefix:arg) + paths + then + let env = Lazy.force !env in + match retype_applicative_functor_type ~loc env funct arg with + | None -> () + | Some explanation -> + raise(Error(loc, env, + With_makes_applicative_functor_ill_typed + (lid.txt, referenced_path, explanation))) + ) + ); + } + +(* When doing a module type destructive substitution [with module type T = RHS] + where RHS is not a module type path, we need to check that the module type + T was not used as a path for a packed module +*) +let check_usage_of_module_types ~error ~paths ~loc env super = + let it_do_type_expr it ty = match get_desc ty with + | Tpackage (p, _) -> + begin match List.find_opt (Path.same p) paths with + | Some p -> raise (Error(loc,Lazy.force !env,error p)) + | _ -> super.Btype.it_do_type_expr it ty + end + | _ -> super.Btype.it_do_type_expr it ty in + { super with Btype.it_do_type_expr } + +let do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg = + let env, iterator = iterator_with_env env in + let last, rest = match List.rev paths with + | [] -> assert false + | last :: rest -> last, rest + in + (* The last item is the one that's removed. We don't need to check how + it's used since it's replaced by a more specific type/module. *) + assert (match last with Pident _ -> true | _ -> false); + let iterator = match rest with + | [] -> iterator + | _ :: _ -> + check_usage_of_path_of_substituted_item rest ~loc ~lid env iterator + in + let iterator = match unpackable_modtype with + | None -> iterator + | Some mty -> + let error p = With_cannot_remove_packed_modtype(p,mty) in + check_usage_of_module_types ~error ~paths ~loc env iterator + in + iterator.Btype.it_signature iterator sg; + Btype.(unmark_iterators.it_signature unmark_iterators) sg + +let check_usage_after_substitution env ~loc ~lid paths unpackable_modtype sg = + match paths, unpackable_modtype with + | [_], None -> () + | _ -> do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg + +(* After substitution one also needs to re-check the well-foundedness + of type declarations in recursive modules *) +let rec extract_next_modules = function + | Sig_module (id, _, mty, Trec_next, _) :: rem -> + let (id_mty_l, rem) = extract_next_modules rem in + ((id, mty) :: id_mty_l, rem) + | sg -> ([], sg) + +let check_well_formed_module env loc context mty = + (* Format.eprintf "@[check_well_formed_module@ %a@]@." + Printtyp.modtype mty; *) + let open Btype in + let iterator = + let rec check_signature env = function + | [] -> () + | Sig_module (id, _, mty, Trec_first, _) :: rem -> + let (id_mty_l, rem) = extract_next_modules rem in + begin try + check_recmod_typedecls (Lazy.force env) ((id, mty) :: id_mty_l) + with Typedecl.Error (_, err) -> + raise (Error (loc, Lazy.force env, + Badly_formed_signature(context, err))) + end; + check_signature env rem + | _ :: rem -> + check_signature env rem + in + let env, super = iterator_with_env env in + { super with + it_type_expr = (fun _self _ty -> ()); + it_signature = (fun self sg -> + let env_before = !env in + let env = lazy (Env.add_signature sg (Lazy.force env_before)) in + check_signature env sg; + super.it_signature self sg); + } + in + iterator.it_module_type iterator mty + +let () = Env.check_well_formed_module := check_well_formed_module + +let type_decl_is_alias sdecl = (* assuming no explicit constraint *) + match sdecl.ptype_manifest with + | Some {ptyp_desc = Ptyp_constr (lid, stl)} + when List.length stl = List.length sdecl.ptype_params -> + begin + match + List.iter2 (fun x (y, _) -> + match x, y with + {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy} + when sx = sy -> () + | _, _ -> raise Exit) + stl sdecl.ptype_params; + with + | exception Exit -> None + | () -> Some lid + end + | _ -> None + +let params_are_constrained = + let rec loop = function + | [] -> false + | hd :: tl -> + match get_desc hd with + | Tvar _ -> List.memq hd tl || loop tl + | _ -> true + in + loop + +type with_info = + | With_type of Parsetree.type_declaration + | With_typesubst of Parsetree.type_declaration + | With_module of { + lid:Longident.t loc; + path:Path.t; + md:Types.module_declaration; + remove_aliases:bool + } + | With_modsubst of Longident.t loc * Path.t * Types.module_declaration + | With_modtype of Typedtree.module_type + | With_modtypesubst of Typedtree.module_type + +let merge_constraint initial_env loc sg lid constr = + let destructive_substitution = + match constr with + | With_type _ | With_module _ | With_modtype _ -> false + | With_typesubst _ | With_modsubst _ | With_modtypesubst _ -> true + in + let real_ids = ref [] in + let unpackable_modtype = ref None in + let split_row_id s ghosts = + let srow = s ^ "#row" in + let rec split before = function + | Sig_type(id,_,_,_) :: rest when Ident.name id = srow -> + before, Some id, rest + | a :: rest -> split (a::before) rest + | [] -> before, None, [] + in + split [] ghosts + in + let rec patch_item constr namelist outer_sig_env sg_for_env ~ghosts item = + let return ?(ghosts=ghosts) ~replace_by info = + Some (info, {Signature_group.ghosts; replace_by}) + in + match item, namelist, constr with + | Sig_type(id, decl, rs, priv), [s], + With_type ({ptype_kind = Ptype_abstract} as sdecl) + when Ident.name id = s && Typedecl.is_fixed_type sdecl -> + let decl_row = + let arity = List.length sdecl.ptype_params in + { + type_params = + List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; + type_arity = arity; + type_kind = Type_abstract; + type_private = Private; + type_manifest = None; + type_variance = + List.map + (fun (_, (v, i)) -> + let (c, n) = + match v with + | Covariant -> true, false + | Contravariant -> false, true + | NoVariance -> false, false + in + make_variance (not n) (not c) (i = Injective) + ) + sdecl.ptype_params; + type_separability = + Types.Separability.default_signature ~arity; + type_loc = sdecl.ptype_loc; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + and id_row = Ident.create_local (s^"#row") in + let initial_env = + Env.add_type ~check:false id_row decl_row initial_env + in + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let tdecl = + Typedecl.transl_with_constraint id ~fixed_row_path:(Pident id_row) + ~sig_env ~sig_decl:decl ~outer_env:initial_env sdecl in + let newdecl = tdecl.typ_type in + let before_ghosts, row_id, after_ghosts = split_row_id s ghosts in + check_type_decl outer_sig_env sg_for_env sdecl.ptype_loc + id row_id newdecl decl; + let decl_row = {decl_row with type_params = newdecl.type_params} in + let rs' = if rs = Trec_first then Trec_not else rs in + let ghosts = + List.rev_append before_ghosts + (Sig_type(id_row, decl_row, rs', priv)::after_ghosts) + in + return ~ghosts + ~replace_by:(Some (Sig_type(id, newdecl, rs, priv))) + (Pident id, lid, Twith_type tdecl) + | Sig_type(id, sig_decl, rs, priv) , [s], + (With_type sdecl | With_typesubst sdecl as constr) + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let tdecl = + Typedecl.transl_with_constraint id + ~sig_env ~sig_decl ~outer_env:initial_env sdecl in + let newdecl = tdecl.typ_type and loc = sdecl.ptype_loc in + let before_ghosts, row_id, after_ghosts = split_row_id s ghosts in + let ghosts = List.rev_append before_ghosts after_ghosts in + check_type_decl outer_sig_env sg_for_env loc + id row_id newdecl sig_decl; + begin match constr with + With_type _ -> + return ~ghosts + ~replace_by:(Some(Sig_type(id, newdecl, rs, priv))) + (Pident id, lid, Twith_type tdecl) + | (* With_typesubst *) _ -> + real_ids := [Pident id]; + return ~ghosts ~replace_by:None + (Pident id, lid, Twith_typesubst tdecl) + end + | Sig_modtype(id, mtd, priv), [s], + (With_modtype mty | With_modtypesubst mty) + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let () = match mtd.mtd_type with + | None -> () + | Some previous_mty -> + Includemod.check_modtype_equiv ~loc sig_env + id previous_mty mty.mty_type + in + if not destructive_substitution then + let mtd': modtype_declaration = + { + mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + mtd_type = Some mty.mty_type; + mtd_attributes = []; + mtd_loc = loc; + } + in + return + ~replace_by:(Some(Sig_modtype(id, mtd', priv))) + (Pident id, lid, Twith_modtype mty) + else begin + let path = Pident id in + real_ids := [path]; + begin match mty.mty_type with + | Mty_ident _ -> () + | mty -> unpackable_modtype := Some mty + end; + return ~replace_by:None (Pident id, lid, Twith_modtypesubst mty) + end + | Sig_module(id, pres, md, rs, priv), [s], + With_module {lid=lid'; md=md'; path; remove_aliases} + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let mty = md'.md_type in + let mty = Mtype.scrape_for_type_of ~remove_aliases sig_env mty in + let md'' = { md' with md_type = mty } in + let newmd = Mtype.strengthen_decl ~aliasable:false sig_env md'' path in + ignore(Includemod.modtypes ~mark:Mark_both ~loc sig_env + newmd.md_type md.md_type); + return + ~replace_by:(Some(Sig_module(id, pres, newmd, rs, priv))) + (Pident id, lid, Twith_module (path, lid')) + | Sig_module(id, _, md, _rs, _), [s], With_modsubst (lid',path,md') + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let aliasable = not (Env.is_functor_arg path sig_env) in + ignore + (Includemod.strengthened_module_decl ~loc ~mark:Mark_both + ~aliasable sig_env md' path md); + real_ids := [Pident id]; + return ~replace_by:None (Pident id, lid, Twith_modsubst (path, lid')) + | Sig_module(id, _, md, rs, priv) as item, s :: namelist, constr + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let sg = extract_sig sig_env loc md.md_type in + let ((path, _, tcstr), newsg) = merge_signature sig_env sg namelist in + let path = path_concat id path in + real_ids := path :: !real_ids; + let item = + match md.md_type, constr with + Mty_alias _, (With_module _ | With_type _) -> + (* A module alias cannot be refined, so keep it + and just check that the constraint is correct *) + item + | _ -> + let newmd = {md with md_type = Mty_signature newsg} in + Sig_module(id, Mp_present, newmd, rs, priv) + in + return ~replace_by:(Some item) (path, lid, tcstr) + | _ -> None + and merge_signature env sg namelist = + match + Signature_group.replace_in_place (patch_item constr namelist env sg) sg + with + | Some (x,sg) -> x, sg + | None -> raise(Error(loc, env, With_no_component lid.txt)) + in + try + let names = Longident.flatten lid.txt in + let (tcstr, sg) = merge_signature initial_env sg names in + if destructive_substitution then + check_usage_after_substitution ~loc ~lid initial_env !real_ids + !unpackable_modtype sg; + let sg = + match tcstr with + | (_, _, Twith_typesubst tdecl) -> + let how_to_extend_subst = + let sdecl = + match constr with + | With_typesubst sdecl -> sdecl + | _ -> assert false + in + match type_decl_is_alias sdecl with + | Some lid -> + let replacement, _ = + try Env.find_type_by_name lid.txt initial_env + with Not_found -> assert false + in + fun s path -> Subst.add_type_path path replacement s + | None -> + let body = Option.get tdecl.typ_type.type_manifest in + let params = tdecl.typ_type.type_params in + if params_are_constrained params + then raise(Error(loc, initial_env, + With_cannot_remove_constrained_type)); + fun s path -> Subst.add_type_function path ~params ~body s + in + let sub = Subst.change_locs Subst.identity loc in + let sub = List.fold_left how_to_extend_subst sub !real_ids in + (* This signature will not be used directly, it will always be freshened + by the caller. So what we do with the scope doesn't really matter. But + making it local makes it unlikely that we will ever use the result of + this function unfreshened without issue. *) + Subst.signature Make_local sub sg + | (_, _, Twith_modsubst (real_path, _)) -> + let sub = Subst.change_locs Subst.identity loc in + let sub = + List.fold_left + (fun s path -> Subst.add_module_path path real_path s) + sub + !real_ids + in + (* See explanation in the [Twith_typesubst] case above. *) + Subst.signature Make_local sub sg + | (_, _, Twith_modtypesubst tmty) -> + let add s p = Subst.add_modtype_path p tmty.mty_type s in + let sub = Subst.change_locs Subst.identity loc in + let sub = List.fold_left add sub !real_ids in + Subst.signature Make_local sub sg + | _ -> + sg + in + check_well_formed_module initial_env loc "this instantiated signature" + (Mty_signature sg); + (tcstr, sg) + with Includemod.Error explanation -> + raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation))) + +(* Add recursion flags on declarations arising from a mutually recursive + block. *) + +let map_rec fn decls rem = + match decls with + | [] -> rem + | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem + +let map_rec_type ~rec_flag fn decls rem = + match decls with + | [] -> rem + | d1 :: dl -> + let first = + match rec_flag with + | Recursive -> Trec_first + | Nonrecursive -> Trec_not + in + fn first d1 :: map_end (fn Trec_next) dl rem + +let rec map_rec_type_with_row_types ~rec_flag fn decls rem = + match decls with + | [] -> rem + | d1 :: dl -> + if Btype.is_row_name (Ident.name d1.typ_id) then + fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem + else + map_rec_type ~rec_flag fn decls rem + +(* Add type extension flags to extension constructors *) +let map_ext fn exts rem = + match exts with + | [] -> rem + | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_next) dl rem + +(* Auxiliary for translating recursively-defined module types. + Return a module type that approximates the shape of the given module + type AST. Retain only module, type, and module type + components of signatures. For types, retain only their arity, + making them abstract otherwise. *) + +let rec approx_modtype env smty = + match smty.pmty_desc with + Pmty_ident lid -> + let path = + Env.lookup_modtype_path ~use:false ~loc:smty.pmty_loc lid.txt env + in + Mty_ident path + | Pmty_alias lid -> + let path = + Env.lookup_module_path ~use:false ~load:false + ~loc:smty.pmty_loc lid.txt env + in + Mty_alias(path) + | Pmty_signature ssg -> + Mty_signature(approx_sig env ssg) + | Pmty_functor(param, sres) -> + let (param, newenv) = + match param with + | Unit -> Types.Unit, env + | Named (param, sarg) -> + let arg = approx_modtype env sarg in + match param.txt with + | None -> Types.Named (None, arg), env + | Some name -> + let rarg = Mtype.scrape_for_functor_arg env arg in + let scope = Ctype.create_scope () in + let (id, newenv) = + Env.enter_module ~scope ~arg:true name Mp_present rarg env + in + Types.Named (Some id, arg), newenv + in + let res = approx_modtype newenv sres in + Mty_functor(param, res) + | Pmty_with(sbody, constraints) -> + let body = approx_modtype env sbody in + List.iter + (fun sdecl -> + match sdecl with + | Pwith_type _ + | Pwith_typesubst _ + | Pwith_modtype _ + | Pwith_modtypesubst _ -> () + | Pwith_module (_, lid') -> + (* Lookup the module to make sure that it is not recursive. + (GPR#1626) *) + ignore (Env.lookup_module_path ~use:false ~load:false + ~loc:lid'.loc lid'.txt env) + | Pwith_modsubst (_, lid') -> + ignore (Env.lookup_module_path ~use:false ~load:false + ~loc:lid'.loc lid'.txt env)) + constraints; + body + | Pmty_typeof smod -> + let (_, mty) = !type_module_type_of_fwd env smod in + mty + | Pmty_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and approx_module_declaration env pmd = + { + Types.md_type = approx_modtype env pmd.pmd_type; + md_attributes = pmd.pmd_attributes; + md_loc = pmd.pmd_loc; + md_uid = Uid.internal_not_actually_unique; + } + +and approx_sig env ssg = + match ssg with + [] -> [] + | item :: srem -> + match item.psig_desc with + | Psig_type (rec_flag, sdecls) -> + let decls = Typedecl.approx_type_decl sdecls in + let rem = approx_sig env srem in + map_rec_type ~rec_flag + (fun rs (id, info) -> Sig_type(id, info, rs, Exported)) decls rem + | Psig_typesubst _ -> approx_sig env srem + | Psig_module { pmd_name = { txt = None; _ }; _ } -> + approx_sig env srem + | Psig_module pmd -> + let scope = Ctype.create_scope () in + let md = approx_module_declaration env pmd in + let pres = + match md.Types.md_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let id, newenv = + Env.enter_module_declaration ~scope (Option.get pmd.pmd_name.txt) + pres md env + in + Sig_module(id, pres, md, Trec_not, Exported) :: approx_sig newenv srem + | Psig_modsubst pms -> + let scope = Ctype.create_scope () in + let _, md = + Env.lookup_module ~use:false ~loc:pms.pms_manifest.loc + pms.pms_manifest.txt env + in + let pres = + match md.Types.md_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let _, newenv = + Env.enter_module_declaration ~scope pms.pms_name.txt pres md env + in + approx_sig newenv srem + | Psig_recmodule sdecls -> + let scope = Ctype.create_scope () in + let decls = + List.filter_map + (fun pmd -> + Option.map (fun name -> + Ident.create_scoped ~scope name, + approx_module_declaration env pmd + ) pmd.pmd_name.txt + ) + sdecls + in + let newenv = + List.fold_left + (fun env (id, md) -> Env.add_module_declaration ~check:false + id Mp_present md env) + env decls + in + map_rec + (fun rs (id, md) -> Sig_module(id, Mp_present, md, rs, Exported)) + decls + (approx_sig newenv srem) + | Psig_modtype d -> + let info = approx_modtype_info env d in + let scope = Ctype.create_scope () in + let (id, newenv) = + Env.enter_modtype ~scope d.pmtd_name.txt info env + in + Sig_modtype(id, info, Exported) :: approx_sig newenv srem + | Psig_modtypesubst d -> + let info = approx_modtype_info env d in + let scope = Ctype.create_scope () in + let (_id, newenv) = + Env.enter_modtype ~scope d.pmtd_name.txt info env + in + approx_sig newenv srem + | Psig_open sod -> + let _, env = type_open_descr env sod in + approx_sig env srem + | Psig_include sincl -> + let smty = sincl.pincl_mod in + let mty = approx_modtype env smty in + let scope = Ctype.create_scope () in + let sg, newenv = Env.enter_signature ~scope + (extract_sig env smty.pmty_loc mty) env in + sg @ approx_sig newenv srem + | Psig_class sdecls | Psig_class_type sdecls -> + let decls, env = Typeclass.approx_class_declarations env sdecls in + let rem = approx_sig env srem in + map_rec (fun rs decl -> + let open Typeclass in [ + Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs, + Exported); + Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported); + ] + ) decls [rem] + |> List.flatten + | _ -> + approx_sig env srem + +and approx_modtype_info env sinfo = + { + mtd_type = Option.map (approx_modtype env) sinfo.pmtd_type; + mtd_attributes = sinfo.pmtd_attributes; + mtd_loc = sinfo.pmtd_loc; + mtd_uid = Uid.internal_not_actually_unique; + } + +let approx_modtype env smty = + Warnings.without_warnings + (fun () -> approx_modtype env smty) + +(* Auxiliaries for checking the validity of name shadowing in signatures and + structures. + If a shadowing is valid, we also record some information (its ident, + location where it first appears, etc) about the item that gets shadowed. *) +module Signature_names : sig + type t + + type shadowable = + { + self: Ident.t; + group: Ident.t list; + (** group includes the element itself and all elements + that should be removed at the same time + *) + loc:Location.t; + } + + type info = [ + | `Exported + | `From_open + | `Shadowable of shadowable + | `Substituted_away of Subst.t + | `Unpackable_modtype_substituted_away of Ident.t * Subst.t + ] + + val create : unit -> t + + val check_value : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_type : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_typext : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_module : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_modtype : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_class : ?info:info -> t -> Location.t -> Ident.t -> unit + val check_class_type: ?info:info -> t -> Location.t -> Ident.t -> unit + + val check_sig_item: + ?info:info -> t -> Location.t -> Signature_group.rec_group -> unit + + val simplify: Env.t -> t -> Types.signature -> Types.signature +end = struct + + type shadowable = + { + self: Ident.t; + group: Ident.t list; + (** group includes the element itself and all elements + that should be removed at the same time + *) + loc:Location.t; + } + + type bound_info = [ + | `Exported + | `Shadowable of shadowable + ] + + type info = [ + | `From_open + | `Substituted_away of Subst.t + | `Unpackable_modtype_substituted_away of Ident.t * Subst.t + | bound_info + ] + + type hide_reason = + | From_open + | Shadowed_by of Ident.t * Location.t + + type to_be_removed = { + mutable subst: Subst.t; + mutable hide: (Sig_component_kind.t * Location.t * hide_reason) Ident.Map.t; + mutable unpackable_modtypes: Ident.Set.t; + } + + type names_infos = (string, bound_info) Hashtbl.t + + type names = { + values: names_infos; + types: names_infos; + modules: names_infos; + modtypes: names_infos; + typexts: names_infos; + classes: names_infos; + class_types: names_infos; + } + + let new_names () = { + values = Hashtbl.create 16; + types = Hashtbl.create 16; + modules = Hashtbl.create 16; + modtypes = Hashtbl.create 16; + typexts = Hashtbl.create 16; + classes = Hashtbl.create 16; + class_types = Hashtbl.create 16; + } + + type t = { + bound: names; + to_be_removed: to_be_removed; + } + + let create () = { + bound = new_names (); + to_be_removed = { + subst = Subst.identity; + hide = Ident.Map.empty; + unpackable_modtypes = Ident.Set.empty; + }; + } + + let table_for component names = + let open Sig_component_kind in + match component with + | Value -> names.values + | Type -> names.types + | Module -> names.modules + | Module_type -> names.modtypes + | Extension_constructor -> names.typexts + | Class -> names.classes + | Class_type -> names.class_types + + let check cl t loc id (info : info) = + let to_be_removed = t.to_be_removed in + match info with + | `Substituted_away s -> + to_be_removed.subst <- Subst.compose s to_be_removed.subst; + | `Unpackable_modtype_substituted_away (id,s) -> + to_be_removed.subst <- Subst.compose s to_be_removed.subst; + to_be_removed.unpackable_modtypes <- + Ident.Set.add id to_be_removed.unpackable_modtypes + | `From_open -> + to_be_removed.hide <- + Ident.Map.add id (cl, loc, From_open) to_be_removed.hide + | #bound_info as bound_info -> + let tbl = table_for cl t.bound in + let name = Ident.name id in + match Hashtbl.find_opt tbl name with + | None -> Hashtbl.add tbl name bound_info + | Some (`Shadowable s) -> + Hashtbl.replace tbl name bound_info; + let reason = Shadowed_by (id, loc) in + List.iter (fun shadowed_id -> + to_be_removed.hide <- + Ident.Map.add shadowed_id (cl, s.loc, reason) + to_be_removed.hide + ) s.group + | Some `Exported -> + raise(Error(loc, Env.empty, Repeated_name(cl, name))) + + let check_value ?info t loc id = + let info = + match info with + | Some i -> i + | None -> `Shadowable {self=id; group=[id]; loc} + in + check Sig_component_kind.Value t loc id info + let check_type ?(info=`Exported) t loc id = + check Sig_component_kind.Type t loc id info + let check_module ?(info=`Exported) t loc id = + check Sig_component_kind.Module t loc id info + let check_modtype ?(info=`Exported) t loc id = + check Sig_component_kind.Module_type t loc id info + let check_typext ?(info=`Exported) t loc id = + check Sig_component_kind.Extension_constructor t loc id info + let check_class ?(info=`Exported) t loc id = + check Sig_component_kind.Class t loc id info + let check_class_type ?(info=`Exported) t loc id = + check Sig_component_kind.Class_type t loc id info + + let classify = + let open Sig_component_kind in + function + | Sig_type(id, _, _, _) -> Type, id + | Sig_module(id, _, _, _, _) -> Module, id + | Sig_modtype(id, _, _) -> Module_type, id + | Sig_typext(id, _, _, _) -> Extension_constructor, id + | Sig_value (id, _, _) -> Value, id + | Sig_class (id, _, _, _) -> Class, id + | Sig_class_type (id, _, _, _) -> Class_type, id + + let check_item ?info names loc kind id ids = + let info = + match info with + | None -> `Shadowable {self=id; group=ids; loc} + | Some i -> i + in + check kind names loc id info + + let check_sig_item ?info names loc (item:Signature_group.rec_group) = + let check ?info names loc item = + let all = List.map classify (Signature_group.flatten item) in + let group = List.map snd all in + List.iter (fun (kind,id) -> check_item ?info names loc kind id group) + all + in + (* we can ignore x.pre_ghosts: they are eliminated by strengthening, and + thus never appear in includes *) + List.iter (check ?info names loc) (Signature_group.rec_items item.group) + + (* + Before applying local module type substitutions where the + right-hand side is not a path, we need to check that those module types + where never used to pack modules. For instance + {[ + module type T := sig end + val x: (module T) + ]} + should raise an error. + *) + let check_unpackable_modtypes ~loc ~env to_remove component = + if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then begin + let iterator = + let error p = Unpackable_local_modtype_subst p in + let paths = + List.map (fun id -> Pident id) + (Ident.Set.elements to_remove.unpackable_modtypes) + in + check_usage_of_module_types ~loc ~error ~paths + (ref (lazy env)) Btype.type_iterators + in + iterator.Btype.it_signature_item iterator component; + Btype.(unmark_iterators.it_signature_item unmark_iterators) component + end + + (* We usually require name uniqueness of signature components (e.g. types, + modules, etc), however in some situation reusing the name is allowed: if + the component is a value or an extension, or if the name is introduced by + an include. + When there are multiple specifications of a component with the same name, + we try to keep only the last (rightmost) one, removing all references to + the previous ones from the signature. + If some reference cannot be removed, then we error out with + [Cannot_hide_id]. + *) + + let simplify env t sg = + let to_remove = t.to_be_removed in + let ids_to_remove = + Ident.Map.fold (fun id (kind, _, _) lst -> + if Sig_component_kind.can_appear_in_types kind then + id :: lst + else + lst + ) to_remove.hide [] + in + let simplify_item (component: Types.signature_item) = + let user_kind, user_id, user_loc = + let open Sig_component_kind in + match component with + | Sig_value(id, v, _) -> Value, id, v.val_loc + | Sig_type (id, td, _, _) -> Type, id, td.type_loc + | Sig_typext (id, te, _, _) -> Extension_constructor, id, te.ext_loc + | Sig_module (id, _, md, _, _) -> Module, id, md.md_loc + | Sig_modtype (id, mtd, _) -> Module_type, id, mtd.mtd_loc + | Sig_class (id, c, _, _) -> Class, id, c.cty_loc + | Sig_class_type (id, ct, _, _) -> Class_type, id, ct.clty_loc + in + if Ident.Map.mem user_id to_remove.hide then + None + else begin + let component = + if to_remove.subst == Subst.identity then + component + else + begin + check_unpackable_modtypes ~loc:user_loc ~env to_remove component; + Subst.signature_item Keep to_remove.subst component + end + in + let component = + match ids_to_remove with + | [] -> component + | ids -> + try Mtype.nondep_sig_item env ids component with + | Ctype.Nondep_cannot_erase removed_item_id -> + let (removed_item_kind, removed_item_loc, reason) = + Ident.Map.find removed_item_id to_remove.hide + in + let err_loc, hiding_error = + match reason with + | From_open -> + removed_item_loc, + Appears_in_signature { + opened_item_kind = removed_item_kind; + opened_item_id = removed_item_id; + user_id; + user_kind; + user_loc; + } + | Shadowed_by (shadower_id, shadower_loc) -> + shadower_loc, + Illegal_shadowing { + shadowed_item_kind = removed_item_kind; + shadowed_item_id = removed_item_id; + shadowed_item_loc = removed_item_loc; + shadower_id; + user_id; + user_kind; + user_loc; + } + in + raise (Error(err_loc, env, Cannot_hide_id hiding_error)) + in + Some component + end + in + List.filter_map simplify_item sg +end + +let has_remove_aliases_attribute attr = + let remove_aliases = + Attr_helper.get_no_payload_attribute + ["remove_aliases"; "ocaml.remove_aliases"] attr + in + match remove_aliases with + | None -> false + | Some _ -> true + +(* Check and translate a module type expression *) + +let transl_modtype_longident loc env lid = + Env.lookup_modtype_path ~loc lid env + +let transl_module_alias loc env lid = + Env.lookup_module_path ~load:false ~loc lid env + +let mkmty desc typ env loc attrs = + let mty = { + mty_desc = desc; + mty_type = typ; + mty_loc = loc; + mty_env = env; + mty_attributes = attrs; + } in + Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); + mty + +let mksig desc env loc = + let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in + Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); + sg + +(* let signature sg = List.map (fun item -> item.sig_type) sg *) + +let rec transl_modtype env smty = + Builtin_attributes.warning_scope smty.pmty_attributes + (fun () -> transl_modtype_aux env smty) + +and transl_modtype_functor_arg env sarg = + let mty = transl_modtype env sarg in + {mty with mty_type = Mtype.scrape_for_functor_arg env mty.mty_type} + +and transl_modtype_aux env smty = + let loc = smty.pmty_loc in + match smty.pmty_desc with + Pmty_ident lid -> + let path = transl_modtype_longident loc env lid.txt in + mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc + smty.pmty_attributes + | Pmty_alias lid -> + let path = transl_module_alias loc env lid.txt in + mkmty (Tmty_alias (path, lid)) (Mty_alias path) env loc + smty.pmty_attributes + | Pmty_signature ssg -> + let sg = transl_signature env ssg in + mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc + smty.pmty_attributes + | Pmty_functor(sarg_opt, sres) -> + let t_arg, ty_arg, newenv = + match sarg_opt with + | Unit -> Unit, Types.Unit, env + | Named (param, sarg) -> + let arg = transl_modtype_functor_arg env sarg in + let (id, newenv) = + match param.txt with + | None -> None, env + | Some name -> + let scope = Ctype.create_scope () in + let id, newenv = + let arg_md = + { md_type = arg.mty_type; + md_attributes = []; + md_loc = param.loc; + md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + in + Env.enter_module_declaration ~scope ~arg:true name Mp_present + arg_md env + in + Some id, newenv + in + Named (id, param, arg), Types.Named (id, arg.mty_type), newenv + in + let res = transl_modtype newenv sres in + mkmty (Tmty_functor (t_arg, res)) + (Mty_functor(ty_arg, res.mty_type)) env loc + smty.pmty_attributes + | Pmty_with(sbody, constraints) -> + let body = transl_modtype env sbody in + let init_sg = extract_sig env sbody.pmty_loc body.mty_type in + let remove_aliases = has_remove_aliases_attribute smty.pmty_attributes in + let (rev_tcstrs, final_sg) = + List.fold_left (transl_with ~loc:smty.pmty_loc env remove_aliases) + ([],init_sg) constraints in + let scope = Ctype.create_scope () in + mkmty (Tmty_with ( body, List.rev rev_tcstrs)) + (Mtype.freshen ~scope (Mty_signature final_sg)) env loc + smty.pmty_attributes + | Pmty_typeof smod -> + let env = Env.in_signature false env in + let tmty, mty = !type_module_type_of_fwd env smod in + mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes + | Pmty_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and transl_with ~loc env remove_aliases (rev_tcstrs,sg) constr = + let lid, with_info = match constr with + | Pwith_type (l,decl) ->l , With_type decl + | Pwith_typesubst (l,decl) ->l , With_typesubst decl + | Pwith_module (l,l') -> + let path, md = Env.lookup_module ~loc l'.txt env in + l , With_module {lid=l';path;md; remove_aliases} + | Pwith_modsubst (l,l') -> + let path, md' = Env.lookup_module ~loc l'.txt env in + l , With_modsubst (l',path,md') + | Pwith_modtype (l,smty) -> + let mty = transl_modtype env smty in + l, With_modtype mty + | Pwith_modtypesubst (l,smty) -> + let mty = transl_modtype env smty in + l, With_modtypesubst mty + in + let (tcstr, sg) = merge_constraint env loc sg lid with_info in + (tcstr :: rev_tcstrs, sg) + + + +and transl_signature ?(keep_warnings = false) env sg = + let names = Signature_names.create () in + let rec transl_sig env sg = + match sg with + [] -> [], [], env + | item :: srem -> + let loc = item.psig_loc in + match item.psig_desc with + | Psig_value sdesc -> + begin match + let (tdesc, _) as res = + Typedecl.transl_value_decl env item.psig_loc sdesc + in + Signature_names.check_value names tdesc.val_loc tdesc.val_id; + Env.register_uid tdesc.val_val.val_uid tdesc.val_loc; + res + with + | (tdesc, newenv) -> + let (trem,rem, final_env) = transl_sig newenv srem in + mksig (Tsig_value tdesc) env loc :: trem, + Sig_value(tdesc.val_id, tdesc.val_val, Exported) :: rem, + final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_type (rec_flag, sdecls) -> + begin match + let (decls, _) as res = + Typedecl.transl_type_decl env rec_flag sdecls + in + List.iter (fun td -> + Signature_names.check_type names td.typ_loc td.typ_id; + if not (Btype.is_row_name (Ident.name td.typ_id)) then + Env.register_uid td.typ_type.type_uid td.typ_loc + ) decls; + res + with + | (decls, newenv) -> + let newenv = Env.update_short_paths newenv in + let (trem, rem, final_env) = transl_sig newenv srem in + let sg = + map_rec_type_with_row_types ~rec_flag + (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs, Exported)) + decls rem + in + mksig (Tsig_type (rec_flag, decls)) env loc :: trem, + sg, + final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_typesubst sdecls -> + begin match + List.iter (fun td -> + if td.ptype_kind <> Ptype_abstract || td.ptype_manifest = None || + td.ptype_private = Private + then + (* This error should be a parsing error, + once we have nice error messages there. *) + raise (Error (td.ptype_loc, env, Invalid_type_subst_rhs)) + ) sdecls; + let (decls, _) as res = + Typedecl.transl_type_decl env Nonrecursive sdecls + in + List.iter (fun td -> + let params = td.typ_type.type_params in + if params_are_constrained params + then raise(Error(loc, env, With_cannot_remove_constrained_type)); + let info = + let subst = + Subst.add_type_function (Pident td.typ_id) + ~params + ~body:(Option.get td.typ_type.type_manifest) + Subst.identity + in + Some (`Substituted_away subst) + in + Signature_names.check_type ?info names td.typ_loc td.typ_id; + Env.register_uid td.typ_type.type_uid td.typ_loc + ) decls; + res + with + | (decls, newenv) -> + let (trem, rem, final_env) = transl_sig newenv srem in + let sg = rem + in + mksig (Tsig_typesubst decls) env loc :: trem, + sg, + final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_typext styext -> + begin match + let (tyext, _) as res = + Typedecl.transl_type_extension false env item.psig_loc styext + in + let constructors = tyext.tyext_constructors in + List.iter (fun ext -> + Signature_names.check_typext names ext.ext_loc ext.ext_id; + Env.register_uid ext.ext_type.ext_uid ext.ext_loc + ) constructors; + res, constructors + with + | (tyext, newenv), constructors -> + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_typext tyext) env loc :: trem, + map_ext (fun es ext -> + Sig_typext(ext.ext_id, ext.ext_type, es, Exported) + ) constructors rem, + final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_exception sext -> + begin match + let (ext, _) as res = Typedecl.transl_type_exception env sext in + let constructor = ext.tyexn_constructor in + Signature_names.check_typext names constructor.ext_loc + constructor.ext_id; + Env.register_uid + constructor.ext_type.ext_uid + constructor.ext_loc; + res, constructor + with + | (ext, newenv), constructor -> + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_exception ext) env loc :: trem, + Sig_typext(constructor.ext_id, + constructor.ext_type, + Text_exception, + Exported) :: rem, + final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_module pmd -> + let scope = Ctype.create_scope () in + begin match + let tmty = + Builtin_attributes.warning_scope pmd.pmd_attributes + (fun () -> transl_modtype env pmd.pmd_type) + in + let pres = + match tmty.mty_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + match pmd.pmd_name.txt with + | None -> None, pres, env, None, tmty + | Some name -> + let md = { + md_type=tmty.mty_type; + md_attributes=pmd.pmd_attributes; + md_loc=pmd.pmd_loc; + md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + in + let id, newenv = + Env.enter_module_declaration ~scope name pres md env + in + let newenv = Env.update_short_paths newenv in + Signature_names.check_module names pmd.pmd_name.loc id; + Env.register_uid md.md_uid md.md_loc; + let sig_item = Sig_module(id, pres, md, Trec_not, Exported) in + Some id, pres, newenv, Some sig_item, tmty + with + | (id, pres, newenv, sig_item, tmty) -> + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; + md_presence=pres; md_type=tmty; + md_loc=pmd.pmd_loc; + md_attributes=pmd.pmd_attributes}) + env loc :: trem, + (match sig_item with None -> rem | Some i -> i :: rem), + final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_modsubst pms -> + let scope = Ctype.create_scope () in + begin match + let path, md = + Env.lookup_module ~loc:pms.pms_manifest.loc + pms.pms_manifest.txt env + in + let aliasable = not (Env.is_functor_arg path env) in + let md = + if not aliasable then + md + else + { md_type = Mty_alias path; + md_attributes = pms.pms_attributes; + md_loc = pms.pms_loc; + md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + in + let pres = + match md.md_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let id, newenv = + Env.enter_module_declaration ~scope pms.pms_name.txt pres md env + in + let info = + `Substituted_away (Subst.add_module id path Subst.identity) + in + Signature_names.check_module ~info names pms.pms_name.loc id; + Env.register_uid md.md_uid md.md_loc; + (newenv, Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; + ms_manifest=path; ms_txt=pms.pms_manifest; + ms_loc=pms.pms_loc; + ms_attributes=pms.pms_attributes}) + with + | newenv, sig_item -> + let (trem, rem, final_env) = transl_sig newenv srem in + (mksig sig_item env loc :: trem, rem, final_env) + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_recmodule sdecls -> + begin match + let (tdecls, newenv) = + transl_recmodule_modtypes env sdecls in + let decls = + List.filter_map (fun (md, uid, _) -> + match md.md_id with + | None -> None + | Some id -> Some (id, md, uid) + ) tdecls + in + List.iter (fun (id, md, uid) -> + Signature_names.check_module names md.md_loc id; + Env.register_uid uid md.md_loc + ) decls; + (tdecls, decls, newenv) + with + | (tdecls, decls, newenv) -> + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_recmodule (List.map (fun (md, _, _) -> md) tdecls)) + env loc :: trem, + map_rec (fun rs (id, md, uid) -> + let d = {Types.md_type = md.md_type.mty_type; + md_attributes = md.md_attributes; + md_loc = md.md_loc; + md_uid = uid; + } in + Sig_module(id, Mp_present, d, rs, Exported)) + decls rem, + final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_modtype pmtd -> + begin match transl_modtype_decl env pmtd with + | newenv, mtd, decl -> + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + Env.register_uid decl.mtd_uid mtd.mtd_loc; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_modtype mtd) env loc :: trem, + Sig_modtype (mtd.mtd_id, decl, Exported) :: rem, + final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_modtypesubst pmtd -> + begin match transl_modtype_decl env pmtd with + | newenv, mtd, decl -> + let info = + let mty = match mtd.mtd_type with + | Some tmty -> tmty.mty_type + | None -> + (* parsetree invariant, see Ast_invariants *) + assert false + in + let subst = Subst.add_modtype mtd.mtd_id mty Subst.identity in + match mty with + | Mty_ident _ -> `Substituted_away subst + | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst) + in + Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id; + Env.register_uid decl.mtd_uid mtd.mtd_loc; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_modtypesubst mtd) env loc :: trem, + rem, + final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_open sod -> + begin match type_open_descr env sod with + | (od, newenv) -> + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_open od) env loc :: trem, + rem, final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_include sincl -> + begin match + let smty = sincl.pincl_mod in + let tmty = + Builtin_attributes.warning_scope sincl.pincl_attributes + (fun () -> transl_modtype env smty) + in + let mty = tmty.mty_type in + let scope = Ctype.create_scope () in + let sg, newenv = Env.enter_signature ~scope + (extract_sig env smty.pmty_loc mty) env in + Signature_group.iter + (Signature_names.check_sig_item names item.psig_loc) + sg; + let incl = + { incl_mod = tmty; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + incl, sg, newenv + with + | incl, sg, newenv -> + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_include incl) env loc :: trem, + sg @ rem, + final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_class cl -> + begin match + let (classes, _) as res = Typeclass.class_descriptions env cl in + List.iter (fun cls -> + let open Typeclass in + let loc = cls.cls_id_loc.Location.loc in + Signature_names.check_type names loc cls.cls_obj_id; + Signature_names.check_class names loc cls.cls_id; + Signature_names.check_class_type names loc cls.cls_ty_id; + Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc; + ) classes; + res + with + | (classes, newenv) -> + let (trem, rem, final_env) = transl_sig newenv srem in + let sg = + map_rec (fun rs cls -> + let open Typeclass in + [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported); + Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported); + Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported) + ] + ) classes [rem] + |> List.flatten + in + let typedtree = + mksig (Tsig_class + (List.map (fun decr -> + decr.Typeclass.cls_info) classes)) env loc + :: trem + in + typedtree, sg, final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_class_type cl -> + begin match + let (classes, _) as res = Typeclass.class_type_declarations env cl in + List.iter (fun decl -> + let open Typeclass in + let loc = decl.clsty_id_loc.Location.loc in + Signature_names.check_class_type names loc decl.clsty_ty_id; + Signature_names.check_type names loc decl.clsty_obj_id; + Env.register_uid + decl.clsty_ty_decl.clty_uid + decl.clsty_ty_decl.clty_loc; + ) classes; + res + with + | (classes, newenv) -> + let (trem,rem, final_env) = transl_sig newenv srem in + let sg = + map_rec (fun rs decl -> + let open Typeclass in + [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs, + Exported); + Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported); + ] + ) classes [rem] + |> List.flatten + in + let typedtree = + mksig + (Tsig_class_type + (List.map (fun decl -> decl.Typeclass.clsty_info) classes)) + env loc + :: trem + in + typedtree, sg, final_env + | exception exn -> + Msupport.raise_error exn; + transl_sig env srem + end + | Psig_attribute x -> + Builtin_attributes.warning_attribute x; + let (trem,rem, final_env) = transl_sig env srem in + mksig (Tsig_attribute x) env loc :: trem, rem, final_env + | Psig_extension (ext, _attrs) -> + Msupport.raise_error + (Error_forward (Builtin_attributes.error_of_extension ext)); + transl_sig env srem + in + Msupport.with_saved_types + ?warning_attribute:(if keep_warnings then None else Some []) + ~save_part:(fun sg -> Cmt_format.Partial_signature sg) + (fun () -> + let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in + let rem = Signature_names.simplify final_env names rem in + { sig_items = trem; sig_type = rem; sig_final_env = final_env }) + +and transl_modtype_decl env pmtd = + Builtin_attributes.warning_scope pmtd.pmtd_attributes + (fun () -> transl_modtype_decl_aux env pmtd) + +and transl_modtype_decl_aux env + {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = + let tmty = + Option.map (transl_modtype (Env.in_signature true env)) pmtd_type + in + let decl = + { + Types.mtd_type=Option.map (fun t -> t.mty_type) tmty; + mtd_attributes=pmtd_attributes; + mtd_loc=pmtd_loc; + mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + in + let scope = Ctype.create_scope () in + let (id, newenv) = Env.enter_modtype ~scope pmtd_name.txt decl env in + let mtd = + { + mtd_id=id; + mtd_name=pmtd_name; + mtd_type=tmty; + mtd_attributes=pmtd_attributes; + mtd_loc=pmtd_loc; + } + in + newenv, mtd, decl + +and transl_recmodule_modtypes env sdecls = + let make_env curr = + List.fold_left (fun env (id_shape, _, md, _) -> + Option.fold ~none:env ~some:(fun (id, shape) -> + Env.add_module_declaration ~check:true ~shape ~arg:true + id Mp_present md env + ) id_shape + ) env curr + in + let transition env_c curr = + List.map2 + (fun pmd (id_shape, id_loc, md, _) -> + let tmty = + Builtin_attributes.warning_scope pmd.pmd_attributes + (fun () -> transl_modtype env_c pmd.pmd_type) + in + let md = { md with Types.md_type = tmty.mty_type } in + (id_shape, id_loc, md, tmty)) + sdecls curr in + let map_mtys curr = + List.filter_map + (fun (id_shape, _, md, _) -> + Option.map (fun (id, _) -> (id, md)) id_shape) + curr + in + let scope = Ctype.create_scope () in + let ids = + List.map (fun x -> Option.map (Ident.create_scoped ~scope) x.pmd_name.txt) + sdecls + in + let approx_env = + List.fold_left + (fun env -> + Option.fold ~none:env ~some:(fun id -> (* cf #5965 *) + Env.enter_unbound_module (Ident.name id) + Mod_unbound_illegal_recursion env + )) + env ids + in + let init = + List.map2 + (fun id pmd -> + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let md = + { md_type = approx_modtype approx_env pmd.pmd_type; + md_loc = pmd.pmd_loc; + md_attributes = pmd.pmd_attributes; + md_uid } + in + let id_shape = + Option.map (fun id -> id, Shape.var md_uid id) id + in + (id_shape, pmd.pmd_name, md, ())) + ids sdecls + in + let env0 = make_env init in + let dcl1 = + Warnings.without_warnings + (fun () -> transition env0 init) + in + let env1 = make_env dcl1 in + check_recmod_typedecls env1 (map_mtys dcl1); + let dcl2 = transition env1 dcl1 in +(* + List.iter + (fun (id, mty) -> + Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty) + dcl2; +*) + let env2 = make_env dcl2 in + check_recmod_typedecls env2 (map_mtys dcl2); + let dcl2 = + List.map2 (fun pmd (id_shape, id_loc, md, mty) -> + let tmd = + {md_id=Option.map fst id_shape; md_name=id_loc; md_type=mty; + md_presence=Mp_present; + md_loc=pmd.pmd_loc; + md_attributes=pmd.pmd_attributes} + in + tmd, md.md_uid, Option.map snd id_shape + ) sdecls dcl2 + in + (dcl2, env2) + +(* Try to convert a module expression to a module path. *) + +exception Not_a_path + +let rec path_of_module mexp = + match mexp.mod_desc with + | Tmod_ident (p,_) -> p + | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors -> + Papply(path_of_module funct, path_of_module arg) + | Tmod_constraint (mexp, _, _, _) -> + path_of_module mexp + | (Tmod_structure _ | Tmod_functor _ | Tmod_apply_unit _ | Tmod_unpack _ | + Tmod_apply _ | Tmod_hole) -> + raise Not_a_path + +let path_of_module mexp = + try Some (path_of_module mexp) with Not_a_path -> None + +(* Check that all core type schemes in a structure + do not contain non-generalized type variable *) + +let rec nongen_modtype env = function + Mty_ident _ -> None + | Mty_alias _ -> None + | Mty_for_hole -> None + | Mty_signature sg -> + let env = Env.add_signature sg env in + List.find_map (nongen_signature_item env) sg + | Mty_functor(arg_opt, body) -> + let env = + match arg_opt with + | Unit + | Named (None, _) -> env + | Named (Some id, param) -> + Env.add_module ~arg:true id Mp_present param env + in + nongen_modtype env body + +and nongen_signature_item env = function + | Sig_value(_id, desc, _) -> + Ctype.nongen_vars_in_schema env desc.val_type + |> Option.map (fun vars -> (vars, desc)) + | Sig_module(_id, _, md, _, _) -> nongen_modtype env md.md_type + | _ -> None + +let check_nongen_modtype env loc mty = + nongen_modtype env mty + |> Option.iter (fun (vars, item) -> + let vars = Btype.TypeSet.elements vars in + let error = + Non_generalizable_module { vars; item; mty } + in + raise(Error(loc, env, error)) + ) + +let check_nongen_signature_item env sig_item = + match sig_item with + Sig_value(_id, vd, _) -> + Ctype.nongen_vars_in_schema env vd.val_type + |> Option.iter (fun vars -> + let vars = Btype.TypeSet.elements vars in + let error = + Non_generalizable { vars; expression = vd.val_type } + in + raise (Error (vd.val_loc, env, error)) + ) + | Sig_module (_id, _, md, _, _) -> + check_nongen_modtype env md.md_loc md.md_type + | _ -> () + +let check_nongen_signature env sg = + List.iter (check_nongen_signature_item env) sg + +(* Helpers for typing recursive modules *) + +let anchor_submodule name anchor = + match anchor, name with + | None, _ + | _, None -> + None + | Some p, Some name -> + Some(Pdot(p, name)) + +let anchor_recmodule = Option.map (fun id -> Pident id) + +let enrich_type_decls anchor decls oldenv newenv = + match anchor with + None -> newenv + | Some p -> + List.fold_left + (fun e info -> + let id = info.typ_id in + let info' = + Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id)) + id info.typ_type + in + Env.add_type ~check:true id info' e) + oldenv decls + +let enrich_module_type anchor name mty env = + match anchor, name with + | None, _ + | _, None -> + mty + | Some p, Some name -> + Mtype.enrich_modtype env (Pdot(p, name)) mty + +let check_recmodule_inclusion env bindings = + (* PR#4450, PR#4470: consider + module rec X : DECL = MOD where MOD has inferred type ACTUAL + The "natural" typing condition + E, X: ACTUAL |- ACTUAL <: DECL + leads to circularities through manifest types. + Instead, we "unroll away" the potential circularities a finite number + of times. The (weaker) condition we implement is: + E, X: DECL, + X1: ACTUAL, + X2: ACTUAL{X <- X1}/X1 + ... + Xn: ACTUAL{X <- X(n-1)}/X(n-1) + |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn} + so that manifest types rooted at X(n+1) are expanded in terms of X(n), + avoiding circularities. The strengthenings ensure that + Xn.t = X(n-1).t = ... = X2.t = X1.t. + N can be chosen arbitrarily; larger values of N result in more + recursive definitions being accepted. A good choice appears to be + the number of mutually recursive declarations. *) + + let subst_and_strengthen env scope s id mty = + let mty = Subst.modtype (Rescope scope) s mty in + match id with + | None -> mty + | Some id -> + Mtype.strengthen ~aliasable:false env mty + (Subst.module_path s (Pident id)) + in + + let rec check_incl first_time n env s = + let scope = Ctype.create_scope () in + if n > 0 then begin + (* Generate fresh names Y_i for the rec. bound module idents X_i *) + let bindings1 = + List.map + (fun (id, _name, _mty_decl, _modl, + mty_actual, _attrs, _loc, shape, _uid) -> + let ids = + Option.map + (fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id + in + (ids, mty_actual, shape)) + bindings in + (* Enter the Y_i in the environment with their actual types substituted + by the input substitution s *) + let env' = + List.fold_left + (fun env (ids, mty_actual, shape) -> + match ids with + | None -> env + | Some (id, id') -> + let mty_actual' = + if first_time + then mty_actual + else subst_and_strengthen env scope s (Some id) mty_actual + in + Env.add_module ~arg:false ~shape id' Mp_present mty_actual' env) + env bindings1 in + (* Build the output substitution Y_i <- X_i *) + let s' = + List.fold_left + (fun s (ids, _mty_actual, _shape) -> + match ids with + | None -> s + | Some (id, id') -> Subst.add_module id (Pident id') s) + Subst.identity bindings1 in + (* Recurse with env' and s' *) + check_incl false (n-1) env' s' + end else begin + (* Base case: check inclusion of s(mty_actual) in s(mty_decl) + and insert coercion if needed *) + let check_inclusion + (id, name, mty_decl, modl, mty_actual, attrs, loc, shape, uid) = + let mty_decl' = Subst.modtype (Rescope scope) s mty_decl.mty_type + and mty_actual' = subst_and_strengthen env scope s id mty_actual in + let coercion, shape = + try + Includemod.modtypes_with_shape ~shape + ~loc:modl.mod_loc ~mark:Mark_both + env mty_actual' mty_decl' + with Includemod.Error msg -> + Msupport.raise_error(Error(modl.mod_loc, env, Not_included msg)); + Tcoerce_none, shape + in + let modl' = + { mod_desc = Tmod_constraint(modl, mty_decl.mty_type, + Tmodtype_explicit mty_decl, coercion); + mod_type = mty_decl.mty_type; + mod_env = env; + mod_loc = modl.mod_loc; + mod_attributes = []; + } in + let mb = + { + mb_id = id; + mb_name = name; + mb_presence = Mp_present; + mb_expr = modl'; + mb_attributes = attrs; + mb_loc = loc; + } + in + mb, shape, uid + in + List.map check_inclusion bindings + end + in check_incl true (List.length bindings) env Subst.identity + +(* Helper for unpack *) + +let rec package_constraints_sig env loc sg constrs = + List.map + (function + | Sig_type (id, ({type_params=[]} as td), rs, priv) + when List.mem_assoc [Ident.name id] constrs -> + let ty = List.assoc [Ident.name id] constrs in + Sig_type (id, {td with type_manifest = Some ty}, rs, priv) + | Sig_module (id, pres, md, rs, priv) -> + let rec aux = function + | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> + (l, t) :: aux rest + | _ :: rest -> aux rest + | [] -> [] + in + let md = + {md with + md_type = package_constraints env loc md.md_type (aux constrs) + } + in + Sig_module (id, pres, md, rs, priv) + | item -> item + ) + sg + +and package_constraints env loc mty constrs = + if constrs = [] then mty + else begin + match Mtype.scrape env mty with + | Mty_signature sg -> + Mty_signature (package_constraints_sig env loc sg constrs) + | Mty_functor _ | Mty_alias _ -> assert false + | Mty_for_hole -> Mty_for_hole + | Mty_ident p -> raise(Error(loc, env, Cannot_scrape_package_type p)) + end + +let modtype_of_package env loc p fl = + (* We call Ctype.correct_levels to ensure that the types being added to the + module type are at generic_level. *) + let mty = + package_constraints env loc (Mty_ident p) + (List.map (fun (n, t) -> Longident.flatten n, Ctype.correct_levels t) fl) + in + Subst.modtype Keep Subst.identity mty + +let package_subtype env p1 fl1 p2 fl2 = + let mkmty p fl = + let fl = + List.filter (fun (_n,t) -> Ctype.free_variables t = []) fl in + modtype_of_package env Location.none p fl + in + match mkmty p1 fl1, mkmty p2 fl2 with + | exception Error(_, _, Cannot_scrape_package_type _) -> false + | mty1, mty2 -> + let loc = Location.none in + match Includemod.modtypes ~loc ~mark:Mark_both env mty1 mty2 with + | Tcoerce_none -> true + | _ | exception Includemod.Error _ -> false + +let () = Ctype.package_subtype := package_subtype + +let wrap_constraint_package env mark arg mty explicit = + let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let mty1 = Subst.modtype Keep Subst.identity arg.mod_type in + let mty2 = Subst.modtype Keep Subst.identity mty in + let coercion = + try + Includemod.modtypes ~loc:arg.mod_loc env ~mark mty1 mty2 + with Includemod.Error msg -> + Msupport.raise_error(Error(arg.mod_loc, env, Not_included msg)); + Tcoerce_none + in + { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); + mod_type = mty; + mod_env = env; + mod_attributes = []; + mod_loc = arg.mod_loc } + +let wrap_constraint_with_shape env mark arg mty + shape explicit = + let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let coercion, shape = + try + Includemod.modtypes_with_shape ~shape ~loc:arg.mod_loc env ~mark + arg.mod_type mty + with Includemod.Error msg -> + raise(Error(arg.mod_loc, env, Not_included msg)) in + { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); + mod_type = mty; + mod_env = env; + mod_attributes = []; + mod_loc = arg.mod_loc }, shape + +(* Type a module value expression *) + + +(* These describe the X in [F(X)] (which might be missing, for [F ()]) *) +type argument_summary = { + is_syntactic_unit: bool; + arg: Typedtree.module_expr; + path: Path.t option; + shape: Shape.t +} + +type application_summary = { + loc: Location.t; + attributes: attributes; + f_loc: Location.t; (* loc for F *) + arg: argument_summary option (* None for () *) +} + +let simplify_app_summary app_view = match app_view.arg with + | None -> + Includemod.Error.Unit, Mty_signature [] + | Some arg -> + let mty = arg.arg.mod_type in + match arg.is_syntactic_unit , arg.path with + | true , _ -> Includemod.Error.Empty_struct, mty + | false, Some p -> Includemod.Error.Named p, mty + | false, None -> Includemod.Error.Anonymous, mty + +let rec type_module ?(alias=false) sttn funct_body anchor env smod = + (* Merlin: when we start typing a module we don't want to include potential + saved_items from its parent. We backup them before starting and restore them + when finished. *) + Msupport.with_saved_types @@ fun () -> + try + Builtin_attributes.warning_scope smod.pmod_attributes + (fun () -> type_module_aux ~alias sttn funct_body anchor env smod) + with exn -> + Msupport.raise_error exn; + { mod_desc = Tmod_structure { + str_items = []; + str_type = []; + str_final_env = env; + }; + mod_type = Mty_signature []; + mod_env = env; + mod_attributes = Msupport.flush_saved_types () @ smod.pmod_attributes; + mod_loc = smod.pmod_loc }, + Shape.dummy_mod + +and type_module_aux ~alias sttn funct_body anchor env smod = + match smod.pmod_desc with + Pmod_ident lid -> + let path = + Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env + in + let md = { mod_desc = Tmod_ident (path, lid); + mod_type = Mty_alias path; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc } in + let aliasable = not (Env.is_functor_arg path env) in + let shape = + Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path + in + let md = + if alias && aliasable then + (Env.add_required_global (Path.head path); md) + else begin + let mty = + if sttn then + Env.find_strengthened_module ~aliasable path env + else + (Env.find_module path env).md_type + in + match mty with + | Mty_alias p1 when not alias -> + let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in + let mty = Includemod.expand_module_alias + ~strengthen:sttn env p1 in + { md with + mod_desc = + Tmod_constraint (md, mty, Tmodtype_implicit, + Tcoerce_alias (env, path, Tcoerce_none)); + mod_type = mty } + | mty -> + { md with mod_type = mty } + end + in + md, shape + | Pmod_structure sstr -> + let (str, sg, names, shape, _finalenv) = + type_structure funct_body anchor env sstr in + let md = + { mod_desc = Tmod_structure str; + mod_type = Mty_signature sg; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc } + in + let sg' = Signature_names.simplify _finalenv names sg in + if List.length sg' = List.length sg then md, shape else + wrap_constraint_with_shape env false md + (Mty_signature sg') shape Tmodtype_implicit + | Pmod_functor(arg_opt, sbody) -> + let t_arg, ty_arg, newenv, funct_shape_param, funct_body = + match arg_opt with + | Unit -> + Unit, Types.Unit, env, Shape.for_unnamed_functor_param, false + | Named (param, smty) -> + let mty = transl_modtype_functor_arg env smty in + let scope = Ctype.create_scope () in + let (id, newenv, var) = + match param.txt with + | None -> None, env, Shape.for_unnamed_functor_param + | Some name -> + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let arg_md = + { md_type = mty.mty_type; + md_attributes = []; + md_loc = param.loc; + md_uid; + } + in + let id = Ident.create_scoped ~scope name in + let shape = Shape.var md_uid id in + let newenv = Env.add_module_declaration + ~shape ~arg:true ~check:true id Mp_present arg_md env + in + Some id, newenv, id + in + Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, + var, true + in + let body, body_shape = type_module true funct_body None newenv sbody in + { mod_desc = Tmod_functor(t_arg, body); + mod_type = Mty_functor(ty_arg, body.mod_type); + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc }, + Shape.abs funct_shape_param body_shape + | Pmod_apply _ | Pmod_apply_unit _ -> + type_application smod.pmod_loc sttn funct_body env smod + | Pmod_constraint(sarg, smty) -> + let arg, arg_shape = type_module ~alias true funct_body anchor env sarg in + begin try + let mty = transl_modtype env smty in + let md, final_shape = + wrap_constraint_with_shape env true arg mty.mty_type arg_shape + (Tmodtype_explicit mty) + in + { md with + mod_loc = smod.pmod_loc; + mod_attributes = smod.pmod_attributes; + }, + final_shape + with exn -> + (* [merlin] For better Construct error messages we need to keep holes + in the recovered typedtree *) + match sarg.pmod_desc with + | Pmod_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt -> + Msupport.raise_error exn; + { + mod_desc = Tmod_hole; + mod_type = Mty_for_hole; + mod_loc = sarg.pmod_loc; + mod_env = env; + mod_attributes = sarg.pmod_attributes; + }, + Shape.dummy_mod + | _ -> raise exn + end + | Pmod_unpack sexp -> + let exp = + Ctype.with_local_level_if_principal + (fun () -> Typecore.type_exp env sexp) + ~post:Typecore.generalize_structure_exp + in + let mty = + match get_desc (Ctype.expand_head env exp.exp_type) with + Tpackage (p, fl) -> + if List.exists (fun (_n, t) -> Ctype.free_variables t <> []) fl then + raise (Error (smod.pmod_loc, env, + Incomplete_packed_module exp.exp_type)); + if !Clflags.principal && + not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type) + then + Location.prerr_warning smod.pmod_loc + (Warnings.Not_principal "this module unpacking"); + modtype_of_package env smod.pmod_loc p fl + | Tvar _ -> + raise (Typecore.Error + (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) + | _ -> + raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type)) + in + if funct_body && Mtype.contains_type env mty then + raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); + { mod_desc = Tmod_unpack(exp, mty); + mod_type = mty; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc }, + Shape.leaf_for_unpack + | Pmod_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt -> + { mod_desc = Tmod_hole; + mod_type = Mty_for_hole; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc }, + Shape.dummy_mod + | Pmod_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and type_application loc strengthen funct_body env smod = + let rec extract_application funct_body env sargs smod = + match smod.pmod_desc with + | Pmod_apply (f, sarg) -> + let arg, shape = type_module true funct_body None env sarg in + let summary = { + loc = smod.pmod_loc; + attributes = smod.pmod_attributes; + f_loc = f.pmod_loc; + arg = Some { + is_syntactic_unit = sarg.pmod_desc = Pmod_structure []; + arg; + path = path_of_module arg; + shape; + } + } in + extract_application funct_body env (summary::sargs) f + | Pmod_apply_unit f -> + let summary = { + loc = smod.pmod_loc; + attributes = smod.pmod_attributes; + f_loc = f.pmod_loc; + arg = None + } in + extract_application funct_body env (summary::sargs) f + | _ -> smod, sargs + in + let sfunct, args = extract_application funct_body env [] smod in + let funct, funct_shape = + let has_path { arg } = match arg with + | None | Some { path = None } -> false + | Some { path = Some _ } -> true + in + let strengthen = strengthen && List.for_all has_path args in + type_module strengthen funct_body None env sfunct + in + List.fold_left (type_one_application ~ctx:(loc, funct, args) funct_body env) + (funct, funct_shape) args + +and type_one_application ~ctx:(apply_loc,md_f,args) + funct_body env (funct, funct_shape) app_view = + match Env.scrape_alias env funct.mod_type with + | Mty_functor (Unit, mty_res) -> + begin match app_view.arg with + | None -> () + | Some arg -> + if arg.is_syntactic_unit then + (* this call to warning_scope allows e.g. + [ F (struct end [@warning "-73"]) ] + not to warn; useful when generating code that must + work over multiple versions of OCaml *) + Builtin_attributes.warning_scope arg.arg.mod_attributes @@ fun () -> + Location.prerr_warning arg.arg.mod_loc + Warnings.Generative_application_expects_unit + else + raise (Error (app_view.f_loc, env, Apply_generative)); + end; + if funct_body && Mtype.contains_type env funct.mod_type then + Msupport.raise_error + (Error (apply_loc, env, Not_allowed_in_functor_body)); + { mod_desc = Tmod_apply_unit funct; + mod_type = mty_res; + mod_env = env; + mod_attributes = app_view.attributes; + mod_loc = funct.mod_loc }, + Shape.app funct_shape ~arg:Shape.dummy_mod + | Mty_functor (Named (param, mty_param), mty_res) as mty_functor -> + let apply_error () = + let args = List.map simplify_app_summary args in + let mty_f = md_f.mod_type in + let lid_app = None in + Includemod.Apply_error {loc=apply_loc;env;lid_app;mty_f;args} + in + begin match app_view with + | { arg = None; loc = app_loc; attributes = app_attributes; _ } -> + Msupport.raise_error (apply_error ()); + { mod_desc = Tmod_apply_unit(funct); + mod_type = mty_res; + mod_env = env; + mod_attributes = app_attributes; + mod_loc = app_loc }, + funct_shape + | { loc = app_loc; attributes = app_attributes; + arg = Some { shape = arg_shape; path = arg_path; arg } } -> + let coercion = + try Includemod.modtypes + ~loc:arg.mod_loc ~mark:Mark_both env arg.mod_type mty_param + with Includemod.Error _ -> + Msupport.raise_error (apply_error ()); + Tcoerce_none + in + let mty_appl = + match arg_path with + | Some path -> + let scope = Ctype.create_scope () in + let subst = + match param with + | None -> Subst.identity + | Some p -> Subst.add_module p path Subst.identity + in + Subst.modtype (Rescope scope) subst mty_res + | None -> + let nondep_mty = + match param with + | None -> mty_res + | Some param -> + let parent_env = env in + let env = + Env.add_module ~arg:true param Mp_present arg.mod_type env + in + check_well_formed_module env app_loc + "the signature of this functor application" mty_res; + try Mtype.nondep_supertype env [param] mty_res + with Ctype.Nondep_cannot_erase _ -> + let error = Cannot_eliminate_dependency mty_functor in + raise (Error(app_loc, parent_env, error)) + in + (* TODO(merlin): we could perhaps log the "fatal error" cases... + not sure it's worth the effort. *) + (* + begin match + Includemod.modtypes + ~loc:app_loc ~mark:Mark_neither env mty_res nondep_mty + with + | Tcoerce_none -> () + | _ -> + fatal_error + "unexpected coercion from original module type to \ + nondep_supertype one" + | exception Includemod.Error _ -> + fatal_error + "nondep_supertype not included in original module type" + end; + *) + nondep_mty + in + check_well_formed_module env apply_loc + "the signature of this functor application" mty_appl; + { mod_desc = Tmod_apply(funct, arg, coercion); + mod_type = mty_appl; + mod_env = env; + mod_attributes = app_attributes; + mod_loc = app_loc }, + Shape.app ~arg:arg_shape funct_shape + end + | Mty_alias path -> + raise(Error(app_view.f_loc, env, Cannot_scrape_alias path)) + | _ -> + let args = List.map simplify_app_summary args in + let mty_f = md_f.mod_type in + let lid_app = None in + raise(Includemod.Apply_error {loc=apply_loc;env;lid_app;mty_f;args}) + +and type_open_decl ?used_slot ?toplevel funct_body names env sod = + Builtin_attributes.warning_scope sod.popen_attributes + (fun () -> + type_open_decl_aux ?used_slot ?toplevel funct_body names env sod + ) + +and type_open_decl_aux ?used_slot ?toplevel funct_body names env od = + let loc = od.popen_loc in + match od.popen_expr.pmod_desc with + | Pmod_ident lid -> + let path, newenv = + type_open_ ?used_slot ?toplevel od.popen_override env loc lid + in + let md = { mod_desc = Tmod_ident (path, lid); + mod_type = Mty_alias path; + mod_env = env; + mod_attributes = od.popen_expr.pmod_attributes; + mod_loc = od.popen_expr.pmod_loc } + in + let open_descr = { + open_expr = md; + open_bound_items = []; + open_override = od.popen_override; + open_env = newenv; + open_loc = loc; + open_attributes = od.popen_attributes + } in + open_descr, [], newenv + | _ -> + let md, mod_shape = type_module true funct_body None env od.popen_expr in + let scope = Ctype.create_scope () in + let sg, newenv = + Env.enter_signature ~scope ~mod_shape + (extract_sig_open env md.mod_loc md.mod_type) env + in + let info, visibility = + match toplevel with + | Some false | None -> Some `From_open, Hidden + | Some true -> None, Exported + in + Signature_group.iter (Signature_names.check_sig_item ?info names loc) sg; + let sg = + List.map (function + | Sig_value(id, vd, _) -> Sig_value(id, vd, visibility) + | Sig_type(id, td, rs, _) -> Sig_type(id, td, rs, visibility) + | Sig_typext(id, ec, et, _) -> Sig_typext(id, ec, et, visibility) + | Sig_module(id, mp, md, rs, _) -> + Sig_module(id, mp, md, rs, visibility) + | Sig_modtype(id, mtd, _) -> Sig_modtype(id, mtd, visibility) + | Sig_class(id, cd, rs, _) -> Sig_class(id, cd, rs, visibility) + | Sig_class_type(id, ctd, rs, _) -> + Sig_class_type(id, ctd, rs, visibility) + ) sg + in + let open_descr = { + open_expr = md; + open_bound_items = sg; + open_override = od.popen_override; + open_env = newenv; + open_loc = loc; + open_attributes = od.popen_attributes + } in + open_descr, sg, newenv + +and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body anchor env sstr = + let names = Signature_names.create () in + + let type_str_item env shape_map {pstr_loc = loc; pstr_desc = desc} = + match desc with + | Pstr_eval (sexpr, attrs) -> + let expr = + Builtin_attributes.warning_scope attrs + (fun () -> Typecore.type_expression env sexpr) + in + Tstr_eval (expr, attrs), [], shape_map, env + | Pstr_value(rec_flag, sdefs) -> + let (defs, newenv) = + Typecore.type_binding env rec_flag sdefs in + let () = if rec_flag = Recursive then + Typecore.check_recursive_bindings env defs + in + (* Note: Env.find_value does not trigger the value_used event. Values + will be marked as being used during the signature inclusion test. *) + let items, shape_map = + List.fold_left + (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ)-> + Signature_names.check_value names loc id; + let vd = Env.find_value (Pident id) newenv in + Env.register_uid vd.val_uid vd.val_loc; + Sig_value(id, vd, Exported) :: acc, + Shape.Map.add_value shape_map id vd.val_uid + ) + ([], shape_map) + (let_bound_idents_full defs) + in + Tstr_value(rec_flag, defs), + List.rev items, + shape_map, + newenv + | Pstr_primitive sdesc -> + let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in + Signature_names.check_value names desc.val_loc desc.val_id; + Env.register_uid desc.val_val.val_uid desc.val_val.val_loc; + Tstr_primitive desc, + [Sig_value(desc.val_id, desc.val_val, Exported)], + Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid, + newenv + | Pstr_type (rec_flag, sdecls) -> + let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in + let newenv = Env.update_short_paths newenv in + List.iter + Signature_names.(fun td -> check_type names td.typ_loc td.typ_id) + decls; + let items = map_rec_type_with_row_types ~rec_flag + (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported)) + decls [] + in + let shape_map = List.fold_left + (fun shape_map -> function + | Sig_type (id, vd, _, _) -> + if not (Btype.is_row_name (Ident.name id)) then begin + Env.register_uid vd.type_uid vd.type_loc; + Shape.Map.add_type shape_map id vd.type_uid + end else shape_map + | _ -> assert false + ) + shape_map + items + in + Tstr_type (rec_flag, decls), + items, + shape_map, + enrich_type_decls anchor decls env newenv + | Pstr_typext styext -> + let (tyext, newenv) = + Typedecl.transl_type_extension true env loc styext + in + let constructors = tyext.tyext_constructors in + let shape_map = List.fold_left (fun shape_map ext -> + Signature_names.check_typext names ext.ext_loc ext.ext_id; + Env.register_uid ext.ext_type.ext_uid ext.ext_loc; + Shape.Map.add_extcons shape_map ext.ext_id ext.ext_type.ext_uid + ) shape_map constructors + in + (Tstr_typext tyext, + map_ext + (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported)) + constructors [], + shape_map, + newenv) + | Pstr_exception sext -> + let (ext, newenv) = Typedecl.transl_type_exception env sext in + let constructor = ext.tyexn_constructor in + Signature_names.check_typext names constructor.ext_loc + constructor.ext_id; + Env.register_uid + constructor.ext_type.ext_uid + constructor.ext_loc; + Tstr_exception ext, + [Sig_typext(constructor.ext_id, + constructor.ext_type, + Text_exception, + Exported)], + Shape.Map.add_extcons shape_map + constructor.ext_id + constructor.ext_type.ext_uid, + newenv + | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; + pmb_loc; + } -> + let outer_scope = Ctype.get_current_level () in + let scope = Ctype.create_scope () in + let modl, md_shape = + Builtin_attributes.warning_scope attrs + (fun () -> + type_module ~alias:true true funct_body + (anchor_submodule name.txt anchor) env smodl + ) + in + let pres = + match modl.mod_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let md = + { md_type = enrich_module_type anchor name.txt modl.mod_type env; + md_attributes = attrs; + md_loc = pmb_loc; + md_uid; + } + in + let md_shape = Shape.set_uid_if_none md_shape md_uid in + Env.register_uid md_uid pmb_loc; + (*prerr_endline (Ident.unique_toplevel_name id);*) + Mtype.lower_nongen outer_scope md.md_type; + let id, newenv, sg = + match name.txt with + | None -> None, env, [] + | Some name -> + let id, e = Env.enter_module_declaration + ~scope ~shape:md_shape name pres md env + in + let e = Env.update_short_paths e in + Signature_names.check_module names pmb_loc id; + Some id, e, + [Sig_module(id, pres, + {md_type = modl.mod_type; + md_attributes = attrs; + md_loc = pmb_loc; + md_uid; + }, Trec_not, Exported)] + in + let shape_map = match id with + | Some id -> Shape.Map.add_module shape_map id md_shape + | None -> shape_map + in + Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; + mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; }, + sg, + shape_map, + newenv + | Pstr_recmodule sbind -> + let sbind = + List.map + (function + | {pmb_name = name; + pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; + pmb_attributes = attrs; + pmb_loc = loc; + } -> + name, typ, expr, attrs, loc + | mb -> + raise (Error (mb.pmb_expr.pmod_loc, env, + Recursive_module_require_explicit_type)) + ) + sbind + in + let (decls, newenv) = + transl_recmodule_modtypes env + (List.map (fun (name, smty, _smodl, attrs, loc) -> + {pmd_name=name; pmd_type=smty; + pmd_attributes=attrs; pmd_loc=loc}) sbind + ) in + List.iter + (fun (md, _, _) -> + Option.iter Signature_names.(check_module names md.md_loc) md.md_id + ) decls; + let newenv = Env.update_short_paths newenv in + let bindings1 = + List.map2 + (fun ({md_id=id; md_type=mty}, uid, _prev_shape) + (name, _, smodl, attrs, loc) -> + let modl, shape = + Builtin_attributes.warning_scope attrs + (fun () -> + type_module true funct_body (anchor_recmodule id) + newenv smodl + ) + in + let mty' = + enrich_module_type anchor name.txt modl.mod_type newenv + in + (id, name, mty, modl, mty', attrs, loc, shape, uid)) + decls sbind in + let newenv = (* allow aliasing recursive modules from outside *) + List.fold_left + (fun env (id_opt, _, mty, _, _, attrs, loc, shape, uid) -> + match id_opt with + | None -> env + | Some id -> + let mdecl = + { + md_type = mty.mty_type; + md_attributes = attrs; + md_loc = loc; + md_uid = uid; + } + in + Env.add_module_declaration ~check:true ~shape + id Mp_present mdecl env + ) + env bindings1 + in + let newenv = Env.update_short_paths newenv in + let bindings2 = + check_recmodule_inclusion newenv bindings1 in + let mbs = + List.filter_map (fun (mb, shape, uid) -> + Option.map (fun id -> id, mb, uid, shape) mb.mb_id + ) bindings2 + in + let shape_map = + List.fold_left (fun map (id, mb, uid, shape) -> + Env.register_uid uid mb.mb_loc; + Shape.Map.add_module map id shape + ) shape_map mbs + in + Tstr_recmodule (List.map (fun (mb, _, _) -> mb) bindings2), + map_rec (fun rs (id, mb, uid, _shape) -> + Sig_module(id, Mp_present, { + md_type=mb.mb_expr.mod_type; + md_attributes=mb.mb_attributes; + md_loc=mb.mb_loc; + md_uid = uid; + }, rs, Exported)) + mbs [], + shape_map, + newenv + | Pstr_modtype pmtd -> + (* check that it is non-abstract *) + let newenv, mtd, decl = transl_modtype_decl env pmtd in + let newenv = Env.update_short_paths newenv in + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + Env.register_uid decl.mtd_uid decl.mtd_loc; + let id = mtd.mtd_id in + let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in + Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv + | Pstr_open sod -> + let (od, sg, newenv) = + type_open_decl ~toplevel funct_body names env sod + in + let newenv = Env.update_short_paths newenv in + Tstr_open od, sg, shape_map, newenv + | Pstr_class cl -> + let (classes, new_env) = Typeclass.class_declarations env cl in + let new_env = Env.update_short_paths new_env in + let shape_map = List.fold_left (fun acc cls -> + let open Typeclass in + let loc = cls.cls_id_loc.Location.loc in + Signature_names.check_class names loc cls.cls_id; + Signature_names.check_class_type names loc cls.cls_ty_id; + Signature_names.check_type names loc cls.cls_obj_id; + Env.register_uid cls.cls_decl.cty_uid loc; + let map f id acc = f acc id cls.cls_decl.cty_uid in + map Shape.Map.add_class cls.cls_id acc + |> map Shape.Map.add_class_type cls.cls_ty_id + |> map Shape.Map.add_type cls.cls_obj_id + ) shape_map classes + in + Tstr_class + (List.map (fun cls -> + (cls.Typeclass.cls_info, + cls.Typeclass.cls_pub_methods)) classes), + List.flatten + (map_rec + (fun rs cls -> + let open Typeclass in + [Sig_class(cls.cls_id, cls.cls_decl, rs, Exported); + Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs, Exported); + Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported) + ]) + classes []), + shape_map, + new_env + | Pstr_class_type cl -> + let (classes, new_env) = Typeclass.class_type_declarations env cl in + let new_env = Env.update_short_paths new_env in + let shape_map = List.fold_left (fun acc decl -> + let open Typeclass in + let loc = decl.clsty_id_loc.Location.loc in + Signature_names.check_class_type names loc decl.clsty_ty_id; + Signature_names.check_type names loc decl.clsty_obj_id; + Env.register_uid decl.clsty_ty_decl.clty_uid loc; + let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in + map Shape.Map.add_class_type decl.clsty_ty_id acc + |> map Shape.Map.add_type decl.clsty_obj_id + ) shape_map classes + in + Tstr_class_type + (List.map (fun cl -> + (cl.Typeclass.clsty_ty_id, + cl.Typeclass.clsty_id_loc, + cl.Typeclass.clsty_info)) classes), + List.flatten + (map_rec + (fun rs decl -> + let open Typeclass in + [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs, + Exported); + Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs, Exported); + ]) + classes []), + shape_map, + new_env + | Pstr_include sincl -> + let smodl = sincl.pincl_mod in + let modl, modl_shape = + Builtin_attributes.warning_scope sincl.pincl_attributes + (fun () -> type_module true funct_body None env smodl) + in + let scope = Ctype.create_scope () in + (* Rename all identifiers bound by this signature to avoid clashes *) + let sg, shape, new_env = + Env.enter_signature_and_shape ~scope ~parent_shape:shape_map + modl_shape (extract_sig_open env smodl.pmod_loc modl.mod_type) env + in + let new_env = Env.update_short_paths new_env in + Signature_group.iter (Signature_names.check_sig_item names loc) sg; + let incl = + { incl_mod = modl; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + Tstr_include incl, sg, shape, new_env + | Pstr_extension (ext, _attrs) -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | Pstr_attribute x -> + Builtin_attributes.warning_attribute x; + Tstr_attribute x, [], shape_map, env + in + let rec type_struct env shape_map sstr = + match sstr with + | [] -> ([], [], shape_map, env) + | pstr :: srem -> + let previous_saved_types = Cmt_format.get_saved_types () in + match type_str_item env shape_map pstr with + | desc, sg, shape_map, new_env -> + let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in + Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str + :: previous_saved_types); + let (str_rem, sig_rem, shape_map, final_env) = + type_struct new_env shape_map srem + in + (str :: str_rem, sg @ sig_rem, shape_map, final_env) + | exception exn -> + Msupport.raise_error exn; + type_struct env shape_map srem + in + Msupport.with_saved_types + ?warning_attribute:(if toplevel || keep_warnings then None else Some []) + ~save_part:(fun (str,_,_,_,_) -> Cmt_format.Partial_structure str) + (fun () -> + let (items, sg, shape_map, final_env) = + type_struct env Shape.Map.empty sstr + in + let str = { str_items = items; str_type = sg; str_final_env = final_env } in + str, sg, names, Shape.str shape_map, final_env) + +let type_toplevel_phrase env s = + Env.reset_required_globals (); + let (str, sg, _to_remove_from_sg, shape, env) = + type_structure ~toplevel:true false None env s + in + (str, sg, (* to_remove_from_sg, *) shape, env) + +let type_module_alias = type_module ~alias:true true false None +let type_module = type_module true false None + +let merlin_type_structure env str = + let (str, sg, _sg_names, _shape, env) = + type_structure ~keep_warnings:true false None env str + in + str, sg, env +let type_structure = type_structure false None +let merlin_transl_signature env sg = transl_signature ~keep_warnings:true env sg +let transl_signature env sg = transl_signature env sg + +(* Normalize types in a signature *) + +let rec normalize_modtype = function + Mty_ident _ + | Mty_alias _ + | Mty_for_hole -> () + | Mty_signature sg -> normalize_signature sg + | Mty_functor(_param, body) -> normalize_modtype body + +and normalize_signature sg = List.iter normalize_signature_item sg + +and normalize_signature_item = function + Sig_value(_id, desc, _) -> Ctype.normalize_type desc.val_type + | Sig_module(_id, _, md, _, _) -> normalize_modtype md.md_type + | _ -> () + +(* Extract the module type of a module expression *) + +let type_module_type_of env smod = + let remove_aliases = has_remove_aliases_attribute smod.pmod_attributes in + let tmty = + match smod.pmod_desc with + | Pmod_ident lid -> (* turn off strengthening in this case *) + let path, md = Env.lookup_module ~loc:smod.pmod_loc lid.txt env in + { mod_desc = Tmod_ident (path, lid); + mod_type = md.md_type; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc } + | _ -> + let me, _shape = type_module env smod in + me + in + let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in + (* PR#5036: must not contain non-generalized type variables *) + check_nongen_modtype env smod.pmod_loc mty; + tmty, mty + +(* For Typecore *) + +(* Graft a longident onto a path *) +let rec extend_path path = + fun lid -> + match lid with + | Lident name -> Pdot(path, name) + | Ldot(m, name) -> Pdot(extend_path path m, name) + | Lapply _ -> assert false + +(* Lookup a type's longident within a signature *) +let lookup_type_in_sig sg = + let types, modules = + List.fold_left + (fun acc item -> + match item with + | Sig_type(id, _, _, _) -> + let types, modules = acc in + let types = String.Map.add (Ident.name id) id types in + types, modules + | Sig_module(id, _, _, _, _) -> + let types, modules = acc in + let modules = String.Map.add (Ident.name id) id modules in + types, modules + | _ -> acc) + (String.Map.empty, String.Map.empty) sg + in + let rec module_path = function + | Lident name -> Pident (String.Map.find name modules) + | Ldot(m, name) -> Pdot(module_path m, name) + | Lapply _ -> assert false + in + fun lid -> + match lid with + | Lident name -> Pident (String.Map.find name types) + | Ldot(m, name) -> Pdot(module_path m, name) + | Lapply _ -> assert false + +let type_package env m p fl = + (* Same as Pexp_letmodule *) + let modl, scope = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + (* type the module and create a scope in a raised level *) + Ctype.with_local_level begin fun () -> + let modl, _mod_shape = type_module env m in + let scope = Ctype.create_scope () in + modl, scope + end + end + in + let fl', env = + match fl with + | [] -> [], env + | fl -> + let type_path, env = + match modl.mod_desc with + | Tmod_ident (mp,_) + | Tmod_constraint + ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _) -> + (* We special case these because interactions between + strengthening of module types and packages can cause + spurious escape errors. See examples from PR#6982 in the + testsuite. This can be removed when such issues are + fixed. *) + extend_path mp, env + | _ -> + let sg = extract_sig_open env modl.mod_loc modl.mod_type in + let sg, env = Env.enter_signature ~scope sg env in + lookup_type_in_sig sg, env + in + let fl' = + List.fold_right + (fun (lid, _t) fl -> + match type_path lid with + | exception Not_found -> fl + | path -> begin + match Env.find_type path env with + | exception Not_found -> fl + | decl -> + if decl.type_arity > 0 then begin + fl + end else begin + let t = Btype.newgenty (Tconstr (path,[],ref Mnil)) in + (lid, t) :: fl + end + end) + fl [] + in + fl', env + in + let mty = + if fl = [] then (Mty_ident p) + else modtype_of_package env modl.mod_loc p fl' + in + List.iter + (fun (n, ty) -> + try Ctype.unify env ty (Ctype.newvar ()) + with Ctype.Unify _ -> + raise (Error(modl.mod_loc, env, Scoping_pack (n,ty)))) + fl'; + let modl = wrap_constraint_package env true modl mty Tmodtype_implicit in + modl, fl' + +(* Fill in the forward declarations *) + +let type_open_decl ?used_slot env od = + type_open_decl ?used_slot ?toplevel:None false (Signature_names.create ()) env + od + +let type_open_descr ?used_slot env od = + type_open_descr ?used_slot ?toplevel:None env od + +let () = + Typecore.type_module := type_module_alias; + Typetexp.transl_modtype_longident := transl_modtype_longident; + Typetexp.transl_modtype := transl_modtype; + Typecore.type_open := type_open_ ?toplevel:None; + Typecore.type_open_decl := type_open_decl; + Typecore.type_package := type_package; + Typeclass.type_open_descr := type_open_descr; + type_module_type_of_fwd := type_module_type_of + + +(* Typecheck an implementation file *) + +let type_implementation sourcefile outputprefix modulename initial_env ast = + Cmt_format.clear (); + Misc.try_finally (fun () -> + Typecore.reset_delayed_checks (); + Env.reset_required_globals (); + if !Clflags.print_types then (* #7656 *) + ignore @@ Warnings.parse_options false "-32-34-37-38-60"; + let (str, sg, names, shape, finalenv) = + type_structure initial_env ast in + let shape = + Shape.set_uid_if_none shape + (Uid.of_compilation_unit_id (Ident.create_persistent modulename)) + in + let simple_sg = Signature_names.simplify finalenv names sg in + if !Clflags.print_types then begin + Typecore.force_delayed_checks (); + let shape = Shape.local_reduce shape in + Printtyp.wrap_printing_env ~error:false initial_env + (fun () -> fprintf std_formatter "%a@." + (Printtyp.printed_signature sourcefile) simple_sg + ); + { structure = str; + coercion = Tcoerce_none; + shape; + signature = simple_sg + } (* result is ignored by Compile.implementation *) + end else begin + let sourceintf = + Filename.remove_extension sourcefile ^ !Config.interface_suffix in + if !Clflags.cmi_file <> None || Sys.file_exists sourceintf then begin + let intf_file = + match !Clflags.cmi_file with + | None -> + (try + Load_path.find_uncap (modulename ^ ".cmi") + with Not_found -> + raise(Error(Location.in_file sourcefile, Env.empty, + Interface_not_compiled sourceintf))) + | Some cmi_file -> cmi_file + in + let dclsig = Env.read_signature modulename intf_file in + let coercion, shape = + Includemod.compunit initial_env ~mark:Mark_positive + sourcefile sg intf_file dclsig shape + in + Typecore.force_delayed_checks (); + (* It is important to run these checks after the inclusion test above, + so that value declarations which are not used internally but + exported are not reported as being unused. *) + let shape = Shape.local_reduce shape in + let annots = Cmt_format.Implementation str in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + annots (Some sourcefile) initial_env None (Some shape); + { structure = str; + coercion; + shape; + signature = dclsig + } + end else begin + Location.prerr_warning (Location.in_file sourcefile) + Warnings.Missing_mli; + let coercion, shape = + Includemod.compunit initial_env ~mark:Mark_positive + sourcefile sg "(inferred signature)" simple_sg shape + in + check_nongen_signature finalenv simple_sg; + normalize_signature simple_sg; + Typecore.force_delayed_checks (); + (* See comment above. Here the target signature contains all + the values being exported. We can still capture unused + declarations like "let x = true;; let x = 1;;", because in this + case, the inferred signature contains only the last declaration. *) + let shape = Shape.local_reduce shape in + if not !Clflags.dont_write_files then begin + let alerts = Builtin_attributes.alerts_of_str ast in + let cmi = + Env.save_signature ~alerts + simple_sg modulename (outputprefix ^ ".cmi") + in + let annots = Cmt_format.Implementation str in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + annots (Some sourcefile) initial_env (Some cmi) (Some shape); + end; + { structure = str; + coercion; + shape; + signature = simple_sg + } + end + end + ) + ~exceptionally:(fun () -> + let annots = + Cmt_format.Partial_implementation + (Array.of_list (Cmt_format.get_saved_types ())) + in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + annots (Some sourcefile) initial_env None None; + ) + +let save_signature modname tsg outputprefix source_file initial_env cmi = + Cmt_format.save_cmt (outputprefix ^ ".cmti") modname + (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) None + +let type_interface env ast = + transl_signature env ast + +(* "Packaging" of several compilation units into one unit + having them as sub-modules. *) + +let package_signatures units = + let units_with_ids = + List.map + (fun (name, sg) -> + let oldid = Ident.create_persistent name in + let newid = Ident.create_local name in + (oldid, newid, sg)) + units + in + let subst = + List.fold_left + (fun acc (oldid, newid, _) -> + Subst.add_module oldid (Pident newid) acc) + Subst.identity units_with_ids + in + List.map + (fun (_, newid, sg) -> + (* This signature won't be used for anything, it'll just be saved in a cmi + and cmt. *) + let sg = Subst.signature Make_local subst sg in + let md = + { md_type=Mty_signature sg; + md_attributes=[]; + md_loc=Location.none; + md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } + in + Sig_module(newid, Mp_present, md, Trec_not, Exported)) + units_with_ids + +let package_units initial_env objfiles cmifile modulename = + (* Read the signatures of the units *) + let units = + List.map + (fun f -> + let pref = chop_extensions f in + let modname = String.capitalize_ascii(Filename.basename pref) in + let sg = Env.read_signature modname (pref ^ ".cmi") in + if Filename.check_suffix f ".cmi" && + not(Mtype.no_code_needed_sig Env.initial sg) + then raise(Error(Location.none, Env.empty, + Implementation_is_required f)); + (modname, Env.read_signature modname (pref ^ ".cmi"))) + objfiles in + (* Compute signature of packaged unit *) + Ident.reinit(); + let sg = package_signatures units in + (* Compute the shape of the package *) + let prefix = Filename.remove_extension cmifile in + let pack_uid = Uid.of_compilation_unit_id (Ident.create_persistent prefix) in + let shape = + List.fold_left (fun map (name, _sg) -> + let id = Ident.create_persistent name in + Shape.Map.add_module map id (Shape.for_persistent_unit name) + ) Shape.Map.empty units + |> Shape.str ~uid:pack_uid + in + (* See if explicit interface is provided *) + let mlifile = prefix ^ !Config.interface_suffix in + if Sys.file_exists mlifile then begin + if not (Sys.file_exists cmifile) then begin + raise(Error(Location.in_file mlifile, Env.empty, + Interface_not_compiled mlifile)) + end; + let dclsig = Env.read_signature modulename cmifile in + let cc, _shape = + Includemod.compunit initial_env ~mark:Mark_both + "(obtained by packing)" sg mlifile dclsig shape + in + Cmt_format.save_cmt (prefix ^ ".cmt") modulename + (Cmt_format.Packed (sg, objfiles)) None initial_env None (Some shape); + cc + end else begin + (* Determine imports *) + let unit_names = List.map fst units in + let imports = + List.filter + (fun (name, _crc) -> not (List.mem name unit_names)) + (Env.imports()) in + (* Write packaged signature *) + if not !Clflags.dont_write_files then begin + let cmi = + Env.save_signature_with_imports ~alerts:Misc.String.Map.empty + sg modulename + (prefix ^ ".cmi") imports + in + Cmt_format.save_cmt (prefix ^ ".cmt") modulename + (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env + (Some cmi) (Some shape); + end; + Tcoerce_none + end + + +(* Error report *) + + +open Printtyp + +let report_error ~loc _env = function + Cannot_apply mty -> + Location.errorf ~loc + "@[This module is not a functor; it has type@ %a@]" modtype mty + | Not_included errs -> + let main = Includemod_errorprinter.err_msgs errs in + Location.errorf ~loc "@[Signature mismatch:@ %t@]" main + | Cannot_eliminate_dependency mty -> + Location.errorf ~loc + "@[This functor has type@ %a@ \ + The parameter cannot be eliminated in the result type.@ \ + Please bind the argument to a module identifier.@]" modtype mty + | Signature_expected -> + Location.errorf ~loc "This module type is not a signature" + | Structure_expected mty -> + Location.errorf ~loc + "@[This module is not a structure; it has type@ %a" modtype mty + | With_no_component lid -> + Location.errorf ~loc + "@[The signature constrained by `with' has no component named %a@]" + longident lid + | With_mismatch(lid, explanation) -> + let main = Includemod_errorprinter.err_msgs explanation in + Location.errorf ~loc + "@[\ + @[In this `with' constraint, the new definition of %a@ \ + does not match its original definition@ \ + in the constrained signature:@]@ \ + %t@]" + longident lid main + | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> + let main = Includemod_errorprinter.err_msgs explanation in + Location.errorf ~loc + "@[\ + @[This `with' constraint on %a makes the applicative functor @ \ + type %s ill-typed in the constrained signature:@]@ \ + %t@]" + longident lid (Path.name path) main + | With_changes_module_alias(lid, id, path) -> + Location.errorf ~loc + "@[\ + @[This `with' constraint on %a changes %s, which is aliased @ \ + in the constrained signature (as %s)@].@]" + longident lid (Path.name path) (Ident.name id) + | With_cannot_remove_constrained_type -> + Location.errorf ~loc + "@[Destructive substitutions are not supported for constrained @ \ + types (other than when replacing a type constructor with @ \ + a type constructor with the same arguments).@]" + | With_cannot_remove_packed_modtype (p,mty) -> + Location.errorf ~loc + "This `with' constraint@ %s := %a@ makes a packed module ill-formed." + (Path.name p) Printtyp.modtype mty + | Repeated_name(kind, name) -> + Location.errorf ~loc + "@[Multiple definition of the %s name %s.@ \ + Names must be unique in a given structure or signature.@]" + (Sig_component_kind.to_string kind) name + | Non_generalizable { vars; expression } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + prepare_for_printing vars; + add_type_to_preparation expression; + Location.errorf ~loc + "@[The type of this expression,@ %a,@ \ + contains the non-generalizable type variable(s): %a.@ %a@]" + prepared_type_scheme expression + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + prepared_type_scheme) vars + Misc.print_see_manual manual_ref + | Non_generalizable_module { vars; mty; item } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + prepare_for_printing vars; + add_type_to_preparation item.val_type; + let sub = + [ Location.msg ~loc:item.val_loc + "The type of this value,@ %a,@ \ + contains the non-generalizable type variable(s) %a." + prepared_type_scheme + item.val_type + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + prepared_type_scheme) vars + ] + in + Location.errorf ~loc ~sub + "@[The type of this module,@ %a,@ \ + contains non-generalizable type variable(s).@ %a@]" + modtype mty + Misc.print_see_manual manual_ref + | Implementation_is_required intf_name -> + Location.errorf ~loc + "@[The interface %a@ declares values, not just types.@ \ + An implementation must be provided.@]" + Location.print_filename intf_name + | Interface_not_compiled intf_name -> + Location.errorf ~loc + "@[Could not find the .cmi file for interface@ %a.@]" + Location.print_filename intf_name + | Not_allowed_in_functor_body -> + Location.errorf ~loc + "@[This expression creates fresh types.@ %s@]" + "It is not allowed inside applicative functors." + | Not_a_packed_module ty -> + Location.errorf ~loc + "This expression is not a packed module. It has type@ %a" + type_expr ty + | Incomplete_packed_module ty -> + Location.errorf ~loc + "The type of this packed module contains variables:@ %a" + type_expr ty + | Scoping_pack (lid, ty) -> + Location.errorf ~loc + "The type %a in this module cannot be exported.@ \ + Its type contains local dependencies:@ %a" longident lid type_expr ty + | Recursive_module_require_explicit_type -> + Location.errorf ~loc "Recursive modules require an explicit module type." + | Apply_generative -> + Location.errorf ~loc + "This is a generative functor. It can only be applied to ()" + | Cannot_scrape_alias p -> + Location.errorf ~loc + "This is an alias for module %a, which is missing" + path p + | Cannot_scrape_package_type p -> + Location.errorf ~loc + "The type of this packed module refers to %a, which is missing" + path p + | Badly_formed_signature (context, err) -> + Location.errorf ~loc "@[In %s:@ %a@]" context Typedecl.report_error err + | Cannot_hide_id Illegal_shadowing + { shadowed_item_kind; shadowed_item_id; shadowed_item_loc; + shadower_id; user_id; user_kind; user_loc } -> + let shadowed = + Printtyp.namespaced_ident shadowed_item_kind shadowed_item_id + in + let shadower = + Printtyp.namespaced_ident shadowed_item_kind shadower_id + in + let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in + let shadowed_msg = + Location.msg ~loc:shadowed_item_loc + "@[%s %s came from this include.@]" + (String.capitalize_ascii shadowed_item_kind) + shadowed + in + let user_msg = + Location.msg ~loc:user_loc + "@[The %s %s has no valid type@ if %s is shadowed.@]" + (Sig_component_kind.to_string user_kind) (Ident.name user_id) + shadowed + in + Location.errorf ~loc ~sub:[shadowed_msg; user_msg] + "Illegal shadowing of included %s %s@ by %s." + shadowed_item_kind shadowed shadower + | Cannot_hide_id Appears_in_signature + { opened_item_kind; opened_item_id; user_id; user_kind; user_loc } -> + let opened_item_kind= Sig_component_kind.to_string opened_item_kind in + let opened_id = Ident.name opened_item_id in + let user_msg = + Location.msg ~loc:user_loc + "@[The %s %s has no valid type@ if %s is hidden.@]" + (Sig_component_kind.to_string user_kind) (Ident.name user_id) + opened_id + in + Location.errorf ~loc ~sub:[user_msg] + "The %s %s introduced by this open appears in the signature." + opened_item_kind opened_id + | Invalid_type_subst_rhs -> + Location.errorf ~loc "Only type synonyms are allowed on the right of :=" + | Unpackable_local_modtype_subst p -> + Location.errorf ~loc + "The module type@ %s@ is not a valid type for a packed module:@ \ + it is defined as a local substitution for a non-path module type." + (Path.name p) + +let report_error env ~loc err = + Printtyp.wrap_printing_env ~error:true env + (fun () -> report_error env ~loc err) + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (report_error ~loc env err) + | Error_forward err -> + Some err + | _ -> + None + ) diff --git a/ocamlmerlin_mlx/ocaml/typing/typemod.mli b/ocamlmerlin_mlx/ocaml/typing/typemod.mli new file mode 100644 index 0000000..209f2a5 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typemod.mli @@ -0,0 +1,152 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Type-checking of the module language and typed ast hooks + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Types + +module Signature_names : sig + type t + + val simplify: Env.t -> t -> signature -> signature +end + +val type_module: + Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t +val type_structure: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Signature_names.t * Shape.t * + Env.t +val type_toplevel_phrase: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * (* Signature_names.t * *) Shape.t * + Env.t +val type_implementation: + string -> string -> string -> Env.t -> + Parsetree.structure -> Typedtree.implementation +val type_interface: + Env.t -> Parsetree.signature -> Typedtree.signature +val transl_signature: + Env.t -> Parsetree.signature -> Typedtree.signature +val check_nongen_signature: + Env.t -> Types.signature -> unit + (* +val type_open_: + ?used_slot:bool ref -> ?toplevel:bool -> + Asttypes.override_flag -> + Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t + *) +val modtype_of_package: + Env.t -> Location.t -> + Path.t -> (Longident.t * type_expr) list -> module_type + +val path_of_module : Typedtree.module_expr -> Path.t option + +val save_signature: + string -> Typedtree.signature -> string -> string -> + Env.t -> Cmi_format.cmi_infos -> unit + +val package_units: + Env.t -> string list -> string -> string -> Typedtree.module_coercion + +(* Should be in Envaux, but it breaks the build of the debugger *) +val initial_env: + loc:Location.t -> + initially_opened_module:string option -> + open_implicit_modules:string list -> Env.t + +module Sig_component_kind : sig + type t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + val to_string : t -> string +end + +type hiding_error = + | Illegal_shadowing of { + shadowed_item_id: Ident.t; + shadowed_item_kind: Sig_component_kind.t; + shadowed_item_loc: Location.t; + shadower_id: Ident.t; + user_id: Ident.t; + user_kind: Sig_component_kind.t; + user_loc: Location.t; + } + | Appears_in_signature of { + opened_item_id: Ident.t; + opened_item_kind: Sig_component_kind.t; + user_id: Ident.t; + user_kind: Sig_component_kind.t; + user_loc: Location.t; + } + +type error = + Cannot_apply of module_type + | Not_included of Includemod.explanation + | Cannot_eliminate_dependency of module_type + | Signature_expected + | Structure_expected of module_type + | With_no_component of Longident.t + | With_mismatch of Longident.t * Includemod.explanation + | With_makes_applicative_functor_ill_typed of + Longident.t * Path.t * Includemod.explanation + | With_changes_module_alias of Longident.t * Ident.t * Path.t + | With_cannot_remove_constrained_type + | Repeated_name of Sig_component_kind.t * string + | Non_generalizable of { vars : type_expr list; expression : type_expr } + | Non_generalizable_module of + { vars : type_expr list; item : value_description; mty : module_type } + | Implementation_is_required of string + | Interface_not_compiled of string + | Not_allowed_in_functor_body + | Not_a_packed_module of type_expr + | Incomplete_packed_module of type_expr + | Scoping_pack of Longident.t * type_expr + | Recursive_module_require_explicit_type + | Apply_generative + | Cannot_scrape_alias of Path.t + | Cannot_scrape_package_type of Path.t + | Badly_formed_signature of string * Typedecl.error + | Cannot_hide_id of hiding_error + | Invalid_type_subst_rhs + | Unpackable_local_modtype_subst of Path.t + | With_cannot_remove_packed_modtype of Path.t * module_type + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +val report_error: Env.t -> loc:Location.t -> error -> Location.error + +(* merlin *) + +val normalize_signature : Types.signature -> unit + +val merlin_type_structure: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * (* Signature_names.t * *) Env.t + +val merlin_transl_signature: + Env.t -> Parsetree.signature -> Typedtree.signature diff --git a/ocamlmerlin_mlx/ocaml/typing/typeopt.ml b/ocamlmerlin_mlx/ocaml/typing/typeopt.ml new file mode 100644 index 0000000..7462e16 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typeopt.ml @@ -0,0 +1,226 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Auxiliaries for type-based optimizations, e.g. array kinds *) + +open Types +open Asttypes +open Typedtree + +let scrape_ty env ty = + match get_desc ty with + | Tconstr _ -> + let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in + begin match get_desc ty with + | Tconstr (p, _, _) -> + begin match Env.find_type p env with + | {type_kind = ( Type_variant (_, Variant_unboxed) + | Type_record (_, Record_unboxed _) ); _} -> begin + match Typedecl_unboxed.get_unboxed_type_representation env ty with + | None -> ty + | Some ty2 -> ty2 + end + | _ -> ty + | exception Not_found -> ty + end + | _ -> + ty + end + | _ -> ty + +let scrape env ty = + get_desc (scrape_ty env ty) + +let _scrape_poly env ty = + let ty = scrape_ty env ty in + match get_desc ty with + | Tpoly (ty, _) -> get_desc ty + | d -> d + +let is_function_type env ty = + match scrape env ty with + | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs) + | _ -> None + +let is_base_type env ty base_ty_path = + match scrape env ty with + | Tconstr(p, _, _) -> Path.same p base_ty_path + | _ -> false + +let is_immediate = function + | Type_immediacy.Unknown -> false + | Type_immediacy.Always -> true + | Type_immediacy.Always_on_64bits -> + (* In bytecode, we don't know at compile time whether we are + targeting 32 or 64 bits. *) + !Clflags.native_code && Sys.word_size = 64 + +type classification = + | Int + | Float + | Lazy + | Addr (* anything except a float or a lazy *) + | Any + +let classify env ty = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Int + else match get_desc ty with + | Tvar _ | Tunivar _ -> + Any + | Tconstr (p, _args, _abbrev) -> + if Path.same p Predef.path_float then Float + else if Path.same p Predef.path_lazy_t then Lazy + else if Path.same p Predef.path_string + || Path.same p Predef.path_bytes + || Path.same p Predef.path_array + || Path.same p Predef.path_nativeint + || Path.same p Predef.path_int32 + || Path.same p Predef.path_int64 then Addr + else begin + try + match (Env.find_type p env).type_kind with + | Type_abstract -> + Any + | Type_record _ | Type_variant _ | Type_open -> + Addr + with Not_found -> + (* This can happen due to e.g. missing -I options, + causing some .cmi files to be unavailable. + Maybe we should emit a warning. *) + Any + end + | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ -> + Addr + | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ -> + assert false + +(* +let array_type_kind env ty = + match scrape_poly env ty with + | Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array -> + begin match classify env elt_ty with + | Any -> if Config.flat_float_array then Pgenarray else Paddrarray + | Float -> if Config.flat_float_array then Pfloatarray else Paddrarray + | Addr | Lazy -> Paddrarray + | Int -> Pintarray + end + | Tconstr(p, [], _) when Path.same p Predef.path_floatarray -> + Pfloatarray + | _ -> + (* This can happen with e.g. Obj.field *) + Pgenarray + +let array_kind exp = array_type_kind exp.exp_env exp.exp_type + +let array_pattern_kind pat = array_type_kind pat.pat_env pat.pat_type + +let bigarray_decode_type env ty tbl dfl = + match scrape env ty with + | Tconstr(Pdot(Pident mod_id, type_name), [], _) + when Ident.name mod_id = "Stdlib__Bigarray" -> + begin try List.assoc type_name tbl with Not_found -> dfl end + | _ -> + dfl + +let kind_table = + ["float32_elt", Pbigarray_float32; + "float64_elt", Pbigarray_float64; + "int8_signed_elt", Pbigarray_sint8; + "int8_unsigned_elt", Pbigarray_uint8; + "int16_signed_elt", Pbigarray_sint16; + "int16_unsigned_elt", Pbigarray_uint16; + "int32_elt", Pbigarray_int32; + "int64_elt", Pbigarray_int64; + "int_elt", Pbigarray_caml_int; + "nativeint_elt", Pbigarray_native_int; + "complex32_elt", Pbigarray_complex32; + "complex64_elt", Pbigarray_complex64] + +let layout_table = + ["c_layout", Pbigarray_c_layout; + "fortran_layout", Pbigarray_fortran_layout] + +let bigarray_type_kind_and_layout env typ = + match scrape env typ with + | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) -> + (bigarray_decode_type env elt_type kind_table Pbigarray_unknown, + bigarray_decode_type env layout_type layout_table + Pbigarray_unknown_layout) + | _ -> + (Pbigarray_unknown, Pbigarray_unknown_layout) + +let value_kind env ty = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Pintval + else begin + match get_desc ty with + | Tconstr(p, _, _) when Path.same p Predef.path_float -> + Pfloatval + | Tconstr(p, _, _) when Path.same p Predef.path_int32 -> + Pboxedintval Pint32 + | Tconstr(p, _, _) when Path.same p Predef.path_int64 -> + Pboxedintval Pint64 + | Tconstr(p, _, _) when Path.same p Predef.path_nativeint -> + Pboxedintval Pnativeint + | _ -> + Pgenval + end + +let function_return_value_kind env ty = + match is_function_type env ty with + | Some (_lhs, rhs) -> value_kind env rhs + | None -> Pgenval +*) + +(** Whether a forward block is needed for a lazy thunk on a value, i.e. + if the value can be represented as a float/forward/lazy *) +let lazy_val_requires_forward env ty = + match classify env ty with + | Any | Lazy -> true + | Float -> false (* TODO: Config.flat_float_array *) + | Addr | Int -> false + +(** The compilation of the expression [lazy e] depends on the form of e: + constants, floats and identifiers are optimized. The optimization must be + taken into account when determining whether a recursive binding is safe. *) +let classify_lazy_argument : Typedtree.expression -> + [`Constant_or_function + |`Float_that_cannot_be_shortcut + |`Identifier of [`Forward_value|`Other] + |`Other] = + fun e -> match e.exp_desc with + | Texp_constant + ( Const_int _ | Const_char _ | Const_string _ + | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) + | Texp_function _ + | Texp_construct (_, {cstr_arity = 0}, _) -> + `Constant_or_function + | Texp_constant(Const_float _) -> + (* TODO: handle flat float array, either at configure time or from the + .merlin. *) + `Constant_or_function + | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type -> + `Identifier `Forward_value + | Texp_ident _ -> + `Identifier `Other + | _ -> + `Other + +(* +let value_kind_union k1 k2 = + if k1 = k2 then k1 + else Pgenval +*) diff --git a/ocamlmerlin_mlx/ocaml/typing/typeopt.mli b/ocamlmerlin_mlx/ocaml/typing/typeopt.mli new file mode 100644 index 0000000..6ca678d --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typeopt.mli @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Auxiliaries for type-based optimizations, e.g. array kinds *) + +val is_function_type : + Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option +val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool + +(* +val maybe_pointer_type : Env.t -> Types.type_expr + -> Lambda.immediate_or_pointer +val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer + +val array_type_kind : Env.t -> Types.type_expr -> Lambda.array_kind +val array_kind : Typedtree.expression -> Lambda.array_kind +val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind +val bigarray_type_kind_and_layout : + Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout +val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind +val function_return_value_kind : Env.t -> Types.type_expr -> Lambda.value_kind +*) + +val classify_lazy_argument : Typedtree.expression -> + [ `Constant_or_function + | `Float_that_cannot_be_shortcut + | `Identifier of [`Forward_value | `Other] + | `Other] + +(* +val value_kind_union : + Lambda.value_kind -> Lambda.value_kind -> Lambda.value_kind + (** [value_kind_union k1 k2] is a value_kind at least as general as + [k1] and [k2] *) +*) diff --git a/ocamlmerlin_mlx/ocaml/typing/types.ml b/ocamlmerlin_mlx/ocaml/typing/types.ml new file mode 100644 index 0000000..4bba370 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/types.ml @@ -0,0 +1,921 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Representation of types and declarations *) + +open Asttypes + +(* Type expressions for the core language *) + +type transient_expr = + { mutable desc: type_desc; + mutable level: int; + mutable scope: int; + id: int } + +and type_expr = transient_expr + +and type_desc = + Tvar of string option + | Tarrow of arg_label * type_expr * type_expr * commutable + | Ttuple of type_expr list + | Tconstr of Path.t * type_expr list * abbrev_memo ref + | Tobject of type_expr * (Path.t * type_expr list) option ref + | Tfield of string * field_kind * type_expr * type_expr + | Tnil + | Tlink of type_expr + | Tsubst of type_expr * type_expr option + | Tvariant of row_desc + | Tunivar of string option + | Tpoly of type_expr * type_expr list + | Tpackage of Path.t * (Longident.t * type_expr) list + +and row_desc = + { row_fields: (label * row_field) list; + row_more: type_expr; + row_closed: bool; + row_fixed: fixed_explanation option; + row_name: (Path.t * type_expr list) option } +and fixed_explanation = + | Univar of type_expr | Fixed_private | Reified of Path.t | Rigid +and row_field = [`some] row_field_gen +and _ row_field_gen = + RFpresent : type_expr option -> [> `some] row_field_gen + | RFeither : + { no_arg: bool; + arg_type: type_expr list; + matched: bool; + ext: [`some | `none] row_field_gen ref} -> [> `some] row_field_gen + | RFabsent : [> `some] row_field_gen + | RFnone : [> `none] row_field_gen + +and abbrev_memo = + Mnil + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo + | Mlink of abbrev_memo ref + +and any = [`some | `none | `var] +and field_kind = [`some|`var] field_kind_gen +and _ field_kind_gen = + FKvar : {mutable field_kind: any field_kind_gen} -> [> `var] field_kind_gen + | FKprivate : [> `none] field_kind_gen (* private method; only under FKvar *) + | FKpublic : [> `some] field_kind_gen (* public method *) + | FKabsent : [> `some] field_kind_gen (* hidden private method *) + +and commutable = [`some|`var] commutable_gen +and _ commutable_gen = + Cok : [> `some] commutable_gen + | Cunknown : [> `none] commutable_gen + | Cvar : {mutable commu: any commutable_gen} -> [> `var] commutable_gen + +module TransientTypeOps = struct + type t = type_expr + let compare t1 t2 = t1.id - t2.id + let hash t = t.id + let equal t1 t2 = t1 == t2 +end + +(* *) + +module Uid = Shape.Uid + +(* Maps of methods and instance variables *) + +module MethSet = Misc.String.Set +module VarSet = Misc.String.Set + +module Meths = Misc.String.Map +module Vars = Misc.String.Map + +(* Value descriptions *) + +type value_description = + { val_type: type_expr; (* Type of the value *) + val_kind: value_kind; + val_loc: Location.t; + val_attributes: Parsetree.attributes; + val_uid: Uid.t; + } + +and value_kind = + Val_reg (* Regular value *) + | Val_prim of Primitive.description (* Primitive *) + | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) + | Val_self of + class_signature * self_meths * Ident.t Vars.t * string + (* Self *) + | Val_anc of class_signature * Ident.t Meths.t * string + (* Ancestor *) + +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + +(* Variance *) +(* Variance forms a product lattice of the following partial orders: + 0 <= may_pos <= pos + 0 <= may_weak <= may_neg <= neg + 0 <= inj + Additionally, the following implications are valid + pos => inj + neg => inj + Examples: + type 'a t : may_pos + may_neg + may_weak + type 'a t = 'a : pos + type 'a t = 'a -> unit : neg + type 'a t = ('a -> unit) -> unit : pos + may_weak + type 'a t = A of (('a -> unit) -> unit) : pos + type +'a p = .. : may_pos + inj + type +!'a t : may_pos + inj + type -!'a t : may_neg + inj + type 'a t = A : inj + *) + +module Variance = struct + type t = int + type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv + let single = function + | May_pos -> 1 + | May_neg -> 2 + 4 + | May_weak -> 4 + | Inj -> 8 + | Pos -> 16 + 8 + 1 + | Neg -> 32 + 8 + 4 + 2 + | Inv -> 63 + let union v1 v2 = v1 lor v2 + let inter v1 v2 = v1 land v2 + let subset v1 v2 = (v1 land v2 = v1) + let eq (v1 : t) v2 = (v1 = v2) + let set x v = union v (single x) + let set_if b x v = if b then set x v else v + let mem x = subset (single x) + let null = 0 + let unknown = 7 + let full = single Inv + let covariant = single Pos + let swap f1 f2 v v' = + set_if (mem f2 v) f1 (set_if (mem f1 v) f2 v') + let conjugate v = + let v' = inter v (union (single Inj) (single May_weak)) in + swap Pos Neg v (swap May_pos May_neg v v') + let compose v1 v2 = + if mem Inv v1 && mem Inj v2 then full else + let mp = + mem May_pos v1 && mem May_pos v2 || mem May_neg v1 && mem May_neg v2 + and mn = + mem May_pos v1 && mem May_neg v2 || mem May_neg v1 && mem May_pos v2 + and mw = mem May_weak v1 && v2 <> null || v1 <> null && mem May_weak v2 + and inj = mem Inj v1 && mem Inj v2 + and pos = mem Pos v1 && mem Pos v2 || mem Neg v1 && mem Neg v2 + and neg = mem Pos v1 && mem Neg v2 || mem Neg v1 && mem Pos v2 in + List.fold_left (fun v (b,f) -> set_if b f v) null + [mp, May_pos; mn, May_neg; mw, May_weak; inj, Inj; pos, Pos; neg, Neg] + let strengthen v = + if mem May_neg v then v else v land (full - single May_weak) + let get_upper v = (mem May_pos v, mem May_neg v) + let get_lower v = (mem Pos v, mem Neg v, mem Inj v) + let unknown_signature ~injective ~arity = + let v = if injective then set Inj unknown else unknown in + Misc.replicate_list v arity +end + +module Separability = struct + type t = Ind | Sep | Deepsep + type signature = t list + let eq (m1 : t) m2 = (m1 = m2) + let rank = function + | Ind -> 0 + | Sep -> 1 + | Deepsep -> 2 + let compare m1 m2 = compare (rank m1) (rank m2) + let max m1 m2 = if rank m1 >= rank m2 then m1 else m2 + + let print ppf = function + | Ind -> Format.fprintf ppf "Ind" + | Sep -> Format.fprintf ppf "Sep" + | Deepsep -> Format.fprintf ppf "Deepsep" + + let print_signature ppf modes = + let pp_sep ppf () = Format.fprintf ppf ",@," in + Format.fprintf ppf "@[(%a)@]" + (Format.pp_print_list ~pp_sep print) modes + + let default_signature ~arity = + let default_mode = if Config.flat_float_array then Deepsep else Ind in + Misc.replicate_list default_mode arity +end + +(* Type definitions *) + +type type_declaration = + { type_params: type_expr list; + type_arity: int; + type_kind: type_decl_kind; + type_private: private_flag; + type_manifest: type_expr option; + type_variance: Variance.t list; + type_separability: Separability.t list; + type_is_newtype: bool; + type_expansion_scope: int; + type_loc: Location.t; + type_attributes: Parsetree.attributes; + type_immediate: Type_immediacy.t; + type_unboxed_default: bool; + type_uid: Uid.t; + } + +and type_decl_kind = (label_declaration, constructor_declaration) type_kind + +and ('lbl, 'cstr) type_kind = + Type_abstract + | Type_record of 'lbl list * record_representation + | Type_variant of 'cstr list * variant_representation + | Type_open + +and record_representation = + Record_regular (* All fields are boxed / tagged *) + | Record_float (* All fields are floats *) + | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) + | Record_inlined of int (* Inlined record *) + | Record_extension of Path.t (* Inlined record under extension *) + +and variant_representation = + Variant_regular (* Constant or boxed constructors *) + | Variant_unboxed (* One unboxed single-field constructor *) + +and label_declaration = + { + ld_id: Ident.t; + ld_mutable: mutable_flag; + ld_type: type_expr; + ld_loc: Location.t; + ld_attributes: Parsetree.attributes; + ld_uid: Uid.t; + } + +and constructor_declaration = + { + cd_id: Ident.t; + cd_args: constructor_arguments; + cd_res: type_expr option; + cd_loc: Location.t; + cd_attributes: Parsetree.attributes; + cd_uid: Uid.t; + } + +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of label_declaration list + +type extension_constructor = + { ext_type_path: Path.t; + ext_type_params: type_expr list; + ext_args: constructor_arguments; + ext_ret_type: type_expr option; + ext_private: private_flag; + ext_loc: Location.t; + ext_attributes: Parsetree.attributes; + ext_uid: Uid.t; + } + +and type_transparence = + Type_public (* unrestricted expansion *) + | Type_new (* "new" type *) + | Type_private (* private type *) + +(* Type expressions for the class language *) + +type class_type = + Cty_constr of Path.t * type_expr list * class_type + | Cty_signature of class_signature + | Cty_arrow of arg_label * type_expr * class_type + +type class_declaration = + { cty_params: type_expr list; + mutable cty_type: class_type; + cty_path: Path.t; + cty_new: type_expr option; + cty_variance: Variance.t list; + cty_loc: Location.t; + cty_attributes: Parsetree.attributes; + cty_uid: Uid.t; + } + +type class_type_declaration = + { clty_params: type_expr list; + clty_type: class_type; + clty_path: Path.t; + clty_hash_type: type_declaration; + clty_variance: Variance.t list; + clty_loc: Location.t; + clty_attributes: Parsetree.attributes; + clty_uid: Uid.t; + } + +(* Type expressions for the module language *) + +type visibility = + | Exported + | Hidden + +type module_type = + Mty_ident of Path.t + | Mty_signature of signature + | Mty_functor of functor_parameter * module_type + | Mty_alias of Path.t + | Mty_for_hole + +and functor_parameter = + | Unit + | Named of Ident.t option * module_type + +and module_presence = + | Mp_present + | Mp_absent + +and signature = signature_item list + +and signature_item = + Sig_value of Ident.t * value_description * visibility + | Sig_type of Ident.t * type_declaration * rec_status * visibility + | Sig_typext of Ident.t * extension_constructor * ext_status * visibility + | Sig_module of + Ident.t * module_presence * module_declaration * rec_status * visibility + | Sig_modtype of Ident.t * modtype_declaration * visibility + | Sig_class of Ident.t * class_declaration * rec_status * visibility + | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility + +and module_declaration = + { + md_type: module_type; + md_attributes: Parsetree.attributes; + md_loc: Location.t; + md_uid: Uid.t; + } + +and modtype_declaration = + { + mtd_type: module_type option; (* Note: abstract *) + mtd_attributes: Parsetree.attributes; + mtd_loc: Location.t; + mtd_uid: Uid.t; + } + +and rec_status = + Trec_not (* first in a nonrecursive group *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive/nonrecursive group *) + +and ext_status = + Text_first (* first constructor of an extension *) + | Text_next (* not first constructor of an extension *) + | Text_exception (* an exception *) + + +(* Constructor and record label descriptions inserted held in typing + environments *) + +type constructor_description = + { cstr_name: string; (* Constructor name *) + cstr_res: type_expr; (* Type of the result *) + cstr_existentials: type_expr list; (* list of existentials *) + cstr_args: type_expr list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_generalized: bool; (* Constrained return type? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; + cstr_uid: Uid.t; + } + +and constructor_tag = + Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) + | Cstr_unboxed (* Constructor of an unboxed type *) + | Cstr_extension of Path.t * bool (* Extension constructor + true if a constant false if a block*) + +let equal_tag t1 t2 = + match (t1, t2) with + | Cstr_constant i1, Cstr_constant i2 -> i2 = i1 + | Cstr_block i1, Cstr_block i2 -> i2 = i1 + | Cstr_unboxed, Cstr_unboxed -> true + | Cstr_extension (path1, b1), Cstr_extension (path2, b2) -> + Path.same path1 path2 && b1 = b2 + | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false + +let may_equal_constr c1 c2 = + c1.cstr_arity = c2.cstr_arity + && (match c1.cstr_tag,c2.cstr_tag with + | Cstr_extension _,Cstr_extension _ -> + (* extension constructors may be rebindings of each other *) + true + | tag1, tag2 -> + equal_tag tag1 tag2) + +let item_visibility = function + | Sig_value (_, _, vis) + | Sig_type (_, _, _, vis) + | Sig_typext (_, _, _, vis) + | Sig_module (_, _, _, _, vis) + | Sig_modtype (_, _, vis) + | Sig_class (_, _, _, vis) + | Sig_class_type (_, _, _, vis) -> vis + +type label_description = + { lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + lbl_arg: type_expr; (* Type of the argument *) + lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_pos: int; (* Position in block *) + lbl_all: label_description array; (* All the labels in this type *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + lbl_uid: Uid.t; + } + +let rec bound_value_identifiers = function + [] -> [] + | Sig_value(id, {val_kind = Val_reg}, _) :: rem -> + id :: bound_value_identifiers rem + | Sig_typext(id, _, _, _) :: rem -> id :: bound_value_identifiers rem + | Sig_module(id, Mp_present, _, _, _) :: rem -> + id :: bound_value_identifiers rem + | Sig_class(id, _, _, _) :: rem -> id :: bound_value_identifiers rem + | _ :: rem -> bound_value_identifiers rem + +let signature_item_id = function + | Sig_value (id, _, _) + | Sig_type (id, _, _, _) + | Sig_typext (id, _, _, _) + | Sig_module (id, _, _, _, _) + | Sig_modtype (id, _, _) + | Sig_class (id, _, _, _) + | Sig_class_type (id, _, _, _) + -> id + +(**** Definitions for backtracking ****) + +type change = + Ctype of type_expr * type_desc + | Ccompress of type_expr * type_desc * type_desc + | Clevel of type_expr * int + | Cscope of type_expr * int + | Cname of + (Path.t * type_expr list) option ref * (Path.t * type_expr list) option + | Crow of [`none|`some] row_field_gen ref + | Ckind of [`var] field_kind_gen + | Ccommu of [`var] commutable_gen + | Cuniv of type_expr option ref * type_expr option + | Cfun of (unit -> unit) + +type changes = + Change of change * changes ref + | Unchanged + | Invalid + +open Local_store + +let trail = s_table ref Unchanged + +let log_change ch = + let r' = ref Unchanged in + !trail := Change (ch, r'); + trail := r' + + (* constructor and accessors for [field_kind] *) + + type field_kind_view = + Fprivate + | Fpublic + | Fabsent + + let rec field_kind_internal_repr : field_kind -> field_kind = function + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as fk} -> + field_kind_internal_repr fk + | kind -> kind + + let field_kind_repr fk = + match field_kind_internal_repr fk with + | FKvar _ -> Fprivate + | FKpublic -> Fpublic + | FKabsent -> Fabsent + + let field_public = FKpublic + let field_absent = FKabsent + let field_private () = FKvar {field_kind=FKprivate} + +(* Constructor and accessors for [commutable] *) + +let rec is_commu_ok : type a. a commutable_gen -> bool = function + | Cvar {commu} -> is_commu_ok commu + | Cunknown -> false + | Cok -> true + +let commu_ok = Cok +let commu_var () = Cvar {commu=Cunknown} + +(**** Representative of a type ****) + +let rec repr_link (t : type_expr) d : type_expr -> type_expr = + function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> + log_change (Ccompress (t, t.desc, d)); + t.desc <- d; + t' + +let repr_link1 t = function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> t' + +let repr t = + match t.desc with + Tlink t' -> + repr_link1 t t' + | Tfield (_, k, _, t') when field_kind_internal_repr k = FKabsent -> + repr_link1 t t' + | _ -> t + + +(* getters for type_expr *) + +let get_desc t = (repr t).desc +let get_level t = (repr t).level +let get_scope t = (repr t).scope +let get_id t = (repr t).id + +(* transient type_expr *) + +module Transient_expr = struct + let create desc ~level ~scope ~id = {desc; level; scope; id} + let set_desc ty d = ty.desc <- d + let set_stub_desc ty d = assert (ty.desc = Tvar None); ty.desc <- d + let set_level ty lv = ty.level <- lv + let set_scope ty sc = ty.scope <- sc + let coerce ty = ty + let repr = repr + let type_expr ty = ty +end + +(* Comparison for [type_expr]; cannot be used for functors *) + +let eq_type t1 t2 = t1 == t2 || repr t1 == repr t2 +let compare_type t1 t2 = compare (get_id t1) (get_id t2) + +(* Constructor and accessors for [row_desc] *) + +let create_row ~fields ~more ~closed ~fixed ~name = + { row_fields=fields; row_more=more; + row_closed=closed; row_fixed=fixed; row_name=name } + +(* [row_fields] subsumes the original [row_repr] *) +let rec row_fields row = + match get_desc row.row_more with + | Tvariant row' -> + row.row_fields @ row_fields row' + | _ -> + row.row_fields + +let rec row_repr_no_fields row = + match get_desc row.row_more with + | Tvariant row' -> row_repr_no_fields row' + | _ -> row + +let row_more row = (row_repr_no_fields row).row_more +let row_closed row = (row_repr_no_fields row).row_closed +let row_fixed row = (row_repr_no_fields row).row_fixed +let row_name row = (row_repr_no_fields row).row_name + +let rec get_row_field tag row = + let rec find = function + | (tag',f) :: fields -> + if tag = tag' then f else find fields + | [] -> + match get_desc row.row_more with + | Tvariant row' -> get_row_field tag row' + | _ -> RFabsent + in find row.row_fields + +let set_row_name row row_name = + let row_fields = row_fields row in + let row = row_repr_no_fields row in + {row with row_fields; row_name} + +type row_desc_repr = + Row of { fields: (label * row_field) list; + more:type_expr; + closed:bool; + fixed:fixed_explanation option; + name:(Path.t * type_expr list) option } + +let row_repr row = + let fields = row_fields row in + let row = row_repr_no_fields row in + Row { fields; + more = row.row_more; + closed = row.row_closed; + fixed = row.row_fixed; + name = row.row_name } + +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +let rec row_field_repr_aux tl : row_field -> row_field = function + | RFeither ({ext = {contents = RFnone}} as r) -> + RFeither {r with arg_type = tl@r.arg_type} + | RFeither {arg_type; + ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_repr_aux (tl@arg_type) rf + | RFpresent (Some _) when tl <> [] -> + RFpresent (Some (List.hd tl)) + | RFpresent _ as rf -> rf + | RFabsent -> RFabsent + +let row_field_repr fi = + match row_field_repr_aux [] fi with + | RFeither {no_arg; arg_type; matched} -> Reither (no_arg, arg_type, matched) + | RFpresent t -> Rpresent t + | RFabsent -> Rabsent + +let rec row_field_ext (fi : row_field) = + match fi with + | RFeither {ext = {contents = RFnone} as ext} -> ext + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_ext rf + | _ -> Misc.fatal_error "Types.row_field_ext " + +let rf_present oty = RFpresent oty +let rf_absent = RFabsent +let rf_either ?use_ext_of ~no_arg arg_type ~matched = + let ext = + match use_ext_of with + Some rf -> row_field_ext rf + | None -> ref RFnone + in + RFeither {no_arg; arg_type; matched; ext} + +let rf_either_of = function + | None -> + RFeither {no_arg=true; arg_type=[]; matched=false; ext=ref RFnone} + | Some ty -> + RFeither {no_arg=false; arg_type=[ty]; matched=false; ext=ref RFnone} + +let eq_row_field_ext rf1 rf2 = + row_field_ext rf1 == row_field_ext rf2 + +let changed_row_field_exts l f = + let exts = List.map row_field_ext l in + f (); + List.exists (fun r -> !r <> RFnone) exts + +let match_row_field ~present ~absent ~either (f : row_field) = + match f with + | RFabsent -> absent () + | RFpresent t -> present t + | RFeither {no_arg; arg_type; matched; ext} -> + let e : row_field option = + match !ext with + | RFnone -> None + | RFeither _ | RFpresent _ | RFabsent as e -> Some e + in + either no_arg arg_type matched e + + +(**** Some type creators ****) + +let new_id = Local_store.s_ref (-1) + +let create_expr = Transient_expr.create + +let newty3 ~level ~scope desc = + incr new_id; + create_expr desc ~level ~scope ~id:!new_id + +let newty2 ~level desc = + newty3 ~level ~scope:Ident.lowest_scope desc + + (**********************************) + (* Utilities for backtracking *) + (**********************************) + +let undo_change = function + Ctype (ty, desc) -> Transient_expr.set_desc ty desc + | Ccompress (ty, desc, _) -> Transient_expr.set_desc ty desc + | Clevel (ty, level) -> Transient_expr.set_level ty level + | Cscope (ty, scope) -> Transient_expr.set_scope ty scope + | Cname (r, v) -> r := v + | Crow r -> r := RFnone + | Ckind (FKvar r) -> r.field_kind <- FKprivate + | Ccommu (Cvar r) -> r.commu <- Cunknown + | Cuniv (r, v) -> r := v + | Cfun f -> f () + +type snapshot = changes ref * int +let last_snapshot = Local_store.s_ref 0 +let linked_variables = s_ref 0 + +let log_type ty = + if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) +let link_type ty ty' = + let ty = repr ty in + let ty' = repr ty' in + if ty == ty' then () else begin + log_type ty; + let desc = ty.desc in + (match desc with + | Tvar _ -> incr linked_variables + | _ -> ()); + Transient_expr.set_desc ty (Tlink ty'); + (* Name is a user-supplied name for this unification variable (obtained + * through a type annotation for instance). *) + match desc, ty'.desc with + Tvar name, Tvar name' -> + begin match name, name' with + | Some _, None -> log_type ty'; Transient_expr.set_desc ty' (Tvar name) + | None, Some _ -> () + | Some _, Some _ -> + if ty.level < ty'.level then + (log_type ty'; Transient_expr.set_desc ty' (Tvar name)) + | None, None -> () + end + | _ -> () + end + (* ; assert (check_memorized_abbrevs ()) *) + (* ; check_expans [] ty' *) +(* TODO: consider eliminating set_type_desc, replacing it with link types *) +let set_type_desc ty td = + let ty = repr ty in + if td != ty.desc then begin + log_type ty; + Transient_expr.set_desc ty td + end +(* TODO: separate set_level into two specific functions: *) +(* set_lower_level and set_generic_level *) +let set_level ty level = + let ty = repr ty in + if level <> ty.level then begin + if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); + Transient_expr.set_level ty level + end +(* TODO: introduce a guard and rename it to set_higher_scope? *) +let set_scope ty scope = + let ty = repr ty in + if scope <> ty.scope then begin + if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); + Transient_expr.set_scope ty scope + end +let set_univar rty ty = + log_change (Cuniv (rty, !rty)); rty := Some ty +let set_name nm v = + log_change (Cname (nm, !nm)); nm := v + +let rec link_row_field_ext ~(inside : row_field) (v : row_field) = + match inside with + | RFeither {ext = {contents = RFnone} as e} -> + let RFeither _ | RFpresent _ | RFabsent as v = v in + log_change (Crow e); e := v + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + link_row_field_ext ~inside:rf v + | _ -> invalid_arg "Types.link_row_field_ext" + +let rec link_kind ~(inside : field_kind) (k : field_kind) = + match inside with + | FKvar ({field_kind = FKprivate} as rk) as inside -> + (* prevent a loop by normalizing k and comparing it with inside *) + let FKvar _ | FKpublic | FKabsent as k = field_kind_internal_repr k in + if k != inside then begin + log_change (Ckind inside); + rk.field_kind <- k + end + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as inside} -> + link_kind ~inside k + | _ -> invalid_arg "Types.link_kind" + +let rec commu_repr : commutable -> commutable = function + | Cvar {commu = Cvar _ | Cok as commu} -> commu_repr commu + | c -> c + +let rec link_commu ~(inside : commutable) (c : commutable) = + match inside with + | Cvar ({commu = Cunknown} as rc) as inside -> + (* prevent a loop by normalizing c and comparing it with inside *) + let Cvar _ | Cok as c = commu_repr c in + if c != inside then begin + log_change (Ccommu inside); + rc.commu <- c + end + | Cvar {commu = Cvar _ | Cok as inside} -> + link_commu ~inside c + | _ -> invalid_arg "Types.link_commu" + +let set_commu_ok c = link_commu ~inside:c Cok + +let snapshot () = + let old = !last_snapshot in + last_snapshot := !new_id; + (!trail, old) + +let rec rev_log accu = function + Unchanged -> accu + | Invalid -> assert false + | Change (ch, next) -> + let d = !next in + next := Invalid; + rev_log (ch::accu) d + +let backtrack ~cleanup_abbrev (changes, old) = + match !changes with + Unchanged -> last_snapshot := old + | Invalid -> failwith "Types.backtrack" + | Change _ as change -> + cleanup_abbrev (); + let backlog = rev_log [] change in + List.iter undo_change backlog; + changes := Unchanged; + last_snapshot := old; + trail := changes + +let undo_first_change_after (changes, _) = + match !changes with + | Change (ch, _) -> + undo_change ch + | _ -> () + +let rec rev_compress_log log r = + match !r with + Unchanged | Invalid -> + log + | Change (Ccompress _, next) -> + rev_compress_log (r::log) next + | Change (_, next) -> + rev_compress_log log next + +let undo_compress (changes, _old) = + match !changes with + Unchanged + | Invalid -> () + | Change _ -> + let log = rev_compress_log [] changes in + List.iter + (fun r -> match !r with + Change (Ccompress (ty, desc, d), next) when ty.desc == d -> + Transient_expr.set_desc ty desc; r := !next + | _ -> ()) + log + +(* Merlin specific *) +let linked_variables () = !linked_variables + +let is_valid (changes, _old) = + match !changes with + | Invalid -> false + | _ -> true + +let on_backtrack f = + log_change (Cfun f) + +let unpack_functor = function + | Mty_functor (fp, mty) -> fp, mty + | _ -> invalid_arg "Types.unpack_functor (merlin)" diff --git a/ocamlmerlin_mlx/ocaml/typing/types.mli b/ocamlmerlin_mlx/ocaml/typing/types.mli new file mode 100644 index 0000000..ec8a137 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/types.mli @@ -0,0 +1,746 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** {0 Representation of types and declarations} *) + +(** [Types] defines the representation of types and declarations (that is, the + content of module signatures). + + CMI files are made of marshalled types. +*) + +(** Asttypes exposes basic definitions shared both by Parsetree and Types. *) +open Asttypes + +(** Type expressions for the core language. + + The [type_desc] variant defines all the possible type expressions one can + find in OCaml. [type_expr] wraps this with some annotations. + + The [level] field tracks the level of polymorphism associated to a type, + guiding the generalization algorithm. + Put shortly, when referring to a type in a given environment, both the type + and the environment have a level. If the type has an higher level, then it + can be considered fully polymorphic (type variables will be printed as + ['a]), otherwise it'll be weakly polymorphic, or non generalized (type + variables printed as ['_a]). + See [http://okmij.org/ftp/ML/generalization.html] for more information. + + Note about [type_declaration]: one should not make the confusion between + [type_expr] and [type_declaration]. + + [type_declaration] refers specifically to the [type] construct in OCaml + language, where you create and name a new type or type alias. + + [type_expr] is used when you refer to existing types, e.g. when annotating + the expected type of a value. + + Also, as the type system of OCaml is generative, a [type_declaration] can + have the side-effect of introducing a new type constructor, different from + all other known types. + Whereas [type_expr] is a pure construct which allows referring to existing + types. + + Note on mutability: TBD. + *) +type type_expr +type row_desc +type row_field +type field_kind +type commutable + +type type_desc = + | Tvar of string option + (** [Tvar (Some "a")] ==> ['a] or ['_a] + [Tvar None] ==> [_] *) + + | Tarrow of arg_label * type_expr * type_expr * commutable + (** [Tarrow (Nolabel, e1, e2, c)] ==> [e1 -> e2] + [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1 -> e2] + [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2] + + See [commutable] for the last argument. *) + + | Ttuple of type_expr list + (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *) + + | Tconstr of Path.t * type_expr list * abbrev_memo ref + (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t] + The last parameter keep tracks of known expansions, see [abbrev_memo]. *) + + | Tobject of type_expr * (Path.t * type_expr list) option ref + (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >] + f1, fn are represented as a linked list of types using Tfield and Tnil + constructors. + + [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct]. + where A.ct is the type of some class. + + There are also special cases for so-called "class-types", cf. [Typeclass] + and [Ctype.set_object_name]: + + [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...), + Some(`A.#ct`, [rv;t1;...;tn])] + ==> [(t1, ..., tn) #A.ct] + [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct] + + where [rv] is the hidden row variable. + *) + + | Tfield of string * field_kind * type_expr * type_expr + (** [Tfield ("foo", field_public, t, ts)] ==> [<...; foo : t; ts>] *) + + | Tnil + (** [Tnil] ==> [<...; >] *) + + | Tlink of type_expr + (** Indirection used by unification engine. *) + + | Tsubst of type_expr * type_expr option + (** [Tsubst] is used temporarily to store information in low-level + functions manipulating representation of types, such as + instantiation or copy. + The first argument contains a copy of the original node. + The second is available only when the first is the row variable of + a polymorphic variant. It then contains a copy of the whole variant. + This constructor should not appear outside of these cases. *) + + | Tvariant of row_desc + (** Representation of polymorphic variants, see [row_desc]. *) + + | Tunivar of string option + (** Occurrence of a type variable introduced by a + forall quantifier / [Tpoly]. *) + + | Tpoly of type_expr * type_expr list + (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty], + where 'a1 ... 'an are names given to types in tyl + and occurrences of those types in ty. *) + + | Tpackage of Path.t * (Longident.t * type_expr) list + (** Type of a first-class module (a.k.a package). *) + +and fixed_explanation = + | Univar of type_expr (** The row type was bound to an univar *) + | Fixed_private (** The row type is private *) + | Reified of Path.t (** The row was reified *) + | Rigid (** The row type was made rigid during constraint verification *) + +(** [abbrev_memo] allows one to keep track of different expansions of a type + alias. This is done for performance purposes. + + For instance, when defining [type 'a pair = 'a * 'a], when one refers to an + ['a pair], it is just a shortcut for the ['a * 'a] type. + This expansion will be stored in the [abbrev_memo] of the corresponding + [Tconstr] node. + + In practice, [abbrev_memo] behaves like list of expansions with a mutable + tail. + + Note on marshalling: [abbrev_memo] must not appear in saved types. + [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and + removing abbreviations. +*) +and abbrev_memo = + | Mnil (** No known abbreviation *) + + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo + (** Found one abbreviation. + A valid abbreviation should be at least as visible and reachable by the + same path. + The first expression is the abbreviation and the second the expansion. *) + + | Mlink of abbrev_memo ref + (** Abbreviations can be found after this indirection *) + +(** [commutable] is a flag appended to every arrow type. + + When typing an application, if the type of the functional is + known, its type is instantiated with [commu_ok] arrows, otherwise as + [commu_var ()]. + + When the type is not known, the application will be used to infer + the actual type. This is fragile in presence of labels where + there is no principal type. + + Two incompatible applications must rely on [is_commu_ok] arrows, + otherwise they will trigger an error. + + let f g = + g ~a:() ~b:(); + g ~b:() ~a:(); + + Error: This function is applied to arguments + in an order different from other calls. + This is only allowed when the real type is known. +*) + +val is_commu_ok: commutable -> bool +val commu_ok: commutable +val commu_var: unit -> commutable + +(** [field_kind] indicates the accessibility of a method. + + An [Fprivate] field may become [Fpublic] or [Fabsent] during unification, + but not the other way round. + + The same [field_kind] is kept shared when copying [Tfield] nodes + so that the copies of the self-type of a class share the same accessibility + (see also PR#10539). + *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +val field_kind_repr: field_kind -> field_kind_view +val field_public: field_kind +val field_absent: field_kind +val field_private: unit -> field_kind +val field_kind_internal_repr: field_kind -> field_kind + (* Removes indirections in [field_kind]. + Only needed for performance. *) + +(** Getters for type_expr; calls repr before answering a value *) + +val get_desc: type_expr -> type_desc +val get_level: type_expr -> int +val get_scope: type_expr -> int +val get_id: type_expr -> int + +(** Transient [type_expr]. + Should only be used immediately after [Transient_expr.repr] *) +type transient_expr = private + { mutable desc: type_desc; + mutable level: int; + mutable scope: int; + id: int } + +module Transient_expr : sig + (** Operations on [transient_expr] *) + + val create: type_desc -> level: int -> scope: int -> id: int -> transient_expr + val set_desc: transient_expr -> type_desc -> unit + val set_level: transient_expr -> int -> unit + val set_scope: transient_expr -> int -> unit + val repr: type_expr -> transient_expr + val type_expr: transient_expr -> type_expr + val coerce: type_expr -> transient_expr + (** Coerce without normalizing with [repr] *) + + val set_stub_desc: type_expr -> type_desc -> unit + (** Instantiate a not yet instantiated stub. + Fail if already instantiated. *) +end + +val create_expr: type_desc -> level: int -> scope: int -> id: int -> type_expr + +(** Functions and definitions moved from Btype *) + +val newty3: level:int -> scope:int -> type_desc -> type_expr + (** Create a type with a fresh id *) + +val newty2: level:int -> type_desc -> type_expr + (** Create a type with a fresh id and no scope *) + +module TransientTypeOps : sig + (** Comparisons for functors *) + + type t = transient_expr + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +(** Comparisons for [type_expr]; cannot be used for functors *) + +val eq_type: type_expr -> type_expr -> bool +val compare_type: type_expr -> type_expr -> int + +(** Constructor and accessors for [row_desc] *) + +(** [ `X | `Y ] (row_closed = true) + [< `X | `Y ] (row_closed = true) + [> `X | `Y ] (row_closed = false) + [< `X | `Y > `X ] (row_closed = true) + + type t = [> `X ] as 'a (row_more = Tvar a) + type t = private [> `X ] (row_more = Tconstr ("t#row", [], ref Mnil)) + + And for: + + let f = function `X -> `X -> | `Y -> `X + + the type of "f" will be a [Tarrow] whose lhs will (basically) be: + + Tvariant { row_fields = [("X", _)]; + row_more = + Tvariant { row_fields = [("Y", _)]; + row_more = + Tvariant { row_fields = []; + row_more = _; + _ }; + _ }; + _ + } + +*) + +val create_row: + fields:(label * row_field) list -> + more:type_expr -> + closed:bool -> + fixed:fixed_explanation option -> + name:(Path.t * type_expr list) option -> row_desc + +val row_fields: row_desc -> (label * row_field) list +val row_more: row_desc -> type_expr +val row_closed: row_desc -> bool +val row_fixed: row_desc -> fixed_explanation option +val row_name: row_desc -> (Path.t * type_expr list) option + +val set_row_name: row_desc -> (Path.t * type_expr list) option -> row_desc + +val get_row_field: label -> row_desc -> row_field + +(** get all fields at once; different from the old [row_repr] *) +type row_desc_repr = + Row of { fields: (label * row_field) list; + more: type_expr; + closed: bool; + fixed: fixed_explanation option; + name: (Path.t * type_expr list) option } + +val row_repr: row_desc -> row_desc_repr + +(** Current contents of a row field *) +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +val row_field_repr: row_field -> row_field_view +val rf_present: type_expr option -> row_field +val rf_absent: row_field +val rf_either: + ?use_ext_of:row_field -> + no_arg:bool -> type_expr list -> matched:bool -> row_field +val rf_either_of: type_expr option -> row_field + +val eq_row_field_ext: row_field -> row_field -> bool +val changed_row_field_exts: row_field list -> (unit -> unit) -> bool + +val match_row_field: + present:(type_expr option -> 'a) -> + absent:(unit -> 'a) -> + either:(bool -> type_expr list -> bool -> row_field option ->'a) -> + row_field -> 'a + +(* *) + +module Uid = Shape.Uid + +(* Sets and maps of methods and instance variables *) + +module MethSet : Set.S with type elt = string +module VarSet : Set.S with type elt = string + +module Meths : Map.S with type key = string +module Vars : Map.S with type key = string + +(* Value descriptions *) + +type value_description = + { val_type: type_expr; (* Type of the value *) + val_kind: value_kind; + val_loc: Location.t; + val_attributes: Parsetree.attributes; + val_uid: Uid.t; + } + +and value_kind = + Val_reg (* Regular value *) + | Val_prim of Primitive.description (* Primitive *) + | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) + | Val_self of class_signature * self_meths * Ident.t Vars.t * string + (* Self *) + | Val_anc of class_signature * Ident.t Meths.t * string + (* Ancestor *) + +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + (* The [field_kind] is always [Fabsent] in a complete class type. *) + +(* Variance *) + +module Variance : sig + type t + type f = + May_pos (* allow positive occurrences *) + | May_neg (* allow negative occurrences *) + | May_weak (* allow occurrences under a negative position *) + | Inj (* type is injective in this parameter *) + | Pos (* there is a positive occurrence *) + | Neg (* there is a negative occurrence *) + | Inv (* both negative and positive occurrences *) + val null : t (* no occurrence *) + val full : t (* strictly invariant (all flags) *) + val covariant : t (* strictly covariant (May_pos, Pos and Inj) *) + val unknown : t (* allow everything, guarantee nothing *) + val union : t -> t -> t + val inter : t -> t -> t + val subset : t -> t -> bool + val eq : t -> t -> bool + val set : f -> t -> t + val set_if : bool -> f -> t -> t + val mem : f -> t -> bool + val conjugate : t -> t (* exchange positive and negative *) + val compose : t -> t -> t + val strengthen : t -> t (* remove May_weak when possible *) + val get_upper : t -> bool * bool (* may_pos, may_neg *) + val get_lower : t -> bool * bool * bool (* pos, neg, inj *) + val unknown_signature : injective:bool -> arity:int -> t list + (** The most pessimistic variance for a completely unknown type. *) +end + +module Separability : sig + (** see {!Typedecl_separability} for an explanation of separability + and separability modes.*) + + type t = Ind | Sep | Deepsep + val eq : t -> t -> bool + val print : Format.formatter -> t -> unit + + val rank : t -> int + (** Modes are ordered from the least to the most demanding: + Ind < Sep < Deepsep. + 'rank' maps them to integers in an order-respecting way: + m1 < m2 <=> rank m1 < rank m2 *) + + val compare : t -> t -> int + (** Compare two mode according to their mode ordering. *) + + val max : t -> t -> t + (** [max_mode m1 m2] returns the most demanding mode. It is used to + express the conjunction of two parameter mode constraints. *) + + type signature = t list + (** The 'separability signature' of a type assigns a mode for + each of its parameters. [('a, 'b) t] has mode [(m1, m2)] if + [(t1, t2) t] is separable whenever [t1, t2] have mode [m1, m2]. *) + + val print_signature : Format.formatter -> signature -> unit + + val default_signature : arity:int -> signature + (** The most pessimistic separability for a completely unknown type. *) +end + +(* Type definitions *) + +type type_declaration = + { type_params: type_expr list; + type_arity: int; + type_kind: type_decl_kind; + type_private: private_flag; + type_manifest: type_expr option; + type_variance: Variance.t list; + (* covariant, contravariant, weakly contravariant, injective *) + type_separability: Separability.t list; + type_is_newtype: bool; + type_expansion_scope: int; + type_loc: Location.t; + type_attributes: Parsetree.attributes; + type_immediate: Type_immediacy.t; + type_unboxed_default: bool; + (* true if the unboxed-ness of this type was chosen by a compiler flag *) + type_uid: Uid.t; + } + +and type_decl_kind = (label_declaration, constructor_declaration) type_kind + +and ('lbl, 'cstr) type_kind = + Type_abstract + | Type_record of 'lbl list * record_representation + | Type_variant of 'cstr list * variant_representation + | Type_open + +and record_representation = + Record_regular (* All fields are boxed / tagged *) + | Record_float (* All fields are floats *) + | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) + | Record_inlined of int (* Inlined record *) + | Record_extension of Path.t (* Inlined record under extension *) + (* The argument is the path of the extension *) + +and variant_representation = + Variant_regular (* Constant or boxed constructors *) + | Variant_unboxed (* One unboxed single-field constructor *) + +and label_declaration = + { + ld_id: Ident.t; + ld_mutable: mutable_flag; + ld_type: type_expr; + ld_loc: Location.t; + ld_attributes: Parsetree.attributes; + ld_uid: Uid.t; + } + +and constructor_declaration = + { + cd_id: Ident.t; + cd_args: constructor_arguments; + cd_res: type_expr option; + cd_loc: Location.t; + cd_attributes: Parsetree.attributes; + cd_uid: Uid.t; + } + +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of label_declaration list + +type extension_constructor = + { + ext_type_path: Path.t; + ext_type_params: type_expr list; + ext_args: constructor_arguments; + ext_ret_type: type_expr option; + ext_private: private_flag; + ext_loc: Location.t; + ext_attributes: Parsetree.attributes; + ext_uid: Uid.t; + } + +and type_transparence = + Type_public (* unrestricted expansion *) + | Type_new (* "new" type *) + | Type_private (* private type *) + +(* Type expressions for the class language *) + +type class_type = + Cty_constr of Path.t * type_expr list * class_type + | Cty_signature of class_signature + | Cty_arrow of arg_label * type_expr * class_type + +type class_declaration = + { cty_params: type_expr list; + mutable cty_type: class_type; + cty_path: Path.t; + cty_new: type_expr option; + cty_variance: Variance.t list; + cty_loc: Location.t; + cty_attributes: Parsetree.attributes; + cty_uid: Uid.t; + } + +type class_type_declaration = + { clty_params: type_expr list; + clty_type: class_type; + clty_path: Path.t; + clty_hash_type: type_declaration; (* object type with an open row *) + clty_variance: Variance.t list; + clty_loc: Location.t; + clty_attributes: Parsetree.attributes; + clty_uid: Uid.t; + } + +(* Type expressions for the module language *) + +type visibility = + | Exported + | Hidden + +type module_type = + Mty_ident of Path.t + | Mty_signature of signature + | Mty_functor of functor_parameter * module_type + | Mty_alias of Path.t + | Mty_for_hole + +and functor_parameter = + | Unit + | Named of Ident.t option * module_type + +and module_presence = + | Mp_present + | Mp_absent + +and signature = signature_item list + +and signature_item = + Sig_value of Ident.t * value_description * visibility + | Sig_type of Ident.t * type_declaration * rec_status * visibility + | Sig_typext of Ident.t * extension_constructor * ext_status * visibility + | Sig_module of + Ident.t * module_presence * module_declaration * rec_status * visibility + | Sig_modtype of Ident.t * modtype_declaration * visibility + | Sig_class of Ident.t * class_declaration * rec_status * visibility + | Sig_class_type of Ident.t * class_type_declaration * rec_status * visibility + +and module_declaration = + { + md_type: module_type; + md_attributes: Parsetree.attributes; + md_loc: Location.t; + md_uid: Uid.t; + } + +and modtype_declaration = + { + mtd_type: module_type option; (* None: abstract *) + mtd_attributes: Parsetree.attributes; + mtd_loc: Location.t; + mtd_uid: Uid.t; + } + +and rec_status = + Trec_not (* first in a nonrecursive group *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive/nonrecursive group *) + +and ext_status = + Text_first (* first constructor in an extension *) + | Text_next (* not first constructor in an extension *) + | Text_exception + +val item_visibility : signature_item -> visibility + +(* Constructor and record label descriptions inserted held in typing + environments *) + +type constructor_description = + { cstr_name: string; (* Constructor name *) + cstr_res: type_expr; (* Type of the result *) + cstr_existentials: type_expr list; (* list of existentials *) + cstr_args: type_expr list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_generalized: bool; (* Constrained return type? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; + cstr_uid: Uid.t; + } + +and constructor_tag = + Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) + | Cstr_unboxed (* Constructor of an unboxed type *) + | Cstr_extension of Path.t * bool (* Extension constructor + true if a constant false if a block*) + +(* Constructors are the same *) +val equal_tag : constructor_tag -> constructor_tag -> bool + +(* Constructors may be the same, given potential rebinding *) +val may_equal_constr : + constructor_description -> constructor_description -> bool + +type label_description = + { lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + lbl_arg: type_expr; (* Type of the argument *) + lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_pos: int; (* Position in block *) + lbl_all: label_description array; (* All the labels in this type *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + lbl_uid: Uid.t; + } + +(** Extracts the list of "value" identifiers bound by a signature. + "Value" identifiers are identifiers for signature components that + correspond to a run-time value: values, extensions, modules, classes. + Note: manifest primitives do not correspond to a run-time value! *) +val bound_value_identifiers: signature -> Ident.t list + +val signature_item_id : signature_item -> Ident.t + +(**** Utilities for backtracking ****) + +type snapshot + (* A snapshot for backtracking *) +val snapshot: unit -> snapshot + (* Make a snapshot for later backtracking. Costs nothing *) +val backtrack: cleanup_abbrev:(unit -> unit) -> snapshot -> unit + (* Backtrack to a given snapshot. Only possible if you have + not already backtracked to a previous snapshot. + Calls [cleanup_abbrev] internally *) +val undo_first_change_after: snapshot -> unit + (* Backtrack only the first change after a snapshot. + Does not update the list of changes *) +val undo_compress: snapshot -> unit + (* Backtrack only path compression. Only meaningful if you have + not already backtracked to a previous snapshot. + Does not call [cleanup_abbrev] *) + +(** Functions to use when modifying a type (only Ctype?). + The old values are logged and reverted on backtracking. + *) + +val link_type: type_expr -> type_expr -> unit + (* Set the desc field of [t1] to [Tlink t2], logging the old + value if there is an active snapshot *) +val set_type_desc: type_expr -> type_desc -> unit + (* Set directly the desc field, without sharing *) +val set_level: type_expr -> int -> unit +val set_scope: type_expr -> int -> unit +val set_name: + (Path.t * type_expr list) option ref -> + (Path.t * type_expr list) option -> unit +val link_row_field_ext: inside:row_field -> row_field -> unit + (* Extract the extension variable of [inside] and set it to the + second argument *) +val set_univar: type_expr option ref -> type_expr -> unit +val link_kind: inside:field_kind -> field_kind -> unit +val link_commu: inside:commutable -> commutable -> unit +val set_commu_ok: commutable -> unit + + +(* Merlin specific *) + +(** check if a snapshot has been invalidated *) +val is_valid: snapshot -> bool + +(** also register changes to arbitrary references *) +val on_backtrack: (unit -> unit) -> unit + +(** Number of unification variables that have been linked so far. + Used to estimate the "cost" of unification. *) +val linked_variables: unit -> int + +val unpack_functor : module_type -> functor_parameter * module_type diff --git a/ocamlmerlin_mlx/ocaml/typing/typetexp.ml b/ocamlmerlin_mlx/ocaml/typing/typetexp.ml new file mode 100644 index 0000000..a104ba8 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typetexp.ml @@ -0,0 +1,978 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *) + +(* Typechecking of type expressions for the core language *) + +open Asttypes +open Misc +open Parsetree +open Typedtree +open Types +open Ctype + +exception Already_bound + +type error = + | Unbound_type_variable of string * string list + | No_type_wildcards + | Undefined_type_constructor of Path.t + | Type_arity_mismatch of Longident.t * int * int + | Bound_type_variable of string + | Recursive_type + | Unbound_row_variable of Longident.t + | Type_mismatch of Errortrace.unification_error + | Alias_type_mismatch of Errortrace.unification_error + | Present_has_conjunction of string + | Present_has_no_type of string + | Constructor_mismatch of type_expr * type_expr + | Not_a_variant of type_expr + | Variant_tags of string * string + | Invalid_variable_name of string + | Cannot_quantify of string * type_expr + | Multiple_constraints_on_type of Longident.t + | Method_mismatch of string * type_expr * type_expr + | Opened_object of Path.t option + | Not_an_object of type_expr + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +(** Map indexed by type variable names. *) +module TyVarEnv : sig + val reset : unit -> unit + (* see mli file *) + val is_in_scope : string -> bool + + val add : string -> type_expr -> unit + (* add a global type variable to the environment *) + + val with_local_scope : (unit -> 'a) -> 'a + (* see mli file *) + + type poly_univars + val with_univars : poly_univars -> (unit -> 'a) -> 'a + (* evaluate with a locally extended set of univars *) + + val make_poly_univars : string list -> poly_univars + (* see mli file *) + + val check_poly_univars : Env.t -> Location.t -> poly_univars -> type_expr list + (* see mli file *) + + val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (* see mli file *) + + type policy + val fixed_policy : policy (* no wildcards allowed *) + val extensible_policy : policy (* common case *) + val univars_policy : policy (* fresh variables are univars (in methods) *) + val new_any_var : Location.t -> Env.t -> policy -> type_expr + (* create a new variable to represent a _; fails for fixed_policy *) + val new_var : ?name:string -> policy -> type_expr + (* create a new variable according to the given policy *) + + val add_pre_univar : type_expr -> policy -> unit + (* remember that a variable might become a univar if it isn't unified; + used for checking method types *) + + val collect_univars : (unit -> 'a) -> 'a * type_expr list + (* collect univars during a computation; returns the univars. + The wrapped computation should use [univars_policy]. + postcondition: the returned type_exprs are all Tunivar *) + + val reset_locals : ?univars:poly_univars -> unit -> unit + (* clear out the local type variable env't; call this when starting + a new e.g. type signature. Optionally pass some univars that + are in scope. *) + + val lookup_local : + row_context:type_expr option ref list -> string -> type_expr + (* look up a local type variable; throws Not_found if it isn't in scope *) + + val remember_used : string -> type_expr -> Location.t -> unit + (* remember that a given name is bound to a given type *) + + val globalize_used_variables : policy -> Env.t -> unit -> unit + (* after finishing with a type signature, used variables are unified to the + corresponding global type variables if they exist. Otherwise, in function + of the policy, fresh used variables are either + - added to the global type variable scope if they are not longer + variables under the {!fixed_policy} + - added to the global type variable scope under the {!extensible_policy} + - expected to be collected later by a call to `collect_univar` under the + {!universal_policy} + *) + +end = struct + (** Map indexed by type variable names. *) + module TyVarMap = Misc.String.Map + + let not_generic v = get_level v <> Btype.generic_level + + (* These are the "global" type variables: they were in scope before + we started processing the current type. + *) + let type_variables = ref (TyVarMap.empty : type_expr TyVarMap.t) + + (* These are variables that have been used in the currently-being-checked + type. + *) + let used_variables = + ref (TyVarMap.empty : (type_expr * Location.t) TyVarMap.t) + + (* These are variables we expect to become univars (they were introduced with + e.g. ['a .]), but we need to make sure they don't unify first. Why not + just birth them as univars? Because they might successfully unify with a + row variable in the ['a. < m : ty; .. > as 'a] idiom. They are like the + [used_variables], but will not be globalized in [globalize_used_variables]. + *) + type pending_univar = { + univar: type_expr (** the univar itself *); + mutable associated: type_expr option ref list + (** associated references to row variables that we want to generalize + if possible *) + } + + let univars = ref ([] : (string * pending_univar) list) + let assert_univars uvs = + assert (List.for_all (fun (_name, v) -> not_generic v.univar) uvs) + + (* These are variables that will become univars when we're done with the + current type. Used to force free variables in method types to become + univars. + *) + let pre_univars = ref ([] : type_expr list) + + let reset () = + reset_global_level (); + type_variables := TyVarMap.empty + + let is_in_scope name = + TyVarMap.mem name !type_variables + + let add name v = + assert (not_generic v); + type_variables := TyVarMap.add name v !type_variables + + let narrow () = + (increase_global_level (), !type_variables) + + let widen (gl, tv) = + restore_global_level gl; + type_variables := tv + + let with_local_scope f = + let context = narrow () in + Fun.protect + f + ~finally:(fun () -> widen context) + + (* throws Not_found if the variable is not in scope *) + let lookup_global_type_variable name = + TyVarMap.find name !type_variables + + let get_in_scope_names () = + let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in + TyVarMap.fold add_name !type_variables [] + + (*****) + type poly_univars = (string * pending_univar) list + + let with_univars new_ones f = + assert_univars new_ones; + let old_univars = !univars in + univars := new_ones @ !univars; + Fun.protect + f + ~finally:(fun () -> univars := old_univars) + + let make_poly_univars vars = + let make name = { univar=newvar ~name (); associated = [] } in + List.map (fun name -> name, make name ) vars + + let promote_generics_to_univars promoted vars = + List.fold_left + (fun acc v -> + match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name); + v :: acc + | _ -> acc + ) + promoted vars + + let check_poly_univars env loc vars = + vars |> List.iter (fun (_, p) -> generalize p.univar); + let univars = + vars |> List.map (fun (name, {univar=ty1; _ }) -> + let v = Btype.proxy ty1 in + begin match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name) + | _ -> + raise (Error (loc, env, Cannot_quantify(name, v))) + end; + v) + in + (* Since we are promoting variables to univars in + {!promote_generics_to_univars}, even if a row variable is associated with + multiple univars we will promote it once, when checking the nearest + univar associated to this row variable. + *) + let promote_associated acc (_,v) = + let enclosed_rows = List.filter_map (!) v.associated in + promote_generics_to_univars acc enclosed_rows + in + List.fold_left promote_associated univars vars + + let instance_poly_univars env loc vars = + let vs = check_poly_univars env loc vars in + vs |> List.iter (fun v -> + match get_desc v with + | Tunivar name -> + set_type_desc v (Tvar name) + | _ -> assert false); + vs + + (*****) + let reset_locals ?univars:(uvs=[]) () = + assert_univars uvs; + univars := uvs; + used_variables := TyVarMap.empty + + let associate row_context p = + let add l x = if List.memq x l then l else x :: l in + p.associated <- List.fold_left add row_context p.associated + + (* throws Not_found if the variable is not in scope *) + let lookup_local ~row_context name = + try + let p = List.assoc name !univars in + associate row_context p; + p.univar + with Not_found -> + instance (fst (TyVarMap.find name !used_variables)) + (* This call to instance might be redundant; all variables + inserted into [used_variables] are non-generic, but some + might get generalized. *) + + let remember_used name v loc = + assert (not_generic v); + used_variables := TyVarMap.add name (v, loc) !used_variables + + + type flavor = Unification | Universal + type extensibility = Extensible | Fixed + type policy = { flavor : flavor; extensibility : extensibility } + + let fixed_policy = { flavor = Unification; extensibility = Fixed } + let extensible_policy = { flavor = Unification; extensibility = Extensible } + let univars_policy = { flavor = Universal; extensibility = Extensible } + + let add_pre_univar tv = function + | { flavor = Universal } -> + assert (not_generic tv); + pre_univars := tv :: !pre_univars + | _ -> () + + let collect_univars f = + pre_univars := []; + let result = f () in + let univs = promote_generics_to_univars [] !pre_univars in + result, univs + + let new_var ?name policy = + let tv = Ctype.newvar ?name () in + add_pre_univar tv policy; + tv + + let new_any_var loc env = function + | { extensibility = Fixed } -> raise(Error(loc, env, No_type_wildcards)) + | policy -> new_var policy + + let globalize_used_variables { flavor; extensibility } env = + let r = ref [] in + TyVarMap.iter + (fun name (ty, loc) -> + if flavor = Unification || is_in_scope name then + let v = new_global_var () in + let snap = Btype.snapshot () in + if try unify env v ty; true with _ -> Btype.backtrack snap; false + then try + r := (loc, v, lookup_global_type_variable name) :: !r + with Not_found -> + if extensibility = Fixed && Btype.is_Tvar ty then + raise(Error(loc, env, + Unbound_type_variable ("'"^name, + get_in_scope_names ()))); + let v2 = new_global_var () in + r := (loc, v, v2) :: !r; + add name v2) + !used_variables; + used_variables := TyVarMap.empty; + fun () -> + List.iter + (function (loc, t1, t2) -> + try unify env t1 t2 with Unify err -> + raise (Error(loc, env, Type_mismatch err))) + !r +end + +(* Support for first-class modules. *) + +let transl_modtype_longident = ref (fun _ -> assert false) +let transl_modtype = ref (fun _ -> assert false) + +let sort_constraints_no_duplicates loc env l = + List.sort + (fun (s1, _t1) (s2, _t2) -> + if s1.txt = s2.txt then + raise (Error (loc, env, Multiple_constraints_on_type s1.txt)); + compare s1.txt s2.txt) + l + +let create_package_mty loc p l = + List.fold_left + (fun mty (s, _) -> + let d = {ptype_name = mkloc (Longident.last s.txt) s.loc; + ptype_params = []; + ptype_cstrs = []; + ptype_kind = Ptype_abstract; + ptype_private = Asttypes.Public; + ptype_manifest = None; + ptype_attributes = []; + ptype_loc = loc} in + Ast_helper.Mty.mk ~loc + (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ])) + ) + (Ast_helper.Mty.mk ~loc (Pmty_ident p)) + l + +(* Translation of type expressions *) + +let generalize_ctyp typ = generalize typ.ctyp_type + +let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z') + +let validate_name = function + None -> None + | Some name as s -> + if name <> "" && strict_ident name.[0] then s else None + +let new_global_var ?name () = + new_global_var ?name:(validate_name name) () +let newvar ?name () = + newvar ?name:(validate_name name) () + +let valid_tyvar_name name = + name <> "" && name.[0] <> '_' + +let transl_type_param env styp = + let loc = styp.ptyp_loc in + match styp.ptyp_desc with + Ptyp_any -> + let ty = new_global_var ~name:"_" () in + { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env; + ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } + | Ptyp_var name -> + let ty = + if not (valid_tyvar_name name) then + raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); + if TyVarEnv.is_in_scope name then + raise Already_bound; + let v = new_global_var ~name () in + TyVarEnv.add name v; + v + in + { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env; + ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } + | _ -> assert false + +let transl_type_param env styp = + (* Currently useless, since type parameters cannot hold attributes + (but this could easily be lifted in the future). *) + Builtin_attributes.warning_scope styp.ptyp_attributes + (fun () -> transl_type_param env styp) + +let rec transl_type env ~policy ?(aliased=false) ~row_context styp = + Msupport.with_saved_types + ~warning_attribute:styp.ptyp_attributes ?save_part:None + (fun () -> + try + transl_type_aux env ~policy ~aliased ~row_context styp + with exn -> + let ty = new_global_var () in + Msupport.erroneous_type_register ty; + Msupport.raise_error exn; + { ctyp_desc = Ttyp_any; + ctyp_type = ty; + ctyp_env = env; + ctyp_loc = styp.ptyp_loc; + ctyp_attributes = []; + } + ) + +and transl_type_aux env ~row_context ~aliased ~policy styp = + let loc = styp.ptyp_loc in + let ctyp ctyp_desc ctyp_type = + { ctyp_desc; ctyp_type; ctyp_env = env; + ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes } + in + match styp.ptyp_desc with + Ptyp_any -> + let ty = TyVarEnv.new_any_var styp.ptyp_loc env policy in + ctyp Ttyp_any ty + | Ptyp_var name -> + let ty = + if not (valid_tyvar_name name) then + raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name))); + begin try + TyVarEnv.lookup_local ~row_context:row_context name + with Not_found -> + let v = TyVarEnv.new_var ~name policy in + TyVarEnv.remember_used name v styp.ptyp_loc; + v + end + in + ctyp (Ttyp_var name) ty + | Ptyp_arrow(l, st1, st2) -> + let cty1 = transl_type env ~policy ~row_context st1 in + let cty2 = transl_type env ~policy ~row_context st2 in + let ty1 = cty1.ctyp_type in + let ty1 = + if Btype.is_optional l + then newty (Tconstr(Predef.path_option,[ty1], ref Mnil)) + else ty1 in + let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, commu_ok)) in + ctyp (Ttyp_arrow (l, cty1, cty2)) ty + | Ptyp_tuple stl -> + assert (List.length stl >= 2); + let ctys = List.map (transl_type env ~policy ~row_context) stl in + let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in + ctyp (Ttyp_tuple ctys) ty + | Ptyp_constr(lid, stl) -> + let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in + let stl = + match stl with + | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 -> + List.map (fun _ -> t) decl.type_params + | _ -> stl + in + if List.length stl <> decl.type_arity then + raise(Error(styp.ptyp_loc, env, + Type_arity_mismatch(lid.txt, decl.type_arity, + List.length stl))); + let args = List.map (transl_type env ~policy ~row_context) stl in + let params = instance_list decl.type_params in + let unify_param = + match decl.type_manifest with + None -> unify_var + | Some ty -> + if get_level ty = Btype.generic_level then unify_var else unify + in + List.iter2 + (fun (sty, cty) ty' -> + try unify_param env ty' cty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) + ) + (List.combine stl args) params; + let constr = + newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in + ctyp (Ttyp_constr (path, lid, args)) constr + | Ptyp_object (fields, o) -> + let ty, fields = transl_fields env ~policy ~row_context o fields in + ctyp (Ttyp_object (fields, o)) (newobj ty) + | Ptyp_class(lid, stl) -> + let (path, decl) = + let path, decl = Env.lookup_cltype ~loc:lid.loc lid.txt env in + (path, decl.clty_hash_type) + in + if List.length stl <> decl.type_arity then + raise(Error(styp.ptyp_loc, env, + Type_arity_mismatch(lid.txt, decl.type_arity, + List.length stl))); + let args = List.map (transl_type env ~policy ~row_context) stl in + let body = Option.get decl.type_manifest in + let (params, body) = instance_parameterized_type decl.type_params body in + List.iter2 + (fun (sty, cty) ty' -> + try unify_var env ty' cty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) + ) + (List.combine stl args) params; + let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in + let ty = Ctype.apply ~use_current_level:true env params body ty_args in + let ty = match get_desc ty with + | Tobject (fi, _) -> + let _, tv = flatten_fields fi in + TyVarEnv.add_pre_univar tv policy; + ty + | _ -> + assert false + in + ctyp (Ttyp_class (path, lid, args)) ty + | Ptyp_alias(st, alias) -> + let cty = + try + let t = TyVarEnv.lookup_local ~row_context alias in + let ty = transl_type env ~policy ~aliased:true ~row_context st in + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) + end; + ty + with Not_found -> + let t, ty = + with_local_level_if_principal begin fun () -> + let t = newvar () in + TyVarEnv.remember_used alias t styp.ptyp_loc; + let ty = transl_type env ~policy ~row_context st in + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) + end; + (t, ty) + end + ~post: (fun (t, _) -> generalize_structure t) + in + let t = instance t in + let px = Btype.proxy t in + begin match get_desc px with + | Tvar None -> set_type_desc px (Tvar (Some alias)) + | Tunivar None -> set_type_desc px (Tunivar (Some alias)) + | _ -> () + end; + { ty with ctyp_type = t } + in + ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type + | Ptyp_variant(fields, closed, present) -> + let name = ref None in + let mkfield l f = + newty (Tvariant (create_row ~fields:[l,f] ~more:(newvar()) + ~closed:true ~fixed:None ~name:None)) in + let hfields = Hashtbl.create 17 in + let add_typed_field loc l f = + let h = Btype.hash_variant l in + try + let (l',f') = Hashtbl.find hfields h in + (* Check for tag conflicts *) + if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l'))); + let ty = mkfield l f and ty' = mkfield l f' in + if is_equal env false [ty] [ty'] then () else + try unify env ty ty' + with Unify _trace -> + raise(Error(loc, env, Constructor_mismatch (ty,ty'))) + with Not_found -> + Hashtbl.add hfields h (l,f) + in + let add_field row_context field = + let rf_loc = field.prf_loc in + let rf_attributes = field.prf_attributes in + let rf_desc = match field.prf_desc with + | Rtag (l, c, stl) -> + name := None; + let tl = + Builtin_attributes.warning_scope rf_attributes + (fun () -> List.map (transl_type env ~policy ~row_context) stl) + in + let f = match present with + Some present when not (List.mem l.txt present) -> + let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in + rf_either ty_tl ~no_arg:c ~matched:false + | _ -> + if List.length stl > 1 || c && stl <> [] then + raise(Error(styp.ptyp_loc, env, + Present_has_conjunction l.txt)); + match tl with [] -> rf_present None + | st :: _ -> rf_present (Some st.ctyp_type) + in + add_typed_field styp.ptyp_loc l.txt f; + Ttag (l,c,tl) + | Rinherit sty -> + let cty = transl_type env ~policy ~row_context sty in + let ty = cty.ctyp_type in + let nm = + match get_desc cty.ctyp_type with + Tconstr(p, tl, _) -> Some(p, tl) + | _ -> None + in + name := if Hashtbl.length hfields <> 0 then None else nm; + let fl = match get_desc (expand_head env cty.ctyp_type), nm with + Tvariant row, _ when Btype.static_row row -> + row_fields row + | Tvar _, Some(p, _) -> + raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p)) + | _ -> + raise(Error(sty.ptyp_loc, env, Not_a_variant ty)) + in + List.iter + (fun (l, f) -> + let f = match present with + Some present when not (List.mem l present) -> + begin match row_field_repr f with + Rpresent oty -> rf_either_of oty + | _ -> assert false + end + | _ -> f + in + add_typed_field sty.ptyp_loc l f) + fl; + Tinherit cty + in + { rf_desc; rf_loc; rf_attributes; } + in + let more_slot = ref None in + let row_context = + if aliased then row_context else more_slot :: row_context + in + let tfields = List.map (add_field row_context) fields in + let fields = List.rev (Hashtbl.fold (fun _ p l -> p :: l) hfields []) in + begin match present with None -> () + | Some present -> + List.iter + (fun l -> if not (List.mem_assoc l fields) then + raise(Error(styp.ptyp_loc, env, Present_has_no_type l))) + present + end; + let name = !name in + let make_row more = + create_row ~fields ~more ~closed:(closed = Closed) ~fixed:None ~name + in + let more = + if Btype.static_row (make_row (newvar ())) then newty Tnil else + TyVarEnv.new_var policy + in + more_slot := Some more; + let ty = newty (Tvariant (make_row more)) in + ctyp (Ttyp_variant (tfields, closed, present)) ty + | Ptyp_poly(vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + let new_univars, cty = + with_local_level begin fun () -> + let new_univars = TyVarEnv.make_poly_univars vars in + let cty = TyVarEnv.with_univars new_univars begin fun () -> + transl_type env ~policy ~row_context st + end in + (new_univars, cty) + end + ~post:(fun (_,cty) -> generalize_ctyp cty) + in + let ty = cty.ctyp_type in + let ty_list = TyVarEnv.check_poly_univars env styp.ptyp_loc new_univars in + let ty_list = List.filter (fun v -> deep_occur v ty) ty_list in + let ty' = Btype.newgenty (Tpoly(ty, ty_list)) in + unify_var env (newvar()) ty'; + ctyp (Ttyp_poly (vars, cty)) ty' + | Ptyp_package (p, l) -> + let loc = styp.ptyp_loc in + let l = sort_constraints_no_duplicates loc env l in + let mty = create_package_mty loc p l in + let mty = + TyVarEnv.with_local_scope (fun () -> !transl_modtype env mty) in + let ptys = List.map (fun (s, pty) -> + s, transl_type env ~policy ~row_context pty + ) l in + let path = !transl_modtype_longident loc env p.txt in + let ty = newty (Tpackage (path, + List.map (fun (s, cty) -> (s.txt, cty.ctyp_type)) ptys)) + in + ctyp (Ttyp_package { + pack_path = path; + pack_type = mty.mty_type; + pack_fields = ptys; + pack_txt = p; + }) ty + | Ptyp_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and transl_fields env ~policy ~row_context o fields = + let hfields = Hashtbl.create 17 in + let add_typed_field loc l ty = + try + let ty' = Hashtbl.find hfields l in + if is_equal env false [ty] [ty'] then () else + try unify env ty ty' + with Unify _trace -> + raise(Error(loc, env, Method_mismatch (l, ty, ty'))) + with Not_found -> + Hashtbl.add hfields l ty in + let add_field {pof_desc; pof_loc; pof_attributes;} = + let of_loc = pof_loc in + let of_attributes = pof_attributes in + let of_desc = match pof_desc with + | Otag (s, ty1) -> begin + let ty1 = + Builtin_attributes.warning_scope of_attributes + (fun () -> transl_type env ~policy ~row_context + (Ast_helper.Typ.force_poly ty1)) + in + let field = OTtag (s, ty1) in + add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type; + field + end + | Oinherit sty -> begin + let cty = transl_type env ~policy ~row_context sty in + let nm = + match get_desc cty.ctyp_type with + Tconstr(p, _, _) -> Some p + | _ -> None in + let t = expand_head env cty.ctyp_type in + match get_desc t, nm with + Tobject (tf, _), _ + when (match get_desc tf with Tfield _ | Tnil -> true | _ -> false) -> + begin + if opened_object t then + raise (Error (sty.ptyp_loc, env, Opened_object nm)); + let rec iter_add ty = + match get_desc ty with + | Tfield (s, _k, ty1, ty2) -> + add_typed_field sty.ptyp_loc s ty1; + iter_add ty2 + | Tnil -> () + | _ -> assert false + in + iter_add tf; + OTinherit cty + end + | Tvar _, Some p -> + raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p)) + | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t)) + end in + { of_desc; of_loc; of_attributes; } + in + let object_fields = List.map add_field fields in + let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in + let ty_init = + match o with + | Closed -> newty Tnil + | Open -> TyVarEnv.new_var policy + in + let ty = List.fold_left (fun ty (s, ty') -> + newty (Tfield (s, field_public, ty', ty))) ty_init fields in + ty, object_fields + +let transl_type env policy styp = + transl_type env ~policy ~row_context:[] styp + +(* Make the rows "fixed" in this type, to make universal check easier *) +let rec make_fixed_univars ty = + if Btype.try_mark_node ty then + begin match get_desc ty with + | Tvariant row -> + let Row {fields; more; name; closed} = row_repr row in + if Btype.is_Tunivar more then + let fields = + List.map + (fun (s,f as p) -> match row_field_repr f with + Reither (no_arg, tl, _m) -> + s, rf_either tl ~use_ext_of:f ~no_arg ~matched:true + | _ -> p) + fields + in + set_type_desc ty + (Tvariant + (create_row ~fields ~more ~name ~closed + ~fixed:(Some (Univar more)))); + Btype.iter_row make_fixed_univars row + | _ -> + Btype.iter_type_expr make_fixed_univars ty + end + +let make_fixed_univars ty = + make_fixed_univars ty; + Btype.unmark_type ty + +let transl_simple_type env ?univars ~closed styp = + TyVarEnv.reset_locals ?univars (); + let policy = TyVarEnv.(if closed then fixed_policy else extensible_policy) in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); + make_fixed_univars typ.ctyp_type; + typ + +let transl_simple_type_univars env styp = + TyVarEnv.reset_locals (); + let typ, univs = + TyVarEnv.collect_univars begin fun () -> + with_local_level ~post:generalize_ctyp begin fun () -> + let policy = TyVarEnv.univars_policy in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); + typ + end + end in + make_fixed_univars typ.ctyp_type; + { typ with ctyp_type = + instance (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) } + +let transl_simple_type_delayed env styp = + TyVarEnv.reset_locals (); + let typ, force = + with_local_level begin fun () -> + let policy = TyVarEnv.extensible_policy in + let typ = transl_type env policy styp in + make_fixed_univars typ.ctyp_type; + (* This brings the used variables to the global level, but doesn't link + them to their other occurrences just yet. This will be done when + [force] is called. *) + let force = TyVarEnv.globalize_used_variables policy env in + (typ, force) + end + (* Generalize everything except the variables that were just globalized. *) + ~post:(fun (typ,_) -> generalize_ctyp typ) + in + (typ, instance typ.ctyp_type, force) + +let transl_type_scheme env styp = + match styp.ptyp_desc with + | Ptyp_poly (vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + let univars, typ = + with_local_level begin fun () -> + TyVarEnv.reset (); + let univars = TyVarEnv.make_poly_univars vars in + let typ = transl_simple_type env ~univars ~closed:true st in + (univars, typ) + end + ~post:(fun (_,typ) -> generalize_ctyp typ) + in + let _ = TyVarEnv.instance_poly_univars env styp.ptyp_loc univars in + { ctyp_desc = Ttyp_poly (vars, typ); + ctyp_type = typ.ctyp_type; + ctyp_env = env; + ctyp_loc = styp.ptyp_loc; + ctyp_attributes = styp.ptyp_attributes } + | _ -> + with_local_level + (fun () -> TyVarEnv.reset (); transl_simple_type env ~closed:false styp) + ~post:generalize_ctyp + + +(* Error report *) + +open Format +open Printtyp + +let report_error env ppf = function + | Unbound_type_variable (name, in_scope_names) -> + fprintf ppf "The type variable %s is unbound in this type declaration.@ %a" + name + did_you_mean (fun () -> Misc.spellcheck in_scope_names name ) + | No_type_wildcards -> + fprintf ppf "A type wildcard \"_\" is not allowed in this type declaration." + | Undefined_type_constructor p -> + fprintf ppf "The type constructor@ %a@ is not yet completely defined" + path p + | Type_arity_mismatch(lid, expected, provided) -> + fprintf ppf + "@[The type constructor %a@ expects %i argument(s),@ \ + but is here applied to %i argument(s)@]" + longident lid expected provided + | Bound_type_variable name -> + fprintf ppf "Already bound type parameter %a" Pprintast.tyvar name + | Recursive_type -> + fprintf ppf "This type is recursive" + | Unbound_row_variable lid -> + (* we don't use "spellcheck" here: this error is not raised + anywhere so it's unclear how it should be handled *) + fprintf ppf "Unbound row variable in #%a" longident lid + | Type_mismatch trace -> + Printtyp.report_unification_error ppf Env.empty trace + (function ppf -> + fprintf ppf "This type") + (function ppf -> + fprintf ppf "should be an instance of type") + | Alias_type_mismatch trace -> + Printtyp.report_unification_error ppf Env.empty trace + (function ppf -> + fprintf ppf "This alias is bound to type") + (function ppf -> + fprintf ppf "but is used as an instance of type") + | Present_has_conjunction l -> + fprintf ppf "The present constructor %s has a conjunctive type" l + | Present_has_no_type l -> + fprintf ppf + "@[@[The constructor %s is missing from the upper bound@ \ + (between '<'@ and '>')@ of this polymorphic variant@ \ + but is present in@ its lower bound (after '>').@]@,\ + @[@{Hint@}: Either add `%s in the upper bound,@ \ + or remove it@ from the lower bound.@]@]" + l l + | Constructor_mismatch (ty, ty') -> + wrap_printing_env ~error:true env (fun () -> + Printtyp.prepare_for_printing [ty; ty']; + fprintf ppf "@[%s %a@ %s@ %a@]" + "This variant type contains a constructor" + !Oprint.out_type (tree_of_typexp Type ty) + "which should be" + !Oprint.out_type (tree_of_typexp Type ty')) + | Not_a_variant ty -> + fprintf ppf + "@[The type %a@ does not expand to a polymorphic variant type@]" + Printtyp.type_expr ty; + begin match get_desc ty with + | Tvar (Some s) -> + (* PR#7012: help the user that wrote 'Foo instead of `Foo *) + Misc.did_you_mean ppf (fun () -> ["`" ^ s]) + | _ -> () + end + | Variant_tags (lab1, lab2) -> + fprintf ppf + "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]" + lab1 lab2 "Change one of them." + | Invalid_variable_name name -> + fprintf ppf "The type variable name %s is not allowed in programs" name + | Cannot_quantify (name, v) -> + fprintf ppf + "@[The universal type variable %a cannot be generalized:@ " + Pprintast.tyvar name; + if Btype.is_Tvar v then + fprintf ppf "it escapes its scope" + else if Btype.is_Tunivar v then + fprintf ppf "it is already bound to another variable" + else + fprintf ppf "it is bound to@ %a" Printtyp.type_expr v; + fprintf ppf ".@]"; + | Multiple_constraints_on_type s -> + fprintf ppf "Multiple constraints for type %a" longident s + | Method_mismatch (l, ty, ty') -> + wrap_printing_env ~error:true env (fun () -> + fprintf ppf "@[Method '%s' has type %a,@ which should be %a@]" + l Printtyp.type_expr ty Printtyp.type_expr ty') + | Opened_object nm -> + fprintf ppf + "Illegal open object type%a" + (fun ppf -> function + Some p -> fprintf ppf "@ %a" path p + | None -> fprintf ppf "") nm + | Not_an_object ty -> + fprintf ppf "@[The type %a@ is not an object type@]" + Printtyp.type_expr ty + +let () = + Location.register_error_of_exn + (function + | Error (loc, env, err) -> + Some (Location.error_of_printer ~loc (report_error env) err) + | Error_forward err -> + Some err + | _ -> + None + ) diff --git a/ocamlmerlin_mlx/ocaml/typing/typetexp.mli b/ocamlmerlin_mlx/ocaml/typing/typetexp.mli new file mode 100644 index 0000000..ca058a5 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/typetexp.mli @@ -0,0 +1,99 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Typechecking of type expressions for the core language *) + +open Types + +module TyVarEnv : sig + (* this is just the subset of [TyVarEnv] that is needed outside + of [Typetexp]. See the ml file for more. *) + + val reset : unit -> unit + (** removes all type variables from scope *) + + val with_local_scope : (unit -> 'a) -> 'a + (** Evaluate in a narrowed type-variable scope *) + + type poly_univars + val make_poly_univars : string list -> poly_univars + (** remember that a list of strings connotes univars; this must + always be paired with a [check_poly_univars]. *) + + val check_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (** Verify that the given univars are universally quantified, + and return the list of variables. The type in which the + univars are used must be generalised *) + + val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (** Same as [check_poly_univars], but instantiates the resulting + type scheme (i.e. variables become Tvar rather than Tunivar) *) + +end + +val valid_tyvar_name : string -> bool + +val transl_simple_type: + Env.t -> ?univars:TyVarEnv.poly_univars -> closed:bool + -> Parsetree.core_type -> Typedtree.core_type +val transl_simple_type_univars: + Env.t -> Parsetree.core_type -> Typedtree.core_type +val transl_simple_type_delayed + : Env.t + -> Parsetree.core_type + -> Typedtree.core_type * type_expr * (unit -> unit) + (* Translate a type, but leave type variables unbound. Returns + the type, an instance of the corresponding type_expr, and a + function that binds the type variable. *) +val transl_type_scheme: + Env.t -> Parsetree.core_type -> Typedtree.core_type +val transl_type_param: + Env.t -> Parsetree.core_type -> Typedtree.core_type + +exception Already_bound + +type error = + | Unbound_type_variable of string * string list + | No_type_wildcards + | Undefined_type_constructor of Path.t + | Type_arity_mismatch of Longident.t * int * int + | Bound_type_variable of string + | Recursive_type + | Unbound_row_variable of Longident.t + | Type_mismatch of Errortrace.unification_error + | Alias_type_mismatch of Errortrace.unification_error + | Present_has_conjunction of string + | Present_has_no_type of string + | Constructor_mismatch of type_expr * type_expr + | Not_a_variant of type_expr + | Variant_tags of string * string + | Invalid_variable_name of string + | Cannot_quantify of string * type_expr + | Multiple_constraints_on_type of Longident.t + | Method_mismatch of string * type_expr * type_expr + | Opened_object of Path.t option + | Not_an_object of type_expr + +exception Error of Location.t * Env.t * error + +val report_error: Env.t -> Format.formatter -> error -> unit + +(* Support for first-class modules. *) +val transl_modtype_longident: (* from Typemod *) + (Location.t -> Env.t -> Longident.t -> Path.t) ref +val transl_modtype: (* from Typemod *) + (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref diff --git a/ocamlmerlin_mlx/ocaml/typing/untypeast.ml b/ocamlmerlin_mlx/ocaml/typing/untypeast.ml new file mode 100644 index 0000000..5bf9119 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/untypeast.ml @@ -0,0 +1,927 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Longident +open Asttypes +open Parsetree +open Ast_helper + +module T = Typedtree + +type mapper = { + attribute: mapper -> T.attribute -> attribute; + attributes: mapper -> T.attribute list -> attribute list; + binding_op: mapper -> T.binding_op -> T.pattern -> binding_op; + case: 'k . mapper -> 'k T.case -> case; + class_declaration: mapper -> T.class_declaration -> class_declaration; + class_description: mapper -> T.class_description -> class_description; + class_expr: mapper -> T.class_expr -> class_expr; + class_field: mapper -> T.class_field -> class_field; + class_signature: mapper -> T.class_signature -> class_signature; + class_structure: mapper -> T.class_structure -> class_structure; + class_type: mapper -> T.class_type -> class_type; + class_type_declaration: mapper -> T.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> T.class_type_field -> class_type_field; + constructor_declaration: mapper -> T.constructor_declaration + -> constructor_declaration; + expr: mapper -> T.expression -> expression; + extension_constructor: mapper -> T.extension_constructor + -> extension_constructor; + include_declaration: mapper -> T.include_declaration -> include_declaration; + include_description: mapper -> T.include_description -> include_description; + label_declaration: mapper -> T.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> T.module_binding -> module_binding; + module_declaration: mapper -> T.module_declaration -> module_declaration; + module_substitution: mapper -> T.module_substitution -> module_substitution; + module_expr: mapper -> T.module_expr -> module_expr; + module_type: mapper -> T.module_type -> module_type; + module_type_declaration: + mapper -> T.module_type_declaration -> module_type_declaration; + package_type: mapper -> T.package_type -> package_type; + open_declaration: mapper -> T.open_declaration -> open_declaration; + open_description: mapper -> T.open_description -> open_description; + pat: 'k . mapper -> 'k T.general_pattern -> pattern; + row_field: mapper -> T.row_field -> row_field; + object_field: mapper -> T.object_field -> object_field; + signature: mapper -> T.signature -> signature; + signature_item: mapper -> T.signature_item -> signature_item; + structure: mapper -> T.structure -> structure; + structure_item: mapper -> T.structure_item -> structure_item; + typ: mapper -> T.core_type -> core_type; + type_declaration: mapper -> T.type_declaration -> type_declaration; + type_extension: mapper -> T.type_extension -> type_extension; + type_exception: mapper -> T.type_exception -> type_exception; + type_kind: mapper -> T.type_kind -> type_kind; + value_binding: mapper -> T.value_binding -> value_binding; + value_description: mapper -> T.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * T.with_constraint) + -> with_constraint; +} + +open T + +(* +Some notes: + + * For Pexp_function, we cannot go back to the exact original version + when there is a default argument, because the default argument is + translated in the typer. The code, if printed, will not be parsable because + new generated identifiers are not correct. + + * For Pexp_apply, it is unclear whether arguments are reordered, especially + when there are optional arguments. + +*) + + +(** Utility functions. *) + +let string_is_prefix sub str = + let sublen = String.length sub in + String.length str >= sublen && String.sub str 0 sublen = sub + +let rec lident_of_path = function + | Path.Pident id -> Longident.Lident (Ident.name id) + | Path.Papply (p1, p2) -> + Longident.Lapply (lident_of_path p1, lident_of_path p2) + | Path.Pdot (p, s) | Path.Pextra_ty (p, Pcstr_ty s) -> + Longident.Ldot (lident_of_path p, s) + | Path.Pextra_ty (p, _) -> lident_of_path p + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +(** Try a name [$name$0], check if it's free, if not, increment and repeat. *) +let fresh_name s env = + let name i = s ^ Int.to_string i in + let available i = not (Env.bound_value (name i) env) in + let first_i = Misc.find_first_mono available in + name first_i + +(** Extract the [n] patterns from the case of a letop *) +let rec extract_letop_patterns n pat = + if n = 0 then pat, [] + else begin + match pat.pat_desc with + | Tpat_tuple([first; rest]) -> + let next, others = extract_letop_patterns (n-1) rest in + first, next :: others + | _ -> + let rec anys n = + if n = 0 then [] + else { pat with pat_desc = Tpat_any } :: anys (n-1) + in + { pat with pat_desc = Tpat_any }, anys (n-1) + end + +(** Mapping functions. *) + +let constant = function + | Const_char c -> Pconst_char c + | Const_string (s,loc,d) -> Pconst_string (s,loc,d) + | Const_int i -> Pconst_integer (Int.to_string i, None) + | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') + | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') + | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n') + | Const_float f -> Pconst_float (f,None) + +let attribute sub a = { + attr_name = map_loc sub a.attr_name; + attr_payload = a.attr_payload; + attr_loc = a.attr_loc + } + +let attributes sub l = List.map (sub.attribute sub) l + +let structure sub str = + List.map (sub.structure_item sub) str.str_items + +let open_description sub od = + let loc = sub.location sub od.open_loc in + let attrs = sub.attributes sub od.open_attributes in + Opn.mk ~loc ~attrs + ~override:od.open_override + (snd od.open_expr) + +let open_declaration sub od = + let loc = sub.location sub od.open_loc in + let attrs = sub.attributes sub od.open_attributes in + Opn.mk ~loc ~attrs + ~override:od.open_override + (sub.module_expr sub od.open_expr) + +let structure_item sub item = + let loc = sub.location sub item.str_loc in + let desc = + match item.str_desc with + Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs) + | Tstr_value (rec_flag, list) -> + Pstr_value (rec_flag, List.map (sub.value_binding sub) list) + | Tstr_primitive vd -> + Pstr_primitive (sub.value_description sub vd) + | Tstr_type (rec_flag, list) -> + Pstr_type (rec_flag, List.map (sub.type_declaration sub) list) + | Tstr_typext tyext -> + Pstr_typext (sub.type_extension sub tyext) + | Tstr_exception ext -> + Pstr_exception (sub.type_exception sub ext) + | Tstr_module mb -> + Pstr_module (sub.module_binding sub mb) + | Tstr_recmodule list -> + Pstr_recmodule (List.map (sub.module_binding sub) list) + | Tstr_modtype mtd -> + Pstr_modtype (sub.module_type_declaration sub mtd) + | Tstr_open od -> + Pstr_open (sub.open_declaration sub od) + | Tstr_class list -> + Pstr_class + (List.map + (fun (ci, _) -> sub.class_declaration sub ci) + list) + | Tstr_class_type list -> + Pstr_class_type + (List.map + (fun (_id, _name, ct) -> sub.class_type_declaration sub ct) + list) + | Tstr_include incl -> + Pstr_include (sub.include_declaration sub incl) + | Tstr_attribute x -> + Pstr_attribute x + in + Str.mk ~loc desc + +let value_description sub v = + let loc = sub.location sub v.val_loc in + let attrs = sub.attributes sub v.val_attributes in + Val.mk ~loc ~attrs + ~prim:v.val_prim + (map_loc sub v.val_name) + (sub.typ sub v.val_desc) + +let module_binding sub mb = + let loc = sub.location sub mb.mb_loc in + let attrs = sub.attributes sub mb.mb_attributes in + Mb.mk ~loc ~attrs + (map_loc sub mb.mb_name) + (sub.module_expr sub mb.mb_expr) + +let type_parameter sub (ct, v) = (sub.typ sub ct, v) + +let type_declaration sub decl = + let loc = sub.location sub decl.typ_loc in + let attrs = sub.attributes sub decl.typ_attributes in + Type.mk ~loc ~attrs + ~params:(List.map (type_parameter sub) decl.typ_params) + ~cstrs:( + List.map + (fun (ct1, ct2, loc) -> + (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc)) + decl.typ_cstrs) + ~kind:(sub.type_kind sub decl.typ_kind) + ~priv:decl.typ_private + ?manifest:(Option.map (sub.typ sub) decl.typ_manifest) + (map_loc sub decl.typ_name) + +let type_kind sub tk = match tk with + | Ttype_abstract -> Ptype_abstract + | Ttype_variant list -> + Ptype_variant (List.map (sub.constructor_declaration sub) list) + | Ttype_record list -> + Ptype_record (List.map (sub.label_declaration sub) list) + | Ttype_open -> Ptype_open + +let constructor_arguments sub = function + | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) + +let constructor_declaration sub cd = + let loc = sub.location sub cd.cd_loc in + let attrs = sub.attributes sub cd.cd_attributes in + Type.constructor ~loc ~attrs + ~vars:cd.cd_vars + ~args:(constructor_arguments sub cd.cd_args) + ?res:(Option.map (sub.typ sub) cd.cd_res) + (map_loc sub cd.cd_name) + +let label_declaration sub ld = + let loc = sub.location sub ld.ld_loc in + let attrs = sub.attributes sub ld.ld_attributes in + Type.field ~loc ~attrs + ~mut:ld.ld_mutable + (map_loc sub ld.ld_name) + (sub.typ sub ld.ld_type) + +let type_extension sub tyext = + let attrs = sub.attributes sub tyext.tyext_attributes in + Te.mk ~attrs + ~params:(List.map (type_parameter sub) tyext.tyext_params) + ~priv:tyext.tyext_private + (map_loc sub tyext.tyext_txt) + (List.map (sub.extension_constructor sub) tyext.tyext_constructors) + +let type_exception sub tyexn = + let attrs = sub.attributes sub tyexn.tyexn_attributes in + Te.mk_exception ~attrs + (sub.extension_constructor sub tyexn.tyexn_constructor) + +let extension_constructor sub ext = + let loc = sub.location sub ext.ext_loc in + let attrs = sub.attributes sub ext.ext_attributes in + Te.constructor ~loc ~attrs + (map_loc sub ext.ext_name) + (match ext.ext_kind with + | Text_decl (vs, args, ret) -> + Pext_decl (vs, constructor_arguments sub args, + Option.map (sub.typ sub) ret) + | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid) + ) + +let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> + let loc = sub.location sub pat.pat_loc in + (* todo: fix attributes on extras *) + let attrs = sub.attributes sub pat.pat_attributes in + let desc = + match pat with + { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } -> + Ppat_unpack { txt = None; loc } + | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> + Ppat_unpack { name with txt = Some name.txt } + | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> + Ppat_type (map_loc sub lid) + | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } -> + Ppat_constraint (sub.pat sub { pat with pat_extra=rem }, + sub.typ sub ct) + | _ -> + match pat.pat_desc with + Tpat_any -> Ppat_any + | Tpat_var (id, name) -> + begin + match (Ident.name id).[0] with + 'A'..'Z' -> + Ppat_unpack { name with txt = Some name.txt} + | _ -> + Ppat_var name + end + + (* We transform (_ as x) in x if _ and x have the same location. + The compiler transforms (x:t) into (_ as x : t). + This avoids transforming a warning 27 into a 26. + *) + | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name) + when pat_loc = pat.pat_loc -> + Ppat_var name + + | Tpat_alias (pat, _id, name) -> + Ppat_alias (sub.pat sub pat, name) + | Tpat_constant cst -> Ppat_constant (constant cst) + | Tpat_tuple list -> + Ppat_tuple (List.map (sub.pat sub) list) + | Tpat_construct (lid, _, args, vto) -> + let tyo = + match vto with + None -> None + | Some (vl, ty) -> + let vl = + List.map (fun x -> {x with txt = Ident.name x.txt}) vl + in + Some (vl, sub.typ sub ty) + in + let arg = + match args with + [] -> None + | [arg] -> Some (sub.pat sub arg) + | args -> Some (Pat.tuple ~loc (List.map (sub.pat sub) args)) + in + Ppat_construct (map_loc sub lid, + match tyo, arg with + | Some (vl, ty), Some arg -> + Some (vl, Pat.mk ~loc (Ppat_constraint (arg, ty))) + | None, Some arg -> Some ([], arg) + | _, None -> None) + | Tpat_variant (label, pato, _) -> + Ppat_variant (label, Option.map (sub.pat sub) pato) + | Tpat_record (list, closed) -> + Ppat_record (List.map (fun (lid, _, pat) -> + map_loc sub lid, sub.pat sub pat) list, closed) + | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list) + | Tpat_lazy p -> Ppat_lazy (sub.pat sub p) + + | Tpat_exception p -> Ppat_exception (sub.pat sub p) + | Tpat_value p -> (sub.pat sub (p :> pattern)).ppat_desc + | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2) + in + Pat.mk ~loc ~attrs desc + +let exp_extra sub (extra, loc, attrs) sexp = + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + let desc = + match extra with + Texp_coerce (cty1, cty2) -> + Pexp_coerce (sexp, + Option.map (sub.typ sub) cty1, + sub.typ sub cty2) + | Texp_constraint cty -> + Pexp_constraint (sexp, sub.typ sub cty) + | Texp_poly cto -> Pexp_poly (sexp, Option.map (sub.typ sub) cto) + | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp) + | Texp_newtype' (_id, label_loc) -> Pexp_newtype (label_loc, sexp) + in + Exp.mk ~loc ~attrs desc + +let case : type k . mapper -> k case -> _ = fun sub {c_lhs; c_guard; c_rhs} -> + { + pc_lhs = sub.pat sub c_lhs; + pc_guard = Option.map (sub.expr sub) c_guard; + pc_rhs = sub.expr sub c_rhs; + } + +let value_binding sub vb = + let loc = sub.location sub vb.vb_loc in + let attrs = sub.attributes sub vb.vb_attributes in + Vb.mk ~loc ~attrs + (sub.pat sub vb.vb_pat) + (sub.expr sub vb.vb_expr) + +let expression sub exp = + let loc = sub.location sub exp.exp_loc in + let attrs = sub.attributes sub exp.exp_attributes in + let desc = + match exp.exp_desc with + Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid) + | Texp_constant cst -> Pexp_constant (constant cst) + | Texp_let (rec_flag, list, exp) -> + Pexp_let (rec_flag, + List.map (sub.value_binding sub) list, + sub.expr sub exp) + + (* Pexp_function can't have a label, so we split in 3 cases. *) + (* One case, no guard: It's a fun. *) + | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}]; + _ } -> + Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e) + (* No label: it's a function. *) + | Texp_function { arg_label = Nolabel; cases; _; } -> + Pexp_function (List.map (sub.case sub) cases) + (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *) + | Texp_function { arg_label = Labelled s | Optional s as label; cases; + _ } -> + let name = fresh_name s exp.exp_env in + Pexp_fun (label, None, Pat.var ~loc {loc;txt = name }, + Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name}) + (List.map (sub.case sub) cases)) + | Texp_apply (exp, list) -> + Pexp_apply (sub.expr sub exp, + List.fold_right (fun (label, expo) list -> + match expo with + None -> list + | Some exp -> (label, sub.expr sub exp) :: list + ) list []) + | Texp_match (exp, cases, _) -> + Pexp_match (sub.expr sub exp, List.map (sub.case sub) cases) + | Texp_try (exp, cases) -> + Pexp_try (sub.expr sub exp, List.map (sub.case sub) cases) + | Texp_tuple list -> + Pexp_tuple (List.map (sub.expr sub) list) + | Texp_construct (lid, _, args) -> + Pexp_construct (map_loc sub lid, + (match args with + [] -> None + | [ arg ] -> Some (sub.expr sub arg) + | args -> + Some + (Exp.tuple ~loc (List.map (sub.expr sub) args)) + )) + | Texp_variant (label, expo) -> + Pexp_variant (label, Option.map (sub.expr sub) expo) + | Texp_record { fields; extended_expression; _ } -> + let list = Array.fold_left (fun l -> function + | _, Kept _ -> l + | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l) + [] fields + in + Pexp_record (list, Option.map (sub.expr sub) extended_expression) + | Texp_field (exp, lid, _label) -> + Pexp_field (sub.expr sub exp, map_loc sub lid) + | Texp_setfield (exp1, lid, _label, exp2) -> + Pexp_setfield (sub.expr sub exp1, map_loc sub lid, + sub.expr sub exp2) + | Texp_array list -> + Pexp_array (List.map (sub.expr sub) list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Pexp_ifthenelse (sub.expr sub exp1, + sub.expr sub exp2, + Option.map (sub.expr sub) expo) + | Texp_sequence (exp1, exp2) -> + Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2) + | Texp_while (exp1, exp2) -> + Pexp_while (sub.expr sub exp1, sub.expr sub exp2) + | Texp_for (_id, name, exp1, exp2, dir, exp3) -> + Pexp_for (name, + sub.expr sub exp1, sub.expr sub exp2, + dir, sub.expr sub exp3) + | Texp_send (exp, meth) -> + Pexp_send (sub.expr sub exp, match meth with + Tmeth_name name -> mkloc name loc + | Tmeth_val id -> mkloc (Ident.name id) loc + | Tmeth_ancestor(id, _) -> mkloc (Ident.name id) loc) + | Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid) + | Texp_instvar (_, path, name) -> + Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path}) + | Texp_setinstvar (_, _path, lid, exp) -> + Pexp_setinstvar (map_loc sub lid, sub.expr sub exp) + | Texp_override (_, list) -> + Pexp_override (List.map (fun (_path, lid, exp) -> + (map_loc sub lid, sub.expr sub exp) + ) list) + | Texp_letmodule (_id, name, _pres, mexpr, exp) -> + Pexp_letmodule (name, sub.module_expr sub mexpr, + sub.expr sub exp) + | Texp_letexception (ext, exp) -> + Pexp_letexception (sub.extension_constructor sub ext, + sub.expr sub exp) + | Texp_assert (exp, _) -> Pexp_assert (sub.expr sub exp) + | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp) + | Texp_object (cl, _) -> + Pexp_object (sub.class_structure sub cl) + | Texp_pack (mexpr) -> + Pexp_pack (sub.module_expr sub mexpr) + | Texp_letop {let_; ands; body; _} -> + let pat, and_pats = + extract_letop_patterns (List.length ands) body.c_lhs + in + let let_ = sub.binding_op sub let_ pat in + let ands = List.map2 (sub.binding_op sub) ands and_pats in + let body = sub.expr sub body.c_rhs in + Pexp_letop {let_; ands; body } + | Texp_unreachable -> + Pexp_unreachable + | Texp_extension_constructor (lid, _) -> + Pexp_extension ({ txt = "ocaml.extension_constructor"; loc }, + PStr [ Str.eval ~loc + (Exp.construct ~loc (map_loc sub lid) None) + ]) + | Texp_open (od, exp) -> + Pexp_open (sub.open_declaration sub od, sub.expr sub exp) + | Texp_hole -> + let id = Location.mkloc hole_txt loc in + Pexp_extension (id, PStr []) + in + List.fold_right (exp_extra sub) exp.exp_extra + (Exp.mk ~loc ~attrs desc) + +let binding_op sub bop pat = + let pbop_op = bop.bop_op_name in + let pbop_pat = sub.pat sub pat in + let pbop_exp = sub.expr sub bop.bop_exp in + let pbop_loc = bop.bop_loc in + {pbop_op; pbop_pat; pbop_exp; pbop_loc} + +let package_type sub pack = + (map_loc sub pack.pack_txt, + List.map (fun (s, ct) -> + (s, sub.typ sub ct)) pack.pack_fields) + +let module_type_declaration sub mtd = + let loc = sub.location sub mtd.mtd_loc in + let attrs = sub.attributes sub mtd.mtd_attributes in + Mtd.mk ~loc ~attrs + ?typ:(Option.map (sub.module_type sub) mtd.mtd_type) + (map_loc sub mtd.mtd_name) + +let signature sub sg = + List.map (sub.signature_item sub) sg.sig_items + +let signature_item sub item = + let loc = sub.location sub item.sig_loc in + let desc = + match item.sig_desc with + Tsig_value v -> + Psig_value (sub.value_description sub v) + | Tsig_type (rec_flag, list) -> + Psig_type (rec_flag, List.map (sub.type_declaration sub) list) + | Tsig_typesubst list -> + Psig_typesubst (List.map (sub.type_declaration sub) list) + | Tsig_typext tyext -> + Psig_typext (sub.type_extension sub tyext) + | Tsig_exception ext -> + Psig_exception (sub.type_exception sub ext) + | Tsig_module md -> + Psig_module (sub.module_declaration sub md) + | Tsig_modsubst ms -> + Psig_modsubst (sub.module_substitution sub ms) + | Tsig_recmodule list -> + Psig_recmodule (List.map (sub.module_declaration sub) list) + | Tsig_modtype mtd -> + Psig_modtype (sub.module_type_declaration sub mtd) + | Tsig_modtypesubst mtd -> + Psig_modtypesubst (sub.module_type_declaration sub mtd) + | Tsig_open od -> + Psig_open (sub.open_description sub od) + | Tsig_include incl -> + Psig_include (sub.include_description sub incl) + | Tsig_class list -> + Psig_class (List.map (sub.class_description sub) list) + | Tsig_class_type list -> + Psig_class_type (List.map (sub.class_type_declaration sub) list) + | Tsig_attribute x -> + Psig_attribute x + in + Sig.mk ~loc desc + +let module_declaration sub md = + let loc = sub.location sub md.md_loc in + let attrs = sub.attributes sub md.md_attributes in + Md.mk ~loc ~attrs + (map_loc sub md.md_name) + (sub.module_type sub md.md_type) + +let module_substitution sub ms = + let loc = sub.location sub ms.ms_loc in + let attrs = sub.attributes sub ms.ms_attributes in + Ms.mk ~loc ~attrs + (map_loc sub ms.ms_name) + (map_loc sub ms.ms_txt) + +let include_infos f sub incl = + let loc = sub.location sub incl.incl_loc in + let attrs = sub.attributes sub incl.incl_attributes in + Incl.mk ~loc ~attrs + (f sub incl.incl_mod) + +let include_declaration sub = include_infos sub.module_expr sub +let include_description sub = include_infos sub.module_type sub + +let class_infos f sub ci = + let loc = sub.location sub ci.ci_loc in + let attrs = sub.attributes sub ci.ci_attributes in + Ci.mk ~loc ~attrs + ~virt:ci.ci_virt + ~params:(List.map (type_parameter sub) ci.ci_params) + (map_loc sub ci.ci_id_name) + (f sub ci.ci_expr) + +let class_declaration sub = class_infos sub.class_expr sub +let class_description sub = class_infos sub.class_type sub +let class_type_declaration sub = class_infos sub.class_type sub + +let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter = + function + | Unit -> Unit + | Named (_, name, mtype) -> Named (name, sub.module_type sub mtype) + +let module_type (sub : mapper) mty = + let loc = sub.location sub mty.mty_loc in + let attrs = sub.attributes sub mty.mty_attributes in + let desc = match mty.mty_desc with + Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid) + | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid) + | Tmty_signature sg -> Pmty_signature (sub.signature sub sg) + | Tmty_functor (arg, mtype2) -> + Pmty_functor (functor_parameter sub arg, sub.module_type sub mtype2) + | Tmty_with (mtype, list) -> + Pmty_with (sub.module_type sub mtype, + List.map (sub.with_constraint sub) list) + | Tmty_typeof mexpr -> + Pmty_typeof (sub.module_expr sub mexpr) + in + Mty.mk ~loc ~attrs desc + +let with_constraint sub (_path, lid, cstr) = + match cstr with + | Twith_type decl -> + Pwith_type (map_loc sub lid, sub.type_declaration sub decl) + | Twith_module (_path, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Twith_modtype mty -> + let mty = sub.module_type sub mty in + Pwith_modtype (map_loc sub lid,mty) + | Twith_typesubst decl -> + Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl) + | Twith_modsubst (_path, lid2) -> + Pwith_modsubst (map_loc sub lid, map_loc sub lid2) + | Twith_modtypesubst mty -> + let mty = sub.module_type sub mty in + Pwith_modtypesubst (map_loc sub lid, mty) + +let module_expr (sub : mapper) mexpr = + let loc = sub.location sub mexpr.mod_loc in + let attrs = sub.attributes sub mexpr.mod_attributes in + match mexpr.mod_desc with + Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> + sub.module_expr sub m + | _ -> + let desc = match mexpr.mod_desc with + Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid) + | Tmod_structure st -> Pmod_structure (sub.structure sub st) + | Tmod_functor (arg, mexpr) -> + Pmod_functor + (functor_parameter sub arg, sub.module_expr sub mexpr) + | Tmod_apply (mexp1, mexp2, _) -> + Pmod_apply (sub.module_expr sub mexp1, + sub.module_expr sub mexp2) + | Tmod_apply_unit mexp1 -> + Pmod_apply_unit (sub.module_expr sub mexp1) + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + Pmod_constraint (sub.module_expr sub mexpr, + sub.module_type sub mtype) + | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> + assert false + | Tmod_unpack (exp, _pack) -> + Pmod_unpack (sub.expr sub exp) + (* TODO , sub.package_type sub pack) *) + | Tmod_hole -> + let id = Location.mkloc hole_txt loc in + Pmod_extension (id, PStr []) + in + Mod.mk ~loc ~attrs desc + +let class_expr sub cexpr = + let loc = sub.location sub cexpr.cl_loc in + let attrs = sub.attributes sub cexpr.cl_attributes in + let desc = match cexpr.cl_desc with + | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ }, + None, _, _, _ ) -> + Pcl_constr (map_loc sub lid, + List.map (sub.typ sub) tyl) + | Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr) + + | Tcl_fun (label, pat, _pv, cl, _partial) -> + Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl) + + | Tcl_apply (cl, args) -> + Pcl_apply (sub.class_expr sub cl, + List.fold_right (fun (label, expo) list -> + match expo with + None -> list + | Some exp -> (label, sub.expr sub exp) :: list + ) args []) + + | Tcl_let (rec_flat, bindings, _ivars, cl) -> + Pcl_let (rec_flat, + List.map (sub.value_binding sub) bindings, + sub.class_expr sub cl) + + | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> + Pcl_constraint (sub.class_expr sub cl, sub.class_type sub clty) + + | Tcl_open (od, e) -> + Pcl_open (sub.open_description sub od, sub.class_expr sub e) + + | Tcl_ident _ -> assert false + | Tcl_constraint (_, None, _, _, _) -> assert false + in + Cl.mk ~loc ~attrs desc + +let class_type sub ct = + let loc = sub.location sub ct.cltyp_loc in + let attrs = sub.attributes sub ct.cltyp_attributes in + let desc = match ct.cltyp_desc with + Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg) + | Tcty_constr (_path, lid, list) -> + Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) + | Tcty_arrow (label, ct, cl) -> + Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) + | Tcty_open (od, e) -> + Pcty_open (sub.open_description sub od, sub.class_type sub e) + in + Cty.mk ~loc ~attrs desc + +let class_signature sub cs = + { + pcsig_self = sub.typ sub cs.csig_self; + pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields; + } + +let class_type_field sub ctf = + let loc = sub.location sub ctf.ctf_loc in + let attrs = sub.attributes sub ctf.ctf_attributes in + let desc = match ctf.ctf_desc with + Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct) + | Tctf_val (s, mut, virt, ct) -> + Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct) + | Tctf_method (s, priv, virt, ct) -> + Pctf_method (mkloc s loc, priv, virt, sub.typ sub ct) + | Tctf_constraint (ct1, ct2) -> + Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2) + | Tctf_attribute x -> Pctf_attribute x + in + Ctf.mk ~loc ~attrs desc + +let core_type sub ct = + let loc = sub.location sub ct.ctyp_loc in + let attrs = sub.attributes sub ct.ctyp_attributes in + let desc = match ct.ctyp_desc with + Ttyp_any -> Ptyp_any + | Ttyp_var s -> Ptyp_var s + | Ttyp_arrow (label, ct1, ct2) -> + Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list) + | Ttyp_constr (_path, lid, list) -> + Ptyp_constr (map_loc sub lid, + List.map (sub.typ sub) list) + | Ttyp_object (list, o) -> + Ptyp_object + (List.map (sub.object_field sub) list, o) + | Ttyp_class (_path, lid, list) -> + Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list) + | Ttyp_alias (ct, s) -> + Ptyp_alias (sub.typ sub ct, s) + | Ttyp_variant (list, bool, labels) -> + Ptyp_variant (List.map (sub.row_field sub) list, bool, labels) + | Ttyp_poly (list, ct) -> + let list = List.map (fun v -> mkloc v loc) list in + Ptyp_poly (list, sub.typ sub ct) + | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack) + in + Typ.mk ~loc ~attrs desc + +let class_structure sub cs = + let rec remove_self = function + | { pat_desc = Tpat_alias (p, id, _s) } + when string_is_prefix "selfpat-" (Ident.name id) -> + remove_self p + | p -> p + in + { pcstr_self = sub.pat sub (remove_self cs.cstr_self); + pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields; + } + +let row_field sub {rf_loc; rf_desc; rf_attributes;} = + let loc = sub.location sub rf_loc in + let attrs = sub.attributes sub rf_attributes in + let desc = match rf_desc with + | Ttag (label, bool, list) -> + Rtag (label, bool, List.map (sub.typ sub) list) + | Tinherit ct -> Rinherit (sub.typ sub ct) + in + Rf.mk ~loc ~attrs desc + +let object_field sub {of_loc; of_desc; of_attributes;} = + let loc = sub.location sub of_loc in + let attrs = sub.attributes sub of_attributes in + let desc = match of_desc with + | OTtag (label, ct) -> + Otag (label, sub.typ sub ct) + | OTinherit ct -> Oinherit (sub.typ sub ct) + in + Of.mk ~loc ~attrs desc + +and is_self_pat = function + | { pat_desc = Tpat_alias(_pat, id, _) } -> + string_is_prefix "self-" (Ident.name id) + | _ -> false + +let class_field sub cf = + let loc = sub.location sub cf.cf_loc in + let attrs = sub.attributes sub cf.cf_attributes in + let desc = match cf.cf_desc with + Tcf_inherit (ovf, cl, super, _vals, _meths) -> + Pcf_inherit (ovf, sub.class_expr sub cl, + Option.map (fun v -> mkloc v loc) super) + | Tcf_constraint (cty, cty') -> + Pcf_constraint (sub.typ sub cty, sub.typ sub cty') + | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) -> + Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty)) + | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) -> + Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp)) + | Tcf_method (lab, priv, Tcfk_virtual cty) -> + Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty)) + | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) -> + let remove_fun_self = function + | { exp_desc = + Texp_function { arg_label = Nolabel; cases = [case]; _ } } + when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs + | e -> e + in + let exp = remove_fun_self exp in + Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp)) + | Tcf_initializer exp -> + let remove_fun_self = function + | { exp_desc = + Texp_function { arg_label = Nolabel; cases = [case]; _ } } + when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs + | e -> e + in + let exp = remove_fun_self exp in + Pcf_initializer (sub.expr sub exp) + | Tcf_attribute x -> Pcf_attribute x + in + Cf.mk ~loc ~attrs desc + +let location _sub l = l + +let default_mapper = + { + attribute = attribute; + attributes = attributes; + binding_op = binding_op; + structure = structure; + structure_item = structure_item; + module_expr = module_expr; + signature = signature; + signature_item = signature_item; + module_type = module_type; + with_constraint = with_constraint; + class_declaration = class_declaration; + class_expr = class_expr; + class_field = class_field; + class_structure = class_structure; + class_type = class_type; + class_type_field = class_type_field; + class_signature = class_signature; + class_type_declaration = class_type_declaration; + class_description = class_description; + type_declaration = type_declaration; + type_kind = type_kind; + typ = core_type; + type_extension = type_extension; + type_exception = type_exception; + extension_constructor = extension_constructor; + value_description = value_description; + pat = pattern; + expr = expression; + module_declaration = module_declaration; + module_substitution = module_substitution; + module_type_declaration = module_type_declaration; + module_binding = module_binding; + package_type = package_type ; + open_declaration = open_declaration; + open_description = open_description; + include_description = include_description; + include_declaration = include_declaration; + value_binding = value_binding; + constructor_declaration = constructor_declaration; + label_declaration = label_declaration; + case = case; + location = location; + row_field = row_field ; + object_field = object_field ; + } + +let untype_structure ?(mapper : mapper = default_mapper) structure = + mapper.structure mapper structure + +let untype_signature ?(mapper : mapper = default_mapper) signature = + mapper.signature mapper signature + +(* Merlin *) +let untype_pattern pat = + default_mapper.pat default_mapper pat + +let untype_expression exp = + default_mapper.expr default_mapper exp diff --git a/ocamlmerlin_mlx/ocaml/typing/untypeast.mli b/ocamlmerlin_mlx/ocaml/typing/untypeast.mli new file mode 100644 index 0000000..7f9e386 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/typing/untypeast.mli @@ -0,0 +1,89 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Parsetree + +val lident_of_path : Path.t -> Longident.t + +type mapper = { + attribute: mapper -> Typedtree.attribute -> attribute; + attributes: mapper -> Typedtree.attribute list -> attribute list; + binding_op: + mapper -> + Typedtree.binding_op -> Typedtree.pattern -> binding_op; + case: 'k . mapper -> 'k Typedtree.case -> case; + class_declaration: mapper -> Typedtree.class_declaration -> class_declaration; + class_description: mapper -> Typedtree.class_description -> class_description; + class_expr: mapper -> Typedtree.class_expr -> class_expr; + class_field: mapper -> Typedtree.class_field -> class_field; + class_signature: mapper -> Typedtree.class_signature -> class_signature; + class_structure: mapper -> Typedtree.class_structure -> class_structure; + class_type: mapper -> Typedtree.class_type -> class_type; + class_type_declaration: mapper -> Typedtree.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> Typedtree.class_type_field -> class_type_field; + constructor_declaration: mapper -> Typedtree.constructor_declaration + -> constructor_declaration; + expr: mapper -> Typedtree.expression -> expression; + extension_constructor: mapper -> Typedtree.extension_constructor + -> extension_constructor; + include_declaration: + mapper -> Typedtree.include_declaration -> include_declaration; + include_description: + mapper -> Typedtree.include_description -> include_description; + label_declaration: + mapper -> Typedtree.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> Typedtree.module_binding -> module_binding; + module_declaration: + mapper -> Typedtree.module_declaration -> module_declaration; + module_substitution: + mapper -> Typedtree.module_substitution -> module_substitution; + module_expr: mapper -> Typedtree.module_expr -> module_expr; + module_type: mapper -> Typedtree.module_type -> module_type; + module_type_declaration: + mapper -> Typedtree.module_type_declaration -> module_type_declaration; + package_type: mapper -> Typedtree.package_type -> package_type; + open_declaration: mapper -> Typedtree.open_declaration -> open_declaration; + open_description: mapper -> Typedtree.open_description -> open_description; + pat: 'k . mapper -> 'k Typedtree.general_pattern -> pattern; + row_field: mapper -> Typedtree.row_field -> row_field; + object_field: mapper -> Typedtree.object_field -> object_field; + signature: mapper -> Typedtree.signature -> signature; + signature_item: mapper -> Typedtree.signature_item -> signature_item; + structure: mapper -> Typedtree.structure -> structure; + structure_item: mapper -> Typedtree.structure_item -> structure_item; + typ: mapper -> Typedtree.core_type -> core_type; + type_declaration: mapper -> Typedtree.type_declaration -> type_declaration; + type_extension: mapper -> Typedtree.type_extension -> type_extension; + type_exception: mapper -> Typedtree.type_exception -> type_exception; + type_kind: mapper -> Typedtree.type_kind -> type_kind; + value_binding: mapper -> Typedtree.value_binding -> value_binding; + value_description: mapper -> Typedtree.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint) + -> with_constraint; +} + +val default_mapper : mapper + +val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure +val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature + +val constant : Asttypes.constant -> Parsetree.constant + +(* Merlin *) +val untype_pattern : _ Typedtree.general_pattern -> Parsetree.pattern +val untype_expression : Typedtree.expression -> Parsetree.expression diff --git a/ocamlmerlin_mlx/ocaml/utils/build_path_prefix_map.ml b/ocamlmerlin_mlx/ocaml/utils/build_path_prefix_map.ml new file mode 100644 index 0000000..17cfac8 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/build_path_prefix_map.ml @@ -0,0 +1,118 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type path = string +type path_prefix = string +type error_message = string + +let errorf fmt = Printf.ksprintf (fun err -> Error err) fmt + +let encode_prefix str = + let buf = Buffer.create (String.length str) in + let push_char = function + | '%' -> Buffer.add_string buf "%#" + | '=' -> Buffer.add_string buf "%+" + | ':' -> Buffer.add_string buf "%." + | c -> Buffer.add_char buf c + in + String.iter push_char str; + Buffer.contents buf + +let decode_prefix str = + let buf = Buffer.create (String.length str) in + let rec loop i = + if i >= String.length str + then Ok (Buffer.contents buf) + else match str.[i] with + | ('=' | ':') as c -> + errorf "invalid character '%c' in key or value" c + | '%' -> + let push c = Buffer.add_char buf c; loop (i + 2) in + if i + 1 = String.length str then + errorf "invalid encoded string %S (trailing '%%')" str + else begin match str.[i + 1] with + | '#' -> push '%' + | '+' -> push '=' + | '.' -> push ':' + | c -> errorf "invalid %%-escaped character '%c'" c + end + | c -> + Buffer.add_char buf c; + loop (i + 1) + in loop 0 + +type pair = { target: path_prefix; source : path_prefix } + +let encode_pair { target; source } = + String.concat "=" [encode_prefix target; encode_prefix source] + +let decode_pair str = + match String.index str '=' with + | exception Not_found -> + errorf "invalid key/value pair %S, no '=' separator" str + | equal_pos -> + let encoded_target = String.sub str 0 equal_pos in + let encoded_source = + String.sub str (equal_pos + 1) (String.length str - equal_pos - 1) in + match decode_prefix encoded_target, decode_prefix encoded_source with + | Ok target, Ok source -> Ok { target; source } + | ((Error _ as err), _) | (_, (Error _ as err)) -> err + +type map = pair option list + +let encode_map map = + let encode_elem = function + | None -> "" + | Some pair -> encode_pair pair + in + List.map encode_elem map + |> String.concat ":" + +let decode_map str = + let exception Shortcut of error_message in + let decode_or_empty = function + | "" -> None + | pair -> + begin match decode_pair pair with + | Ok str -> Some str + | Error err -> raise (Shortcut err) + end + in + let pairs = String.split_on_char ':' str in + match List.map decode_or_empty pairs with + | exception (Shortcut err) -> Error err + | map -> Ok map + +let make_target path : pair option -> path option = function + | None -> None + | Some { target; source } -> + let is_prefix = + String.length source <= String.length path + && String.equal source (String.sub path 0 (String.length source)) in + if is_prefix then + Some (target ^ (String.sub path (String.length source) + (String.length path - String.length source))) + else None + +let rewrite_first prefix_map path = + List.find_map (make_target path) (List.rev prefix_map) + +let rewrite_all prefix_map path = + List.filter_map (make_target path) (List.rev prefix_map) + +let rewrite prefix_map path = + match rewrite_first prefix_map path with + | None -> path + | Some path -> path diff --git a/ocamlmerlin_mlx/ocaml/utils/build_path_prefix_map.mli b/ocamlmerlin_mlx/ocaml/utils/build_path_prefix_map.mli new file mode 100644 index 0000000..d8ec9ca --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/build_path_prefix_map.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Scherer, projet Parsifal, INRIA Saclay *) +(* *) +(* Copyright 2017 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Rewrite paths for reproducible builds + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} +*) + + +type path = string +type path_prefix = string +type error_message = string + +val encode_prefix : path_prefix -> string +val decode_prefix : string -> (path_prefix, error_message) result + +type pair = { target: path_prefix; source : path_prefix } + +val encode_pair : pair -> string +val decode_pair : string -> (pair, error_message) result + +type map = pair option list + +val encode_map : map -> string +val decode_map : string -> (map, error_message) result + +val rewrite_first : map -> path -> path option +(** [rewrite_first map path] tries to find a source in [map] + that is a prefix of the input [path]. If it succeeds, + it replaces this prefix with the corresponding target. + If it fails, it just returns [None]. *) + +val rewrite_all : map -> path -> path list +(** [rewrite_all map path] finds all sources in [map] + that are a prefix of the input [path]. For each matching + source, in priority order, it replaces this prefix with + the corresponding target and adds the result to + the returned list. + If there are no matches, it just returns [[]]. *) + +val rewrite : map -> path -> path +(** [rewrite path] uses [rewrite_first] to try to find a + mapping for path. If found, it returns that, otherwise + it just returns [path]. *) diff --git a/ocamlmerlin_mlx/ocaml/utils/clflags.ml b/ocamlmerlin_mlx/ocaml/utils/clflags.ml new file mode 100644 index 0000000..337ac0a --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/clflags.ml @@ -0,0 +1,30 @@ +(** {0 OCaml compiler compatible command-line parameters} *) +let cmi_file = ref None +let include_dirs = ref [] +let fast = ref false +let classic = ref false +let principal = ref false +let real_paths = ref true +let recursive_types = ref false +let strict_sequence = ref false +let applicative_functors = ref true + +let nopervasives = ref false +let strict_formats = ref true +let open_modules = ref [] + +let annotations = ref false +let binary_annotations = ref true +let print_types = ref false +let native_code = ref false +let error_size = ref 500 +let dont_write_files = ref true +let keep_locs = ref true +let keep_docs = ref false +let transparent_modules = ref true +let for_package = ref None +let debug = ref false +let opaque = ref false +let unboxed_types = ref false + +let locations = ref true diff --git a/ocamlmerlin_mlx/ocaml/utils/clflags.mli b/ocamlmerlin_mlx/ocaml/utils/clflags.mli new file mode 100644 index 0000000..6294b08 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/clflags.mli @@ -0,0 +1,38 @@ +(** {0 OCaml compiler compatible command-line parameters} + + For compatibility with typechecker. + Argument parsing / build environment construction happens elsewhere. +*) + +(** {1 Relevant settings} + Parameters from OCaml compiler which affect Merlin behavior. *) +val cmi_file : string option ref +val include_dirs : string list ref +val fast : bool ref +val classic : bool ref +val principal : bool ref +val real_paths : bool ref +val recursive_types : bool ref +val strict_sequence : bool ref +val applicative_functors : bool ref +val nopervasives : bool ref +val strict_formats : bool ref +val open_modules : string list ref + +(** {1 Dummy values} + Ignored by merlin but kept for compatibility with upstream code. *) +val annotations : bool ref +val binary_annotations : bool ref +val print_types : bool ref +val native_code : bool ref +val dont_write_files : bool ref +val error_size : int ref (* max size of module related errors *) +val keep_locs : bool ref +val keep_docs : bool ref +val transparent_modules : bool ref +val for_package : string option ref +val debug : bool ref +val opaque : bool ref +val unboxed_types : bool ref + +val locations : bool ref diff --git a/ocamlmerlin_mlx/ocaml/utils/config.ml b/ocamlmerlin_mlx/ocaml/utils/config.ml new file mode 100644 index 0000000..f1f93f2 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/config.ml @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(***********************************************************************) +(** **) +(** WARNING WARNING WARNING **) +(** **) +(** When you change this file, you must make the parallel change **) +(** in config.mlbuild **) +(** **) +(***********************************************************************) + + +(* The main OCaml version string has moved to ../VERSION *) +let version = Sys.ocaml_version + +let flambda = false + +let exec_magic_number = "Caml1999X033" + (* exec_magic_number is duplicated in runtime/caml/exec.h *) +and cmi_magic_number = "Caml1999I033" +and cmo_magic_number = "Caml1999O033" +and cma_magic_number = "Caml1999A033" +and cmx_magic_number = + if flambda then + "Caml1999y033" + else + "Caml1999Y033" +and cmxa_magic_number = + if flambda then + "Caml1999z033" + else + "Caml1999Z033" +and ast_impl_magic_number = "Caml1999M033" +and ast_intf_magic_number = "Caml1999N033" +and cmxs_magic_number = "Caml1999D033" +and cmt_magic_number = "Caml1999T033" + +let interface_suffix = ref ".mli" + +let max_tag = 245 +let flat_float_array = false + +let merlin = true diff --git a/ocamlmerlin_mlx/ocaml/utils/config.mli b/ocamlmerlin_mlx/ocaml/utils/config.mli new file mode 100644 index 0000000..02713f5 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/config.mli @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* System configuration *) + +val version: string + (* The current version number of the system *) + +val interface_suffix: string ref + (* Suffix for interface file names *) + +val exec_magic_number: string + (* Magic number for bytecode executable files *) +val cmi_magic_number: string + (* Magic number for compiled interface files *) +val cmo_magic_number: string + (* Magic number for object bytecode files *) +val cma_magic_number: string + (* Magic number for archive files *) +val cmx_magic_number: string + (* Magic number for compilation unit descriptions *) +val cmxa_magic_number: string + (* Magic number for libraries of compilation unit descriptions *) +val ast_intf_magic_number: string + (* Magic number for file holding an interface syntax tree *) +val ast_impl_magic_number: string + (* Magic number for file holding an implementation syntax tree *) +val cmxs_magic_number: string + (* Magic number for dynamically-loadable plugins *) +val cmt_magic_number: string + (* Magic number for compiled interface files *) + +val max_tag: int + (* Biggest tag that can be stored in the header of a regular block. *) + +val flat_float_array: bool + +(**/**) + +val merlin : bool + +(**/**) diff --git a/ocamlmerlin_mlx/ocaml/utils/consistbl.ml b/ocamlmerlin_mlx/ocaml/utils/consistbl.ml new file mode 100644 index 0000000..2928920 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/consistbl.ml @@ -0,0 +1,95 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Consistency tables: for checking consistency of module CRCs *) + +open Misc + +module Make (Module_name : sig + type t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t + module Tbl : Hashtbl.S with type key = t + val compare : t -> t -> int +end) = struct + type t = (Digest.t * filepath) Module_name.Tbl.t + + let create () = Module_name.Tbl.create 13 + + let clear = Module_name.Tbl.clear + + exception Inconsistency of { + unit_name : Module_name.t; + inconsistent_source : string; + original_source : string; + } + + exception Not_available of Module_name.t + + let check_ tbl name crc source = + let (old_crc, old_source) = Module_name.Tbl.find tbl name in + if crc <> old_crc then raise(Inconsistency { + unit_name = name; + inconsistent_source = source; + original_source = old_source; + }) + + let check tbl name crc source = + try check_ tbl name crc source + with Not_found -> + Module_name.Tbl.add tbl name (crc, source) + + let check_noadd tbl name crc source = + try check_ tbl name crc source + with Not_found -> + raise (Not_available name) + + let source tbl name = snd (Module_name.Tbl.find tbl name) + + let extract l tbl = + let l = List.sort_uniq Module_name.compare l in + List.fold_left + (fun assc name -> + try + let (crc, _) = Module_name.Tbl.find tbl name in + (name, Some crc) :: assc + with Not_found -> + (name, None) :: assc) + [] l + + let extract_map mod_names tbl = + Module_name.Set.fold + (fun name result -> + try + let (crc, _) = Module_name.Tbl.find tbl name in + Module_name.Map.add name (Some crc) result + with Not_found -> + Module_name.Map.add name None result) + mod_names + Module_name.Map.empty + + let filter p tbl = + let to_remove = ref [] in + Module_name.Tbl.iter + (fun name _ -> + if not (p name) then to_remove := name :: !to_remove) + tbl; + List.iter + (fun name -> + while Module_name.Tbl.mem tbl name do + Module_name.Tbl.remove tbl name + done) + !to_remove +end diff --git a/ocamlmerlin_mlx/ocaml/utils/consistbl.mli b/ocamlmerlin_mlx/ocaml/utils/consistbl.mli new file mode 100644 index 0000000..acc89eb --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/consistbl.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Consistency tables: for checking consistency of module CRCs + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +open Misc + +module Make (Module_name : sig + type t + module Set : Set.S with type elt = t + module Map : Map.S with type key = t + module Tbl : Hashtbl.S with type key = t + val compare : t -> t -> int +end) : sig + type t + + val create: unit -> t + + val clear: t -> unit + + val check: t -> Module_name.t -> Digest.t -> filepath -> unit + (* [check tbl name crc source] + checks consistency of ([name], [crc]) with infos previously + stored in [tbl]. If no CRC was previously associated with + [name], record ([name], [crc]) in [tbl]. + [source] is the name of the file from which the information + comes from. This is used for error reporting. *) + + val check_noadd: t -> Module_name.t -> Digest.t -> filepath -> unit + (* Same as [check], but raise [Not_available] if no CRC was previously + associated with [name]. *) + + val source: t -> Module_name.t -> filepath + (* [source tbl name] returns the file name associated with [name] + if the latter has an associated CRC in [tbl]. + Raise [Not_found] otherwise. *) + + val extract: Module_name.t list -> t -> (Module_name.t * Digest.t option) list + (* [extract tbl names] returns an associative list mapping each string + in [names] to the CRC associated with it in [tbl]. If no CRC is + associated with a name then it is mapped to [None]. *) + + val extract_map : Module_name.Set.t -> t -> Digest.t option Module_name.Map.t + (* Like [extract] but with a more sophisticated type. *) + + val filter: (Module_name.t -> bool) -> t -> unit + (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs + such that [pred name] is [false]. *) + + exception Inconsistency of { + unit_name : Module_name.t; + inconsistent_source : string; + original_source : string; + } + (* Raised by [check] when a CRC mismatch is detected. *) + + exception Not_available of Module_name.t + (* Raised by [check_noadd] when a name doesn't have an associated + CRC. *) +end diff --git a/ocamlmerlin_mlx/ocaml/utils/diffing.ml b/ocamlmerlin_mlx/ocaml/utils/diffing.ml new file mode 100644 index 0000000..e5b230e --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/diffing.ml @@ -0,0 +1,447 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Radanne, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@warning "-16"] + +(* This module implements a modified version of Wagner-Fischer + See + for preliminary reading. + + The main extensions is that: + - State is computed based on the optimal patch so far. + - The lists can be extended at each state computation. + + We add the constraint that extensions can only be in one side + (either the left or right list). This is enforced by the external API. + +*) + +(** Shared types *) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation + +let style = function + | Preservation -> Misc.Color.[ FG Green ] + | Deletion -> Misc.Color.[ FG Red; Bold] + | Insertion -> Misc.Color.[ FG Red; Bold] + | Modification -> Misc.Color.[ FG Magenta; Bold] + +let prefix ppf (pos, p) = + let sty = style p in + Format.pp_open_stag ppf (Misc.Color.Style sty); + Format.fprintf ppf "%i. " pos; + Format.pp_close_stag ppf () + + +let (let*) = Option.bind +let (let+) x f = Option.map f x +let (let*!) x f = Option.iter f x + +module type Defs = sig + type left + type right + type eq + type diff + type state +end + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +let classify = function + | Delete _ -> Deletion + | Insert _ -> Insertion + | Change _ -> Modification + | Keep _ -> Preservation + +module Define(D:Defs) = struct + open D + +type nonrec change = (left,right,eq,diff) change + +type patch = change list +module type S = sig + val diff: state -> left array -> right array -> patch +end + + +type full_state = { + line: left array; + column: right array; + state: state +} + +(* The matrix supporting our dynamic programming implementation. + + Each cell contains: + - The diff and its weight + - The state computed so far + - The lists, potentially extended locally. + + The matrix can also be reshaped. +*) +module Matrix : sig + + type shape = { l : int ; c : int } + + type t + + val make : shape -> t + val reshape : shape -> t -> t + + (** accessor functions *) + val diff : t -> int -> int -> change option + val state : t -> int -> int -> full_state option + val weight : t -> int -> int -> int + + val line : t -> int -> int -> left option + val column : t -> int -> int -> right option + + val set : + t -> int -> int -> + diff:change option -> + weight:int -> + state:full_state -> + unit + + (** the shape when starting filling the matrix *) + val shape : t -> shape + + (** [shape m i j] is the shape as seen from the state at position (i,j) + after some possible extensions + *) + val shape_at : t -> int -> int -> shape option + + (** the maximal shape on the whole matrix *) + val real_shape : t -> shape + + (** debugging printer *) + val[@warning "-32"] pp : Format.formatter -> t -> unit + +end = struct + + type shape = { l : int ; c : int } + + type t = + { states: full_state option array array; + weight: int array array; + diff: change option array array; + columns: int; + lines: int; + } + let opt_get a n = + if n < Array.length a then Some (Array.unsafe_get a n) else None + let line m i j = let* st = m.states.(i).(j) in opt_get st.line i + let column m i j = let* st = m.states.(i).(j) in opt_get st.column j + let diff m i j = m.diff.(i).(j) + let weight m i j = m.weight.(i).(j) + let state m i j = m.states.(i).(j) + let shape m = { l = m.lines ; c = m.columns } + + let set m i j ~diff ~weight ~state = + m.weight.(i).(j) <- weight; + m.states.(i).(j) <- Some state; + m.diff.(i).(j) <- diff; + () + + let shape_at tbl i j = + let+ st = tbl.states.(i).(j) in + let l = Array.length st.line in + let c = Array.length st.column in + { l ; c } + + let real_shape tbl = + let lines = ref tbl.lines in + let columns = ref tbl.columns in + for i = 0 to tbl.lines do + for j = 0 to tbl.columns do + let*! {l; c} = shape_at tbl i j in + if l > !lines then lines := l; + if c > !columns then columns := c + done; + done; + { l = !lines ; c = !columns } + + let make { l = lines ; c = columns } = + { states = Array.make_matrix (lines + 1) (columns + 1) None; + weight = Array.make_matrix (lines + 1) (columns + 1) max_int; + diff = Array.make_matrix (lines + 1) (columns + 1) None; + lines; + columns; + } + + let reshape { l = lines ; c = columns } m = + let copy default a = + Array.init (1+lines) (fun i -> Array.init (1+columns) (fun j -> + if i <= m.lines && j <= m.columns then + a.(i).(j) + else default) ) in + { states = copy None m.states; + weight = copy max_int m.weight; + diff = copy None m.diff; + lines; + columns + } + + let pp ppf m = + let { l ; c } = shape m in + Format.eprintf "Shape : %i, %i@." l c; + for i = 0 to l do + for j = 0 to c do + let d = diff m i j in + match d with + | None -> + Format.fprintf ppf " " + | Some diff -> + let sdiff = match diff with + | Insert _ -> "\u{2190}" + | Delete _ -> "\u{2191}" + | Keep _ -> "\u{2196}" + | Change _ -> "\u{21F1}" + in + let w = weight m i j in + Format.fprintf ppf "%s%i " sdiff w + done; + Format.pp_print_newline ppf () + done + +end + + +(* Building the patch. + + We first select the best final cell. A potential final cell + is a cell where the local shape (i.e., the size of the strings) correspond + to its position in the matrix. In other words: it's at the end of both its + strings. We select the final cell with the smallest weight. + + We then build the patch by walking backward from the final cell to the + origin. +*) + +let select_final_state m0 = + let maybe_final i j = + match Matrix.shape_at m0 i j with + | Some shape_here -> shape_here.l = i && shape_here.c = j + | None -> false + in + let best_state (i0,j0,weigth0) (i,j) = + let weight = Matrix.weight m0 i j in + if weight < weigth0 then (i,j,weight) else (i0,j0,weigth0) + in + let res = ref (0,0,max_int) in + let shape = Matrix.shape m0 in + for i = 0 to shape.l do + for j = 0 to shape.c do + if maybe_final i j then + res := best_state !res (i,j) + done + done; + let i_final, j_final, _ = !res in + assert (i_final <> 0 || j_final <> 0); + (i_final, j_final) + +let construct_patch m0 = + let rec aux acc (i, j) = + if i = 0 && j = 0 then + acc + else + match Matrix.diff m0 i j with + | None -> assert false + | Some d -> + let next = match d with + | Keep _ | Change _ -> (i-1, j-1) + | Delete _ -> (i-1, j) + | Insert _ -> (i, j-1) + in + aux (d::acc) next + in + aux [] (select_final_state m0) + +(* Computation of new cells *) + +let select_best_proposition l = + let compare_proposition curr prop = + match curr, prop with + | None, o | o, None -> o + | Some (curr_m, curr_res), Some (m, res) -> + Some (if curr_m <= m then curr_m, curr_res else m,res) + in + List.fold_left compare_proposition None l + + module type Full_core = sig + type update_result + type update_state + val weight: change -> int + val test: state -> left -> right -> (eq, diff) result + val update: change -> update_state -> update_result + end + +module Generic + (X: Full_core + with type update_result := full_state + and type update_state := full_state) = struct + open X + + (* Boundary cell update *) + let compute_column0 tbl i = + let*! st = Matrix.state tbl (i-1) 0 in + let*! line = Matrix.line tbl (i-1) 0 in + let diff = Delete line in + Matrix.set tbl i 0 + ~weight:(weight diff + Matrix.weight tbl (i-1) 0) + ~state:(update diff st) + ~diff:(Some diff) + + let compute_line0 tbl j = + let*! st = Matrix.state tbl 0 (j-1) in + let*! column = Matrix.column tbl 0 (j-1) in + let diff = Insert column in + Matrix.set tbl 0 j + ~weight:(weight diff + Matrix.weight tbl 0 (j-1)) + ~state:(update diff st) + ~diff:(Some diff) + +let compute_inner_cell tbl i j = + let compute_proposition i j diff = + let* diff = diff in + let+ localstate = Matrix.state tbl i j in + weight diff + Matrix.weight tbl i j, (diff, localstate) + in + let del = + let diff = let+ x = Matrix.line tbl (i-1) j in Delete x in + compute_proposition (i-1) j diff + in + let insert = + let diff = let+ x = Matrix.column tbl i (j-1) in Insert x in + compute_proposition i (j-1) diff + in + let diag = + let diff = + let* state = Matrix.state tbl (i-1) (j-1) in + let* line = Matrix.line tbl (i-1) (j-1) in + let* column = Matrix.column tbl (i-1) (j-1) in + match test state.state line column with + | Ok ok -> Some (Keep (line, column, ok)) + | Error err -> Some (Change (line, column, err)) + in + compute_proposition (i-1) (j-1) diff + in + let*! newweight, (diff, localstate) = + select_best_proposition [diag;del;insert] + in + let state = update diff localstate in + Matrix.set tbl i j ~weight:newweight ~state ~diff:(Some diff) + +let compute_cell m i j = + match i, j with + | _ when Matrix.diff m i j <> None -> () + | 0,0 -> () + | 0,j -> compute_line0 m j + | i,0 -> compute_column0 m i; + | _ -> compute_inner_cell m i j + +(* Filling the matrix + + We fill the whole matrix, as in vanilla Wagner-Fischer. + At this point, the lists in some states might have been extended. + If any list have been extended, we need to reshape the matrix + and repeat the process +*) +let compute_matrix state0 = + let m0 = Matrix.make { l = 0 ; c = 0 } in + Matrix.set m0 0 0 ~weight:0 ~state:state0 ~diff:None; + let rec loop m = + let shape = Matrix.shape m in + let new_shape = Matrix.real_shape m in + if new_shape.l > shape.l || new_shape.c > shape.c then + let m = Matrix.reshape new_shape m in + for i = 0 to new_shape.l do + for j = 0 to new_shape.c do + compute_cell m i j + done + done; + loop m + else + m + in + loop m0 + end + + + module type Parameters = Full_core with type update_state := state + + module Simple(X:Parameters with type update_result := state) = struct + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = { fs with state = X.update d fs.state } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + + let may_append x = function + | [||] -> x + | y -> Array.append x y + + + module Left_variadic + (X:Parameters with type update_result := state * left array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; line = may_append fs.line a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + module Right_variadic + (X:Parameters with type update_result := state * right array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; column = may_append fs.column a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + +end diff --git a/ocamlmerlin_mlx/ocaml/utils/diffing.mli b/ocamlmerlin_mlx/ocaml/utils/diffing.mli new file mode 100644 index 0000000..80cfa5e --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/diffing.mli @@ -0,0 +1,147 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Radanne, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Parametric diffing + + This module implements diffing over lists of arbitrary content. + It is parameterized by + - The content of the two lists + - The equality witness when an element is kept + - The diffing witness when an element is changed + + Diffing is extended to maintain state depending on the + computed changes while walking through the two lists. + + The underlying algorithm is a modified Wagner-Fischer algorithm + (see ). + + We provide the following guarantee: + Given two lists [l] and [r], if different patches result in different + states, we say that the state diverges. + - We always return the optimal patch on prefixes of [l] and [r] + on which state does not diverge. + - Otherwise, we return a correct but non-optimal patch where subpatches + with no divergent states are optimal for the given initial state. + + More precisely, the optimality of Wagner-Fischer depends on the property + that the edit-distance between a k-prefix of the left input and a l-prefix + of the right input d(k,l) satisfies + + d(k,l) = min ( + del_cost + d(k-1,l), + insert_cost + d(k,l-1), + change_cost + d(k-1,l-1) + ) + + Under this hypothesis, it is optimal to choose greedily the state of the + minimal patch transforming the left k-prefix into the right l-prefix as a + representative of the states of all possible patches transforming the left + k-prefix into the right l-prefix. + + If this property is not satisfied, we can still choose greedily a + representative state. However, the computed patch is no more guaranteed to + be globally optimal. + Nevertheless, it is still a correct patch, which is even optimal among all + explored patches. + +*) + +(** The core types of a diffing implementation *) +module type Defs = sig + type left + type right + type eq + (** Detailed equality trace *) + + type diff + (** Detailed difference trace *) + + type state + (** environment of a partial patch *) +end + +(** The kind of changes which is used to share printing and styling + across implementation*) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation +val prefix: Format.formatter -> (int * change_kind) -> unit +val style: change_kind -> Misc.Color.style list + + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +val classify: _ change -> change_kind + +(** [Define(Defs)] creates the diffing types from the types + defined in [Defs] and the functors that need to be instantatied + with the diffing algorithm parameters +*) +module Define(D:Defs): sig + open D + + (** The type of potential changes on a list. *) + type nonrec change = (left,right,eq,diff) change + type patch = change list + (** A patch is an ordered list of changes. *) + + module type Parameters = sig + type update_result + + val weight: change -> int + (** [weight ch] returns the weight of the change [ch]. + Used to find the smallest patch. *) + + val test: state -> left -> right -> (eq, diff) result + (** + [test st xl xr] tests if the elements [xl] and [xr] are + co mpatible ([Ok]) or not ([Error]). + *) + + val update: change -> state -> update_result + (** [update ch st] returns the new state after applying a change. + The [update_result] type also contains expansions in the variadic + case. + *) + end + + module type S = sig + val diff: state -> left array -> right array -> patch + (** [diff state l r] computes the optimal patch between [l] and [r], + using the initial state [state]. + *) + end + + + module Simple: (Parameters with type update_result := state) -> S + + (** {1 Variadic diffing} + + Variadic diffing allows to expand the lists being diffed during diffing. + in one specific direction. + *) + module Left_variadic: + (Parameters with type update_result := state * left array) -> S + + module Right_variadic: + (Parameters with type update_result := state * right array) -> S + +end diff --git a/ocamlmerlin_mlx/ocaml/utils/diffing_with_keys.ml b/ocamlmerlin_mlx/ocaml/utils/diffing_with_keys.ml new file mode 100644 index 0000000..8a31314 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/diffing_with_keys.ml @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +type 'a with_pos = {pos:int; data:'a} +let with_pos l = List.mapi (fun n data -> {pos=n+1; data}) l + +(** Composite change and mismatches *) +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +let prefix ppf x = + let kind = match x with + | Change _ | Swap _ | Move _ -> Diffing.Modification + | Insert _ -> Diffing.Insertion + | Delete _ -> Diffing.Deletion + in + let style k ppf inner = + let sty = Diffing.style k in + Format.pp_open_stag ppf (Misc.Color.Style sty); + Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner + in + match x with + | Change (Name {pos; _ } | Type {pos; _}) + | Insert { pos; _ } | Delete { pos; _ } -> + style kind ppf "%i. " pos + | Swap { pos = left, right; _ } -> + style kind ppf "%i<->%i. " left right + | Move { got; expected; _ } -> + style kind ppf "%i->%i. " expected got + + + +(** To detect [move] and [swaps], we are using the fact that + there are 2-cycles in the graph of name renaming. + - [Change (x,y,_) is then an edge from + [key_left x] to [key_right y]. + - [Insert x] is an edge between the special node epsilon and + [key_left x] + - [Delete x] is an edge between [key_right] and the epsilon node + Since for 2-cycle, knowing one edge is enough to identify the cycle + it might belong to, we are using maps of partial 2-cycles. +*) +module Two_cycle: sig + type t = private (string * string) + val create: string -> string -> t +end = struct + type t = string * string + let create kx ky = + if kx <= ky then kx, ky else ky, kx +end +module Swap = Map.Make(struct + type t = Two_cycle.t + let compare: t -> t -> int = Stdlib.compare + end) +module Move = Misc.String.Map + + +module Define(D:Diffing.Defs with type eq := unit) = struct + + module Internal_defs = struct + type left = D.left with_pos + type right = D.right with_pos + type diff = (D.left, D.right, D.diff) mismatch + type eq = unit + type state = D.state + end + module Diff = Diffing.Define(Internal_defs) + + type left = Internal_defs.left + type right = Internal_defs.right + type diff = (D.left, D.right, D.diff) mismatch + type composite_change = (D.left,D.right,D.diff) change + type nonrec change = (left, right, unit, diff) Diffing.change + type patch = composite_change list + + module type Parameters = sig + include Diff.Parameters with type update_result := D.state + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple(Impl:Parameters) = struct + open Impl + + (** Partial 2-cycles *) + type ('l,'r) partial_cycle = + | Left of int * D.state * 'l + | Right of int * D.state * 'r + | Both of D.state * 'l * 'r + + (** Compute the partial cycle and edge associated to an edge *) + let edge state (x:left) (y:right) = + let kx, ky = key_left x.data, key_right y.data in + let edge = + if kx <= ky then + Left (x.pos, state, (x,y)) + else + Right (x.pos,state, (x,y)) + in + Two_cycle.create kx ky, edge + + let merge_edge ex ey = match ex, ey with + | ex, None -> Some ex + | Left (lpos, lstate, l), Some Right (rpos, rstate,r) + | Right (rpos, rstate,r), Some Left (lpos, lstate, l) -> + let state = if lpos < rpos then rstate else lstate in + Some (Both (state,l,r)) + | Both _ as b, _ | _, Some (Both _ as b) -> Some b + | l, _ -> Some l + + let two_cycles state changes = + let add (state,(swaps,moves)) (d:change) = + update d state, + match d with + | Change (x,y,_) -> + let k, edge = edge state x y in + Swap.update k (merge_edge edge) swaps, moves + | Insert nx -> + let k = key_right nx.data in + let edge = Right (nx.pos, state,nx) in + swaps, Move.update k (merge_edge edge) moves + | Delete nx -> + let k, edge = key_left nx.data, Left (nx.pos, state, nx) in + swaps, Move.update k (merge_edge edge) moves + | _ -> swaps, moves + in + List.fold_left add (state,(Swap.empty,Move.empty)) changes + + (** Check if an edge belongs to a known 2-cycle *) + let swap swaps x y = + let kx, ky = key_left x.data, key_right y.data in + let key = Two_cycle.create kx ky in + match Swap.find_opt key swaps with + | None | Some (Left _ | Right _)-> None + | Some Both (state, (ll,lr),(rl,rr)) -> + match test state ll rr, test state rl lr with + | Ok _, Ok _ -> + Some ({pos=ll.pos; data=kx}, {pos=rl.pos; data=ky}) + | Error _, _ | _, Error _ -> None + + let move moves x = + let name = + match x with + | Either.Left x -> key_left x.data + | Either.Right x -> key_right x.data + in + match Move.find_opt name moves with + | None | Some (Left _ | Right _)-> None + | Some Both (state,got,expected) -> + match test state got expected with + | Ok _ -> + Some (Move {name; got=got.pos; expected=expected.pos}) + | Error _ -> None + + let refine state patch = + let _, (swaps, moves) = two_cycles state patch in + let filter: change -> composite_change option = function + | Keep _ -> None + | Insert x -> + begin match move moves (Either.Right x) with + | Some _ as move -> move + | None -> Some (Insert {pos=x.pos;insert=x.data}) + end + | Delete x -> + begin match move moves (Either.Left x) with + | Some _ -> None + | None -> Some (Delete {pos=x.pos; delete=x.data}) + end + | Change(x,y, reason) -> + match swap swaps x y with + | Some ({pos=pos1; data=first}, {pos=pos2; data=last}) -> + if x.pos = pos1 then + Some (Swap { pos = pos1, pos2; first; last}) + else None + | None -> Some (Change reason) + in + List.filter_map filter patch + + let diff state left right = + let left = with_pos left in + let right = with_pos right in + let module Raw = Diff.Simple(Impl) in + let raw = Raw.diff state (Array.of_list left) (Array.of_list right) in + refine state raw + + end +end diff --git a/ocamlmerlin_mlx/ocaml/utils/diffing_with_keys.mli b/ocamlmerlin_mlx/ocaml/utils/diffing_with_keys.mli new file mode 100644 index 0000000..2da8268 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/diffing_with_keys.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** + + When diffing lists where each element has a distinct key, we can refine + the diffing patch by introducing two composite edit moves: swaps and moves. + + [Swap]s exchange the position of two elements. [Swap] cost is set to + [2 * change - epsilon]. + [Move]s change the position of one element. [Move] cost is set to + [delete + addition - epsilon]. + + When the cost [delete + addition] is greater than [change] and with those + specific weights, the optimal patch with [Swap]s and [Move]s can be computed + directly and cheaply from the original optimal patch. + +*) + +type 'a with_pos = {pos: int; data:'a} +val with_pos: 'a list -> 'a with_pos list + +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +(** This specialized version of changes introduces two composite + changes: [Move] and [Swap] +*) +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +val prefix: Format.formatter -> ('l,'r,'diff) change -> unit + +module Define(D:Diffing.Defs with type eq := unit): sig + + type diff = (D.left, D.right, D.diff) mismatch + type left = D.left with_pos + type right = D.right with_pos + + (** Composite changes and patches *) + type composite_change = (D.left,D.right,D.diff) change + type patch = composite_change list + + (** Atomic changes *) + type change = (left,right,unit,diff) Diffing.change + + module type Parameters = sig + val weight: change -> int + val test: D.state -> left -> right -> (unit, diff) result + val update: change -> D.state -> D.state + + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple: Parameters -> sig + val diff: D.state -> D.left list -> D.right list -> patch + end + +end diff --git a/ocamlmerlin_mlx/ocaml/utils/directory_content_cache.ml b/ocamlmerlin_mlx/ocaml/utils/directory_content_cache.ml new file mode 100644 index 0000000..7b5ee9e --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/directory_content_cache.ml @@ -0,0 +1,14 @@ +include File_cache.Make (struct + let cache_name = "Directory_content_cache" + type t = string array + + (* For backward compatibility reason, simulate the behavior of + [Misc.find_in_path]: silently ignore directories that don't exist + + treat [""] as the current directory. *) + let read dir = + try + Sys.readdir (if dir = "" then Filename.current_dir_name else dir) + with Sys_error _ -> + [||] + end) + diff --git a/ocamlmerlin_mlx/ocaml/utils/dune b/ocamlmerlin_mlx/ocaml/utils/dune new file mode 100644 index 0000000..3d41eb7 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/dune @@ -0,0 +1,11 @@ +(library + (name mlx_ocaml_utils) + (package ocamlmerlin-mlx) + (flags :standard -w=-9-67-69 -open=Mlx_utils -open Astlib.Ast_501) + (libraries ppxlib compiler-libs.common merlin-lib.config mlx_utils)) + +(copy_files + (enabled_if + (<> %{profile} "release")) + (mode promote) + (files %{project_root}/merlin/src/ocaml/utils/*.{ml,mli})) diff --git a/ocamlmerlin_mlx/ocaml/utils/identifiable.ml b/ocamlmerlin_mlx/ocaml/utils/identifiable.ml new file mode 100644 index 0000000..fc6cd44 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/identifiable.ml @@ -0,0 +1,223 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file ../LICENSE. *) +(* *) +(**************************************************************************) + +module Stdlib_map = Map +module Stdlib_set = Set + +module type Thing = sig + type t + + include Hashtbl.HashedType with type t := t + include Map.OrderedType with type t := t + + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit +end + +module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct + type t = A.t * B.t + + let compare (a1, b1) (a2, b2) = + let c = A.compare a1 a2 in + if c <> 0 then c + else B.compare b1 b2 + + let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b + let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b) + let equal (a1, b1) (a2, b2) = A.equal a1 a2 && B.equal b1 b2 + let print ppf (a, b) = Format.fprintf ppf " (%a, @ %a)" A.print a B.print b +end + +module Make_map (T : Thing) = struct + include Map.Make (T) + + let filter_map t ~f = + fold (fun id v map -> + match f id v with + | None -> map + | Some r -> add id r map) t empty + + let of_list l = + List.fold_left (fun map (id, v) -> add id v map) empty l + + let disjoint_union ?eq m1 m2 = + merge (fun id v1 v2 -> + match v1, v2 with + | Some v1, Some v2 -> + let ok = match eq with + | None -> false + | Some eq -> eq v1 v2 + in + if not ok then + let err = Format.asprintf "Map.disjoint_union %a" T.print id in + Misc.fatal_error err + else Some v1 + | x, None | None, x -> x) + m1 m2 + + let union_right m1 m2 = + merge (fun _ x y -> match x, y with + | None, None -> None + | None, Some v + | Some v, None + | Some _, Some v -> Some v) + m1 m2 + + let union_left m1 m2 = union_right m2 m1 + + let union_merge f m1 m2 = + let aux _ m1 m2 = + match m1, m2 with + | None, m | m, None -> m + | Some m1, Some m2 -> Some (f m1 m2) + in + merge aux m1 m2 + + let rename m v = + try find v m + with Not_found -> v + + let map_keys f m = + of_list (List.map (fun (k, v) -> f k, v) (bindings m)) + + let print f ppf s = + let elts ppf s = iter (fun id v -> + Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s in + Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s + + module T_set = Set.Make (T) + + let keys map = fold (fun k _ set -> T_set.add k set) map T_set.empty + + let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty + + let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty +end + +module Make_set (T : Thing) = struct + include Set.Make (T) + + let output oc s = + Printf.fprintf oc " ( "; + iter (fun v -> Printf.fprintf oc "%a " T.output v) s; + Printf.fprintf oc ")" + + let print ppf s = + let elts ppf s = iter (fun e -> Format.fprintf ppf "@ %a" T.print e) s in + Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s + + let to_string s = Format.asprintf "%a" print s + + let of_list l = match l with + | [] -> empty + | [t] -> singleton t + | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q + + let map f s = of_list (List.map f (elements s)) +end + +module Make_tbl (T : Thing) = struct + include Hashtbl.Make (T) + + module T_map = Make_map (T) + + let to_list t = + fold (fun key datum elts -> (key, datum)::elts) t [] + + let of_list elts = + let t = create 42 in + List.iter (fun (key, datum) -> add t key datum) elts; + t + + let to_map v = fold T_map.add v T_map.empty + + let of_map m = + let t = create (T_map.cardinal m) in + T_map.iter (fun k v -> add t k v) m; + t + + let memoize t f = fun key -> + try find t key with + | Not_found -> + let r = f key in + add t key r; + r + + let map t f = + of_map (T_map.map f (to_map t)) +end + +module type S = sig + type t + + module T : Thing with type t = t + include Thing with type t := T.t + + module Set : sig + include Stdlib_set.S + with type elt = T.t + and type t = Make_set (T).t + + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit + val to_string : t -> string + val of_list : elt list -> t + val map : (elt -> elt) -> t -> t + end + + module Map : sig + include Stdlib_map.S + with type key = T.t + and type 'a t = 'a Make_map (T).t + + val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t + val of_list : (key * 'a) list -> 'a t + val disjoint_union : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t + val union_right : 'a t -> 'a t -> 'a t + val union_left : 'a t -> 'a t -> 'a t + val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t + val rename : key t -> key -> key + val map_keys : (key -> key) -> 'a t -> 'a t + val keys : 'a t -> Make_set (T).t + val of_set : (key -> 'a) -> Make_set (T).t -> 'a t + val transpose_keys_and_data : key t -> key t + val print : + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit + end + + module Tbl : sig + include Hashtbl.S + with type key = T.t + and type 'a t = 'a Hashtbl.Make (T).t + + val to_list : 'a t -> (T.t * 'a) list + val of_list : (T.t * 'a) list -> 'a t + + val to_map : 'a t -> 'a Make_map (T).t + val of_map : 'a Make_map (T).t -> 'a t + val memoize : 'a t -> (key -> 'a) -> key -> 'a + val map : 'a t -> ('a -> 'b) -> 'b t + end +end + +module Make (T : Thing) = struct + module T = T + include T + + module Set = Make_set (T) + module Map = Make_map (T) + module Tbl = Make_tbl (T) +end diff --git a/ocamlmerlin_mlx/ocaml/utils/identifiable.mli b/ocamlmerlin_mlx/ocaml/utils/identifiable.mli new file mode 100644 index 0000000..568ce46 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/identifiable.mli @@ -0,0 +1,94 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file ../LICENSE. *) +(* *) +(**************************************************************************) + +(** Uniform interface for common data structures over various things. *) + +module type Thing = sig + type t + + include Hashtbl.HashedType with type t := t + include Map.OrderedType with type t := t + + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit +end + +module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t + +module type S = sig + type t + + module T : Thing with type t = t + include Thing with type t := T.t + + module Set : sig + include Set.S + with type elt = T.t + and type t = Set.Make (T).t + + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit + val to_string : t -> string + val of_list : elt list -> t + val map : (elt -> elt) -> t -> t + end + + module Map : sig + include Map.S + with type key = T.t + and type 'a t = 'a Map.Make (T).t + + val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t + val of_list : (key * 'a) list -> 'a t + + (** [disjoint_union m1 m2] contains all bindings from [m1] and + [m2]. If some binding is present in both and the associated + value is not equal, a Fatal_error is raised *) + val disjoint_union : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t + + (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If + some binding is present in both, the one from [m2] is taken *) + val union_right : 'a t -> 'a t -> 'a t + + (** [union_left m1 m2 = union_right m2 m1] *) + val union_left : 'a t -> 'a t -> 'a t + + val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t + val rename : key t -> key -> key + val map_keys : (key -> key) -> 'a t -> 'a t + val keys : 'a t -> Set.t + val of_set : (key -> 'a) -> Set.t -> 'a t + val transpose_keys_and_data : key t -> key t + val print : + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit + end + + module Tbl : sig + include Hashtbl.S + with type key = T.t + and type 'a t = 'a Hashtbl.Make (T).t + + val to_list : 'a t -> (T.t * 'a) list + val of_list : (T.t * 'a) list -> 'a t + + val to_map : 'a t -> 'a Map.t + val of_map : 'a Map.t -> 'a t + val memoize : 'a t -> (key -> 'a) -> key -> 'a + val map : 'a t -> ('a -> 'b) -> 'b t + end +end + +module Make (T : Thing) : S with type t := T.t diff --git a/ocamlmerlin_mlx/ocaml/utils/lazy_backtrack.ml b/ocamlmerlin_mlx/ocaml/utils/lazy_backtrack.ml new file mode 100644 index 0000000..1f7b28b --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/lazy_backtrack.ml @@ -0,0 +1,98 @@ +type ('a,'b) t = ('a,'b) eval ref + +and ('a,'b) eval = + | Done of 'b + | Raise of exn + | Thunk of 'a + +type undo = + | Nil + | Cons : ('a, 'b) t * 'a * undo -> undo + +type log = undo ref + +let force f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> + match f e with + | y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e + +let get_arg x = + match !x with Thunk a -> Some a | _ -> None + +let get_contents x = + match !x with + | Thunk a -> Either.Left a + | Done b -> Either.Right b + | Raise e -> raise e + +let create x = + ref (Thunk x) + +let create_forced y = + ref (Done y) + +let create_failed e = + ref (Raise e) + +let log () = + ref Nil + +let force_logged log f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> + match f e with + | (Error _ as err : _ result) -> + x := Done err; + log := Cons(x, e, !log); + err + | Ok _ as res -> + x := Done res; + res + | exception e -> + x := Raise e; + raise e + +let backtrack log = + let rec loop = function + | Nil -> () + | Cons(x, e, rest) -> + x := Thunk e; + loop rest + in + loop !log + +(* For compatibility with 4.02 and 4.03 *) + +let is_val t = match !t with + | Done _ -> true + | Raise _ | Thunk _ -> false + +let view t = !t + +(* For compatibility with 4.08 and 4.09 *) + +let force_logged_408 log f x = + match !x with + | Done x -> x + | Raise e -> raise e | Thunk e -> + match f e with + | None -> + x := Done None; + log := Cons(x, e, !log); + None + | Some _ as y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e diff --git a/ocamlmerlin_mlx/ocaml/utils/lazy_backtrack.mli b/ocamlmerlin_mlx/ocaml/utils/lazy_backtrack.mli new file mode 100644 index 0000000..fe211fe --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/lazy_backtrack.mli @@ -0,0 +1,30 @@ +type ('a,'b) t + +type log + +val force : ('a -> 'b) -> ('a,'b) t -> 'b +val create : 'a -> ('a,'b) t +val get_arg : ('a,'b) t -> 'a option +val get_contents : ('a,'b) t -> ('a,'b) Either.t +val create_forced : 'b -> ('a, 'b) t +val create_failed : exn -> ('a, 'b) t + +(* [force_logged log f t] is equivalent to [force f t] but if [f] returns + [None] then [t] is recorded in [log]. [backtrack log] will then reset all + the recorded [t]s back to their original state. *) +val log : unit -> log +val force_logged : + log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result +val backtrack : log -> unit + +(* For compatibility with 4.02 and 4.03 *) +val is_val : ('a, 'b) t -> bool +type ('a, 'b) eval = + | Done of 'b + | Raise of exn + | Thunk of 'a +val view : ('a, 'b) t -> ('a, 'b) eval + +(* For compatibility with 4.08 and 4.09 *) +val force_logged_408 : + log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option diff --git a/ocamlmerlin_mlx/ocaml/utils/load_path.ml b/ocamlmerlin_mlx/ocaml/utils/load_path.ml new file mode 100644 index 0000000..70ce575 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/load_path.ml @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2018 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Local_store + +module STbl = Misc.String.Tbl + +(* Mapping from basenames to full filenames *) +type registry = string STbl.t + +let files : registry ref = s_table STbl.create 42 +let files_uncap : registry ref = s_table STbl.create 42 + +module Dir = struct + type t = { + path : string; + files : string list; + } + + let path t = t.path + let files t = t.files + + let find t fn = + if List.mem fn t.files then + Some (Filename.concat t.path fn) + else + None + + let find_uncap t fn = + let fn = String.uncapitalize_ascii fn in + let search base = + if String.uncapitalize_ascii base = fn then + Some (Filename.concat t.path base) + else + None + in + List.find_map search t.files + + let create path = + { path; files = Array.to_list (Directory_content_cache.read path) } + + let check t = Directory_content_cache.check t.path + +end + +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string +let dirs = s_ref [] +let no_auto_include _ _ = raise Not_found +let auto_include_callback = ref no_auto_include + +let reset () = + assert (not Config.merlin || Local_store.is_bound ()); + STbl.clear !files; + STbl.clear !files_uncap; + dirs := []; + auto_include_callback := no_auto_include + +let get () = List.rev !dirs +let get_paths () = List.rev_map Dir.path !dirs + +(* Optimized version of [add] below, for use in [init] and [remove_dir]: since + we are starting from an empty cache, we can avoid checking whether a unit + name already exists in the cache simply by adding entries in reverse + order. *) +let prepend_add dir = + List.iter (fun base -> + let fn = Filename.concat dir.Dir.path base in + STbl.replace !files base fn; + STbl.replace !files_uncap (String.uncapitalize_ascii base) fn + ) dir.Dir.files + +let init ~auto_include l = + assert (not Config.merlin || Local_store.is_bound ()); + let rec loop_changed acc = function + | [] -> Some acc + | new_path :: new_rest -> + loop_changed (Dir.create new_path :: acc) new_rest + in + let rec loop_unchanged acc new_paths old_dirs = + match new_paths, old_dirs with + | [], [] -> None + | new_path :: new_rest, [] -> + loop_changed (Dir.create new_path :: acc) new_rest + | [], _ :: _ -> Some acc + | new_path :: new_rest, old_dir :: old_rest -> + if String.equal new_path (Dir.path old_dir) then begin + if Dir.check old_dir then begin + loop_unchanged (old_dir :: acc) new_rest old_rest + end else begin + loop_changed (Dir.create new_path :: acc) new_rest + end + end else begin + loop_changed (Dir.create new_path :: acc) new_rest + end + in + match loop_unchanged [] l (List.rev !dirs) with + | None -> () + | Some new_dirs -> + reset (); + dirs := new_dirs; + List.iter prepend_add new_dirs; + auto_include_callback := auto_include + +let remove_dir dir = + assert (not Config.merlin || Local_store.is_bound ()); + let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in + if List.compare_lengths new_dirs !dirs <> 0 then begin + reset (); + List.iter prepend_add new_dirs; + dirs := new_dirs + end + +(* General purpose version of function to add a new entry to load path: We only + add a basename to the cache if it is not already present in the cache, in + order to enforce left-to-right precedence. *) +let add dir = + assert (not Config.merlin || Local_store.is_bound ()); + List.iter + (fun base -> + let fn = Filename.concat dir.Dir.path base in + if not (STbl.mem !files base) then + STbl.replace !files base fn; + let ubase = String.uncapitalize_ascii base in + if not (STbl.mem !files_uncap ubase) then + STbl.replace !files_uncap ubase fn) + dir.Dir.files; + dirs := dir :: !dirs + +let append_dir = add + +let add_dir dir = add (Dir.create dir) + +(* Add the directory at the start of load path - so basenames are + unconditionally added. *) +let prepend_dir dir = + assert (not Config.merlin || Local_store.is_bound ()); + prepend_add dir; + dirs := !dirs @ [dir] + +let is_basename fn = Filename.basename fn = fn + +(* let auto_include_libs libs alert find_in_dir fn = + let scan (lib, lazy dir) = + let file = find_in_dir dir fn in + let alert_and_add_dir _ = + alert lib; + append_dir dir + in + Option.iter alert_and_add_dir file; + file + in + match List.find_map scan libs with + | Some base -> base + | None -> raise Not_found *) + +(* let auto_include_otherlibs = + (* Ensure directories are only ever scanned once *) + let expand = Misc.expand_directory Config.standard_library in + let otherlibs = + let read_lib lib = lazy (Dir.create (expand ("+" ^ lib))) in + List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in + auto_include_libs otherlibs *) + +let find fn = + assert (not Config.merlin || Local_store.is_bound ()); + try + if is_basename fn && not !Sys.interactive then + STbl.find !files fn + else + Misc.find_in_path (get_paths ()) fn + with Not_found -> + !auto_include_callback Dir.find fn + +let find_uncap fn = + assert (not Config.merlin || Local_store.is_bound ()); + try + if is_basename fn && not !Sys.interactive then + STbl.find !files_uncap (String.uncapitalize_ascii fn) + else + Misc.find_in_path_uncap (get_paths ()) fn + with Not_found -> + let fn_uncap = String.uncapitalize_ascii fn in + !auto_include_callback Dir.find_uncap fn_uncap diff --git a/ocamlmerlin_mlx/ocaml/utils/load_path.mli b/ocamlmerlin_mlx/ocaml/utils/load_path.mli new file mode 100644 index 0000000..7d9abe0 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/load_path.mli @@ -0,0 +1,96 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2018 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Management of include directories. + + This module offers a high level interface to locating files in the + load path, which is constructed from [-I] command line flags and a few + other parameters. + + It makes the assumption that the contents of include directories + doesn't change during the execution of the compiler. +*) + +val add_dir : string -> unit +(** Add a directory to the end of the load path (i.e. at lowest priority.) *) + +val remove_dir : string -> unit +(** Remove a directory from the load path *) + +val reset : unit -> unit +(** Remove all directories *) + +module Dir : sig + type t + (** Represent one directory in the load path. *) + + val create : string -> t + + val path : t -> string + + val files : t -> string list + (** All the files in that directory. This doesn't include files in + sub-directories of this directory. *) + + val find : t -> string -> string option + (** [find dir fn] returns the full path to [fn] in [dir]. *) + + val find_uncap : t -> string -> string option + (** As {!find}, but search also for uncapitalized name, i.e. if name is + Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) +end + +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string +(** The type of callback functions on for [init ~auto_include] *) + +val no_auto_include : auto_include_callback +(** No automatic directory inclusion: misses in the load path raise [Not_found] + as normal. *) + +val init : auto_include:auto_include_callback -> string list -> unit +(** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *) + +(* val auto_include_otherlibs : + config:Mconfig.t -> (string -> unit) -> auto_include_callback *) +(** [auto_include_otherlibs alert] is a callback function to be passed to + {!Load_path.init} and automatically adds [-I +lib] to the load path after + calling [alert lib]. *) + +val get_paths : unit -> string list +(** Return the list of directories passed to [add_dir] so far. *) + +val find : string -> string +(** Locate a file in the load path. Raise [Not_found] if the file + cannot be found. This function is optimized for the case where the + filename is a basename, i.e. doesn't contain a directory + separator. *) + +val find_uncap : string -> string +(** Same as [find], but search also for uncapitalized name, i.e. if + name is Foo.ml, allow /path/Foo.ml and /path/foo.ml to match. *) + +val[@deprecated] add : Dir.t -> unit +(** Old name for {!append_dir} *) + +val append_dir : Dir.t -> unit +(** [append_dir d] adds [d] to the end of the load path (i.e. at lowest + priority. *) + +val prepend_dir : Dir.t -> unit +(** [prepend_dir d] adds [d] to the start of the load path (i.e. at highest + priority. *) + +val get : unit -> Dir.t list +(** Same as [get_paths ()], except that it returns a [Dir.t list]. *) diff --git a/ocamlmerlin_mlx/ocaml/utils/local_store.ml b/ocamlmerlin_mlx/ocaml/utils/local_store.ml new file mode 100644 index 0000000..b6d117e --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/local_store.ml @@ -0,0 +1,59 @@ +type ref_and_reset = + | Table : { ref: 'a ref; init: unit -> 'a } -> ref_and_reset + | Ref : { ref: 'a ref; mutable snapshot: 'a } -> ref_and_reset + +type bindings = { + mutable refs: ref_and_reset list; + mutable frozen : bool; + mutable is_bound: bool; +} + +let global_bindings = + { refs = []; is_bound = false; frozen = false } + +let is_bound () = global_bindings.is_bound + +let reset () = + assert (is_bound ()); + List.iter (function + | Table { ref; init } -> ref := init () + | Ref { ref; snapshot } -> ref := snapshot + ) global_bindings.refs + +let s_table create size = + let init () = create size in + let ref = ref (init ()) in + assert (not global_bindings.frozen); + global_bindings.refs <- (Table { ref; init }) :: global_bindings.refs; + ref + +let s_ref k = + let ref = ref k in + assert (not global_bindings.frozen); + global_bindings.refs <- + (Ref { ref; snapshot = k }) :: global_bindings.refs; + ref + +type slot = Slot : { ref : 'a ref; mutable value : 'a } -> slot +type store = slot list + +let fresh () = + let slots = + List.map (function + | Table { ref; init } -> Slot {ref; value = init ()} + | Ref r -> + if not global_bindings.frozen then r.snapshot <- !(r.ref); + Slot { ref = r.ref; value = r.snapshot } + ) global_bindings.refs + in + global_bindings.frozen <- true; + slots + +let with_store slots f = + assert (not global_bindings.is_bound); + global_bindings.is_bound <- true; + List.iter (fun (Slot {ref;value}) -> ref := value) slots; + Fun.protect f ~finally:(fun () -> + List.iter (fun (Slot s) -> s.value <- !(s.ref)) slots; + global_bindings.is_bound <- false; + ) diff --git a/ocamlmerlin_mlx/ocaml/utils/local_store.mli b/ocamlmerlin_mlx/ocaml/utils/local_store.mli new file mode 100644 index 0000000..3ea05d5 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/local_store.mli @@ -0,0 +1,66 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Frederic Bour, Tarides *) +(* Thomas Refis, Tarides *) +(* *) +(* Copyright 2020 Tarides *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** This module provides some facilities for creating references (and hash + tables) which can easily be snapshoted and restored to an arbitrary version. + + It is used throughout the frontend (read: typechecker), to register all + (well, hopefully) the global state. Thus making it easy for tools like + Merlin to go back and forth typechecking different files. *) + +(** {1 Creators} *) + +val s_ref : 'a -> 'a ref +(** Similar to {!val:Stdlib.ref}, except the allocated reference is registered + into the store. *) + +val s_table : ('a -> 'b) -> 'a -> 'b ref +(** Used to register hash tables. Those also need to be placed into refs to be + easily swapped out, but one can't just "snapshot" the initial value to + create fresh instances, so instead an initializer is required. + + Use it like this: + {[ + let my_table = s_table Hashtbl.create 42 + ]} +*) + +(** {1 State management} + + Note: all the following functions are currently unused inside the compiler + codebase. Merlin is their only user at the moment. *) + +type store + +val fresh : unit -> store +(** Returns a fresh instance of the store. + + The first time this function is called, it snapshots the value of all the + registered references, later calls to [fresh] will return instances + initialized to those values. *) + +val with_store : store -> (unit -> 'a) -> 'a +(** [with_store s f] resets all the registered references to the value they have + in [s] for the run of [f]. + If [f] updates any of the registered refs, [s] is updated to remember those + changes. *) + +val reset : unit -> unit +(** Resets all the references to the initial snapshot (i.e. to the same values + that new instances start with). *) + +val is_bound : unit -> bool +(** Returns [true] when a store is active (i.e. when called from the callback + passed to {!with_store}), [false] otherwise. *) diff --git a/ocamlmerlin_mlx/ocaml/utils/tbl.ml b/ocamlmerlin_mlx/ocaml/utils/tbl.ml new file mode 100644 index 0000000..fa278b4 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/tbl.ml @@ -0,0 +1,123 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type ('k, 'v) t = + Empty + | Node of ('k, 'v) t * 'k * 'v * ('k, 'v) t * int + +let empty = Empty + +let height = function + Empty -> 0 + | Node(_,_,_,_,h) -> h + +let create l x d r = + let hl = height l and hr = height r in + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + +let bal l x d r = + let hl = height l and hr = height r in + if hl > hr + 1 then + match l with + | Node (ll, lv, ld, lr, _) when height ll >= height lr -> + create ll lv ld (create lr x d r) + | Node (ll, lv, ld, Node (lrl, lrv, lrd, lrr, _), _) -> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + | _ -> assert false + else if hr > hl + 1 then + match r with + | Node (rl, rv, rd, rr, _) when height rr >= height rl -> + create (create l x d rl) rv rd rr + | Node (Node (rll, rlv, rld, rlr, _), rv, rd, rr, _) -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + | _ -> assert false + else + create l x d r + +let rec add x data = function + Empty -> + Node(Empty, x, data, Empty, 1) + | Node(l, v, d, r, h) -> + let c = compare x v in + if c = 0 then + Node(l, x, data, r, h) + else if c < 0 then + bal (add x data l) v d r + else + bal l v d (add x data r) + +let rec find x = function + Empty -> + raise Not_found + | Node(l, v, d, r, _) -> + let c = compare x v in + if c = 0 then d + else find x (if c < 0 then l else r) + +let rec find_str (x : string) = function + Empty -> + raise Not_found + | Node(l, v, d, r, _) -> + let c = compare x v in + if c = 0 then d + else find_str x (if c < 0 then l else r) + +let rec mem x = function + Empty -> false + | Node(l, v, _d, r, _) -> + let c = compare x v in + c = 0 || mem x (if c < 0 then l else r) + +let rec merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (Node(l1, v1, d1, r1, _h1), Node(l2, v2, d2, r2, _h2)) -> + bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2) + +let rec remove x = function + Empty -> + Empty + | Node(l, v, d, r, _h) -> + let c = compare x v in + if c = 0 then + merge l r + else if c < 0 then + bal (remove x l) v d r + else + bal l v d (remove x r) + +let rec iter f = function + Empty -> () + | Node(l, v, d, r, _) -> + iter f l; f v d; iter f r + +let rec map f = function + Empty -> Empty + | Node(l, v, d, r, h) -> Node(map f l, v, f v d, map f r, h) + +let rec fold f m accu = + match m with + | Empty -> accu + | Node(l, v, d, r, _) -> + fold f r (f v d (fold f l accu)) + +open Format + +let print print_key print_data ppf tbl = + let print_tbl ppf tbl = + iter (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d) + tbl in + fprintf ppf "@[[[%a]]@]" print_tbl tbl diff --git a/ocamlmerlin_mlx/ocaml/utils/tbl.mli b/ocamlmerlin_mlx/ocaml/utils/tbl.mli new file mode 100644 index 0000000..d23b959 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/tbl.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Association tables from any ordered type to any type. + We use the generic ordering to compare keys. *) + +type ('k, 'v) t + +val empty: ('k, 'v) t +val add: 'k -> 'v -> ('k, 'v) t -> ('k, 'v) t +val find: 'k -> ('k, 'v) t -> 'v +val find_str: string -> (string, 'v) t -> 'v +val mem: 'k -> ('k, 'v) t -> bool +val remove: 'k -> ('k, 'v) t -> ('k, 'v) t +val iter: ('k -> 'v -> unit) -> ('k, 'v) t -> unit +val map: ('k -> 'v1 -> 'v2) -> ('k, 'v1) t -> ('k, 'v2) t +val fold: ('k -> 'v -> 'acc -> 'acc) -> ('k, 'v) t -> 'acc -> 'acc + +open Format + +val print: (formatter -> 'k -> unit) -> (formatter -> 'v -> unit) -> + formatter -> ('k, 'v) t -> unit diff --git a/ocamlmerlin_mlx/ocaml/utils/warnings.ml b/ocamlmerlin_mlx/ocaml/utils/warnings.ml new file mode 100644 index 0000000..4eb85d8 --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/warnings.ml @@ -0,0 +1,1286 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* When you change this, you need to update: + - the list 'description' at the bottom of this file + - man/ocamlc.m +*) + +type loc = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +type field_usage_warning = + | Unused + | Not_read + | Not_mutated + +type constructor_usage_warning = + | Unused + | Not_constructed + | Only_exported_private + +type t = + | Comment_start (* 1 *) + | Comment_not_end (* 2 *) +(*| Deprecated --> alert "deprecated" *) (* 3 *) + | Fragile_match of string (* 4 *) + | Ignored_partial_application (* 5 *) + | Labels_omitted of string list (* 6 *) + | Method_override of string list (* 7 *) + | Partial_match of string (* 8 *) + | Missing_record_field_pattern of string (* 9 *) + | Non_unit_statement (* 10 *) + | Redundant_case (* 11 *) + | Redundant_subpat (* 12 *) + | Instance_variable_override of string list (* 13 *) + | Illegal_backslash (* 14 *) + | Implicit_public_methods of string list (* 15 *) + | Unerasable_optional_argument (* 16 *) + | Undeclared_virtual_method of string (* 17 *) + | Not_principal of string (* 18 *) + | Non_principal_labels of string (* 19 *) + | Ignored_extra_argument (* 20 *) + | Nonreturning_statement (* 21 *) + | Preprocessor of string (* 22 *) + | Useless_record_with (* 23 *) + | Bad_module_name of string (* 24 *) + | All_clauses_guarded (* 8, used to be 25 *) + | Unused_var of string (* 26 *) + | Unused_var_strict of string (* 27 *) + | Wildcard_arg_to_constant_constr (* 28 *) + | Eol_in_string (* 29 *) + | Duplicate_definitions of string * string * string * string (*30 *) + (* [Module_linked_twice of string * string * string] (* 31 *) + was turned into a hard error *) + | Unused_value_declaration of string (* 32 *) + | Unused_open of string (* 33 *) + | Unused_type_declaration of string (* 34 *) + | Unused_for_index of string (* 35 *) + | Unused_ancestor of string (* 36 *) + | Unused_constructor of string * constructor_usage_warning (* 37 *) + | Unused_extension of string * bool * constructor_usage_warning (* 38 *) + | Unused_rec_flag (* 39 *) + | Name_out_of_scope of string * string list * bool (* 40 *) + | Ambiguous_name of string list * string list * bool * string (* 41 *) + | Disambiguated_name of string (* 42 *) + | Nonoptional_label of string (* 43 *) + | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) + | Bad_env_variable of string * string (* 46 *) + | Attribute_payload of string * string (* 47 *) + | Eliminated_optional_arguments of string list (* 48 *) + | No_cmi_file of string * string option (* 49 *) + | Unexpected_docstring of bool (* 50 *) + | Wrong_tailcall_expectation of bool (* 51 *) + | Fragile_literal_pattern (* 52 *) + | Misplaced_attribute of string (* 53 *) + | Duplicated_attribute of string (* 54 *) + | Inlining_impossible of string (* 55 *) + | Unreachable_case (* 56 *) + | Ambiguous_var_in_pattern_guard of string list (* 57 *) + | No_cmx_file of string (* 58 *) + | Flambda_assignment_to_non_mutable_value (* 59 *) + | Unused_module of string (* 60 *) + | Unboxable_type_in_prim_decl of string (* 61 *) + | Constraint_on_gadt (* 62 *) + | Erroneous_printed_signature of string (* 63 *) + | Unsafe_array_syntax_without_parsing (* 64 *) + | Redefining_unit of string (* 65 *) + | Unused_open_bang of string (* 66 *) + | Unused_functor_parameter of string (* 67 *) + | Match_on_mutable_state_prevent_uncurry (* 68 *) + | Unused_field of string * field_usage_warning (* 69 *) + | Missing_mli (* 70 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) + +(* If you remove a warning, leave a hole in the numbering. NEVER change + the numbers of existing warnings. + If you add a new warning, add it at the end with a new number; + do NOT reuse one of the holes. +*) + +type alert = {kind:string; message:string; def:loc; use:loc} + +let number = function + | Comment_start -> 1 + | Comment_not_end -> 2 + | Fragile_match _ -> 4 + | Ignored_partial_application -> 5 + | Labels_omitted _ -> 6 + | Method_override _ -> 7 + | Partial_match _ -> 8 + | Missing_record_field_pattern _ -> 9 + | Non_unit_statement -> 10 + | Redundant_case -> 11 + | Redundant_subpat -> 12 + | Instance_variable_override _ -> 13 + | Illegal_backslash -> 14 + | Implicit_public_methods _ -> 15 + | Unerasable_optional_argument -> 16 + | Undeclared_virtual_method _ -> 17 + | Not_principal _ -> 18 + | Non_principal_labels _ -> 19 + | Ignored_extra_argument -> 20 + | Nonreturning_statement -> 21 + | Preprocessor _ -> 22 + | Useless_record_with -> 23 + | Bad_module_name _ -> 24 + | All_clauses_guarded -> 8 (* used to be 25 *) + | Unused_var _ -> 26 + | Unused_var_strict _ -> 27 + | Wildcard_arg_to_constant_constr -> 28 + | Eol_in_string -> 29 + | Duplicate_definitions _ -> 30 + | Unused_value_declaration _ -> 32 + | Unused_open _ -> 33 + | Unused_type_declaration _ -> 34 + | Unused_for_index _ -> 35 + | Unused_ancestor _ -> 36 + | Unused_constructor _ -> 37 + | Unused_extension _ -> 38 + | Unused_rec_flag -> 39 + | Name_out_of_scope _ -> 40 + | Ambiguous_name _ -> 41 + | Disambiguated_name _ -> 42 + | Nonoptional_label _ -> 43 + | Open_shadow_identifier _ -> 44 + | Open_shadow_label_constructor _ -> 45 + | Bad_env_variable _ -> 46 + | Attribute_payload _ -> 47 + | Eliminated_optional_arguments _ -> 48 + | No_cmi_file _ -> 49 + | Unexpected_docstring _ -> 50 + | Wrong_tailcall_expectation _ -> 51 + | Fragile_literal_pattern -> 52 + | Misplaced_attribute _ -> 53 + | Duplicated_attribute _ -> 54 + | Inlining_impossible _ -> 55 + | Unreachable_case -> 56 + | Ambiguous_var_in_pattern_guard _ -> 57 + | No_cmx_file _ -> 58 + | Flambda_assignment_to_non_mutable_value -> 59 + | Unused_module _ -> 60 + | Unboxable_type_in_prim_decl _ -> 61 + | Constraint_on_gadt -> 62 + | Erroneous_printed_signature _ -> 63 + | Unsafe_array_syntax_without_parsing -> 64 + | Redefining_unit _ -> 65 + | Unused_open_bang _ -> 66 + | Unused_functor_parameter _ -> 67 + | Match_on_mutable_state_prevent_uncurry -> 68 + | Unused_field _ -> 69 + | Missing_mli -> 70 + | Unused_tmc_attribute -> 71 + | Tmc_breaks_tailcall -> 72 + | Generative_application_expects_unit -> 73 +;; +(* DO NOT REMOVE the ;; above: it is used by + the testsuite/ests/warnings/mnemonics.mll test to determine where + the definition of the number function above ends *) + +let last_warning_number = 73 + +type description = + { number : int; + names : string list; + (* The first element of the list is the current name, any following ones are + deprecated. The current name should always be derived mechanically from + the constructor name. *) + description : string; + since : Sys.ocaml_release_info option; + (* The compiler version introducing this warning; only tagged for warnings + created after 3.12, which introduced the numbered syntax. *) + } + + let since major minor = Some { Sys.major; minor; patchlevel=0; extra=None } + +let descriptions = [ + { number = 1; + names = ["comment-start"]; + description = "Suspicious-looking start-of-comment mark."; + since = None }; + { number = 2; + names = ["comment-not-end"]; + description = "Suspicious-looking end-of-comment mark."; + since = None }; + { number = 3; + names = []; + description = "Deprecated synonym for the 'deprecated' alert."; + since = None }; + { number = 4; + names = ["fragile-match"]; + description = + "Fragile pattern matching: matching that will remain complete even\n\ + \ if additional constructors are added to one of the variant types\n\ + \ matched."; + since = None }; + { number = 5; + names = ["ignored-partial-application"]; + description = + "Partially applied function: expression whose result has function\n\ + \ type and is ignored."; + since = None }; + { number = 6; + names = ["labels-omitted"]; + description = "Label omitted in function application."; + since = None }; + { number = 7; + names = ["method-override"]; + description = "Method overridden."; + since = None }; + { number = 8; + names = ["partial-match"]; + description = "Partial match: missing cases in pattern-matching."; + since = None }; + { number = 9; + names = ["missing-record-field-pattern"]; + description = "Missing fields in a record pattern."; + since = None }; + { number = 10; + names = ["non-unit-statement"]; + description = + "Expression on the left-hand side of a sequence that doesn't have type\n\ + \ \"unit\" (and that is not a function, see warning number 5)."; + since = None }; + { number = 11; + names = ["redundant-case"]; + description = + "Redundant case in a pattern matching (unused match case)."; + since = None }; + { number = 12; + names = ["redundant-subpat"]; + description = "Redundant sub-pattern in a pattern-matching." ; + since = None}; + { number = 13; + names = ["instance-variable-override"]; + description = "Instance variable overridden."; + since = None }; + { number = 14; + names = ["illegal-backslash"]; + description = "Illegal backslash escape in a string constant."; + since = None }; + { number = 15; + names = ["implicit-public-methods"]; + description = "Private method made public implicitly."; + since = None }; + { number = 16; + names = ["unerasable-optional-argument"]; + description = "Unerasable optional argument."; + since = None }; + { number = 17; + names = ["undeclared-virtual-method"]; + description = "Undeclared virtual method."; + since = None }; + { number = 18; + names = ["not-principal"]; + description = "Non-principal type."; + since = None }; + { number = 19; + names = ["non-principal-labels"]; + description = "Type without principality."; + since = None }; + { number = 20; + names = ["ignored-extra-argument"]; + description = "Unused function argument."; + since = None }; + { number = 21; + names = ["nonreturning-statement"]; + description = "Non-returning statement."; + since = None }; + { number = 22; + names = ["preprocessor"]; + description = "Preprocessor warning."; + since = None }; + { number = 23; + names = ["useless-record-with"]; + description = "Useless record \"with\" clause."; + since = None }; + { number = 24; + names = ["bad-module-name"]; + description = + "Bad module name: the source file name is not a valid OCaml module name."; + since = None }; + { number = 25; + names = []; + description = "Ignored: now part of warning 8."; + since = None }; + { number = 26; + names = ["unused-var"]; + description = + "Suspicious unused variable: unused variable that is bound\n\ + \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character."; + since = None }; + { number = 27; + names = ["unused-var-strict"]; + description = + "Innocuous unused variable: unused variable that is not bound with\n\ + \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character."; + since = None }; + { number = 28; + names = ["wildcard-arg-to-constant-constr"]; + description = + "Wildcard pattern given as argument to a constant constructor."; + since = None }; + { number = 29; + names = ["eol-in-string"]; + description = + "Unescaped end-of-line in a string constant (non-portable code)."; + since = None }; + { number = 30; + names = ["duplicate-definitions"]; + description = + "Two labels or constructors of the same name are defined in two\n\ + \ mutually recursive types."; + since = None }; + { number = 31; + names = ["module-linked-twice"]; + description = + "A module is linked twice in the same executable.\n\ + \ Ignored: now a hard error (since 5.1)."; + since = None }; + { number = 32; + names = ["unused-value-declaration"]; + description = "Unused value declaration."; + since = since 4 0 }; + { number = 33; + names = ["unused-open"]; + description = "Unused open statement."; + since = since 4 0 }; + { number = 34; + names = ["unused-type-declaration"]; + description = "Unused type declaration."; + since = since 4 0 }; + { number = 35; + names = ["unused-for-index"]; + description = "Unused for-loop index."; + since = since 4 0 }; + { number = 36; + names = ["unused-ancestor"]; + description = "Unused ancestor variable."; + since = since 4 0 }; + { number = 37; + names = ["unused-constructor"]; + description = "Unused constructor."; + since = since 4 0 }; + { number = 38; + names = ["unused-extension"]; + description = "Unused extension constructor."; + since = since 4 0 }; + { number = 39; + names = ["unused-rec-flag"]; + description = "Unused rec flag."; + since = since 4 0 }; + { number = 40; + names = ["name-out-of-scope"]; + description = "Constructor or label name used out of scope."; + since = since 4 1 }; + { number = 41; + names = ["ambiguous-name"]; + description = "Ambiguous constructor or label name."; + since = since 4 1 }; + { number = 42; + names = ["disambiguated-name"]; + description = + "Disambiguated constructor or label name (compatibility warning)."; + since = since 4 1 }; + { number = 43; + names = ["nonoptional-label"]; + description = "Nonoptional label applied as optional."; + since = since 4 1 }; + { number = 44; + names = ["open-shadow-identifier"]; + description = "Open statement shadows an already defined identifier."; + since = since 4 1 }; + { number = 45; + names = ["open-shadow-label-constructor"]; + description = + "Open statement shadows an already defined label or constructor."; + since = since 4 1 }; + { number = 46; + names = ["bad-env-variable"]; + description = "Error in environment variable."; + since = since 4 1 }; + { number = 47; + names = ["attribute-payload"]; + description = "Illegal attribute payload."; + since = since 4 2 }; + { number = 48; + names = ["eliminated-optional-arguments"]; + description = "Implicit elimination of optional arguments."; + since = since 4 2 }; + { number = 49; + names = ["no-cmi-file"]; + description = "Absent cmi file when looking up module alias."; + since = since 4 2 }; + { number = 50; + names = ["unexpected-docstring"]; + description = "Unexpected documentation comment."; + since = since 4 3 }; + { number = 51; + names = ["wrong-tailcall-expectation"]; + description = + "Function call annotated with an incorrect @tailcall attribute."; + since = since 4 3 }; + { number = 52; + names = ["fragile-literal-pattern"]; + description = "Fragile constant pattern."; + since = since 4 3 }; + { number = 53; + names = ["misplaced-attribute"]; + description = "Attribute cannot appear in this context."; + since = since 4 3 }; + { number = 54; + names = ["duplicated-attribute"]; + description = "Attribute used more than once on an expression."; + since = since 4 3 }; + { number = 55; + names = ["inlining-impossible"]; + description = "Inlining impossible."; + since = since 4 3 }; + { number = 56; + names = ["unreachable-case"]; + description = + "Unreachable case in a pattern-matching (based on type information)."; + since = since 4 3 }; + { number = 57; + names = ["ambiguous-var-in-pattern-guard"]; + description = "Ambiguous or-pattern variables under guard."; + since = since 4 3 }; + { number = 58; + names = ["no-cmx-file"]; + description = "Missing cmx file."; + since = since 4 3 }; + { number = 59; + names = ["flambda-assignment-to-non-mutable-value"]; + description = "Assignment to non-mutable value."; + since = since 4 3 }; + { number = 60; + names = ["unused-module"]; + description = "Unused module declaration."; + since = since 4 4 }; + { number = 61; + names = ["unboxable-type-in-prim-decl"]; + description = "Unboxable type in primitive declaration."; + since = since 4 4 }; + { number = 62; + names = ["constraint-on-gadt"]; + description = "Type constraint on GADT type declaration."; + since = since 4 6 }; + { number = 63; + names = ["erroneous-printed-signature"]; + description = "Erroneous printed signature."; + since = since 4 8 }; + { number = 64; + names = ["unsafe-array-syntax-without-parsing"]; + description = + "-unsafe used with a preprocessor returning a syntax tree."; + since = since 4 8 }; + { number = 65; + names = ["redefining-unit"]; + description = "Type declaration defining a new '()' constructor."; + since = since 4 8 }; + { number = 66; + names = ["unused-open-bang"]; + description = "Unused open! statement."; + since = since 4 8 }; + { number = 67; + names = ["unused-functor-parameter"]; + description = "Unused functor parameter."; + since = since 4 10 }; + { number = 68; + names = ["match-on-mutable-state-prevent-uncurry"]; + description = + "Pattern-matching depending on mutable state prevents the remaining \n\ + \ arguments from being uncurried."; + since = since 4 12 }; + { number = 69; + names = ["unused-field"]; + description = "Unused record field."; + since = since 4 13 }; + { number = 70; + names = ["missing-mli"]; + description = "Missing interface file."; + since = since 4 13 }; + { number = 71; + names = ["unused-tmc-attribute"]; + description = "Unused @tail_mod_cons attribute."; + since = since 4 14 }; + { number = 72; + names = ["tmc-breaks-tailcall"]; + description = "A tail call is turned into a non-tail call \ + by the @tail_mod_cons transformation."; + since = since 4 14 }; + { number = 73; + names = ["generative-application-expects-unit"]; + description = "A generative functor is applied to an empty structure \ + (struct end) rather than to ()."; + since = since 5 1 }; +] + +let name_to_number = + let h = Hashtbl.create last_warning_number in + List.iter (fun {number; names; _} -> + List.iter (fun name -> Hashtbl.add h name number) names + ) descriptions; + fun s -> Hashtbl.find_opt h s + +(* Must be the max number returned by the [number] function. *) + +let letter = function + | 'a' -> + let rec loop i = if i = 0 then [] else i :: loop (i - 1) in + loop last_warning_number + | 'b' -> [] + | 'c' -> [1; 2] + | 'd' -> [3] + | 'e' -> [4] + | 'f' -> [5] + | 'g' -> [] + | 'h' -> [] + | 'i' -> [] + | 'j' -> [] + | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39] + | 'l' -> [6] + | 'm' -> [7] + | 'n' -> [] + | 'o' -> [] + | 'p' -> [8] + | 'q' -> [] + | 'r' -> [9] + | 's' -> [10] + | 't' -> [] + | 'u' -> [11; 12] + | 'v' -> [13] + | 'w' -> [] + | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30] + | 'y' -> [26] + | 'z' -> [27] + | _ -> assert false + +type state = + { + active: bool array; + error: bool array; + alerts: (Std.String.Set.t * bool); (* false:set complement *) + alert_errors: (Std.String.Set.t * bool); (* false:set complement *) + } + +let current = + ref + { + active = Array.make (last_warning_number + 1) true; + error = Array.make (last_warning_number + 1) false; + alerts = (Std.String.Set.empty, false); + alert_errors = (Std.String.Set.empty, true); (* all soft *) + } + +let disabled = ref false + +let without_warnings f = + Misc.protect_refs [Misc.R(disabled, true)] f + +let backup () = !current + +let restore x = current := x + +(* Some warnings are not properly implemented in merlin, just disable *) +let is_disabled x = Config.merlin && ((x >= 32 && x <= 39) || x = 60 || x = 69) + +let is_active x = + not !disabled && + let x = number x in + not (is_disabled x) && (!current).active.(x) + +let is_error x = + not !disabled && + let x = number x in + not (is_disabled x) && (!current).error.(x) + +let alert_is_active {kind; _} = + not !disabled && + let (set, pos) = (!current).alerts in + Std.String.Set.mem kind set = pos + +let alert_is_error {kind; _} = + not !disabled && + let (set, pos) = (!current).alert_errors in + Std.String.Set.mem kind set = pos + +let with_state state f = + let prev = backup () in + restore state; + try + let r = f () in + restore prev; + r + with exn -> + restore prev; + raise exn + +let mk_lazy f = + let state = backup () in + lazy (with_state state f) + +let set_alert ~error ~enable s = + let upd = + match s with + | "all" -> + (Std.String.Set.empty, not enable) + | s -> + let (set, pos) = + if error then (!current).alert_errors else (!current).alerts + in + let f = + if enable = pos + then Std.String.Set.add + else Std.String.Set.remove + in + (f s set, pos) + in + if error then + current := {(!current) with alert_errors=upd} + else + current := {(!current) with alerts=upd} + +let parse_alert_option s = + let n = String.length s in + let id_char = function + | 'a'..'z' | 'A'..'Z' | '_' | '\'' | '0'..'9' -> true + | _ -> false + in + let rec parse_id i = + if i < n && id_char s.[i] then parse_id (i + 1) else i + in + let rec scan i = + if i = n then () + else if i + 1 = n then raise (Arg.Bad "Ill-formed list of alert settings") + else match s.[i], s.[i+1] with + | '+', '+' -> id (set_alert ~error:true ~enable:true) (i + 2) + | '+', _ -> id (set_alert ~error:false ~enable:true) (i + 1) + | '-', '-' -> id (set_alert ~error:true ~enable:false) (i + 2) + | '-', _ -> id (set_alert ~error:false ~enable:false) (i + 1) + | '@', _ -> + id (fun s -> + set_alert ~error:true ~enable:true s; + set_alert ~error:false ~enable:true s) + (i + 1) + | _ -> raise (Arg.Bad "Ill-formed list of alert settings") + and id f i = + let j = parse_id i in + if j = i then raise (Arg.Bad "Ill-formed list of alert settings"); + let id = String.sub s i (j - i) in + f id; + scan j + in + scan 0 + +type modifier = + | Set (** +a *) + | Clear (** -a *) + | Set_all (** @a *) + +type token = + | Letter of char * modifier option + | Num of int * int * modifier + +let ghost_loc_in_file name = + let pos = { Lexing.dummy_pos with pos_fname = name } in + { loc_start = pos; loc_end = pos; loc_ghost = true } + +let letter_alert tokens = + let print_warning_char ppf c = + let lowercase = Char.lowercase_ascii c = c in + Format.fprintf ppf "%c%c" + (if lowercase then '-' else '+') c + in + let print_modifier ppf = function + | Set_all -> Format.fprintf ppf "@" + | Clear -> Format.fprintf ppf "-" + | Set -> Format.fprintf ppf "+" + in + let print_token ppf = function + | Num (a,b,m) -> if a = b then + Format.fprintf ppf "%a%d" print_modifier m a + else + Format.fprintf ppf "%a%d..%d" print_modifier m a b + | Letter(l,Some m) -> Format.fprintf ppf "%a%c" print_modifier m l + | Letter(l,None) -> print_warning_char ppf l + in + let consecutive_letters = + (* we are tracking sequences of 2 or more consecutive unsigned letters + in warning strings, for instance in '-w "not-principa"'. *) + let commit_chunk l = function + | [] | [ _ ] -> l + | _ :: _ :: _ as chunk -> List.rev chunk :: l + in + let group_consecutive_letters (l,current) = function + | Letter (x, None) -> (l, x::current) + | _ -> (commit_chunk l current, []) + in + let l, on_going = + List.fold_left group_consecutive_letters ([],[]) tokens + in + commit_chunk l on_going + in + match consecutive_letters with + | [] -> None + | example :: _ -> + let nowhere = ghost_loc_in_file "_none_" in + let spelling_hint ppf = + let max_seq_len = + List.fold_left (fun l x -> Int.max l (List.length x)) + 0 consecutive_letters + in + if max_seq_len >= 5 then + Format.fprintf ppf + "@ @[Hint: Did you make a spelling mistake \ + when using a mnemonic name?@]" + else + () + in + let message = + Format.asprintf + "@[@[Setting a warning with a sequence of lowercase \ + or uppercase letters,@ like '%a',@ is deprecated.@]@ \ + @[Use the equivalent signed form:@ %t.@]@ \ + @[Hint: Enabling or disabling a warning by its mnemonic name \ + requires a + or - prefix.@]\ + %t@?@]" + Format.(pp_print_list ~pp_sep:(fun _ -> ignore) pp_print_char) example + (fun ppf -> List.iter (print_token ppf) tokens) + spelling_hint + in + Some { + kind="ocaml_deprecated_cli"; + use=nowhere; def=nowhere; + message + } + + +let parse_warnings s = + let error () = raise (Arg.Bad "Ill-formed list of warnings") in + let rec get_num n i = + if i >= String.length s then i, n + else match s.[i] with + | '0'..'9' -> get_num (10 * n + Char.code s.[i] - Char.code '0') (i + 1) + | _ -> i, n + in + let get_range i = + let i, n1 = get_num 0 i in + if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then + let i, n2 = get_num 0 (i + 2) in + if n2 < n1 then error (); + i, n1, n2 + else + i, n1, n1 + in + let rec loop tokens i = + if i >= String.length s then List.rev tokens else + match s.[i] with + | 'A' .. 'Z' | 'a' .. 'z' -> + loop (Letter(s.[i],None)::tokens) (i+1) + | '+' -> loop_letter_num tokens Set (i+1) + | '-' -> loop_letter_num tokens Clear (i+1) + | '@' -> loop_letter_num tokens Set_all (i+1) + | _ -> error () + and loop_letter_num tokens modifier i = + if i >= String.length s then error () else + match s.[i] with + | '0' .. '9' -> + let i, n1, n2 = get_range i in + loop (Num(n1,n2,modifier)::tokens) i + | 'A' .. 'Z' | 'a' .. 'z' -> + loop (Letter(s.[i],Some modifier)::tokens) (i+1) + | _ -> error () + in + loop [] 0 + +let parse_opt error active errflag s = + let flags = if errflag then error else active in + let action modifier i = match modifier with + | Set -> + if i = 3 then set_alert ~error:errflag ~enable:true "deprecated" + else flags.(i) <- true + | Clear -> + if i = 3 then set_alert ~error:errflag ~enable:false "deprecated" + else flags.(i) <- false + | Set_all -> + if i = 3 then begin + set_alert ~error:false ~enable:true "deprecated"; + set_alert ~error:true ~enable:true "deprecated" + end + else begin + active.(i) <- true; + error.(i) <- true + end + in + let eval = function + | Letter(c, m) -> + let lc = Char.lowercase_ascii c in + let modifier = match m with + | None -> if c = lc then Clear else Set + | Some m -> m + in + List.iter (action modifier) (letter lc) + | Num(n1,n2,modifier) -> + for n = n1 to Int.min n2 last_warning_number do action modifier n done + in + let parse_and_eval s = + let tokens = parse_warnings s in + List.iter eval tokens; + letter_alert tokens + in + match name_to_number s with + | Some n -> action Set n; None + | None -> + if s = "" then parse_and_eval s + else begin + let rest = String.sub s 1 (String.length s - 1) in + match s.[0], name_to_number rest with + | '+', Some n -> action Set n; None + | '-', Some n -> action Clear n; None + | '@', Some n -> action Set_all n; None + | _ -> parse_and_eval s + end + +let parse_options errflag s = + let error = Array.copy (!current).error in + let active = Array.copy (!current).active in + let alerts = parse_opt error active errflag s in + current := {(!current) with error; active}; + alerts + +(* If you change these, don't forget to change them in man/ocamlc.m *) +let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70" +let defaults_warn_error = "-a" +let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] + + +let () = ignore @@ parse_options false defaults_w +let () = ignore @@ parse_options true defaults_warn_error +let () = + List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts + +let message = function + | Comment_start -> + "this `(*' is the start of a comment.\n\ + Hint: Did you forget spaces when writing the infix operator `( * )'?" + | Comment_not_end -> "this is not the end of a comment." + | Fragile_match "" -> + "this pattern-matching is fragile." + | Fragile_match s -> + "this pattern-matching is fragile.\n\ + It will remain exhaustive when constructors are added to type " ^ s ^ "." + | Ignored_partial_application -> + "this function application is partial,\n\ + maybe some arguments are missing." + | Labels_omitted [] -> assert false + | Labels_omitted [l] -> + "label " ^ l ^ " was omitted in the application of this function." + | Labels_omitted ls -> + "labels " ^ String.concat ", " ls ^ + " were omitted in the application of this function." + | Method_override [lab] -> + "the method " ^ lab ^ " is overridden." + | Method_override (cname :: slist) -> + String.concat " " + ("the following methods are overridden by the class" + :: cname :: ":\n " :: slist) + | Method_override [] -> assert false + | Partial_match "" -> "this pattern-matching is not exhaustive." + | Partial_match s -> + "this pattern-matching is not exhaustive.\n\ + Here is an example of a case that is not matched:\n" ^ s + | Missing_record_field_pattern s -> + "the following labels are not bound in this record pattern:\n" ^ s ^ + "\nEither bind these labels explicitly or add '; _' to the pattern." + | Non_unit_statement -> + "this expression should have type unit." + | Redundant_case -> "this match case is unused." + | Redundant_subpat -> "this sub-pattern is unused." + | Instance_variable_override [lab] -> + "the instance variable " ^ lab ^ " is overridden." + | Instance_variable_override (cname :: slist) -> + String.concat " " + ("the following instance variables are overridden by the class" + :: cname :: ":\n " :: slist) + | Instance_variable_override [] -> assert false + | Illegal_backslash -> + "illegal backslash escape in string.\n\ + Hint: Single backslashes \\ are reserved for escape sequences\n\ + (\\n, \\r, ...). Did you check the list of OCaml escape sequences?\n\ + To get a backslash character, escape it with a second backslash: \\\\." + | Implicit_public_methods l -> + "the following private methods were made public implicitly:\n " + ^ String.concat " " l ^ "." + | Unerasable_optional_argument -> "this optional argument cannot be erased." + | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared." + | Not_principal s -> s^" is not principal." + | Non_principal_labels s -> s^" without principality." + | Ignored_extra_argument -> "this argument will not be used by the function." + | Nonreturning_statement -> + "this statement never returns (or has an unsound type.)" + | Preprocessor s -> s + | Useless_record_with -> + "all the fields are explicitly listed in this record:\n\ + the 'with' clause is useless." + | Bad_module_name (modname) -> + "bad source file name: \"" ^ modname ^ "\" is not a valid module name." + | All_clauses_guarded -> + "this pattern-matching is not exhaustive.\n\ + All clauses in this pattern-matching are guarded." + | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "." + | Wildcard_arg_to_constant_constr -> + "wildcard pattern given as argument to a constant constructor" + | Eol_in_string -> + "unescaped end-of-line in a string constant (non-portable code)" + | Duplicate_definitions (kind, cname, tc1, tc2) -> + Printf.sprintf "the %s %s is defined in both types %s and %s." + kind cname tc1 tc2 + | Unused_value_declaration v -> "unused value " ^ v ^ "." + | Unused_open s -> "unused open " ^ s ^ "." + | Unused_open_bang s -> "unused open! " ^ s ^ "." + | Unused_type_declaration s -> "unused type " ^ s ^ "." + | Unused_for_index s -> "unused for-loop index " ^ s ^ "." + | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "." + | Unused_constructor (s, Unused) -> "unused constructor " ^ s ^ "." + | Unused_constructor (s, Not_constructed) -> + "constructor " ^ s ^ + " is never used to build values.\n\ + (However, this constructor appears in patterns.)" + | Unused_constructor (s, Only_exported_private) -> + "constructor " ^ s ^ + " is never used to build values.\n\ + Its type is exported as a private type." + | Unused_extension (s, is_exception, complaint) -> + let kind = + if is_exception then "exception" else "extension constructor" in + let name = kind ^ " " ^ s in + begin match complaint with + | Unused -> "unused " ^ name + | Not_constructed -> + name ^ + " is never used to build values.\n\ + (However, this constructor appears in patterns.)" + | Only_exported_private -> + name ^ + " is never used to build values.\n\ + It is exported or rebound as a private extension." + end + | Unused_rec_flag -> + "unused rec flag." + | Name_out_of_scope (ty, [nm], false) -> + nm ^ " was selected from type " ^ ty ^ + ".\nIt is not visible in the current scope, and will not \n\ + be selected if the type becomes unknown." + | Name_out_of_scope (_, _, false) -> assert false + | Name_out_of_scope (ty, slist, true) -> + "this record of type "^ ty ^" contains fields that are \n\ + not visible in the current scope: " + ^ String.concat " " slist ^ ".\n\ + They will not be selected if the type becomes unknown." + | Ambiguous_name ([s], tl, false, expansion) -> + s ^ " belongs to several types: " ^ String.concat " " tl ^ + "\nThe first one was selected. Please disambiguate if this is wrong." + ^ expansion + | Ambiguous_name (_, _, false, _ ) -> assert false + | Ambiguous_name (_slist, tl, true, expansion) -> + "these field labels belong to several types: " ^ + String.concat " " tl ^ + "\nThe first one was selected. Please disambiguate if this is wrong." + ^ expansion + | Disambiguated_name s -> + "this use of " ^ s ^ " relies on type-directed disambiguation,\n\ + it will not compile with OCaml 4.00 or earlier." + | Nonoptional_label s -> + "the label " ^ s ^ " is not optional." + | Open_shadow_identifier (kind, s) -> + Printf.sprintf + "this open statement shadows the %s identifier %s (which is later used)" + kind s + | Open_shadow_label_constructor (kind, s) -> + Printf.sprintf + "this open statement shadows the %s %s (which is later used)" + kind s + | Bad_env_variable (var, s) -> + Printf.sprintf "illegal environment variable %s : %s" var s + | Attribute_payload (a, s) -> + Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s + | Eliminated_optional_arguments sl -> + Printf.sprintf "implicit elimination of optional argument%s %s" + (if List.length sl = 1 then "" else "s") + (String.concat ", " sl) + | No_cmi_file(name, None) -> + "no cmi file was found in path for module " ^ name + | No_cmi_file(name, Some msg) -> + Printf.sprintf + "no valid cmi file was found in path for module %s. %s" + name msg + | Unexpected_docstring unattached -> + if unattached then "unattached documentation comment (ignored)" + else "ambiguous documentation comment" + | Wrong_tailcall_expectation b -> + Printf.sprintf "expected %s" + (if b then "tailcall" else "non-tailcall") + | Fragile_literal_pattern -> + let[@manual.ref "ss:warn52"] ref_manual = [ 13; 5; 3 ] in + Format.asprintf + "Code should not depend on the actual values of\n\ + this constructor's arguments. They are only for information\n\ + and may change in future versions. %a" + Misc.print_see_manual ref_manual + | Unreachable_case -> + "this match case is unreachable.\n\ + Consider replacing it with a refutation case ' -> .'" + | Misplaced_attribute attr_name -> + Printf.sprintf "the %S attribute cannot appear in this context" attr_name + | Duplicated_attribute attr_name -> + Printf.sprintf "the %S attribute is used more than once on this \ + expression" + attr_name + | Inlining_impossible reason -> + Printf.sprintf "Cannot inline: %s" reason + | Ambiguous_var_in_pattern_guard vars -> + let[@manual.ref "ss:warn57"] ref_manual = [ 13; 5; 4 ] in + let vars = List.sort String.compare vars in + let vars_explanation = + let in_different_places = + "in different places in different or-pattern alternatives" + in + match vars with + | [] -> assert false + | [x] -> "variable " ^ x ^ " appears " ^ in_different_places + | _::_ -> + let vars = String.concat ", " vars in + "variables " ^ vars ^ " appear " ^ in_different_places + in + Format.asprintf + "Ambiguous or-pattern variables under guard;\n\ + %s.\n\ + Only the first match will be used to evaluate the guard expression.\n\ + %a" + vars_explanation Misc.print_see_manual ref_manual + | No_cmx_file name -> + Printf.sprintf + "no cmx file was found in path for module %s, \ + and its interface was not compiled with -opaque" name + | Flambda_assignment_to_non_mutable_value -> + "A potential assignment to a non-mutable value was detected \n\ + in this source file. Such assignments may generate incorrect code \n\ + when using Flambda." + | Unused_module s -> "unused module " ^ s ^ "." + | Unboxable_type_in_prim_decl t -> + Printf.sprintf + "This primitive declaration uses type %s, whose representation\n\ + may be either boxed or unboxed. Without an annotation to indicate\n\ + which representation is intended, the boxed representation has been\n\ + selected by default. This default choice may change in future\n\ + versions of the compiler, breaking the primitive implementation.\n\ + You should explicitly annotate the declaration of %s\n\ + with [@@boxed] or [@@unboxed], so that its external interface\n\ + remains stable in the future." t t + | Constraint_on_gadt -> + "Type constraints do not apply to GADT cases of variant types." + | Erroneous_printed_signature s -> + "The printed interface differs from the inferred interface.\n\ + The inferred interface contained items which could not be printed\n\ + properly due to name collisions between identifiers." + ^ s + ^ "\nBeware that this warning is purely informational and will not catch\n\ + all instances of erroneous printed interface." + | Unsafe_array_syntax_without_parsing -> + "option -unsafe used with a preprocessor returning a syntax tree" + | Redefining_unit name -> + Printf.sprintf + "This type declaration is defining a new '()' constructor\n\ + which shadows the existing one.\n\ + Hint: Did you mean 'type %s = unit'?" name + | Unused_functor_parameter s -> "unused functor parameter " ^ s ^ "." + | Match_on_mutable_state_prevent_uncurry -> + "This pattern depends on mutable state.\n\ + It prevents the remaining arguments from being uncurried, which will \ + cause additional closure allocations." + | Unused_field (s, Unused) -> "unused record field " ^ s ^ "." + | Unused_field (s, Not_read) -> + "record field " ^ s ^ + " is never read.\n\ + (However, this field is used to build or mutate values.)" + | Unused_field (s, Not_mutated) -> + "mutable record field " ^ s ^ + " is never mutated." + | Missing_mli -> + "Cannot find interface file." + | Unused_tmc_attribute -> + "This function is marked @tail_mod_cons\n\ + but is never applied in TMC position." + | Tmc_breaks_tailcall -> + "This call\n\ + is in tail-modulo-cons position in a TMC function,\n\ + but the function called is not itself specialized for TMC,\n\ + so the call will not be transformed into a tail call.\n\ + Please either mark the called function with the [@tail_mod_cons]\n\ + attribute, or mark this call with the [@tailcall false] attribute\n\ + to make its non-tailness explicit." + | Generative_application_expects_unit -> + "A generative functor\n\ + should be applied to '()'; using '(struct end)' is deprecated." +;; + +let nerrors = ref 0 + +type reporting_information = + { id : string + ; message : string + ; is_error : bool + ; sub_locs : (loc * string) list; + } + +let id_name w = + let n = number w in + (* (* Merlin: let's keep our messages compact. *) + match List.find_opt (fun {number; _} -> number = n) descriptions with + | Some {names = s :: _; _} -> + Printf.sprintf "%d [%s]" n s + | _ -> + string_of_int n + *) + string_of_int n + +let report w = + match is_active w with + | false -> `Inactive + | true -> + if is_error w then incr nerrors; + `Active + { id = id_name w; + message = message w; + is_error = is_error w; + sub_locs = []; + } + +let report_alert (alert : alert) = + match alert_is_active alert with + | false -> `Inactive + | true -> + let is_error = alert_is_error alert in + if is_error then incr nerrors; + let message = Misc.normalise_eol alert.message in + (* Reduce \r\n to \n: + - Prevents any \r characters being printed on Unix when processing + Windows sources + - Prevents \r\r\n being generated on Windows, which affects the + testsuite + *) + let sub_locs = + if not alert.def.loc_ghost && not alert.use.loc_ghost then + [ + alert.def, "Definition"; + alert.use, "Expected signature"; + ] + else + [] + in + `Active + { + id = alert.kind; + message; + is_error; + sub_locs; + } + +exception Errors + +let reset_fatal () = + nerrors := 0 + +let check_fatal () = + if !nerrors > 0 then begin + nerrors := 0; + raise Errors; + end + +let pp_since out release_info = + Printf.fprintf out " (since %d.%0*d)" + release_info.Sys.major + (if release_info.Sys.major >= 5 then 0 else 2) + release_info.Sys.minor + +let help_warnings () = + List.iter + (fun {number; description; names; since} -> + let name = + match names with + | s :: _ -> " [" ^ s ^ "]" + | [] -> "" + in + Printf.printf "%3i%s %s%a\n" + number name description (fun out -> Option.iter (pp_since out)) since) + descriptions; + print_endline " A all warnings"; + for i = Char.code 'b' to Char.code 'z' do + let c = Char.chr i in + match letter c with + | [] -> () + | [n] -> + Printf.printf " %c Alias for warning %i.\n" (Char.uppercase_ascii c) n + | l -> + Printf.printf " %c warnings %s.\n" + (Char.uppercase_ascii c) + (String.concat ", " (List.map Int.to_string l)) + done; + exit 0 + +(* merlin *) + +let dump ?(verbose=false) () = + let open Std in + let actives arr = + let acc = ref [] in + for i = 1 to last_warning_number do + if arr.(i) then ( + let x = + try + if verbose then + let { description; _ } = List.find + ~f:(fun { number; _ } -> number = i) descriptions + in + `String (string_of_int i ^ ": " ^ description) + else + `Int i + with Not_found -> `Int i + in + acc := x :: !acc + ) + done; + List.rev !acc + in + let alerts (set, enabled) = + `Assoc + [ "alerts", Json.list Json.string (String.Set.elements set); + "complement", Json.bool (not enabled) ] + in + `Assoc [ + "actives", `List (actives !current.active); + "warn_error", `List (actives !current.error); + "alerts", alerts !current.alerts; + "alerts_error", alerts !current.alert_errors; + ] diff --git a/ocamlmerlin_mlx/ocaml/utils/warnings.mli b/ocamlmerlin_mlx/ocaml/utils/warnings.mli new file mode 100644 index 0000000..08f30ac --- /dev/null +++ b/ocamlmerlin_mlx/ocaml/utils/warnings.mli @@ -0,0 +1,169 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Warning definitions + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +type loc = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +val ghost_loc_in_file : string -> loc +(** Return an empty ghost range located in a given file *) + +type field_usage_warning = + | Unused + | Not_read + | Not_mutated + +type constructor_usage_warning = + | Unused + | Not_constructed + | Only_exported_private + +type t = + | Comment_start (* 1 *) + | Comment_not_end (* 2 *) +(*| Deprecated --> alert "deprecated" *) (* 3 *) + | Fragile_match of string (* 4 *) + | Ignored_partial_application (* 5 *) + | Labels_omitted of string list (* 6 *) + | Method_override of string list (* 7 *) + | Partial_match of string (* 8 *) + | Missing_record_field_pattern of string (* 9 *) + | Non_unit_statement (* 10 *) + | Redundant_case (* 11 *) + | Redundant_subpat (* 12 *) + | Instance_variable_override of string list (* 13 *) + | Illegal_backslash (* 14 *) + | Implicit_public_methods of string list (* 15 *) + | Unerasable_optional_argument (* 16 *) + | Undeclared_virtual_method of string (* 17 *) + | Not_principal of string (* 18 *) + | Non_principal_labels of string (* 19 *) + | Ignored_extra_argument (* 20 *) + | Nonreturning_statement (* 21 *) + | Preprocessor of string (* 22 *) + | Useless_record_with (* 23 *) + | Bad_module_name of string (* 24 *) + | All_clauses_guarded (* 8, used to be 25 *) + | Unused_var of string (* 26 *) + | Unused_var_strict of string (* 27 *) + | Wildcard_arg_to_constant_constr (* 28 *) + | Eol_in_string (* 29 *) + | Duplicate_definitions of string * string * string * string (* 30 *) + | Unused_value_declaration of string (* 32 *) + | Unused_open of string (* 33 *) + | Unused_type_declaration of string (* 34 *) + | Unused_for_index of string (* 35 *) + | Unused_ancestor of string (* 36 *) + | Unused_constructor of string * constructor_usage_warning (* 37 *) + | Unused_extension of string * bool * constructor_usage_warning (* 38 *) + | Unused_rec_flag (* 39 *) + | Name_out_of_scope of string * string list * bool (* 40 *) + | Ambiguous_name of string list * string list * bool * string (* 41 *) + | Disambiguated_name of string (* 42 *) + | Nonoptional_label of string (* 43 *) + | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) + | Bad_env_variable of string * string (* 46 *) + | Attribute_payload of string * string (* 47 *) + | Eliminated_optional_arguments of string list (* 48 *) + | No_cmi_file of string * string option (* 49 *) + | Unexpected_docstring of bool (* 50 *) + | Wrong_tailcall_expectation of bool (* 51 *) + | Fragile_literal_pattern (* 52 *) + | Misplaced_attribute of string (* 53 *) + | Duplicated_attribute of string (* 54 *) + | Inlining_impossible of string (* 55 *) + | Unreachable_case (* 56 *) + | Ambiguous_var_in_pattern_guard of string list (* 57 *) + | No_cmx_file of string (* 58 *) + | Flambda_assignment_to_non_mutable_value (* 59 *) + | Unused_module of string (* 60 *) + | Unboxable_type_in_prim_decl of string (* 61 *) + | Constraint_on_gadt (* 62 *) + | Erroneous_printed_signature of string (* 63 *) + | Unsafe_array_syntax_without_parsing (* 64 *) + | Redefining_unit of string (* 65 *) + | Unused_open_bang of string (* 66 *) + | Unused_functor_parameter of string (* 67 *) + | Match_on_mutable_state_prevent_uncurry (* 68 *) + | Unused_field of string * field_usage_warning (* 69 *) + | Missing_mli (* 70 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) + +type alert = {kind:string; message:string; def:loc; use:loc} + +val parse_options : bool -> string -> alert option + +val parse_alert_option: string -> unit + (** Disable/enable alerts based on the parameter to the -alert + command-line option. Raises [Arg.Bad] if the string is not a + valid specification. + *) + +val without_warnings : (unit -> 'a) -> 'a + (** Run the thunk with all warnings and alerts disabled. *) + +val is_active : t -> bool +val is_error : t -> bool + +val defaults_w : string +val defaults_warn_error : string + +type reporting_information = + { id : string + ; message : string + ; is_error : bool + ; sub_locs : (loc * string) list; + } + +val report : t -> [ `Active of reporting_information | `Inactive ] +val report_alert : alert -> [ `Active of reporting_information | `Inactive ] + +exception Errors + +val check_fatal : unit -> unit +val reset_fatal: unit -> unit + +val help_warnings: unit -> unit + +type state +val backup: unit -> state +val restore: state -> unit +val with_state : state -> (unit -> 'a) -> 'a +val mk_lazy: (unit -> 'a) -> 'a Lazy.t + (** Like [Lazy.of_fun], but the function is applied with + the warning/alert settings at the time [mk_lazy] is called. *) + +type description = + { number : int; + names : string list; + description : string; + since : Sys.ocaml_release_info option; } + +val descriptions : description list + +(* merlin *) +val dump : ?verbose:bool -> unit -> Std.json diff --git a/ocamlmerlin_mlx/ocamlmerlin_mlx.ml b/ocamlmerlin_mlx/ocamlmerlin_mlx.ml index 3ccaa36..f43981d 100644 --- a/ocamlmerlin_mlx/ocamlmerlin_mlx.ml +++ b/ocamlmerlin_mlx/ocamlmerlin_mlx.ml @@ -3,13 +3,27 @@ open Merlin_extend.Extend_protocol.Reader open Ocaml_parsing open Mlx_kernel +module Conv = Ppxlib_ast.Convert(Ppxlib_ast__Versions.OCaml_501)(Ppxlib_ast.Compiler_version) + +let conv_signature intf = + let intf: Astlib.Ast_501.Parsetree.signature = Obj.magic intf in + let intf = Conv.copy_signature intf in + let intf: Ocaml_parsing.Parsetree.signature = Obj.magic intf in + intf + +let conv_structure impl = + let impl: Astlib.Ast_501.Parsetree.structure = Obj.magic impl in + let impl = Conv.copy_structure impl in + let impl: Ocaml_parsing.Parsetree.structure = Obj.magic impl in + impl + let parse_string filename str = let src = Msource.make str in let cfg = Mconfig.initial in let cfg = { cfg with - Merlin_kernel.Mconfig.query = { cfg.query with filename }; + Mconfig.query = { cfg.query with filename }; (* override this so we don't try to run any extensions *) merlin = { cfg.merlin with extension_to_reader = [] }; } @@ -67,17 +81,17 @@ module Mlx_reader = struct List.filter_map to_extension_node res.lexer_errors in match res.parsetree with - | `Interface intf -> Signature intf + | `Interface intf -> Signature (conv_signature intf) | `Implementation impl -> - Structure (impl @ parser_errors @ lexer_errors) + Structure (conv_structure impl @ parser_errors @ lexer_errors) let for_completion t _pos = { complete_labels = true }, parse t let parse_line _ _ text = let res = parse_string "*buffer*" text in match res.parsetree with - | `Interface intf -> Signature intf - | `Implementation impl -> Structure impl + | `Interface intf -> Signature (conv_signature intf) + | `Implementation impl -> Structure (conv_structure impl) let ident_at _ _ = [] let pretty_print _ppf _ = () diff --git a/ocamlmerlin_mlx/utils/dune b/ocamlmerlin_mlx/utils/dune new file mode 100644 index 0000000..33966fc --- /dev/null +++ b/ocamlmerlin_mlx/utils/dune @@ -0,0 +1,19 @@ +(library + (name mlx_utils) + (package ocamlmerlin-mlx) + (libraries str unix) + (foreign_stubs + (language c) + (names platform_misc))) + +(copy_files# + (enabled_if + (<> %{profile} "release")) + (mode promote) + (files %{project_root}/merlin/src/platform/platform_misc.c)) + +(copy_files# + (enabled_if + (<> %{profile} "release")) + (mode promote) + (files %{project_root}/merlin/src/utils/*.{ml,mli})) diff --git a/ocamlmerlin_mlx/utils/file_cache.ml b/ocamlmerlin_mlx/utils/file_cache.ml new file mode 100644 index 0000000..57e716f --- /dev/null +++ b/ocamlmerlin_mlx/utils/file_cache.ml @@ -0,0 +1,116 @@ +# 1 "merlin/src/utils/file_cache.ml" +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +module Make(Input : sig + type t + val read : string -> t + val cache_name : string +end) = struct + let {Logger. log} = Logger.for_section ("File_cache("^Input.cache_name^")") + + let cache : (string, File_id.t * float ref * Input.t) Hashtbl.t + = Hashtbl.create 17 + + type cache_stats = { hit: int; miss: int } + let cache_hit = ref 0 + let cache_miss = ref 0 + + let get_cache_stats () = { hit = !cache_hit; miss = !cache_miss } + let clear_cache_stats () = + cache_hit := 0; cache_miss := 0 + + let get_cached_entry ~title fid filename = + let fid', latest_use, file = Hashtbl.find cache filename in + if (File_id.check fid fid') then ( + log ~title "reusing %S" filename; + cache_hit := !cache_hit + 1) + else ( + log ~title "%S was updated on disk" filename; + raise Not_found; + ); + latest_use := Unix.time (); + file + + let read filename = + let fid = File_id.get filename in + let title = "read" in + try get_cached_entry ~title fid filename + with Not_found -> + try + cache_miss := !cache_miss + 1; + log ~title "reading %S from disk" filename; + let file = Input.read filename in + Hashtbl.replace cache filename (fid, ref (Unix.time ()), file); + file + with exn -> + log ~title "failed to read %S (%t)" + filename (fun () -> Printexc.to_string exn); + Hashtbl.remove cache filename; + raise exn + + let check filename = + let fid = File_id.get filename in + match Hashtbl.find cache filename with + | exception Not_found -> false + | (fid', latest_use, _) -> + if File_id.check fid fid' then begin + latest_use := Unix.time (); + true + end else begin + false + end + + let get_cached_entry filename = + let fid = File_id.get filename in + let title = "get_cached_entry" in + get_cached_entry ~title fid filename + + let flush ?older_than () = + let title = "flush" in + let limit = match older_than with + | None -> -.max_float + | Some dt -> Unix.time () -. dt + in + let add_invalid filename (fid, latest_use, _) invalids = + if !latest_use > limit && + File_id.check (File_id.get filename) fid + then ( + log ~title "keeping %S" filename; + invalids + ) else ( + log ~title "removing %S" filename; + filename :: invalids + ) + in + let invalid = Hashtbl.fold add_invalid cache [] in + List.iter (Hashtbl.remove cache) invalid + + let clear () = + Hashtbl.clear cache +end diff --git a/ocamlmerlin_mlx/utils/file_cache.mli b/ocamlmerlin_mlx/utils/file_cache.mli new file mode 100644 index 0000000..0f3f5f1 --- /dev/null +++ b/ocamlmerlin_mlx/utils/file_cache.mli @@ -0,0 +1,46 @@ +# 1 "merlin/src/utils/file_cache.mli" +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +module Make (Input : sig + type t + val read : string -> t + val cache_name : string +end) : sig + val read : string -> Input.t + val flush : ?older_than:float -> unit -> unit + val clear : unit -> unit + val check : string -> bool + + val get_cached_entry : string -> Input.t + (** @raises Not_found if the file is not in cache. *) + + type cache_stats = { hit: int; miss: int } + val get_cache_stats : unit -> cache_stats + val clear_cache_stats : unit -> unit +end diff --git a/ocamlmerlin_mlx/utils/file_id.ml b/ocamlmerlin_mlx/utils/file_id.ml new file mode 100644 index 0000000..afe2492 --- /dev/null +++ b/ocamlmerlin_mlx/utils/file_id.ml @@ -0,0 +1,43 @@ +# 1 "merlin/src/utils/file_id.ml" +type t = Unix.stats + +let null_stat = + { Unix. + st_dev = -1; st_ino = -1; st_kind = Unix.S_REG; st_nlink = -1; + st_perm = -1; st_uid = -1; st_gid = -1; st_rdev = -1; st_size = -1; + st_atime = nan; st_mtime = nan; st_ctime = nan } + +let get_res filename = + try Result.ok @@ Unix.stat filename + with _ -> Error ("Stat for" ^ filename ^ "couldn't be gathered") + +let get filename = + match get_res filename with Ok fn -> fn | Error _ -> null_stat + +let check a b = + a == b || ( + (a != null_stat) && (b != null_stat) && + let open Unix in + a.st_mtime = b.st_mtime && + a.st_size = b.st_size && + a.st_ino = b.st_ino && + a.st_dev = b.st_dev + ) + +let cache = ref None + +let with_cache k = + Std.let_ref cache (Some (Hashtbl.create 7)) k + +let get filename = + match !cache with + | None -> get filename + | Some table -> + match Hashtbl.find table filename with + | stats -> + Logger.log ~section:"stat_cache" ~title:"reuse cache" "%s" filename; + stats + | exception Not_found -> + let stats = get filename in + Hashtbl.add table filename stats; + stats diff --git a/ocamlmerlin_mlx/utils/file_id.mli b/ocamlmerlin_mlx/utils/file_id.mli new file mode 100644 index 0000000..e1f9dd8 --- /dev/null +++ b/ocamlmerlin_mlx/utils/file_id.mli @@ -0,0 +1,21 @@ +# 1 "merlin/src/utils/file_id.mli" +type t +(** An instance of [t] represents the identity of the contents of a file path. + Use this to quickly detect if a file has changed. + (Detection is done by checking some fields from stat syscall, + it can be tricked but should behave well in regular cases). + FIXME: precision of mtime is still the second?! +*) + +val check: t -> t -> bool +(** Returns true iff the heuristic determines that the file contents has not + changed. *) + +val get: string -> t +(** [file_id filename] computes an id for the current contents of [filename]. + Returns a generic id, if the id can't be computed. *) + +val get_res: string -> (t, string) Result.t +(** Same as [get], but returns an error, if the id can't be computed. *) + +val with_cache : (unit -> 'a) -> 'a diff --git a/ocamlmerlin_mlx/utils/lib_config.ml b/ocamlmerlin_mlx/utils/lib_config.ml new file mode 100644 index 0000000..5011139 --- /dev/null +++ b/ocamlmerlin_mlx/utils/lib_config.ml @@ -0,0 +1,16 @@ +# 1 "merlin/src/utils/lib_config.ml" +let program_name = ref "Merlin" + +let set_program_name name = program_name := name + +let program_name () = !program_name + +module Json = struct + let set_pretty_to_string f = + Std.Json.pretty_to_string := f +end + +module System = struct + let set_run_in_directory f = + Std.System.run_in_directory := f +end diff --git a/ocamlmerlin_mlx/utils/lib_config.mli b/ocamlmerlin_mlx/utils/lib_config.mli new file mode 100644 index 0000000..e809d88 --- /dev/null +++ b/ocamlmerlin_mlx/utils/lib_config.mli @@ -0,0 +1,56 @@ +# 1 "merlin/src/utils/lib_config.mli" +(** When using Merlin as a library, one should use functions provided by this + module to customize Merlin's behaviour. *) + +(** [set_program] sets the name of the program that will be used in error + messages. *) +val set_program_name : string -> unit + +(** [program ()] returns the name of the program as registered by + [set_program]. Defaults to "Merlin". *) +val program_name : unit -> string + +module Json : sig + (** Merlin's logger requires a Json pretty-printer for correct operation. + [set_pretty_to_string] can be used to provide one. A common pretifier + is [Yojson.Basic.pretty_to_string]. *) + val set_pretty_to_string : (Std.json -> string) -> unit +end + +(** Merlin spawns child processes for preprocessors (pp and ppx), which can be + customized via [System] *) +module System : sig + (** [set_run_in_directory] sets an implementation for spawning external + programs. This is used by Merlin to spawn preprocessors and ppxes. For + compatibility reasons, there are currently some limitations to how this + should be implemented: + + - Implementation should expect [prog] to be already quoted and contain + arguments. This is due to how ppx configuration is passed to Merlin. In + order to prepare a future transition to more sane argument passing, the + implementation can look at the [prog_is_quoted] argument to know if it + is actually safe to quote the command normally (using + [Filename.quote_command] for example). + + - [prog] might contain shell expansions, command substitutions etc. It + should therefore be ran under a shell for maximum compatibility. However + this should never happen when the configuration is generated by Dune. + + - Programs runned by this function should never output on stdout since it + is the channel used by Merlin to communicate with the editor. One way to + enforce that is to redirect stdout to stderr. + + - As of today Merlin handles the [`Cancelled] return case identically as + other error codes. *) + val set_run_in_directory + : (prog:string + -> prog_is_quoted:bool + -> args:string list + -> cwd:string + -> ?stdin:string + -> ?stdout:string + -> ?stderr:string + -> unit + -> [ `Finished of int | `Cancelled ]) + -> unit +end diff --git a/ocamlmerlin_mlx/utils/logger.ml b/ocamlmerlin_mlx/utils/logger.ml new file mode 100644 index 0000000..b921caa --- /dev/null +++ b/ocamlmerlin_mlx/utils/logger.ml @@ -0,0 +1,153 @@ +# 1 "merlin/src/utils/logger.ml" +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +open Std + +let time = ref 0.0 + +let delta_time () = + Sys.time () -. !time + +let destination = ref None +let selected_sections = ref None + +let is_section_enabled section = + match !selected_sections with + | None -> true + | Some sections -> Hashtbl.mem sections section + +let output_section oc section title = + Printf.fprintf oc "# %2.2f %s - %s\n" (delta_time ()) section title + +let log_flush () = + match !destination with + | None -> () + | Some oc -> flush oc + +let log ~section ~title fmt = + match !destination with + | Some oc when is_section_enabled section -> + Printf.ksprintf (fun str -> + output_section oc section title; + if str <> "" then ( + output_string oc str; + if str.[String.length str - 1] <> '\n' then + output_char oc '\n' + ) + ) fmt + | None | Some _ -> + Printf.ifprintf () fmt + +let fmt_buffer = Buffer.create 128 +let fmt_handle = Format.formatter_of_buffer fmt_buffer + +let fmt () f = + Buffer.reset fmt_buffer; + begin match f fmt_handle with + | () -> () + | exception exn -> + Format.fprintf fmt_handle "@\nException: %s" (Printexc.to_string exn); + end; + Format.pp_print_flush fmt_handle (); + let msg = Buffer.contents fmt_buffer in + Buffer.reset fmt_buffer; + msg + +let json () f = + match f () with + | json -> !Json.pretty_to_string json + | exception exn -> + Printf.sprintf "Exception: %s" (Printexc.to_string exn) + +let exn () exn = Printexc.to_string exn + +type notification = { + section: string; + msg: string; +} + +let notifications : notification list ref option ref = ref None + +let notify ~section = + let tell msg = + log ~section ~title:"notify" "%s" msg; + match !notifications with + | None -> () + | Some r -> r := {section; msg} :: !r + in + Printf.ksprintf tell + +let with_notifications r f = + let_ref notifications (Some r) f + +let with_sections sections f = + let sections = match sections with + | [] -> None + | sections -> + let table = Hashtbl.create (List.length sections) in + List.iter sections ~f:(fun section -> Hashtbl.replace table section ()); + Some table + in + let sections0 = !selected_sections in + selected_sections := sections; + match f () with + | result -> selected_sections := sections0; result + | exception exn -> selected_sections := sections0; reraise exn + +let with_log_file file ?(sections=[]) f = + match file with + | None -> with_sections sections f + | Some file -> + log_flush (); + let destination', release = match file with + | "" -> (None, ignore) + | "-" -> (Some stderr, ignore) + | filename -> + match open_out filename with + | exception exn -> + Printf.eprintf "cannot open %S for logging: %s" + filename (Printexc.to_string exn); + (None, ignore) + | oc -> + (Some oc, (fun () -> close_out_noerr oc)) + in + let destination0 = !destination in + destination := destination'; + let release () = + log_flush (); + destination := destination0; + release () + in + match with_sections sections f with + | v -> release (); v + | exception exn -> release (); reraise exn + +type 'a printf = title:string -> ('a, unit, string, unit) format4 -> 'a +type logger = { log : 'a. 'a printf } +let for_section section = { log = (fun ~title fmt -> log ~section ~title fmt) } diff --git a/ocamlmerlin_mlx/utils/logger.mli b/ocamlmerlin_mlx/utils/logger.mli new file mode 100644 index 0000000..47a3fee --- /dev/null +++ b/ocamlmerlin_mlx/utils/logger.mli @@ -0,0 +1,59 @@ +# 1 "merlin/src/utils/logger.mli" +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +(** Log module + * + * 1. Provide functions to log arbitrary messages, filtered according to a + * section and a verbosity level. + * + * 2. Allow to setup a destination for these log messages. + * + **) + +val log + : section:string -> title:string -> ('b, unit, string, unit) format4 -> 'b + +val fmt : unit -> (Format.formatter -> unit) -> string +val json : unit -> (unit -> Std.json) -> string +val exn : unit -> exn -> string + +val log_flush : unit -> unit + +type notification = { + section: string; + msg: string; +} + +val notify : section:string -> ('b, unit, string, unit) format4 -> 'b +val with_notifications : notification list ref -> (unit -> 'a) -> 'a +val with_log_file : string option -> ?sections:string list -> (unit -> 'a) -> 'a + +type 'a printf = title:string -> ('a, unit, string, unit) format4 -> 'a +type logger = { log : 'a. 'a printf } +val for_section : string -> logger diff --git a/ocamlmerlin_mlx/utils/marg.ml b/ocamlmerlin_mlx/utils/marg.ml new file mode 100644 index 0000000..8612676 --- /dev/null +++ b/ocamlmerlin_mlx/utils/marg.ml @@ -0,0 +1,99 @@ +# 1 "merlin/src/utils/marg.ml" +open Std + +(** {1 Flag parsing utils} *) + +type 'a t = string list -> 'a -> (string list * 'a) + +type 'a table = (string, 'a t) Hashtbl.t + +let unit f : 'a t = fun args acc -> (args, (f acc)) + +let param ptype f : 'a t = fun args acc -> + match args with + | [] -> failwith ("expects a " ^ ptype ^ " argument") + | arg :: args -> args, f arg acc + +let unit_ignore : 'a t = + fun x -> unit (fun x -> x) x + +let param_ignore = + fun x -> param "string" (fun _ x -> x) x + +let bool f = param "bool" + (function + | "yes" | "y" | "Y" | "true" | "True" | "1" -> f true + | "no" | "n" | "N" | "false" | "False" | "0" -> f false + | str -> + failwithf "expecting boolean (%s), got %S." + "yes|y|Y|true|1 / no|n|N|false|0" + str + ) + +type docstring = string + +type 'a spec = (string * docstring * 'a t) + +let rec assoc3 key = function + | [] -> raise Not_found + | (key', _, value) :: _ when key = key' -> value + | _ :: xs -> assoc3 key xs + +let rec mem_assoc3 key = function + | [] -> false + | (key', _, _) :: xs -> key = key' || mem_assoc3 key xs + +let parse_one ~warning global_spec local_spec args global local = + match args with + | [] -> None + | arg :: args -> + match Hashtbl.find global_spec arg with + | action -> begin match action args global with + | (args, global) -> + Some (args, global, local) + | exception (Failure msg) -> + warning ("flag " ^ arg ^ " " ^ msg); + Some (args, global, local) + | exception exn -> + warning ("flag " ^ arg ^ ": error, " ^ Printexc.to_string exn); + Some (args, global, local) + end + | exception Not_found -> + match assoc3 arg local_spec with + | action -> begin match action args local with + | (args, local) -> + Some (args, global, local) + | exception (Failure msg) -> + warning ("flag " ^ arg ^ " " ^ msg); + Some (args, global, local) + | exception exn -> + warning ("flag " ^ arg ^ ": error, " ^ Printexc.to_string exn); + Some (args, global, local) + end + | exception Not_found -> None + +let parse_all ~warning global_spec local_spec = + let rec normal_parsing args global local = + match parse_one ~warning global_spec local_spec args global local with + | Some (args, global, local) -> normal_parsing args global local + | None -> match args with + | arg :: args -> begin + (* We split on the first '=' to check if the argument was + of the form name=value *) + try + let name, value = Misc.cut_at arg '=' in + normal_parsing (name::value::args) global local + with Not_found -> + warning ("unknown flag " ^ arg); + resume_parsing args global local + end + | [] -> (global, local) + and resume_parsing args global local = + let args = match args with + | arg :: args when not (Hashtbl.mem global_spec arg || + mem_assoc3 arg local_spec) -> args + | args -> args + in + normal_parsing args global local + in + normal_parsing diff --git a/ocamlmerlin_mlx/utils/marg.mli b/ocamlmerlin_mlx/utils/marg.mli new file mode 100644 index 0000000..08a58fa --- /dev/null +++ b/ocamlmerlin_mlx/utils/marg.mli @@ -0,0 +1,57 @@ +# 1 "merlin/src/utils/marg.mli" +(** {0 Argument parsing library which fold over arguments} + + Specifications of arguments is split in two passes: + - [_ table] for parsing global arguments (compiler flags, merlin + configuration) + - a (string * _ t) for parsing command local arguments +*) + +(** Action associated to a flag updating a state of type 'acc. + It takes a list of arguments and either succeeds returning untouched + arguments or fails raising an exception. *) +type 'acc t = string list -> 'acc -> string list * 'acc + +(** A table mapping a flag to the corresponding action *) +type 'acc table = (string, 'acc t) Hashtbl.t + +(** {1 Combinators for building actions} *) + +(** Action updating state and not consuming any argument *) +val unit : ('acc -> 'acc) -> 'acc t + +(** Action consuming a single argument *) +val param : string -> (string -> 'acc -> 'acc) -> 'acc t + +(** Action consuming a boolean argument *) +val bool : (bool -> 'acc -> 'acc) -> 'acc t + +(** Action doing nothing *) +val unit_ignore : 'acc t + +(** Action doing nothing and dropping one argument *) +val param_ignore : 'acc t + +(** {1 Parsing of argument lists} *) + +type docstring = string + +type 'a spec = (string * docstring * 'a t) + +(** Consume at most one flag from the list, returning updated state or + [None] in case of failure. + Warning function is called with an error message in case of incorrect + use. *) +val parse_one : + warning:(string -> unit) -> + 'global table -> 'local spec list -> + string list -> 'global -> 'local -> + (string list * 'global * 'local) option + +(** Consume all arguments from the input list, calling warning for incorrect + ones and resuming parsing after. *) +val parse_all : + warning:(string -> unit) -> + 'global table -> 'local spec list -> + string list -> 'global -> 'local -> + 'global * 'local diff --git a/ocamlmerlin_mlx/utils/misc.ml b/ocamlmerlin_mlx/utils/misc.ml new file mode 100644 index 0000000..4cda4bb --- /dev/null +++ b/ocamlmerlin_mlx/utils/misc.ml @@ -0,0 +1,874 @@ +# 1 "merlin/src/utils/misc.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module CamlString = String + +open Std + +(* Errors *) + +exception Fatal_error of string * Printexc.raw_backtrace + +let () = Printexc.register_printer (function + | Fatal_error (msg, bt) -> + Some (Printf.sprintf "Fatal error: %s\n%s" + msg (Printexc.raw_backtrace_to_string bt)) + | _ -> None + ) + +let fatal_error msg = + raise (Fatal_error (msg, Printexc.get_callstack 50)) + +let fatal_errorf fmt = + (*Format.kasprintf is not available in 4.02.3 *) + (*Format.kasprintf fatal_error fmt*) + ignore (Format.flush_str_formatter ()); + Format.kfprintf + (fun _ppf -> fatal_error (Format.flush_str_formatter ())) + Format.str_formatter fmt + +(* Exceptions *) + +let try_finally ?(always=(fun () -> ())) ?(exceptionally=(fun () -> ())) work = + match work () with + | result -> + begin match always () with + | () -> result + | exception always_exn -> + (* raise_with_backtrace is not available before OCaml 4.05 *) + (*let always_bt = Printexc.get_raw_backtrace () in*) + exceptionally (); + (*Printexc.raise_with_backtrace always_exn always_bt*) + raise always_exn + end + | exception work_exn -> + (*let work_bt = Printexc.get_raw_backtrace () in*) + begin match always () with + | () -> + exceptionally (); + (*Printexc.raise_with_backtrace work_exn work_bt*) + raise work_exn + | exception always_exn -> + (*let always_bt = Printexc.get_raw_backtrace () in*) + exceptionally (); + (*Printexc.raise_with_backtrace always_exn always_bt*) + raise always_exn + end + +let reraise_preserving_backtrace e f = + let bt = Printexc.get_raw_backtrace () in + f (); + Printexc.raise_with_backtrace e bt + +type ref_and_value = R : 'a ref * 'a -> ref_and_value + +let protect_refs = + let set_refs l = List.iter ~f:(fun (R (r, v)) -> r := v) l in + fun refs f -> + let backup = List.map ~f:(fun (R (r, _)) -> R (r, !r)) refs in + set_refs refs; + match f () with + | x -> set_refs backup; x + | exception e -> set_refs backup; raise e + +(* List functions *) + +let map_end f l1 l2 = List.map_end ~f l1 l2 + +let rec map_left_right f = function + [] -> [] + | hd::tl -> let res = f hd in res :: map_left_right f tl + +let for_all2 pred l1 l2 = List.for_all2 ~f:pred l1 l2 + +let replicate_list = List.replicate + +let list_remove x = List.remove ~phys:false x + +let rec split_last = function + [] -> assert false + | [x] -> ([], x) + | hd :: tl -> + let (lst, last) = split_last tl in + (hd :: lst, last) + +(* Options *) + +let may f x = Option.iter ~f x +let may_map f x = Option.map ~f x + +(* File functions *) + +let remove_file filename = + try + if Sys.is_regular_file filename + then Sys.remove filename + with Sys_error _msg -> () + +let rec split_path path acc = + match Filename.dirname path with + | dir when dir = path -> + let is_letter c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') in + let dir = + if not Sys.unix && String.length dir > 2 && is_letter dir.[0] && dir.[1] = ':' + then + (* We do two things here: + - We use an uppercase letter to match Dune's behavior + - We also add the separator ousrselves because [Filename.concat] + does not if its first argument is of the form ["C:"] *) + Printf.sprintf "%c:%s" + (Char.uppercase_ascii dir.[0]) + Filename.dir_sep + else dir + in + dir :: acc + | dir -> split_path dir (Filename.basename path :: acc) + +(* Deal with case insensitive FS *) + +external fs_exact_case : string -> string = "ml_merlin_fs_exact_case" +external fs_exact_case_basename: string -> string option = "ml_merlin_fs_exact_case_basename" + +(* A replacement for sys_file_exists that makes use of stat_cache *) +module Exists_in_directory = File_cache.Make(struct + let cache_name = "Exists_in_directory" + type t = string -> bool + let read dir = + if Sys.file_exists dir && + Sys.is_directory dir + then + let cache = Hashtbl.create 4 in + (fun filename -> + match Hashtbl.find cache filename with + | x -> x + | exception Not_found -> + let exists = Sys.file_exists (Filename.concat dir filename) in + Hashtbl.add cache filename exists; + exists) + else (fun _ -> false) + end) + +let exact_file_exists ~dirname ~basename = + Exists_in_directory.read dirname basename && + let path = Filename.concat dirname basename in + match fs_exact_case_basename path with + | None -> + let path' = fs_exact_case path in + path == path' || (* only on macos *) basename = Filename.basename path' + | Some bn -> + (* only on windows *) + basename = bn + +let canonicalize_filename ?cwd path = + let parts = + match split_path path [] with + | dot :: rest when dot = Filename.current_dir_name -> + split_path (match cwd with None -> Sys.getcwd () | Some c -> c) rest + | parts -> parts + in + let goup path = function + | dir when dir = Filename.parent_dir_name -> + (match path with _ :: t -> t | [] -> []) + | dir when dir = Filename.current_dir_name -> + path + | dir -> dir :: path + in + let parts = List.rev (List.fold_left ~f:goup ~init:[] parts) in + let filename_concats = function + | [] -> "" + | root :: subs -> List.fold_left ~f:Filename.concat ~init:root subs + in + fs_exact_case (filename_concats parts) + +let rec expand_glob ~filter acc root = function + | [] -> root :: acc + | Glob.Wildwild :: _tl -> (* FIXME: why is tl not used? *) + let rec append acc root = + let items = try Sys.readdir root with Sys_error _ -> [||] in + let process acc dir = + let filename = Filename.concat root dir in + if filter filename + then append (filename :: acc) filename + else acc + in + Array.fold_left process (root :: acc) items + in + append acc root + | Glob.Exact component :: tl -> + let filename = Filename.concat root component in + expand_glob ~filter acc filename tl + | pattern :: tl -> + let items = try Sys.readdir root with Sys_error _ -> [||] in + let process acc dir = + if Glob.match_pattern pattern dir then + let root' = Filename.concat root dir in + if filter root' then + expand_glob ~filter acc root' tl + else acc + else acc + in + Array.fold_left process acc items + +let expand_glob ?(filter=fun _ -> true) path acc = + match split_path path [] with + | [] -> acc + | root :: subs -> + let patterns = List.map ~f:Glob.compile_pattern subs in + expand_glob ~filter acc root patterns + +let find_in_path path name = + canonicalize_filename + begin + if not (Filename.is_implicit name) then + if exact_file_exists + ~dirname:(Filename.dirname name) + ~basename:(Filename.basename name) + then name + else raise Not_found + else List.find_map path ~f:(fun dirname -> + if exact_file_exists ~dirname ~basename:name + then Some (Filename.concat dirname name) + else None + ) + end + +let find_in_path_rel path name = + let rec simplify s = + let open Filename in + let base = basename s in + let dir = dirname s in + if dir = s then dir + else if base = current_dir_name then simplify dir + else concat (simplify dir) base + in + let rec try_dir = function + | [] -> raise Not_found + | dir::rem -> + let dir = simplify dir in + if Exists_in_directory.read dir name + then Filename.concat dir name + else try_dir rem + in try_dir path + +let find_in_path_uncap ?(fallback="") path name = + let has_fallback = fallback <> "" in + canonicalize_filename + begin + let uname = String.uncapitalize name in + let ufallback = String.uncapitalize fallback in + List.find_map path ~f:(fun dirname -> + if exact_file_exists ~dirname ~basename:uname + then Some (Filename.concat dirname uname) + else if exact_file_exists ~dirname ~basename:name + then Some (Filename.concat dirname name) + else + let () = Logger.log + ~section:"locate" + ~title:"find_in_path_uncap" + "Failed to load %s/%s" dirname name + in + if has_fallback && exact_file_exists ~dirname ~basename:ufallback + then Some (Filename.concat dirname ufallback) + else if has_fallback && exact_file_exists ~dirname ~basename:fallback + then Some (Filename.concat dirname fallback) + else None + ) + end + +(* Expand a -I option: if it starts with +, make it relative to the standard + library directory *) + +let expand_directory alt s = + if String.length s > 0 && s.[0] = '+' + then Filename.concat alt + (String.sub s ~pos:1 ~len:(String.length s - 1)) + else s + +(* Hashtable functions *) + +let create_hashtable size init = + let tbl = Hashtbl.create size in + List.iter ~f:(fun (key, data) -> Hashtbl.add tbl key data) init; + tbl + +(* File copy *) + +let copy_file ic oc = + let buff = Bytes.create 0x1000 in + let rec copy () = + let n = input ic buff 0 0x1000 in + if n = 0 then () else (output oc buff 0 n; copy()) + in copy() + +let copy_file_chunk ic oc len = + let buff = Bytes.create 0x1000 in + let rec copy n = + if n <= 0 then () else begin + let r = input ic buff 0 (min n 0x1000) in + if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r)) + end + in copy len + +let string_of_file ic = + let b = Buffer.create 0x10000 in + let buff = Bytes.create 0x1000 in + let rec copy () = + let n = input ic buff 0 0x1000 in + if n = 0 then Buffer.contents b else + (Buffer.add_subbytes b buff 0 n; copy()) + in copy() + +let output_to_file_via_temporary ?(mode = [Open_text]) filename fn = + let (temp_filename, oc) = + Filename.open_temp_file + ~mode (*~perms:0o666*) ~temp_dir:(Filename.dirname filename) + (Filename.basename filename) ".tmp" in + (* The 0o666 permissions will be modified by the umask. It's just + like what [open_out] and [open_out_bin] do. + With temp_dir = dirname filename, we ensure that the returned + temp file is in the same directory as filename itself, making + it safe to rename temp_filename to filename later. + With prefix = basename filename, we are almost certain that + the first generated name will be unique. A fixed prefix + would work too but might generate more collisions if many + files are being produced simultaneously in the same directory. *) + match fn temp_filename oc with + | res -> + close_out oc; + begin try + Sys.rename temp_filename filename; res + with exn -> + remove_file temp_filename; raise exn + end + | exception exn -> + close_out oc; remove_file temp_filename; raise exn + +(* Reading from a channel *) + +let input_bytes ic n = + let result = Bytes.create n in + really_input ic result 0 n; + result + +(* Integer operations *) + +let rec log2 n = + if n <= 1 then 0 else 1 + log2(n asr 1) + +let align n a = + if n >= 0 then (n + a - 1) land (-a) else n land (-a) + +let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0 + +let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0 + +(* Taken from Hacker's Delight, chapter "Overflow Detection" *) +let no_overflow_mul a b = + not ((a = min_int && b < 0) || (b <> 0 && (a * b) / b <> a)) + +let no_overflow_lsl a k = + 0 <= k && k < Sys.word_size - 1 && min_int asr k <= a && a <= max_int asr k + +module Int_literal_converter = struct + (* To convert integer literals, allowing max_int + 1 (PR#4210) *) + let cvt_int_aux str neg of_string = + if String.length str = 0 || str.[0]= '-' + then of_string str + else neg (of_string ("-" ^ str)) + let int s = cvt_int_aux s (~-) int_of_string + let int32 s = cvt_int_aux s Int32.neg Int32.of_string + let int64 s = cvt_int_aux s Int64.neg Int64.of_string + let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string +end + +(* [find_first_mono p] assumes that there exists a natural number + N such that [p] is false on [0; N[ and true on [N; max_int], and + returns this N. (See misc.mli for the detailed specification.) *) +let find_first_mono = + let rec find p ~low ~jump ~high = + (* Invariants: + [low, jump, high] are non-negative with [low < high], + [p low = false], + [p high = true]. *) + if low + 1 = high then high + (* ensure that [low + jump] is in ]low; high[ *) + else if jump < 1 then find p ~low ~jump:1 ~high + else if jump >= high - low then find p ~low ~jump:((high - low) / 2) ~high + else if p (low + jump) then + (* We jumped too high: continue with a smaller jump and lower limit *) + find p ~low:low ~jump:(jump / 2) ~high:(low + jump) + else + (* we jumped too low: + continue from [low + jump] with a larger jump *) + let next_jump = max jump (2 * jump) (* avoid overflows *) in + find p ~low:(low + jump) ~jump:next_jump ~high + in + fun p -> + if p 0 then 0 + else find p ~low:0 ~jump:1 ~high:max_int + +(* String operations *) + +(* let split_null_terminated s = + let[@tail_mod_cons] rec discard_last_sep = function + | [] | [""] -> [] + | x :: xs -> x :: discard_last_sep xs + in + discard_last_sep (String.split_on_char ~sep:'' s) *) + +(* let concat_null_terminated = function + | [] -> "" + | l -> String.concat ~sep:"" (l @ [""]) *) + +let chop_extension_if_any fname = + try Filename.chop_extension fname with Invalid_argument _ -> fname + +let chop_extensions file = + let dirname = Filename.dirname file and basename = Filename.basename file in + try + let pos = String.index basename '.' in + let basename = String.sub basename ~pos:0 ~len:pos in + if Filename.is_implicit file && dirname = Filename.current_dir_name then + basename + else + Filename.concat dirname basename + with Not_found -> file + +let search_substring pat str start = + let rec search i j = + if j >= String.length pat then i + else if i + j >= String.length str then raise Not_found + else if str.[i + j] = pat.[j] then search i (j+1) + else search (i+1) 0 + in search start 0 + +let replace_substring ~before ~after str = + let rec search acc curr = + match search_substring before str curr with + | next -> + let prefix = String.sub str ~pos:curr ~len:(next - curr) in + search (prefix :: acc) (next + String.length before) + | exception Not_found -> + let suffix = String.sub str ~pos:curr ~len:(String.length str - curr) in + List.rev (suffix :: acc) + in String.concat ~sep:after (search [] 0) + + +let rev_split_string cond s = + let rec split1 res i = + if i >= String.length s then res else begin + if cond s.[i] then + split1 res (i+1) + else + split2 res i (i+1) + end + and split2 res i j = + if j >= String.length s then String.sub s ~pos:i ~len:(j-i) :: res else begin + if cond s.[j] then + split1 (String.sub s ~pos:i ~len:(j-i) :: res) (j+1) + else + split2 res i (j+1) + end + in split1 [] 0 + +let rev_split_words s = + let helper = function + | ' ' | '\t' | '\r' | '\n' -> true + | _ -> false + in + rev_split_string helper s + +let rev_string_split ~on s = + rev_split_string ((=) on) s + +let get_ref r = + let v = !r in + r := []; v + +let set_or_ignore f opt x = + match f x with + | None -> () + | Some y -> opt := Some y + +let fst3 (x, _, _) = x +let snd3 (_,x,_) = x +let thd3 (_,_,x) = x + +let fst4 (x, _, _, _) = x +let snd4 (_,x,_, _) = x +let thd4 (_,_,x,_) = x +let for4 (_,_,_,x) = x + + +module LongString = struct + type t = bytes array + + let create str_size = + let tbl_size = str_size / Sys.max_string_length + 1 in + let tbl = Array.make tbl_size Bytes.empty in + for i = 0 to tbl_size - 2 do + tbl.(i) <- Bytes.create Sys.max_string_length; + done; + tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length); + tbl + + let length tbl = + let tbl_size = Array.length tbl in + Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1) + + let get tbl ind = + Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length) + + let set tbl ind c = + Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length) + c + + let blit src srcoff dst dstoff len = + for i = 0 to len - 1 do + set dst (dstoff + i) (get src (srcoff + i)) + done + + let output oc tbl pos len = + for i = pos to pos + len - 1 do + output_char oc (get tbl i) + done + + let unsafe_blit_to_bytes src srcoff dst dstoff len = + for i = 0 to len - 1 do + Bytes.unsafe_set dst (dstoff + i) (get src (srcoff + i)) + done + + let input_bytes ic len = + let tbl = create len in + Array.iter (fun str -> really_input ic str 0 (Bytes.length str)) tbl; + tbl +end + +let file_contents filename = + let ic = open_in filename in + try + let str = Bytes.create 1024 in + let buf = Buffer.create 1024 in + let rec loop () = + match input ic str 0 1024 with + | 0 -> () + | n -> + Buffer.add_subbytes buf str 0 n; + loop () + in + loop (); + close_in_noerr ic; + Buffer.contents buf + with exn -> + close_in_noerr ic; + raise exn + +let edit_distance a b cutoff = + let la, lb = String.length a, String.length b in + let cutoff = + (* using max_int for cutoff would cause overflows in (i + cutoff + 1); + we bring it back to the (max la lb) worstcase *) + min (max la lb) cutoff in + if abs (la - lb) > cutoff then None + else begin + (* initialize with 'cutoff + 1' so that not-yet-written-to cases have + the worst possible cost; this is useful when computing the cost of + a case just at the boundary of the cutoff diagonal. *) + let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in + m.(0).(0) <- 0; + for i = 1 to la do + m.(i).(0) <- i; + done; + for j = 1 to lb do + m.(0).(j) <- j; + done; + for i = 1 to la do + for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do + let cost = if a.[i-1] = b.[j-1] then 0 else 1 in + let best = + (* insert, delete or substitute *) + min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost) + in + let best = + (* swap two adjacent letters; we use "cost" again in case of + a swap between two identical letters; this is slightly + redundant as this is a double-substitution case, but it + was done this way in most online implementations and + imitation has its virtues *) + if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1]) + then best + else min best (m.(i-2).(j-2) + cost) + in + m.(i).(j) <- best + done; + done; + let result = m.(la).(lb) in + if result > cutoff + then None + else Some result + end + +let spellcheck env name = + let cutoff = + match String.length name with + | 1 | 2 -> 0 + | 3 | 4 -> 1 + | 5 | 6 -> 2 + | _ -> 3 + in + let compare target acc head = + match edit_distance target head cutoff with + | None -> acc + | Some dist -> + let (best_choice, best_dist) = acc in + if dist < best_dist then ([head], dist) + else if dist = best_dist then (head :: best_choice, dist) + else acc + in + fst (List.fold_left ~f:(compare name) ~init:([], max_int) env) + +let did_you_mean ppf get_choices = + (* flush now to get the error report early, in the (unheard of) case + where the search in the get_choices function would take a bit of + time; in the worst case, the user has seen the error, she can + interrupt the process before the spell-checking terminates. *) + Format.fprintf ppf "@?"; + match get_choices () with + | [] -> () + | choices -> + let rest, last = split_last choices in + Format.fprintf ppf "@\n@{Hint@}: Did you mean %s%s%s?@?" + (String.concat ~sep:", " rest) + (if rest = [] then "" else " or ") + last + +let cut_at s c = + let pos = String.index s c in + String.sub s ~pos:0 ~len:pos, + String.sub s ~pos:(pos+1) ~len:(String.length s - pos - 1) + +let ordinal_suffix n = + let teen = (n mod 100)/10 = 1 in + match n mod 10 with + | 1 when not teen -> "st" + | 2 when not teen -> "nd" + | 3 when not teen -> "rd" + | _ -> "th" + +(* Color handling *) +module Color = struct + (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) + type color = + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + + type style = + | FG of color (* foreground *) + | BG of color (* background *) + | Bold + | Reset + + let ansi_of_color = function + | Black -> "0" + | Red -> "1" + | Green -> "2" + | Yellow -> "3" + | Blue -> "4" + | Magenta -> "5" + | Cyan -> "6" + | White -> "7" + + let code_of_style = function + | FG c -> "3" ^ ansi_of_color c + | BG c -> "4" ^ ansi_of_color c + | Bold -> "1" + | Reset -> "0" + + let ansi_of_style_l l = + let s = match l with + | [] -> code_of_style Reset + | [s] -> code_of_style s + | _ -> String.concat ~sep:";" (List.map ~f:code_of_style l) + in + "\x1b[" ^ s ^ "m" + + + type Format.stag += Style of style list + type styles = { + error: style list; + warning: style list; + loc: style list; + hint:style list; + } + + let default_styles = { + warning = [Bold; FG Magenta]; + error = [Bold; FG Red]; + loc = [Bold]; + hint = [Bold; FG Blue]; + } + + let cur_styles = ref default_styles + let get_styles () = !cur_styles + let set_styles s = cur_styles := s + + (* map a tag to a style, if the tag is known. + @raise Not_found otherwise *) + let style_of_tag s = match s with + | Format.String_tag "error" -> (!cur_styles).error + | Format.String_tag "warning" -> (!cur_styles).warning + | Format.String_tag "loc" -> (!cur_styles).loc + | Format.String_tag "hint" -> (!cur_styles).hint + | Style s -> s + | _ -> raise Not_found + + let color_enabled = ref true + + (* either prints the tag of [s] or delegates to [or_else] *) + let mark_open_tag ~or_else s = + try + let style = style_of_tag s in + if !color_enabled then ansi_of_style_l style else "" + with Not_found -> or_else s + + let mark_close_tag ~or_else s = + try + let _ = style_of_tag s in + if !color_enabled then ansi_of_style_l [Reset] else "" + with Not_found -> or_else s + + (* add color handling to formatter [ppf] *) + let set_color_tag_handling ppf = + let open Format in + let functions = pp_get_formatter_stag_functions ppf () in + let functions' = {functions with + mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag); + mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag); + } in + pp_set_mark_tags ppf true; (* enable tags *) + pp_set_formatter_stag_functions ppf functions'; + () + + external isatty : out_channel -> bool = "caml_sys_isatty" + + (* reasonable heuristic on whether colors should be enabled *) + let should_enable_color () = + let term = try Sys.getenv "TERM" with Not_found -> "" in + term <> "dumb" + && term <> "" + && isatty stderr + + type setting = Auto | Always | Never + + let default_setting = Auto + + let setup = + let first = ref true in (* initialize only once *) + let formatter_l = + [Format.std_formatter; Format.err_formatter; Format.str_formatter] + in + let enable_color = function + | Auto -> should_enable_color () + | Always -> true + | Never -> false + in + fun o -> + if !first then ( + first := false; + Format.set_mark_tags true; + List.iter ~f:set_color_tag_handling formatter_l; + color_enabled := (match o with + | Some s -> enable_color s + | None -> enable_color default_setting) + ); + () +end + +let print_see_manual ppf manual_section = + let open Format in + fprintf ppf "(see manual section %a)" + (pp_print_list ~pp_sep:(fun f () -> pp_print_char f '.') pp_print_int) + manual_section + +let time_spent () = + let open Unix in + let t = times () in + ((t.tms_utime +. t.tms_stime +. t.tms_cutime +. t.tms_cstime) *. 1000.0) + +let normalise_eol s = + let b = Buffer.create 80 in + for i = 0 to String.length s - 1 do + if s.[i] <> '\r' then Buffer.add_char b s.[i] + done; + Buffer.contents b + +let unitname filename = + let unitname = + try String.sub filename ~pos:0 ~len:(String.index filename '.') + with Not_found -> filename + in + String.capitalize unitname + +(* [modules_in_path ~ext path] lists ocaml modules corresponding to + * filenames with extension [ext] in given [path]es. + * For instance, if there is file "a.ml","a.mli","b.ml" in ".": + * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"], + * - modules_in_path ~ext:".mli" ["."] returns ["A"] *) +let modules_in_path ~ext path = + let seen = Hashtbl.create 7 in + List.fold_left ~init:[] path + ~f:begin fun results dir -> + try + Array.fold_left + begin fun results file -> + if Filename.check_suffix file ext + then let name = Filename.chop_extension file in + (if Hashtbl.mem seen name + then results + else + (Hashtbl.add seen name (); String.capitalize name :: results)) + else results + end results (Sys.readdir dir) + with Sys_error _ -> results + end + +module String = struct + include CamlString + module Ord = struct + type t = string + let compare = String.compare + end + module Set = Set.Make (Ord) + module Map = Map.Make (Ord) + module Tbl = Hashtbl.Make (struct + type t = string + let equal (x : string) (y : string) : bool = (x = y) + let hash = Hashtbl.hash + end) +end + + +type filepath = string +type modname = string +type crcs = (modname * Digest.t option) list + +type alerts = string String.Map.t diff --git a/ocamlmerlin_mlx/utils/misc.mli b/ocamlmerlin_mlx/utils/misc.mli new file mode 100644 index 0000000..d61e412 --- /dev/null +++ b/ocamlmerlin_mlx/utils/misc.mli @@ -0,0 +1,411 @@ +# 1 "merlin/src/utils/misc.mli" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Miscellaneous useful types and functions *) + +(** {1 Reporting fatal errors} *) + +val fatal_error: string -> 'a + (** Raise the [Fatal_error] exception with the given string. *) + +val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a + (** Format the arguments according to the given format string + and raise [Fatal_error] with the resulting string. *) + +exception Fatal_error of string * Printexc.raw_backtrace + +(** {1 Exceptions and finalization} *) + +val try_finally : + ?always:(unit -> unit) -> + ?exceptionally:(unit -> unit) -> + (unit -> 'a) -> 'a +(** [try_finally work ~always ~exceptionally] is designed to run code + in [work] that may fail with an exception, and has two kind of + cleanup routines: [always], that must be run after any execution + of the function (typically, freeing system resources), and + [exceptionally], that should be run only if [work] or [always] + failed with an exception (typically, undoing user-visible state + changes that would only make sense if the function completes + correctly). For example: + + {[ + let objfile = outputprefix ^ ".cmo" in + let oc = open_out_bin objfile in + Misc.try_finally + (fun () -> + bytecode + ++ Timings.(accumulate_time (Generate sourcefile)) + (Emitcode.to_file oc modulename objfile); + Warnings.check_fatal ()) + ~always:(fun () -> close_out oc) + ~exceptionally:(fun _exn -> remove_file objfile); + ]} + + If [exceptionally] fail with an exception, it is propagated as + usual. + + If [always] or [exceptionally] use exceptions internally for + control-flow but do not raise, then [try_finally] is careful to + preserve any exception backtrace coming from [work] or [always] + for easier debugging. +*) + +val reraise_preserving_backtrace : exn -> (unit -> unit) -> 'a +(** [reraise_preserving_backtrace e f] is (f (); raise e) except that the + current backtrace is preserved, even if [f] uses exceptions internally. *) + +(** {1 List operations} *) + +val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list + (** [map_end f l t] is [map f l @ t], just more efficient. *) + +val map_left_right: ('a -> 'b) -> 'a list -> 'b list + (** Like [List.map], with guaranteed left-to-right evaluation order *) + +val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + (** Same as [List.for_all] but for a binary predicate. + In addition, this [for_all2] never fails: given two lists + with different lengths, it returns false. *) + +val replicate_list: 'a -> int -> 'a list + (** [replicate_list elem n] is the list with [n] elements + all identical to [elem]. *) + +val list_remove: 'a -> 'a list -> 'a list + (** [list_remove x l] returns a copy of [l] with the first + element equal to [x] removed. *) + +val split_last: 'a list -> 'a list * 'a + (** Return the last element and the other elements of the given list. *) + +val may: ('a -> unit) -> 'a option -> unit +val may_map: ('a -> 'b) -> 'a option -> 'b option + +type ref_and_value = R : 'a ref * 'a -> ref_and_value + +val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a +(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l] + while executing [f]. The previous contents of the references is restored + even if [f] raises an exception. *) + +val exact_file_exists : dirname:string -> basename:string -> bool + (* Like [Sys.file_exists], but takes into account case-insensitive file + systems: return true only if the basename (last component of the + path) has the correct case. *) +val find_in_path: string list -> string -> string + (** Search a file in a list of directories. *) + +val find_in_path_rel: string list -> string -> string + (** Search a relative file in a list of directories. *) + +val find_in_path_uncap: ?fallback:string -> string list -> string -> string + (** Same, but search also for uncapitalized name, i.e. + if name is [Foo.ml], allow [/path/Foo.ml] and [/path/foo.ml] + to match. *) + +val canonicalize_filename : ?cwd:string -> string -> string + (* Ensure that path is absolute (wrt to cwd), by following ".." and "." *) + +val expand_glob : ?filter:(string -> bool) -> string -> string list -> string list + (* [expand_glob ~filter pattern acc] adds all filenames matching + [pattern] and satistfying the [filter] predicate to [acc]*) +val split_path : string -> string list -> string list + (* [split_path path tail] prepends all components of [path] to [tail], + including implicit "." if path is not absolute. + [split_path "a/b/c" []] = ["."; "a"; "b"; "c"] + [split_path "/a/b/c" []] = ["/"; "a"; "b"; "c"] + FIXME: explain windows behavior + *) + +val remove_file: string -> unit + (** Delete the given file if it exists and is a regular file. + Does nothing for other kinds of files. + Never raises an error. *) + +val expand_directory: string -> string -> string + (** [expand_directory alt file] eventually expands a [+] at the + beginning of file into [alt] (an alternate root directory) *) + +val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t + (* Create a hashtable of the given size and fills it with the + given bindings. *) + +val copy_file: in_channel -> out_channel -> unit + (* [copy_file ic oc] reads the contents of file [ic] and copies + them to [oc]. It stops when encountering EOF on [ic]. *) +val copy_file_chunk: in_channel -> out_channel -> int -> unit + (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies + them to [oc]. It raises [End_of_file] when encountering + EOF on [ic]. *) +val string_of_file: in_channel -> string + (* [string_of_file ic] reads the contents of file [ic] and copies + them to a string. It stops when encountering EOF on [ic]. *) +val output_to_file_via_temporary: + ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a + (* Produce output in temporary file, then rename it + (as atomically as possible) to the desired output file name. + [output_to_file_via_temporary filename fn] opens a temporary file + which is passed to [fn] (name + output channel). When [fn] returns, + the channel is closed and the temporary file is renamed to + [filename]. *) + +val input_bytes : in_channel -> int -> bytes + (* [input_bytes ic n] reads [n] bytes from [ic] and returns them + in a new string. It raises [End_of_file] if EOF is encountered + before all the bytes are read. *) + +val log2: int -> int + (* [log2 n] returns [s] such that [n = 1 lsl s] + if [n] is a power of 2*) +val align: int -> int -> int + (* [align n a] rounds [n] upwards to a multiple of [a] + (a power of 2). *) +val no_overflow_add: int -> int -> bool + (* [no_overflow_add n1 n2] returns [true] if the computation of + [n1 + n2] does not overflow. *) +val no_overflow_sub: int -> int -> bool + (* [no_overflow_sub n1 n2] returns [true] if the computation of + [n1 - n2] does not overflow. *) +val no_overflow_mul: int -> int -> bool + (* [no_overflow_mul n1 n2] returns [true] if the computation of + [n1 * n2] does not overflow. *) +val no_overflow_lsl: int -> int -> bool + (* [no_overflow_lsl n k] returns [true] if the computation of + [n lsl k] does not overflow. *) + +module Int_literal_converter : sig + val int : string -> int + val int32 : string -> int32 + val int64 : string -> int64 + val nativeint : string -> nativeint +end + +val find_first_mono : (int -> bool) -> int + (**[find_first_mono p] takes an integer predicate [p : int -> bool] + that we assume: + 1. is monotonic on natural numbers: + if [a <= b] then [p a] implies [p b], + 2. is satisfied for some natural numbers in range [0; max_int] + (this is equivalent to: [p max_int = true]). + + [find_first_mono p] is the smallest natural number N that satisfies [p], + computed in O(log(N)) calls to [p]. + + Our implementation supports two cases where the preconditions on [p] + are not respected: + - If [p] is always [false], we silently return [max_int] + instead of looping or crashing. + - If [p] is non-monotonic but eventually true, + we return some satisfying value. + *) + +(** {1 String operations} *) + +val chop_extension_if_any: string -> string + (* Like Filename.chop_extension but returns the initial file + name if it has no extension *) + +val chop_extensions: string -> string + (* Return the given file name without its extensions. The extensions + is the longest suffix starting with a period and not including + a directory separator, [.xyz.uvw] for instance. + + Return the given name if it does not contain an extension. *) + +val search_substring: string -> string -> int -> int + (* [search_substring pat str start] returns the position of the first + occurrence of string [pat] in string [str]. Search starts + at offset [start] in [str]. Raise [Not_found] if [pat] + does not occur. *) + +val replace_substring: before:string -> after:string -> string -> string + (* [replace_substring ~before ~after str] replaces all + occurrences of [before] with [after] in [str] and returns + the resulting string. *) + +val rev_split_words: string -> string list + (* [rev_split_words s] splits [s] in blank-separated words, and returns + the list of words in reverse order. *) + +val rev_string_split: on:char -> string -> string list + (* [rev_string_split ~on s] splits [s] on [on], and return the list of + words in reverse order. *) + +val get_ref: 'a list ref -> 'a list + (* [get_ref lr] returns the content of the list reference [lr] and reset + its content to the empty list. *) + +val set_or_ignore : ('a -> 'b option) -> 'b option ref -> 'a -> unit + (* [set_or_ignore f opt x] sets [opt] to [f x] if it returns [Some _], + or leaves it unmodified if it returns [None]. *) + +val fst3: 'a * 'b * 'c -> 'a +val snd3: 'a * 'b * 'c -> 'b +val thd3: 'a * 'b * 'c -> 'c + +val fst4: 'a * 'b * 'c * 'd -> 'a +val snd4: 'a * 'b * 'c * 'd -> 'b +val thd4: 'a * 'b * 'c * 'd -> 'c +val for4: 'a * 'b * 'c * 'd -> 'd + +(* [modules_in_path ~ext path] lists ocaml modules corresponding to + * filenames with extension [ext] in given [path]es. + * For instance, if there is file "a.ml","a.mli","b.ml" in ".": + * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"], + * - modules_in_path ~ext:".mli" ["."] returns ["A"] *) +val modules_in_path : ext:string -> string list -> string list + +val file_contents : string -> string + +module LongString : + sig + type t = bytes array + val create : int -> t + val length : t -> int + val get : t -> int -> char + val set : t -> int -> char -> unit + val blit : t -> int -> t -> int -> int -> unit + val output : out_channel -> t -> int -> int -> unit + val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit + val input_bytes : in_channel -> int -> t + end + +val edit_distance : string -> string -> int -> int option +(** [edit_distance a b cutoff] computes the edit distance between + strings [a] and [b]. To help efficiency, it uses a cutoff: if the + distance [d] is smaller than [cutoff], it returns [Some d], else + [None]. + + The distance algorithm currently used is Damerau-Levenshtein: it + computes the number of insertion, deletion, substitution of + letters, or swapping of adjacent letters to go from one word to the + other. The particular algorithm may change in the future. +*) + +val spellcheck : string list -> string -> string list +(** [spellcheck env name] takes a list of names [env] that exist in + the current environment and an erroneous [name], and returns a + list of suggestions taken from [env], that are close enough to + [name] that it may be a typo for one of them. *) + +val did_you_mean : Format.formatter -> (unit -> string list) -> unit +(** [did_you_mean ppf get_choices] hints that the user may have meant + one of the option returned by calling [get_choices]. It does nothing + if the returned list is empty. + + The [unit -> ...] thunking is meant to delay any potentially-slow + computation (typically computing edit-distance with many things + from the current environment) to when the hint message is to be + printed. You should print an understandable error message before + calling [did_you_mean], so that users get a clear notification of + the failure even if producing the hint is slow. +*) + +val cut_at : string -> char -> string * string +(** [String.cut_at s c] returns a pair containing the sub-string before + the first occurrence of [c] in [s], and the sub-string after the + first occurrence of [c] in [s]. + [let (before, after) = String.cut_at s c in + before ^ String.make 1 c ^ after] is the identity if [s] contains [c]. + + Raise [Not_found] if the character does not appear in the string + @since 4.01 +*) + +val time_spent : unit -> float +(** Returns a more precise measurement of resources usage than + Sys.times/Unix.times. + Both user and kernel cpu time is accounted. *) + +module String : sig + include module type of String + module Map : Map.S with type key = t + module Set : Set.S with type elt = t + module Tbl : Hashtbl.S with type key = t +end + +val normalise_eol : string -> string +(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters + removed. Intended for pre-processing text which will subsequently be printed + on a channel which performs EOL transformations (i.e. Windows) *) + +val unitname: string -> string +(** Return the name of the OCaml module matching a basename + (filename without directory). + Remove the extension and capitalize *) + +type filepath = string +type modname = string +type crcs = (modname * Digest.t option) list + +type alerts = string String.Map.t + +val ordinal_suffix : int -> string +(** [ordinal_suffix n] is the appropriate suffix to append to the numeral [n] as + an ordinal number: [1] -> ["st"], [2] -> ["nd"], [3] -> ["rd"], + [4] -> ["th"], and so on. Handles larger numbers (e.g., [42] -> ["nd"]) and + the numbers 11--13 (which all get ["th"]) correctly. *) + +(* Color handling *) +module Color : sig + type color = + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + + type style = + | FG of color (* foreground *) + | BG of color (* background *) + | Bold + | Reset + + type Format.stag += Style of style list + + val ansi_of_style_l : style list -> string + (* ANSI escape sequence for the given style *) + + type styles = { + error: style list; + warning: style list; + loc: style list; + hint:style list; + } + + val default_styles: styles + val get_styles: unit -> styles + val set_styles: styles -> unit + + type setting = Auto | Always | Never + + val default_setting : setting + + val setup : setting option -> unit + (* [setup opt] will enable or disable color handling on standard formatters + according to the value of color setting [opt]. + Only the first call to this function has an effect. *) + + val set_color_tag_handling : Format.formatter -> unit + (* adds functions to support color tags to the given formatter. *) +end + +val print_see_manual : Format.formatter -> int list -> unit +(** See manual section *) diff --git a/ocamlmerlin_mlx/utils/platform_misc.c b/ocamlmerlin_mlx/utils/platform_misc.c new file mode 100644 index 0000000..b90e7da --- /dev/null +++ b/ocamlmerlin_mlx/utils/platform_misc.c @@ -0,0 +1,226 @@ +#line 1 "merlin/src/platform/platform_misc.c" +#ifdef _WIN32 +#define CAML_NAME_SPACE +#define CAML_INTERNALS +#include +#include +#include +#endif + +#include +#include +#include +#include +#include +#include + +/* FS case */ + +#ifdef __APPLE__ + +#include +#include +#include + +value ml_merlin_fs_exact_case(value path) +{ + CAMLparam1(path); + CAMLlocal1(realpath); + char realpath_c[MAXPATHLEN]; + + realpath = path; + + int fd = open(String_val(path), O_EVTONLY | O_SYMLINK); + if (fd != -1) + { + if (fcntl(fd, F_GETPATH, realpath_c) != -1) + { + realpath = caml_copy_string(realpath_c); + } + close(fd); + } + CAMLreturn(realpath); +} + + +#else + +value ml_merlin_fs_exact_case(value path) +{ + return path; +} + +#endif + +#ifdef _WIN32 + +value ml_merlin_fs_exact_case_basename(value path) +{ + CAMLparam1(path); + CAMLlocal1(result); + HANDLE h; + wchar_t * wname; + WIN32_FIND_DATAW fileinfo; + + wname = caml_stat_strdup_to_utf16(String_val(path)); + h = FindFirstFileW(wname, &fileinfo); + caml_stat_free(wname); + + if (h == INVALID_HANDLE_VALUE) { + result = Val_int(0); + } else { + FindClose(h); + result = caml_alloc (1, 0); + Store_field(result, 0, caml_copy_string_of_utf16(fileinfo.cFileName)); + } + + CAMLreturn(result); +} + +#else + +value ml_merlin_fs_exact_case_basename(value path) +{ + (void)path; + return Val_int(0); +} + +#endif + +#ifdef _WIN32 + +/* File descriptor inheritance */ + +#include +#include + +value ml_merlin_dont_inherit_stdio(value vstatus) +{ + int status = Int_val(vstatus) ? 0 : HANDLE_FLAG_INHERIT; + SetHandleInformation((HANDLE)_get_osfhandle(1), HANDLE_FLAG_INHERIT, status); + SetHandleInformation((HANDLE)_get_osfhandle(2), HANDLE_FLAG_INHERIT, status); + return Val_unit; +} + +/* Run ppx-command without opening a sub console */ + +static int windows_system(wchar_t *cmd, wchar_t *cwd, wchar_t *outfile, DWORD *ret) +{ + PROCESS_INFORMATION p_info; + STARTUPINFOW s_info; + SECURITY_ATTRIBUTES s_attrs; + HANDLE hp, p_stderr, hf; + DWORD handleInfo, flags, err = ERROR_SUCCESS; + + memset(&s_info, 0, sizeof(s_info)); + memset(&p_info, 0, sizeof(p_info)); + memset(&s_attrs, 0, sizeof(s_attrs)); + s_info.cb = sizeof(s_info); + s_info.dwFlags = STARTF_USESTDHANDLES; + + s_info.hStdInput = INVALID_HANDLE_VALUE; + + /* If needed, duplicate stderr to make sure it is inheritable */ + p_stderr = GetStdHandle(STD_ERROR_HANDLE); + if (p_stderr == INVALID_HANDLE_VALUE) { + err = GetLastError(); goto ret; + } + if (! GetHandleInformation(p_stderr, &handleInfo)) { + err = GetLastError(); goto ret; + } + if (! (handleInfo & HANDLE_FLAG_INHERIT)) { + hp = GetCurrentProcess(); + if (! DuplicateHandle(hp, p_stderr, hp, &(s_info.hStdError), + 0, TRUE, DUPLICATE_SAME_ACCESS)) { + err = GetLastError(); goto ret; + } + } else { + s_info.hStdError = p_stderr; + } + + /* Redirect stdout to , or to stderr if no */ + if (outfile == NULL) { + s_info.hStdOutput = s_info.hStdError; + hf = INVALID_HANDLE_VALUE; + } else { + s_attrs.bInheritHandle = TRUE; + s_attrs.nLength = sizeof(s_attrs); + hf = CreateFileW(outfile, + GENERIC_WRITE, + FILE_SHARE_WRITE | FILE_SHARE_READ, + &s_attrs, + OPEN_ALWAYS, + FILE_ATTRIBUTE_NORMAL, + NULL); + if (hf == INVALID_HANDLE_VALUE) { + err = GetLastError(); goto ret; + } + s_info.hStdOutput = hf; + } + + flags = CREATE_NO_WINDOW | CREATE_UNICODE_ENVIRONMENT; + if (! CreateProcessW(NULL, cmd, NULL, NULL, + TRUE, flags, NULL, cwd, &s_info, &p_info)) { + err = GetLastError(); + } + + /* Close the handle if we duplicated it above. */ + if (! (handleInfo & HANDLE_FLAG_INHERIT)) + CloseHandle(s_info.hStdError); + + if (err == ERROR_SUCCESS) { + WaitForSingleObject(p_info.hProcess, INFINITE); + GetExitCodeProcess(p_info.hProcess, ret); + CloseHandle(p_info.hProcess); + CloseHandle(p_info.hThread); + } + + if (hf != INVALID_HANDLE_VALUE) { + CloseHandle(hf); + } + ret: + return err; +} + +value ml_merlin_system_command(value v_command, value v_cwd, value v_opt_outfile) +{ + CAMLparam3(v_command, v_cwd, v_opt_outfile); + DWORD ret, err; + wchar_t *command = caml_stat_strdup_to_utf16(String_val(v_command)); + wchar_t *cwd = caml_stat_strdup_to_utf16(String_val(v_cwd)); + wchar_t *outfile = NULL; + if (Is_some(v_opt_outfile)) { + outfile = caml_stat_strdup_to_utf16(String_val(Some_val(v_opt_outfile))); + } + caml_release_runtime_system(); + err = windows_system(command, cwd, outfile, &ret); + caml_acquire_runtime_system(); + caml_stat_free(command); + caml_stat_free(cwd); + if (outfile != NULL) caml_stat_free(outfile); + + if (err != ERROR_SUCCESS) { + win32_maperr(err); + uerror("windows_system", v_command); + } + + CAMLreturn(Val_int(ret)); +} + +#else + +value ml_merlin_dont_inherit_stdio(value vstatus) +{ + (void)vstatus; + return Val_unit; +} + +CAMLprim value ml_merlin_system_command(value v_command, value v_cwd, value v_opt_outfile) +{ + (void)v_command; + (void)v_cwd; + (void)v_opt_outfile; + caml_invalid_argument("ml_merlin_system_command is only available on windows"); +} + +#endif diff --git a/ocamlmerlin_mlx/utils/ppxsetup.ml b/ocamlmerlin_mlx/utils/ppxsetup.ml new file mode 100644 index 0000000..57b4e78 --- /dev/null +++ b/ocamlmerlin_mlx/utils/ppxsetup.ml @@ -0,0 +1,92 @@ +# 1 "merlin/src/utils/ppxsetup.ml" +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +open Std + +type t = { + ppxs: string list; + ppxopts: string list list String.Map.t; +} + +let empty = { ppxs = []; ppxopts = String.Map.empty } + +let add_ppx ppx t = + if List.mem ppx ~set:t.ppxs + then t + else {t with ppxs = ppx :: t.ppxs} + +let add_ppxopts ppx opts t = + match opts with + | [] -> t + | opts -> + let ppx = Filename.basename ppx in + let optss = + try String.Map.find ppx t.ppxopts + with Not_found -> [] + in + if not (List.mem ~set:optss opts) then + let ppxopts = String.Map.add ~key:ppx ~data:(opts :: optss) t.ppxopts in + {t with ppxopts} + else t + +let union ta tb = + { ppxs = List.filter_dup (ta.ppxs @ tb.ppxs); + ppxopts = String.Map.merge ~f:(fun _ a b -> match a, b with + | v, None | None, v -> v + | Some a, Some b -> Some (List.filter_dup (a @ b))) + ta.ppxopts tb.ppxopts + } + +let command_line t = + List.fold_right ~f:(fun ppx ppxs -> + let basename = Filename.basename ppx in + let opts = + try String.Map.find basename t.ppxopts + with Not_found -> [] + in + let opts = List.concat (List.rev opts) in + String.concat ~sep:" " (ppx :: opts) :: ppxs) + t.ppxs ~init:[] + +let dump t = + let string k = `String k in + let string_list l = `List (List.map ~f:string l) in + `Assoc [ + "preprocessors", + string_list t.ppxs; + "options", + `Assoc ( + String.Map.fold + ~f:(fun ~key ~data:opts acc -> + let opts = List.rev_map ~f:string_list opts in + (key, `List opts) :: acc) + ~init:[] + t.ppxopts + ) + ] diff --git a/ocamlmerlin_mlx/kernel/mreader_parser.mli b/ocamlmerlin_mlx/utils/ppxsetup.mli similarity index 82% rename from ocamlmerlin_mlx/kernel/mreader_parser.mli rename to ocamlmerlin_mlx/utils/ppxsetup.mli index be2dce4..745c4db 100644 --- a/ocamlmerlin_mlx/kernel/mreader_parser.mli +++ b/ocamlmerlin_mlx/utils/ppxsetup.mli @@ -1,4 +1,4 @@ -# 1 "merlin/src/kernel/mreader_parser.mli" +# 1 "merlin/src/utils/ppxsetup.mli" (* {{{ COPYING *( This file is part of Merlin, an helper for ocaml editors @@ -27,20 +27,14 @@ )* }}} *) -type kind = - | ML - | MLI - (*| MLL | MLY*) - type t -val make : Warnings.state -> Mreader_lexer.t -> kind -> t +val empty: t +val add_ppx: string -> t -> t +val add_ppxopts: string -> string list -> t -> t -type tree = [ - | `Interface of Parsetree.signature - | `Implementation of Parsetree.structure -] +val union: t -> t -> t -val result : t -> tree +val command_line: t -> string list -val errors : t -> exn list +val dump : t -> Std.json diff --git a/ocamlmerlin_mlx/utils/sexp.ml b/ocamlmerlin_mlx/utils/sexp.ml new file mode 100644 index 0000000..da3045d --- /dev/null +++ b/ocamlmerlin_mlx/utils/sexp.ml @@ -0,0 +1,314 @@ +# 1 "merlin/src/utils/sexp.ml" +type t = + | Cons of t * t + | Sym of string + | String of string + | Int of int + | Float of float + +let nil = Sym "nil" + +let escaped str = + let len = String.length str in + let extra_chars = ref 0 in + for i = 0 to len - 1 do + match str.[i] with + | '\\' | '"' -> incr extra_chars + | _ -> () + done; + let buf = Buffer.create (len + !extra_chars + 2) in + Buffer.add_char buf '"'; + if !extra_chars = 0 then ( + Buffer.add_string buf str + ) else ( + for i = 0 to len - 1 do + let c = str.[i] in + if c = '"' || c = '\\' then + Buffer.add_char buf '\\'; + Buffer.add_char buf c + done; + ); + Buffer.add_char buf '"'; + Buffer.contents buf + +let unescaped str = + (* Unescaped doesn't support unicode escaping and multibyte hex and octal + escaping. + Unicode escaping: '\uNNNN' or '\U00NNNNNN' + Hex/octal escaping looks like '\xNN' or '\NNN'. + '\xNNNN' and '\NNNNNN' are ambiguous, but emacs will try to parse them + as multibyte + *) + match String.index str '\\' with + | exception Not_found -> str + | _ -> + let len = String.length str in + let buf = Buffer.create len in + let i = ref 0 in + while !i < len do + match str.[!i] with + | '\\' -> ( + incr i; + begin match str.[!i] with + | 'n' -> Buffer.add_char buf '\n' + | 'r' -> Buffer.add_char buf '\r' + | 't' -> Buffer.add_char buf '\t' + | 'x' -> + let c0 = Char.code str.[!i+1] in + let c1 = Char.code str.[!i+2] in + Buffer.add_char buf (Char.chr ((c0 * 16) lor c1)); + i := !i + 2; + | '0'..'9' -> + let c0 = Char.code str.[!i+1] in + let c1 = Char.code str.[!i+2] in + let c2 = Char.code str.[!i+3] in + Buffer.add_char buf (Char.chr ((c0 * 64) lor (c1 * 8) lor c2)); + i := !i + 2; + | c -> Buffer.add_char buf c + end; + incr i + ) + | c -> + Buffer.add_char buf c; + incr i + done; + Buffer.contents buf + +let rec of_list = function + | [] -> nil + | a :: tl -> Cons (a, of_list tl) + +let rec tell_sexp tell = function + | Cons (a,b) -> + tell "("; + tell_sexp tell a; + tell_cons tell b + | Sym s -> tell s + | String s -> tell (escaped s) + | Int i -> tell (string_of_int i) + | Float f -> tell (string_of_float f) + +and tell_cons tell = function + | Sym "nil" -> tell ")" + | Cons (a,b) -> + tell " "; + tell_sexp tell a; + tell_cons tell b + | sexp -> + tell " . "; + tell_sexp tell sexp; + tell ")" + +let is_alpha c = + (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + +let is_num c = + (c >= '0' && c <= '9' || c == '-') + +let is_alphanum c = is_alpha c || is_num c + +let read_sexp getch = + let buf = Buffer.create 10 in + let rec read_sexp getch = function + | ' ' | '\t' | '\n' -> + read_sexp getch (getch ()) + + | c when is_num c -> + read_num getch c + + | '\'' | ':' | '_' as c -> read_sym getch (Some c) + | c when is_alpha c -> read_sym getch (Some c) + + | '"' -> + read_string getch + | '\000' -> raise End_of_file + | '(' -> + let lhs, next = read_sexp getch (getch ()) in + read_cons getch (fun rhs -> Cons (lhs, rhs)) next + | _ -> failwith "Invalid parse" + + and read_cons getch k next = + match (match next with Some c -> c | None -> getch ()) with + | ' ' | '\t' | '\n' -> read_cons getch k None + | ')' -> k nil, None + | '.' -> + let rhs, next = read_sexp getch (getch ()) in + let rec aux = function + | ')' -> k rhs + | ' ' | '\t' | '\n' -> aux (getch ()) + | _ -> failwith "Invalid parse" + in + begin match next with + | Some c -> aux c + | None -> aux (getch ()) + end, None + | c -> + let cell, next = read_sexp getch c in + read_cons getch (fun rhs -> k (Cons (cell, rhs))) next + + and read_num getch c = + Buffer.clear buf; + Buffer.add_char buf c; + let rec aux ~is_start ~is_float = + match getch () with + | '-' when is_start -> + Buffer.add_char buf c; aux ~is_start:false ~is_float + | c when c >= '0' && c <= '9' -> + Buffer.add_char buf c; aux ~is_start:false ~is_float + | '.' | 'e' | 'E' as c -> + Buffer.add_char buf c; aux ~is_start:false ~is_float:true + | c -> + let s = Buffer.contents buf in + (if is_float + then Float (float_of_string s) + else Int (int_of_string s)), + Some c + in + aux ~is_start:true ~is_float:false + + and read_string getch = + Buffer.clear buf; + let rec aux () = + match getch () with + | '\000' -> failwith "Unterminated string" + | '\\' -> + Buffer.add_char buf '\\'; + Buffer.add_char buf (getch ()); + aux () + | '"' -> + String (unescaped (Buffer.contents buf)), None + | c -> + Buffer.add_char buf c; + aux () + in + aux () + + and read_sym getch next = + Buffer.clear buf; + let rec aux next = + match (match next with Some c -> c | None -> getch ()) with + | ('\'' | '-' | ':' | '_') as c -> + Buffer.add_char buf c; + aux None + | c when is_alphanum c -> + Buffer.add_char buf c; + aux None + | c -> Sym (Buffer.contents buf), Some c + in + aux next + in + read_sexp getch (getch ()) + +let to_buf sexp buf = + tell_sexp (Buffer.add_string buf) sexp + +let to_string sexp = + let buf = Buffer.create 100 in + to_buf sexp buf; + Buffer.contents buf + +let getch_of_substring str pos len = + let len = pos + len in + if pos < 0 || len > String.length str then + invalid_arg "Sexp.getch_of_substring"; + let pos = ref pos in + let getch () = + if !pos < len then + let r = str.[!pos] in + incr pos; + r + else '\000' + in + getch + +let getch_of_string str = + getch_of_substring str 0 (String.length str) + +let of_string str = + fst (read_sexp (getch_of_string str)) + +let getch_of_subbytes str pos len = + let len = pos + len in + if pos < 0 || len > Bytes.length str then + invalid_arg "Sexp.getch_of_subbytes"; + let pos = ref pos in + let getch () = + if !pos < len then + let r = Bytes.get str !pos in + incr pos; + r + else '\000' + in + getch + +let of_file_descr ?(on_read=ignore) fd = + let getch = ref (fun () -> '\000') in + let rest = ref None in + let buffer = Bytes.create 1024 in + let getch () = + match !rest with + | Some r -> + rest := None; + r + | None -> + match !getch () with + | '\000' -> + on_read fd; + let read = Unix.read fd buffer 0 1024 in + if read = 0 then '\000' + else + begin + getch := getch_of_subbytes buffer 0 read; + !getch () + end + | c -> c + in + fun () -> + try + let sexp, rest' = read_sexp getch in + rest := rest'; + Some sexp + with End_of_file -> None + +let of_channel ?on_read ic = + of_file_descr ?on_read (Unix.descr_of_in_channel ic) + +let rec of_json = + let assoc_item (a,b) = Cons (Sym a, of_json b) in + function + | `Null -> Sym "null" + | `Int i -> Int i + | `Float f -> Float f + | `String s -> String s + | `Bool true -> Sym "true" + | `Bool false -> Sym "false" + | `Assoc lst -> Cons (Cons (Sym "assoc", Sym "nil"), of_list (List.map assoc_item lst)) + | `List lst -> of_list (List.map of_json lst) + +let rec to_json = + let fail msg sexp = + failwith (msg ^ ", got: \n" ^ to_string sexp) + in + let rec assoc_item = function + | Cons (Cons (Sym a, b), c) -> (a, to_json b) :: assoc_item c + | Sym "nil" -> [] + | sexp -> fail "expecting association (key . value)" sexp + in + let rec list_items = function + | Sym "nil" -> [] + | Cons (hd, tl) -> to_json hd :: list_items tl + | sexp -> fail "expecting list" sexp + in + function + | Sym "null" -> `Null + | Sym "true" -> `Bool true + | Sym "false" -> `Bool false + | Int i -> `Int i + | Float f -> `Float f + | String s -> `String s + | Cons (Cons (Sym "assoc", Sym "nil"), assocs) -> + `Assoc (assoc_item assocs) + | Sym "nil" -> `List [] + | Cons (hd, tl) -> `List (to_json hd :: list_items tl) + | Sym s -> `String s diff --git a/ocamlmerlin_mlx/utils/sexp.mli b/ocamlmerlin_mlx/utils/sexp.mli new file mode 100644 index 0000000..5c7035e --- /dev/null +++ b/ocamlmerlin_mlx/utils/sexp.mli @@ -0,0 +1,29 @@ +# 1 "merlin/src/utils/sexp.mli" +open Std + +type t = + Cons of t * t + | Sym of string + | String of string + | Int of int + | Float of float + +val nil : t +val of_list : t list -> t + +val tell_sexp : (string -> unit) -> t -> unit +val tell_cons : (string -> unit) -> t -> unit + +val to_buf : t -> Buffer.t -> unit + +val to_string : t -> string + +val of_string : string -> t + +val of_file_descr : + ?on_read:(Unix.file_descr -> unit) -> Unix.file_descr -> unit -> t option +val of_channel : + ?on_read:(Unix.file_descr -> unit) -> in_channel -> unit -> t option + +val of_json : json -> t +val to_json : t -> json diff --git a/ocamlmerlin_mlx/utils/stamped_hashtable.ml b/ocamlmerlin_mlx/utils/stamped_hashtable.ml new file mode 100644 index 0000000..e466000 --- /dev/null +++ b/ocamlmerlin_mlx/utils/stamped_hashtable.ml @@ -0,0 +1,92 @@ +# 1 "merlin/src/utils/stamped_hashtable.ml" +(* A cell, recording a single change of the changelog. + It needs to be a GADT to hide the parameters of the Hashtbl. *) +type cell = + Cell : { + stamp: int; + table: ('a, 'b) Hashtbl.t; + key: 'a; + } -> cell + +type changelog = { + mutable recent: cell list; + (* The [recent] list contains the changes that happened since the last + call to backtrack, in reverse order (the most recent change is first + in the list). *) + mutable sorted: cell list; + (* Cells in the [sorted] list are sorted by decreasing stamp, such that + listing all cells greater than a threshold is a simple, in order, + traversal. *) +} + +let create_changelog () = { + recent = []; + sorted = []; +} + +(* Wrappers around [Hashtbl] *) + +type ('a, 'b) t = { + table: ('a, 'b) Hashtbl.t; + changelog: changelog; +} + +let create changelog n = { + table = Hashtbl.create n; + changelog; +} + +let add {table; changelog} ?stamp key value = + Hashtbl.add table key value; + match stamp with + | None -> () + | Some stamp -> + changelog.recent <- Cell {stamp; key; table} :: changelog.recent + +let mem t a = + Hashtbl.mem t.table a + +let find t a = + Hashtbl.find t.table a + +(* Implementation of backtracking *) + +(* Helper to sort by decreasing stamps *) +let order (Cell c1) (Cell c2) = + Int.compare c2.stamp c1.stamp + +(* Drop the prefix not satisfying a certain predicate *) +let rec filter_prefix pred = function + | x :: xs when not (pred x) -> + filter_prefix pred xs + | xs -> xs + +let backtrack cs ~stamp = + (* Check if a cell is still valid (older than [stamp]). + If not, remove it from its table. *) + let process (Cell c) = + if c.stamp > stamp then ( + Hashtbl.remove c.table c.key; + false + ) else + true + in + (* Process recent list: + - remove items newer than [stamp] + - sort the remainder *) + let recent = + cs.recent + |> List.filter process + |> List.fast_sort order + in + cs.recent <- []; + (* Process sorted list: + - remove prefix items newer than [stamp] + - merge remaining items with the recent ones + *) + let sorted = + cs.sorted + |> filter_prefix process + |> List.merge order recent + in + cs.sorted <- sorted diff --git a/ocamlmerlin_mlx/utils/stamped_hashtable.mli b/ocamlmerlin_mlx/utils/stamped_hashtable.mli new file mode 100644 index 0000000..2a7121e --- /dev/null +++ b/ocamlmerlin_mlx/utils/stamped_hashtable.mli @@ -0,0 +1,43 @@ +# 1 "merlin/src/utils/stamped_hashtable.mli" +(* A stamped hashtable is a hashtable that can associate an optional integer + stamp to its bindings. + The user can then efficiently remove all bindings with stamps greater than a + bound. + + This datastructure is used to flush of the compiler caches: stamps come from + [Ident.stamp] which are monotonically increasing unique identifiers. + + Merlin keeps regular snapshots of the compiler state to minimize the amount + of work that needs to be redone. Flushing the cache is necessary to avoid + state (and memory) leaking when backtracking. +*) + +type ('a, 'b) t +(** An instance of a stamped hashtable *) + +type changelog +(** The [changelog] datastructure logs stamped bindings added to tables. + By separating the log from the table, it is possible to efficiently remove + stamped bindings spread accross multiple tables. *) + +val create : changelog -> int -> ('a, 'b) t +(** [create changelog n] creates a new table with an initial size of [n] + (see [Hashtbl.create]) that logs its changes to [changelog]. *) + +val add : ('a, 'b) t -> ?stamp:int -> 'a -> 'b -> unit +(** Add a binding, like [Hashtbl.add], with an optional [stamp]. + Unlike [Hashtbl.add], having multiple bindings with the same key is + undefined. (It's ok, this feature is not used by the caches!) *) + +val mem : ('a, 'b) t -> 'a -> bool +(** See [Hashtbl.mem]. *) + +val find : ('a, 'b) t -> 'a -> 'b +(** See [Hashtbl.find]. *) + +val create_changelog : unit -> changelog +(** Create a new change log. *) + +(* [backtrack changelog ~stamp] remove all items added to tables logging to + [changelog] with a stamp strictly greater than [stamp] *) +val backtrack : changelog -> stamp:int -> unit diff --git a/ocamlmerlin_mlx/utils/std.ml b/ocamlmerlin_mlx/utils/std.ml new file mode 100644 index 0000000..68bab0b --- /dev/null +++ b/ocamlmerlin_mlx/utils/std.ml @@ -0,0 +1,851 @@ +# 1 "merlin/src/utils/std.ml" +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan + + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. + +)* }}} *) + +type json = +[ `Assoc of (string * json) list +| `Bool of bool +| `Float of float +| `Int of int +| `List of json list +| `Null +| `String of string ] + +module Json = struct + type t = json + + let string x = `String x + let int x = `Int x + let bool x = `Bool x + + let option f = function + | None -> `Null + | Some x -> f x + + let list f x = + `List (List.map f x) + + let pretty_to_string : (t -> string) ref = ref @@ fun _ -> + Printf.sprintf + "Logger error: `Std.Json.pretty_to_string` \ + is not set. You should initialize that reference with the \ + pretifier of your choice to enable json logging. \ + A common one is `Yojson.Basic.pretty_to_string`." +end + +module Hashtbl = struct + include Hashtbl + + let find_some tbl key = + try Some (find tbl key) + with Not_found -> None + + let elements tbl = Hashtbl.fold (fun _key elt acc -> elt :: acc) tbl [] + + let forall table f = + match Hashtbl.iter (fun k v -> if not (f k v) then raise Exit) table with + | () -> true + | exception Exit -> false +end + +module List = struct + include ListLabels + + let init ~f n = + let rec aux i = if i = n then [] else f i :: aux (succ i) in + aux 0 + + let index ~f l = + let rec aux i = function + | [] -> raise Not_found + | x :: _ when f x -> i + | _ :: xs -> aux (succ i) xs + in + aux 0 l + + let find_some ~f l = + try Some (find ~f l) + with Not_found -> None + + let rec rev_scan_left acc ~f l ~init = match l with + | [] -> acc + | x :: xs -> + let init = f init x in + rev_scan_left (init :: acc) ~f xs ~init + + let scan_left ~f l ~init = + List.rev (rev_scan_left [] ~f l ~init) + + let rev_filter ~f lst = + let rec aux acc = function + | [] -> acc + | x :: xs -> aux (if f x then x :: acc else acc) xs + in + aux [] lst + + let rec filter_map ~f = function + | [] -> [] + | x :: xs -> + match f x with + | None -> filter_map ~f xs + | Some x -> x :: filter_map ~f xs + + let rec find_map ~f = function + | [] -> raise Not_found + | x :: xs -> + match f x with + | None -> find_map ~f xs + | Some x' -> x' + + let rec map_end ~f l1 l2 = + match l1 with + | [] -> l2 + | hd::tl -> f hd :: map_end ~f tl l2 + + let concat_map ~f l = flatten (map ~f l) + + let replicate elem n = + let rec aux acc elem n = + if n <= 0 then acc else aux (elem :: acc) elem (n-1) + in + aux [] elem n + + let rec remove ?(phys=false) x = + let check = if phys then (==) else (=) in + function + | [] -> [] + | hd :: tl when check x hd -> tl + | hd :: tl -> hd :: remove ~phys x tl + + let rec remove_all x = function + | [] -> [] + | hd :: tl when x = hd -> remove_all x tl + | hd :: tl -> hd :: remove_all x tl + + let rec same ~f l1 l2 = match l1, l2 with + | [], [] -> true + | (hd1 :: tl1), (hd2 :: tl2) when f hd1 hd2 -> same ~f tl1 tl2 + | _, _ -> false + + (* [length_lessthan n l] returns + * Some (List.length l) if List.length l <= n + * None otherwise *) + let length_lessthan n l = + let rec aux i = function + | _ :: xs when i < n -> aux (succ i) xs + | [] -> Some i + | _ -> None + in + aux 0 l + + let filter_dup' ~equiv lst = + let tbl = Hashtbl.create 17 in + let f a b = + let b' = equiv b in + if Hashtbl.mem tbl b' + then a + else (Hashtbl.add tbl b' (); b :: a) + in + rev (fold_left ~f ~init:[] lst) + + let filter_dup lst = filter_dup' ~equiv:(fun x -> x) lst + + let rec merge_cons ~f = function + | a :: ((b :: tl) as tl') -> + begin match f a b with + | Some a' -> merge_cons ~f (a' :: tl) + | None -> a :: merge_cons ~f tl' + end + | tl -> tl + + let rec take_while ~f = function + | x :: xs when f x -> x :: take_while ~f xs + | _ -> [] + + let rec drop_while ~f = function + | x :: xs when f x -> drop_while ~f xs + | xs -> xs + + let rec take_n acc n = function + | x :: xs when n > 0 -> take_n (x :: acc) (n - 1) xs + | _ -> List.rev acc + let take_n n l = take_n [] n l + + let rec drop_n n = function + | _ :: xs when n > 0 -> drop_n (n - 1) xs + | xs -> xs + + let rec split_n acc n = function + | x :: xs when n > 0 -> split_n (x :: acc) (n - 1) xs + | xs -> List.rev acc, xs + let split_n n l = split_n [] n l + + let rec split3 xs ys zs = function + | (x,y,z) :: tl -> split3 (x :: xs) (y :: ys) (z :: zs) tl + | [] -> List.rev xs, List.rev ys, List.rev zs + let split3 l = split3 [] [] [] l + + let rec unfold ~f a = match f a with + | None -> [] + | Some a -> a :: unfold ~f a + + let rec rev_unfold acc ~f a = match f a with + | None -> acc + | Some a -> rev_unfold (a :: acc) ~f a + + let rec fold_n_map ~f ~init = function + | [] -> init, [] + | x :: xs -> + let acc, x' = f init x in + let acc, xs' = fold_n_map ~f ~init:acc xs in + acc, (x' :: xs') + + module Lazy = struct + type 'a t = + | Nil + | Cons of 'a * 'a t lazy_t + + let rec map ~f = function + | Nil -> Nil + | Cons (hd,tl) -> + Cons (f hd, lazy (map ~f (Lazy.force tl))) + + let rec to_strict = function + | Nil -> [] + | Cons (hd, lazy tl) -> hd :: to_strict tl + + let rec unfold f a = match f a with + | None -> Nil + | Some a -> Cons (a, lazy (unfold f a)) + + let rec filter_map ~f = function + | Nil -> Nil + | Cons (a, tl) -> match f a with + | None -> filter_map ~f (Lazy.force tl) + | Some a' -> Cons (a', lazy (filter_map ~f (Lazy.force tl))) + end + + let rec last = function + | [] -> None + | [x] -> Some x + | _ :: l -> last l + + let rec group_by pred group acc = function + | [] -> List.rev acc + | x :: xs -> + match group with + | (x' :: _) when pred x x' -> + group_by pred (x :: group) acc xs + | _ -> group_by pred [x] (group :: acc) xs + + let group_by pred xs = + match group_by pred [] [] xs with + | [] :: xs | xs -> xs + + (* Merge sorted lists *) + let rec merge ~cmp l1 l2 = match l1, l2 with + | l, [] | [], l -> l + | (x1 :: _), (x2 :: x2s) when cmp x1 x2 > 0 -> + x2 :: merge ~cmp l1 x2s + | x1 :: x1s, _ -> + x1 :: merge ~cmp x1s l2 + + let rec dedup_adjacent ~cmp = function + | x1 :: (x2 :: _ as xs) when cmp x1 x2 = 0 -> dedup_adjacent ~cmp xs + | x :: xs -> x :: dedup_adjacent ~cmp xs + | [] -> [] + + (* [sort_uniq] does not need to maintain a set of seen entries because duplicates will + be adjacent. *) + let sort_uniq ~cmp l = dedup_adjacent ~cmp (sort ~cmp l) + + let print f () l = + "[ " ^ String.concat "; " (List.map (f ()) l) ^ " ]" +end + +module Option = struct + let bind opt ~f = + match opt with + | None -> None + | Some x -> f x + + let map ~f = function + | None -> None + | Some x -> Some (f x) + + let get = function + | None -> raise Not_found + | Some x -> x + + let value ~default = function + | None -> default + | Some x -> x + + let value_map ~f ~default = function + | None -> default + | Some x -> f x + + let iter ~f = function + | None -> () + | Some x -> f x + + let cons o xs = match o with + | None -> xs + | Some x -> x :: xs + + module Infix = struct + let return x = Some x + let (>>=) x f = bind x ~f + let (>>|) x f = map x ~f + end + + include Infix + + let to_list = function + | None -> [] + | Some x -> [x] + + let is_some = function + | None -> false + | _ -> true + + let plus a b = match a with + | Some _ -> a + | None -> b + + let print f () = function + | None -> "None" + | Some s -> "Some (" ^ f () s ^ ")" +end + +module Result = struct + type ('a, 'e) t = ('a, 'e) result = + | Ok of 'a + | Error of 'e + + let map ~f r = Result.map f r + let bind ~f r = Result.bind r f +end + +module String = struct + include StringLabels + + let for_all f t = + let len = String.length t in + let rec loop i = + i = len || (f t.[i] && loop (i + 1)) + in + loop 0 + + + let reverse s1 = + let len = length s1 in + let s2 = Bytes.make len 'a' in + for i = 0 to len - 1 do + Bytes.set s2 i s1.[len - i - 1] + done ; + Bytes.to_string s2 + + let common_prefix_len s1 s2 = + let rec aux i = + if i >= length s1 || i >= length s2 || s1.[i] <> s2.[i] then i else + aux (succ i) + in + aux 0 + + (* [is_prefixed ~by s] returns [true] iff [by] is a prefix of [s] *) + let is_prefixed ~by = + let l = String.length by in + fun s -> + let l' = String.length s in + (l' >= l) && + (try for i = 0 to pred l do + if s.[i] <> by.[i] then + raise Not_found + done; + true + with Not_found -> false) + + (* Drop characters from beginning of string *) + let drop n s = sub s ~pos:n ~len:(length s - n) + + module Set = struct + include MoreLabels.Set.Make (struct type t = string let compare = compare end) + let of_list l = List.fold_left ~f:(fun s elt -> add elt s) l ~init:empty + let to_list s = fold ~f:(fun x xs -> x :: xs) s ~init:[] + end + + module Map = struct + include MoreLabels.Map.Make (struct type t = string let compare = compare end) + let of_list l = + List.fold_left ~f:(fun m (k,v) -> add ~key:k ~data:v m) l ~init:empty + let to_list m = fold ~f:(fun ~key ~data xs -> (key,data) :: xs) m ~init:[] + + let keys m = fold ~f:(fun ~key ~data:_ xs -> key :: xs) m ~init:[] + let values m = fold ~f:(fun ~key:_ ~data xs -> data :: xs) m ~init:[] + + let add_multiple key data t = + let current = + try find key t + with Not_found -> [] + in + let data = data :: current in + add ~key ~data t + end + + let mem c s = + try ignore (String.index s c : int); true + with Not_found -> false + + let first_double_underscore_end s = + let len = String.length s in + let rec aux i = + if i > len - 2 then raise Not_found else + if s.[i] = '_' && s.[i + 1] = '_' then i + 1 + else aux (i + 1) + in + aux 0 + + let no_double_underscore s = + try ignore (first_double_underscore_end s); false + with Not_found -> true + + let trim = function "" -> "" | str -> + let l = String.length str in + let is_space = function + | ' ' | '\n' | '\t' | '\r' -> true + | _ -> false + in + let r0 = ref 0 and rl = ref l in + while !r0 < l && is_space str.[!r0] do incr r0 done; + let r0 = !r0 in + while !rl > r0 && is_space str.[!rl - 1] do decr rl done; + let rl = !rl in + if r0 = 0 && rl = l then str else sub str ~pos:r0 ~len:(rl - r0) + + let print () s = Printf.sprintf "%S" s + + let capitalize = capitalize_ascii + let uncapitalize = uncapitalize_ascii + + let lowercase = lowercase_ascii + let uppercase = uppercase_ascii + + let split_on_char_ c s = + match String.index s c with + | exception Not_found -> [s] + | p -> + let rec loop i = + match String.index_from s i c with + | exception Not_found -> [String.sub s i (String.length s - i)] + | j -> + let s0 = String.sub s i (j - i) in + s0 :: loop (j + 1) + in + let s0 = String.sub s 0 p in + s0 :: loop (p + 1) + + let chop_prefix ~prefix text = + let tlen = String.length text in + let plen = String.length prefix in + if tlen >= plen then + try + for i = 0 to plen - 1 do + if prefix.[i] <> text.[i] then raise Not_found + done; + Some (String.sub text plen (tlen - plen)) + with Not_found -> None + else + None + + let next_occurrence ~pattern text from = + let plen = String.length pattern in + let last = String.length text - plen in + let i = ref from and j = ref 0 in + while !i <= last && !j < plen do + if text.[!i + !j] <> pattern.[!j] + then (incr i; j := 0) + else incr j + done; + if !j < plen then + raise Not_found + else + !i + + let replace_all ~pattern ~with_ text = + if pattern = "" then text else + match next_occurrence ~pattern text 0 with + | exception Not_found -> text + | j0 -> + let buffer = Buffer.create (String.length text) in + let rec aux i j = + Buffer.add_substring buffer text i (j - i); + Buffer.add_string buffer with_; + let i' = j + String.length pattern in + match next_occurrence ~pattern text i' with + | exception Not_found -> + Buffer.add_substring buffer text i' (String.length text - i') + | j' -> aux i' j' + in + aux 0 j0; + Buffer.contents buffer +end + +let sprintf = Printf.sprintf + +module Format = struct + include Format + + let default_width = ref 0 + + let to_string ?(width= !default_width) () = + let b = Buffer.create 32 in + let ppf = formatter_of_buffer b in + let contents () = + pp_print_flush ppf (); + Buffer.contents b + in + pp_set_margin ppf width; + ppf, contents +end + +module Lexing = struct + + type position = Lexing.position = { + pos_fname : string; + pos_lnum : int; + pos_bol : int; + pos_cnum : int; + } + + include (Lexing : module type of struct include Lexing end + with type position := position) + + let move buf p = + buf.lex_abs_pos <- (p.pos_cnum - buf.lex_curr_pos); + buf.lex_curr_p <- p + + let from_strings ?empty ?position source refill = + let pos = ref 0 in + let len = ref (String.length source) in + let source = ref source in + let lex_fun buf size = + let count = min (!len - !pos) size in + let count = + if count <= 0 then + begin + source := refill (); + len := String.length !source; + pos := 0; + min !len size + end + else count + in + if count <= 0 then 0 + else begin + String.blit ~src:!source ~src_pos:!pos ~dst:buf ~dst_pos:0 ~len:count; + pos := !pos + count; + (match empty with None -> () | Some r -> r := !pos >= !len); + count + end + in + let buf = from_function lex_fun in + Option.iter ~f:(move buf) position; + buf + + (* Manipulating position *) + let make_pos ?(pos_fname="") (pos_lnum, pos_cnum) = + { pos_fname ; pos_lnum ; pos_cnum ; pos_bol = 0 } + + let column pos = pos.pos_cnum - pos.pos_bol + + let set_column pos col = {pos with pos_cnum = pos.pos_bol + col} + + let split_pos pos = (pos.pos_lnum, column pos) + + let compare_pos p1 p2 = + match compare p1.pos_lnum p2.pos_lnum with + | 0 -> compare (column p1) (column p2) + | n -> n + + let print_position () p = + let l1, c1 = split_pos p in + sprintf "%d:%d" l1 c1 + + (* Current position in lexer, even if the buffer is in the middle of a refill + operation *) + let immediate_pos buf = + {buf.lex_curr_p with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos} + + let json_of_position pos = + let line, col = split_pos pos in + `Assoc ["line", `Int line; "col", `Int col] + + let min_pos p1 p2 = + if compare_pos p1 p2 <= 0 then p1 else p2 + + let max_pos p1 p2 = + if compare_pos p1 p2 >= 0 then p1 else p2 +end + +module Char = struct + + (* FIXME: Remove once we drop support for 4.02 and replace the calls to + [uppercase] and [lowercase] by their [_ascii] version. *) + [@@@ocaml.warning "-3"] + + include Char + let is_lowercase c = lowercase_ascii c = c + let is_uppercase c = uppercase_ascii c = c + let is_strictly_lowercase c = not (is_uppercase c) + let is_strictly_uppercase c = not (is_lowercase c) +end + +module Glob : sig + type pattern = + | Wildwild + | Exact of string + | Regexp of Str.regexp + val compile_pattern : string -> pattern + val match_pattern : pattern -> string -> bool +end = struct + type pattern = + | Wildwild + | Exact of string + | Regexp of Str.regexp + + let compile_pattern = function + | "**" -> Wildwild + | pattern -> + let regexp = Buffer.create 15 in + let chunk = Buffer.create 15 in + let flush () = + if Buffer.length chunk > 0 then ( + Buffer.add_string regexp (Str.quote (Buffer.contents chunk)); + Buffer.clear chunk; + ) + in + let l = String.length pattern in + let i = ref 0 in + while !i < l do + begin match pattern.[!i] with + | '\\' -> incr i; if !i < l then Buffer.add_char chunk pattern.[!i] + | '*' -> flush (); Buffer.add_string regexp ".*"; + | '?' -> flush (); Buffer.add_char regexp '.'; + | x -> Buffer.add_char chunk x + end; + incr i + done; + if Buffer.length regexp = 0 then + Exact (Buffer.contents chunk) + else ( + flush (); + Buffer.add_char regexp '$'; + Regexp (Str.regexp (Buffer.contents regexp)) + ) + + let match_pattern re str = + match re with + | Wildwild -> true + | Regexp re -> Str.string_match re str 0 + | Exact s -> s = str +end + +let fprintf = Format.fprintf + +let lazy_eq a b = + match Lazy.is_val a, Lazy.is_val b with + | true, true -> Lazy.force_val a == Lazy.force_val b + | false, false -> a == b + | _ -> false + +let let_ref r v f = + let v' = !r in + r := v; + match f () with + | result -> r := v'; result + | exception exn -> r := v'; raise exn + +let failwithf fmt = Printf.ksprintf failwith fmt + +module Shell = struct + let split_command str = + let comps = ref [] in + let dirty = ref false in + let buf = Buffer.create 16 in + let flush () = + if !dirty then ( + comps := Buffer.contents buf :: !comps; + dirty := false; + Buffer.clear buf; + ) + in + let i = ref 0 and len = String.length str in + let unescape = function + | 'n' -> '\n' + | 'r' -> '\r' + | 't' -> '\t' + | x -> x + in + while !i < len do + let c = str.[!i] in + incr i; + match c with + | ' ' | '\t' | '\n' | '\r' -> flush () + | '\\' -> + dirty := true; + if !i < len then ( + Buffer.add_char buf (unescape str.[!i]); + incr i + ) + | '\'' -> + dirty := true; + while !i < len && str.[!i] <> '\'' do + Buffer.add_char buf str.[!i]; + incr i; + done; + incr i + | '"' -> + dirty := true; + while !i < len && str.[!i] <> '"' do + (match str.[!i] with + | '\\' -> + incr i; + if !i < len then + Buffer.add_char buf (unescape str.[!i]); + | x -> Buffer.add_char buf x + ); + incr i; + done; + incr i + | x -> + dirty := true; + Buffer.add_char buf x + done; + flush (); + List.rev !comps +end + +module System = struct + external windows_merlin_system_command : string -> cwd:string -> ?outfile:string -> int = + "ml_merlin_system_command" + + let run_in_directory + : (prog:string + -> prog_is_quoted:bool + -> args:string list + -> cwd:string + -> ?stdin:string + -> ?stdout:string + -> ?stderr:string + -> unit + -> [ `Finished of int | `Cancelled ]) ref = ref @@ + fun ~prog ~prog_is_quoted:_ ~args ~cwd ?stdin:_ ?stdout ?stderr:_ () -> + (* Currently we assume that [prog] is always quoted and might contain + arguments such as [-as-ppx]. This is due to the way Merlin gets its + configuration. Thus we cannot rely on [Filename.quote_command]. *) + let args = String.concat ~sep:" " @@ List.map ~f:Filename.quote args in + (* Runned program should never output on stdout since it is the + channel used by Merlin to communicate with the editor *) + let args = + if Sys.win32 then args + else + let stdout = match stdout with + | Some file -> Filename.quote file + | None -> "&2" + in + Printf.sprintf "%s 1>%s" args stdout + in + let cmd = Format.sprintf "%s %s" prog args in + let exit_code = + if Sys.win32 then + (* Note: the following function will never output to stdout. + When [stdout = None], stdout is sent to stderr. *) + windows_merlin_system_command cmd ~cwd ?outfile:stdout + else + Sys.command (Printf.sprintf "cd %s && %s" (Filename.quote cwd) cmd) + in + `Finished exit_code +end + + (* [modules_in_path ~ext path] lists ocaml modules corresponding to + * filenames with extension [ext] in given [path]es. + * For instance, if there is file "a.ml","a.mli","b.ml" in ".": + * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"], + * - modules_in_path ~ext:".mli" ["."] returns ["A"] *) +let modules_in_path ~ext path = + let seen = Hashtbl.create 7 in + List.fold_left ~init:[] path + ~f:begin fun results dir -> + try + Array.fold_left + begin fun results file -> + if Filename.check_suffix file ext + then let name = Filename.chop_extension file in + (if Hashtbl.mem seen name + then results + else + (Hashtbl.add seen name (); String.capitalize name :: results)) + else results + end results (Sys.readdir dir) + with Sys_error _ -> results + end + +let file_contents filename = + let ic = open_in filename in + try + let str = Bytes.create 1024 in + let buf = Buffer.create 1024 in + let rec loop () = + match input ic str 0 1024 with + | 0 -> () + | n -> + Buffer.add_subbytes buf str 0 n; + loop () + in + loop (); + close_in_noerr ic; + Buffer.contents buf + with exn -> + close_in_noerr ic; + raise exn + +external reraise : exn -> 'a = "%reraise" + +type 'a with_workdir = { + workdir : string; + workval : 'a; +} +(** Some value that must be interpreted with respect to a specific work + directory. (e.g. for resolving relative paths or executing sub-commands *) + +let dump_with_workdir f x : json = + `Assoc [ + "workdir", `String x.workdir; + "workval", f x.workval; + ] diff --git a/ocamlmerlin_mlx/utils/sys.ml b/ocamlmerlin_mlx/utils/sys.ml new file mode 100644 index 0000000..4b7aad2 --- /dev/null +++ b/ocamlmerlin_mlx/utils/sys.ml @@ -0,0 +1,4 @@ +include Stdlib.Sys + +let is_regular_file path = + file_exists path && not (is_directory path) diff --git a/test/example/dune-project b/test/example/dune-project index 025d490..c7699e5 100644 --- a/test/example/dune-project +++ b/test/example/dune-project @@ -1,4 +1,5 @@ -(lang dune 3.10) +(lang dune 3.15) +; (lang dune 3.16) (generate_opam_files false) @@ -9,6 +10,7 @@ (dialect (name mlx) (implementation + ; (merlin_reader mlx) (extension mlx) (preprocess (run mlx-pp %{input-file})))) diff --git a/test/mlx_merlin.ml b/test/mlx_merlin.ml index d37713e..ce0ca52 100644 --- a/test/mlx_merlin.ml +++ b/test/mlx_merlin.ml @@ -1,4 +1,4 @@ -open Ocaml_parsing +open Mlx_ocaml_parsing open Mlx_kernel let parse_string filename str = @@ -7,7 +7,7 @@ let parse_string filename str = let cfg = { cfg with - Merlin_kernel.Mconfig.query = { cfg.query with filename }; + Mconfig.query = { cfg.query with filename }; (* override this so we don't try to run any extensions *) merlin = { cfg.merlin with extension_to_reader = [] }; } @@ -35,6 +35,6 @@ let () = let () = List.iter report_error res.parser_errors in match res.parsetree with | `Implementation str -> - Format.printf "%a@." Ocaml_parsing.Pprintast.structure str + Format.printf "%a@." Mlx_ocaml_parsing.Pprintast.structure str | `Interface str -> - Format.printf "%a@." Ocaml_parsing.Pprintast.signature str + Format.printf "%a@." Mlx_ocaml_parsing.Pprintast.signature str