packages feed

lorentz (empty) → 0.1.0

raw patch · 87 files changed

+13389/−0 lines, 87 filesdep +HUnitdep +QuickCheckdep +base-noprelude

Dependencies added: HUnit, QuickCheck, base-noprelude, bimap, bytestring, constraints, containers, data-default, first-class-families, fmt, formatting, ghc-prim, hspec, interpolate, lens, lorentz, morley, morley-prelude, named, optparse-applicative, pretty-terminal, singletons, spoon, tasty, tasty-hunit-compat, tasty-quickcheck, template-haskell, text, type-spec, unordered-containers, vinyl

Files

+ CHANGES.md view
@@ -0,0 +1,7 @@+Unreleased+==========++0.1.0+=====++Initial release extracted from the [morley](https://hackage.haskell.org/package/morley) package.
+ LICENSE view
@@ -0,0 +1,662 @@+                    GNU AFFERO GENERAL PUBLIC LICENSE+                       Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU Affero General Public License is a free, copyleft license for+software and other kinds of works, specifically designed to ensure+cooperation with the community in the case of network server software.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+our General Public Licenses are intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  Developers that use our General Public Licenses protect your rights+with two steps: (1) assert copyright on the software, and (2) offer+you this License which gives you legal permission to copy, distribute+and/or modify the software.++  A secondary benefit of defending all users' freedom is that+improvements made in alternate versions of the program, if they+receive widespread use, become available for other developers to+incorporate.  Many developers of free software are heartened and+encouraged by the resulting cooperation.  However, in the case of+software used on network servers, this result may fail to come about.+The GNU General Public License permits making a modified version and+letting the public access it on a server without ever releasing its+source code to the public.++  The GNU Affero General Public License is designed specifically to+ensure that, in such cases, the modified source code becomes available+to the community.  It requires the operator of a network server to+provide the source code of the modified version running there to the+users of that server.  Therefore, public use of a modified version, on+a publicly accessible server, gives the public access to the source+code of the modified version.++  An older license, called the Affero General Public License and+published by Affero, was designed to accomplish similar goals.  This is+a different license, not a version of the Affero GPL, but Affero has+released a new version of the Affero GPL which permits relicensing under+this license.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU Affero General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Remote Network Interaction; Use with the GNU General Public License.++  Notwithstanding any other provision of this License, if you modify the+Program, your modified version must prominently offer all users+interacting with it remotely through a computer network (if your version+supports such interaction) an opportunity to receive the Corresponding+Source of your version by providing access to the Corresponding Source+from a network server at no charge, through some standard or customary+means of facilitating copying of software.  This Corresponding Source+shall include the Corresponding Source for any work covered by version 3+of the GNU General Public License that is incorporated pursuant to the+following paragraph.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the work with which it is combined will remain governed by version+3 of the GNU General Public License.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU Affero General Public License from time to time.  Such new versions+will be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU Affero General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU Affero General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU Affero General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU Affero General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU Affero General Public License for more details.++    You should have received a copy of the GNU Affero General Public License+    along with this program.  If not, see <https://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If your software can interact with users remotely through a computer+network, you should also make sure that it provides a way for users to+get its source.  For example, if your program is a web application, its+interface could display a "Source" link that leads users to an archive+of the code.  There are many ways you could offer source, and different+solutions will be better for different programs; see section 13 for the+specific requirements.++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU AGPL, see+<https://www.gnu.org/licenses/>.+
+ README.md view
@@ -0,0 +1,12 @@+# Morley Lorentz EDSL++Lorentz is a powerful meta-programming tool which allows one to write Michelson contracts directly in Haskell.++Haskell's type checker and automatic type inference facilitate contracts implementation and reduce boilerplate related to types.+Adoption of Algebraic Data Types makes work with complex objects safe and convenient.+Later Lorentz contract can be dumped as a plain textual Michelson contract using functions from [`Michelson.Printer`](/src/Michelson/Printer.hs).++You can find Lorentz instructions in [`Lorentz`](src/Lorentz.hs) modules.++Examples of using Lorentz eDSL reside in the [`morley-ledgers`](/morley-ledgers) package.+For more information, refer to that package's [README](/morley-ledgers/README.md).
+ lorentz.cabal view
@@ -0,0 +1,181 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.32.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 7990f612989602be8cc01109be8cbf14f3b33c3346292f6f58d3c293094c3f8d++name:           lorentz+version:        0.1.0+synopsis:       EDSL for the Michelson Language+description:    Lorentz is a powerful meta-programming tool which allows one to write Michelson contracts directly in Haskell. It has the same instructions as Michelson, but operates on Haskell values and allows one to use Haskell features.+category:       Language+homepage:       https://gitlab.com/morley-framework/morley+bug-reports:    https://gitlab.com/morley-framework/morley/issues+author:         camlCase, Serokell, Tocqueville Group+maintainer:     Serokell <hi@serokell.io>+copyright:      2019-2020 Tocqueville Group+license:        AGPL-3.0-or-later+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    CHANGES.md+    README.md++source-repository head+  type: git+  location: git@gitlab.com:morley-framework/morley.git++library+  exposed-modules:+      Lorentz+      Lorentz.ADT+      Lorentz.Arith+      Lorentz.Base+      Lorentz.Coercions+      Lorentz.Common+      Lorentz.Constraints+      Lorentz.Constraints.Derivative+      Lorentz.Constraints.Scopes+      Lorentz.ContractRegistry+      Lorentz.Doc+      Lorentz.Empty+      Lorentz.EntryPoints+      Lorentz.EntryPoints.Core+      Lorentz.EntryPoints.Doc+      Lorentz.EntryPoints.Helpers+      Lorentz.EntryPoints.Impl+      Lorentz.EntryPoints.Manual+      Lorentz.Errors+      Lorentz.Errors.Common+      Lorentz.Errors.Numeric+      Lorentz.Ext+      Lorentz.Extensible+      Lorentz.Instr+      Lorentz.Macro+      Lorentz.Pack+      Lorentz.Polymorphic+      Lorentz.Prelude+      Lorentz.Print+      Lorentz.Rebinded+      Lorentz.Referenced+      Lorentz.Run+      Lorentz.Store+      Lorentz.StoreClass+      Lorentz.Test+      Lorentz.Test.Consumer+      Lorentz.Test.Doc+      Lorentz.Test.Import+      Lorentz.Test.Integrational+      Lorentz.Test.Unit+      Lorentz.TestScenario+      Lorentz.TypeAnns+      Lorentz.UParam+      Lorentz.UStore+      Lorentz.UStore.Common+      Lorentz.UStore.Haskell+      Lorentz.UStore.Instances+      Lorentz.UStore.Instr+      Lorentz.UStore.Lift+      Lorentz.UStore.Migration+      Lorentz.UStore.Migration.Base+      Lorentz.UStore.Migration.Batching+      Lorentz.UStore.Migration.Blocks+      Lorentz.UStore.Migration.Diff+      Lorentz.UStore.Types+      Lorentz.Value+      Lorentz.Zip+  hs-source-dirs:+      src+  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -O0+  build-depends:+      HUnit+    , QuickCheck+    , base-noprelude >=4.7 && <5+    , bimap+    , bytestring+    , constraints >=0.11+    , containers+    , data-default+    , first-class-families >=0.5.0.0+    , fmt+    , formatting+    , ghc-prim+    , hspec+    , interpolate+    , lens+    , morley+    , morley-prelude >=0.3.0+    , named+    , optparse-applicative+    , pretty-terminal+    , singletons+    , tasty+    , template-haskell+    , text+    , unordered-containers+    , vinyl+  default-language: Haskell2010++test-suite lorentz-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Test.Doc+      Test.DocTest+      Test.Lorentz.Base+      Test.Lorentz.Conditionals+      Test.Lorentz.DeadCode+      Test.Lorentz.EntryPoints+      Test.Lorentz.Errors+      Test.Lorentz.Extensible+      Test.Lorentz.Macro+      Test.Lorentz.Pack+      Test.Lorentz.Print+      Test.Lorentz.UParam+      Test.Lorentz.UStore.Behaviour+      Test.Lorentz.UStore.Migration.Batched+      Test.Lorentz.UStore.Migration.Batched.V1+      Test.Lorentz.UStore.Migration.Batched.V2+      Test.Lorentz.UStore.Migration.FillInParts+      Test.Lorentz.UStore.Migration.Simple+      Test.Lorentz.UStore.Migration.Simple.V1+      Test.Lorentz.UStore.Migration.Simple.V2+      Test.Lorentz.UStore.SafeLift+      Test.Lorentz.UStore.SafeLift.Helpers+      Test.Tasty.TypeSpec+      Test.Util.TypeSpec+      Tree+  hs-source-dirs:+      test+  default-extensions: ApplicativeDo AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances ViewPatterns DerivingStrategies+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -O0 -threaded -with-rtsopts=-N+  build-tool-depends:+      tasty-discover:tasty-discover+  build-depends:+      HUnit+    , QuickCheck+    , base-noprelude >=4.7 && <5+    , bimap+    , bytestring+    , constraints+    , containers+    , data-default+    , first-class-families+    , fmt+    , formatting+    , lorentz+    , morley+    , morley-prelude+    , singletons+    , spoon+    , tasty+    , tasty-hunit-compat+    , tasty-quickcheck+    , text+    , type-spec+    , unordered-containers+    , vinyl+  default-language: Haskell2010
+ src/Lorentz.hs view
@@ -0,0 +1,33 @@+module Lorentz+  ( module Exports+  ) where++import Lorentz.ADT as Exports+import Lorentz.Arith as Exports+import Lorentz.Base as Exports+import Lorentz.Coercions as Exports+import Lorentz.Common as Exports+import Lorentz.Constraints as Exports+import Lorentz.Doc as Exports+import Lorentz.Empty as Exports+import Lorentz.EntryPoints as Exports+import Lorentz.EntryPoints.Doc as Exports+import Lorentz.Errors as Exports+import Lorentz.Errors.Common as Exports ()+import Lorentz.Errors.Numeric as Exports+import Lorentz.Ext as Exports+import Lorentz.Instr as Exports+import Lorentz.Macro as Exports+import Lorentz.Pack as Exports+import Lorentz.Polymorphic as Exports+import Lorentz.Prelude as Exports+import Lorentz.Print as Exports+import Lorentz.Rebinded as Exports+import Lorentz.Referenced as Exports+import Lorentz.Run as Exports+import Lorentz.StoreClass as Exports+import Lorentz.TypeAnns as Exports+import Lorentz.UParam as Exports+import Lorentz.UStore as Exports+import Lorentz.Value as Exports+import Lorentz.Zip as Exports ()
+ src/Lorentz/ADT.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE FunctionalDependencies #-}++module Lorentz.ADT+  ( HasField+  , HasFieldOfType+  , HasFieldsOfType+  , NamedField (..)+  , (:=)+  , toField+  , toFieldNamed+  , getField+  , getFieldNamed+  , setField+  , modifyField+  , construct+  , constructT+  , fieldCtor+  , wrap_+  , case_+  , caseT+  , unwrapUnsafe_+  , CaseTC+  , CaseArrow (..)+  , CaseClauseL (..)+  , InstrConstructC+  , ConstructorFieldTypes++    -- * Useful re-exports+  , Rec (..)+  , (:!)+  , (:?)+  , arg+  , argDef+  , argF+  ) where++import Data.Constraint (Dict(..))+import qualified Data.Kind as Kind+import Data.Vinyl.Core (RMap(..), Rec(..))+import Data.Vinyl.Derived (Label)+import GHC.TypeLits (AppendSymbol, Symbol)+import Named ((:!), (:?), arg, argDef, argF)++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Instr+import Michelson.Typed.Haskell.Instr+import Michelson.Typed.Haskell.Value+import Util.TypeTuple++-- | Allows field access and modification.+type HasField dt fname =+  ( InstrGetFieldC dt fname+  , InstrSetFieldC dt fname+  )++-- | Like 'HasField', but allows constrainting field type.+type HasFieldOfType dt fname fieldTy =+  ( HasField dt fname+  , GetFieldType dt fname ~ fieldTy+  )++-- | A pair of field name and type.+data NamedField = NamedField Symbol Kind.Type+type n := ty = 'NamedField n ty+infixr 0 :=++-- | Shortcut for multiple 'HasFieldOfType' constraints.+type family HasFieldsOfType (dt :: Kind.Type) (fs :: [NamedField])+             :: Constraint where+  HasFieldsOfType _ '[] = ()+  HasFieldsOfType dt ((n := ty) ': fs) =+    (HasFieldOfType dt n ty, HasFieldsOfType dt fs)++-- | Extract a field of a datatype replacing the value of this+-- datatype with the extracted field.+--+-- For this and the following functions you have to specify field name+-- which is either record name or name attached with @(:!)@ operator.+toField+  :: forall dt name st.+     InstrGetFieldC dt name+  => Label name -> dt & st :-> GetFieldType dt name & st+toField = I . instrGetField @dt++-- | Like 'toField', but leaves field named.+toFieldNamed+  :: forall dt name st.+     InstrGetFieldC dt name+  => Label name -> dt & st :-> (name :! GetFieldType dt name) & st+toFieldNamed l = toField l # forcedCoerce_++-- | Extract a field of a datatype, leaving the original datatype on stack.+getField+  :: forall dt name st.+     InstrGetFieldC dt name+  => Label name -> dt & st :-> GetFieldType dt name & dt ': st+getField l = dup # toField @dt l++-- | Like 'getField', but leaves field named.+getFieldNamed+  :: forall dt name st.+     InstrGetFieldC dt name+  => Label name -> dt & st :-> (name :! GetFieldType dt name) & dt ': st+getFieldNamed l = getField l # coerceWrap++-- | Set a field of a datatype.+setField+  :: forall dt name st.+     InstrSetFieldC dt name+  => Label name -> (GetFieldType dt name ': dt ': st) :-> (dt ': st)+setField = I . instrSetField @dt++-- | Apply given modifier to a datatype field.+modifyField+  :: forall dt name st.+     ( InstrGetFieldC dt name+     , InstrSetFieldC dt name+     )+  => Label name+  -> (forall st0. (GetFieldType dt name ': st0) :-> (GetFieldType dt name ': st0))+  -> dt & st :-> dt & st+modifyField l i = getField @dt l # i # setField @dt l++-- | Make up a datatype. You provide a pack of individual fields constructors.+--+-- Each element of the accepted record should be an instruction wrapped with+-- 'fieldCtor' function. This instruction will have access to the stack at+-- the moment of calling @construct@.+-- Instructions have to output fields of the built datatype, one per instruction;+-- instructions order is expected to correspond to the order of fields in the+-- datatype.+construct+  :: forall dt st.+     ( InstrConstructC dt+     , RMap (ConstructorFieldTypes dt)+     )+  => Rec (FieldConstructor st) (ConstructorFieldTypes dt)+  -> st :-> dt & st+construct fctors =+  I $ instrConstruct @dt $+  rmap (\(FieldConstructor i) -> FieldConstructor i) fctors++-- | Version of 'construct' which accepts tuple of field constructors.+constructT+  :: forall dt fctors st.+     ( InstrConstructC dt+     , RMap (ConstructorFieldTypes dt)+     , fctors ~ Rec (FieldConstructor st) (ConstructorFieldTypes dt)+     , RecFromTuple fctors+     )+  => IsoRecTuple fctors+  -> st :-> dt & st+constructT = construct . recFromTuple++-- | Lift an instruction to field constructor.+fieldCtor :: HasCallStack => (st :-> f & st) -> FieldConstructor st f+fieldCtor = \case+  I i -> FieldConstructor i+  FI _ -> error "Field constructor always fails"++-- | Wrap entry in constructor. Useful for sum types.+wrap_+  :: forall dt name st.+     InstrWrapC dt name+  => Label name -> (AppendCtorField (GetCtorField dt name) st) :-> dt & st+wrap_ =+  case appendCtorFieldAxiom @(GetCtorField dt name) @st of+    Dict -> I . instrWrap @dt++-- | Lorentz analogy of 'CaseClause', it works on plain 'Kind.Type' types.+data CaseClauseL (inp :: [Kind.Type]) (out :: [Kind.Type]) (param :: CaseClauseParam) where+  CaseClauseL :: AppendCtorField x inp :-> out -> CaseClauseL inp out ('CaseClauseParam ctor x)++-- | Provides "case" arrow which works on different wrappers for clauses.+class CaseArrow name body clause | clause -> name, clause -> body where+  -- | Lift an instruction to case clause.+  --+  -- You should write out constructor name corresponding to the clause+  -- explicitly. Prefix constructor name with "c" letter, otherwise+  -- your label will not be recognized by Haskell parser.+  -- Passing constructor name can be circumvented but doing so is not recomended+  -- as mentioning contructor name improves readability and allows avoiding+  -- some mistakes.+  (/->) :: Label name -> body -> clause+  infixr 0 /->++instance ( name ~ ("c" `AppendSymbol` ctor)+         , body ~ (AppendCtorField x inp :-> out)+         ) => CaseArrow name body+                (CaseClauseL inp out ('CaseClauseParam ctor x)) where+  (/->) _ = CaseClauseL++-- | Pattern match on the given sum type.+--+-- You have to provide a 'Rec' containing case branches.+-- To construct a case branch use '/->' operator.+case_+  :: forall dt out inp.+     ( InstrCaseC dt inp out+     , RMap (CaseClauses dt)+     )+  => Rec (CaseClauseL inp out) (CaseClauses dt) -> dt & inp :-> out+case_ = LorentzInstr . instrCase @dt . rmap coerceCaseClause+  where+    coerceCaseClause+      :: forall clauses.+         CaseClauseL inp out clauses -> CaseClause (ToTs inp) (ToTs out) clauses+    coerceCaseClause (CaseClauseL (LorentzInstr cc)) =+      CaseClause $ case Proxy @clauses of+        (_ :: Proxy ('CaseClauseParam ctor cc)) ->+          case appendCtorFieldAxiom @cc @inp of Dict -> cc++-- | Like 'case_', accepts a tuple of clauses, which may be more convenient.+--+-- If user is experiencing problems with wierd errors about tuples while using+-- this function, he should take look at `Util.TypeTuple.Instances` and ensure+-- that his tuple isn't bigger than generated instances, if so, he should probably+-- extend number of generated instances.+caseT+  :: forall dt out inp clauses.+     CaseTC dt out inp clauses+  => IsoRecTuple clauses -> dt & inp :-> out+caseT = case_ @dt . recFromTuple++type CaseTC dt out inp clauses =+  ( InstrCaseC dt inp out+  , RMap (CaseClauses dt)+  , RecFromTuple clauses+  , clauses ~ Rec (CaseClauseL inp out) (CaseClauses dt)+  )++-- | Wrap entry in constructor. Useful for sum types.+unwrapUnsafe_+  :: forall dt name st.+     InstrUnwrapC dt name+  => Label name -> dt & st :-> (CtorOnlyField name dt ': st)+unwrapUnsafe_ =+  case appendCtorFieldAxiom @(GetCtorField dt name) @st of+    Dict -> I . instrUnwrapUnsafe @dt
+ src/Lorentz/Arith.hs view
@@ -0,0 +1,127 @@+-- | Type families from 'Michelson.Typed.Arith' lifted to Haskell types.+module Lorentz.Arith+  ( ArithOpHs (..)+  , UnaryArithOpHs (..)+  ) where++import qualified Data.Kind as Kind++import Lorentz.Value+import Michelson.Typed.Arith+import Michelson.Typed.Haskell.Value+import Michelson.Typed.T++-- | Lifted 'AithOp'.+class ( ArithOp aop (ToCT n) (ToCT m)+      , IsComparable n, IsComparable m+      , Typeable (ToCT n), Typeable (ToCT m)+      , ToT (ArithResHs aop n m) ~ 'Tc (ArithRes aop (ToCT n) (ToCT m))+      ) => ArithOpHs (aop :: Kind.Type) (n :: Kind.Type) (m :: Kind.Type) where+  type ArithResHs aop n m :: Kind.Type++-- | Lifted 'UnaryAithOp'.+class ( UnaryArithOp aop (ToCT n)+      , IsComparable n+      , Typeable (ToCT n)+      , ToT (UnaryArithResHs aop n) ~ 'Tc (UnaryArithRes aop (ToCT n))+      ) => UnaryArithOpHs (aop :: Kind.Type) (n :: Kind.Type) where+  type UnaryArithResHs aop n :: Kind.Type++instance ArithOpHs Add Natural Integer where+  type ArithResHs Add Natural Integer = Integer+instance ArithOpHs Add Integer Natural where+  type ArithResHs Add Integer Natural = Integer+instance ArithOpHs Add Natural Natural where+  type ArithResHs Add Natural Natural = Natural+instance ArithOpHs Add Integer Integer where+  type ArithResHs Add Integer Integer = Integer+instance ArithOpHs Add Timestamp Integer where+  type ArithResHs Add Timestamp Integer = Timestamp+instance ArithOpHs Add Integer Timestamp where+  type ArithResHs Add Integer Timestamp = Timestamp+instance ArithOpHs Add Mutez Mutez where+  type ArithResHs Add Mutez Mutez = Mutez++instance ArithOpHs Sub Natural Integer where+  type ArithResHs Sub Natural Integer = Integer+instance ArithOpHs Sub Integer Natural where+  type ArithResHs Sub Integer Natural = Integer+instance ArithOpHs Sub Natural Natural where+  type ArithResHs Sub Natural Natural = Integer+instance ArithOpHs Sub Integer Integer where+  type ArithResHs Sub Integer Integer = Integer+instance ArithOpHs Sub Timestamp Integer where+  type ArithResHs Sub Timestamp Integer = Timestamp+instance ArithOpHs Sub Timestamp Timestamp where+  type ArithResHs Sub Timestamp Timestamp = Integer+instance ArithOpHs Sub Mutez Mutez where+  type ArithResHs Sub Mutez Mutez = Mutez++instance ArithOpHs Mul Natural Integer where+  type ArithResHs Mul Natural Integer = Integer+instance ArithOpHs Mul Integer Natural where+  type ArithResHs Mul Integer Natural = Integer+instance ArithOpHs Mul Natural Natural where+  type ArithResHs Mul Natural Natural = Natural+instance ArithOpHs Mul Integer Integer where+  type ArithResHs Mul Integer Integer = Integer+instance ArithOpHs Mul Natural Mutez where+  type ArithResHs Mul Natural Mutez = Mutez+instance ArithOpHs Mul Mutez Natural where+  type ArithResHs Mul Mutez Natural = Mutez++instance UnaryArithOpHs Abs Integer where+  type UnaryArithResHs Abs Integer = Natural++instance UnaryArithOpHs Neg Integer where+  type UnaryArithResHs Neg Integer = Integer+instance UnaryArithOpHs Neg Natural where+  type UnaryArithResHs Neg Natural = Integer++instance ArithOpHs Or Natural Natural where+  type ArithResHs Or Natural Natural = Natural+instance ArithOpHs Or Bool Bool where+  type ArithResHs Or Bool Bool = Bool++instance ArithOpHs And Integer Natural where+  type ArithResHs And Integer Natural = Integer+instance ArithOpHs And Natural Natural where+  type ArithResHs And Natural Natural = Natural+instance ArithOpHs And Bool Bool where+  type ArithResHs And Bool Bool = Bool++instance ArithOpHs Xor Natural Natural where+  type ArithResHs Xor Natural Natural = Natural+instance ArithOpHs Xor Bool Bool where+  type ArithResHs Xor Bool Bool = Bool++instance ArithOpHs Lsl Natural Natural where+  type ArithResHs Lsl Natural Natural = Natural++instance ArithOpHs Lsr Natural Natural where+  type ArithResHs Lsr Natural Natural = Natural++instance UnaryArithOpHs Not Integer where+  type UnaryArithResHs Not Integer = Integer+instance UnaryArithOpHs Not Natural where+  type UnaryArithResHs Not Natural = Integer+instance UnaryArithOpHs Not Bool where+  type UnaryArithResHs Not Bool = Bool++instance UnaryArithOpHs Eq' Integer where+  type UnaryArithResHs Eq' Integer = Bool++instance UnaryArithOpHs Neq Integer where+  type UnaryArithResHs Neq Integer = Bool++instance UnaryArithOpHs Lt Integer where+  type UnaryArithResHs Lt Integer = Bool++instance UnaryArithOpHs Gt Integer where+  type UnaryArithResHs Gt Integer = Bool++instance UnaryArithOpHs Le Integer where+  type UnaryArithResHs Le Integer = Bool++instance UnaryArithOpHs Ge Integer where+  type UnaryArithResHs Ge Integer = Bool
+ src/Lorentz/Base.hs view
@@ -0,0 +1,193 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Foundation of Lorentz development.+module Lorentz.Base+  ( (:->) (..)+  , type (%>)+  , type (&)+  , (#)+  , (##)+  , pattern I+  , pattern FI+  , iGenericIf+  , iAnyCode+  , iNonFailingCode+  , iMapAnyCode+  , iForceNotFail+  , iWithVarAnnotations++  , parseLorentzValue+  , transformStringsLorentz+  , transformBytesLorentz+  , optimizeLorentz+  , optimizeLorentzWithConf++  , ContractOut+  , Contract+  , SomeContract (..)+  , Lambda+  ) where++import Data.Default (def)+import qualified Data.Kind as Kind+import qualified Data.List.NonEmpty as NE (fromList)+import Data.Singletons (SingI(..))+import Fmt (Buildable(..))++import Lorentz.Constraints+import Lorentz.Value+import Michelson.ErrorPos (InstrCallStack)+import Michelson.Optimizer (OptimizerConf, optimizeWithConf)+import Michelson.Parser (ParserException, parseExpandValue)+import Michelson.Preprocess (transformBytes, transformStrings)+import Michelson.TypeCheck (TCError, runTypeCheckIsolated, typeVerifyValue)+import Michelson.Typed+  (Instr(..), RemFail(..), ToT, ToTs, Value, rfAnyInstr, rfMapAnyInstr, rfMerge)+import qualified Michelson.Untyped as U++-- | Alias for instruction which hides inner types representation via 'T'.+newtype (inp :: [Kind.Type]) :-> (out :: [Kind.Type]) = LorentzInstr+  { unLorentzInstr :: RemFail Instr (ToTs inp) (ToTs out)+  } deriving newtype (Show, Eq)+infixr 1 :->++instance Semigroup (s :-> s) where+  (<>) = (#)+instance Monoid (s :-> s) where+  mempty = I Nop++pattern I :: Instr (ToTs inp) (ToTs out) -> inp :-> out+pattern I i = LorentzInstr (RfNormal i)++pattern FI :: (forall out'. Instr (ToTs inp) out') -> inp :-> out+pattern FI i = LorentzInstr (RfAlwaysFails i)++{-# COMPLETE I, FI #-}++iGenericIf+  :: (forall s'. Instr (ToTs a) s' -> Instr (ToTs b) s' -> Instr (ToTs c) s')+  -> (a :-> s) -> (b :-> s) -> (c :-> s)+iGenericIf merger (LorentzInstr instr1) (LorentzInstr instr2) =+  LorentzInstr (rfMerge merger instr1 instr2)++iAnyCode :: inp :-> out -> Instr (ToTs inp) (ToTs out)+iAnyCode = rfAnyInstr . unLorentzInstr++iNonFailingCode :: HasCallStack => inp :-> out -> Instr (ToTs inp) (ToTs out)+iNonFailingCode (I i) = i+iNonFailingCode (FI _) = error "Always failing code cannot appear here"++iMapAnyCode+  :: (forall o'. Instr (ToTs i1) o' -> Instr (ToTs i2) o')+  -> (i1 :-> o)+  -> (i2 :-> o)+iMapAnyCode f (LorentzInstr i) = LorentzInstr $ rfMapAnyInstr f i++iForceNotFail :: (i :-> o) -> (i :-> o)+iForceNotFail = I . iAnyCode++-- | Wrap Lorentz instruction with variable annotations, @annots@ list has to be+-- non-empty, otherwise this function raises an error.+iWithVarAnnotations :: HasCallStack => [Text] -> inp :-> out -> inp :-> out+iWithVarAnnotations annots (LorentzInstr i) = case i of+  RfNormal instr -> LorentzInstr $ RfNormal $+    InstrWithVarNotes (NE.fromList $ map U.AnnotationUnsafe annots) instr+  RfAlwaysFails instr -> LorentzInstr $ RfAlwaysFails $+    InstrWithVarNotes (NE.fromList $ map U.AnnotationUnsafe annots) instr++-- There is also @instance IsoValue (i :-> o)@ in a separate module.++-- | Alias for ':->', seems to make signatures more readable sometimes.+--+-- Let's someday decide which one of these two should remain.+type (%>) = (:->)+infixr 1 %>++type ContractOut st = '[([Operation], st)]+type Contract cp st = '[(cp, st)] :-> ContractOut st++data SomeContract where+  SomeContract+    :: (NiceParameterFull cp, NiceStorage st)+    => Contract cp st+    -> SomeContract++type (&) (a :: Kind.Type) (b :: [Kind.Type]) = a ': b+infixr 2 &++(#) :: (a :-> b) -> (b :-> c) -> a :-> c+I l # I r = I (l `Seq` r)+I l # FI r = FI (l `Seq` r)+FI l # _ = FI l+infixl 8 #++-- | Version of '#' which performs some optimizations immediately.+(##) :: (a :-> b) -> (b :-> c) -> (a :-> c)+l ## r = case (l, r) of+  (I Nop, I x) -> I x+  (I x, I Nop) -> I x+  _ -> l # r+++type Lambda i o = '[i] :-> '[o]++-- | Errors that can happen during parsing into a Lorentz value.+data ParseLorentzError+  = ParseLorentzParseError ParserException+  | ParseLorentzTypecheckError TCError+  deriving stock (Show, Eq)++instance Buildable ParseLorentzError where+  build =+    \case+      ParseLorentzParseError e -> build e+      ParseLorentzTypecheckError e -> build e++-- | Parse textual representation of a Michelson value and turn it+-- into corresponding Haskell value.+--+-- Note: it won't work in some complex cases, e. g. if there is a+-- lambda which uses an instruction which depends on current+-- contract's type. Obviously it can not work, because we don't have+-- any information about a contract to which this value belongs (there+-- is no such contract at all).+parseLorentzValue ::+     forall v. (IsoValue v, SingI (ToT v), Typeable (ToT v))+  => Text+  -> Either ParseLorentzError v+parseLorentzValue =+  fmap fromVal . (toTyped <=< first ParseLorentzParseError . parseExpandValue)+  where+    toTyped :: U.Value -> Either ParseLorentzError (Value (ToT v))+    toTyped =+      first ParseLorentzTypecheckError .+      runTypeCheckIsolated .+      usingReaderT (def @InstrCallStack) .+      typeVerifyValue++-- | Lorentz version of 'transformStrings'.+transformStringsLorentz ::+  Bool -> (MText -> MText) -> inp :-> out -> inp :-> out+transformStringsLorentz goToValues f =+  iMapAnyCode $ transformStrings goToValues f++-- | Lorentz version of 'transformBytes'.+transformBytesLorentz ::+  Bool -> (ByteString -> ByteString) -> inp :-> out -> inp :-> out+transformBytesLorentz goToValues f =+  iMapAnyCode $ transformBytes goToValues f++optimizeLorentzWithConf+  :: OptimizerConf+  -> inp :-> out+  -> inp :-> out+optimizeLorentzWithConf conf =+  -- Optimizer can produce dead code.+  -- Example: @push True # if_ failWith nop # ...@ will fold to @failWith # ...@.+  -- But let's not care about this case for now until need in it fires.+  iMapAnyCode (optimizeWithConf conf)++optimizeLorentz+  :: inp :-> out+  -> inp :-> out+optimizeLorentz = optimizeLorentzWithConf def
+ src/Lorentz/Coercions.hs view
@@ -0,0 +1,196 @@+-- | Identity transformations between different Haskell types.+module Lorentz.Coercions+  ( -- * Safe coercions+    CanCastTo (..)+  , checkedCoerce+  , Coercible_+  , checkedCoerce_+  , checkedCoercing_+  , allowCheckedCoerceTo+  , allowCheckedCoerce+  , coerceUnwrap+  , coerceWrap+  , toNamed+  , fromNamed++    -- * Unsafe coercions+  , MichelsonCoercible+  , forcedCoerce+  , forcedCoerce_+  , gForcedCoerce_+  , fakeCoerce+  , fakeCoercing++    -- * Re-exports+  , Wrapped (..)+  ) where++import Control.Lens (Wrapped(..))+import qualified Data.Coerce as Coerce+import Data.Constraint (Dict(..), (\\))+import Data.Vinyl.Derived (Label)+import Named (NamedF)+import Unsafe.Coerce (unsafeCoerce)++import Lorentz.Base+import Lorentz.Instr+import Lorentz.Value+import Michelson.Typed++----------------------------------------------------------------------------+-- Unsafe coercions+----------------------------------------------------------------------------++-- | Coercion for Haskell world.+--+-- We discourage using this function on Lorentz types, consider using 'coerce'+-- instead.+-- One of the reasons forthat is that in Lorentz it's common to declare types as+-- newtypes consisting of existing primitives, and @forcedCoerce@ tends to ignore+-- all phantom type variables of newtypes thus violating their invariants.+forcedCoerce :: Coerce.Coercible a b => a -> b+forcedCoerce = Coerce.coerce++-- | Whether two types have the same Michelson representation.+type MichelsonCoercible a b = ToT a ~ ToT b++-- | Convert between values of types that have the same representation.+--+-- This function is not safe in a sense that this allows breaking invariants of+-- casted type (example: @UStore@) or may stop compile on code changes (example:+-- coercion of pair to a datatype with two fields will break if new field is+-- added).+-- Still, produced Michelson code will always be valid.+--+-- Prefer using one of more specific functions from this module.+forcedCoerce_ :: MichelsonCoercible a b => a & s :-> b & s+forcedCoerce_ = I Nop++gForcedCoerce_ :: MichelsonCoercible (t a) (t b) => t a : s :-> t b : s+gForcedCoerce_ = forcedCoerce_++-- | Convert between two stacks via failing.+fakeCoerce :: s1 :-> s2+fakeCoerce = unit # I FAILWITH++fakeCoercing :: (s1 :-> s2) -> s1' :-> s2'+fakeCoercing i = fakeCoerce # iForceNotFail i # fakeCoerce++----------------------------------------------------------------------------+-- Safe coercions+----------------------------------------------------------------------------++-- | Specialized version of 'coerce_' to wrap into a haskell newtype.+coerceWrap+  :: forall newtyp inner s.+     (inner ~ Unwrapped newtyp, MichelsonCoercible newtyp (Unwrapped newtyp))+  => inner : s :-> newtyp : s+coerceWrap = forcedCoerce_++-- | Specialized version of 'coerce_' to unwrap a haskell newtype.+coerceUnwrap+  :: forall newtyp inner s.+     (inner ~ Unwrapped newtyp, MichelsonCoercible newtyp (Unwrapped newtyp))+  => newtyp : s :-> inner : s+coerceUnwrap = forcedCoerce_++-- | Lift given value to a named value.+toNamed :: Label name -> a : s :-> NamedF Identity a name : s+toNamed _ = coerceWrap++-- | Unpack named value.+fromNamed :: Label name -> NamedF Identity a name : s :-> a : s+fromNamed _ = coerceUnwrap++-- Arbitrary coercions+----------------------------------------------------------------------------++-- | Explicitly allowed coercions.+class a `CanCastTo` b where+  -- | An optional method which helps passing -Wredundant-constraints check.+  castDummy :: ()+  castDummy = ()++-- | Coercion in Haskell world which respects 'CanCastTo'.+checkedCoerce :: forall a b. (CanCastTo a b, Coerce.Coercible a b) => a -> b+checkedCoerce = Coerce.coerce+  where _useCast = castDummy @a @b++-- Incoherent instance are generally evil because arbitrary instance can be+-- picked, but in our case this is exactly what we want: permit cast if+-- /any/ instance matches.+instance {-# INCOHERENT #-} CanCastTo a a where+  castDummy = castDummy @a @a++instance CanCastTo a b => CanCastTo [a] [b] where+  castDummy = castDummy @a @b++instance (CanCastTo a1 a2, CanCastTo b1 b2) =>+         CanCastTo (a1, b1) (a2, b2) where+  castDummy = castDummy @a1 @a2 `seq` castDummy @b1 @b2++instance (CanCastTo i1 i2, CanCastTo o1 o2) =>+         CanCastTo (Lambda i1 o1) (Lambda i2 o2)+  -- That's magic, having default impl for 'castDummy' disables+  -- -Wredundant-constraints automatically++instance CanCastTo a b => CanCastTo (Maybe a) (Maybe b)++-- | Coercion from @a@ to @b@ is permitted and safe.+type Castable_ a b = (MichelsonCoercible a b, CanCastTo a b)++-- | Coercions between @a@ to @b@ are permitted and safe.+type Coercible_ a b = (MichelsonCoercible a b, CanCastTo a b, CanCastTo b a)++-- | Coerce between types which have an explicit permission for that in the+-- face of 'CanCastTo' constraint.+checkedCoerce_ :: forall a b s. (Castable_ a b) => a : s :-> b : s+checkedCoerce_ = forcedCoerce_++-- | Pretends that the top item of the stack was coerced.+checkedCoercing_+  :: forall a b s. (Coercible_ a b)+  => (b ': s :-> b ': s) -> (a ': s :-> a ': s)+checkedCoercing_ f = checkedCoerce_ @a @b # f # checkedCoerce_ @b @a++-- | Locally provide given 'CanCastTo' instance.+allowCheckedCoerceTo :: forall b a. Dict (CanCastTo a b)+allowCheckedCoerceTo =+  unsafeCoerce+    @(Dict $ CanCastTo () ())+    @(Dict $ CanCastTo a b)+    Dict++-- | Locally provide bidirectional 'CanCastTo' instance.+allowCheckedCoerce :: forall a b. Dict (CanCastTo a b, CanCastTo b a)+allowCheckedCoerce =+  Dict \\ allowCheckedCoerceTo @a @b \\ allowCheckedCoerceTo @b @a++{- Note about potential use of 'Coercible'.++Alternative to 'CanCastTo' would be using 'Coercible' constraint.++Pros:+* Reflexivity, symmetry and transitivity properties hold automatically.+* Complex structures are handled automatically.++Cons:+* When declaring a datatype type, one should always care to set the corresponding+type role (in most cases it will nominal or representational). Newtypes are+even more difficult to control as they are always coercible if constructor is+in scope.+* Where are some cases where going with 'Coercible' does not work, e.g.+allow @MigrationScriptFrom oldStore@ to @MigrationScript oldStore newStore@.++Despite the mentioned cons, described 'coerce_' may be useful someday.++-}++----------------------------------------------------------------------------+-- Coercions for some basic types+----------------------------------------------------------------------------++instance TAddress p `CanCastTo` Address+instance Address `CanCastTo` TAddress p++instance FutureContract p `CanCastTo` EpAddress
+ src/Lorentz/Common.hs view
@@ -0,0 +1,17 @@+-- | Common primitives.+module Lorentz.Common+  ( Entrypoint+  , Entrypoint_+  ) where++import Lorentz.Base++-- | Single entrypoint of a contract.+--+-- Note that we cannot make it return @[[Operation], store]@ because+-- such entrypoint should've been followed by @pair@, and this is not+-- possible if entrypoint implementation ends with 'failWith'.+type Entrypoint param store = '[ param, store ] :-> ContractOut store++-- | Version of 'Entrypoint' which accepts no argument.+type Entrypoint_ store = '[ store ] :-> ContractOut store
+ src/Lorentz/Constraints.hs view
@@ -0,0 +1,6 @@+module Lorentz.Constraints+  ( module Exports+  ) where++import Lorentz.Constraints.Derivative as Exports+import Lorentz.Constraints.Scopes as Exports
+ src/Lorentz/Constraints/Derivative.hs view
@@ -0,0 +1,12 @@+-- | Some derivative constraints.+--+-- They are moved to separate module because they need to lie quite high in+-- modules dependencies graph (unlike "Lorentz.Constraints.Scopes").+module Lorentz.Constraints.Derivative+  ( NiceParameterFull+  ) where++import Lorentz.EntryPoints.Core++-- | Constraint applied to a whole parameter type.+type NiceParameterFull cp = (Typeable cp, ParameterDeclaresEntryPoints cp)
+ src/Lorentz/Constraints/Scopes.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE UndecidableSuperClasses #-}++-- | Scope-related constraints used in Lorentz.+--+-- This contains constraints from 'Michelson.Typed.Scope' modified for use+-- in Lorentz.+module Lorentz.Constraints.Scopes+  ( -- * Grouped constraints+    NiceParameter+  , NiceStorage+  , NiceConstant+  , NicePackedValue+  , NiceUnpackedValue+  , NiceFullPackedValue+  , NicePrintedValue+  , NiceComparable++  , niceParameterEvi+  , niceStorageEvi+  , niceConstantEvi+  , nicePackedValueEvi+  , niceUnpackedValueEvi+  , nicePrintedValueEvi++    -- * Individual constraints (internals)+  , CanHaveBigMap+  , KnownValue+  , KnownCValue+  , NoOperation+  , NoContractType+  , NoBigMap++  , -- * Re-exports+    withDict+  ) where++import Data.Constraint (trans, weaken2)+import Data.Singletons (SingI)++import Michelson.Typed++-- We write these constraints as class + instance, rather than+-- type aliases, in order to allow their partial application.++-- | Gathers constraints, commonly required for values.+class (IsoValue a, Typeable (ToT a), SingI (ToT a)) => KnownValue a+instance (IsoValue a, Typeable (ToT a), SingI (ToT a)) => KnownValue a++class (IsoValue a, Typeable (ToCT a), SingI (ToCT a)) => KnownCValue a+instance (IsoValue a, Typeable (ToCT a), SingI (ToCT a)) => KnownCValue a++-- | Ensure given type does not contain "operation".+class (IsoValue a, ForbidOp (ToT a)) => NoOperation a+instance (IsoValue a, ForbidOp (ToT a)) => NoOperation a++class (IsoValue a, ForbidContract (ToT a)) => NoContractType a+instance (IsoValue a, ForbidContract (ToT a)) => NoContractType a++class (IsoValue a, ForbidBigMap (ToT a)) => NoBigMap a+instance (IsoValue a, ForbidBigMap (ToT a)) => NoBigMap a++class (IsoValue a, HasNoNestedBigMaps (ToT a)) => CanHaveBigMap a+instance (IsoValue a, HasNoNestedBigMaps (ToT a)) => CanHaveBigMap a++-- | Constraint applied to any part of parameter type.+--+-- Note that you don't usually apply this constraint to the whole parameter,+-- consider using 'Lorentz.Constraints.Derivative.NiceParameterFull' in such case.+--+-- Using this type is justified e.g. when calling another contract, there+-- you usually supply an entrypoint argument, not the whole parameter.+type NiceParameter a = (KnownValue a, ProperParameterBetterErrors (ToT a))++type NiceStorage a = (KnownValue a, ProperStorageBetterErrors (ToT a))++type NiceConstant a = (KnownValue a, ProperConstantBetterErrors (ToT a))++type NicePackedValue a = (KnownValue a, ProperPackedValBetterErrors (ToT a))++type NiceUnpackedValue a = (KnownValue a, ProperUnpackedValBetterErrors (ToT a))++type NiceFullPackedValue a = (NicePackedValue a, NiceUnpackedValue a)++type NicePrintedValue a = (KnownValue a, ProperPrintedValBetterErrors (ToT a))++type NiceComparable a = (KnownValue a, ProperComparabilityBetterErrors (ToT a))++niceParameterEvi :: forall a. NiceParameter a :- ParameterScope (ToT a)+niceParameterEvi =+  properParameterEvi @(ToT a) `trans` weaken2++niceStorageEvi :: forall a. NiceStorage a :- StorageScope (ToT a)+niceStorageEvi =+  properStorageEvi @(ToT a) `trans` weaken2++niceConstantEvi :: forall a. NiceConstant a :- ConstantScope (ToT a)+niceConstantEvi =+  properConstantEvi @(ToT a) `trans` weaken2++nicePackedValueEvi :: forall a. NicePackedValue a :- PackedValScope (ToT a)+nicePackedValueEvi =+  properPackedValEvi @(ToT a) `trans` weaken2++niceUnpackedValueEvi :: forall a. NiceUnpackedValue a :- UnpackedValScope (ToT a)+niceUnpackedValueEvi =+  properUnpackedValEvi @(ToT a) `trans` weaken2++nicePrintedValueEvi :: forall a. NicePrintedValue a :- PrintedValScope (ToT a)+nicePrintedValueEvi =+  properPrintedValEvi @(ToT a) `trans` weaken2
+ src/Lorentz/ContractRegistry.hs view
@@ -0,0 +1,109 @@+-- | This module contains various datatypes and functions which are+-- common for contract registry packages (e.g. morley-ledgers and morley-multisig).+module Lorentz.ContractRegistry+  ( ContractInfo (..)+  , ContractRegistry (..)+  , getContract+  , printContractFromRegistryDoc+  , (?::)+  -- Common CLI stuff+  , CmdLnArgs (..)+  , argParser+  ) where++import qualified Data.Map as Map+import qualified Data.Text.Lazy.IO as TL+import Fmt (Buildable(..), blockListF, nameF, (+|), (|+))+import qualified Options.Applicative as Opt++import Lorentz.Base+import Lorentz.Constraints+import Lorentz.Doc+import Util.IO++data ContractInfo =+  forall cp st.+    (NiceParameterFull cp, NiceStorage st) =>+  ContractInfo+  { ciContract :: Contract cp st+  , ciIsDocumented :: Bool+  }++(?::) :: Text -> a -> (Text, a)+(?::) = (,)++newtype ContractRegistry = ContractRegistry+  { unContractRegistry :: Map Text ContractInfo }++getContract :: Text -> ContractRegistry -> Either String ContractInfo+getContract name registry =+  case Map.lookup name (unContractRegistry registry) of+    Nothing ->+      Left $ "No contract with name '" +| name |+ "' found\n" +| registry |+ ""+    Just c -> Right c++instance Buildable ContractRegistry where+  build registry =+    nameF "Available contracts" (blockListF $ keys (unContractRegistry registry))++printContractFromRegistryDoc :: Text -> ContractRegistry -> Maybe FilePath -> IO ()+printContractFromRegistryDoc name contracts mOutput = do+  ContractInfo{..} <- either die pure $ getContract name contracts+  let writeFunc = case mOutput of+        Nothing -> TL.putStrLn+        Just "def" -> writeFileUtf8 $ toString name <> ".md"+        Just output -> writeFileUtf8 output+  if ciIsDocumented+  then writeFunc $ contractDocToMarkdown $ buildLorentzDoc ciContract+  else die "This contract is not documented"++data CmdLnArgs+  = List+  | Print Text (Maybe FilePath) Bool+  | Document Text (Maybe FilePath)++argParser :: Opt.Parser CmdLnArgs+argParser = Opt.subparser $ mconcat+  [ listSubCmd+  , printSubCmd+  , documentSubCmd+  ]+  where+    mkCommandParser commandName parser desc =+      Opt.command commandName $+      Opt.info (Opt.helper <*> parser) $+      Opt.progDesc desc++    listSubCmd =+      mkCommandParser "list"+      (pure List)+      "Show all available contracts"++    printSubCmd =+      mkCommandParser "print"+      (Print <$> printOptions <*> outputOptions <*> onelineOption)+      "Dump a contract in form of Michelson code"++    documentSubCmd =+      mkCommandParser "document"+      (Document <$> printOptions <*> outputOptions)+      "Dump contract documentation in Markdown"++    printOptions = Opt.strOption $ mconcat+      [ Opt.short 'n'+      , Opt.long "name"+      , Opt.metavar "IDENTIFIER"+      , Opt.help "Name of a contract returned by `list` command."+      ]++    outputOptions = optional . Opt.strOption $ mconcat+      [ Opt.short 'o'+      , Opt.long "output"+      , Opt.metavar "FILEPATH"+      , Opt.help "File to use as output. If not specified, stdout is used."+      ]++    onelineOption :: Opt.Parser Bool+    onelineOption = Opt.switch (+      Opt.long "oneline" <>+      Opt.help "Force single line output")
+ src/Lorentz/Doc.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Lorentz.Doc+  ( doc+  , docGroup+  , buildLorentzDoc+  , renderLorentzDoc+  , contractName+  , cutLorentzNonDoc++    -- * Re-exports+  , Markdown+  , DocItem (..)+  , docItemPosition+  , DocItemId (..)+  , DocItemPlacementKind (..)+  , DocItemRef (..)+  , DocSectionNameStyle (..)+  , SomeDocItem (..)+  , SomeDocDefinitionItem (..)+  , SubDoc (..)+  , DocGrouping+  , ContractDoc (..)+  , DDescription (..)+  , DGitRevision (..)+  , GitRepoSettings (..)+  , mkDGitRevision+  , morleyRepoSettings+  , DComment (..)+  , DType (..)+  , docDefinitionRef+  , contractDocToMarkdown+  , subDocToMarkdown++  , TypeHasDoc (..)+  , SomeTypeWithDoc (..)++  , HaveCommonTypeCtor+  , IsHomomorphic+  , genericTypeDocDependencies+  , customTypeDocMdReference+  , homomorphicTypeDocMdReference+  , poly1TypeDocMdReference+  , poly2TypeDocMdReference+  , homomorphicTypeDocHaskellRep+  , concreteTypeDocHaskellRep+  , concreteTypeDocHaskellRepUnsafe+  , haskellRepNoFields+  , haskellRepStripFieldPrefix+  , homomorphicTypeDocMichelsonRep+  , concreteTypeDocMichelsonRep+  , concreteTypeDocMichelsonRepUnsafe+  ) where++import Data.Singletons (demote)++import Lorentz.Base+import Lorentz.Value+import Lorentz.Zip ()+import Michelson.Doc+import Michelson.Optimizer+import Michelson.Typed+import Util.Markdown+import Util.Type++-- | Put a document item.+doc :: DocItem di => di -> s :-> s+doc = I . Ext . DOC_ITEM . SomeDocItem++-- | Group documentation built in the given piece of code+-- into block dedicated to one thing, e.g. to one entrypoint.+docGroup :: DocGrouping -> (inp :-> out) -> (inp :-> out)+docGroup gr = iMapAnyCode (DocGroup gr)++-- | Give a name to given contract. Apply it to the whole contract code.+contractName :: Text -> (inp :-> out) -> (inp :-> out)+contractName name = docGroup (SomeDocItem . DName name)++buildLorentzDoc :: inp :-> out -> ContractDoc+buildLorentzDoc (iAnyCode -> code) = buildInstrDoc code++renderLorentzDoc :: inp :-> out -> LText+renderLorentzDoc = contractDocToMarkdown . buildLorentzDoc++-- | Leave only instructions related to documentation.+--+-- This function is useful when your method executes a lambda coming from outside,+-- but you know its properties and want to propagate its documentation to your+-- contract code.+cutLorentzNonDoc :: (inp :-> out) -> (s :-> s)+cutLorentzNonDoc (iAnyCode -> code) = I $ cutInstrNonDoc optimize code++instance Each [Typeable, ReifyList TypeHasDoc] [i, o] =>+         TypeHasDoc (i :-> o) where+  typeDocName _ = "Code (extended lambda)"+  typeDocMdReference tp wp =+    let DocItemRef (DocItemId ctorDocItemId) = docItemRef (DType tp)+        refToThis = mdLocalRef (mdTicked "Code") ctorDocItemId+    in applyWithinParens wp $+      mconcat $ intersperse " " [refToThis, refToStack @i, refToStack @o]+    where+    refToStack :: forall s. ReifyList TypeHasDoc s => Markdown+    refToStack =+      let stack = reifyList @_ @TypeHasDoc @s (\p -> typeDocMdReference p (WithinParens False))+      in mconcat+          [ mdBold "["+          , case stack of+              [] -> " "+              st -> mconcat $ intersperse (mdBold "," <> " ") st+          , mdBold "]"+          ]++  typeDocMdDescription =+    "`Code i o` stands for a sequence of instructions which accepts stack \+    \of type `i` and returns stack of type `o`.\n\n\+    \When both `i` and `o` are of length 1, this primitive corresponds to \+    \the Michelson lambda. In more complex cases code is surrounded with `pair`\+    \and `unpair` instructions until fits into mentioned restriction.\+    \"+  typeDocDependencies _ = mconcat+    [ reifyList @_ @TypeHasDoc @i SomeTypeWithDoc+    , reifyList @_ @TypeHasDoc @o SomeTypeWithDoc+    , [ SomeTypeWithDoc (Proxy @Integer)+      , SomeTypeWithDoc (Proxy @Natural)+      , SomeTypeWithDoc (Proxy @MText)+      ]+    ]+  typeDocHaskellRep _ = Nothing+  typeDocMichelsonRep _ =+    ( Just "Code [Integer, Natural, MText, ()] [ByteString]"+    , demote @(ToT ([Integer, Natural, MText, ()] :-> '[ByteString]))+    )
+ src/Lorentz/Empty.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Support for uninhabited type.+--+-- Currently they are not supported my Michelson, so we provide+-- a sort of replacement.+--+-- This module should be removed once the proposal is implemented:+-- https://gitlab.com/tezos/tezos/issues/662+module Lorentz.Empty+  ( Empty+  , absurd_+  ) where++import Fmt (Buildable(..))++import Lorentz.Base+import Lorentz.Doc+import Lorentz.Errors+import Lorentz.Value+import Michelson.Typed.Haskell.Doc++-- | Replacement for uninhabited type.+newtype Empty = Empty ()+  deriving stock Generic+  deriving anyclass IsoValue++instance TypeHasDoc Empty where+  typeDocMdDescription =+    "Type which should never be constructed.\n\n\+    \If appears as part of entrypoint argument, this means that the entrypoint \+    \should never be called."++-- | Someone constructed 'Empty' type.+type instance ErrorArg "emptySupplied" = ()++instance Buildable (CustomError "emptySupplied") where+  build (CustomError _ ()) =+    "'Empty' value was passed to the contract."++instance CustomErrorHasDoc "emptySupplied" where+  customErrClass = ErrClassBadArgument+  customErrDocMdCause =+    "Value of type " <> typeDocMdReference (Proxy @Empty) (WithinParens False)+    <> " has been supplied."++-- | Witness of that this code is unreachable.+absurd_ :: Empty : s :-> s'+absurd_ =+  failCustom_ #emptySupplied #+  doc (DDescription "Should never be called")
+ src/Lorentz/EntryPoints.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE UndecidableSuperClasses #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Entrypoints utilities for Lorentz+module Lorentz.EntryPoints+  ( -- * Typeclasses+    EntryPointsDerivation (..)+  , ParameterHasEntryPoints (..)+  , ParameterDeclaresEntryPoints++    -- * Entrypoints API+  , AllParameterEntryPoints+  , LookupParameterEntryPoint+  , parameterEntryPointsToNotes+  , flattenEntryPoints+  , GetEntryPointArg+  , parameterEntryPointCall+  , GetDefaultEntryPointArg+  , parameterEntryPointCallDefault+  , ForbidExplicitDefaultEntryPoint+  , NoExplicitDefaultEntryPoint+  , sepcCallRootChecked+  , EntryPointRef (..)+  , eprName+  , GetEntryPointArgCustom+  , HasEntryPointArg (..)+  , HasDefEntryPointArg+  , TrustEpName (..)+  , parameterEntryPointCallCustom+  , RequireAllUniqueEntryPoints++    -- * Implementations+  , EpdNone+  , EpdPlain+  , EpdRecursive+  , EpdDelegate++    -- * Behaviour modifiers+  , ParameterWrapper (..)+  , ShouldHaveEntryPoints (..)+  ) where++import Lorentz.EntryPoints.Core+import Lorentz.EntryPoints.Helpers+import Lorentz.EntryPoints.Impl+import Lorentz.EntryPoints.Manual
+ src/Lorentz/EntryPoints/Core.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE UndecidableSuperClasses #-}++-- | Primitives supplying entrypoints declarations and lookup.+module Lorentz.EntryPoints.Core+  ( CanHaveEntryPoints+  , EntryPointsDerivation (..)+  , EpConstructionRes (..)+  , RequireAllUniqueEntryPoints+  , ParameterHasEntryPoints (..)+  , ParameterDeclaresEntryPoints+  , GetParameterEpDerivation+  , pepNotes+  , pepCall+  , AllParameterEntryPoints+  , LookupParameterEntryPoint+  , parameterEntryPointsToNotes+  , GetEntryPointArg+  , parameterEntryPointCall+  , GetDefaultEntryPointArg+  , parameterEntryPointCallDefault+  , flattenEntryPoints+  , ForbidExplicitDefaultEntryPoint+  , NoExplicitDefaultEntryPoint+  , sepcCallRootChecked+  , EntryPointRef (..)+  , NiceEntryPointName+  , eprName+  , GetEntryPointArgCustom+  , TrustEpName (..)+  , HasEntryPointArg (..)+  , HasDefEntryPointArg+  , parameterEntryPointCallCustom+  , EpdNone++    -- * Internals+  , RequireAllUniqueEntryPoints'+  ) where++import Data.Constraint (Dict(..), (\\))+import qualified Data.Kind as Kind+import Data.Map (Map, insert)+import Data.Singletons (SingI, sing)+import Data.Typeable (typeRep)+import Data.Vinyl.Derived (Label)+import Fcf (Eval, Exp)+import qualified Fcf+import qualified Fcf.Utils as Fcf+import Fmt (pretty)++import Michelson.Typed+import qualified Michelson.Untyped as U+import Util.Type+import Util.TypeLits++import Lorentz.Constraints.Scopes+import Lorentz.EntryPoints.Helpers++-- | Defines a generalized way to declare entrypoints for various parameter types.+--+-- When defining instances of this typeclass, set concrete @deriv@ argument+-- and leave variable @cp@ argument.+-- Also keep in mind, that in presence of explicit default entrypoint, all other+-- 'Or' arms should be callable, though you can put this burden on user if very+-- necessary.+class EntryPointsDerivation deriv cp where+  -- | Name and argument of each entrypoint.+  -- This may include intermediate ones, even root if necessary.+  --+  -- Touching this type family is costly (@O(N^2)@), don't use it often.+  type EpdAllEntryPoints deriv cp :: [(Symbol, Kind.Type)]++  -- | Get entrypoint argument by name.+  type EpdLookupEntryPoint deriv cp :: Symbol -> Exp (Maybe Kind.Type)++  -- | Construct parameter annotations corresponding to expected entrypoints set.+  --+  -- This method is implementation detail, for actual notes construction+  -- use 'parameterEntryPointsToNotes'.+  --+  -- TODO [#35]: Should also return field annotation+  epdNotes :: Notes (ToT cp)++  -- | Construct entrypoint caller.+  --+  -- This does not treat calls to default entrypoint in a special way.+  --+  -- This method is implementation detail, for actual entrypoint lookup+  -- use 'parameterEntryPointCall'.+  epdCall+    :: (KnownSymbol name, ParameterScope (ToT cp))+    => Label name+    -> EpConstructionRes (ToT cp) (Eval (EpdLookupEntryPoint deriv cp name))++type RequireAllUniqueEntryPoints' deriv cp =+  RequireAllUnique+    "entrypoint name"+    (Eval (Fcf.Map Fcf.Fst $ EpdAllEntryPoints deriv cp))++-- | Ensure that all declared entrypoints are unique.+type RequireAllUniqueEntryPoints cp =+  RequireAllUniqueEntryPoints' (ParameterEntryPointsDerivation cp) cp++-- | Result of entrypoint lookup at term level.+data EpConstructionRes (param :: T) (marg :: Maybe Kind.Type) where+  EpConstructed+    :: ParameterScope (ToT arg)+    => EpLiftSequence (ToT arg) param -> EpConstructionRes param ('Just arg)+  EpConstructionFailed+    :: EpConstructionRes param 'Nothing++-- | Which entrypoints given parameter declares.+--+-- Note that usually this function should not be used as constraint, use+-- 'ParameterDeclaresEntryPoints' for this purpose.+class ( EntryPointsDerivation (ParameterEntryPointsDerivation cp) cp+      , RequireAllUniqueEntryPoints cp+      ) =>+      ParameterHasEntryPoints cp where+  type ParameterEntryPointsDerivation cp :: Kind.Type++-- | Parameter declares some entrypoints.+--+-- This is a version of 'ParameterHasEntryPoints' which we actually use in+-- constraints. When given type is a sum type or newtype, we refer to+-- 'ParameterHasEntryPoints' instance, otherwise this instance is not+-- necessary.+type ParameterDeclaresEntryPoints cp =+  ( If (CanHaveEntryPoints cp)+     (ParameterHasEntryPoints cp)+     (() :: Constraint)+  , NiceParameter cp+  , EntryPointsDerivation (GetParameterEpDerivation cp) cp+  )++-- | Version of 'ParameterEntryPointsDerivation' which we actually use in+-- function signatures. When given type is sum type or newtype, we refer to+-- 'ParameterEntryPointsDerivation', otherwise we suppose that no entrypoints+-- are declared.+type GetParameterEpDerivation cp =+  If (CanHaveEntryPoints cp)+     (ParameterEntryPointsDerivation cp)+     EpdNone++-- | Version of 'epdNotes' which we actually use in code.+-- It hides derivations stuff inside, and treats primitive types specially+-- like 'GetParameterEpDerivation' does.+pepNotes :: forall cp. ParameterDeclaresEntryPoints cp => Notes (ToT cp)+pepNotes = epdNotes @(GetParameterEpDerivation cp) @cp++-- | Version of 'epdCall' which we actually use in code.+-- It hides derivations stuff inside, and treats primitive types specially+-- like 'GetParameterEpDerivation' does.+pepCall+  :: forall cp name deriv.+     ( ParameterDeclaresEntryPoints cp, ParameterScope (ToT cp)+     , KnownSymbol name, deriv ~ GetParameterEpDerivation cp+     )+  => Label name+  -> EpConstructionRes (ToT cp) (Eval (EpdLookupEntryPoint deriv cp name))+pepCall = epdCall @(GetParameterEpDerivation cp) @cp++-- Derived methods and type families+----------------------------------------------------------------------------++-- | Get all entrypoints declared for parameter.+type family AllParameterEntryPoints (cp :: Kind.Type)+             :: [(Symbol, Kind.Type)] where+  AllParameterEntryPoints cp =+    EpdAllEntryPoints (GetParameterEpDerivation cp) cp++-- | Lookup for entrypoint type by name.+--+-- Does not treat default entrypoints in a special way.+type family LookupParameterEntryPoint (cp :: Kind.Type)+             :: Symbol -> Exp (Maybe Kind.Type) where+  LookupParameterEntryPoint cp =+    EpdLookupEntryPoint (GetParameterEpDerivation cp) cp++-- | Derive annotations for given parameter.+parameterEntryPointsToNotes+  :: forall cp.+     (Typeable cp, ParameterDeclaresEntryPoints cp)+  => ParamNotes (ToT cp)+parameterEntryPointsToNotes =+  let notes = pepNotes @cp+  in case mkParamNotes notes of+       -- Normally this should be valid because+       -- 1. Constraint in superclass of 'ParameterHasEntryPoints' ensures that+       -- no entrypoint is duplicated.+       -- 2. Each entrypoint is callable by laws of 'EntryPointsDerivation'.+       Right n -> n+       Left e -> error $ mconcat+        [ "Lorentz unexpectedly compiled into contract with \+          \illegal parameter declaration.\n"+        , "Parameter: " <> show (typeRep (Proxy @cp)) <> "\n"+        , "Derived annotations: " <> show notes <> "\n"+        , "Failure reason: " <> pretty e+        ]++-- | Prepare call to given entrypoint.+--+-- This does not treat calls to default entrypoint in a special way.+-- To call default entrypoint properly use 'parameterEntryPointCallDefault'.+parameterEntryPointCall+  :: forall cp name.+     ( ParameterDeclaresEntryPoints cp+     , KnownSymbol name+     )+  => Label name+  -> EntryPointCall cp (GetEntryPointArg cp name)+parameterEntryPointCall label =+  withDict (niceParameterEvi @cp) $+  case pepCall @cp label of+    EpConstructed liftSeq -> EntryPointCall+      { epcName = epNameFromParamAnn (ctorNameToAnn @name)+               ?: error "Empty constructor-entrypoint name"+      , epcParamProxy = Proxy+      , epcLiftSequence = liftSeq+      }+    EpConstructionFailed ->+      -- Not possible by 'GetEntryPointArg' constraint.+      error "impossible"++-- | Get type of entrypoint with given name, fail if not found.+type GetEntryPointArg cp name = Eval+  ( Fcf.LiftM2+      Fcf.FromMaybe+      (Fcf.TError ('Text "Entrypoint not found: " ':<>: 'ShowType name ':$$:+                   'Text "In contract parameter `" ':<>: 'ShowType cp ':<>: 'Text "`"))+      (LookupParameterEntryPoint cp name)+  )++type DefaultEpName = "Default"++-- | Call the default entrypoint.+parameterEntryPointCallDefault+  :: forall cp.+     (ParameterDeclaresEntryPoints cp)+  => EntryPointCall cp (GetDefaultEntryPointArg cp)+parameterEntryPointCallDefault =+  withDict (niceParameterEvi @cp) $+  case pepCall @cp (fromLabel @DefaultEpName) of+    EpConstructed liftSeq -> EntryPointCall+      { epcName = DefEpName+      , epcParamProxy = Proxy+      , epcLiftSequence = liftSeq+      }+    EpConstructionFailed ->+      EntryPointCall+      { epcName = DefEpName+      , epcParamProxy = Proxy+      , epcLiftSequence = EplArgHere+      }++-- | Get type of entrypoint with given name, fail if not found.+type GetDefaultEntryPointArg cp = Eval+  ( Fcf.LiftM2+      Fcf.FromMaybe+      (Fcf.Pure cp)+      (LookupParameterEntryPoint cp DefaultEpName)+  )++-- | Ensure that there is no explicit "default" entrypoint.+type ForbidExplicitDefaultEntryPoint cp = Eval+  (Fcf.LiftM3+      Fcf.UnMaybe+      (Fcf.Pure (Fcf.Pure (() :: Constraint)))+      (Fcf.TError+         ('Text "Parameter used here must have no explicit \"default\" entrypoint" ':$$:+          'Text "In parameter type `" ':<>: 'ShowType cp ':<>: 'Text "`"+         )+      )+      (LookupParameterEntryPoint cp DefaultEpName)+  )++-- | Similar to 'ForbidExplicitDefaultEntryPoint', but in a version which+-- the compiler can work with (and which produces errors confusing for users :/)+type NoExplicitDefaultEntryPoint cp =+  Eval (LookupParameterEntryPoint cp DefaultEpName) ~ 'Nothing++-- | Call root entrypoint safely.+sepcCallRootChecked+  :: forall cp.+     (NiceParameter cp, ForbidExplicitDefaultEntryPoint cp)+  => SomeEntryPointCall cp+sepcCallRootChecked = sepcCallRootUnsafe \\ niceParameterEvi @cp+  where+    -- Avoiding redundant-constraints warning.+    _validUsage = Dict @(ForbidExplicitDefaultEntryPoint cp)++-- | Which entrypoint to call.+--+-- We intentionally distinguish default and non-default cases because+-- this makes API more details-agnostic.+data EntryPointRef (mname :: Maybe Symbol) where+  -- | Call the default entrypoint, or root if no explicit default is assigned.+  CallDefault :: EntryPointRef 'Nothing++  -- | Call the given entrypoint; calling default is not treated specially.+  -- You have to provide entrypoint name via passing it as type argument.+  --+  -- Unfortunatelly, here we cannot accept a label because in most cases our+  -- entrypoints begin from capital letter (being derived from constructor name),+  -- while labels must start from a lower-case letter, and there is no way to+  -- make a conversion at type-level.+  Call :: NiceEntryPointName name => EntryPointRef ('Just name)++-- | Constraint on type-level entrypoint name specifier.+type NiceEntryPointName name = (KnownSymbol name, ForbidDefaultName name)++type family ForbidDefaultName (name :: Symbol) :: Constraint where+  ForbidDefaultName "Default" =+    TypeError ('Text "Calling `Default` entrypoint is not allowed here")+  ForbidDefaultName _ = ()++eprName :: forall mname. EntryPointRef mname -> EpName+eprName = \case+  CallDefault -> DefEpName+  Call | (_ :: Proxy ('Just name)) <- Proxy @mname ->+    epNameFromParamAnn (ctorNameToAnn @name)+    ?: error "Empty constructor-entrypoint name"++-- | Universal entrypoint calling.+parameterEntryPointCallCustom+  :: forall cp mname.+     (ParameterDeclaresEntryPoints cp)+  => EntryPointRef mname+  -> EntryPointCall cp (GetEntryPointArgCustom cp mname)+parameterEntryPointCallCustom = \case+  CallDefault ->+    parameterEntryPointCallDefault @cp+  Call | (_ :: Proxy ('Just name)) <- Proxy @mname ->+    parameterEntryPointCall @cp (fromLabel @name)++-- | Flatten a provided list of notes to a map of its entrypoints+-- and its corresponding utype.+--+-- It is obtained by constructing `insert k1 v1 (insert k2 v2 ... mempty)`+-- pipe using `Endo` so that it is more concise rather than stacking composition+-- of monoidal endomorphisms explicitly. Note that here no duplicates can appear+-- in returned map for `ParamNotes` even if they may appear inside passed `Notes` tree.+flattenEntryPoints :: SingI t => ParamNotes t -> Map EpName U.Type+flattenEntryPoints (unParamNotes -> notes) = appEndo (gatherEPs (sing, notes)) mempty+  where+    gatherEPs+      :: forall n.+         (Sing n, Notes n)+      -> Endo (Map EpName U.Type)+    gatherEPs = \case+      (STOr ls rs, NTOr _ fn1 fn2 ln rn) -> mconcat+        [ Endo . maybe id (uncurry insert) . psi ln $ epNameFromParamAnn fn1+        , Endo . maybe id (uncurry insert) . psi rn $ epNameFromParamAnn fn2+        , gatherEPs (ls, ln)+        , gatherEPs (rs, rn)+        ]+      _ -> mempty++    psi+      :: forall n.+         SingI n+      => Notes n+      -> Maybe EpName+      -> Maybe (EpName, U.Type)+    psi n x = tensor x $ mkUType sing n++    -- Tensorial strength criteria+    tensor :: Functor f => f a -> b -> f (a,b)+    tensor fa b = fmap (,b) fa++-- | Universal entrypoint lookup.+type family GetEntryPointArgCustom cp mname :: Kind.Type where+  GetEntryPointArgCustom cp 'Nothing = GetDefaultEntryPointArg cp+  GetEntryPointArgCustom cp ('Just name) = GetEntryPointArg cp name++----------------------------------------------------------------------------+-- Type class for functions that take entrypoint name as argument+----------------------------------------------------------------------------++-- | When we call a Lorentz contract we should pass entrypoint name+-- and corresponding argument. Ideally we want to statically check+-- that parameter has entrypoint with given name and+-- argument. Constraint defined by this type class holds for contract+-- with parameter @cp@ that have entrypoint matching @name@ with type+-- @arg@.+--+-- In order to check this property statically, we need to know entrypoint+-- name in compile time, 'EntryPointRef' type serves this purpose.+-- If entrypoint name is not known, one can use 'TrustEpName' wrapper+-- to take responsibility for presence of this entrypoint.+--+-- If you want to call a function which has this constraint, you have+-- two options:+-- 1. Pass contract parameter @cp@ using type application, pass 'EntryPointRef'+-- as a value and pass entrypoint argument. Type system will check that+-- @cp@ has an entrypoint with given reference and type.+-- 2. Pass 'EpName' wrapped into 'TrustEpName' and entrypoint argument.+-- In this case passing contract parameter is not necessary, you do not even+-- have to know it.+class HasEntryPointArg cp name arg where+  -- | Data returned by this method may look somewhat arbitrary.+  -- 'EpName' is obviously needed because @name@ can be+  -- 'EntryPointRef' or 'TrustEpName'.  @Dict@ is returned because in+  -- 'EntryPointRef' case we get this evidence for free and don't want+  -- to use it. We seem to always need it anyway.+  useHasEntryPointArg :: name -> (Dict (ParameterScope (ToT arg)), EpName)++-- | 'HasEntryPointArg' constraint specialized to default entrypoint.+type HasDefEntryPointArg cp defEpName defArg =+  ( defEpName ~ EntryPointRef 'Nothing+  , HasEntryPointArg cp defEpName defArg+  )++instance+  (GetEntryPointArgCustom cp mname ~ arg, ParameterDeclaresEntryPoints cp) =>+  HasEntryPointArg cp (EntryPointRef mname) arg where+  useHasEntryPointArg epRef =+    withDict (niceParameterEvi @cp) $+    case parameterEntryPointCallCustom @cp epRef of+      EntryPointCall{} -> (Dict, eprName epRef)++-- | This wrapper allows to pass untyped 'EpName' and bypass checking+-- that entrypoint with given name and type exists.+newtype TrustEpName = TrustEpName EpName++instance (NiceParameter arg) =>+  HasEntryPointArg cp TrustEpName arg where+  useHasEntryPointArg (TrustEpName epName) = (Dict, epName) \\ niceParameterEvi @arg++----------------------------------------------------------------------------+-- Trivial implementation+----------------------------------------------------------------------------++-- | No entrypoints declared, parameter type will serve as argument type+-- of the only existing entrypoint (default one).+data EpdNone+instance SingI (ToT cp) => EntryPointsDerivation EpdNone cp where+  type EpdAllEntryPoints EpdNone cp = '[]+  type EpdLookupEntryPoint EpdNone cp = Fcf.ConstFn 'Nothing+  epdNotes = starNotes+  epdCall _ = EpConstructionFailed
+ src/Lorentz/EntryPoints/Doc.hs view
@@ -0,0 +1,355 @@+-- | Utilities for declaring and documenting entry points.+module Lorentz.EntryPoints.Doc+  ( DEntryPoint (..)+  , EntryArrow (..)+  , PlainEntryPointsKind+  , diEntryPointToMarkdown+  , DEntryPointArg (..)+  , DType (..)+  , DeriveCtorFieldDoc (..)+  , ParamBuildingStep (..)+  , clarifyParamBuildingSteps+  , constructDEpArg+  , emptyDEpArg+  , mkUType+  , mkDEpUType+  , mkDEntryPointArgSimple+  , DocumentEntryPoints+  , documentEntryPoint+  , entryCase+  , entryCase_+  ) where++import Control.Lens.Cons (_head)+import Data.Char (toLower)+import qualified Data.Kind as Kind+import Data.Singletons (sing)+import Data.Vinyl.Core (RMap, Rec(..), rappend)+import Data.Vinyl.Derived (Label)+import Fmt (build)+import GHC.Generics ((:+:))+import qualified GHC.Generics as G+import GHC.TypeLits (AppendSymbol, KnownSymbol, symbolVal)++import Lorentz.ADT+import Lorentz.Base+import Lorentz.Constraints.Scopes+import Lorentz.Doc+import Lorentz.TypeAnns+import Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB)+import Michelson.Typed (mkUType)+import Michelson.Typed.Doc+import Michelson.Typed.Haskell.Doc+import Michelson.Typed.Haskell.Instr+import qualified Michelson.Untyped as Untyped+import Util.Markdown+import Util.Type+import Util.TypeTuple++-- | Gathers information about single entrypoint.+--+-- We assume that entry points might be of different kinds,+-- which is designated by phantom type parameter.+-- For instance, you may want to have several groups of entry points+-- corresponding to various parts of a contract - specifying different @kind@+-- type argument for each of those groups will allow you defining different+-- 'DocItem' instances with appropriate custom descriptions for them.+data DEntryPoint (kind :: Kind.Type) = DEntryPoint+  { depName :: Text+  , depSub :: SubDoc+  }++-- | Default implementation of 'docItemToMarkdown' for entry points.+diEntryPointToMarkdown :: HeaderLevel -> DEntryPoint level -> Markdown+diEntryPointToMarkdown lvl (DEntryPoint name block) =+  mdSeparator <>+  mdHeader lvl (mdTicked . build . over _head toLower $ name) <>+  subDocToMarkdown (nextHeaderLevel lvl) block++-- | Default value for 'DEntryPoint' type argument.+data PlainEntryPointsKind++instance DocItem (DEntryPoint PlainEntryPointsKind) where+  type DocItemPosition (DEntryPoint PlainEntryPointsKind) = 1000+  docItemSectionName = Just "Entrypoints"+  docItemToMarkdown = diEntryPointToMarkdown++-- | During incremental assembly of parameter building steps -+-- current representation of parameter.+type CurrentParam = Markdown++-- | Describes a parameter building step.+--+-- This can be wrapping into (Haskell) constructor, or a more complex+-- transformation.+data ParamBuildingStep = ParamBuildingStep+  { pbsEnglish :: Markdown+    -- ^ Plain english description of this step.+  , pbsHaskell :: CurrentParam -> Markdown+    -- ^ How to construct parameter in Haskell code.+  , pbsMichelson :: CurrentParam -> Markdown+    -- ^ How to construct parameter working on raw Michelson.+  }++-- | Describes argument of an entrypoint.+data DEntryPointArg =+  DEntryPointArg+  { epaArg :: Maybe DType+    -- ^ Argument of the entrypoint. Pass 'Nothing' if no argument is required.+  , epaHasAnnotation :: Bool+    -- ^ Whether this entrypoint has a field annotation (and thus is+    -- callable using the standard "lightweigth entrypoints"+    -- mechanism) or is a virtual entrypoint which requires+    -- constructing a value of the full parameter type.+  , epaBuilding :: [ParamBuildingStep]+    -- ^ Describes a way to lift an entrypoint argument into full parameter+    -- which can be passed to the contract.+    --+    -- Steps are supposed to be applied in the order in which they are given.+    -- E.g. suppose that an entrypoint is called as @Run (Service1 arg)@;+    -- then the first step should describe wrapping into @Service1@ constructor,+    -- and the second step should be about wrapping into @Run@ constructor.+  , epaType :: Untyped.Type+    -- ^ Untyped representation of entrypoint, used for printing its michelson+    -- type representation.+  }++constructDEpArg+  :: forall arg.+     ( TypeHasDoc arg+     , HasTypeAnn arg+     , KnownValue arg+     )+  => Bool -> DEntryPointArg+constructDEpArg epaHasAnnotation = DEntryPointArg+  { epaArg = Just $ DType (Proxy @arg)+  , epaHasAnnotation = epaHasAnnotation+  , epaBuilding = []+  , epaType = mkDEpUType @arg+  }++emptyDEpArg :: Bool -> DEntryPointArg+emptyDEpArg epaHasAnnotation = DEntryPointArg+  { epaArg = Nothing+  , epaHasAnnotation = epaHasAnnotation+  , epaBuilding = []+  , epaType = Untyped.Type Untyped.TUnit Untyped.noAnn+  }++mkDEpUType :: forall t. (KnownValue t, HasTypeAnn t) => Untyped.Type+mkDEpUType = mkUType sing (getTypeAnn @t)++mkDEntryPointArgSimple+  :: forall t.+     ( KnownValue t+     , HasTypeAnn t+     , TypeHasDoc t+     )+  => DEntryPointArg+mkDEntryPointArgSimple = DEntryPointArg+  { epaArg = Just $ DType (Proxy @t)+  , epaHasAnnotation = False+  , epaBuilding = []+  , epaType = mkDEpUType @t+  }++-- | Go over contract code and update every occurrence of 'DEntryPointArg'+-- documentation item, adding the given step to its "how to build parameter"+-- description.+clarifyParamBuildingSteps :: ParamBuildingStep -> (inp :-> out) -> (inp :-> out)+clarifyParamBuildingSteps pbs =+  iMapAnyCode $+  modifyInstrDoc (\di -> di{ epaBuilding = epaBuilding di ++ [pbs] })++instance DocItem DEntryPointArg where+  type DocItemPosition DEntryPointArg = 20+  docItemSectionName = Nothing+  docItemDependencies (DEntryPointArg mdty _ _ _) =+    [SomeDocDefinitionItem dty | Just dty <- pure mdty]+  docItemToMarkdown _ (DEntryPointArg mdty hasAnnotation psteps et) =+    mconcat . Prelude.map (<> "\n\n") $+      [ mdSubsection "Argument" $+          case mdty of+            Nothing -> "none (pass unit)"+            Just (DType (dty :: Proxy ep)) -> mconcat . Prelude.intersperse "\n" $+              [ mempty+              , "  + " <>+                mdSubsection "In Haskell"+                  (typeDocMdReference dty (WithinParens False))+              , "  + " <>+                mdSubsection "In Michelson"+                  (mdTicked $ printDocB False . renderDoc needsParens $ et)+              ],+          mdSpoiler "How to call this entrypoint" $+            "\n0. Construct an argument for the entrypoint.\n" <>+            mconcat howToCall+      ]+    where+      howToCall+        | hasAnnotation = howToCallAnnotatedEntrypoint+        | otherwise = howToCallVirtualEntrypoint++      -- TODO: currently we always set @hasAnnotation@ to @True@,+      -- hence this case in unreachable.  It is still useful, we+      -- should set @hasAnnotation@ properly and improve handling of+      -- this case.  Specifically, for virtual entrypoints we should+      -- wrap them into constructors until we reach one having a field+      -- annotation. As soon as it is reached, we can call the+      -- contract by an entrypoint name.+      howToCallVirtualEntrypoint =+        [ mconcat . Prelude.intersperse "\n" $+            psteps <&> \ParamBuildingStep{..} ->+              mconcat . Prelude.intersperse "\n" $+              [ -- Markdown re-enumerates enumerated lists automatically+                "1. " <> pbsEnglish+              , "  + " <>+                mdSubsection "In Haskell" (mdTicked $ pbsHaskell "·")+              , "  + " <>+                mdSubsection "In Michelson" (mdTicked $ pbsMichelson "·")+              ]+        , "\n\nPass resulting value as parameter to the contract.\n"+        ]++      howToCallAnnotatedEntrypoint =+        [ "1. Make a transfer to the contract passing this entrypoint's name " <>+          "and the constructed value as an argument."+        ]++-- | Pick a type documentation from 'CtorField'.+class (KnownSymbol con) => DeriveCtorFieldDoc con (cf :: CtorField) where+  deriveCtorFieldDoc :: DEntryPointArg++instance+    (KnownSymbol con)+  =>+    DeriveCtorFieldDoc con 'NoFields+  where+  deriveCtorFieldDoc = emptyDEpArg True++instance+    (TypeHasDoc ty, HasTypeAnn ty, KnownValue ty, KnownSymbol con)+  =>+    DeriveCtorFieldDoc con ('OneField ty)+  where+  deriveCtorFieldDoc = constructDEpArg @ty True++-- | Add necessary documentation to entry points.+documentEntryPoints+  :: forall a kind inp out.+     DocumentEntryPoints kind a+  => Rec (CaseClauseL inp out) (CaseClauses a)+  -> Rec (CaseClauseL inp out) (CaseClauses a)+documentEntryPoints = gDocumentEntryPoints @kind @(G.Rep a) id++-- | Constraint for 'documentEntryPoints'.+type DocumentEntryPoints kind a =+  (Generic a, GDocumentEntryPoints kind (G.Rep a))++-- | Traverse entry points and add parameter building step (which describes+-- necessity to wrap parameter into some constructor of the given datatype)+-- to all parameters described within given code.+class GDocumentEntryPoints (kind :: Kind.Type) (x :: Kind.Type -> Kind.Type) where+  -- | Add corresponding parameter building step.+  --+  -- First argument is accumulator for Michelson description of the building step.+  gDocumentEntryPoints+    :: (Markdown -> Markdown)+    -> Rec (CaseClauseL inp out) (GCaseClauses x)+    -> Rec (CaseClauseL inp out) (GCaseClauses x)++instance GDocumentEntryPoints kind x => GDocumentEntryPoints kind (G.D1 i x) where+  gDocumentEntryPoints = gDocumentEntryPoints @kind @x++instance ( GDocumentEntryPoints kind x, GDocumentEntryPoints kind y+         , RSplit (GCaseClauses x) (GCaseClauses y)+         ) =>+         GDocumentEntryPoints kind (x :+: y) where+  gDocumentEntryPoints michDesc clauses =+    let (lclauses, rclauses) = rsplit @CaseClauseParam @(GCaseClauses x) clauses+    in gDocumentEntryPoints @kind @x+         (\a -> michDesc $ "Left (" <> a <> ")")+         lclauses+       `rappend`+       gDocumentEntryPoints @kind @y+         (\a -> michDesc $ "Right (" <> a <> ")")+         rclauses++instance ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x+         , KnownSymbol ctor+         , DocItem (DEntryPoint kind)+         , DeriveCtorFieldDoc ctor cf+         ) =>+         GDocumentEntryPoints kind (G.C1 ('G.MetaCons ctor _1 _2) x) where+  gDocumentEntryPoints michDesc (CaseClauseL clause :& RNil) =+    let entryPointName = toText $ symbolVal (Proxy @ctor)+        psteps = ParamBuildingStep+          { pbsEnglish = "Wrap into " <> mdTicked (build entryPointName) <> " constructor."+          , pbsHaskell = \p -> build entryPointName <> " (" <> p <> ")"+          , pbsMichelson = michDesc+          }+        addDoc instr =+          clarifyParamBuildingSteps psteps $+          docGroup (SomeDocItem . DEntryPoint @kind entryPointName) $+          doc (deriveCtorFieldDoc @ctor @cf) # instr+    in CaseClauseL (addDoc clause) :& RNil++-- | Like 'case_', to be used for pattern-matching on parameter.+--+-- Modifies documentation accordingly. Including description of+-- entrypoints' arguments, thus for them you will need to supply+-- 'TypeHasDoc' instance.+entryCase_+  :: forall dt entryPointKind out inp.+     ( InstrCaseC dt inp out+     , RMap (CaseClauses dt)+     , DocumentEntryPoints entryPointKind dt+     )+  => Proxy entryPointKind+  -> Rec (CaseClauseL inp out) (CaseClauses dt)+  -> dt & inp :-> out+entryCase_ _ = case_ . documentEntryPoints @dt @entryPointKind++-- | Version of 'entryCase_' for tuples.+entryCase+  :: forall dt entryPointKind out inp clauses.+     ( CaseTC dt out inp clauses+     , DocumentEntryPoints entryPointKind dt+     )+  => Proxy entryPointKind -> IsoRecTuple clauses -> dt & inp :-> out+entryCase p = entryCase_ p . recFromTuple++-- | Wrapper for documenting single entrypoint which parameter+-- isn't going to be unwrapped from some datatype.+--+-- @entryCase@ unwraps a datatype, however, sometimes we want to+-- have entrypoint parameter to be not wrapped into some datatype.+documentEntryPoint+  :: forall kind epName param s out.+     ( KnownSymbol epName+     , DocItem (DEntryPoint kind)+     , TypeHasDoc param+     , HasTypeAnn param+     , KnownValue param+     )+  => param & s :-> out -> param & s :-> out+documentEntryPoint instr =+  let entryPointName = toText $ symbolVal (Proxy @epName) in+    docGroup (SomeDocItem . DEntryPoint @kind entryPointName) $+    doc (constructDEpArg @param True) # instr++-- | Provides arror for convenient entrypoint documentation+class EntryArrow kind name body where+  -- | Lift entrypoint implementation.+  --+  -- Entrypoint names should go with "e" prefix.+  (#->) :: (Label name, Proxy kind) -> body -> body++instance ( name ~ ("e" `AppendSymbol` epName)+         , body ~ (param & s :-> out)+         , KnownSymbol epName+         , DocItem (DEntryPoint kind)+         , TypeHasDoc param+         , HasTypeAnn param+         , KnownValue param+         ) => EntryArrow kind name body where+  (#->) _ = documentEntryPoint @kind @epName
+ src/Lorentz/EntryPoints/Helpers.hs view
@@ -0,0 +1,46 @@+module Lorentz.EntryPoints.Helpers+  ( ctorNameToAnn+  , CanHaveEntryPoints+  , ShouldHaveEntryPoints (..)+  , RequireSumType+  ) where++import qualified Data.Kind as Kind++import Michelson.Typed.Haskell+import Michelson.Typed.T+import Michelson.Untyped (FieldAnn, ann)+import Util.Text+import Util.Type+import Util.TypeLits++ctorNameToAnn :: forall ctor. (KnownSymbol ctor, HasCallStack) => FieldAnn+ctorNameToAnn = ann . headToLower $ (symbolValT' @ctor)++-- | A special type which wraps over a primitive type and states that it has+-- entrypoints (one).+--+-- Assuming that any type can have entrypoints makes use of Lorentz entrypoints+-- too annoying, so for declaring entrypoints for not sum types we require an+-- explicit wrapper.+newtype ShouldHaveEntryPoints a = ShouldHaveEntryPoints { unHasEntryPoints :: a }+  deriving stock Generic+  deriving anyclass IsoValue++-- | Used to understand whether a type can potentially declare any entrypoints.+type family CanHaveEntryPoints (p :: Kind.Type) :: Bool where+  CanHaveEntryPoints (ShouldHaveEntryPoints _) = 'True+  CanHaveEntryPoints p = CanHaveEntryPointsT (ToT p)++type family CanHaveEntryPointsT (t :: T) :: Bool where+  CanHaveEntryPointsT ('TOr _ _) = 'True+  CanHaveEntryPointsT _ = 'False++-- | Ensure that given type is a sum type.+--+-- This helps to prevent attempts to apply a function to, for instance, a pair.+type family RequireSumType (a :: Kind.Type) :: Constraint where+  RequireSumType a =+    If (CanHaveEntryPoints a)+       (() :: Constraint)+       (TypeError ('Text "Expected Michelson sum type"))
+ src/Lorentz/EntryPoints/Impl.hs view
@@ -0,0 +1,306 @@+-- | Common implementations of entrypoints.+module Lorentz.EntryPoints.Impl+  ( EpdPlain+  , EpdRecursive+  , EpdDelegate+  ) where++import qualified Data.Kind as Kind+import Data.Singletons (SingI (..))+import Data.Singletons.Prelude (Sing (STrue, SFalse))+import Data.Singletons.Prelude.Eq ((%==))+import Data.Type.Bool (If)+import qualified GHC.Generics as G+import Util.TypeLits+import Fcf (Exp, Eval)+import qualified Fcf++import Michelson.Typed+import Michelson.Typed.Haskell.Instr.Sum (IsPrimitiveValue)+import Michelson.Typed.Haskell.Value (GValueType, GenericIsoValue)+import Michelson.Untyped (FieldAnn, noAnn)+import Lorentz.Value+import Util.Type+import Util.Fcf (Over2, type (<|>), TyEqSing)++import Lorentz.EntryPoints.Helpers+import Lorentz.EntryPoints.Core+import Lorentz.TypeAnns++-- | Implementation of 'ParameterHasEntryPoints' which fits for case when+-- your contract exposes multiple entrypoints via having sum type as its+-- parameter.+--+-- In particular, each constructor would produce a homonymous entrypoint with+-- argument type equal to type of constructor field (each constructor should+-- have only one field).+-- Constructor called 'Default' will designate the default entrypoint.+data EpdPlain+instance PlainEntryPointsC EpdPlain cp => EntryPointsDerivation EpdPlain cp where+  type EpdAllEntryPoints EpdPlain cp = PlainAllEntryPointsExt EpdPlain cp+  type EpdLookupEntryPoint EpdPlain cp = PlainLookupEntryPointExt EpdPlain cp+  epdNotes = plainEpdNotesExt @EpdPlain @cp+  epdCall = plainEpdCallExt @EpdPlain @cp++-- | Extension of 'EpdPlain' on parameters being defined as several nested+-- datatypes.+--+-- In particular, this will traverse sum types recursively, stopping at+-- Michelson primitives (like 'Natural') and constructors with number of+-- fields different from one.+--+-- It does not assign names to intermediate nodes of 'Or' tree, only to the very+-- leaves.+--+-- If some entrypoint arguments have custom 'IsoValue' instance, this+-- derivation way will not work. As a workaround, you can wrap your+-- argument into some primitive (e.g. ':!').+data EpdRecursive+instance PlainEntryPointsC EpdRecursive cp => EntryPointsDerivation EpdRecursive cp where+  type EpdAllEntryPoints EpdRecursive cp = PlainAllEntryPointsExt EpdRecursive cp+  type EpdLookupEntryPoint EpdRecursive cp = PlainLookupEntryPointExt EpdRecursive cp+  epdNotes = plainEpdNotesExt @EpdRecursive @cp+  epdCall = plainEpdCallExt @EpdRecursive @cp++-- | Extension of 'EpdPlain' on parameters being defined as several nested+-- datatypes.+--+-- In particular, it will traverse the immediate sum type, and require another+-- 'ParameterHasEntryPoints' for the inner complex datatypes. Only those+-- inner types are considered which are the only fields in their respective+-- constructors.+-- Inner types should not themselves declare default entrypoint, we enforce+-- this for better modularity.+-- Each top-level constructor will be treated as entrypoint even if it contains+-- a complex datatype within, in such case that would be an entrypoint+-- corresponding to intermediate node in @or@ tree.+--+-- Comparing to 'EpdRecursive' this gives you more control over where and how+-- entrypoints will be derived.+data EpdDelegate+instance (PlainEntryPointsC EpdDelegate cp) => EntryPointsDerivation EpdDelegate cp where+  type EpdAllEntryPoints EpdDelegate cp = PlainAllEntryPointsExt EpdDelegate cp+  type EpdLookupEntryPoint EpdDelegate cp = PlainLookupEntryPointExt EpdDelegate cp+  epdNotes = plainEpdNotesExt @EpdDelegate @cp+  epdCall = plainEpdCallExt @EpdDelegate @cp++type PlainAllEntryPointsExt mode cp = AllEntryPoints mode (BuildEPTree mode cp) cp++type PlainLookupEntryPointExt mode cp = LookupEntryPoint mode (BuildEPTree mode cp) cp++plainEpdNotesExt+  :: forall mode cp.+     (PlainEntryPointsC mode cp, HasCallStack)+  => Notes (ToT cp)+plainEpdNotesExt = mkEntryPointsNotes @mode @(BuildEPTree mode cp) @cp++plainEpdCallExt+  :: forall mode cp name.+     (PlainEntryPointsC mode cp, ParameterScope (ToT cp), KnownSymbol name)+  => Label name+  -> EpConstructionRes (ToT cp) (Eval (LookupEntryPoint mode (BuildEPTree mode cp) cp name))+plainEpdCallExt = mkEpLiftSequence @mode @(BuildEPTree mode cp) @cp++type PlainEntryPointsC mode cp =+  ( GenericIsoValue cp+  , EntryPointsNotes mode (BuildEPTree mode cp) cp+  , RequireSumType cp+  )++-- | Entrypoints tree - skeleton on 'TOr' tree later used to distinguish+-- between constructors-entrypoints and constructors which consolidate+-- a whole pack of entrypoints.+data EPTree+  = EPNode EPTree EPTree+    -- ^ We are in the intermediate node and need to go deeper.+  | EPLeaf+    -- ^ We reached entrypoint argument.+  | EPDelegate+    -- ^ We reached complex parameter part and will need to ask how to process it.++-- | Build 'EPTree' by parameter type.+type BuildEPTree mode a = GBuildEntryPointsTree mode (G.Rep a)++type family GBuildEntryPointsTree (mode :: Kind.Type) (x :: Kind.Type -> Kind.Type)+             :: EPTree where+  GBuildEntryPointsTree mode (G.D1 _ x) =+    GBuildEntryPointsTree mode x+  GBuildEntryPointsTree mode (x G.:+: y) =+    'EPNode (GBuildEntryPointsTree mode x) (GBuildEntryPointsTree mode y)++  GBuildEntryPointsTree EpdPlain (G.C1 _ _) =+    'EPLeaf+  GBuildEntryPointsTree EpdRecursive (G.C1 _ x) =+    GBuildEntryPointsTree EpdRecursive x+  GBuildEntryPointsTree EpdDelegate (G.C1 _ (G.S1 _ (G.Rec0 _))) =+    'EPDelegate+  GBuildEntryPointsTree EpdDelegate (G.C1 _ _) =+    'EPLeaf+  GBuildEntryPointsTree mode (G.S1 _ x) =+    GBuildEntryPointsTree mode x+  GBuildEntryPointsTree _ G.U1 =+    'EPLeaf+  GBuildEntryPointsTree _ (_ G.:*: _) =+    'EPLeaf+  GBuildEntryPointsTree mode (G.Rec0 a) =+    If (IsPrimitiveValue a)+       'EPLeaf+       (BuildEPTree mode a)++-- | Traverses sum type and constructs 'Notes' which report+-- constructor names via field annotations.+type EntryPointsNotes mode ep a = (Generic a, GEntryPointsNotes mode ep (G.Rep a))++-- | Makes up notes with proper field annotations for given parameter.+mkEntryPointsNotes+  :: forall mode ep a.+      (EntryPointsNotes mode ep a, GenericIsoValue a, HasCallStack)+  => Notes (ToT a)+mkEntryPointsNotes = fst $ gMkEntryPointsNotes @mode @ep @(G.Rep a)++-- | Makes up a way to lift entrypoint argument to full parameter.+mkEpLiftSequence+  :: forall mode ep a name.+      ( EntryPointsNotes mode ep a, ParameterScope (ToT a)+      , GenericIsoValue a, KnownSymbol name+      )+  => Label name+  -> EpConstructionRes (ToT a) (Eval (LookupEntryPoint mode ep a name))+mkEpLiftSequence = gMkEpLiftSequence @mode @ep @(G.Rep a)++-- | Fetches information about all entrypoints - leaves of 'Or' tree.+type AllEntryPoints mode ep a = GAllEntryPoints mode ep (G.Rep a)++-- | Fetches information about all entrypoints - leaves of 'Or' tree.+type LookupEntryPoint mode ep a = GLookupEntryPoint mode ep (G.Rep a)++-- | Generic traversal for 'EntryPointsNotes'.+class GEntryPointsNotes (mode :: Kind.Type) (ep :: EPTree) (x :: Kind.Type -> Kind.Type) where+  type GAllEntryPoints mode ep x :: [(Symbol, Kind.Type)]+  type GLookupEntryPoint mode ep x :: Symbol -> Exp (Maybe Kind.Type)++  {- | Returns:+    1. Notes corresponding to this level;+    2. Field annotation for this level (and which should be used one level above).+  -}+  gMkEntryPointsNotes :: HasCallStack => (Notes (GValueType x), FieldAnn)++  gMkEpLiftSequence+    :: (KnownSymbol name, ParameterScope (GValueType x))+    => Label name+    -> EpConstructionRes (GValueType x) (Eval (GLookupEntryPoint mode ep x name))++instance GEntryPointsNotes mode ep x => GEntryPointsNotes mode ep (G.D1 i x) where+  type GAllEntryPoints mode ep (G.D1 i x) = GAllEntryPoints mode ep x+  type GLookupEntryPoint mode ep (G.D1 i x) = GLookupEntryPoint mode ep x+  gMkEntryPointsNotes = gMkEntryPointsNotes @mode @ep @x+  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x++instance (GEntryPointsNotes mode epx x, GEntryPointsNotes mode epy y) =>+         GEntryPointsNotes mode ('EPNode epx epy) (x G.:+: y) where+  type GAllEntryPoints mode ('EPNode epx epy) (x G.:+: y) =+    GAllEntryPoints mode epx x ++ GAllEntryPoints mode epy y+  type GLookupEntryPoint mode ('EPNode epx epy) (x G.:+: y) =+    Over2 (<|>) (GLookupEntryPoint mode epx x) (GLookupEntryPoint mode epy y)+  gMkEntryPointsNotes =+    let (xnotes, xann) = gMkEntryPointsNotes @mode @epx @x+        (ynotes, yann) = gMkEntryPointsNotes @mode @epy @y+    in (NTOr noAnn xann yann xnotes ynotes, noAnn)+  gMkEpLiftSequence label =+    case sing @(GValueType (x G.:+: y)) of+      STOr sl _ -> case (checkOpPresence sl, checkNestedBigMapsPresence sl) of+        (OpAbsent, NestedBigMapsAbsent) ->+          case gMkEpLiftSequence @mode @epx @x label of+            EpConstructed liftSeq -> EpConstructed (EplWrapLeft liftSeq)+            EpConstructionFailed ->+              case gMkEpLiftSequence @mode @epy @y label of+                EpConstructed liftSeq -> EpConstructed (EplWrapRight liftSeq)+                EpConstructionFailed -> EpConstructionFailed++instance ( GHasTypeAnn x, KnownSymbol ctor+         , ToT (GExtractField x) ~ GValueType x+         ) =>+         GEntryPointsNotes mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GAllEntryPoints mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =+    '[ '(ctor, GExtractField x) ]+  type GLookupEntryPoint mode 'EPLeaf (G.C1 ('G.MetaCons ctor _1 _2) x) =+    JustOnEq ctor (GExtractField x)+  gMkEntryPointsNotes =+    (gGetTypeAnn @x, ctorNameToAnn @ctor)+  gMkEpLiftSequence (_ :: Label name) =+    case sing @ctor %== sing @name of+      STrue -> EpConstructed EplArgHere+      SFalse -> EpConstructionFailed++instance (ep ~ 'EPNode epx epy, GEntryPointsNotes mode ep x) =>+         GEntryPointsNotes mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GAllEntryPoints mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) =+    GAllEntryPoints mode ('EPNode epx epy) x+  type GLookupEntryPoint mode ('EPNode epx epy) (G.C1 ('G.MetaCons ctor _1 _2) x) =+    GLookupEntryPoint mode ('EPNode epx epy) x+  gMkEntryPointsNotes = gMkEntryPointsNotes @mode @ep @x+  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x++instance ( ep ~ 'EPDelegate, GEntryPointsNotes mode ep x+         , KnownSymbol ctor, ToT (GExtractField x) ~ GValueType x+         ) =>+         GEntryPointsNotes mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) where+  type GAllEntryPoints mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) =+    '(ctor, GExtractField x) ': GAllEntryPoints mode 'EPDelegate x+  type GLookupEntryPoint mode 'EPDelegate (G.C1 ('G.MetaCons ctor _1 _2) x) =+    Over2 (<|>) (JustOnEq ctor (GExtractField x)) (GLookupEntryPoint mode 'EPDelegate x)+  gMkEntryPointsNotes =+    let (notes, _rootAnn) = gMkEntryPointsNotes @mode @ep @x+    in (notes, ctorNameToAnn @ctor)+  gMkEpLiftSequence (label :: Label name) =+    case sing @ctor %== sing @name of+      STrue -> EpConstructed EplArgHere+      SFalse -> gMkEpLiftSequence @mode @ep @x label++instance GEntryPointsNotes mode ep x => GEntryPointsNotes mode ep (G.S1 i x) where+  type GAllEntryPoints mode ep (G.S1 i x) = GAllEntryPoints mode ep x+  type GLookupEntryPoint mode ep (G.S1 i x) = GLookupEntryPoint mode ep x+  gMkEntryPointsNotes = gMkEntryPointsNotes @mode @ep @x+  gMkEpLiftSequence = gMkEpLiftSequence @mode @ep @x++instance (EntryPointsNotes EpdRecursive ep a, GenericIsoValue a) =>+         GEntryPointsNotes EpdRecursive ep (G.Rec0 a) where+  type GAllEntryPoints EpdRecursive ep (G.Rec0 a) = AllEntryPoints EpdRecursive ep a+  type GLookupEntryPoint EpdRecursive ep (G.Rec0 a) = LookupEntryPoint EpdRecursive ep a+  gMkEntryPointsNotes = (mkEntryPointsNotes @EpdRecursive @ep @a, noAnn)+  gMkEpLiftSequence = mkEpLiftSequence @EpdRecursive @ep @a++instance (ParameterDeclaresEntryPoints a) =>+         GEntryPointsNotes EpdDelegate 'EPDelegate (G.Rec0 a) where+  type GAllEntryPoints EpdDelegate 'EPDelegate (G.Rec0 a) = AllParameterEntryPoints a+  type GLookupEntryPoint EpdDelegate 'EPDelegate (G.Rec0 a) = LookupParameterEntryPoint a+  gMkEntryPointsNotes = (pepNotes @a, noAnn)+  -- TODO [#35]: should use field ann ^^^^^ returned by 'epdNotes'+  gMkEpLiftSequence = pepCall @a++instance GEntryPointsNotes mode 'EPLeaf G.U1 where+  type GAllEntryPoints mode 'EPLeaf G.U1 = '[]+  type GLookupEntryPoint mode 'EPLeaf G.U1 = Fcf.ConstFn 'Nothing+  gMkEntryPointsNotes = (starNotes, noAnn)+  gMkEpLiftSequence _ = EpConstructionFailed++instance Each [Typeable, SingI] [GValueType x, GValueType y] =>+         GEntryPointsNotes mode 'EPLeaf (x G.:*: y) where+  type GAllEntryPoints mode 'EPLeaf (x G.:*: y) = '[]+  type GLookupEntryPoint mode 'EPLeaf (x G.:*: y) = Fcf.ConstFn 'Nothing+  gMkEntryPointsNotes = (starNotes, noAnn)+  gMkEpLiftSequence _ = EpConstructionFailed++-- Return 'Just' iff given entries of type @k1@ are equal.+type family JustOnEq (a :: k1) (b :: k2) :: k1 -> Exp (Maybe k2) where+  JustOnEq a b =+    Fcf.Flip Fcf.Guarded+      '[ TyEqSing a 'Fcf.:= Fcf.Pure ('Just b)+       , Fcf.Otherwise 'Fcf.:= Fcf.Pure 'Nothing+       ]++-- Get field type under 'G.C1'.+type family GExtractField (x :: Kind.Type -> Kind.Type) where+  GExtractField (G.S1 _ x) = GExtractField x+  GExtractField (G.Rec0 a) = a+  GExtractField G.U1 = ()
+ src/Lorentz/EntryPoints/Manual.hs view
@@ -0,0 +1,38 @@+-- | Allows specifying entrypoints without declaring 'ParamterHasEntryPoints'+-- instance.+module Lorentz.EntryPoints.Manual+  ( ParameterWrapper (..)+  ) where++import Control.Lens (Wrapped)+import qualified Data.Kind as Kind++import Lorentz.Constraints+import Lorentz.EntryPoints.Core+import Michelson.Typed++-- | Wrap parameter into this to locally assign a way to derive entrypoints for+-- it.+newtype ParameterWrapper (deriv :: Kind.Type) cp = ParameterWrapper { unParameterWraper :: cp }+  deriving stock Generic+  deriving anyclass IsoValue++instance Wrapped (ParameterWrapper deriv cp)++-- Helper for implementing @instance ParameterHasEntryPoints ParameterWrapper@.+data PwDeriv deriv+instance EntryPointsDerivation deriv cp =>+         EntryPointsDerivation (PwDeriv deriv) (ParameterWrapper deriv cp) where+  type EpdAllEntryPoints (PwDeriv deriv) (ParameterWrapper deriv cp) =+    EpdAllEntryPoints deriv cp+  type EpdLookupEntryPoint (PwDeriv deriv) (ParameterWrapper deriv cp) =+    EpdLookupEntryPoint deriv cp+  epdNotes = epdNotes @deriv @cp+  epdCall = epdCall @deriv @cp++instance ( NiceParameter cp+         , EntryPointsDerivation epd cp+         , RequireAllUniqueEntryPoints' epd cp+         ) =>+         ParameterHasEntryPoints (ParameterWrapper epd cp) where+  type ParameterEntryPointsDerivation (ParameterWrapper epd cp) = PwDeriv epd
+ src/Lorentz/Errors.hs view
@@ -0,0 +1,682 @@+{-# LANGUAGE TypeFamilyDependencies #-}++-- We want to make sure 'failUsingArg' is used with sane argument.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Lorentz.Errors+  ( -- * Haskell to 'Value' conversion+    IsError (..)+  , isoErrorToVal+  , isoErrorFromVal+  , ErrorHasDoc (..)+  , typeDocMdDescriptionReferToError++  , UnspecifiedError (..)++    -- * General instructions+  , failUsing+  , failUnexpected++    -- * Custom errors+  , ErrorArg+  , CustomError (..)+  , failCustom+  , RequireNoArgError+  , failCustom_++    -- * Documentation+  , ErrorClass (..)+  , CustomErrorHasDoc (..)+  , DError (..)+  , DThrows (..)++    -- * Old interface (DEPRECATED)+  , customErrorToVal+  , customErrorFromVal+  , failUsingArg+  , FailUsingArg+  , CustomErrorNoIsoValue+  , deriveCustomError++  , errorsDocumentation+  ) where++import qualified Data.Char as C+import Data.Constraint (Dict(..))+import qualified Data.Kind as Kind+import qualified Data.List as L+import Data.Singletons (SingI(..), demote)+import Data.Type.Equality (type (==))+import Data.Typeable (cast)+import Data.Vinyl.Derived (Label)+import Fmt (Buildable, build, fmt, pretty, (+|), (+||), (|+), (||+))+import GHC.TypeLits (ErrorMessage(..), KnownSymbol, Symbol, TypeError, symbolVal)+import qualified Language.Haskell.TH as TH+import qualified Text.Show++import Lorentz.Base+import Lorentz.Doc+import Lorentz.Instr hiding (cast)+import Lorentz.Value+import Michelson.Text+import Michelson.Typed.Haskell+import Michelson.Typed.Instr+import Michelson.Typed.Scope+import Michelson.Typed.Sing+import Michelson.Typed.T+import Michelson.Typed.Value+import Util.Markdown+import Util.Type+import Util.Typeable+import Util.TypeLits++----------------------------------------------------------------------------+-- IsError+----------------------------------------------------------------------------++type ErrorScope t =+  -- We can require a weaker constraint (e.g. no 'HasNoOp'), but+  -- for now it's the simplest way to make 'failUsing' work+  ( Typeable t+  , ConstantScope t+  )++type KnownError a = ErrorScope (ToT a)++-- | Haskell type representing error.+class (Typeable e, ErrorHasDoc e) => IsError e where++  -- | Converts a Haskell error into @Value@ representation.+  errorToVal :: e -> (forall t. ErrorScope t => Value t -> r) -> r++  -- | Converts a @Value@ into Haskell error.+  errorFromVal :: (Typeable t, SingI t) => Value t -> Either Text e++-- | Implementation of 'errorToVal' via 'IsoValue'.+isoErrorToVal+  :: (KnownError e, IsoValue e)+  => e -> (forall t. ErrorScope t => Value t -> r) -> r+isoErrorToVal e cont = cont $ toVal e++-- | Implementation of 'errorFromVal' via 'IsoValue'.+isoErrorFromVal+  :: (Typeable t, Typeable (ToT e), IsoValue e)+  => Value t -> Either Text e+isoErrorFromVal e = fromVal <$> gcastE e++class ErrorHasDoc e where+  -- | Name of error as it appears in the corresponding section title.+  errorDocName :: Text++  -- | What should happen for this error to be raised.+  errorDocMdCause :: Markdown++  -- | Brief version of 'errorDocMdCause'.+  --+  -- This will appear along with the error when mentioned in entrypoint description.+  -- By default, the first sentence of the full description is used.+  errorDocMdCauseInEntrypoint :: Markdown+  errorDocMdCauseInEntrypoint = pickFirstSentence $ errorDocMdCause @e++  -- | How this error is represented in Haskell.+  errorDocHaskellRep :: Markdown++  -- | Error class.+  errorDocClass :: ErrorClass+  errorDocClass = ErrClassUnknown++  -- | Which definitions documentation for this error mentions.+  errorDocDependencies :: [SomeDocDefinitionItem]++-- | Helper for managing descriptions.+pickFirstSentence :: Markdown -> Markdown+pickFirstSentence = build . toText . go . fmt+  where+    go :: String -> String+    go = \case+      '.' : c : _ | C.isSpace c -> "."+      c : s -> c : go s+      "" -> ""++-- Instances+----------------------------------------------------------------------------++-- | Use this for internal errors only.+--+-- "Normal" error scenarios should use the mechanism of custom errors, see below.+instance IsError MText where+  errorToVal = isoErrorToVal+  errorFromVal = isoErrorFromVal++instance ErrorHasDoc MText where+  errorDocName = "InternalError"+  errorDocMdCause =+    "Internal error occured."+  errorDocHaskellRep =+    "Textual error message, see " <>+    typeDocMdReference (Proxy @MText) (WithinParens False) <> "."+  errorDocClass = ErrClassContractInternal+  errorDocDependencies = [SomeDocDefinitionItem (DType $ Proxy @MText)]++instance TypeError ('Text "Use representative error messages") => IsError () where+  errorToVal _ _ = error "impossible"+  errorFromVal = error "impossible"++instance TypeError ('Text "Use representative error messages") => ErrorHasDoc () where+  errorDocName = error "impossible"+  errorDocMdCause = error "impossible"+  errorDocHaskellRep = error "impossible"+  errorDocDependencies = error "impossible"++-- | Use this type as replacement for @()@ when you __really__ want to leave+-- error cause unspecified.+data UnspecifiedError = UnspecifiedError+  deriving stock Generic+  deriving anyclass IsoValue++instance IsError UnspecifiedError where+  errorToVal = isoErrorToVal+  errorFromVal = isoErrorFromVal++instance ErrorHasDoc UnspecifiedError where+  errorDocName = "Unspecified error"+  errorDocMdCause = "Some error occured."+  errorDocHaskellRep = typeDocMdReference (Proxy @()) (WithinParens False) <> "."+  errorDocDependencies = typeDocDependencies' (Proxy @())++----------------------------------------------------------------------------+-- General instructions+----------------------------------------------------------------------------++-- | Fail with the given Haskell value.+failUsing+  :: forall e s t.+     (IsError e)+  => e -> s :-> t+failUsing err =+  errorToVal err $ \eval ->+    doc (DThrows (Proxy @e)) #+    (FI $ PUSH eval `Seq` FAILWITH)++-- | Fail, providing a reference to the place in the code where+-- this function is called.+--+-- Like 'error' in Haskell code, this instruction is for internal errors only.+failUnexpected :: MText -> s :-> t+failUnexpected msg = failUsing $ [mt|Internal: |] <> msg++----------------------------------------------------------------------------+-- Custom errors+----------------------------------------------------------------------------++{- | Declares a custom error, defining @error name - error argument@ relation.++If your error is supposed to carry no argument, then provide @()@.++Note that this relation is defined globally rather than on per-contract basis,+so define errors accordingly. If your error has argument specific to your+contract, call it such that error name reflects its belonging to this contract.+-}++{- About global registry of errors:++Pros: this allows defining pieces of code which can be reused among the contracts.++Cons: possible name collisions. Example of worst case: two libraries define+different errors for the same tag, attempt to use both of these libraries would+cause compile-time error. But such infrastructure will barely take place in+practice.+-}+{- For future work:++* Assosiating unique numeric error codes to tags, and put codes into+the contract instead of tags. This allows getting rid of overhead related to+often long tag literals.++* Allow using arbitrary type instead of tag (and 'KnownSymbol' constraint will+be replaced with a more generic one).+Some users may prefer using datatypes as tags rather than type-level strings as tags+because+  * there will be no orphan instances then+  * no problem with name collisions+  * compiler will prompt a hint in case of typo in tag name+  * in some cases autocomplete handles declarations in code better than strings+(and cons here is that each such tag will need to be declared first).++-}+type family ErrorArg (tag :: Symbol) :: Kind.Type++-- | Material custom error.+--+-- Use this in pattern matches against error (e.g. in tests).+data CustomError (tag :: Symbol) = CustomError+  { ceTag :: Label tag+  , ceArg :: ErrorArg tag+  }++deriving stock instance Eq (ErrorArg tag) => Eq (CustomError tag)+deriving stock instance Show (ErrorArg tag) => Show (CustomError tag)++-- | How 'CustomError' is actually represented in Michelson.+type CustomErrorRep tag = (MText, ErrorArg tag)++-- | This instance cannot be implemented, use 'IsError' instance instead.+instance TypeError ('Text "CustomError has no IsoValue instance") =>+         IsoValue (CustomError tag) where+  type ToT (CustomError tag) = TypeError ('Text "CustomError has no IsoValue instance")+  toVal = error "impossible"+  fromVal = error "impossible"++instance (CustomErrorHasDoc tag, KnownError (ErrorArg tag), IsoValue (ErrorArg tag)) =>+         IsError (CustomError tag) where+  errorToVal (CustomError l arg) cont =+    cont $ toVal @(CustomErrorRep tag) (errorTagToMText l, arg)+  errorFromVal (v :: Value t) =+    let expectedTag = errorTagToMText (fromLabel @tag)+    in case cast v of+        Just v' ->+          let (tag, arg) = fromVal @(CustomErrorRep tag) v'+          in if tag == expectedTag+             then Right $ CustomError fromLabel arg+             else Left $ "Bad tag, expected " +| expectedTag |+ ", got " +| tag |+ ""+        Nothing -> Left $ "Wrong type for custom error: " <> pretty (demote @t)++instance (CustomErrorHasDoc tag, SingI (ToT (ErrorArg tag))) =>+         ErrorHasDoc (CustomError tag) where+  errorDocName = errorTagToText @tag+  errorDocDependencies = [SomeDocDefinitionItem $ DType $ Proxy @(ErrorArg tag)]+  errorDocMdCause = customErrDocMdCause @tag+  errorDocMdCauseInEntrypoint = customErrDocMdCauseInEntrypoint @tag+  errorDocClass = customErrClass @tag+  errorDocHaskellRep =+    let hasArg = demote @(ToT (ErrorArg tag)) /= TUnit+        name = build $ errorTagToText @tag+    in mconcat $ catMaybes+      [ Just $+          ( if hasArg+            then mdTicked ("(\"" <> name <> "\", " <> "<error argument>" <> ")")+            else mdTicked ("(\"" <> name <> "\", ())")+          ) <> "."+      , guard hasArg $>+          ("\n\nProvided error argument will be of type "+          <> typeDocMdReference (Proxy @(ErrorArg tag)) (WithinParens False)+          <> (maybe "" (\txt -> " and stand for " <> txt) (customErrArgumentSemantics @tag))+          <> "."+          )+      ]++-- | Demote error tag to term level.+errorTagToMText :: KnownSymbol tag => Label tag -> MText+errorTagToMText l =+  -- Now tags come not from constructor names, but from labels,+  -- we have to lead the first letter to upper case to preserve+  -- compatibility with FA1.2 interface.+  mtextHeadToUpper $+    labelToMText l++errorTagToText :: forall tag. KnownSymbol tag => Text+errorTagToText = toText $ errorTagToMText (fromLabel @tag)++-- | Fail with given custom error.+failCustom+  :: forall tag err s any.+     ( err ~ ErrorArg tag+     , CustomErrorHasDoc tag+     , KnownError err+     )+  => Label tag -> err : s :-> any+failCustom l =+  doc (DThrows (Proxy @(CustomError tag))) #+  push (errorTagToMText l) # pair @MText @err #+  FI (FAILWITH @(ToT (CustomErrorRep tag)))++type RequireNoArgError tag msg =+  ( TypeErrorUnless (ErrorArg tag == ()) msg+  , msg ~+    ('Text "Expected no-arg error, but given error requires argument of type "+      ':<>: 'ShowType (ErrorArg tag)+    )+  )++-- | Specialization of 'failCustom' for no-arg errors.+failCustom_+  :: forall tag s any notVoidErrorMsg.+     ( RequireNoArgError tag notVoidErrorMsg+     , CustomErrorHasDoc tag+     )+  => Label tag -> s :-> any+failCustom_ l =+  inTypeErrorUnless @(ErrorArg tag == ()) @notVoidErrorMsg $+  reifyTypeEquality @(ErrorArg tag) @() $+    unit # failCustom l++-- Special treatment of no-arg errors+----------------------------------------------------------------------------++instance Eq (ErrorArg tag) => Eq (() -> CustomError tag) where+  e1 == e2 = e1 () == e2 ()+instance Show (ErrorArg tag) => Show (() -> CustomError tag) where+  show e = show (e ())++-- | If 'CustomError' constructor is not provided its argument, we assume+-- that this is no-arg error and interpret the passed value as complete.+instance ( Typeable arg+         , IsError (CustomError tag)+         , TypeErrorUnless (arg == ()) notVoidError+         , arg ~ ErrorArg tag+         , notVoidError ~+            ('Text "This error requires argument of type "+              ':<>: 'ShowType (ErrorArg tag)+            )+         ) =>+         IsError (arg -> CustomError tag) where+  errorToVal mkCustomError cont =+    inTypeErrorUnless @(arg == ()) @notVoidError $+    reifyTypeEquality @arg @() $+      errorToVal (mkCustomError ()) cont+  errorFromVal v =+    inTypeErrorUnless @(arg == ()) @notVoidError $+    reifyTypeEquality @arg @() $+      errorFromVal v <&> \(CustomError l ()) -> CustomError l++instance ErrorHasDoc (CustomError tag) => ErrorHasDoc (arg -> CustomError tag) where+  errorDocName = errorDocName @(CustomError tag)+  errorDocMdCauseInEntrypoint = errorDocMdCauseInEntrypoint @(CustomError tag)+  errorDocMdCause = errorDocMdCause @(CustomError tag)+  errorDocHaskellRep = errorDocHaskellRep @(CustomError tag)+  errorDocDependencies = errorDocDependencies @(CustomError tag)++----------------------------------------------------------------------------+-- Errors documentation injection into contracts+----------------------------------------------------------------------------++-- | Error class on how the error should be handled by the client.+data ErrorClass+  = ErrClassActionException+    -- ^ Normal expected error.+    -- Examples: "insufficient balance", "wallet does not exist".+  | ErrClassBadArgument+    -- ^ Invalid argument passed to entrypoint.+    -- Examples: your entrypoint accepts an enum represented as @nat@, and+    -- unknown value is provided.+    -- This includes more complex cases which involve multiple entrypoints.+    -- E.g. API provides iterator interface, middleware should care about using it+    -- hiding complex details and exposing a simpler API to user; then an attempt to+    -- request non-existing element would also correspond to an error from this class.+  | ErrClassContractInternal+    -- ^ Unexpected error. Most likely it means that there is a bug in+    -- the contract or the contract has been deployed incorrectly.+  | ErrClassUnknown+    -- ^ It's possible to leave error class unspecified.++instance Buildable ErrorClass where+  build = \case+    ErrClassActionException -> "Action exception"+    ErrClassBadArgument -> "Bad argument"+    ErrClassContractInternal -> "Internal"+    ErrClassUnknown -> "-"++isInternalErrorClass :: ErrorClass -> Bool+isInternalErrorClass = \case+  ErrClassActionException -> False+  ErrClassBadArgument -> False+  ErrClassContractInternal -> True+  ErrClassUnknown -> False++class (KnownSymbol tag, TypeHasDoc (ErrorArg tag), IsError (CustomError tag)) =>+      CustomErrorHasDoc tag where+  -- | What should happen for this error to be raised.+  customErrDocMdCause :: Markdown++  -- | Brief version of 'customErrDocMdCause'.+  -- This will appear along with the error when mentioned in entrypoint description.+  --+  -- By default, the first sentence of the full description is used.+  customErrDocMdCauseInEntrypoint :: Markdown+  customErrDocMdCauseInEntrypoint = pickFirstSentence $ customErrDocMdCause @tag++  -- | Error class.+  --+  -- By default this returns "unknown error" class; though you should provide+  -- explicit implementation in order to avoid a warning.+  customErrClass :: ErrorClass+  customErrClass = ErrClassUnknown++  -- | Clarification of error argument meaning.+  --+  -- Provide when it's not obvious, e.g. argument is not named with ':!'.+  --+  -- NOTE: This should /not/ be an entire sentence, rather just the semantic+  -- backbone.+  --+  -- Bad:+  -- * @Error argument stands for the previous value of approval.@+  --+  -- Good:+  -- * @the previous value of approval@+  -- * @pair, first argument of which is one thing, and the second is another@+  customErrArgumentSemantics :: Maybe Markdown+  customErrArgumentSemantics = Nothing+  {-# MINIMAL customErrDocMdCause, customErrClass #-}++-- | Mentions that contract uses given error.+data DError where+  DError :: IsError e => Proxy e -> DError++instance Eq DError where+  DError e1 == DError e2 = e1 `eqParam1` e2+instance Ord DError where+  DError e1 `compare` DError e2 = e1 `compareExt` e2++instance DocItem DError where+  type DocItemPosition DError = 5010+  type DocItemPlacement DError = 'DocItemInDefinitions+  docItemSectionName = Just "Errors"+  docItemSectionDescription = Just errorsDocumentation+  docItemRef (DError (_ :: Proxy e)) = DocItemRef $+    DocItemId ("errors-" <> errorDocName @e)+  docItemToMarkdown lvl (DError (_ :: Proxy e)) =+    mconcat+    [ mdSeparator+    , mdHeader lvl (mdTicked . build $ errorDocName @e)+    , mdSubsection "Class" (build $ errorDocClass @e)+    , "\n\n"+    , mdSubsection "Fires if" $ errorDocMdCause @e+    , "\n\n"+    , mdSubsection "Representation" $ errorDocHaskellRep @e+    ]+  docItemDependencies (DError (_ :: Proxy e)) = errorDocDependencies @e++errorDocMdReference :: forall e. IsError e => Markdown+errorDocMdReference =+  let DocItemRef (DocItemId anchor) = docItemRef $ DError (Proxy @e)+  in mdLocalRef (mdTicked . build $ errorDocName @e) anchor++-- | Documentation for custom errors.++-- | Mentions that entrypoint throws given error.+data DThrows where+  DThrows :: IsError e => Proxy e -> DThrows++instance Eq DThrows where+  DThrows e1 == DThrows e2 = eqParam1 e1 e2++instance DocItem DThrows where+  type DocItemPosition DThrows = 5011+  docItemSectionName = Just "Possible errors"+  docItemSectionNameStyle = DocSectionNameSmall+  docItemDependencies (DThrows ds) =+    [SomeDocDefinitionItem (DError ds)]+  docItemToMarkdown _ (DThrows (_ :: Proxy e)) =+    "* " <> errorDocMdReference @e <> " — " <> errorDocMdCauseInEntrypoint @e+  docItemsOrder =+    let errType (DThrows (_ :: Proxy e)) = errorDocClass @e+    in L.nub . filter (Prelude.not . isInternalErrorClass . errType)++-- | Implementation of 'typeDocMdDescription' (of 'TypeHasDoc' typeclass)+-- for Haskell types which sole purpose is to be error.+typeDocMdDescriptionReferToError :: forall e. IsError e => Markdown+typeDocMdDescriptionReferToError =+  "This type is primarily used as error, see " <>+  docDefinitionRef "description in section with errors" (DError (Proxy @e))++-- | This is to be included on top of @Errors@ section of the generated+-- documentation.+errorsDocumentation :: Markdown+errorsDocumentation = [md|+  Our contract implies the possibility of error scenarios, this section enlists+  all values which the contract can produce via calling `FAILWITH` instruction+  on them. In case of error, no changes to contract state will be applied.++  Each entrypoint also contains a list of errors which can be raised during its+  execution; only for no-throw entrypoints this list will be omitted.+  Errors in these lists are placed in the order in which the corresponding+  properties are checked unless the opposite is specified. I.e., if for a+  given entrypoint call two different errors may take place, the one which+  appears in the list first will be thrown.++  Most of the errors are represented according to the same+  `(error name, error argument)` pattern. See the list of errors below+  for details.++  We distinquish several error classes:+  + #{mdBold $ build ErrClassActionException}: given action cannot be performed with+    regard to the current contract state.++    Examples: "insufficient balance", "wallet does not exist".++    If you are implementing a middleware, such errors should be propagated to+    the client.++  + #{mdBold $ build ErrClassBadArgument}: invalid argument supplied to the entrypoint.++    Examples: entrypoint accepts a natural number from `0-3` range, and you+    supply `5`.++    If you are implementing a middleware, you should care about not letting+    such errors happen.++  + #{mdBold $ build ErrClassContractInternal}: contract-internal error.++    In ideal case, such errors should not take place, but still, make sure+    that you are ready to handle them. They can signal either invalid contract+    deployment or a bug in contract implementation.++    If an internal error is thrown, please report it to the author of this contract.+  |]++----------------------------------------------------------------------------+-- Old interface (DEPRECATED)+----------------------------------------------------------------------------++{- This API implements an approach when errors are declared via datatype+with constructors corresponding to error scenarios.+-}++-- | Implementation of 'errorToVal' for custom errors.+customErrorToVal+  :: (LooseSumC e, HasCallStack)+  => e+  -> (forall t. ErrorScope t => Value t -> r)+  -> r+customErrorToVal e cont =+  case toTaggedVal e of+    (tag, SomeValue (datVal :: Value t)) ->+      -- Tags come from constructors names, so we can assume+      -- the event of weird chars occurrence to be quite improbable+      let tag' = mkMTextUnsafe tag+      in case (opAbsense (sing @t), bigMapAbsense (sing @t), contractTypeAbsense (sing @t)) of+        (Just Dict, Just Dict, Just Dict) -> cont $ VPair (VC (CvString tag'), datVal)++        -- We could check this at type-level, but this would require+        -- specializing 'Michelson.Typed.LooseSum' to errors.+        -- We can do so, or assume that no one will ever try to put 'Operation'+        -- to error datatypes:+        (Nothing, _, _) -> error "Operation in constructor data"+        (_, Nothing, _) -> error "BigMap in constructor data"+        (_, _, Nothing) -> error "Contract in constructor data"+{-# DEPRECATED customErrorToVal "Datatype error declarations has been deprecated" #-}++-- | Implementation of 'errorFromVal' for custom errors.+--+-- This function is deprecated.+customErrorFromVal+  :: forall t e.+      (SingI t, LooseSumC e)+  => Value t -> Either Text e+customErrorFromVal v = case (v, sing @t) of+  (VPair (VC (CvString tag), datVal), STPair _ _) ->+    case fromTaggedVal (toText tag, SomeValue datVal) of+      ComposeOk e ->+        Right e+      ComposeCtorNotFound ->+        Left $ "Unknown error constructor " +| tag |+ ""+      ComposeFieldTypeMismatch got expected ->+        Left $ "Error data type mismatch, expected " +|| expected ||++                                            ", got " +|| got ||+ ""+  _ -> Left $ "Expected a (tag, dat) pair representing error"+{-# DEPRECATED customErrorFromVal "Datatype error declarations has been deprecated" #-}++-- | Prompt an error message saying that 'IsoValue' is not applicable for this type.+type family CustomErrorNoIsoValue a where+  CustomErrorNoIsoValue a = TypeError+    ('Text "No IsoValue instance for " ':<>: 'ShowType a ':$$:+     'Text "It has custom error representation")++-- | Derive 'IsError' instance for given type.+--+-- This will also forbid deriving 'IsoValue' instance for that type to avoid+-- having multiple different Michelson representations.+deriveCustomError :: TH.Name -> TH.Q [TH.Dec]+deriveCustomError name =+  [d|+    instance IsError $ty where+      errorToVal = customErrorToVal+      errorFromVal = customErrorFromVal++    instance CustomErrorNoIsoValue $ty => IsoValue $ty where+      type ToT $ty = CustomErrorNoIsoValue $ty+      toVal = error "impossible"+      fromVal = error "impossible"++    instance ErrorHasDoc $ty where+      errorDocName = "Some error"+      errorDocMdCause = "An error occurred."+      errorDocHaskellRep = "-"+      errorDocClass = ErrClassUnknown+      errorDocDependencies = []+  |]+  where+    ty = pure (TH.ConT name)+{-# DEPRECATED deriveCustomError "Datatype error declarations has been deprecated" #-}++-- | Signature of 'userFailWith'.+type FailUsingArg e name fieldTy s s'+  = ( KnownSymbol name, IsError e+    , IsoValue fieldTy+    , CtorHasOnlyField name e fieldTy, Each [Typeable, SingI] '[ToT fieldTy]+    , HasCallStack+    )+  => Label name -> fieldTy : s :-> s'++-- | Fail with given error, picking argument for error from the top+-- of the stack.+--+-- If your error constructor does not carry an argument, use 'failUsing'+-- function instead.+-- Consider the following practice: once error datatype for your contract+-- is defined, create a specialization of this function to the error type.+--+-- This function is deprecated.+failUsingArg+  :: forall err name fieldTy s s'.+     FailUsingArg err name fieldTy s s'+failUsingArg _ =+  push (mkMTextUnsafe ctor) #+  pair #+  failWith+  where+    ctor = case symbolVal (Proxy @name) of+      'c' : other -> toText other+      other -> error $ "Bad label provided: " +| other |+ ""+{-# DEPRECATED failUsingArg "Datatype error declarations has been deprecated" #-}
+ src/Lorentz/Errors/Common.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Some common errors.+--+-- Such registry makes sense, as soon as errors are declared globally.+module Lorentz.Errors.Common () where++import Fmt (Buildable(..))++import Lorentz.Errors++----------------------------------------------------------------------------+-- Authorization+----------------------------------------------------------------------------++-- | Contract initiator should be contract admin in order to perform this+-- operation.+type instance ErrorArg "senderIsNotAdmin" = ()++instance Buildable (CustomError "senderIsNotAdmin") where+  build (CustomError _ ()) =+    "This operation can be executed only by admin, but is invoked by \+    \someone else"++instance CustomErrorHasDoc "senderIsNotAdmin" where+  customErrClass = ErrClassActionException+  customErrDocMdCause =+    "Entrypoint executed not by its administrator."
+ src/Lorentz/Errors/Numeric.hs view
@@ -0,0 +1,174 @@+-- | By default we represent error tags using strings. This module+-- makes it possible to use numbers instead.+--+-- There are two possible ways to use it:+-- 1. If you have just one Lorentz instruction (potentially a big one),+-- just use 'useNumericErrors' function. It will change error representation+-- there and return a map that can be used to interpret new error codes.+-- 2. If your contract consists of multiple parts, start with gathering all+-- error tags ('gatherErrorTags'). Then build 'ErrorTagMap' using+-- 'addNewErrorTags'. Pass empty map if you are building from scratch+-- (you can use 'buildErrorTagMap' shortcut) or an existing+-- map if you have one (e. g. you are upgrading a contract).++module Lorentz.Errors.Numeric+  ( ErrorTagMap+  , ErrorTagExclusions+  , gatherErrorTags+  , addNewErrorTags+  , buildErrorTagMap+  , excludeErrorTags+  , applyErrorTagMap+  , applyErrorTagMapWithExclusions+  , useNumericErrors++  , errorFromValNumeric+  ) where++import Data.Bimap (Bimap)+import qualified Data.Bimap as Bimap+import Data.Default (def)+import qualified Data.HashSet as HS+import Data.Singletons (SingI, sing)+import Fmt (pretty)++import Lorentz.Base+import Lorentz.Errors+import Michelson.Analyzer+import Michelson.FailPattern+import Michelson.Text (MText)+import Michelson.Typed++-- | This is a bidirectional map with correspondence between numeric+-- and textual error tags.+type ErrorTagMap = Bimap Natural MText++-- | Tags excluded from map.+type ErrorTagExclusions = HashSet MText++-- | Find all textual error tags that are used in typical+-- @FAILWITH@ patterns within given instruction.+-- Map them to natural numbers.+gatherErrorTags :: inp :-> out -> HashSet MText+gatherErrorTags = HS.fromMap . void . arErrorTags . analyze . iAnyCode++-- | Add more error tags to an existing 'ErrorTagMap'. It is useful when+-- your contract consists of multiple parts (e. g. in case of contract+-- upgrade), you have existing map for some part and want to add tags+-- from another part to it.+-- You can pass empty map as existing one if you just want to build+-- 'ErrorTagMap' from a set of textual tags. See 'buildErrorTagMap'.+addNewErrorTags :: ErrorTagMap -> HashSet MText -> ErrorTagMap+addNewErrorTags existingMap newTags =+  foldl' (flip $ uncurry Bimap.tryInsert) existingMap newItems+  where+    firstUnusedNumeric+      | Bimap.null existingMap = 0+      | otherwise = fst (Bimap.findMax existingMap) + 1++    newItems :: [(Natural, MText)]+    newItems = zip [firstUnusedNumeric .. ] (toList newTags)++-- | Build 'ErrorTagMap' from a set of textual tags.+buildErrorTagMap :: HashSet MText -> ErrorTagMap+buildErrorTagMap = addNewErrorTags Bimap.empty++-- | Remove some error tags from map.+-- This way you say to remain these string tags intact, while others will be+-- converted to numbers when this map is applied.+--+-- Note that later you have to apply this map using+-- 'applyErrorTagMapWithExclusions', otherwise an error would be raised.+excludeErrorTags+  :: HasCallStack+  => ErrorTagExclusions -> ErrorTagMap -> ErrorTagMap+excludeErrorTags toExclude errMap =+  foldl' (flip deleteExistingR) errMap toExclude+  where+    deleteExistingR k m = case Bimap.lookupR k m of+      Just _ -> Bimap.deleteR k m+      Nothing ->+        error $ "Tag " <> show k <> " does not appear in the contract"++-- | For each typical 'FAILWITH' that uses a string to represent error+-- tag this function changes error tag to be a number using the+-- supplied conversion map.+-- It assumes that supplied map contains all such strings+-- (and will error out if it does not).+-- It will always be the case if you gather all error tags using+-- 'gatherErrorTags' and build 'ErrorTagMap' from them using 'addNewErrorTags'.+applyErrorTagMap :: HasCallStack => ErrorTagMap -> inp :-> out -> inp :-> out+applyErrorTagMap errorTagMap = applyErrorTagMapWithExclusions errorTagMap mempty++-- | Similar to 'applyErrorTagMap', but for case when you have excluded some+-- tags from map via 'excludeErrorTags'.+-- Needed, because both 'excludeErrorTags' and this function do not tolerate+-- unknown errors in contract code (for your safety).+applyErrorTagMapWithExclusions+  :: HasCallStack+  => ErrorTagMap -> ErrorTagExclusions -> inp :-> out -> inp :-> out+applyErrorTagMapWithExclusions errorTagMap exclusions =+  iMapAnyCode (applyErrorTagMapWithExcT errorTagMap exclusions)++-- | This function implements the simplest scenario of using this+-- module's functionality:+-- 1. Gather all error tags from a single instruction.+-- 2. Turn them into error conversion map.+-- 3. Apply this conversion.+useNumericErrors ::+  HasCallStack => inp :-> out -> (inp :-> out, ErrorTagMap)+useNumericErrors instr = (applyErrorTagMap errorTagMap instr, errorTagMap)+  where+    errorTagMap = buildErrorTagMap $ gatherErrorTags instr++-- This function works with 'Michelson.Typed' representation, not with Lorentz.+applyErrorTagMapWithExcT ::+     HasCallStack+  => ErrorTagMap+  -> ErrorTagExclusions+  -> Instr inp out+  -> Instr inp out+applyErrorTagMapWithExcT errorTagMap exclusions instr =+  dfsModifyInstr dfsSettings step instr+  where+    dfsSettings :: DfsSettings ()+    dfsSettings = def+      { dsGoToValues = True+      }++    tagToNatValue :: HasCallStack => MText -> SomeConstrainedValue ConstantScope'+    tagToNatValue tag =+      case (HS.member tag exclusions, Bimap.lookupR tag errorTagMap) of+        (True, _) -> SomeConstrainedValue (VC $ CvString tag)+        -- It will be applied to textual tags detected by 'modifyTypicalFailWith'.+        -- Here we assume that all of them are discovered by the analyzer.+        -- If this error ever happens, it means that someone used+        -- 'applyErrorTagMap' with incomplete 'ErrorTagMap' or there is an+        -- internal bug somewhere.+        (False, Nothing) -> error $ "Can't find a tag: " <> pretty tag+        (False, Just n) -> SomeConstrainedValue (VC $ CvNat n)++    step :: HasCallStack => Instr inp out -> Instr inp out+    step = modifyTypicalFailWith tagToNatValue++-- | If you apply numeric error representation in your contract, 'errorFromVal'+-- will stop working because it doesn't know about this+-- transformation.+-- This function takes this transformation into account.+-- If a number is used as a tag, but it is not found in the passed+-- map, we conservatively preserve that number (because this whole+-- approach is rather a heuristic).+errorFromValNumeric ::+  (Typeable t, SingI t, IsError e) => ErrorTagMap -> Value t -> Either Text e+errorFromValNumeric errorTagMap v =+  case v of+    VC (CvNat tag)+      | Just textualTag <- Bimap.lookup tag errorTagMap ->+        errorFromVal . VC . CvString $ textualTag+    VPair (VC (CvNat tag), something)+      | Just textualTag <- Bimap.lookup tag errorTagMap+      , _ :: Value pair <- v ->+        case sing @pair of+          STPair {} ->+            errorFromVal $ VPair (VC $ CvString textualTag, something)+    _ -> errorFromVal v
+ src/Lorentz/Ext.hs view
@@ -0,0 +1,39 @@+module Lorentz.Ext+  ( stackRef+  , printComment+  , testAssert+  , stackType+  ) where++import Data.Singletons (SingI)+import GHC.TypeNats (Nat)++import Lorentz.Base+import Michelson.Typed.Haskell+import Michelson.Typed.Instr+import Util.Peano hiding (Nat)++stackRef+  :: forall (gn :: Nat) st n.+      (n ~ ToPeano gn, SingI n, KnownPeano n, RequireLongerThan st n)+  => PrintComment st+stackRef = PrintComment . one . Right $ mkStackRef @gn++printComment :: PrintComment (ToTs s) -> s :-> s+printComment = I . Ext . PRINT++testAssert+  :: (Typeable (ToTs out), HasCallStack)+  => Text -> PrintComment (ToTs inp) -> inp :-> Bool & out -> inp :-> inp+testAssert msg comment = \case+  I instr -> I . Ext . TEST_ASSERT $ TestAssert msg comment instr+  FI _ -> error "test assert branch always fails"++stackType :: forall s. s :-> s+stackType = I Nop++_sample1 :: s ~ (a & s') => s :-> s+_sample1 = printComment $ "Head is " <> stackRef @0++_sample2 :: Integer & Natural & s :-> Integer & Natural & s+_sample2 = stackType @(Integer & _)
+ src/Lorentz/Extensible.hs view
@@ -0,0 +1,270 @@+{- | This module contains implementation of 'Extensible' values.++@Extensible@ values are an alternative representation of sum-types+for Michelson. Instead of representing them as nested options, we+treat them as (Natural, ByteString) pair, where the first element+of the pair represents the constructor index, while the second is+a packed argument.++With such a representation sum types can be easily upgraded: it is+possible to add new elements to the sum type, and the representation+would not change.++However, such representation essentially limits the applicability of+the values. This module does not provide Michelson-level function to+unwrap the value because it would require traversing all the possible+options in the contract code. While this is possible, it is very+inefficient. Up to this moment, we have not come up with a decent+reason to allow such behavior, so Extensible types are write-only+in Michelson code. They can be unwrapped off-chain with @fromExtVal@.++In order to preserve previous values during migrations, users should+ONLY APPEND items to the underlying sum type. Changing, reordering and+deleting items is not allowed and would lead to compatibility breakage.+Currently, this restriction in not enforced. Only no-argument and+one-argument constructors are supported.++GOOD:+  -- `Extensible GoodSumTypeV1` is backwards compatible+  -- with `Extensible GoodSumTypeV2`+  data GoodSumTypeV1 = A Natural | B+  data GoodSumTypeV2 = A Natural | B | C MText++BAD:+  -- `Extensible BadSumTypeV1` is NOT backwards compatible+  -- with `Extensible BadSumTypeV2`+  data BadSumTypeV1 = A | B+  data BadSumTypeV2 = A Natural | B | C MText+-}++{-# LANGUAGE InstanceSigs #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Lorentz.Extensible+  ( Extensible (..)+  , ExtConversionError (..)+  , ExtVal+  , ExtensibleHasDoc (..)+  , toExtVal+  , fromExtVal+  , wrapExt+  , WrapExtC+  ) where++import Data.Char (isSpace)+import qualified Data.Kind as Kind+import qualified Data.Text as T+import Data.Typeable (Proxy(..))+import Data.Vinyl.Derived (Label)+import Data.Vinyl.TypeLevel (type (++))+import Fmt (Buildable(build), (+||), (|+), (||+))+import GHC.Generics ((:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (AppendSymbol, Nat, Symbol)+import GHC.TypeNats (type (+))++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Constraints+import Lorentz.Instr+import Lorentz.Pack+import Michelson.Typed+import Util.Markdown+import Util.Type+import Util.TypeLits++newtype Extensible x = Extensible (Natural, ByteString)+  deriving stock (Generic, Eq, Show)+  deriving anyclass (IsoValue)++instance Wrapped (Extensible x)++type ExtVal x = (Generic x, GExtVal x (G.Rep x))+type GetCtors x = GGetCtors (G.Rep x)++-- | Converts a value from a Haskell representation to its+--   extensible Michelson representation (i.e. (Natural, Bytestring) pair).+toExtVal :: ExtVal a => a -> Extensible a+toExtVal = gToExtVal . G.from++-- | Converts a value from an extensible Michelson representation to its+--   Haskell sum-type representation. Fails if the Michelson representation+--   points to a nun-existent constructor, or if we failed to unpack+--   the argument.+fromExtVal :: ExtVal a => Extensible a -> Either ExtConversionError a+fromExtVal val = fmap G.to $ gFromExtVal val++-- | Helper typeclass which allows us to sanely handle cases of no-arg+-- constructor and constructor with one argument.+class WrapExt (cf :: CtorField) where+  -- | Pack argument on top of the stack, if any required.+  packForWrap :: AppendCtorField cf s :-> ByteString : s++instance (NicePackedValue param) =>+         WrapExt ('OneField param) where+  packForWrap = pack++instance WrapExt 'NoFields where+  packForWrap = unit # pack++-- | Wraps an argument on top of the stack into an Extensible representation+wrapExt+  :: forall t (n :: Nat) name field s.+     (WrapExtC t n name field s)+  => Label ("c" `AppendSymbol` name) -> AppendCtorField field s :-> Extensible t ': s+wrapExt _ = packForWrap @field # push (natVal (Proxy @n)) # pair # coerceWrap++type WrapExtC t n name field s =+  ( 'Ctor n name field ~ LookupCtor name (EnumerateCtors (GetCtors t))+  , WrapExt field+  , KnownNat n+  )++-- | Errors related to fromExtVal conversion+data ExtConversionError+  = ConstructorIndexNotFound Natural+  | ArgumentUnpackFailed+  deriving stock (Eq, Show)++instance Buildable ExtConversionError where+  build =+    \case+      ConstructorIndexNotFound idx ->+        "Could not convert Extensible value into its Haskell representation: \+        \constructor #" +|| idx ||+ " was not found in the sum type \+        \constructors list"+      ArgumentUnpackFailed ->+        "Could not convert Extensible value into its Haskell representation: \+        \failed to unpack constructor argument"++data Position = Position Nat+data Ctor = Ctor { _n :: Nat, _name :: Symbol, _param :: CtorField }+type CtorKind = (Symbol, CtorField)++-- | Finds the constructor's position and argument type by its name+type family LookupCtor (name :: Symbol) (entries :: [Ctor])+             :: Ctor where+  LookupCtor name ('Ctor pos name param ': _) = 'Ctor pos name param+  LookupCtor name (_ ': entries) =+    LookupCtor name entries+  LookupCtor name '[] =+    TypeError ('Text "Constructor " ':<>: 'ShowType name ':<>:+               'Text " is not in the sum type constructor list")++-- | Transform list of 'CtorKind's to list of 'Ctor's, assigning numbers+-- to elements starting from 0.+type EnumerateCtors ctors = EnumerateCtorsImpl ('Position 0) ctors++type family EnumerateCtorsImpl (pos :: Position) (ctors :: [CtorKind]) :: [Ctor] where+  EnumerateCtorsImpl _ '[] = '[]+  EnumerateCtorsImpl ('Position i) ('(name, param) ': cs) =+    'Ctor i name param ': EnumerateCtorsImpl ('Position (i + 1)) cs++-- | Having a sum-type, yields a type-level list of its constructors+type family GGetCtors (x :: Kind.Type -> Kind.Type) :: [CtorKind] where+  GGetCtors (G.D1 _ x) = GGetCtors x+  GGetCtors (G.C1 ('G.MetaCons name _1 _2) (G.S1 _3 (G.Rec0 param)))+    = '[ '(name, 'OneField param) ]+  GGetCtors (G.C1 ('G.MetaCons name _1 _2) G.U1)+    = '[ '(name, 'NoFields) ]+  GGetCtors (x :+: y) = GGetCtors x ++ GGetCtors y++-- | Generic implementation of toExtVal and fromExtVal+class GExtVal t (x :: Kind.Type -> Kind.Type) where+  gToExtVal :: x p -> Extensible t+  gFromExtVal :: Extensible t -> Either ExtConversionError (x p)++instance GExtVal t x => GExtVal t (G.D1 i x) where+  gToExtVal = gToExtVal @t . G.unM1+  gFromExtVal val = fmap G.M1 (gFromExtVal @t val)++instance ( 'Ctor n name 'NoFields ~ LookupCtor name (EnumerateCtors (GetCtors t))+         , KnownNat n+         )+         => GExtVal t (G.C1 ('G.MetaCons name _1 _2) G.U1) where+  gToExtVal (G.M1 G.U1) = Extensible+    ( natVal (Proxy @n)+    , lPackValue ()+    )+  gFromExtVal (Extensible (idx, _))+    | idx == natVal (Proxy @n)+        = Right $ G.M1 G.U1+    | otherwise = Left $ ConstructorIndexNotFound idx++instance ( NiceFullPackedValue param+         , 'Ctor n name ('OneField param) ~ LookupCtor name (EnumerateCtors (GetCtors t))+         , KnownNat n+         )+         => GExtVal t (G.C1 ('G.MetaCons name _1 _2) (G.S1 _3 (G.Rec0 param))) where+  gToExtVal (G.M1 (G.M1 (G.K1 param))) = Extensible+    ( natVal (Proxy @n)+    , lPackValue param+    )+  gFromExtVal (Extensible (idx, bs))+    | idx == natVal (Proxy @n)+        = first (\_ -> ArgumentUnpackFailed) $+          fmap (G.M1 . G.M1 . G.K1) $ lUnpackValue @param bs+    | otherwise = Left $ ConstructorIndexNotFound idx++instance (GExtVal t x, GExtVal t y) => GExtVal t (x :+: y) where+  gToExtVal = \case+    G.L1 x -> let Extensible val = gToExtVal @t x in Extensible val+    G.R1 y -> let Extensible val = gToExtVal @t y in Extensible val+  gFromExtVal val =+    let l = fmap G.L1 (gFromExtVal @t val)+        r = fmap G.R1 (gFromExtVal @t val)+    in l <> r++-- | Information to be provided for documenting some @'Extensible' x@.+class Typeable x => ExtensibleHasDoc x where+  -- | Implementation for 'typeDocName' of the corresponding @Extensible@.+  extensibleDocName :: Proxy x -> Text++  -- | Implementation for 'typeDocDependencies' of the corresponding @Extensible@.+  extensibleDocDependencies :: Proxy x -> [SomeTypeWithDoc]+  default extensibleDocDependencies+    :: (Generic x, GTypeHasDoc (G.Rep x))+    => Proxy x -> [SomeTypeWithDoc]+  extensibleDocDependencies = genericTypeDocDependencies++  -- | Overall description of this type.+  extensibleDocMdDescription :: Markdown++-- | Helper which documents single constructor.+class DocumentCtor (ctor :: Ctor) where+  documentCtor :: Proxy ctor -> Markdown+instance ( KnownNat pos, KnownSymbol name, TypeHasDoc param+         , param ~ ExtractCtorField field+         ) =>+         DocumentCtor ('Ctor pos name field) where+  documentCtor _ =+    natVal (Proxy @pos) |+ ": " <> mdBold (build $ symbolValT' @name) <>+    " " <> typeDocMdReference (Proxy @param) (WithinParens True)++instance ( ExtensibleHasDoc x+         , ReifyList DocumentCtor (EnumerateCtors (GetCtors x))+         ) => TypeHasDoc (Extensible x) where+  typeDocName _ = extensibleDocName (Proxy @x)+  typeDocMdReference p (WithinParens wp) =+    let name = typeDocName p+        safeName = case T.find isSpace name of+          Nothing -> name+          Just _+            | wp -> "(" <> name <> ")"+            | otherwise -> name+    in customTypeDocMdReference (safeName, DType p) [] (WithinParens False)+  typeDocDependencies _ = extensibleDocDependencies (Proxy @x)+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep+  typeDocMdDescription = mconcat+    [ extensibleDocMdDescription @x+    , "\n\n"+    , "For extensibility purposes this type is represented as `(idx, pack param)`, \+      \where `idx` is a natural number which designates constructor used to \+      \make up given value, and `param` is the argument carried in that \+      \constructor.\n\n"+    , "Value must be one of:\n\n"+    , mconcat $+        Prelude.map (<> "\n\n") $+        reifyList @Ctor @DocumentCtor @(EnumerateCtors (GetCtors x)) documentCtor+    ]
+ src/Lorentz/Instr.hs view
@@ -0,0 +1,691 @@+module Lorentz.Instr+  ( nop+  , drop+  , dropN+  , dup+  , swap+  , digPeano+  , dig+  , dug+  , push+  , some+  , none+  , unit+  , ifNone+  , pair+  , car+  , cdr+  , left+  , right+  , ifLeft+  , nil+  , cons+  , size+  , emptySet+  , emptyMap+  , emptyBigMap+  , map+  , iter+  , mem+  , get+  , update+  , failingWhenPresent+  , updateNew+  , if_+  , ifCons+  , loop+  , loopLeft+  , lambda+  , exec+  , execute+  , apply+  , dip+  , ConstraintDIPNLorentz+  , dipNPeano+  , dipN+  , failWith+  , cast+  , pack+  , unpack+  , concat+  , concat'+  , slice, isNat, add, sub, rsub, mul, ediv, abs+  , neg+  , lsl+  , lsr+  , or+  , and+  , xor+  , not+  , compare+  , eq0+  , neq0+  , lt0+  , gt0+  , le0+  , ge0+  , int+  , toTAddress_+  , self+  , selfCalling+  , contract+  , contractCalling+  , contractCallingUnsafe+  , runFutureContract+  , epAddressToContract+  , transferTokens+  , setDelegate+  , createContract+  , implicitAccount+  , now+  , amount+  , balance+  , checkSignature+  , sha256+  , sha512+  , blake2B+  , hashKey+  , stepsToQuota+  , source+  , sender+  , address+  , chainId+  , framed+  , LorentzFunctor (..)+  , nonZero+  ) where++import Prelude hiding+  (EQ, GT, LT, abs, and, compare, concat, drop, get, map, not, or, some, swap, xor)++import Data.Constraint (Dict(..), (\\))+import qualified Data.Kind as Kind+import Data.Singletons (SingI, sing)+import qualified GHC.TypeNats as GHC (Nat)++import Lorentz.Arith+import Lorentz.Base+import Lorentz.Constraints+import Lorentz.EntryPoints+import Lorentz.Polymorphic+import Lorentz.Run (compileLorentzContract)+import Lorentz.Value+import Lorentz.Zip+import Michelson.Typed+  (pattern CAR, pattern CDR, ConstraintDIG, ConstraintDIG', ConstraintDIPN, ConstraintDIPN',+  ConstraintDUG, ConstraintDUG', pattern DefEpName, EntryPointCallT(..), Instr(..), RemFail(..),+  SomeEntryPointCallT(..), ToTs, Value'(..), sepcName, starNotes)+import Michelson.Typed.Arith+import Michelson.Typed.Haskell.Value+import Util.Peano+import Util.Type++nop :: s :-> s+nop = I Nop++drop :: a & s :-> s+drop = I DROP++-- | Drop top @n@ elements from the stack.+dropN ::+  forall (n :: GHC.Nat) (s :: [Kind.Type]).+  -- Note: if we introduce `nPeano ~ ToPeano n` variable,+  -- GHC will complain that this constraint is redundant.+  ( SingI (ToPeano n), KnownPeano (ToPeano n)+  , RequireLongerOrSameLength (ToTs s) (ToPeano n)+  -- ↓ Kinda obvious, but not to GHC.+  , Drop (ToPeano n) (ToTs s) ~ ToTs (Drop (ToPeano n) s)+  ) => s :-> Drop (ToPeano n) s+dropN = I (DROPN $ sing @(ToPeano n))+  where+    _example :: '[ Integer, Integer, Integer ] :-> '[]+    _example = dropN @3++dup  :: a & s :-> a & a & s+dup = I DUP++swap :: a & b & s :-> b & a & s+swap = I SWAP++-- See a comment about `ConstraintDIPNLorentz'.+type ConstraintDIGLorentz (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type])+  (a :: Kind.Type) =+  ( ConstraintDIG n (ToTs inp) (ToTs out) (ToT a)+  , ConstraintDIG' Kind.Type n inp out a+  )++type ConstraintDUGLorentz (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type])+  (a :: Kind.Type) =+  ( ConstraintDUG n (ToTs inp) (ToTs out) (ToT a)+  , ConstraintDUG' Kind.Type n inp out a+  )++-- | Version of `dig` which uses Peano number.+-- It is inteded for internal usage in Lorentz.+digPeano ::+  forall (n :: Peano) inp out a.+  ( ConstraintDIGLorentz n inp out a+  ) => inp :-> out+digPeano = I (DIG $ sing @n)++dig ::+  forall (n :: GHC.Nat) inp out a.+  ( ConstraintDIGLorentz (ToPeano n) inp out a+  ) => inp :-> out+dig = digPeano @(ToPeano n)+  where+    _example ::+      '[ Integer, Integer, Integer, Bool ] :->+      '[ Bool, Integer, Integer, Integer ]+    _example = dig @3++dug ::+  forall (n :: GHC.Nat) inp out a.+  ( ConstraintDUGLorentz (ToPeano n) inp out a+  ) => inp :-> out+dug = I (DUG $ sing @(ToPeano n))+  where+    _example ::+      '[ Bool, Integer, Integer, Integer ] :->+      '[ Integer, Integer, Integer, Bool ]+    _example = dug @3++push :: forall t s . NiceConstant t => t -> (s :-> t & s)+push a = I $ PUSH (toVal a) \\ niceConstantEvi @t++some :: a & s :-> Maybe a & s+some = I SOME++none :: forall a s . KnownValue a => s :-> (Maybe a & s)+none = I NONE++unit :: s :-> () & s+unit = I UNIT++ifNone+  :: (s :-> s') -> (a & s :-> s') -> (Maybe a & s :-> s')+ifNone = iGenericIf IF_NONE++pair :: a & b & s :-> (a, b) & s+pair = I PAIR++car :: (a, b) & s :-> a & s+car = I CAR++cdr :: (a, b) & s :-> b & s+cdr = I CDR++left :: forall a b s. KnownValue b => a & s :-> Either a b & s+left = I LEFT++right :: forall a b s. KnownValue a => b & s :-> Either a b & s+right = I RIGHT++ifLeft+  :: (a & s :-> s') -> (b & s :-> s') -> (Either a b & s :-> s')+ifLeft = iGenericIf IF_LEFT++nil :: KnownValue p => s :-> List p & s+nil = I NIL++cons :: a & List a & s :-> List a & s+cons = I CONS++ifCons+  :: (a & List a & s :-> s') -> (s :-> s') -> (List a & s :-> s')+ifCons = iGenericIf IF_CONS++size :: SizeOpHs c => c & s :-> Natural & s+size = I SIZE++emptySet :: (KnownCValue e) => s :-> Set e & s+emptySet = I EMPTY_SET++emptyMap :: (KnownCValue k, KnownValue v)+         => s :-> Map k v & s+emptyMap = I EMPTY_MAP++emptyBigMap :: (KnownCValue k, KnownValue v)+            => s :-> BigMap k v & s+emptyBigMap = I EMPTY_BIG_MAP++map+  :: (MapOpHs c, IsoMapOpRes c b, HasCallStack)+  => (MapOpInpHs c & s :-> b & s) -> (c & s :-> MapOpResHs c b & s)+map (iNonFailingCode -> action) = I (MAP action)++iter+  :: (IterOpHs c, HasCallStack)+  => (IterOpElHs c & s :-> s) -> (c & s :-> s)+iter (iNonFailingCode -> action) = I (ITER action)++mem :: MemOpHs c => MemOpKeyHs c & c & s :-> Bool & s+mem = I MEM++get :: GetOpHs c => GetOpKeyHs c & c & s :-> Maybe (GetOpValHs c) & s+get = I GET++update :: UpdOpHs c => UpdOpKeyHs c & UpdOpParamsHs c & c & s :-> c & s+update = I UPDATE++if_ :: (s :-> s') -> (s :-> s') -> (Bool & s :-> s')+if_ = iGenericIf IF++loop :: (s :-> Bool & s) -> (Bool & s :-> s)+loop (iAnyCode -> b) = I (LOOP b)++loopLeft+  :: (a & s :-> Either a b & s) -> (Either a b & s :-> b & s)+loopLeft (iAnyCode -> b) = I (LOOP_LEFT b)++lambda+  :: (ZipInstrs [i, o], KnownValue (ZippedStack i), KnownValue (ZippedStack o))+  => (i :-> o) -> (s :-> (i :-> o) & s)+lambda instr = case zippingStack instr of+  I l -> I (LAMBDA . VLam $ RfNormal l)+  FI l -> I (LAMBDA . VLam $ RfAlwaysFails l)++exec :: a & Lambda a b & s :-> b & s+exec = I EXEC++-- | Similar to 'exec' but works for lambdas with arbitrary size of input+-- and output.+--+-- Note that this instruction has its arguments flipped, lambda goes first.+-- This seems to be the only reasonable way to achieve good inference.+execute+  :: forall i o s.+      (Each [KnownList, ZipInstr] [i, o])+  => ((i :-> o) : (i ++ s)) :-> (o ++ s)+execute = framed @s $+  dip (zipInstr @i) # swap # I EXEC # unzipInstr @o+  where+    _example+      :: ([Integer, Natural] :-> [(), ()]) : Integer : Natural : s+      :-> () : () : s+    _example = execute++apply+  :: forall a b c s.+     (NiceConstant a)+  => a & Lambda (a, b) c & s :-> Lambda b c & s+apply = I $ APPLY \\ niceConstantEvi @a++dip :: forall a s s'. HasCallStack => (s :-> s') -> (a & s :-> a & s')+dip (iNonFailingCode -> a) = I (DIP a)++-- Helper constraint we need for 'dipN'.+-- The first constraint here is sufficient to make 'dipN' compile.+-- However, it is not enough for good type inference. If we use only the first+-- constraint, '_example' below will not compile because GHC will not be able+-- to deduce type of the input stack for 'unit'.+-- It can only deduce that 'ToTs s0' is empty (where 's0' is input stack), but+-- 'ToTs' is not injective, hence 's0' is ambiguous.+-- So we need both and we merge them into one to avoid a warning about+-- a redundant constraint.+type ConstraintDIPNLorentz (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type])+  (s :: [Kind.Type]) (s' :: [Kind.Type]) =+  ( ConstraintDIPN n (ToTs inp) (ToTs out) (ToTs s) (ToTs s')+  , ConstraintDIPN' Kind.Type n inp out s s'+  )++-- | Version of `dipN` which uses Peano number.+-- It is inteded for internal usage in Lorentz.+dipNPeano ::+  forall (n :: Peano) (inp :: [Kind.Type]) (out :: [Kind.Type]) (s :: [Kind.Type]) (s' :: [Kind.Type]).+  ( ConstraintDIPNLorentz n inp out s s'+  ) => s :-> s' -> inp :-> out+dipNPeano (iNonFailingCode -> a) = I (DIPN (sing @n) a)++dipN ::+  forall (n :: GHC.Nat) (inp :: [Kind.Type]) (out :: [Kind.Type]) (s :: [Kind.Type]) (s' :: [Kind.Type]).+  ( ConstraintDIPNLorentz (ToPeano n) inp out s s'+  ) => s :-> s' -> inp :-> out+dipN = dipNPeano @(ToPeano n)+  where+    _example :: '[ Integer, Integer, Integer ] :-> '[ Integer, Integer, Integer, () ]+    _example = dipN @3 unit++failWith :: (KnownValue a) => a & s :-> t+failWith = FI FAILWITH++cast :: KnownValue a => (a & s :-> a & s)+cast = I CAST++pack+  :: forall a s. (NicePackedValue a)+  => a & s :-> ByteString & s+pack = I $ PACK \\ nicePackedValueEvi @a++unpack+  :: forall a s. (NiceUnpackedValue a)+  => ByteString & s :-> Maybe a & s+unpack = I $ UNPACK \\ niceUnpackedValueEvi @a++concat :: ConcatOpHs c => c & c & s :-> c & s+concat = I CONCAT++concat' :: ConcatOpHs c => List c & s :-> c & s+concat' = I CONCAT'++slice :: SliceOpHs c => Natural & Natural & c & s :-> Maybe c & s+slice = I SLICE++isNat :: Integer & s :-> Maybe Natural & s+isNat = I ISNAT++add+  :: ArithOpHs Add n m+  => n & m & s :-> ArithResHs Add n m & s+add = I ADD++sub+  :: ArithOpHs Sub n m+  => n & m & s :-> ArithResHs Sub n m & s+sub = I SUB++rsub+  :: ArithOpHs Sub n m+  => m & n & s :-> ArithResHs Sub n m & s+rsub = swap # sub++mul+  :: ArithOpHs Mul n m+  => n & m & s :-> ArithResHs Mul n m & s+mul = I MUL++ediv :: EDivOpHs n m+     => n & m & s+     :-> Maybe ((EDivOpResHs n m, EModOpResHs n m)) & s+ediv = I EDIV++abs :: UnaryArithOpHs Abs n => n & s :-> UnaryArithResHs Abs n & s+abs = I ABS++neg :: UnaryArithOpHs Neg n => n & s :-> UnaryArithResHs Neg n & s+neg = I NEG+++lsl+  :: ArithOpHs Lsl n m+  => n & m & s :-> ArithResHs Lsl n m & s+lsl = I LSL++lsr+  :: ArithOpHs Lsr n m+  => n & m & s :-> ArithResHs Lsr n m & s+lsr = I LSR++or+  :: ArithOpHs Or n m+  => n & m & s :-> ArithResHs Or n m & s+or = I OR++and+  :: ArithOpHs And n m+  => n & m & s :-> ArithResHs And n m & s+and = I AND++xor+  :: (ArithOpHs Xor n m)+  => n & m & s :-> ArithResHs Xor n m & s+xor = I XOR++not :: UnaryArithOpHs Not n => n & s :-> UnaryArithResHs Not n & s+not = I NOT++compare :: NiceComparable n+        => n & n & s :-> Integer & s+compare = I COMPARE++eq0 :: UnaryArithOpHs Eq' n => n & s :-> UnaryArithResHs Eq' n & s+eq0 = I EQ++neq0 :: UnaryArithOpHs Neq n => n & s :-> UnaryArithResHs Neq n & s+neq0 = I NEQ++lt0 :: UnaryArithOpHs Lt n => n & s :-> UnaryArithResHs Lt n & s+lt0 = I LT++gt0 :: UnaryArithOpHs Gt n => n & s :-> UnaryArithResHs Gt n & s+gt0 = I GT++le0 :: UnaryArithOpHs Le n => n & s :-> UnaryArithResHs Le n & s+le0 = I LE++ge0 :: UnaryArithOpHs Ge n => n & s :-> UnaryArithResHs Ge n & s+ge0 = I GE++int :: Natural & s :-> Integer & s+int = I INT++-- | Cast something appropriate to 'TAddress'.+-- TODO [TM-280]: try to move somewhere+toTAddress_+  :: (ToTAddress_ cp addr)+  => addr : s :-> TAddress cp : s+toTAddress_ = I Nop++-- | Something coercible to 'TAddress cp'.+type ToTAddress_ cp addr = (ToTAddress cp addr, ToT addr ~ ToT Address)++-- | Get a reference to the current contract.+--+-- Note that, similar to 'CONTRACT' instruction, in Michelson 'SELF' instruction+-- can accept an entrypoint as field annotation, and without annotation specified+-- it creates a @contract@ value which calls the default entrypoint.+--+-- This particular function carries the behaviour of @SELF@ before introduction+-- of lightweight entrypoints feature.+-- Thus the contract must __not__ have explicit "default" entrypoint for this to+-- work.+--+-- If you are going to call a specific entrypoint of the contract, see 'selfCalling'.+self+  :: forall p s.+      (NiceParameterFull p, ForbidExplicitDefaultEntryPoint p)+  => s :-> ContractRef p & s+self = I (SELF $ sepcCallRootChecked @p) \\ niceParameterEvi @p++-- | Make a reference to the current contract, maybe a specific entrypoint.+--+-- Note that, since information about parameter of the current contract is not+-- carried around, in this function you need to specify parameter type @p@+-- explicitly.+selfCalling+  :: forall p mname s.+     (NiceParameterFull p)+  => EntryPointRef mname+  -> s :-> ContractRef (GetEntryPointArgCustom p mname) & s+selfCalling epRef = I $+  withDict (niceParameterEvi @p) $+  case parameterEntryPointCallCustom @p epRef of+    epc@EntryPointCall{} -> SELF (SomeEpc epc)++-- | Get a reference to a contract by its address.+--+-- This instruction carries the behaviour of @CONTRACT@ before introduction+-- of lightweight entrypoints feature.+-- The contract must __not__ have explicit "default" entrypoint for this to work.+--+-- If you are going to call a specific entrypoint of the contract, see 'contractCalling'.+contract+  :: forall p addr s.+      ( NiceParameterFull p, ForbidExplicitDefaultEntryPoint p+      , ToTAddress_ p addr+      )+  => addr & s :-> Maybe (ContractRef p) & s+contract = I (CONTRACT starNotes epName) \\ niceParameterEvi @p+  where+    epName = sepcName (sepcCallRootChecked @p)++-- | Make a reference to a contract, maybe a specific entrypoint.+--+-- When calling this function, make sure that parameter type is known.+-- It's recommended that you supply 'TAddress' with a concrete parameter as the+-- stack argument.+contractCalling+  :: forall cp epRef epArg addr s.+     (HasEntryPointArg cp epRef epArg, ToTAddress_ cp addr)+  => epRef+  -> addr & s :-> Maybe (ContractRef epArg) & s+contractCalling epRef = I $+  case useHasEntryPointArg @cp @epRef @epArg epRef of+    (Dict, epName) -> CONTRACT starNotes epName++-- | Specialized version of 'contractCalling' for the case when you do+-- not have compile-time evidence of appropriate 'HasEntryPointArg'.+-- For instance, if you have untyped 'EpName' you can not have this+-- evidence (the value is only available in runtime).+-- If you have typed 'EntryPointRef', use 'eprName' to construct 'EpName'.+contractCallingUnsafe+  :: forall arg s.+     (NiceParameter arg)+  => EpName+  -> Address & s :-> Maybe (ContractRef arg) & s+contractCallingUnsafe epName = contractCalling (TrustEpName epName)++-- | Version of 'contract' instruction which may accept address with already+-- specified entrypoint name.+--+-- Also you cannot specify entrypoint name here because this could result in+-- conflict.+runFutureContract+  :: forall p s. (NiceParameter p)+  => FutureContract p & s :-> Maybe (ContractRef p) & s+runFutureContract =+  I Nop # epAddressToContract++-- | Similar to 'runFutureContract', works with 'EpAddress'.+--+-- Validity of such operation cannot be ensured at compile time.+epAddressToContract+  :: forall p s. (NiceParameter p)+  => EpAddress & s :-> Maybe (ContractRef p) & s+epAddressToContract =+  I (CONTRACT starNotes DefEpName) \\ niceParameterEvi @p++transferTokens+  :: forall p s. (NiceParameter p)+  => p & Mutez & ContractRef p & s :-> Operation & s+transferTokens = I $ TRANSFER_TOKENS \\ niceParameterEvi @p++setDelegate :: Maybe KeyHash & s :-> Operation & s+setDelegate = I SET_DELEGATE++createContract+  :: forall p g s. (NiceStorage g, NiceParameterFull p)+  => Contract p g+  -> Maybe KeyHash & Mutez & g & s+  :-> Operation & Address & s+createContract cntrc =+  I $ CREATE_CONTRACT (compileLorentzContract cntrc)+    \\ niceParameterEvi @p+    \\ niceStorageEvi @g++implicitAccount :: KeyHash & s :-> ContractRef () & s+implicitAccount = I IMPLICIT_ACCOUNT++now :: s :-> Timestamp & s+now = I NOW++amount :: s :-> Mutez & s+amount = I AMOUNT++balance :: s :-> Mutez & s+balance = I BALANCE++checkSignature :: PublicKey & Signature & ByteString & s :-> Bool & s+checkSignature = I CHECK_SIGNATURE++sha256 :: ByteString & s :-> ByteString & s+sha256 = I SHA256++sha512 :: ByteString & s :-> ByteString & s+sha512 = I SHA512++blake2B :: ByteString & s :-> ByteString & s+blake2B = I BLAKE2B++hashKey :: PublicKey & s :-> KeyHash & s+hashKey = I HASH_KEY++{-# WARNING stepsToQuota "STEPS_TO_QUOTA instruction is deprecated in Michelson 005" #-}+stepsToQuota :: s :-> Natural & s+stepsToQuota = I STEPS_TO_QUOTA++{-# WARNING source+    "Using `source` is considered a bad practice.\n\+\    Consider using `sender` instead until further investigation" #-}+source :: s :-> Address & s+source = I SOURCE++sender :: s :-> Address & s+sender = I SENDER++address :: ContractRef a & s :-> Address & s+address = I ADDRESS++chainId :: s :-> ChainId & s+chainId = I CHAIN_ID++-- | Execute given instruction on truncated stack.+--+-- This instruction requires you to specify the piece of stack to truncate+-- as type argument.+framed+  :: forall s i o.+      (KnownList i, KnownList o)+  => (i :-> o) -> ((i ++ s) :-> (o ++ s))+framed (iNonFailingCode -> i) =+  I $ FrameInstr (Proxy @(ToTs s)) i+    \\ totsKnownLemma @i+    \\ totsKnownLemma @o+    \\ totsAppendLemma @i @s+    \\ totsAppendLemma @o @s++----------------------------------------------------------------------------+-- Non-canonical instructions+----------------------------------------------------------------------------++-- | Helper instruction.+--+-- Checks whether given key present in the storage and fails if it is.+-- This instruction leaves stack intact.+failingWhenPresent+  :: forall c k s v st e.+     ( MemOpHs c, k ~ MemOpKeyHs c+     , KnownValue e+     , st ~ (k & v & c & s)+     )+  => (forall s0. k : s0 :-> e : s0)+  -> st :-> st+failingWhenPresent mkErr =+  dip (dip dup # swap) # swap # dip dup # swap # mem #+  if_ (mkErr # failWith) nop++-- | Like 'update', but throw an error on attempt to overwrite existing entry.+updateNew+  :: forall c k s e.+     ( UpdOpHs c, MemOpHs c, k ~ UpdOpKeyHs c, k ~ MemOpKeyHs c+     , KnownValue e+     )+  => (forall s0. k : s0 :-> e : s0)+  -> k & UpdOpParamsHs c & c & s :-> c & s+updateNew mkErr = failingWhenPresent mkErr # update++class LorentzFunctor (c :: Kind.Type -> Kind.Type) where+  lmap :: KnownValue b => (a : s :-> b : s) -> (c a : s :-> c b : s)++instance LorentzFunctor Maybe where+  lmap f = ifNone none (f # some)++class NonZero t where+  -- | Retain the value only if it is not zero.+  nonZero :: t : s :-> Maybe t : s++instance NonZero Integer where+  nonZero = dup # eq0 # if_ (drop # none) some++instance NonZero Natural where+  nonZero = dup # int # eq0 # if_ (drop # none) some
+ src/Lorentz/Macro.hs view
@@ -0,0 +1,687 @@+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Common Michelson macros defined using Lorentz syntax.+module Lorentz.Macro+  ( -- * Compare+    NiceComparable+  , eq+  , neq+  , lt+  , gt+  , le+  , ge+  , ifEq0+  , ifGe0+  , ifGt0+  , ifLe0+  , ifLt0+  , ifNeq0+  , ifEq+  , ifGe+  , ifGt+  , ifLe+  , ifLt+  , ifNeq++  -- * Fail+  , fail_++  -- * Assertion macros+  -- |+  -- They differ from the same macros in Michelson, because those+  -- macros use FAIL macro which is not informative (fails with unit).+  -- If you __really__ want Michelson versions (maybe to produce exact+  -- copy of an existing contract), you can pass 'UnspecifiedError', then+  -- FAILWITH will be called with unit.+  , assert+  , assertEq0+  , assertNeq0+  , assertLt0+  , assertGt0+  , assertLe0+  , assertGe0+  , assertEq+  , assertNeq+  , assertLt+  , assertGt+  , assertLe+  , assertGe+  , assertNone+  , assertSome+  , assertLeft+  , assertRight+  , assertUsing++  -- * Syntactic Conveniences+  , dropX+  , cloneX+  , duupX+  , framedN+  , caar+  , cadr+  , cdar+  , cddr+  , ifRight+  , ifSome+  , when_+  , unless_+  , whenSome+  , mapCar+  , mapCdr+  , papair+  , ppaiir+  , unpair+  , setCar+  , setCdr+  , setInsert+  , mapInsert+  , setInsertNew+  , mapInsertNew+  , deleteMap+  , setDelete++  -- * Additional Morley macros+  , View (..)+  , Void_ (..)+  , VoidResult(..)+  , view_+  , mkView+  , wrapView+  , unwrapView+  , void_+  , mkVoid++  -- * Buildable utils for additional Morley macros+  , buildView+  , buildViewTuple++  -- * Macros for working with @address@ and @contract@-like types+  , addressToEpAddress+  , pushContractRef+  ) where++import Prelude hiding (compare, drop, some, swap)++import qualified Data.Kind as Kind+import Data.Singletons (SingI(..))+import Data.Vinyl.TypeLevel (Nat(..))+import Fmt (Buildable(..), Builder, pretty, tupleF, (+|), (|+))+import Fmt.Internal.Tuple (TupleF)+import GHC.TypeNats (type (-))+import qualified GHC.TypeNats as GHC (Nat)++import Lorentz.Arith+import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Constraints+import Lorentz.Doc+import Lorentz.Errors+import Lorentz.Ext (stackType)+import Lorentz.Instr+import Lorentz.Value+import Michelson.Typed (ConstraintDIG', ConstraintDIPN', T, typeDocDependencies')+import Michelson.Typed.Arith+import Michelson.Typed.Haskell.Value+import Util.Markdown+import Util.Peano+import Util.Type++----------------------------------------------------------------------------+-- Compare+----------------------------------------------------------------------------++eq :: NiceComparable n+   => n & n & s :-> Bool & s+eq = compare # eq0++neq :: NiceComparable n+   => n & n & s :-> Bool & s+neq = compare # neq0++gt :: NiceComparable n+   => n & n & s :-> Bool & s+gt = compare # gt0++le :: NiceComparable n+   => n & n & s :-> Bool & s+le = compare # le0++ge :: NiceComparable n+   => n & n & s :-> Bool & s+ge = compare # ge0++lt :: NiceComparable n+   => n & n & s :-> Bool & s+lt = compare # lt0++type IfCmp0Constraints a op =+  (UnaryArithOpHs op a, (UnaryArithResHs op a ~ Bool), SingI (ToCT a))++ifEq0+  :: (IfCmp0Constraints a Eq')+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifEq0 l r = eq0 # if_ l r++ifNeq0+  :: (IfCmp0Constraints a Neq)+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifNeq0 l r = neq0 # if_ l r++ifLt0+  :: (IfCmp0Constraints a Lt)+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifLt0 l r = lt0 # if_ l r++ifGt0+  :: (IfCmp0Constraints a Gt)+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifGt0 l r = gt0 # if_ l r++ifLe0+  :: (IfCmp0Constraints a Le)+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifLe0 l r = le0 # if_ l r++ifGe0+  :: (IfCmp0Constraints a Ge)+  => (s :-> s') -> (s :-> s') -> (a & s :-> s')+ifGe0 l r = ge0 # if_ l r++ifEq+  :: (NiceComparable a)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')+ifEq l r = eq # if_ l r++ifNeq+  :: (NiceComparable a)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')+ifNeq l r = neq # if_ l r++ifLt+  :: (NiceComparable a)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')+ifLt l r = lt # if_ l r++ifGt+  :: (NiceComparable a)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')+ifGt l r = gt # if_ l r++ifLe+  :: (NiceComparable a)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')+ifLe l r = le # if_ l r++ifGe+  :: (NiceComparable a)+  => (s :-> s') -> (s :-> s') -> (a & a & s :-> s')+ifGe l r = ge # if_ l r++----------------------------------------------------------------------------+-- Fail+----------------------------------------------------------------------------++-- | Analog of the FAIL macro in Michelson. Its usage is discouraged+-- because it doesn't carry any information about failure.+{-# WARNING fail_ "'fail_' remains in code" #-}+fail_ :: a :-> c+fail_ = unit # failWith++----------------------------------------------------------------------------+-- Assertions+----------------------------------------------------------------------------++assert :: IsError err => err -> Bool & s :-> s+assert reason = if_ nop (failUsing reason)++assertEq0 :: (IfCmp0Constraints a Eq', IsError err) => err -> a & s :-> s+assertEq0 reason = ifEq0 nop (failUsing reason)++assertNeq0 :: (IfCmp0Constraints a Neq, IsError err) => err -> a & s :-> s+assertNeq0 reason = ifNeq0 nop (failUsing reason)++assertLt0 :: (IfCmp0Constraints a Lt, IsError err) => err -> a & s :-> s+assertLt0 reason = ifLt0 nop (failUsing reason)++assertGt0 :: (IfCmp0Constraints a Gt, IsError err) => err -> a & s :-> s+assertGt0 reason = ifGt0 nop (failUsing reason)++assertLe0 :: (IfCmp0Constraints a Le, IsError err) => err -> a & s :-> s+assertLe0 reason = ifLe0 nop (failUsing reason)++assertGe0 :: (IfCmp0Constraints a Ge, IsError err) => err -> a & s :-> s+assertGe0 reason = ifGe0 nop (failUsing reason)++assertEq :: (NiceComparable a, IsError err) => err -> a & a & s :-> s+assertEq reason = ifEq nop (failUsing reason)++assertNeq :: (NiceComparable a, IsError err) => err -> a & a & s :-> s+assertNeq reason = ifNeq nop (failUsing reason)++assertLt :: (NiceComparable a, IsError err) => err -> a & a & s :-> s+assertLt reason = ifLt nop (failUsing reason)++assertGt :: (NiceComparable a, IsError err) => err -> a & a & s :-> s+assertGt reason = ifGt nop (failUsing reason)++assertLe :: (NiceComparable a, IsError err) => err -> a & a & s :-> s+assertLe reason = ifLe nop (failUsing reason)++assertGe :: (NiceComparable a, IsError err) => err -> a & a & s :-> s+assertGe reason = ifGe nop (failUsing reason)++assertNone :: IsError err => err -> Maybe a & s :-> s+assertNone reason = ifNone nop (failUsing reason)++assertSome :: IsError err => err -> Maybe a & s :-> a & s+assertSome reason = ifNone (failUsing reason) nop++assertLeft :: IsError err => err -> Either a b & s :-> a & s+assertLeft reason = ifLeft nop (failUsing reason)++assertRight :: IsError err => err -> Either a b & s :-> b & s+assertRight reason = ifLeft (failUsing reason) nop++assertUsing+  :: IsError a+  => a -> Bool & s :-> s+assertUsing err = if_ nop $ failUsing err++----------------------------------------------------------------------------+-- Syntactic Conveniences+----------------------------------------------------------------------------++-- | Custom Lorentz macro that drops element with given index+-- (starting from 0) from the stack.+dropX+  :: forall (n :: GHC.Nat) a inp out s s'.+  ( ConstraintDIPNLorentz (ToPeano n) inp out s s'+  , s ~ (a ': s')+  )+  => inp :-> out+dropX = dipN @n @inp @out @s @s' drop++class CloneX (n :: Peano) a s where+  type CloneXT n a s :: [Kind.Type]+  cloneXImpl :: a & s :-> CloneXT n a s+instance CloneX 'Z a s where+  type CloneXT 'Z a s = a & s+  cloneXImpl = nop+instance (CloneX n a s) => CloneX ('S n) a s where+  type CloneXT ('S n) a s = a ': CloneXT n a s+  cloneXImpl = dup # dip (cloneXImpl @n)++-- | Duplicate the top of the stack @n@ times.+--+-- For example, `cloneX @3` has type `a & s :-> a & a & a & a & s`.+cloneX+  :: forall (n :: GHC.Nat) a s. CloneX (ToPeano n) a s+  => a & s :-> CloneXT (ToPeano n) a s+cloneX = cloneXImpl @(ToPeano n)++-- | Kind-agnostic constraint for duupX+type DuupXConstraint' kind (n :: Peano)+  (s :: [kind]) (a :: kind) (s1 :: [kind]) (tail :: [kind]) =+  ( tail ~ Drop ('S n) s+  , ConstraintDIPN' kind n s s1 (a ': tail) (a ': a ': tail)+  , ConstraintDIG' kind n s1 (a ': s) a+  )++-- | Constraint for duupX that combines kind-agnostic constraint for+-- Lorentz (Haskell) types and for our typed Michelson.+type ConstraintDuupXLorentz (n :: Peano)+  (s :: [Kind.Type]) (a :: Kind.Type)+  (s1 :: [Kind.Type]) (tail :: [Kind.Type]) =+  ( DuupXConstraint' T n (ToTs s) (ToT a) (ToTs s1) (ToTs tail)+  , DuupXConstraint' Kind.Type n s a s1 tail+  )++class DuupX (n :: Peano) (s :: [Kind.Type]) (a :: Kind.Type) s1 tail where+  duupXImpl :: s :-> a ': s++instance {-# OVERLAPPING #-} (s ~ (a ': xs)) => DuupX ('S 'Z) s a s1 tail where+  duupXImpl = dup++instance {-# OVERLAPPING #-} DuupX ('S ('S 'Z)) (b ': a ': xs) a s1 tail where+  duupXImpl = dip dup # swap++instance {-# OVERLAPPABLE #-} (ConstraintDuupXLorentz ('S ('S n)) s a s1 tail) =>+  DuupX ('S ('S ('S n))) s a s1 tail where+  duupXImpl =+    -- 'stackType' helps GHC deduce types+    dipNPeano @('S ('S n)) (dup # stackType @(a ': a ': tail)) #+    digPeano @('S ('S n))++-- | @DUU+P@ macro. For example, `duupX @3` is `DUUUP`, it puts+-- the 3-rd (starting from 1) element to the top of the stack.+-- Note that it is implemented differently for `n ≤ 2` and for `n > 2`.+-- In the latter case it is implemented using `dipN`, `dig` and `dup`.+-- In the former case it uses specialized versions.+-- There is also a minor difference with the implementation of `DUU*P` in+-- Michelson.+-- They implement `DUUUUP` as `DIP 3 { DUP }; DIG 4`.+-- We implement it as `DIP 3 { DUP }; DIG 3`. These are equivalent.+-- Our version is supposedly cheaper, at least it should be packed+-- more efficiently due to the way numbers are packed.+duupX :: forall (n :: GHC.Nat) a (s :: [Kind.Type]) (s1 :: [Kind.Type]) (tail :: [Kind.Type]).+  ( ConstraintDuupXLorentz (ToPeano (n - 1)) s a s1 tail+  , DuupX (ToPeano n) s a s1 tail+  )+  => s :-> a ': s+duupX = duupXImpl @(ToPeano n) @s @a @s1 @tail+  where+    _example ::+      '[ Integer, (), Bool ] :->+      '[ Bool, Integer, (), Bool ]+    _example = duupX @3++-- | Version of 'framed' which accepts number of elements on input stack+-- which should be preserved.+--+-- You can treat this macro as calling a Michelson function with given number+-- of arguments.+framedN+  :: forall n nNat s i i' o o'.+     ( nNat ~ ToPeano n+     , i' ~ Take nNat i, s ~ Drop nNat i+     , i ~ (i' ++ s), o ~ (o' ++ s)+     , KnownList i', KnownList o'+     )+  => (i' :-> o') -> (i :-> o)+framedN = framed @s+  where+  _example+    :: [Integer, Natural] :-> '[ByteString]+    -> Integer : Natural : () : s :-> ByteString : () : s+  _example = framedN @2++papair :: a & b & c & s :-> ((a, b), c) & s+papair = pair # pair++ppaiir :: a & b & c & s :-> (a, (b, c)) & s+ppaiir = dip pair # pair++unpair :: (a, b) & s :-> a & b & s+unpair = dup # car # dip cdr++cdar :: (a1, (a2, b)) & s :-> a2 & s+cdar = cdr # car++cddr :: (a1, (a2, b)) & s :-> b & s+cddr = cdr # cdr++caar :: ((a, b1), b2) & s :-> a & s+caar = car # car++cadr :: ((a, b1), b2) & s :-> b1 & s+cadr = car # cdr++setCar :: (a, b1) & (b2 & s) :-> (b2, b1) & s+setCar = cdr # swap # pair++setCdr :: (a, b1) & (b2 & s) :-> (a, b2) & s+setCdr = car # pair++mapCar+  :: a & s :-> a1 & s+  -> (a, b) & s :-> (a1, b) & s+mapCar op = dup # cdr # dip (car # op) # swap # pair++mapCdr+  :: b & (a, b) & s :-> b1 & (a, b) & s+  -> (a, b) & s :-> (a, b1) & s+mapCdr op = dup # cdr # op # swap # car # pair++ifRight :: (b & s :-> s') -> (a & s :-> s') -> (Either a b & s :-> s')+ifRight l r = ifLeft r l++ifSome+  :: (a & s :-> s') -> (s :-> s') -> (Maybe a & s :-> s')+ifSome s n = ifNone n s++when_ :: (s :-> s) -> (Bool : s :-> s)+when_ i = if_ i nop++unless_ :: (s :-> s) -> (Bool : s :-> s)+unless_ i = if_ nop i++whenSome :: (a : s :-> s) -> (Maybe a : s :-> s)+whenSome i = ifSome i nop++-- | Various convenient instructions on maps.+class MapInstrs map where+  -- | Specialized version of 'update'.+  mapUpdate :: IsComparable k => k : Maybe v : map k v : s :-> map k v : s++  -- | Insert given element into map.+  mapInsert :: IsComparable k => k : v : map k v : s :-> map k v : s+  mapInsert = dip some # mapUpdate++  -- | Insert given element into map, ensuring that it does not overwrite+  -- any existing entry.+  --+  -- As first argument accepts container name (for error message).+  mapInsertNew+    :: (IsComparable k, KnownValue e)+    => (forall s0. k : s0 :-> e : s0)+    -> k : v : map k v : s :-> map k v : s++  -- | Delete element from the map.+  deleteMap+    :: forall k v s. (IsComparable k, KnownValue k, KnownValue v)+    => k : map k v : s :-> map k v : s+  deleteMap = dip (none @v) # mapUpdate++instance MapInstrs Map where+  mapUpdate = update+  mapInsertNew mkErr = failingWhenPresent mkErr # mapInsert+instance MapInstrs BigMap where+  mapUpdate = update+  mapInsertNew mkErr = failingWhenPresent mkErr # mapInsert++-- | Insert given element into set.+--+-- This is a separate function from 'updateMap' because stacks they operate with+-- differ in length.+setInsert :: IsComparable e => e & Set e & s :-> Set e & s+setInsert = dip (push True) # update++-- | Insert given element into set, ensuring that it does not overwrite+-- any existing entry.+--+-- As first argument accepts container name.+setInsertNew+  :: (IsComparable e, KnownValue err)+  => (forall s0. e : s0 :-> err : s0)+  -> e & Set e & s :-> Set e & s+setInsertNew desc = dip (push True) # failingWhenPresent desc # update++-- | Delete given element from the set.+setDelete :: IsComparable e => e & Set e & s :-> Set e & s+setDelete = dip (push False) # update++----------------------------------------------------------------------------+-- Additional Morley macros+----------------------------------------------------------------------------++-- | @view@ type synonym as described in A1.+data View (a :: Kind.Type) (r :: Kind.Type) = View+  { viewParam :: a+  , viewCallbackTo :: ContractRef r+  } deriving stock (Eq, Show, Generic)+    deriving anyclass IsoValue++instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (View a r) where+  typeDocMdDescription =+    "`View a r` accepts an argument of type `a` and callback contract \+    \which accepts `r` and returns result via calling that contract.\n\+    \Read more in [A1 conventions document](https://gitlab.com/tzip/tzip/-/blob/c42e3f0f5e73669e84e615d69bee73281572eb0a/proposals/tzip-4/tzip-4.md#view-entrypoints)."+  typeDocMdReference = poly2TypeDocMdReference+  typeDocDependencies p =+    genericTypeDocDependencies p <>+    [SomeTypeWithDoc (Proxy @()), SomeTypeWithDoc (Proxy @Integer)]+  typeDocHaskellRep =+    haskellRepNoFields $ concreteTypeDocHaskellRep @(View () Integer)+  typeDocMichelsonRep =+    concreteTypeDocMichelsonRep @(View () Integer)++instance {-# OVERLAPPABLE #-} Buildable a => Buildable (View a r) where+  build = buildView build++instance {-# OVERLAPPING  #-} Buildable (View () r) where+  build = buildView $ const "()"++buildViewTuple :: TupleF a => View a r -> Builder+buildViewTuple = buildView tupleF++buildView :: (a -> Builder) -> View a r -> Builder+buildView bfp (View {..}) =+  "(View param: " +| bfp viewParam |+ " callbackTo: " +| viewCallbackTo|+ ")"++-- | Polymorphic version of 'View' constructor.+mkView :: ToContractRef r contract => a -> contract -> View a r+mkView a c = View a (toContractRef c)++-- | Wrap internal representation of view into 'View' itself.+--+-- 'View' is part of public standard and should not change often.+wrapView :: (a, ContractRef r) : s :-> View a r : s+wrapView = forcedCoerce_++-- | Unwrap 'View' into its internal representation.+--+-- 'View' is part of public standard and should not change often.+unwrapView :: View a r : s :-> (a, ContractRef r) : s+unwrapView = forcedCoerce_++view_ ::+     (NiceParameter r)+  => (forall s0. (a, storage) & s0 :-> r : s0)+  -> View a r & storage & s :-> (List Operation, storage) & s+view_ code =+  unwrapView #+  unpair # dip (duupX @2) # pair # code # dip amount #+  transferTokens # nil # swap # cons # pair++-- | @void@ type synonym as described in A1.+data Void_ (a :: Kind.Type) (b :: Kind.Type) = Void_+  { voidParam :: a+    -- ^ Entry point argument.+  , voidResProxy :: Lambda b b+    -- ^ Type of result reported via 'failWith'.+  } deriving stock (Generic, Show)+    deriving anyclass IsoValue++instance Each [Typeable, TypeHasDoc] [a, r] => TypeHasDoc (Void_ a r) where+  typeDocName _ = "Void"+  typeDocMdDescription =+    "`Void a r` accepts an argument of type `a` and returns a value of type \+    \`r` as contract error. To comply with general mechanism of contracts \+    \custom errors, void entrypoints execute `FAILWITH` instruction on \+    \`(\"VoidResult\", r)` value, where `r` is the actual return value of the \+    \entrypoint.\n\+    \Read more in [A1 conventions document](https://gitlab.com/tzip/tzip/-/blob/c42e3f0f5e73669e84e615d69bee73281572eb0a/proposals/tzip-4/tzip-4.md#void-entrypoints)."+  typeDocMdReference tp =+    -- Avoiding trailing underscore+    customTypeDocMdReference+      ("Void", DType tp)+      [ DType (Proxy @a)+      , DType (Proxy @r)+      ]+  typeDocDependencies p =+    genericTypeDocDependencies p <>+    [SomeTypeWithDoc (Proxy @()), SomeTypeWithDoc (Proxy @Integer)]+  typeDocHaskellRep p = do+    (_, rhs) <- haskellRepNoFields (concreteTypeDocHaskellRep @(Void_ () Integer)) p+    return (Just "Void () Integer", rhs)+  typeDocMichelsonRep p =+    let (_, rhs) = concreteTypeDocMichelsonRep @(Void_ () Integer) p+    in (Just "Void () Integer", rhs)++instance Buildable a => Buildable (Void_ a b) where+  build Void_ {..} = "(Void param: " +| voidParam |+ ")"++-- | Newtype over void result type used in tests to+-- distinguish successful void result from other errors.+--+-- Usage example:+-- lExpectFailWith (== VoidResult roleMaster)`+--+-- This error is special - it can contain arguments of different types+-- depending on entrypoint which raises it.+newtype VoidResult r = VoidResult { unVoidResult :: r }+  deriving stock (Generic)+  deriving newtype (Eq)++voidResultTag :: MText+voidResultTag = [mt|VoidResult|]++type VoidResultRep r = (MText, r)++instance (TypeHasDoc r, IsError (VoidResult r)) => TypeHasDoc (VoidResult r) where+  typeDocMdDescription = typeDocMdDescriptionReferToError @(VoidResult r)+  typeDocMdReference = poly1TypeDocMdReference+  typeDocHaskellRep = concreteTypeDocHaskellRepUnsafe @(VoidResultRep Integer)+  typeDocMichelsonRep = concreteTypeDocMichelsonRepUnsafe @(VoidResultRep Integer)++instance (Typeable r, NiceConstant r, ErrorHasDoc (VoidResult r)) =>+         IsError (VoidResult r) where+  errorToVal (VoidResult e) cont =+    withDict (niceConstantEvi @r) $+    isoErrorToVal @(VoidResultRep r) (voidResultTag, e) cont+  errorFromVal fullErr =+    isoErrorFromVal fullErr >>= \((tag, e) :: VoidResultRep r) ->+      if tag == voidResultTag+      then pure $ VoidResult e+      else Left $ "Error mismatch, expected VoidResult, got " <> pretty tag++instance TypeHasDoc r => ErrorHasDoc (VoidResult r) where+  errorDocName = "VoidResult"+  errorDocMdCause =+    "Call to entrypoint has succeeded, reporting returned value as error.\n\+    \As Tezos contracts normally do not produce any output (not counting storage \+    \update), this is the simplest way to return something to the caller in \+    \read-only entrypoints."+  errorDocHaskellRep =+    mdTicked ("(\"" <> pretty (voidResultTag) <> "\", " <> "<return value>" <> ")")+  errorDocDependencies =+    typeDocDependencies' (Proxy @MText) <> typeDocDependencies' (Proxy @r)++instance CustomErrorNoIsoValue (VoidResult r) => IsoValue (VoidResult r) where+  type ToT (VoidResult r) = CustomErrorNoIsoValue (VoidResult r)+  toVal = error "impossible"+  fromVal = error "impossible"++mkVoid :: forall b a. a -> Void_ a b+mkVoid a = Void_ a nop++void_+  :: forall a b s s' anything.+      (IsError (VoidResult b), KnownValue b)+  => a & s :-> b & s' -> Void_ a b & s :-> anything+void_ code =+  doc (DThrows (Proxy @(VoidResult b))) #+  forcedCoerce_ @_ @(_, Lambda b b) #+  unpair # swap # dip code # swap # exec #+  push voidResultTag # pair # failWith @(MText, b)++addressToEpAddress :: Address : s :-> EpAddress : s+addressToEpAddress = forcedCoerce_++-- | Push a value of @contract@ type.+--+-- Doing this via 'push' instruction is not possible, so we need to perform+-- extra actions here.+--+-- Aside from @contract@ value itself you will need to specify which error to+-- throw in case this value is not valid.+pushContractRef+  :: NiceParameter arg+  => (forall s0. FutureContract arg : s :-> s0)+  -> ContractRef arg+  -> (s :-> ContractRef arg : s)+pushContractRef onContractNotFound (contractRef :: ContractRef arg) =+  withDict (niceParameterEvi @arg) $+    push (FutureContract contractRef) # dup #+    runFutureContract # ifNone onContractNotFound (dip drop)
+ src/Lorentz/Pack.hs view
@@ -0,0 +1,26 @@+-- | Packing utilities.+module Lorentz.Pack+  ( lPackValue+  , lUnpackValue+  ) where++import Data.Constraint ((\\))++import Lorentz.Constraints+import Michelson.Interpret.Pack+import Michelson.Interpret.Unpack+import Michelson.Typed++lPackValue+  :: forall a.+     (NicePackedValue a)+  => a -> ByteString+lPackValue =+  packValue' . toVal \\ nicePackedValueEvi @a++lUnpackValue+  :: forall a.+     (NiceUnpackedValue a)+  => ByteString -> Either UnpackError a+lUnpackValue =+  fmap fromVal . unpackValue' \\ niceUnpackedValueEvi @a
+ src/Lorentz/Polymorphic.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE QuantifiedConstraints #-}++-- | Type families from 'Michelson.Typed.Polymorphic' lifted to Haskell types.+module Lorentz.Polymorphic+  ( MemOpHs (..)+  , MapOpHs (..)+  , IterOpHs (..)+  , SizeOpHs+  , UpdOpHs (..)+  , GetOpHs (..)+  , ConcatOpHs+  , SliceOpHs+  , EDivOpHs (..)++  , IsoMapOpRes+  ) where++import qualified Data.Kind as Kind++import Michelson.Text+import Michelson.Typed+import Tezos.Core (Mutez)++----------------------------------------------------------------------------+-- Mirrored from Michelson+----------------------------------------------------------------------------++-- | Lifted 'MemOpKey'.+class ( MemOp (ToT c)+      , ToT (MemOpKeyHs c) ~ 'Tc (MemOpKey (ToT c))+      ) => MemOpHs c where+  type MemOpKeyHs c :: Kind.Type++instance IsComparable e => MemOpHs (Set e) where+  type MemOpKeyHs (Set e) = e++instance IsComparable k => MemOpHs (Map k v) where+  type MemOpKeyHs (Map k v) = k++instance IsComparable k => MemOpHs (BigMap k v) where+  type MemOpKeyHs (BigMap k v) = k++-- | A useful property which holds for reasonable 'MapOp' instances.+--+-- It's a separate thing from 'MapOpHs' because it mentions @b@ type parameter.+type family IsoMapOpRes c b where+  IsoMapOpRes c b = ToT (MapOpResHs c b) ~ MapOpRes (ToT c) (ToT b)++-- | Lifted 'MapOp'.+class ( MapOp (ToT c)+      , ToT (MapOpInpHs c) ~ MapOpInp (ToT c)+      , ToT (MapOpResHs c ()) ~ MapOpRes (ToT c) (ToT ())+      ) => MapOpHs c where+  type MapOpInpHs c :: Kind.Type+  type MapOpResHs c :: Kind.Type -> Kind.Type++instance IsComparable k => MapOpHs (Map k v) where+  type MapOpInpHs (Map k v) = (k, v)+  type MapOpResHs (Map k v) = Map k++instance MapOpHs [e] where+  type MapOpInpHs [e] = e+  type MapOpResHs [e] = []++-- | Lifted 'IterOp'.+class ( IterOp (ToT c)+      , ToT (IterOpElHs c) ~ IterOpEl (ToT c)+      ) => IterOpHs c where+  type IterOpElHs c :: Kind.Type++instance IsComparable k => IterOpHs (Map k v) where+  type IterOpElHs (Map k v) = (k, v)++instance IterOpHs [e] where+  type IterOpElHs [e] = e++instance IsComparable e => IterOpHs (Set e) where+  type IterOpElHs (Set e) = e++-- | Lifted 'SizeOp'.+--+-- This could be just a constraint alias, but to avoid 'T' types appearance in+-- error messages we make a full type class with concrete instances.+class SizeOp (ToT c) => SizeOpHs c++instance SizeOpHs MText+instance SizeOpHs ByteString+instance SizeOpHs (Set a)+instance SizeOpHs [a]+instance SizeOpHs (Map k v)++-- | Lifted 'UpdOp'.+class ( UpdOp (ToT c)+      , ToT (UpdOpKeyHs c) ~ 'Tc (UpdOpKey (ToT c))+      , ToT (UpdOpParamsHs c) ~ UpdOpParams (ToT c)+      ) => UpdOpHs c where+  type UpdOpKeyHs c :: Kind.Type+  type UpdOpParamsHs c :: Kind.Type++instance IsComparable k => UpdOpHs (Map k v) where+  type UpdOpKeyHs (Map k v) = k+  type UpdOpParamsHs (Map k v) = Maybe v++instance IsComparable k => UpdOpHs (BigMap k v) where+  type UpdOpKeyHs (BigMap k v) = k+  type UpdOpParamsHs (BigMap k v) = Maybe v++instance IsComparable a => UpdOpHs (Set a) where+  type UpdOpKeyHs (Set a) = a+  type UpdOpParamsHs (Set a) = Bool++-- | Lifted 'GetOp'.+class ( GetOp (ToT c)+      , ToT (GetOpKeyHs c) ~ 'Tc (GetOpKey (ToT c))+      , ToT (GetOpValHs c) ~ GetOpVal (ToT c)+      ) => GetOpHs c where+  type GetOpKeyHs c :: Kind.Type+  type GetOpValHs c :: Kind.Type++instance IsComparable k => GetOpHs (Map k v) where+  type GetOpKeyHs (Map k v) = k+  type GetOpValHs (Map k v) = v++instance IsComparable k => GetOpHs (BigMap k v) where+  type GetOpKeyHs (BigMap k v) = k+  type GetOpValHs (BigMap k v) = v++-- | Lifted 'ConcatOp'.+class ConcatOp (ToT c) => ConcatOpHs c++instance ConcatOpHs MText+instance ConcatOpHs ByteString++-- | Lifted 'SliceOp'.+class SliceOp (ToT c) => SliceOpHs c++instance SliceOpHs MText+instance SliceOpHs ByteString++-- | Lifted 'EDivOp'.+class ( EDivOp (ToCT n) (ToCT m)+      , IsComparable n, IsComparable m+      , ToT (EDivOpResHs n m) ~ 'Tc (EDivOpRes (ToCT n) (ToCT m))+      , ToT (EModOpResHs n m) ~ 'Tc (EModOpRes (ToCT n) (ToCT m))+      ) => EDivOpHs n m where+  type EDivOpResHs n m :: Kind.Type+  type EModOpResHs n m :: Kind.Type++instance EDivOpHs Integer Integer where+  type EDivOpResHs Integer Integer = Integer+  type EModOpResHs Integer Integer = Natural++instance EDivOpHs Integer Natural where+  type EDivOpResHs Integer Natural = Integer+  type EModOpResHs Integer Natural = Natural++instance EDivOpHs Natural Integer where+  type EDivOpResHs Natural Integer = Integer+  type EModOpResHs Natural Integer = Natural++instance EDivOpHs Natural Natural where+  type EDivOpResHs Natural Natural = Natural+  type EModOpResHs Natural Natural = Natural++instance EDivOpHs Mutez Mutez where+  type EDivOpResHs Mutez Mutez = Natural+  type EModOpResHs Mutez Mutez = Mutez++instance EDivOpHs Mutez Natural where+  type EDivOpResHs Mutez Natural = Mutez+  type EModOpResHs Mutez Natural = Mutez
+ src/Lorentz/Prelude.hs view
@@ -0,0 +1,19 @@+-- | Commonly used parts of regular Prelude.+module Lorentz.Prelude+  ( ($)+  , (.)+  , type ($)+  , Eq+  , Ord+  , Bounded (..)+  , Semigroup (..)+  , Monoid (..)+  , Generic+  , Text+  , Either (..)+  , Maybe (..)+  , Proxy (..)+  , fromString+  , undefined+  , error+  ) where
+ src/Lorentz/Print.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Printing lorentz contracts.+module Lorentz.Print+  ( printLorentzValue+  , printLorentzContract+  ) where+++import Lorentz.Base+import Lorentz.Constraints+import Lorentz.Run+import Michelson.Printer (printTypedFullContract, printTypedValue)+import Michelson.Typed (toVal)++-- | Pretty-print a Haskell value as Michelson one.+printLorentzValue+  :: forall v.+    (NicePrintedValue v)+  => Bool -> v -> LText+printLorentzValue forceSingleLine =+  withDict (nicePrintedValueEvi @v) $+    printTypedValue forceSingleLine . toVal++-- | Pretty-print a Lorentz contract into Michelson code.+printLorentzContract+  :: forall cp st.+     (NiceParameterFull cp, NiceStorage st)+  => Bool -> Contract cp st -> LText+printLorentzContract forceSingleLine =+  printTypedFullContract forceSingleLine . compileLorentzContract
+ src/Lorentz/Rebinded.hs view
@@ -0,0 +1,179 @@+{- | Reimplementation of some syntax sugar.++You need the following module pragmas to make it work smoothly:++{-# LANGUAGE NoApplicativeDo, RebindableSyntax #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}++-}+module Lorentz.Rebinded+  ( (>>)+  , pure+  , return+  , ifThenElse+  , Condition (..)+  , (<.)+  , (>.)+  , (<=.)+  , (>=.)+  , (==.)+  , (/=.)+  , keepIfArgs++    -- * Re-exports required for RebindableSyntax+  , fromInteger+  , fromString+  , fromLabel+  ) where+++import Prelude hiding (drop, swap, (>>), (>>=))++import Data.Vinyl.Derived (Label)+import Named ((:!))++import Lorentz.Arith+import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Instr+import Lorentz.Macro+import Michelson.Typed.Arith++-- | Aliases for '(#)' used by do-blocks.+(>>) :: (a :-> b) -> (b :-> c) -> (a :-> c)+(>>) = (#)++-- | Predicate for @if ... then .. else ...@ construction,+-- defines a kind of operation applied to the top elements of the current stack.+--+-- Type arguments mean:+-- 1. Input of @if@+-- 2. Left branch input+-- 3. Right branch input+-- 4. Output of branches+-- 5. Output of @if@+data Condition arg argl argr outb out where+  Holds :: Condition (Bool ': s) s s o o+  IsSome :: Condition (Maybe a ': s) (a ': s) s o o+  IsNone :: Condition (Maybe a ': s) s (a ': s) o o+  IsLeft :: Condition (Either l r ': s) (l ': s) (r ': s) o o+  IsRight :: Condition (Either l r ': s) (r ': s) (l ': s) o o+  IsCons :: Condition ([a] ': s) (a ': [a] ': s) s o o+  IsNil :: Condition ([a] ': s) s (a ': [a] ': s) o o++  IsZero :: (UnaryArithOpHs Eq' a, UnaryArithResHs Eq' a ~ Bool)+         => Condition (a ': s) s s o o+  IsNotZero :: (UnaryArithOpHs Eq' a, UnaryArithResHs Eq' a ~ Bool)+         => Condition (a ': s) s s o o++  IsEq :: NiceComparable a => Condition (a ': a ': s) s s o o+  IsNeq :: NiceComparable a => Condition (a ': a ': s) s s o o+  IsLt :: NiceComparable a => Condition (a ': a ': s) s s o o+  IsGt :: NiceComparable a => Condition (a ': a ': s) s s o o+  IsLe :: NiceComparable a => Condition (a ': a ': s) s s o o+  IsGe :: NiceComparable a => Condition (a ': a ': s) s s o o++  -- | Explicitly named binary condition, to ensure proper order of+  -- stack arguments.+  NamedBinCondition ::+    Condition (a ': a ': s) s s o o ->+    Label n1 -> Label n2 ->+    Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o++  -- | Provide the compared arguments to @if@ branches.+  PreserveArgsBinCondition ::+    (forall st o. Condition (a ': b ': st) st st o o) ->+    Condition (a ': b ': s) (a ': b ': s) (a ': b ': s) (a ': b ': s) s++-- | Defines semantics of @if ... then ... else ...@ construction.+ifThenElse+  :: Condition arg argl argr outb out+  -> (argl :-> outb) -> (argr :-> outb) -> (arg :-> out)+ifThenElse = \case+  Holds -> if_+  IsSome -> flip ifNone+  IsNone -> ifNone+  IsLeft -> ifLeft+  IsRight -> flip ifLeft+  IsCons -> ifCons+  IsNil -> flip ifCons++  IsZero -> \l r -> eq0 # if_ l r+  IsNotZero -> \l r -> eq0 # if_ r l++  IsEq -> ifEq+  IsNeq -> ifNeq+  IsLt -> ifLt+  IsGt -> ifGt+  IsLe -> ifLe+  IsGe -> ifGe++  NamedBinCondition condition l1 l2 -> \l r ->+    fromNamed l1 # dip (fromNamed l2) # ifThenElse condition l r++  PreserveArgsBinCondition condition -> \l r ->+    dip dup # swap # dip dup # swap #+    ifThenElse condition+      -- since this pattern is commonly used when one of the branches fails,+      -- it's essential to @drop@ within branches, not after @if@ - @drop@s+      -- appearing to be dead code will be cut off+      (l # drop # drop)+      (r # drop # drop)++-- | Named version of 'IsLt'.+--+-- In this and similar operators you provide names of accepted stack operands as+-- a safety measure of that they go in the expected order.+infix 4 <.+(<.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(<.) = NamedBinCondition IsLt++-- | Named version of 'IsGt'.+infix 4 >.+(>.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(>.) = NamedBinCondition IsGt++-- | Named version of 'IsLe'.+infix 4 <=.+(<=.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(<=.) = NamedBinCondition IsLe++-- | Named version of 'IsGe'.+infix 4 >=.+(>=.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(>=.) = NamedBinCondition IsGe++-- | Named version of 'IsEq'.+infix 4 ==.+(==.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(==.) = NamedBinCondition IsEq++-- | Named version of 'IsNeq'.+infix 4 /=.+(/=.)+  :: NiceComparable a+  => Label n1 -> Label n2+  -> Condition ((n1 :! a) ': (n2 :! a) ': s) s s o o+(/=.) = NamedBinCondition IsNeq++-- | Condition modifier, makes stack operands of binary comparison to be+-- available within @if@ branches.+keepIfArgs+  :: (forall st o. Condition (a ': b ': st) st st o o)+  -> Condition (a ': b ': s) (a ': b ': s) (a ': b ': s) (a ': b ': s) s+keepIfArgs = PreserveArgsBinCondition
+ src/Lorentz/Referenced.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FunctionalDependencies #-}++-- | Referenced-by-type versions of some instructions.+--+-- They allow to "dip" into stack or copy elements of stack referring them+-- by type. Their use is justified, because in most cases there is only+-- one element of each type of stack, and in cases when this does not hold+-- (e.g. entrypoint with multiple parameters of the same type), it might be+-- a good idea to wrap those types into a newtype or to use primitives from+-- 'named' package.+--+-- This module is experimental, i.e. everything here should work but may be+-- removed in favor of better development practices.+--+-- Each instruction is followed with usage example.+module Lorentz.Referenced+  ( dupT+  , dipT+  , dropT+  ) where++import Prelude hiding (drop, swap)++import qualified Data.Kind as Kind+import Data.Type.Bool (If)+import GHC.TypeLits (ErrorMessage(..), TypeError)++import Lorentz.Base+import Lorentz.Instr+import Util.Type++-- Errors+----------------------------------------------------------------------------++type family StackElemNotFound st a :: ErrorMessage where+  StackElemNotFound st a =+    'Text "Element of type `" ':<>: 'ShowType a ':<>:+    'Text "` is not present on stack" ':$$: 'ShowType st++type family StackElemAmbiguous st a :: ErrorMessage where+  StackElemAmbiguous st a =+    'Text "Ambigous reference to element of type `" ':<>: 'ShowType a ':<>:+    'Text "` for stack" ':$$: 'ShowType st++-- Dup+----------------------------------------------------------------------------++-- | Allows duplicating stack elements referring them by type.+class DupT (origSt :: [Kind.Type]) (a :: Kind.Type) (st :: [Kind.Type]) where+  dupTImpl :: st :-> a : st++instance TypeError (StackElemNotFound origSt a) =>+         DupT origSt a '[] where+  dupTImpl = error "impossible"++instance {-# OVERLAPPING #-}+         If (a `IsElem` st)+            (TypeError (StackElemAmbiguous origSt a))+            (() :: Constraint) =>+         DupT origSt a (a : st) where+  dupTImpl = dup++instance {-# OVERLAPPABLE #-}+         DupT origSt a st =>+         DupT origSt a (b : st) where+  dupTImpl = dip (dupTImpl @origSt) # swap++-- | Duplicate an element of stack referring it by type.+--+-- If stack contains multiple entries of this type, compile error is raised.+dupT :: forall a st. DupT st a st => st :-> a : st+dupT = dupTImpl @st @a @st++_dupSample1 :: [Integer, Text, ()] :-> [Text, Integer, Text, ()]+_dupSample1 = dupT @Text++-- Dip+----------------------------------------------------------------------------++-- | Allows diving into stack referring expected new tip by type.+--+-- Implemented with fun deps for conciseness; we can replace them+-- with a type family anytime, but that would probably require more declarations.+class DipT (origInp :: [Kind.Type]) (a :: Kind.Type)+           (inp :: [Kind.Type]) (dipInp :: [Kind.Type])+           (dipOut :: [Kind.Type]) (out :: [Kind.Type])+           | inp a -> dipInp, dipOut inp a -> out where+  dipTImpl :: (dipInp :-> dipOut) -> (inp :-> out)++instance ( TypeError (StackElemNotFound origSt a)+         , dipInp ~ TypeError ('Text "Undefined type (see next error)")+         , out ~ TypeError ('Text "Undefined type (see next error)")+         ) =>+         DipT origSt a '[] dipInp dipOut out where+  dipTImpl = error "impossible"++instance {-# OVERLAPPING #-}+         ( If (a `IsElem` st)+            (TypeError (StackElemAmbiguous origSt a))+            (() :: Constraint)+         , dipInp ~ (a : st)+         , dipOut ~ out+         ) =>+         DipT origSt a (a : st) dipInp dipOut out where+  dipTImpl = id++instance {-# OVERLAPPABLE #-}+         ( DipT origSt a st dipInp dipOut out+         , out1 ~ (b : out)+         ) =>+         DipT origSt a (b : st) dipInp dipOut out1 where+  dipTImpl = dip . dipTImpl @origSt @a @st++-- | Dip repeatedly until element of the given type is on top of the stack.+--+-- If stack contains multiple entries of this type, compile error is raised.+dipT+  :: forall a inp dinp dout out.+     DipT inp a inp dinp dout out+  => (dinp :-> dout) -> (inp :-> out)+dipT = dipTImpl @inp @a @inp @dinp++_dipSample1+  :: [Natural, ()]+      :-> '[ByteString]+  -> [Integer, Text, Natural, ()]+      :-> [Integer, Text, ByteString]+_dipSample1 = dipT @Natural++-- Drop+----------------------------------------------------------------------------++-- | Remove element with the given type from the stack.+dropT+  :: forall a inp dinp dout out.+     ( DipT inp a inp dinp dout out+     , dinp ~ (a ': dout)+     )+  => inp :-> out+dropT = dipT @a drop++_dropSample1 :: [Integer, (), Natural] :-> [Integer, Natural]+_dropSample1 = dropT @()++-- Framing+----------------------------------------------------------------------------++{- Note that there instructions are only usable for concrete stacks.++When you know your stack only partially, and you try to refer to element of+type "X", then with the current approach compiler will require the unknown+part of stack to contain no elements of type "X", and this is annoying+at least because it ruins modularity.++This issue can be resolved with using 'framed' instruction wrapper and family.++-}
+ src/Lorentz/Run.hs view
@@ -0,0 +1,97 @@+module Lorentz.Run+  ( CompilationOptions(..)+  , compileLorentz+  , compileLorentzContract+  , compileLorentzContractWithOptions+  , interpretLorentzInstr+  , interpretLorentzLambda+  , analyzeLorentz+  ) where++import Data.Constraint ((\\))+import Data.Vinyl.Core (Rec(..))++import Lorentz.Base+import Lorentz.Constraints+import Lorentz.EntryPoints+import Michelson.Analyzer (AnalyzerRes, analyze)+import Michelson.Interpret+import Michelson.Typed+  (FullContract(..), Instr(..), IsoValue, IsoValuesStack(..), ParamNotes(..), ToT, ToTs, isStar,+  starNotes, unParamNotes)++-- | For use outside of Lorentz.+compileLorentz :: (inp :-> out) -> Instr (ToTs inp) (ToTs out)+compileLorentz = iAnyCode++-- | Version of 'compileLorentz' specialized to instruction corresponding to+-- contract code.+compileLorentzContract+  :: forall cp st.+     (NiceParameterFull cp, NiceStorage st)+  => Contract cp st -> FullContract (ToT cp) (ToT st)+compileLorentzContract =+  compileLorentzContractWithOptions defaultCompilationOptions++data CompilationOptions = CompilationOptions+  { coDisableInitialCast :: Bool+  -- ^ Flag which defines, whether compiled Michelson contract+  -- will have @CAST@ (which drops parameter annotations)+  -- as a first instruction. Note, that when+  -- flag is false, there still can be no @CAST@ (in case+  -- when parameter type has no annotations).+  }++defaultCompilationOptions :: CompilationOptions+defaultCompilationOptions = CompilationOptions { coDisableInitialCast = False }++-- | Version on 'compileLorentzContract' which accepts @CompilationOptions@.+--+-- Note that compiled contract can be ill-typed in terms of Michelson code+-- when some of the compilation options are used (e.g. when coDoInitialCast+-- is False, resulted contract can be ill-typed).+-- However, compilation with @defaultCompilationOptions@ should be valid.+compileLorentzContractWithOptions+  :: forall cp st.+     (NiceParameterFull cp, NiceStorage st)+  => CompilationOptions -> Contract cp st -> FullContract (ToT cp) (ToT st)+compileLorentzContractWithOptions CompilationOptions{..} contract =+  FullContract+  { fcCode = if (isStar (unParamNotes cpNotes) || coDisableInitialCast)+      then -- If contract parameter type has no annotations or explicitly asked, we drop CAST.+        compileLorentz contract+      else -- Perform CAST otherwise.+        compileLorentz (I CAST # contract :: Contract cp st)+  , fcParamNotesSafe = cpNotes+  , fcStoreNotes = starNotes+  } \\ niceParameterEvi @cp+    \\ niceStorageEvi @st+  where+    cpNotes = parameterEntryPointsToNotes @cp++-- | Interpret a Lorentz instruction, for test purposes.+interpretLorentzInstr+  :: (IsoValuesStack inp, IsoValuesStack out)+  => ContractEnv+  -> inp :-> out+  -> Rec Identity inp+  -> Either MichelsonFailed (Rec Identity out)+interpretLorentzInstr env (compileLorentz -> instr) inp =+  fromValStack <$> interpretInstr env instr (toValStack inp)++-- | Like 'interpretLorentzInstr', but works on lambda rather than+-- arbitrary instruction.+interpretLorentzLambda+  :: (IsoValue inp, IsoValue out)+  => ContractEnv+  -> Lambda inp out+  -> inp+  -> Either MichelsonFailed out+interpretLorentzLambda env instr inp = do+  res <- interpretLorentzInstr env instr (Identity inp :& RNil)+  let Identity out :& RNil = res+  return out++-- | Lorentz version of analyzer.+analyzeLorentz :: inp :-> out -> AnalyzerRes+analyzeLorentz = analyze . compileLorentz
+ src/Lorentz/Store.hs view
@@ -0,0 +1,701 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Impementation of @Store@ - object incapsulating multiple 'BigMap's.+--+-- This module also provides template for the contract storage -+-- 'StorageSkeleton'.+--+-- We represent 'Store' as @big_map bytes (a | b | ...)@.+--+-- Key of this map is formed as @(index, orig_key)@, where @index@ is+-- zero-based index of emulated map, @orig_key@ is key of this emulated map.+--+-- Value of this map is just a union of emulated map's values.++{- Note on store inner representation (@martoon)++I see an alternative approach - representing store as+@big_map bytes (option a, option b, ...)@.++This would allow for saner implementation and more convenient interface.+An obvious shortcoming here is gas consumption. But this overhead seems+insignificant against the background of some other instructions.++-}+module Lorentz.Store+  {-# DEPRECATED "Contract storage can contain multiple big_maps starting from Michelson 005" #-}+  ( -- * Store and related type definitions+    Store (..)+  , type (|->)++    -- ** Type-lookup-by-name+  , GetStoreKey+  , GetStoreValue++    -- ** Instructions+  , storeMem+  , storeGet+  , storeUpdate+  , storeInsert+  , storeInsertNew+  , storeDelete++    -- ** Instruction constraints+  , StoreMemC+  , StoreGetC+  , StoreUpdateC+  , StoreInsertC+  , StoreDeleteC+  , HasStore+  , HasStoreForAllIn++    -- * Storage skeleton+  , StorageSkeleton (..)+  , storageUnpack+  , storagePack+  , storageMem+  , storageGet+  , storageInsert+  , storageInsertNew+  , storageDelete++    -- * Store management from Haskell+  , storePiece+  , storeKeyValueList+  , storeLookup++    -- ** Function constraints+  , StorePieceC+  ) where++import Data.Constraint (Dict(..))+import Data.Default (Default)+import qualified Data.Kind as Kind+import qualified Data.Map as Map+import Data.Type.Bool (If, type (||))+import Data.Type.Equality (type (==))+import Data.Vinyl.Derived (Label)+import GHC.Generics ((:+:))+import qualified GHC.Generics as G+import GHC.TypeLits (AppendSymbol, ErrorMessage(..), KnownSymbol, Symbol, TypeError)+import GHC.TypeNats (type (+), Nat)+import Type.Reflection ((:~:)(Refl))++import Lorentz.ADT+import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Constraints+import Lorentz.Instr as L+import Lorentz.Macro+import Lorentz.Pack+import Lorentz.StoreClass+import Michelson.Typed.Haskell.Instr.Sum+import Michelson.Typed.Haskell.Value+import Michelson.Typed.Instr++{-# ANN module ("HLint: ignore Use 'natVal' from Universum" :: Text) #-}++----------------------------------------------------------------------------+-- Store+----------------------------------------------------------------------------++-- | Gathers multple 'BigMap's under one object.+--+-- Type argument of this datatype stands for a "map template" -+-- a datatype with multiple constructors, each containing an object of+-- type '|->' and corresponding to single virtual 'BigMap'.+-- It's also possible to parameterize it with a larger type which is+-- a sum of types satisfying the above property.+--+-- Inside it keeps only one 'BigMap' thus not violating Michelson limitations.+--+-- See examples below.+newtype Store a = Store { unStore :: BigMap ByteString a }+  deriving stock (Eq, Show)+  deriving newtype (Default, Semigroup, Monoid, IsoValue)++-- | Describes one virtual big map.+data k |-> v = BigMapImage v+  deriving stock Generic+  deriving anyclass IsoValue++{- Again we use generic magic to implement methods for 'Store'+(and thus 'Store' type constructor accepts a datatype, not a type-level list).++There are two reasons for this:++1. This gives us expected balanced tree of 'Or's for free.++2. This allows us selecting a map by constructor name, not by+e.g. type of map value. This is subjective, but looks like a good thing+for me (@martoon). On the other hand, it prevents us from sharing the+same interface between maps and 'Store'.++-}++-- | Position of a constructor in the corresponding datatype declaration.+type CtorIdx = Nat++-- | Number of datatype constructors.+type CtorsNum = Nat++-- | Type arguments of '|->'.+data MapSignature = MapSignature Kind.Type Kind.Type CtorIdx++-- Again, we will use these getters instead of binding types within+-- 'MapSignature' using type equality because getters does not produce extra+-- compile errors on "field not found" cases.+type family MSKey ms where+  MSKey ('MapSignature k _ _) = k+type family MSValue ms where+  MSValue ('MapSignature _ v _) = v+type family MSCtorIdx ms where+  MSCtorIdx ('MapSignature _ _ ci) = ci++-- | Get map signature from the constructor with a given name.+type GetStore name a = MSRequireFound name a (GLookupStore name (G.Rep a))++data MapLookupRes+  = MapFound MapSignature+  | MapAbsent CtorsNum++type family MSRequireFound+  (name :: Symbol)+  (a :: Kind.Type)+  (mlr :: MapLookupRes)+    :: MapSignature where+  MSRequireFound _ _ ('MapFound ms) = ms+  MSRequireFound name a ('MapAbsent _) = TypeError+    ('Text "Failed to find store template: datatype " ':<>: 'ShowType a ':<>:+     'Text " has no constructor " ':<>: 'ShowType name)++-- | Prepend a constructor name with a lower-case character so that you+-- could make a label with @OverloadedLabels@ extension matching+-- resulting thing.+type CtorNameToLabel name = "c" `AppendSymbol` name++type family GLookupStore (name :: Symbol) (x :: Kind.Type -> Kind.Type)+              :: MapLookupRes where+  GLookupStore name (G.D1 _ x) = GLookupStore name x+  GLookupStore name (x :+: y) = LSMergeFound name (GLookupStore name x)+                                                  (GLookupStore name y)+  -- When we encounter a constructor there are two cases we are interested in:+  -- 1. This constructor has one field with type `|->`. Then we check its name+  -- and return 'MapFound' if it matches and 'MapAbsent' otherwise (storing+  -- information that we've found one constructor).+  -- 2. This constructor has one field with a different type. Then we expect+  -- this field to store '|->' somewhere deeper and try to find it there.+  GLookupStore name (G.C1 ('G.MetaCons ctorName _ _) x) =+    If (IsLeafCtor x)+      (If (name == ctorName || name == CtorNameToLabel ctorName)+         ('MapFound $ GExtractMapSignature ctorName x)+         ('MapAbsent 1)+      )+      (GLookupStoreDeeper name x)+  GLookupStore _ G.V1 = 'MapAbsent 0++-- Helper type family to check whether ADT constructor has one field+-- with type `|->`.+type family IsLeafCtor (x :: Kind.Type -> Kind.Type) :: Bool where+  IsLeafCtor (G.S1 _ (G.Rec0 (_ |-> _))) = 'True+  IsLeafCtor _ = 'False++-- Helper type family to go deeper during type-level store lookup.+type family GLookupStoreDeeper (name :: Symbol) (x :: Kind.Type -> Kind.Type)+              :: MapLookupRes where+  GLookupStoreDeeper name (G.S1 _ (G.Rec0 y))  = GLookupStore name (G.Rep y)+  GLookupStoreDeeper name _ = TypeError+    ('Text "Attempt to go deeper failed while looking for" ':<>: 'ShowType name+    ':$$:+    'Text "Make sure that all constructors have exactly one field inside.")++type family LSMergeFound (name :: Symbol)+  (f1 :: MapLookupRes) (f2 :: MapLookupRes)+  :: MapLookupRes where+  LSMergeFound _ ('MapAbsent n1) ('MapAbsent n2) = 'MapAbsent (n1 + n2)+  LSMergeFound _ ('MapFound ms) ('MapAbsent _) = 'MapFound ms+  LSMergeFound _ ('MapAbsent n) ('MapFound ('MapSignature k v i)) =+    'MapFound ('MapSignature k v (n + i))+  -- It's possible that there are two constructors with the same name,+  -- because main template pattern may be a sum of smaller template+  -- patterns with same constructor names.+  LSMergeFound ctor ('MapFound _) ('MapFound _) = TypeError+    ('Text "Found more than one constructor matching " ':<>: 'ShowType ctor)++type family GExtractMapSignature (ctor :: Symbol) (x :: Kind.Type -> Kind.Type)+             :: MapSignature where+  GExtractMapSignature _ (G.S1 _ (G.Rec0 (k |-> v))) = 'MapSignature k v 0+  GExtractMapSignature ctor _ = TypeError+    ('Text "Expected exactly one field of type `k |-> v`" ':$$:+     'Text "In constructor " ':<>: 'ShowType ctor)++type GetStoreKey store name = MSKey (GetStore name store)+type GetStoreValue store name = MSValue (GetStore name store)++packKey+  :: forall (idx :: CtorIdx) a s.+     (KnownNat idx, NicePackedValue a)+  => (a : s) :-> (ByteString : s)+packKey =+  withDict (nicePackedValueEvi @a) $+    push (natVal $ Proxy @idx) #+    pair @Natural @a #+    pack++wrapBigMapImage :: (v : s) :-> ((k |-> v) : s)+wrapBigMapImage = forcedCoerce_++unwrapBigMapImage :: ((k |-> v) : s) :-> (v : s)+unwrapBigMapImage = forcedCoerce_++type StoreOpC store name =+  ( NicePackedValue (MSKey (GetStore name store))+  , KnownNat (MSCtorIdx (GetStore name store))+  )++{- Note on store initialization:++It's not possible to create an empty store, because Michelson provides no way+to create a new empty @big_map@.+-}++storeMem+  :: forall store name s.+     (StoreMemC store name)+  => Label name+  -> GetStoreKey store name : Store store : s :-> Bool : s+storeMem _ =+  packKey @(MSCtorIdx (GetStore name store)) #+  I MEM++type StoreMemC store name = StoreOpC store name++storeGet+  :: forall store name s.+     StoreGetC store name+  => Label name+  -> GetStoreKey store name : Store store : s+       :-> Maybe (GetStoreValue store name) : s+storeGet label =+  packKey @(MSCtorIdx (GetStore name store)) #+  I GET #+  ifNone none (unwrapUnsafe_ @store label # unwrapBigMapImage # L.some)++type StoreGetC store name =+  ( StoreOpC store name+  , InstrUnwrapC store name+  , KnownValue (GetStoreValue store name)+  , CtorHasOnlyField name store+      (GetStoreKey store name |-> GetStoreValue store name)+  )++storeUpdate+  :: forall store name s.+     StoreUpdateC store name+  => Label name+  -> GetStoreKey store name+      : Maybe (GetStoreValue store name)+      : Store store+      : s+  :-> Store store : s+storeUpdate label =+  packKey @(MSCtorIdx (GetStore name store)) #+  dip (ifNone none (wrapBigMapImage # wrap_ @store label # L.some)) #+  I UPDATE++type StoreUpdateC store name =+  ( KnownValue store+  , StoreOpC store name+  , InstrWrapC store name+  , CtorHasOnlyField name store+      (GetStoreKey store name |-> GetStoreValue store name)+  )++storeInsert+  :: forall store name s.+     StoreInsertC store name+  => Label name+  -> GetStoreKey store name+      : GetStoreValue store name+      : Store store+      : s+  :-> Store store : s+storeInsert label =+  packKey @(MSCtorIdx (GetStore name store)) #+  dip (wrapBigMapImage # wrap_ @store label # L.some) #+  I UPDATE++type StoreInsertC store name =+  ( StoreOpC store name+  , InstrWrapC store name+  , CtorHasOnlyField name store+      (GetStoreKey store name |-> GetStoreValue store name)+  )++-- | Insert a key-value pair, but fail if it will overwrite some existing entry.+storeInsertNew+  :: forall store name s.+     (StoreInsertC store name, KnownSymbol name)+  => Label name+  -> (forall s0 any. GetStoreKey store name : s0 :-> any)+  -> GetStoreKey store name+      : GetStoreValue store name+      : Store store+      : s+  :-> Store store : s+storeInsertNew label doFail =+  duupX @3 # duupX @2 # storeMem label #+  if_ doFail+      (storeInsert label)++storeDelete+  :: forall store name s.+     ( StoreDeleteC store name+     )+  => Label name+  -> GetStoreKey store name : Store store : s+     :-> Store store : s+storeDelete _ =+  packKey @(MSCtorIdx (GetStore name store)) #+  dip (none @store) #+  I UPDATE++type StoreDeleteC store name =+  ( StoreOpC store name+  , KnownValue store+  )++-- | This constraint can be used if a function needs to work with+-- /big/ store, but needs to know only about some part(s) of it.+--+-- It can use all Store operations for a particular name, key and+-- value without knowing whole template.+type HasStore name key value store =+   ( StoreGetC store name+   , StoreInsertC store name+   , StoreDeleteC store name+   , GetStoreKey store name ~ key+   , GetStoreValue store name ~ value+   , StorePieceC store name key value+   )++-- | Write down all sensisble constraints which given @store@ satisfies+-- and apply them to @constrained@.+--+-- This store should have '|->' datatype in its immediate fields,+-- no deep inspection is performed.+type HasStoreForAllIn store constrained =+  GForAllHasStore constrained (G.Rep store)++type family GForAllHasStore (store :: Kind.Type) (x :: Kind.Type -> Kind.Type)+            :: Constraint where+  GForAllHasStore store (G.D1 _ x) = GForAllHasStore store x+  GForAllHasStore store (x :+: y) = ( GForAllHasStore store x+                                    , GForAllHasStore store y )+  GForAllHasStore store (G.C1 ('G.MetaCons ctorName _ _)+                          (G.S1 _ (G.Rec0 (key |-> value)))) =+    HasStore (CtorNameToLabel ctorName) key value store+  GForAllHasStore _ (G.C1 _ _) = ()+  GForAllHasStore _ G.V1 = ()++-- Instances+----------------------------------------------------------------------------++instance ( StoreMemC store name, StoreGetC store name+         , StoreUpdateC store name+         , key ~ GetStoreKey store name, value ~ GetStoreValue store name+         ) =>+         StoreHasSubmap (Store store) name key value where+  storeSubmapOps = StoreSubmapOps+    { sopMem = storeMem+    , sopGet = storeGet+    , sopUpdate = storeUpdate+    , sopDelete = Just storeDelete+    , sopInsert = Just storeInsert+    }++-- Examples+----------------------------------------------------------------------------++data MyStoreTemplate+  = IntsStore (Integer |-> ())+  | BytesStore (ByteString |-> ByteString)+  deriving stock Generic+  deriving anyclass IsoValue++type MyStore = Store MyStoreTemplate++_sample1 :: Integer : MyStore : s :-> MyStore : s+_sample1 = storeDelete @MyStoreTemplate #cIntsStore++_sample2 :: ByteString : ByteString : MyStore : s :-> MyStore : s+_sample2 = storeInsert @MyStoreTemplate #cBytesStore++data MyStoreTemplate2+  = BoolsStore (Bool |-> Bool)+  | IntsStore2 (Integer |-> Integer)+  | IntsStore3 (Integer |-> Bool)+  deriving stock Generic+  deriving anyclass IsoValue++-- You must derive 'Generic' instance for all custom types, even+-- newtypes.+newtype MyNatural = MyNatural Natural+  deriving stock Generic+  deriving newtype (IsoCValue, IsoValue)++data MyStoreTemplate3 = MyStoreTemplate3 (Natural |-> MyNatural)+  deriving stock Generic+  deriving anyclass IsoValue++data MyStoreTemplateBig+  = BigTemplatePart1 MyStoreTemplate+  | BigTemplatePart2 MyStoreTemplate2+  | BigTemplatePart3 MyStoreTemplate3+  deriving stock Generic+  deriving anyclass IsoValue++_MyStoreTemplateBigTextsStore ::+  GetStore "cBytesStore" MyStoreTemplateBig :~: 'MapSignature ByteString ByteString 1+_MyStoreTemplateBigTextsStore = Refl++_MyStoreTemplateBigBoolsStore ::+  GetStore "cBoolsStore" MyStoreTemplateBig :~: 'MapSignature Bool Bool 2+_MyStoreTemplateBigBoolsStore = Refl++_MyStoreTemplateBigMyStoreTemplate3 ::+  GetStore "cMyStoreTemplate3" MyStoreTemplateBig :~: 'MapSignature Natural MyNatural 5+_MyStoreTemplateBigMyStoreTemplate3 = Refl++_MyStoreBigHasAllStores+  :: HasStoreForAllIn MyStoreTemplate store+  => Dict ( HasStore "cIntsStore" Integer () store+          , HasStore "cBytesStore" ByteString ByteString store+          )+_MyStoreBigHasAllStores = Dict++type MyStoreBig = Store MyStoreTemplateBig++_sample3 :: Integer : MyStoreBig : s :-> MyStoreBig : s+_sample3 = storeDelete @MyStoreTemplateBig #cIntsStore2++_sample4 :: ByteString : MyStoreBig : s :-> Bool : s+_sample4 = storeMem @MyStoreTemplateBig #cBytesStore++_sample5 :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s+_sample5 = storeInsert @MyStoreTemplateBig #cMyStoreTemplate3++-- Example of 'HasStoreForAllIn' use.+-- This function will work with any @store@ which has 'MyStoreTemplate3' inside.+_sample6+  :: forall store s.+      HasStoreForAllIn MyStoreTemplate3 store+  => Natural : MyNatural : Store store : s :-> Store store : s+_sample6 = storeInsert @store #cMyStoreTemplate3++-- For instance, 'sample6' works for 'MyStoreBig'.+_sample6' :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s+_sample6' = _sample6++----------------------------------------------------------------------------+-- Storage skeleton+----------------------------------------------------------------------------++-- | Contract storage with @big_map@.+--+-- Due to Michelson constraints it is the only possible layout containing+-- @big_map@.+data StorageSkeleton storeTemplate other = StorageSkeleton+  { sMap :: Store storeTemplate+  , sFields :: other+  } deriving stock (Eq, Show, Generic)+    deriving anyclass (Default, IsoValue)++-- | Unpack 'StorageSkeleton' into a pair.+storageUnpack :: StorageSkeleton store fields : s :-> (Store store, fields) : s+storageUnpack = forcedCoerce_++-- | Pack a pair into 'StorageSkeleton'.+storagePack :: (Store store, fields) : s :-> StorageSkeleton store fields : s+storagePack = forcedCoerce_++storageMem+  :: forall store name fields s.+     (StoreMemC store name)+  => Label name+  -> GetStoreKey store name : StorageSkeleton store fields : s :-> Bool : s+storageMem label = dip (storageUnpack # car) # storeMem label++storageGet+  :: forall store name fields s.+     StoreGetC store name+  => Label name+  -> GetStoreKey store name : StorageSkeleton store fields : s+       :-> Maybe (GetStoreValue store name) : s+storageGet label = dip (storageUnpack # car) # storeGet label++storageInsert+  :: forall store name fields s.+     StoreInsertC store name+  => Label name+  -> GetStoreKey store name+      : GetStoreValue store name+      : StorageSkeleton store fields+      : s+  :-> StorageSkeleton store fields : s+storageInsert label =+  dip (dip (storageUnpack # dup # car # dip cdr)) #+  storeInsert label #+  pair # storagePack++-- | Insert a key-value pair, but fail if it will overwrite some existing entry.+storageInsertNew+  :: forall store name fields s.+     (StoreInsertC store name, KnownSymbol name)+  => Label name+  -> (forall s0 any. GetStoreKey store name : s0 :-> any)+  -> GetStoreKey store name+      : GetStoreValue store name+      : StorageSkeleton store fields+      : s+  :-> StorageSkeleton store fields : s+storageInsertNew label doFail =+  dip (dip (storageUnpack # dup # car # dip cdr)) #+  storeInsertNew label doFail #+  pair # storagePack++storageDelete+  :: forall store name fields s.+     ( StoreDeleteC store name+     )+  => Label name+  -> GetStoreKey store name : StorageSkeleton store fields : s+     :-> StorageSkeleton store fields : s+storageDelete label =+  dip (storageUnpack # dup # car # dip cdr) #+  storeDelete label #+  pair # storagePack++-- Instances+----------------------------------------------------------------------------++instance (StoreHasField other fname ftype, IsoValue store, IsoValue other) =>+         StoreHasField (StorageSkeleton store other) fname ftype where+  storeFieldOps = storeFieldOpsDeeper #sFields++instance ( StoreMemC store name, StoreGetC store name+         , StoreUpdateC store name+         , key ~ GetStoreKey store name, value ~ GetStoreValue store name+         , IsoValue other+         ) =>+         StoreHasSubmap (StorageSkeleton store other) name key value where+  storeSubmapOps = storeSubmapOpsDeeper #sMap++-- Examples+----------------------------------------------------------------------------++type MyStorage = StorageSkeleton MyStoreTemplate (Integer, ByteString)++-- You can access both Store...+_storageSample1 :: Integer : MyStorage : s :-> MyStorage : s+_storageSample1 = storageDelete @MyStoreTemplate #cIntsStore++-- and other fields of the storage created with 'StorageSkeleton'.+_storageSample2 :: MyStorage : s :-> Integer : s+_storageSample2 = toField #sFields # car++----------------------------------------------------------------------------+-- Store construction from Haskell+----------------------------------------------------------------------------++packHsKey+  :: forall ctorIdx key.+     (NicePackedValue key, KnownNat ctorIdx)+  => key -> ByteString+packHsKey key =+  lPackValue (natVal (Proxy @ctorIdx), key)++-- | Lift a key-value pair to 'Store'.+--+-- Further you can use 'Monoid' instance of @Store@ to make up large stores.+storePiece+  :: forall name store key value.+     StorePieceC store name key value+  => Label name+  -> key+  -> value+  -> Store store+storePiece label key val =+  Store . BigMap $ one+    ( packHsKey @(MSCtorIdx (GetStore name store)) key+    , hsWrap @store label (BigMapImage val)+    )++storeKeyValueList+  :: forall name store key value.+     StorePieceC store name key value+  => Label name+  -> [(key, value)]+  -> Store store+storeKeyValueList label keyValues =+  Store . BigMap . Map.fromList $+  Prelude.map (\(key, val) ->+                 ( packHsKey @(MSCtorIdx (GetStore name store)) key+                 , hsWrap @store label (BigMapImage val)+                 )) keyValues++type StorePieceC store name key value =+  ( key ~ GetStoreKey store name+  , value ~ GetStoreValue store name+  , NicePackedValue key+  , KnownNat (MSCtorIdx (GetStore name store))+  , InstrWrapC store name, Generic store+  , ExtractCtorField (GetCtorField store name) ~ (key |-> value)+  )++-- | Get a value from store by key.+--+-- It expects map to be consistent, otherwise call to this function fails+-- with error.+storeLookup+  :: forall name store key value ctorIdx.+     ( key ~ GetStoreKey store name+     , value ~ GetStoreValue store name+     , ctorIdx ~ MSCtorIdx (GetStore name store)+     , NicePackedValue key+     , KnownNat ctorIdx+     , InstrUnwrapC store name, Generic store+     , CtorOnlyField name store ~ (key |-> value)+     )+  => Label name+  -> key+  -> Store store+  -> Maybe value+storeLookup label key (Store (BigMap m)) =+  Map.lookup (packHsKey @ctorIdx key) m <&> \val ->+    case hsUnwrap label val of+      Nothing -> error "Invalid store, keys and values types \+                       \correspondence is violated"+      Just (BigMapImage x) -> x++-- Examples+----------------------------------------------------------------------------++_storeSample :: Store MyStoreTemplate+_storeSample = mconcat+  [ storePiece #cIntsStore 1 ()+  , storePiece #cBytesStore "a" "b"+  ]++_lookupSample :: Maybe ByteString+_lookupSample = storeLookup #cBytesStore "a" _storeSample++_storeSampleBig :: Store MyStoreTemplateBig+_storeSampleBig = mconcat+  [ storePiece #cIntsStore 1 ()+  , storePiece #cBoolsStore True True+  , storePiece #cIntsStore3 2 False+  ]++_lookupSampleBig :: Maybe Bool+_lookupSampleBig = storeLookup #cIntsStore3 2 _storeSampleBig
+ src/Lorentz/StoreClass.hs view
@@ -0,0 +1,351 @@+{-# LANGUAGE FunctionalDependencies #-}++-- | This module provides storage interfaces.+module Lorentz.StoreClass+  ( -- * Class+    StoreHasField (..)+  , StoreFieldOps (..)+  , StoreHasSubmap (..)+  , StoreSubmapOps (..)++    -- * Expressing constraints on storage+  , type (~>)+  , StorageContains++    -- * Methods to work with storage+  , stToField+  , stGetField+  , stSetField+  , stMem+  , stGet+  , stUpdate+  , stDelete+  , stInsert+  , stInsertNew++    -- * Implementations+  , storeFieldOpsADT+  , storeFieldOpsDeeper+  , storeSubmapOpsDeeper+  , storeFieldOpsReferTo+  , storeSubmapOpsReferTo+  , composeStoreFieldOps+  , composeStoreSubmapOps+  ) where++import Data.Vinyl.Derived (Label)++import Lorentz.ADT+import Lorentz.Base+import Lorentz.Constraints+import qualified Lorentz.Instr as L+import qualified Lorentz.Macro as L+import Lorentz.Value+import Michelson.Typed.Haskell++----------------------------------------------------------------------------+-- Fields+----------------------------------------------------------------------------++-- | Datatype containing the full implementation of 'StoreHasField' typeclass.+--+-- We use this grouping because in most cases implementation will be chosen+-- among the default ones, and initializing all methods at once is simpler+-- and more consistent.+-- (One can say that we are trying to emulate benefits of @DerivingVia@ extension.)+data StoreFieldOps store fname ftype = StoreFieldOps+  { sopToField+      :: forall s.+         Label fname -> store : s :-> ftype : s+  , sopSetField+      :: forall s.+         Label fname -> ftype : store : s :-> store : s+  }++-- Using fundeps here for the sake of less amount of boilerplate on user side,+-- switch to type families if having any issues with that.+-- | Provides operations on fields for storage.+class StoreHasField store fname ftype | store fname -> ftype where+  storeFieldOps :: StoreFieldOps store fname ftype++-- | Pick storage field.+stToField+  :: StoreHasField store fname ftype+  => Label fname -> store : s :-> ftype : s+stToField = sopToField storeFieldOps++-- | Get storage field, preserving the storage itself on stack.+stGetField+  :: StoreHasField store fname ftype+  => Label fname -> store : s :-> ftype : store : s+stGetField l = L.dup # sopToField storeFieldOps l++-- | Update storage field.+stSetField+  :: StoreHasField store fname ftype+  => Label fname -> ftype : store : s :-> store : s+stSetField = sopSetField storeFieldOps++----------------------------------------------------------------------------+-- Virtual big maps+----------------------------------------------------------------------------++-- | Datatype containing the full implementation of 'StoreHasField' typeclass.+--+-- We use this grouping because in most cases implementation will be chosen+-- among the default ones, and initializing all methods at once is simpler+-- and more consistent.+-- (One can say that we are trying to emulate @DerivingVia@ extension.)+data StoreSubmapOps store mname key value = StoreSubmapOps+  { sopMem+      :: forall s.+         Label mname -> key : store : s :-> Bool : s+  , sopGet+      :: forall s.+         Label mname -> key : store : s :-> Maybe value : s+  , sopUpdate+      :: forall s.+         Label mname -> key : Maybe value : store : s :-> store : s++    -- Methods below are derivatives of methods above, they can be provided+    -- if for given specific storage type more efficient implementation is+    -- available.+  , sopDelete+      :: forall s.+         Maybe (Label mname -> key : store : s :-> store : s)+  , sopInsert+      :: forall s.+         Maybe (Label mname -> key : value : store : s :-> store : s)+  }++-- | Provides operations on fields for storage.+class StoreHasSubmap store mname key value | store mname -> key value where+  storeSubmapOps :: StoreSubmapOps store mname key value++-- | Check value presence in storage.+stMem+  :: StoreHasSubmap store mname key value+  => Label mname -> key : store : s :-> Bool : s+stMem = sopMem storeSubmapOps++-- | Get value in storage.+stGet+  :: StoreHasSubmap store mname key value+  => Label mname -> key : store : s :-> Maybe value : s+stGet = sopGet storeSubmapOps++-- | Update a value in storage.+stUpdate+  :: StoreHasSubmap store mname key value+  => Label mname -> key : Maybe value : store : s :-> store : s+stUpdate = sopUpdate storeSubmapOps++-- | Delete a value in storage.+stDelete+  :: forall store mname key value s.+     (StoreHasSubmap store mname key value, KnownValue value)+  => Label mname -> key : store : s :-> store : s+stDelete l = case sopDelete storeSubmapOps of+  Just delOp -> delOp l+  Nothing -> L.dip L.none # stUpdate l++-- | Add a value in storage.+stInsert+  :: StoreHasSubmap store mname key value+  => Label mname -> key : value : store : s :-> store : s+stInsert l = case sopInsert storeSubmapOps of+  Just insOp -> insOp l+  Nothing -> L.dip L.some # stUpdate l++-- | Add a value in storage, but fail if it will overwrite some existing entry.+stInsertNew+  :: StoreHasSubmap store mname key value+  => Label mname+  -> (forall s0 any. key : s0 :-> any)+  -> key : value : store : s+  :-> store : s+stInsertNew l doFail =+  L.duupX @3 # L.duupX @2 # stMem l #+  L.if_ doFail (stInsert l)++-- Instances+----------------------------------------------------------------------------++-- | 'BigMap' can be used as standalone key-value storage,+-- name of submap is not accounted in this case.+instance (key ~ key', value ~ value', IsComparable key) =>+         StoreHasSubmap (BigMap key' value') name key value where+  storeSubmapOps = StoreSubmapOps+    { sopMem = \_label -> L.mem+    , sopGet = \_label -> L.get+    , sopUpdate = \_label -> L.update+    , sopDelete = Nothing+    , sopInsert = Nothing+    }++-- | 'Map' can be used as standalone key-value storage if very needed.+instance (key ~ key', value ~ value', IsComparable key) =>+         StoreHasSubmap (Map key' value') name key value where+  storeSubmapOps = StoreSubmapOps+    { sopMem = \_label -> L.mem+    , sopGet = \_label -> L.get+    , sopUpdate = \_label -> L.update+    , sopDelete = Nothing+    , sopInsert = Nothing+    }+++-- Implementations+----------------------------------------------------------------------------++-- | Implementation of 'StoreHasField' for case of datatype+-- keeping a pack of fields.+storeFieldOpsADT+  :: HasFieldOfType dt fname ftype+  => StoreFieldOps dt fname ftype+storeFieldOpsADT = StoreFieldOps+  { sopToField = toField+  , sopSetField = setField+  }++-- | Implementation of 'StoreHasField' for a data type which has an+-- instance of 'StoreHasField' inside.+-- For instance, it can be used for top-level storage.+storeFieldOpsDeeper+  :: ( HasFieldOfType storage fieldsPartName fields+     , StoreHasField fields fname ftype+     )+  => Label fieldsPartName+  -> StoreFieldOps storage fname ftype+storeFieldOpsDeeper fieldsLabel =+  composeStoreFieldOps fieldsLabel storeFieldOpsADT storeFieldOps++-- | Implementation of 'StoreHasSubmap' for a data type which has an+-- instance of 'StoreHasSubmap' inside.+-- For instance, it can be used for top-level storage.+storeSubmapOpsDeeper+  :: ( HasFieldOfType storage bigMapPartName fields+     , StoreHasSubmap fields mname key value+     )+  => Label bigMapPartName+  -> StoreSubmapOps storage mname key value+storeSubmapOpsDeeper submapLabel =+  composeStoreSubmapOps submapLabel storeFieldOpsADT storeSubmapOps++{- | Pretend that given 'StoreSubmapOps' implementation is made up+for submap with name @desiredName@, not its actual name.+Logic of the implementation remains the same.++Use case: imagine that your code requires access to submap named @X@,+but in your storage that submap is called @Y@.+Then you implement the instance which makes @X@ refer to @Y@:++@+instance StoreHasSubmap Store X Key Value where+  storeSubmapOps = storeSubmapOpsReferTo #Y storeSubmapOpsForY+@+-}+storeSubmapOpsReferTo+  :: Label name+  -> StoreSubmapOps storage name key value+  -> StoreSubmapOps storage desiredName key value+storeSubmapOpsReferTo l StoreSubmapOps{..} =+  StoreSubmapOps+  { sopMem = \_l -> sopMem l+  , sopGet = \_l -> sopGet l+  , sopUpdate = \_l -> sopUpdate l+  , sopDelete = (\op _l -> op l) <$> sopDelete+  , sopInsert = (\op _l -> op l) <$> sopInsert+  }++-- | Pretend that given 'StoreSubmapOps' implementation is made up+-- for submap with name @desiredName@, not its actual name.+-- Logic of the implementation remains the same.+--+-- See also 'storeSubmapOpsReferTo'.+storeFieldOpsReferTo+  :: Label name+  -> StoreFieldOps storage name field+  -> StoreFieldOps storage desiredName field+storeFieldOpsReferTo l StoreFieldOps{..} =+  StoreFieldOps+  { sopToField = \_l -> sopToField l+  , sopSetField = \_l -> sopSetField l+  }++-- | Chain two implementations of field operations.+--+-- Suits for a case when your store does not contain its fields directly+-- rather has a nested structure.+composeStoreFieldOps+  :: Label nameInStore+  -> StoreFieldOps store nameInStore substore+  -> StoreFieldOps substore nameInSubstore field+  -> StoreFieldOps store nameInSubstore field+composeStoreFieldOps l1 ops1 ops2 =+  StoreFieldOps+  { sopToField = \l2 ->+      sopToField ops1 l1 # sopToField ops2 l2+  , sopSetField = \l2 ->+      L.dip (L.dup # sopToField ops1 l1) #+      sopSetField ops2 l2 #+      sopSetField ops1 l1+  }++-- | Chain implementations of field and submap operations.+composeStoreSubmapOps+  :: Label nameInStore+  -> StoreFieldOps store nameInStore substore+  -> StoreSubmapOps substore mname key value+  -> StoreSubmapOps store mname key value+composeStoreSubmapOps l1 ops1 ops2 =+  StoreSubmapOps+  { sopMem = \l2 ->+      L.dip (sopToField ops1 l1) # sopMem ops2 l2+  , sopGet = \l2 ->+      L.dip (sopToField ops1 l1) # sopGet ops2 l2+  , sopUpdate = \l2 ->+      L.dip (L.dip (L.dup # sopToField ops1 l1)) #+      sopUpdate ops2 l2 #+      sopSetField ops1 l1+  , sopDelete = case sopDelete ops2 of+      Nothing -> Nothing+      Just delOp -> Just $ \l2 ->+        L.dip (L.dup # sopToField ops1 l1) #+        delOp l2 #+        sopSetField ops1 l1+  , sopInsert = case sopInsert ops2 of+      Nothing -> Nothing+      Just insOp -> Just $ \l2 ->+        L.dip (L.dip (L.dup # sopToField ops1 l1)) #+        insOp l2 #+        sopSetField ops1 l1+  }++----------------------------------------------------------------------------+-- Utilities+----------------------------------------------------------------------------++-- | Indicates a submap with given key and value types.+data k ~> v+infix 9 ~>++{- | Concise way to write down constraints with expected content of a storage.++Use it like follows:++@+type StorageConstraint = StorageContains+  [ "fieldInt" := Int+  , "fieldNat" := Nat+  , "balances" := Address ~> Int+  ]+@++-}+type family StorageContains store (content :: [NamedField]) :: Constraint where+  StorageContains _ '[] = ()+  StorageContains store ((n := k ~> v) ': ct) =+    (StoreHasSubmap store n k v, StorageContains store ct)+  StorageContains store ((n := ty) ': ct) =+    (StoreHasField store n ty, StorageContains store ct)
+ src/Lorentz/Test.hs view
@@ -0,0 +1,106 @@+module Lorentz.Test+  ( -- * Importing a contract+    specWithContract+  , specWithTypedContract+  , specWithUntypedContract++  -- * Unit testing+  , ContractReturn+  , ContractPropValidator+  , contractProp+  , contractPropVal+  , expectContractEntrypoints++  -- * Integrational testing+  -- ** Testing engine+  , IntegrationalValidator+  , SuccessValidator+  , IntegrationalScenario+  , IntegrationalScenarioM+  , ValidationError (..)+  , integrationalTestExpectation+  , integrationalTestProperty+  , lOriginate+  , lOriginateEmpty+  , lTransfer+  , lCall+  , lCallEP+  , EntryPointRef (..)+  , lCallDef+  , validate+  , integrationalFail+  , setMaxSteps+  , setNow+  , rewindTime+  , withSender+  , setChainId+  , branchout+  , (?-)+  , offshoot++  -- ** Validators+  , composeValidators+  , composeValidatorsList+  , expectAnySuccess+  , expectNoUpdates+  , expectNoStorageUpdates+  , lExpectStorageUpdate+  , lExpectBalance+  , lExpectStorage+  , lExpectStorageConst+  , lExpectMichelsonFailed+  , lExpectFailWith+  , lExpectError+  , lExpectErrorNumeric+  , lExpectCustomError+  , lExpectCustomErrorNumeric+  , lExpectCustomError_+  , lExpectCustomErrorNumeric_+  , lExpectConsumerStorage+  , lExpectViewConsumerStorage++  -- ** Various+  , TxData (..)+  , genesisAddresses+  , genesisAddress+  , genesisAddress1+  , genesisAddress2+  , genesisAddress3+  , genesisAddress4+  , genesisAddress5+  , genesisAddress6++  -- * Autodoc testing+  , runDocTests+  , testLorentzDoc+  , excludeDocTests++  -- * General utilities+  , failedProp+  , succeededProp+  , qcIsLeft+  , qcIsRight++  -- * Dummy values+  , dummyContractEnv++  -- * Arbitrary data+  , minTimestamp+  , maxTimestamp+  , midTimestamp++  -- * Special contracts for testing+  , contractConsumer+  ) where++import Michelson.Doc.Test+import Michelson.Test.Dummy+import Michelson.Test.Gen+import Michelson.Test.Import+import Michelson.Test.Unit+import Michelson.Test.Util++import Lorentz.Test.Consumer+import Lorentz.Test.Doc+import Lorentz.Test.Integrational+import Lorentz.Test.Unit
+ src/Lorentz/Test/Consumer.hs view
@@ -0,0 +1,14 @@+-- | Contract which remembers all parameters it has been called with.+--+-- Useful to save return values of @View@ entry points.+module Lorentz.Test.Consumer+  ( contractConsumer+  ) where++import Lorentz.Base+import Lorentz.Instr+import Lorentz.Macro++-- | Remembers parameters it was called with, last goes first.+contractConsumer :: Contract cp [cp]+contractConsumer = unpair # cons # nil # pair
+ src/Lorentz/Test/Doc.hs view
@@ -0,0 +1,61 @@+-- | Testing predicates for documentation of Lorentz contracts.+module Lorentz.Test.Doc+  ( -- * Test predicates+    testLorentzDoc++    -- * Individual test predicates+  , testDeclaresParameter+  , testEachEntrypointIsDescribed++  , module Michelson.Doc.Test+  ) where++import Fmt (pretty)+import Test.HUnit (assertBool, assertFailure)++import Lorentz.EntryPoints.Doc+import Michelson.Doc+import Michelson.Doc.Test+import Util.Typeable++-- | Check that contract documents its parameter.+testDeclaresParameter :: DocTest+testDeclaresParameter =+  mkDocTest "Contract parameter is documented" $+  \contractDoc ->+    assertBool "No doc items describing contract parameter found" $+      or $ forEachContractLayer contractDoc check+  where+    check Nothing _ = False+    check (Just sdi) _ =+      -- Currently the only way to document parameter (mentioning type of each arm)+      -- is using 'entryCase'. This may not suit for small contracts, then+      -- someone needs to invent another way to document parameter and also mention+      -- it below.+      case sdi of+        SomeDocItem (castIgnoringPhantom -> Just DEntryPoint{}) -> True+        _ -> False++-- | It's a common issue to forget to describe an entrypoint.+testEachEntrypointIsDescribed :: DocTest+testEachEntrypointIsDescribed =+  mkDocTest "Each entrypoint has 'DDescription'" $+  \contractDoc ->+    sequence_ . forEachContractLayer contractDoc $ \mDocItem block ->+      runMaybeT $ do+        SomeDocItem docItem <- MaybeT . pure $ mDocItem+        dep@DEntryPoint{} <- MaybeT . pure $ castIgnoringPhantom docItem+        Nothing <- pure $ lookupDocBlockSection @DDescription block+        MaybeT . assertFailure $+          "Entrypoint '" <> pretty (depName dep) <> "' does not contain \+          \description.\n\+          \Put `doc $ DDescription \"text\"` in the entrypoint logic to fix this."++-- | Tests all properties.+testLorentzDoc :: [DocTest]+testLorentzDoc = mconcat+  [ testDocBasic+  , [ testDeclaresParameter+    , testEachEntrypointIsDescribed+    ]+  ]
+ src/Lorentz/Test/Import.hs view
@@ -0,0 +1,27 @@+-- | Mirrors 'Michelson.Test.Import' module in a Lorentz way.++module Lorentz.Test.Import+  ( testTreesWithContractL+  , specWithContractL+  ) where++import Data.Singletons (SingI)+import Test.Hspec (Spec)+import Test.Tasty (TestTree)++import qualified Lorentz.Base as L+import Michelson.Test.Import (specWithContract, testTreesWithContract)+import Michelson.Typed (ToT)+import qualified Michelson.Untyped as U++-- | Like 'testTreesWithContract' but for Lorentz types.+testTreesWithContractL+  :: (Each [Typeable, SingI] [ToT cp, ToT st], HasCallStack)+  => FilePath -> ((U.Contract, L.Contract cp st) -> IO [TestTree]) -> IO [TestTree]+testTreesWithContractL file testImpl = testTreesWithContract file (testImpl . second L.I)++-- | Like 'specWithContract', but for Lorentz types.+specWithContractL+  :: (Each [Typeable, SingI] [ToT cp, ToT st], HasCallStack)+  => FilePath -> ((U.Contract, L.Contract cp st) -> Spec) -> Spec+specWithContractL file mkSpec = specWithContract file (mkSpec . second L.I)
+ src/Lorentz/Test/Integrational.hs view
@@ -0,0 +1,353 @@+-- | Mirrors 'Michelson.Test.Integrational' module in a Lorentz way.+module Lorentz.Test.Integrational+  (+    -- * Re-exports+    TxData (..)+  , genesisAddresses+  , genesisAddress+  -- * More genesis addresses which can be used in tests+  , genesisAddress1+  , genesisAddress2+  , genesisAddress3+  , genesisAddress4+  , genesisAddress5+  , genesisAddress6++    -- * Testing engine for bare Typed primitives+  , I.tOriginate+  , I.tTransfer+  , I.tExpectStorageConst++    -- * Testing engine+  , I.IntegrationalValidator+  , SuccessValidator+  , IntegrationalScenarioM+  , I.IntegrationalScenario+  , I.ValidationError (..)+  , I.integrationalTestExpectation+  , I.integrationalTestProperty+  , lOriginate+  , lOriginateEmpty+  , lTransfer+  , lCall+  , lCallEP+  , EntryPointRef (..)+  , lCallDef+  , I.validate+  , I.integrationalFail+  , I.setMaxSteps+  , I.setNow+  , I.rewindTime+  , I.withSender+  , I.setChainId+  , I.branchout+  , (I.?-)+  , I.offshoot++  -- * Validators+  , I.composeValidators+  , I.composeValidatorsList+  , I.expectAnySuccess+  , I.expectNoUpdates+  , I.expectNoStorageUpdates+  , lExpectStorageUpdate+  , lExpectBalance+  , lExpectStorage+  , lExpectStorageConst+  -- * Errors+  , lExpectMichelsonFailed+  , lExpectFailWith+  , lExpectError+  , lExpectErrorNumeric+  , lExpectCustomError+  , lExpectCustomErrorNumeric+  , lExpectCustomError_+  , lExpectCustomErrorNumeric_++  -- ** Consumer+  , lExpectConsumerStorage+  , lExpectViewConsumerStorage+  ) where++import Data.Constraint (Dict(..))+import Data.Default (Default(..))+import Data.Singletons (SingI)+import Data.Typeable (gcast)+import Data.Vinyl.Derived (Label)+import Fmt (Buildable, listF, (+|), (|+))+import Named ((:!), arg)++import qualified Lorentz.Base as L+import Lorentz.Constraints+import Lorentz.EntryPoints+import qualified Lorentz.Errors as L+import qualified Lorentz.Errors.Numeric as L+import Lorentz.Run+import Lorentz.Value+import qualified Lorentz.Value as L+import Michelson.Interpret (InterpretError(..), MichelsonFailed(..))+import Michelson.Runtime+import Michelson.Runtime.GState+import Michelson.Test.Integrational+import qualified Michelson.Test.Integrational as I+import Michelson.TypeCheck (typeVerifyValue)+import qualified Michelson.Typed as T+import qualified Michelson.Untyped as U+import Tezos.Core+import Util.Named ((.!))++----------------------------------------------------------------------------+-- Interface+----------------------------------------------------------------------------++-- TODO: how to call they normally? :thinking:+-- Preserving just the same names like @transfer@ or @originate@+-- looks very bad because no one will import this or+-- 'Michelson.Test.Integrational' module qualified+-- and thus finding which exact function is used would become too painful.++-- | Like 'originate', but for Lorentz contracts.+lOriginate+  :: forall cp st.+     (NiceParameterFull cp, NiceStorage st)+  => L.Contract cp st+  -> Text+  -> st+  -> Mutez+  -> IntegrationalScenarioM (TAddress cp)+lOriginate contract name value balance =+  withDict (niceParameterEvi @cp) $+  withDict (niceStorageEvi @st) $ do+    addr <- I.tOriginate (compileLorentzContract contract) name (T.toVal value) balance+    return (L.TAddress addr)++-- | Originate a contract with empty balance and default storage.+lOriginateEmpty+  :: (NiceParameterFull cp, NiceStorage st, Default st)+  => L.Contract cp st+  -> Text+  -> IntegrationalScenarioM (TAddress cp)+lOriginateEmpty contract name = lOriginate contract name def (unsafeMkMutez 0)++-- | Similar to 'transfer', for Lorentz values.+lTransfer+  :: forall cp epRef epArg addr.+     (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToTAddress cp addr)+  => "from" :! Address+  -> "to" :! addr+  -> Mutez+  -> epRef+  -> epArg+  -> IntegrationalScenarioM ()+lTransfer from (toTAddress @cp . arg #to -> TAddress to) money epRef param =+  case useHasEntryPointArg @cp @epRef @epArg epRef of+    (Dict, epName) -> I.tTransfer from (#to .! to) money epName (T.toVal param)++{-# DEPRECATED lCall "'lCall' will likely be replaced with 'lCallEP' in future version" #-}+-- | Legacy version of 'lCallEP' function. Calls default entrypoint of+-- a contract assuming its argument is the same as contract parameter+-- (which is equivalent to absence of explicit default entrypoint).+--+-- This function is DEPRECATED and exists only for backwards compatibility.+lCall+  :: forall cp defEpName addr.+     ( HasDefEntryPointArg cp defEpName cp+     , IsoValue cp+     , ToTAddress cp addr+     )+  => addr -> cp -> IntegrationalScenarioM ()+lCall = lCallDef @cp @defEpName @cp @addr++-- | Call an entrypoint of a contract without caring about the source+-- address. Transfers 0 mutez.+lCallEP+  :: forall cp epRef epArg addr.+     (HasEntryPointArg cp epRef epArg, IsoValue epArg, ToTAddress cp addr)+  => addr -> epRef -> epArg -> IntegrationalScenarioM ()+lCallEP addr epRef param =+  lTransfer @cp @epRef @epArg+    (#from .! genesisAddress) (#to .! addr)+    (unsafeMkMutez 0) epRef param++-- | 'lCallEP' for default entrypoint.+lCallDef+  :: forall cp defEpName defArg addr.+     ( HasDefEntryPointArg cp defEpName defArg+     , IsoValue defArg+     , ToTAddress cp addr+     )+  => addr -> defArg -> IntegrationalScenarioM ()+lCallDef addr =+  lCallEP @cp @defEpName @defArg addr CallDefault++----------------------------------------------------------------------------+-- Validators to be used within 'IntegrationalValidator'+----------------------------------------------------------------------------++-- Expect something successful++-- | Internal function that proceeds storage validation from by untyping+-- the value passed to callback.+validateStorageCb+  :: forall st addr.+     (NiceStorage st, ToAddress addr, HasCallStack)+  => (Address -> (U.Value -> Either ValidationError ()) -> SuccessValidator)+  -> addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+validateStorageCb validator (toAddress -> addr) predicate =+  validator addr $ \got -> do+    val <- first I.UnexpectedTypeCheckError $ typeCheck got+    predicate $ T.fromVal val+  where+    typeCheck uval =+      evaluatingState initSt . runExceptT $+      usingReaderT def $+      typeVerifyValue uval+    initSt = error "Typechecker state unavailable"++-- | Similar to 'expectStorage', but for Lorentz values.+lExpectStorage+  :: forall st addr.+     (NiceStorage st, ToAddress addr, HasCallStack)+  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+lExpectStorage = validateStorageCb I.expectStorage++-- | Similar to 'expectStorageUpdate', but for Lorentz values.+lExpectStorageUpdate+  :: forall st addr.+     (NiceStorage st, ToAddress addr, HasCallStack)+  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+lExpectStorageUpdate = validateStorageCb I.expectStorageUpdate++-- | Like 'expectBalance', for Lorentz values.+lExpectBalance :: ToAddress addr => addr -> Mutez -> SuccessValidator+lExpectBalance (toAddress -> addr) money = I.expectBalance addr money++-- | Similar to 'expectStorageConst', for Lorentz values.+lExpectStorageConst+  :: forall st addr.+     (NiceStorage st, ToAddress addr)+  => addr -> st -> SuccessValidator+lExpectStorageConst (toAddress -> addr) expected =+  withDict (niceStorageEvi @st) $+    I.tExpectStorageConst addr (T.toVal expected)++-- Expect errors++-- | Expect that interpretation of contract with given address ended+-- with [FAILED].+lExpectMichelsonFailed+  :: forall addr. (ToAddress addr)+  => (MichelsonFailed -> Bool) -> addr -> ExecutorError -> Bool+lExpectMichelsonFailed predicate (toAddress -> addr) =+  I.expectMichelsonFailed predicate addr++-- | Expect contract to fail with "FAILWITH" instruction and provided value+-- to match against the given predicate.+lExpectFailWith+  :: forall e.+      (Typeable (T.ToT e), T.IsoValue e)+  => (e -> Bool) -> ExecutorError -> Bool+lExpectFailWith predicate =+  \case+    EEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) ->+        case gcast err of+          Just errT -> predicate $ T.fromVal @e errT+          Nothing -> False+    _ -> False++-- | Expect contract to fail with given error.+lExpectError+  :: forall e.+      (L.IsError e)+  => (e -> Bool) -> ExecutorError -> Bool+lExpectError = lExpectError' L.errorFromVal++-- | Version of 'lExpectError' for the case when numeric+-- representation of errors is used.+lExpectErrorNumeric+  :: forall e.+      (L.IsError e)+  => L.ErrorTagMap -> (e -> Bool) -> ExecutorError -> Bool+lExpectErrorNumeric errorTagMap =+  lExpectError' (L.errorFromValNumeric errorTagMap)++lExpectError' ::+     forall e.+     (forall t. (Typeable t, SingI t) =>+                  Value t -> Either Text e)+  -> (e -> Bool)+  -> ExecutorError+  -> Bool+lExpectError' errorFromValImpl predicate =+  \case+    EEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) ->+        case errorFromValImpl err of+          Right err' -> predicate err'+          Left _ -> False+    _ -> False++-- | Expect contract to fail with given 'CustomError'.+lExpectCustomError+  :: forall tag arg.+      (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg)+  => Label tag -> arg -> ExecutorError -> Bool+lExpectCustomError l a =+  lExpectError (== L.CustomError l a)++-- | Version of 'lExpectCustomError' for the case when numeric+-- representation of errors is used.+lExpectCustomErrorNumeric+  :: forall tag arg.+      (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg)+  => L.ErrorTagMap -> Label tag -> arg -> ExecutorError -> Bool+lExpectCustomErrorNumeric errorTagMap l a =+  lExpectErrorNumeric errorTagMap (== L.CustomError l a)++-- | Specialization of 'lExpectCustomError' for non-arg error case.+lExpectCustomError_+  :: forall tag.+      (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())+  => Label tag -> ExecutorError -> Bool+lExpectCustomError_ l =+  lExpectCustomError l ()++-- | Version of 'lExpectCustomError_' for the case when numeric+-- representation of errors is used.+lExpectCustomErrorNumeric_+  :: forall tag.+      (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())+  => L.ErrorTagMap -> Label tag -> ExecutorError -> Bool+lExpectCustomErrorNumeric_ errorTagMap l =+  lExpectCustomErrorNumeric errorTagMap l ()++-- Consumer++-- | Version of 'lExpectStorageUpdate' specialized to "consumer" contract+-- (see 'Lorentz.Contracts.Consumer.contractConsumer').+lExpectConsumerStorage+  :: forall cp st addr.+     (st ~ [cp], NiceStorage st, ToTAddress cp addr)+  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator+lExpectConsumerStorage addr = lExpectStorageUpdate (toTAddress @cp addr)++-- | Assuming that "consumer" contract receives a value from 'View', expect+-- this view return value to be the given one.+--+-- Despite consumer stores parameters it was called with in reversed order,+-- this function cares about it, so you should provide a list of expected values+-- in the same order in which the corresponding events were happenning.+lExpectViewConsumerStorage+  :: ( st ~ [cp]+     , Eq cp, Buildable cp+     , NiceStorage st+     , ToTAddress cp addr+     )+  => addr -> [cp] -> SuccessValidator+lExpectViewConsumerStorage addr expected =+  lExpectConsumerStorage addr (matchExpected . reverse)+  where+    mkError = Left . I.CustomValidationError+    matchExpected got+      | got == expected = pass+      | otherwise = mkError $ "Expected " +| listF expected |++                              ", but got " +| listF got |+ ""
+ src/Lorentz/Test/Unit.hs view
@@ -0,0 +1,28 @@+-- | Unit tests for Lorentz.+module Lorentz.Test.Unit+    ( expectContractEntrypoints+    ) where++import Test.HUnit (Assertion, assertFailure)++import Lorentz hiding (contract)+import Michelson.Test.Unit (matchContractEntryPoints)+import Michelson.Typed (convertFullContract)++-- | Expect the given contract to have some specific entrypoints.+expectContractEntrypoints+  :: forall expectedEps contractEps st.+     ( NiceParameterFull expectedEps+     , NiceParameterFull contractEps+     , NiceStorage st+     )+  => Contract contractEps st -> Assertion+expectContractEntrypoints contract =+  withDict (niceParameterEvi @expectedEps) $+  withDict (niceParameterEvi @contractEps) $+  withDict (niceStorageEvi @st) $ do+    let entrypoints = flattenEntryPoints $ parameterEntryPointsToNotes @expectedEps+        contract' = convertFullContract . compileLorentzContract $ contract+    case matchContractEntryPoints contract' entrypoints of+      Left eps -> assertFailure $ "Some entrypoints were not found " <> show eps+      Right _ -> pass
+ src/Lorentz/TestScenario.hs view
@@ -0,0 +1,53 @@+module Lorentz.TestScenario+  {-# DEPRECATED "Use morley-nettest instead" #-}+  ( TestScenario+  , showTestScenario+  ) where++import Fmt (Buildable, Builder, fmt, (+|), (|+))++import Lorentz.Constraints (KnownValue, NicePrintedValue, NoOperation)+import Lorentz.Print (printLorentzValue)+import Michelson.Typed.Haskell.Value (IsoValue)+import Tezos.Address (Address)++-- | Type that represents test scenario for Lorentz contract.+-- Simply put, it is sequence of pairs (`sender`, `parameter`).+-- Using this sequence we can perform transfers to the desired contract.+type TestScenario param = [(Address, param)]++-- | Function to get textual representation of @TestScenario@, each Parameter+-- is printed as a raw Michelson value.+-- This representation can later be used in order to run test scenario+-- on real network.+--+-- The format for a single contract call is the following:+-- # `printed Lorentz parameter` (actually comment)+-- `sender address`+-- `printed raw Michelson parameter`+showTestScenario+  :: (Buildable param, NicePrintedValue param)+  => TestScenario param -> Text+showTestScenario = fmt . foldMap formatParam+  where+     formatParam+       :: (Buildable param, KnownValue param, NoOperation param)+       => (Address, param) -> Builder+     formatParam (addr, param) =+       "# " +| param |+ "\n" +|+       addr |+ "\n" +|+       printLorentzValue True param |+ "\n"++data Parameter+  = Param1 Integer Bool+  | Param2+  | Param3 Natural Natural+  deriving stock Generic+  deriving anyclass IsoValue++_mkTestScenarioExample :: Address -> TestScenario Parameter+_mkTestScenarioExample owner =+  [ (owner, Param1 5 False)+  , (owner, Param2)+  , (owner, Param3 2 2)+  ]
+ src/Lorentz/TypeAnns.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE UndecidableSuperClasses #-}++-- | Type annotations for Lorentz types.+module Lorentz.TypeAnns+  ( HasTypeAnn (..)+  , GHasTypeAnn (..)+  ) where++import Data.Singletons (SingI)+import qualified GHC.Generics as G+import Named (NamedF)++import Lorentz.Base ((:->))+import Lorentz.Zip+import Michelson.Text+import Michelson.Typed+  (BigMap, ContractRef(..), EpAddress, Notes(..), Operation, T(..), ToCT, ToT, starNotes)+import Michelson.Typed.Haskell.Value (GValueType)+import Michelson.Untyped (TypeAnn, ann, noAnn)+import Tezos.Address+import Tezos.Core+import Tezos.Crypto+import Util.TypeLits++-- For supporting type annotations of entrypoint arguments.+--+--At the botton of this infra is the HasTypeAnn class, which defines the type+--annotations for a given type. Right now the type annotations can only come+--from names in a named field. That is, we are not deriving names from, for+--example, record field names.++class HasTypeAnn a where+  getTypeAnn :: Notes (ToT a)++instance {-# OVERLAPPABLE #-} (GHasTypeAnn (G.Rep a), GValueType (G.Rep a) ~ ToT a)+  => HasTypeAnn a where+  getTypeAnn = gGetTypeAnn @(G.Rep a)++instance (HasTypeAnn a, KnownSymbol name)+  => HasTypeAnn (NamedF Identity a name) where+  getTypeAnn = insertNote (symbolAnn @name) $ getTypeAnn @a+    where+      symbolAnn :: forall s. KnownSymbol s => TypeAnn+      symbolAnn = ann $ symbolValT' @s+      -- Insert the provided type annotation into the provided note.+      insertNote :: forall (b :: T). TypeAnn -> Notes b -> Notes b+      insertNote nt s = case s of+        NTc _ -> NTc nt+        NTKey _ -> NTKey nt+        NTUnit _ -> NTUnit nt+        NTSignature _ -> NTSignature nt+        NTOption _ n1  -> NTOption nt n1+        NTList _ n1 -> NTList nt n1+        NTSet _ n1 -> NTSet nt n1+        NTOperation _ -> NTOperation nt+        NTContract _ n1 -> NTContract nt n1+        NTPair _ n1 n2 n3 n4 -> NTPair nt n1 n2 n3 n4+        NTOr _ n1 n2 n3 n4 -> NTOr nt n1 n2 n3 n4+        NTLambda _ n1 n2 -> NTLambda nt n1 n2+        NTMap _ n1 n2 -> NTMap nt n1 n2+        NTBigMap _ n1 n2 -> NTBigMap nt n1 n2+        NTChainId _ -> NTChainId nt++instance (HasTypeAnn (Maybe a), KnownSymbol name)+  => HasTypeAnn (NamedF Maybe a name) where+  getTypeAnn = getTypeAnn @(NamedF Identity (Maybe a) name)++-- Primitive instances+instance (HasTypeAnn a) => HasTypeAnn (Maybe a) where+  getTypeAnn = NTOption noAnn (getTypeAnn @a)++instance HasTypeAnn Integer where+  getTypeAnn = starNotes++instance HasTypeAnn Natural where+  getTypeAnn = starNotes++instance HasTypeAnn MText where+  getTypeAnn = starNotes++instance HasTypeAnn Bool where+  getTypeAnn = starNotes++instance HasTypeAnn ByteString where+  getTypeAnn = starNotes++instance HasTypeAnn Mutez where+  getTypeAnn = starNotes++instance HasTypeAnn Address where+  getTypeAnn = starNotes++instance HasTypeAnn EpAddress where+  getTypeAnn = starNotes++instance HasTypeAnn KeyHash where+  getTypeAnn = starNotes++instance HasTypeAnn Timestamp where+  getTypeAnn = starNotes++instance HasTypeAnn PublicKey where+  getTypeAnn = starNotes++instance HasTypeAnn Signature where+  getTypeAnn = starNotes++instance (HasTypeAnn a) => HasTypeAnn (ContractRef a) where+  getTypeAnn = NTContract noAnn (getTypeAnn @a)++instance (HasTypeAnn v) => HasTypeAnn (Map k v) where+  getTypeAnn = NTMap noAnn noAnn (getTypeAnn @v)++instance (HasTypeAnn v) => HasTypeAnn (BigMap k v) where+  getTypeAnn = NTBigMap noAnn noAnn (getTypeAnn @v)++instance (SingI (ToCT v), Typeable (ToCT v)) => HasTypeAnn (Set v) where+  getTypeAnn = starNotes++instance (HasTypeAnn a) => HasTypeAnn [a] where+  getTypeAnn = NTList noAnn (getTypeAnn @a)++instance HasTypeAnn Operation where+  getTypeAnn = starNotes++instance+    ( HasTypeAnn (ZippedStack i)+    , HasTypeAnn (ZippedStack o)+    )+  =>+    HasTypeAnn (i :-> o)+  where+  getTypeAnn = NTLambda noAnn+    (getTypeAnn @(ZippedStack i))+    (getTypeAnn @(ZippedStack o))++-- A Generic HasTypeAnn implementation+class GHasTypeAnn a where+  gGetTypeAnn :: Notes (GValueType a)++instance GHasTypeAnn G.U1 where+  gGetTypeAnn = starNotes++instance (GHasTypeAnn x) => GHasTypeAnn (G.M1 i0 i1 x) where+  gGetTypeAnn = gGetTypeAnn @x++instance+    ( GHasTypeAnn x+    , GHasTypeAnn y+    )+  =>+    GHasTypeAnn (x G.:+: y)+  where+  gGetTypeAnn = NTOr noAnn noAnn noAnn+    (gGetTypeAnn @x)+    (gGetTypeAnn @y)++instance+    ( GHasTypeAnn x+    , GHasTypeAnn y+    )+  =>+    GHasTypeAnn (x G.:*: y)+  where+  gGetTypeAnn = NTPair noAnn noAnn noAnn+    (gGetTypeAnn @x)+    (gGetTypeAnn @y)++instance (HasTypeAnn x) => GHasTypeAnn (G.Rec0 x) where+  gGetTypeAnn = getTypeAnn @x
+ src/Lorentz/UParam.hs view
@@ -0,0 +1,417 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Lorentz.UParam+  ( UParam (..)+  , EntryPointKind+  , type (?:)++    -- * Construction+  , mkUParam++    -- * Deconstruction+  , ConstrainedSome (..)+  , UnpackUParam+  , unpackUParam++    -- * Casting to homomorphic value+  , SomeInterface+  , UParam_++    -- * Pattern-matching+  , EntryPointsImpl+  , UParamFallback+  , EntryPointLookupError (..)+  , CaseUParam+  , caseUParam+  , caseUParamT+  , uparamFallbackFail++    -- * Constraints+  , LookupEntryPoint+  , RequireUniqueEntryPoints++    -- * Conversion from ADT+  , uparamFromAdt+  , UParamLinearize+  , UParamLinearized++    -- * Documentation+  , pbsUParam++    -- * Internals used for entrypoint-wise migrations+  , unwrapUParam+  ) where++import Data.Constraint ((\\))+import qualified Data.Kind as Kind+import Data.Vinyl.Core (Rec(..))+import Data.Vinyl.Derived (Label)+import Data.Vinyl.TypeLevel (type (++))+import qualified Fcf+import Fmt (Buildable(..))+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (KnownSymbol, Symbol)+import qualified Text.Show++import Lorentz.ADT+import Lorentz.Base+import Lorentz.Coercions+import Lorentz.EntryPoints.Doc+import Lorentz.Constraints+import Lorentz.Errors+import Lorentz.Instr as L+import Lorentz.Macro+import Lorentz.Pack+import Michelson.Text+import Michelson.Typed+import Util.Type+import Util.TypeLits+import Util.TypeTuple+import Util.Markdown++-- | An entrypoint is described by two types: its name and type of argument.+type EntryPointKind = (Symbol, Kind.Type)++-- | A convenient alias for type-level name-something pair.+type (n :: Symbol) ?: (a :: k) = '(n, a)++-- | Encapsulates parameter for one of entry points.+-- It keeps entrypoint name and corresponding argument serialized.+--+-- In Haskell world, we keep an invariant of that contained value relates+-- to one of entry points from @entries@ list.+newtype UParam (entries :: [EntryPointKind]) = UParamUnsafe (MText, ByteString)+  deriving stock (Generic, Eq, Show)+  deriving anyclass (IsoValue)++instance Wrapped (UParam entries)++-- Casting to homomorphic value+----------------------------------------------------------------------------++-- | Pseudo value for 'UParam' type variable.+type SomeInterface = '[ '("SomeEntrypoints", Void) ]++-- | Homomorphic version of 'UParam', forgets the exact interface.+type UParam_ = UParam SomeInterface++-- | Allows casts only between 'UParam_' and 'UParam'.+instance SameEntries entries1 entries2 =>+         UParam entries1 `CanCastTo` UParam entries2++type family SameEntries (es1 :: [EntryPointKind]) (es :: [EntryPointKind])+              :: Constraint where+  SameEntries e e = ()+  SameEntries SomeInterface _ = ()+  SameEntries _ SomeInterface = ()+  SameEntries e1 e2 = (e1 ~ e2)++----------------------------------------------------------------------------+-- Common type-level stuff+----------------------------------------------------------------------------++-- | Get type of entrypoint argument by its name.+type family LookupEntryPoint (name :: Symbol) (entries :: [EntryPointKind])+             :: Kind.Type where+  LookupEntryPoint name ('(name, a) ': _) = a+  LookupEntryPoint name (_ ': entries) = LookupEntryPoint name entries+  LookupEntryPoint name '[] =+    TypeError ('Text "Entry point " ':<>: 'ShowType name ':<>:+               'Text " in not in the entry points list")++-- | Ensure that given entry points do no contain duplicated names.+type family RequireUniqueEntryPoints (entries :: [EntryPointKind])+             :: Constraint where+  RequireUniqueEntryPoints entries =+    RequireAllUnique "entrypoint" (Fcf.Eval (Fcf.Map Fcf.Fst entries))++----------------------------------------------------------------------------+-- Construction+----------------------------------------------------------------------------++-- | Construct a 'UParam' safely.+mkUParam+  :: ( KnownSymbol name, NicePackedValue a+     , LookupEntryPoint name entries ~ a+     , RequireUniqueEntryPoints entries+     )+  => Label name -> a -> UParam entries+mkUParam label (a :: a) =+  UParamUnsafe (labelToMText label, lPackValue a)+    \\ nicePackedValueEvi @a++-- Example+----------------------------------------------------------------------------++type MyEntryPoints =+  [ "add" ?: Integer+  , "reset" ?: ()+  ]++_mkParamSample1 :: UParam MyEntryPoints+_mkParamSample1 = mkUParam #add 5++----------------------------------------------------------------------------+-- Deconstruction+----------------------------------------------------------------------------++-- | This type can store any value that satisfies a certain constraint.+data ConstrainedSome (c :: Kind.Type -> Constraint) where+  ConstrainedSome :: c a => a -> ConstrainedSome c++instance Show (ConstrainedSome Show) where+  show (ConstrainedSome a) = show a++instance Buildable (ConstrainedSome Buildable) where+  build (ConstrainedSome a) = build a++-- | This class is needed to implement `unpackUParam`.+class UnpackUParam (c :: Kind.Type -> Constraint) entries where+  -- | Turn 'UParam' into a Haskell value.+  -- Since we don't know its type in compile time, we have to erase it using+  -- 'ConstrainedSome'. The user of this function can require arbitrary+  -- constraint to hold (depending on how they want to use the result).+  unpackUParam ::+    UParam entries -> Either EntryPointLookupError (MText, ConstrainedSome c)++instance UnpackUParam c '[] where+  unpackUParam (UParamUnsafe (name, _)) = Left (NoSuchEntryPoint name)++instance+  ( KnownSymbol name+  , UnpackUParam c entries+  , NiceUnpackedValue arg+  , c arg+  ) => UnpackUParam c ((name ?: arg) ': entries) where+  unpackUParam (UParamUnsafe (name, bytes))+    | name == symbolToMText @name =+      fmap (name,) .+      first (const ArgumentUnpackFailed) .+      fmap ConstrainedSome .+      lUnpackValue @arg $+      bytes+    | otherwise = unpackUParam @c @entries (UParamUnsafe (name, bytes))++----------------------------------------------------------------------------+-- Pattern-matching+----------------------------------------------------------------------------++-- | Helper instruction which extracts content of 'UParam'.+unwrapUParam :: UParam entries : s :-> (MText, ByteString) : s+unwrapUParam = coerceUnwrap++-- | Wrapper for a single "case" branch.+data CaseClauseU inp out (entry :: EntryPointKind) where+  CaseClauseU :: (arg : inp) :-> out -> CaseClauseU inp out '(name, arg)++instance (name ~ name', body ~ ((arg : inp) :-> out)) =>+         CaseArrow name' body (CaseClauseU inp out '(name, arg)) where+  (/->) _ = CaseClauseU++data EntryPointLookupError+  = NoSuchEntryPoint MText+  | ArgumentUnpackFailed+  deriving stock (Generic, Eq, Show)++instance Buildable EntryPointLookupError where+  build =+    \case+      NoSuchEntryPoint name -> "No such entrypoint: " <> build name+      ArgumentUnpackFailed -> "UNPACK failed"++type instance ErrorArg "uparamNoSuchEntryPoint" = MText+type instance ErrorArg "uparamArgumentUnpackFailed" = ()++instance Buildable (CustomError "uparamNoSuchEntryPoint") where+  build (CustomError _ name) = "No such entrypoint: " <> build name++instance Buildable (CustomError "uparamArgumentUnpackFailed") where+  build (CustomError _ ()) = "UNPACK failed"++instance CustomErrorHasDoc "uparamNoSuchEntryPoint" where+  customErrClass = ErrClassBadArgument+  customErrDocMdCause = "Entrypoint with given name does not exist."++instance CustomErrorHasDoc "uparamArgumentUnpackFailed" where+  customErrClass = ErrClassBadArgument+  customErrDocMdCause = "Argument of wrong type is provided to the entrypoint."++-- | Implementations of some entry points.+--+-- Note that this thing inherits properties of 'Rec', e.g. you can+-- @Data.Vinyl.Core.rappend@ implementations for two entrypoint sets+-- when assembling scattered parts of a contract.+type EntryPointsImpl inp out entries =+  Rec (CaseClauseU inp out) entries++-- | An action invoked when user-provided entrypoint is not found.+type UParamFallback inp out = ((MText, ByteString) : inp) :-> out++-- | Default implementation for 'UParamFallback', simply reports an error.+uparamFallbackFail :: UParamFallback inp out+uparamFallbackFail =+  car # failCustom #uparamNoSuchEntryPoint++-- | Make up a "case" over entry points.+class CaseUParam (entries :: [EntryPointKind]) where+  -- | Pattern-match on given @UParam entries@.+  --+  -- You have to provide all case branches and a fallback action on case+  -- when entrypoint is not found.+  --+  -- This function is unsafe because it does not make sure at type-level+  -- that entry points' names do not repeat.+  caseUParamUnsafe+    :: Rec (CaseClauseU inp out) entries+    -> UParamFallback inp out+    -> (UParam entries : inp) :-> out++instance CaseUParam '[] where+  caseUParamUnsafe RNil fallback = unwrapUParam # fallback++instance ( KnownSymbol name+         , CaseUParam entries+         , NiceUnpackedValue arg+         ) =>+         CaseUParam ((name ?: arg) ': entries) where+  caseUParamUnsafe (CaseClauseU clause :& clauses) fallback =+    dup # unwrapUParam # car #+    push (mkMTextUnsafe $ symbolValT' @name) # eq #+    if_ (unwrapUParam # cdr # unpack #+         ifSome nop (failCustom_ #uparamArgumentUnpackFailed) # clause)+        (cutUParamEntry # caseUParamUnsafe clauses fallback)+    where+      cutUParamEntry :: UParam (e : es) : s :-> UParam es : s+      cutUParamEntry = forcedCoerce_++-- | Pattern-match on given @UParam entries@.+--+-- You have to provide all case branches and a fallback action on case+-- when entrypoint is not found.+caseUParam+  :: (CaseUParam entries, RequireUniqueEntryPoints entries)+  => Rec (CaseClauseU inp out) entries+  -> UParamFallback inp out+  -> (UParam entries : inp) :-> out+caseUParam = caseUParamUnsafe++-- | Like 'caseUParam', but accepts a tuple of clauses, not a 'Rec'.+caseUParamT+  :: forall entries inp out clauses.+     ( clauses ~ Rec (CaseClauseU inp out) entries+     , RecFromTuple clauses+     , CaseUParam entries+     )+  => IsoRecTuple clauses+  -> UParamFallback inp out+  -> (UParam entries : inp) :-> out+caseUParamT clauses fallback = caseUParamUnsafe (recFromTuple clauses) fallback++-- Example+----------------------------------------------------------------------------++_caseSample :: UParam MyEntryPoints : s :-> Integer : s+_caseSample = caseUParamT+  ( #add /-> nop+  , #reset /-> L.drop @() # push 0+  ) uparamFallbackFail++----------------------------------------------------------------------------+-- ADT conversion+----------------------------------------------------------------------------++{- @martoon: I actually hope no one will use this capability,+   it's here primarily because in other places we also use Generic stuff.++   Representation with type-level list and a datatype made polymorhpic over+   it seems more powerful than Generics.+   1. It's simpler to implement features for it. No extra boilerplate.+   2. 'Data.Vinyl' provides many useful utilities to work with such things.+   3. You are not such constrained in selecting names of entry points as when+      they come from constructor names.+-}++-- | Make up 'UParam' from ADT sum.+--+-- Entry points template will consist of+-- @(constructorName, constructorFieldType)@ pairs.+-- Each constructor is expected to have exactly one field.+uparamFromAdt+  :: UParamLinearize up+  => up -> UParam (UParamLinearized up)+uparamFromAdt = adtToRec . G.from++-- | Constraint required by 'uparamFromAdt'.+type UParamLinearize p = (Generic p, GUParamLinearize (G.Rep p))++-- | Entry points template derived from given ADT sum.+type UParamLinearized p = GUParamLinearized (G.Rep p)++-- | Generic traversal for conversion between ADT sum and 'UParam'.+class GUParamLinearize (x :: Kind.Type -> Kind.Type) where+  type GUParamLinearized x :: [(Symbol, Kind.Type)]+  adtToRec :: x p -> UParam (GUParamLinearized x)++instance GUParamLinearize x => GUParamLinearize (G.D1 i x) where+  type GUParamLinearized (G.D1 i x) = GUParamLinearized x+  adtToRec = adtToRec . G.unM1++instance (GUParamLinearize x, GUParamLinearize y) => GUParamLinearize (x :+: y) where+  type GUParamLinearized (x :+: y) = GUParamLinearized x ++ GUParamLinearized y+  adtToRec = \case+    G.L1 x -> let UParamUnsafe up = adtToRec x in UParamUnsafe up+    G.R1 y -> let UParamUnsafe up = adtToRec y in UParamUnsafe up++instance (KnownSymbol name, NicePackedValue a) =>+         GUParamLinearize (G.C1 ('G.MetaCons name _1 _2) (G.S1 si (G.Rec0 a))) where+  type GUParamLinearized (G.C1 ('G.MetaCons name _1 _2) (G.S1 si (G.Rec0 a))) =+    '[ '(name, a) ]++  adtToRec (G.M1 (G.M1 (G.K1 a))) = UParamUnsafe+    ( symbolToMText @name+    , lPackValue a+    )++instance+    TypeError ('Text "UParam linearization requires exactly one field \+                    \in each constructor") =>+    GUParamLinearize (G.C1 i G.U1) where+  type GUParamLinearized (G.C1 i G.U1) =+    TypeError ('Text "Bad linearized ADT")+  adtToRec = error "impossible"++instance+    TypeError ('Text "UParam linearization requires exactly one field \+                    \in each constructor") =>+    GUParamLinearize (G.C1 i (x :*: y)) where+  type GUParamLinearized (G.C1 i (x :*: y)) =+    TypeError ('Text "Bad linearized ADT")+  adtToRec = error "impossible"++----------------------------------------------------------------------------+-- Documentation+----------------------------------------------------------------------------++instance Typeable interface => TypeHasDoc (UParam interface) where+  typeDocName _ = "Upgradable parameter"+  typeDocMdReference p = customTypeDocMdReference ("UParam", DType p) []+  typeDocMdDescription =+    "This type encapsulates parameter for one of entry points. \+    \It keeps entry point name and corresponding argument serialized."+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep++-- | Note that calling given entrypoints involves constructing 'UParam'.+pbsUParam :: forall ctorName. KnownSymbol ctorName => ParamBuildingStep+pbsUParam =+  let ctor = build $ symbolValT' @ctorName+  in ParamBuildingStep+      { pbsEnglish =+          "Wrap into *UParam* as " <> mdTicked ctor <> " entrypoint."+      , pbsHaskell =+          \a -> "mkUParam #" <> ctor <> " (" <> a <> ")"+      , pbsMichelson =+          \a -> "Pair \"" <> ctor <> "\" (pack (" <> a <> "))"+      }
+ src/Lorentz/UStore.hs view
@@ -0,0 +1,93 @@+{- | This module contains implementation of 'UStore'.++@UStore@ is essentially 'Lorentz.Store.Store' modified for the sake of+upgradeability.++In API it differs from @Store@ in the following ways:+1. It keeps both virtual @big_map@s and plain fields;+2. Neat conversion between Michelson and Haskell values+is implemented;+3. Regarding composabililty, one can operate with one @UStore@+and then lift it to a bigger one which includes the former.+This allows for simpler management of stores and clearer error messages.+In spite of this, operations with 'UStore's over deeply nested templates will+still work as before.++We represent 'UStore' as @big_map bytes bytes@.++* Plain fields are stored as+@key = pack fieldName; value = pack originalValue@.++* Virtual @big_map@s are kept as+@key = pack (bigMapName, originalKey); value = pack originalValue@.++-}+module Lorentz.UStore+  ( -- * UStore and related type definitions+    UStore+  , type (|~>)(..)+  , UStoreFieldExt (..)+  , UStoreField+  , UStoreMarkerType+  , KnownUStoreMarker (..)++    -- ** Type-lookup-by-name+  , GetUStoreKey+  , GetUStoreValue+  , GetUStoreField+  , GetUStoreFieldMarker++    -- ** Instructions+  , ustoreMem+  , ustoreGet+  , ustoreUpdate+  , ustoreInsert+  , ustoreInsertNew+  , ustoreDelete++  , ustoreToField+  , ustoreGetField+  , ustoreSetField++    -- ** Instruction constraints+  , HasUStore+  , HasUField+  , HasUStoreForAllIn++    -- * UStore composability+  , liftUStore+  , unliftUStore++    -- * UStore management from Haskell+  , UStoreConversible+  , mkUStore+  , ustoreDecompose+  , ustoreDecomposeFull+  , fillUStore++    -- * Migrations+  , MigrationScript (..)+  , MigrationScript_+  , UStoreMigration+  , migrationToScript+  , migrationToScriptI+  , migrationToLambda+  , mkUStoreMigration+  , mustoreToOld+  , migrateGetField+  , migrateAddField+  , migrateRemoveField+  , migrateExtractField+  , migrateOverwriteField+  , migrateModifyField++    -- * Extras+  , PickMarkedFields+  ) where++import Lorentz.UStore.Types+import Lorentz.UStore.Instr+import Lorentz.UStore.Instances ()+import Lorentz.UStore.Haskell+import Lorentz.UStore.Lift+import Lorentz.UStore.Migration
+ src/Lorentz/UStore/Common.hs view
@@ -0,0 +1,13 @@+module Lorentz.UStore.Common+  ( fieldNameToMText+  ) where++import GHC.TypeLits (KnownSymbol, symbolVal)++import Michelson.Text++fieldNameToMText :: forall field. KnownSymbol field => MText+fieldNameToMText =+  -- Using 'mkMTextUnsafe' because our coding practices does not allow+  -- weird characters (like unicode) in field names+  mkMTextUnsafe . toText . symbolVal $ Proxy @field
+ src/Lorentz/UStore/Haskell.hs view
@@ -0,0 +1,335 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Conversion between 'UStore' in Haskell and Michelson representation.+module Lorentz.UStore.Haskell+  ( UStoreContent+  , UStoreConversible+  , mkUStore+  , ustoreDecompose+  , ustoreDecomposeFull+  , fillUStore+  , migrateFillUStore+  , fillUStoreMigrationBlock+  ) where++import qualified Data.Kind as Kind+import qualified Data.List as L+import qualified Data.Map as Map+import Data.Singletons (demote)+import Fcf (type (=<<), Eval, Pure2)+import qualified Fcf+import Fmt ((+|), (+||), (|+), (||+))+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal)++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Constraints+import qualified Lorentz.Instr as L+import Lorentz.Pack+import Lorentz.UStore.Common+import Lorentz.UStore.Migration+import Lorentz.UStore.Migration.Diff+import Lorentz.UStore.Types+import Michelson.Interpret.Pack+import Michelson.Text+import Michelson.Typed.Haskell.Value+import Util.Type++-- | 'UStore' content represented as key-value pairs.+type UStoreContent = [(ByteString, ByteString)]++-- | Make 'UStore' from separate @big_map@s and fields.+mkUStore+  :: (UStoreConversible template)+  => template -> UStore template+mkUStore = UStore . BigMap . mkUStoreRec++-- | Decompose 'UStore' into separate @big_map@s and fields.+--+-- Since this function needs to @UNPACK@ content of @UStore@ to actual+-- keys and values, you have to provide 'UnpackEnv'.+--+-- Along with resulting value, you get a list of @UStore@ entries which+-- were not recognized as belonging to any submap or field according to+-- @UStore@'s template - this should be empty unless @UStore@ invariants+-- were violated.+ustoreDecompose+  :: forall template.+     (UStoreConversible template)+  => UStore template -> Either Text (UStoreContent, template)+ustoreDecompose = storeDecomposeRec . Map.toList . unBigMap . unUStore++-- | Make migration script which initializes 'UStore' from scratch.+fillUStore+  :: (UStoreConversible template)+  => template -> UStoreMigration () template+fillUStore v = UStoreMigration $ appEndo (fillUStoreRec v) []++-- | Version of 'migrateFillUStore' for batched migrations.+--+-- Each field write will be placed to a separate batch.+fillUStoreMigrationBlock+  :: ( UStoreConversible template+     , allFieldsExp ~ AllUStoreFieldsF template+     , newDiff ~ FillingNewDiff template diff+     , newTouched ~ FillingNewTouched template touched+     , PatternMatchL newDiff, PatternMatchL newTouched+     )+  => template+  -> MigrationBlocks oldTempl newTempl diff touched newDiff newTouched+fillUStoreMigrationBlock v = MigrationBlocks $ appEndo (fillUStoreRec v) []++-- | Fill 'UStore' with entries from the given template as part of simple+-- migration.+--+-- Sometimes you already have some fields initialized and 'fillUStore' does not+-- suit, then in case if your UStore template is a nested structure you can use+-- sub-templates to initialize the corresponding parts of UStore.+--+-- For batched migrations see 'fillUStoreMigrationBlock'.+migrateFillUStore+  :: ( UStoreConversible template+     , allFieldsExp ~ AllUStoreFieldsF template+     , newDiff ~ FillingNewDiff template diff+     , newTouched ~ FillingNewTouched template touched+     , PatternMatchL newDiff, PatternMatchL newTouched+     )+  => template+  -> Lambda+       (MUStore oldTempl newTempl diff touched)+       (MUStore oldTempl newTempl newDiff newTouched)+migrateFillUStore v =+  let atoms = appEndo (fillUStoreRec v) []+      script = foldMap (unMigrationScript . maScript) atoms+  in forcedCoerce_ # script # forcedCoerce_++type FillingNewDiff template diff =+  CoverDiffMany diff+    (Eval (Fcf.Map (Pure2 '(,) 'DcAdd) =<< LinearizeUStoreF template))++type FillingNewTouched template touched =+  Eval (AllUStoreFieldsF template) ++ touched++-- Implementation+----------------------------------------------------------------------------++-- | Like 'ustoreDecompose', but requires all entries from @UStore@ to be+-- recognized.+ustoreDecomposeFull+  :: forall template.+     (UStoreConversible template)+  => UStore template -> Either Text template+ustoreDecomposeFull ustore = do+  (remained, res) <- ustoreDecompose ustore+  unless (null remained) $+    Left $ "Unrecognized entries in UStore: " +|| remained ||+ ""+  return res++-- | Recursive template traversal for 'mkUStore'.+mkUStoreRec+  :: (UStoreConversible template)+  => template -> Map ByteString ByteString+mkUStoreRec = gUstoreToVal . G.from++-- | Recursive template traversal for 'ustoreDecompose'.+storeDecomposeRec+  :: forall template.+     (UStoreConversible template)+  => UStoreContent -> Either Text (UStoreContent, template)+storeDecomposeRec = fmap (second G.to) ... gUstoreFromVal++-- | Recursive template traversal for 'fillUStore'.+fillUStoreRec+  :: (UStoreConversible template)+  => template+  -> Endo [MigrationAtom]+fillUStoreRec = gUstoreToScript . G.from++-- | Given template can be converted to 'UStore' value.+class (Generic template, GUStoreConversible (G.Rep template)) =>+       UStoreConversible template+instance (Generic template, GUStoreConversible (G.Rep template)) =>+         UStoreConversible template++-- | Generic traversal for 'mkUStore' and 'ustoreDecompose'.+class GUStoreConversible (template :: Kind.Type -> Kind.Type) where+  -- | Convert generic value to internal 'UStore' representation.+  gUstoreToVal :: template p -> Map ByteString ByteString++  -- | Parse internal 'UStore' representation into generic Haskell value of+  -- 'UStore', also returning unparsed entries.+  gUstoreFromVal+    :: UStoreContent+    -> Either Text (UStoreContent, template p)++  -- | Convert generic value to a script filling the corresponding 'UStore'.+  gUstoreToScript+    :: template p+    -> Endo [MigrationAtom]++instance GUStoreConversible x => GUStoreConversible (G.D1 i x) where+  gUstoreToVal = gUstoreToVal . G.unM1+  gUstoreFromVal = fmap (second G.M1) ... gUstoreFromVal+  gUstoreToScript = gUstoreToScript . G.unM1++instance GUStoreConversible x => GUStoreConversible (G.C1 i x) where+  gUstoreToVal = gUstoreToVal . G.unM1+  gUstoreFromVal = fmap (second G.M1) ... gUstoreFromVal+  gUstoreToScript = gUstoreToScript . G.unM1++instance TypeError ('Text "Unexpected sum type in UStore template") =>+         GUStoreConversible (x :+: y) where+  gUstoreToVal = error "impossible"+  gUstoreFromVal = error "impossible"+  gUstoreToScript = error "impossible"++instance TypeError ('Text "UStore template should have one constructor") =>+         GUStoreConversible G.V1 where+  gUstoreToVal = error "impossible"+  gUstoreFromVal = error "impossible"+  gUstoreToScript = error "impossible"++instance (GUStoreConversible x, GUStoreConversible y) =>+         GUStoreConversible (x :*: y) where+  gUstoreToVal (x :*: y) = gUstoreToVal x <> gUstoreToVal y+  gUstoreFromVal entries = do+    (entries', res1) <- gUstoreFromVal entries+    (entries'', res2) <- gUstoreFromVal entries'+    return (entries'', res1 :*: res2)+  gUstoreToScript (x :*: y) = gUstoreToScript x <> gUstoreToScript y++instance GUStoreConversible G.U1 where+  gUstoreToVal G.U1 = mempty+  gUstoreFromVal entries = pure (entries, G.U1)+  gUstoreToScript G.U1 = mempty++-- | Case of nested template.+instance {-# OVERLAPPABLE #-}+         (UStoreConversible template) =>+         GUStoreConversible (G.S1 i (G.Rec0 template)) where+  gUstoreToVal = mkUStoreRec . G.unK1 . G.unM1+  gUstoreFromVal = fmap (second $ G.M1 . G.K1) ... storeDecomposeRec+  gUstoreToScript = fillUStoreRec . G.unK1 . G.unM1++-- | Case of '|~>'.+instance ( NiceFullPackedValue k, NiceFullPackedValue v+         , KnownSymbol fieldName, Ord k+         ) =>+         GUStoreConversible (G.S1 ('G.MetaSel ('Just fieldName) _1 _2 _3)+                                  (G.Rec0 (k |~> v))) where+  gUstoreToVal (G.M1 (G.K1 (UStoreSubMap m))) =+    mconcat+      [ one ( lPackValue (fieldNameToMText @fieldName, k)+            , lPackValue v+            )+      | (k, v) <- Map.toList m+      ]++  gUstoreFromVal allEntries = do+    (unrecognized, res) <- foldM parseEntry (mempty, mempty) allEntries+    return (unrecognized, G.M1 . G.K1 $ UStoreSubMap res)+    where+    parseEntry+      :: (UStoreContent, Map k v)+      -> (ByteString, ByteString)+      -> Either Text (UStoreContent, Map k v)+    parseEntry (entries, !acc) entry@(key, val) =+      case lUnpackValue @(UStoreSubmapKey _) key of+        Left _ -> Right (entry : entries, acc)+        Right (name :: MText, keyValue :: k)+          | toText name /= toText (symbolVal $ Proxy @fieldName) ->+              Right (entry : entries, acc)+          | otherwise ->+            case lUnpackValue val of+              Left err ->+                Left $ "Failed to parse UStore value for " +|+                      demote @(ToT k) |+ " |~> " +| demote @(ToT v) |++                      ": " +| err |+ ""+              Right valValue ->+                Right (entries, Map.insert keyValue valValue acc)++  gUstoreToScript (G.M1 (G.K1 (UStoreSubMap m))) = Endo . (<>) $+    Map.toList m <&> \(k, v) ->+    formMigrationAtom Nothing $+      attachMigrationActionName (DAddAction "init submap") (fromLabel @fieldName) (Proxy @v) #+      -- @PUSH + PACK@ will be merged by optimizer, but there is still place+      -- for further improvement both or value and key pushing.+      -- We cannot push already packed value because that would break code+      -- analyzers and transformers, consider adding necessary rules to+      -- optimizer.+      -- TODO [TM-379]: consider improving this case+      -- or+      -- TODO: add necessary rules to optimizer+      L.push v # L.pack # L.some #+      L.push k # L.push (fieldNameToMText @fieldName) # L.pair #+      L.pack @(UStoreSubmapKey _) #+      L.update++-- | Case of 'UStoreField'.+instance (NiceFullPackedValue v, KnownUStoreMarker m, KnownSymbol fieldName) =>+         GUStoreConversible (G.S1 ('G.MetaSel ('Just fieldName) _1 _2 _3)+                                  (G.Rec0 (UStoreFieldExt m v))) where+  gUstoreToVal (G.M1 (G.K1 (UStoreField val))) =+    one ( mkFieldMarkerUKeyL @m (fromLabel @fieldName)+        , lPackValue val+        )++  gUstoreFromVal entries =+    let key = packValue' $ toVal (fieldNameToMText @fieldName)+    in case L.partition ((== key) . fst) entries of+        ([], _) ->+          Left $ "Failed to find field in UStore: " +|+                fieldNameToMText @fieldName |+ ""+        ([(_, val)], otherEntries) ->+          case lUnpackValue val of+            Left err ->+              Left $ "Failed to parse UStore value for field " +|+                    demote @(ToT v) |+ ": " +| err |+ ""+            Right valValue ->+              Right (otherEntries, G.M1 . G.K1 $ UStoreField valValue)+        (_ : _ : _, _) ->+          error "UStore content contained multiple entries with the same key"++  gUstoreToScript (G.M1 (G.K1 (UStoreField val))) =+    Endo . (:) . formMigrationAtom Nothing $+      attachMigrationActionName (DAddAction "init field") (fromLabel @fieldName) (Proxy @v) #+      -- Not pushing already packed value (which would be more efficient) because+      -- analyzers cannot work with packed values.+      -- TODO: make optimizer compress this to @push (Just $ lPackValue val)@+      L.push val # L.pack # L.some #++      L.push (mkFieldMarkerUKeyL @m (fromLabel @fieldName)) #+      L.update++-- Examples+----------------------------------------------------------------------------++data MyStoreTemplate = MyStoreTemplate+  { ints :: Integer |~> ()+  , flag :: UStoreField Bool+  }+  deriving stock (Generic)++data MyStoreTemplateBig = MyStoreTemplateBig+  { templ :: MyStoreTemplate+  , bytes :: ByteString |~> ByteString+  }+  deriving stock (Generic)++_storeSample :: UStore MyStoreTemplate+_storeSample = mkUStore+  MyStoreTemplate+  { ints = UStoreSubMap $ one (1, ())+  , flag = UStoreField False+  }++_storeSampleBig :: UStore MyStoreTemplateBig+_storeSampleBig = mkUStore $+  MyStoreTemplateBig+    MyStoreTemplate+      { ints = UStoreSubMap $ one (1, ())+      , flag = UStoreField False+      }+    (UStoreSubMap $ one ("a", "b"))
+ src/Lorentz/UStore/Instances.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Lorentz.UStore.Instances () where++import Lorentz.StoreClass+import Lorentz.UStore.Instr+import Lorentz.UStore.Types++instance HasUField fname ftype templ =>+         StoreHasField (UStore templ) fname ftype where+  storeFieldOps = StoreFieldOps+    { sopToField = ustoreToField+    , sopSetField = ustoreSetField+    }++instance HasUStore mname key value templ =>+         StoreHasSubmap (UStore templ) mname key value where+  storeSubmapOps = StoreSubmapOps+    { sopMem = ustoreMem+    , sopGet = ustoreGet+    , sopUpdate = ustoreUpdate+    , sopDelete = Just ustoreDelete+    , sopInsert = Just ustoreInsert+    }
+ src/Lorentz/UStore/Instr.hs view
@@ -0,0 +1,351 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Instructions to work with 'UStore'.+module Lorentz.UStore.Instr+  ( unsafeEmptyUStore+  , ustoreMem+  , ustoreGet+  , ustoreUpdate+  , ustoreInsert+  , ustoreInsertNew+  , ustoreDelete++  , ustoreToField+  , ustoreGetField+  , ustoreSetField+  , ustoreRemoveFieldUnsafe++    -- ** Instruction constraints+  , HasUStore+  , HasUField+  , HasUStoreForAllIn++    -- ** Internals+  , packSubMapUKey+  ) where++import qualified Data.Kind as Kind+import GHC.Generics ((:*:), (:+:))+import qualified GHC.Generics as G+import Data.Vinyl.Derived (Label)+import GHC.TypeLits (KnownSymbol, Symbol)+import Type.Reflection ((:~:)(Refl))++import Lorentz.Base+import Lorentz.Coercions (coerceWrap)+import Lorentz.Errors+import Lorentz.Instr as L+import Lorentz.Macro+import Lorentz.Constraints+import Lorentz.UStore.Types+import Lorentz.UStore.Common+import Michelson.Text+import Michelson.Typed.Haskell.Value++-- Helpers+----------------------------------------------------------------------------++type KeyAccessC store name =+  ( NiceFullPackedValue (GetUStoreKey store name)+  , KnownSymbol name+  )++type ValueAccessC store name =+  ( NiceFullPackedValue (GetUStoreValue store name)+  , KnownSymbol name+  )++type FieldAccessC store name =+  ( NiceFullPackedValue (GetUStoreField store name)+  , KnownUStoreMarker (GetUStoreFieldMarker store name)+  , KnownSymbol name+  )++packSubMapUKey+  :: forall (field :: Symbol) k s.+     (KnownSymbol field, NicePackedValue k)+  => (k : s) :-> (ByteString : s)+packSubMapUKey = push submapName # pair # pack @(UStoreSubmapKey _)+  where+    submapName = fieldNameToMText @field++unpackUValueUnsafe+  :: forall (field :: Symbol) val s.+     (KnownSymbol field, NiceUnpackedValue val)+  => (ByteString : s) :-> (val : s)+unpackUValueUnsafe = unpack @val # ifSome nop (failUsing failErr)+  where+    failErr = mconcat+      [ [mt|UStore: failed to unpack |]+      , fieldNameToMText @field+      ]++-- Main instructions+----------------------------------------------------------------------------++-- | Put an empty 'UStore' onto the stack. This function is generally unsafe:+-- if store template contains a 'UStoreField', the resulting 'UStore' is not+-- immediately usable.+-- If you are sure that 'UStore' contains only submaps, feel free to just use+-- the result of this function. Otherwise you must set all fields.+unsafeEmptyUStore :: forall store s. s :-> UStore store ': s+unsafeEmptyUStore = emptyBigMap # coerceWrap++ustoreMem+  :: forall store name s.+     (KeyAccessC store name)+  => Label name+  -> GetUStoreKey store name : UStore store : s :-> Bool : s+ustoreMem _ = packSubMapUKey @name # mem++ustoreGet+  :: forall store name s.+     (KeyAccessC store name, ValueAccessC store name)+  => Label name+  -> GetUStoreKey store name : UStore store : s+       :-> Maybe (GetUStoreValue store name) : s+ustoreGet _ =+  packSubMapUKey @name #+  L.get #+  lmap (unpackUValueUnsafe @name @(GetUStoreValue store name))++ustoreUpdate+  :: forall store name s.+     (KeyAccessC store name, ValueAccessC store name)+  => Label name+  -> GetUStoreKey store name+      : Maybe (GetUStoreValue store name)+      : UStore store+      : s+  :-> UStore store : s+ustoreUpdate _ =+  packSubMapUKey @name #+  dip (lmap pack) #+  update++ustoreInsert+  :: forall store name s.+     (KeyAccessC store name, ValueAccessC store name)+  => Label name+  -> GetUStoreKey store name+      : GetUStoreValue store name+      : UStore store+      : s+  :-> UStore store : s+ustoreInsert _ =+  packSubMapUKey @name #+  dip (pack # L.some) #+  update++-- | Insert a key-value pair, but fail if it will overwrite some existing entry.+ustoreInsertNew+  :: forall store name s.+     (KeyAccessC store name, ValueAccessC store name)+  => Label name+  -> (forall s0 any. GetUStoreKey store name : s0 :-> any)+  -> GetUStoreKey store name+      : GetUStoreValue store name+      : UStore store+      : s+  :-> UStore store : s+ustoreInsertNew label doFail =+  duupX @3 # duupX @2 # ustoreMem label #+  if_ doFail (ustoreInsert label)++ustoreDelete+  :: forall store name s.+     (KeyAccessC store name)+  => Label name+  -> GetUStoreKey store name : UStore store : s+     :-> UStore store : s+ustoreDelete _ =+  packSubMapUKey @name #+  dip none #+  update++-- | Like 'toField', but for 'UStore'.+--+-- This may fail only if 'UStore' was made up incorrectly during contract+-- initialization.+ustoreToField+  :: forall store name s.+     (FieldAccessC store name)+  => Label name+  -> UStore store : s+     :-> GetUStoreField store name : s+ustoreToField l =+  push (mkFieldUKey @store l) #+  L.get #+  ensureFieldIsPresent #+  unpackUValueUnsafe @name @(GetUStoreField store name)+  where+    ensureFieldIsPresent =+      ifSome nop $ failUsing $ mconcat+        [ [mt|UStore: no field |]+        , fieldNameToMText @name+        ]++-- | Like 'getField', but for 'UStore'.+--+-- This may fail only if 'UStore' was made up incorrectly during contract+-- initialization.+ustoreGetField+  :: forall store name s.+     (FieldAccessC store name)+  => Label name+  -> UStore store : s+     :-> GetUStoreField store name : UStore store : s+ustoreGetField label = dup # ustoreToField label++-- | Like 'setField', but for 'UStore'.+ustoreSetField+  :: forall store name s.+     (FieldAccessC store name)+  => Label name+  -> GetUStoreField store name : UStore store : s+     :-> UStore store : s+ustoreSetField l =+  pack # L.some #+  push (mkFieldUKey @store l) #+  L.update++-- | Remove a field from 'UStore', for internal purposes only.+ustoreRemoveFieldUnsafe+  :: forall store name s.+     (FieldAccessC store name)+  => Label name+  -> UStore store : s+     :-> UStore store : s+ustoreRemoveFieldUnsafe l =+  L.none #+  push (mkFieldUKey @store l) #+  L.update++-- | This constraint can be used if a function needs to work with+-- /big/ store, but needs to know only about some submap(s) of it.+--+-- It can use all UStore operations for a particular name, key and+-- value without knowing whole template.+type HasUStore name key value store =+   ( KeyAccessC store name, ValueAccessC store name+   , GetUStoreKey store name ~ key+   , GetUStoreValue store name ~ value+   )++-- | This constraint can be used if a function needs to work with+-- /big/ store, but needs to know only about some field of it.+type HasUField name ty store =+   ( FieldAccessC store name+   , GetUStoreField store name ~ ty+   )++-- | Write down all sensisble constraints which given @store@ satisfies+-- and apply them to @constrained@.+--+-- This store should have '|~>' and 'UStoreField' fields in its immediate fields,+-- no deep inspection is performed.+type HasUStoreForAllIn store constrained =+  (Generic store, GHasStoreForAllIn constrained (G.Rep store))++type family GHasStoreForAllIn (store :: Kind.Type) (x :: Kind.Type -> Kind.Type)+            :: Constraint where+  GHasStoreForAllIn store (G.D1 _ x) = GHasStoreForAllIn store x+  GHasStoreForAllIn store (x :+: y) =+    (GHasStoreForAllIn store x, GHasStoreForAllIn store y)+  GHasStoreForAllIn store (x :*: y) =+    (GHasStoreForAllIn store x, GHasStoreForAllIn store y)+  GHasStoreForAllIn store (G.C1 _ x) = GHasStoreForAllIn store x+  GHasStoreForAllIn store (G.S1 ('G.MetaSel ('Just name) _ _ _)+                            (G.Rec0 (key |~> value))) =+    HasUStore name key value store+  GHasStoreForAllIn store (G.S1 ('G.MetaSel ('Just name) _ _ _)+                            (G.Rec0 (UStoreFieldExt _ value))) =+    HasUField name value store+  GHasStoreForAllIn _ G.V1 = ()+  GHasStoreForAllIn _ G.U1 = ()++----------------------------------------------------------------------------+-- Examples+----------------------------------------------------------------------------++data MyStoreTemplate = MyStoreTemplate+  { ints :: Integer |~> ()+  , bytes :: ByteString |~> ByteString+  , flag :: UStoreField Bool+  , entrypoint :: UStoreFieldExt Marker1 Integer+  }+  deriving stock (Generic)++type MyStore = UStore MyStoreTemplate++data Marker1 :: UStoreMarkerType+  deriving anyclass KnownUStoreMarker++_sample1 :: Integer : MyStore : s :-> MyStore : s+_sample1 = ustoreDelete @MyStoreTemplate #ints++_sample2 :: ByteString : ByteString : MyStore : s :-> MyStore : s+_sample2 = ustoreInsert @MyStoreTemplate #bytes++_sample3 :: MyStore : s :-> Bool : s+_sample3 = ustoreToField @MyStoreTemplate #flag++_sample3'5 :: MyStore : s :-> Integer : s+_sample3'5 = ustoreToField @MyStoreTemplate #entrypoint++data MyStoreTemplate2 = MyStoreTemplate2+  { bools :: Bool |~> Bool+  , ints2 :: Integer |~> Integer+  , ints3 :: Integer |~> Bool+  }+  deriving stock (Generic)++newtype MyNatural = MyNatural Natural+  deriving newtype (IsoCValue, IsoValue)++data MyStoreTemplate3 = MyStoreTemplate3 { store3 :: Natural |~> MyNatural }+  deriving stock Generic++data MyStoreTemplateBig = MyStoreTemplateBig+  MyStoreTemplate+  MyStoreTemplate2+  MyStoreTemplate3+  deriving stock Generic++_MyStoreTemplateBigTextsStore ::+  GetUStore "bytes" MyStoreTemplateBig :~: 'MapSignature ByteString ByteString+_MyStoreTemplateBigTextsStore = Refl++_MyStoreTemplateBigBoolsStore ::+  GetUStore "bools" MyStoreTemplateBig :~: 'MapSignature Bool Bool+_MyStoreTemplateBigBoolsStore = Refl++_MyStoreTemplateBigMyStoreTemplate3 ::+  GetUStore "store3" MyStoreTemplateBig :~: 'MapSignature Natural MyNatural+_MyStoreTemplateBigMyStoreTemplate3 = Refl++type MyStoreBig = UStore MyStoreTemplateBig++_sample4 :: Integer : MyStoreBig : s :-> MyStoreBig : s+_sample4 = ustoreDelete #ints2++_sample5 :: ByteString : MyStoreBig : s :-> Bool : s+_sample5 = ustoreMem #bytes++_sample6 :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s+_sample6 = ustoreInsert #store3++-- | When you want to express a constraint like+-- "given big store contains all elements present in given small concrete store",+-- you can use 'HasUStoreForAllIn'.+--+-- Here @store@ is a big store, and we expect it to contain 'MyStoreTemplate'+-- entirely.+_sample7+  :: HasUStoreForAllIn MyStoreTemplate store+  => UStore store : s :-> Bool : Maybe ByteString : s+_sample7 = ustoreGetField #flag # dip (push "x" # ustoreGet #bytes)++-- | '_sample7' with @store@ instantiated to 'MyStoreTemplateBig'.+_sample7' :: UStore MyStoreTemplateBig : s :-> Bool : Maybe ByteString : s+_sample7' = _sample7
+ src/Lorentz/UStore/Lift.hs view
@@ -0,0 +1,111 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Composability helper for 'UStore'.+module Lorentz.UStore.Lift+  ( liftUStore+  , unliftUStore++    -- * Internals+  , UStoreFieldsAreUnique+  ) where++import Data.Vinyl.Derived (Label)+import Data.Type.Bool (If)+import qualified Data.Kind as Kind+import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))+import Data.Vinyl.TypeLevel (type (++))+import GHC.Generics (type (:+:), type (:*:))+import qualified GHC.Generics as G++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Instr+import Lorentz.UStore.Types+import Michelson.Typed.Haskell+import Util.Type++-- | Get all fields names accessible in given 'UStore' template.+type UStoreFields (template :: Kind.Type) = GUStoreFields (G.Rep template)++type family GUStoreFields (x :: Kind.Type -> Kind.Type) :: [Symbol] where+  -- We are not oblidged to fail in case of bad template - this will be handled+  -- in other operations with 'UStore' anyway.+  GUStoreFields (G.D1 _ x) = GUStoreFields x+  GUStoreFields (_ :+: _) = '[]+  GUStoreFields G.V1 = '[]+  GUStoreFields (G.C1 _ x) = GUStoreFields x+  GUStoreFields (x :*: y) = GUStoreFields x ++ GUStoreFields y+  GUStoreFields (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (_ |~> _))) =+    '[fieldName]+  GUStoreFields (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (UStoreFieldExt _ _))) =+    '[fieldName]+  GUStoreFields (G.S1 _ (G.Rec0 a)) =+    UStoreFields a++type UStoreFieldsAreUnique template = AllUnique (UStoreFields template)++type family RequireAllUniqueFields (template :: Kind.Type) :: Constraint where+  RequireAllUniqueFields template =+    If (UStoreFieldsAreUnique template)+       (() :: Constraint)+       (TypeError ('Text "Some field in template is duplicated"))+      -- TODO: if this ever fires for you and it's not clear which exact field+      -- is duplicated, please create a ticket to implement the corresponding+      -- logic.++-- | Lift an 'UStore' to another 'UStore' which contains all the entries+-- of the former under given field.+--+-- This function is not intended for use in migrations, only in normal+-- entry points.+--+-- Note that this function ensures that template of resulting store+-- does not contain inner nested templates with duplicated fields,+-- otherwise 'UStore' invariants could get broken.+liftUStore+  :: (Generic template, RequireAllUniqueFields template)+  => Label name+  -> UStore (GetFieldType template name) : s :-> UStore template : s+liftUStore _ = forcedCoerce_++-- | Unlift an 'UStore' to a smaller 'UStore' which is part of the former.+--+-- This function is not intended for use in migrations, only in normal+-- entry points.+--+-- Surprisingly, despite smaller 'UStore' may have extra entries,+-- this function is safe when used in contract code.+-- Truly, all getters and setters are still safe to use.+-- Also, there is no way for the resulting small @UStore@ to leak outside+-- of the contract since the only place where 'big_map' can appear+-- is contract storage, so this small @UStore@ can be either dropped+-- or lifted back via 'liftUStore' to appear as part of the new contract's state.+--+-- When this function is run as part of standalone instructions sequence,+-- not as part of contract code (e.g. in tests), you may get an @UStore@+-- with entries not inherent to it.+unliftUStore+  :: (Generic template)+  => Label name+  -> UStore template : s :-> UStore (GetFieldType template name) : s+unliftUStore _ = forcedCoerce_++-- Examples+----------------------------------------------------------------------------++data MyStoreTemplate = MyStoreTemplate+  { ints :: Integer |~> Integer+  } deriving stock Generic++data MyStoreTemplateBig = MyStoreTemplateBig+  { bool :: UStoreField Bool+  , substore :: MyStoreTemplate+  } deriving stock Generic++-- | This example demostrates a way to run an instruction, operating on small+-- 'UStore', so that it works on a larger 'UStore'.+_sampleWithMyStore+  :: ('[param, UStore MyStoreTemplate] :-> '[UStore MyStoreTemplate])+  -> ('[param, UStore MyStoreTemplateBig] :-> '[UStore MyStoreTemplateBig])+_sampleWithMyStore instr =+  dip (unliftUStore #substore) # instr # liftUStore #substore
+ src/Lorentz/UStore/Migration.hs view
@@ -0,0 +1,89 @@+{- | Type-safe migrations of UStore.++This implements imperative approach to migration when we make user+write a code of migration and track whether all new fields were indeed added+and all unnecessary fields were removed.++You can find migration examples in tests.++== How to write your simple migration++1. Start with migration template:++    @+    migration :: 'UStoreMigration' V1.Storage V2.Storage+    migration = 'mkUStoreMigration' $ do+      -- migration code to be put here+      'migrationFinish'+    @++    You will be prompted with a list of fields which should be added or removed.++2. Add/remove necessary fields using 'migrateAddField', 'migrateExtractField'+and other instructions.+They allow you to operate with 'MUStore' — it is similar to 'UStore'+but used within 'mkUStoreMigration' to track migration progress.++3. Use 'migrationToScript' or 'migrationToTestScript' to turn 'UStoreMigration'+into something useful.++Note that here you will get a solid 'MigrationScript', thus migration has+to fit into single Tezos transaction. If that's an issue, see the next section.++== How to write batched migration++1. Insert migration template.++    It looks like:++    @+    migration :: 'UStoreMigration' V1.Storage V2.Storage+    migration = 'mkUStoreBatchedMigration' $+      -- place for migration blocks+      'migrationFinish'+    @++2. Fill migration code with blocks like++    @+    'mkUStoreBatchedMigration' $+      'muBlock' '$:' do+        -- code for block 1+      '<-->'+      'muBlock' '$:' do+        -- code for block 2+      '<-->'+      'migrationFinish'+    @++    Migration blocks have to be the smallest actions which can safely be mixed+    and splitted accross migration stages.++3. Compile migration with 'compileBatchedMigration'.++    Here you have to supply batching implementation. Alternatives include++    * 'mbNoBatching';+    * 'mbBatchesAsIs';+    * Functions from 'Lorentz.UStore.Migration.Batching' module.++4. Get the required information about migration.++    * 'migrationToScripts' picks the migration scripts, each has to be put+      in a separate Tezos transaction.++    * 'buildMigrationPlan' - dump description of each migration stage.++== Manual migrations++If for some reasons you need to define migration manually, you can use+functions from @Manual migrations@ section of "Lorentz.UStore.Migration.Base".++-}+module Lorentz.UStore.Migration+  ( module Exports+  ) where++import Lorentz.UStore.Migration.Base as Exports+import Lorentz.UStore.Migration.Batching as Exports+import Lorentz.UStore.Migration.Blocks as Exports
+ src/Lorentz/UStore/Migration/Base.hs view
@@ -0,0 +1,497 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{- | Basic migration primitives.++All primitives in one scheme:+++                         MigrationBlocks+                   (batched migrations writing)+                    /|          ||+           muBlock //           || mkUStoreBatchedMigration+                  //            ||+                 //             ||+             MUStore            ||         UStore template value+    (simple migration writing)  ||       (storage initialization)+                    \\          ||         //+                     \\         ||        //+    mkUStoreMigration \\        ||       // fillUStore+                       \|       \/      |/+                         UStoreMigration+                        (whole migration)+                              ||    \\+                              ||     \\+            migrationToScript ||      \\ compileMigration+                              ||       \\                    MigrationBatching+                              ||        \\                (way to slice migration)+                              ||         \\                    //+                              ||          \\                  //+                              ||           \|                |/+                              ||         UStoreMigrationCompiled+                              ||           (sliced migration)+                              ||          //                 \\+                              ||    migrationToScripts        \\ buildMigrationPlan+                              ||        //                     \\ migrationStagesNum+                              ||       //                       \\ ...+                              \/      |/                         \|+                        MigrationScript                    Information about migration+                    (part of migration which            (migration plan, stages number...)+                  fits into Tezos transaction)++-}+module Lorentz.UStore.Migration.Base+  ( -- * 'UStore' utilities+    SomeUTemplate+  , UStore_++    -- * Basic migration primitives+  , MigrationScript (..)+  , maNameL+  , maScriptL+  , maActionsDescL+  , MigrationScriptFrom+  , MigrationScriptTo+  , MigrationScript_+  , MigrationAtom (..)+  , UStoreMigration (..)+  , MigrationBlocks (..)+  , MUStore (..)+  , migrationToLambda+  , mapMigrationCode++    -- ** Simple migrations+  , mkUStoreMigration+  , migrationToScript+  , migrationToScriptI++    -- ** Batched migrations+  , MigrationBatching (..)+  , mbBatchesAsIs+  , mbNoBatching+  , compileMigration+  , UStoreMigrationCompiled (..)+  , mkUStoreBatchedMigration+  , migrationToScripts+  , migrationToScriptsList+  , migrationToInfo+  , migrationStagesNum+  , buildMigrationPlan++    -- * Manual migrations+  , manualWithOldUStore+  , manualWithNewUStore+  , manualConcatMigrationScripts+  , manualMapMigrationScript++    -- * Extras+  , DMigrationActionType (..)+  , DMigrationActionDesc (..)+  , attachMigrationActionName++    -- * Internals+  , formMigrationAtom+  ) where++import Control.Lens (traversed, _Wrapped')+import Data.Default (def)+import qualified Data.Foldable as Foldable+import qualified Data.Kind as Kind+import Data.Singletons (SingI(..), demote)+import qualified Data.Typeable as Typeable+import Data.Vinyl.Derived (Label)+import Fmt (Buildable(..), Builder, fmt)++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Doc+import Lorentz.Instr (nop)+import Lorentz.Run+import Lorentz.UStore.Types+import Lorentz.Value+import Michelson.Typed (ExtInstr(..), Instr(..), T(..))+import Michelson.Typed.Util+import Util.Lens+import Util.TypeLits++import Lorentz.UStore.Migration.Diff++----------------------------------------------------------------------------+-- UStore utilities+----------------------------------------------------------------------------++-- | Dummy template for 'UStore', use this when you want to forget exact template+-- and make type of store homomorphic.+data SomeUTemplate++-- | UStore with hidden template.+type UStore_ = UStore SomeUTemplate++-- | We allow casting between 'UStore_' and 'UStore' freely.+instance SameUStoreTemplate template1 template2 =>+         UStore template1 `CanCastTo` UStore template2++type family SameUStoreTemplate (template1 :: Kind.Type) (template2 :: Kind.Type)+              :: Constraint where+  SameUStoreTemplate t t = ()  -- case for undeducible but equal types+  SameUStoreTemplate SomeUTemplate _ = ()+  SameUStoreTemplate _ SomeUTemplate = ()+  SameUStoreTemplate t1 t2 = (t1 ~ t2)++----------------------------------------------------------------------------+-- Migration primitives+----------------------------------------------------------------------------++-- | Code of migration for 'UStore'.+--+-- Invariant: preferably should fit into op size / gas limits (quite obvious).+-- Often this stands for exactly one stage of migration (one Tezos transaction).+newtype MigrationScript (oldStore :: Kind.Type) (newStore :: Kind.Type) =+  MigrationScript+  { unMigrationScript :: Lambda UStore_ UStore_+  } deriving stock (Show, Generic)+    deriving anyclass IsoValue++instance Wrapped (MigrationScript oldStore newStore)++instance (Typeable oldStore, Typeable newStore) =>+         TypeHasDoc (MigrationScript oldStore newStore) where+  typeDocMdDescription =+    "A code which updates storage in order to make it compliant with the \+    \new version of the contract."+  typeDocMdReference tp = customTypeDocMdReference ("MigrationScript", DType tp) []+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep++instance Lambda (UStore ot1) (UStore nt1) `CanCastTo` Lambda (UStore ot2) (UStore nt2) =>+         MigrationScript ot1 nt1 `CanCastTo` MigrationScript ot2 nt2++-- | Corner case of 'MigrationScript' with some type argument unknown.+--+-- You can turn this into 'MigrationScript' using 'checkedCoerce'.+type MigrationScriptFrom oldStore = MigrationScript oldStore SomeUTemplate+type MigrationScriptTo newStore = MigrationScript SomeUTemplate newStore+type MigrationScript_ = MigrationScript SomeUTemplate SomeUTemplate++-- | Manually perform a piece of migration.+manualWithUStore+  :: forall ustore template oldStore newStore.+      (ustore ~ UStore template)+  => ('[ustore] :-> '[ustore]) -> MigrationScript oldStore newStore+manualWithUStore action = MigrationScript $ checkedCoercing_ action++manualWithOldUStore+  :: ('[UStore oldStore] :-> '[UStore oldStore]) -> MigrationScript oldStore newStore+manualWithOldUStore = manualWithUStore++manualWithNewUStore+  :: ('[UStore newStore] :-> '[UStore newStore]) -> MigrationScript oldStore newStore+manualWithNewUStore = manualWithUStore++manualMapMigrationScript+  :: (('[UStore_] :-> '[UStore_]) -> ('[UStore_] :-> '[UStore_]))+  -> MigrationScript oldStore newStore+  -> MigrationScript oldStore newStore+manualMapMigrationScript f = MigrationScript . f . unMigrationScript++-- | Merge several migration scripts. Used in manual migrations.+--+-- This function is generally unsafe because resulting migration script can fail+-- to fit into operation size limit.+manualConcatMigrationScripts :: [MigrationScript os ns] -> MigrationScript os ns+manualConcatMigrationScripts =+  MigrationScript . foldl' (#) nop . fmap unMigrationScript++-- | An action on storage entry.+data DMigrationActionType+  = DAddAction Text+    -- ^ Some sort of addition: "init", "set", "overwrite", e.t.c.+  | DDelAction+    -- ^ Removal.+  deriving stock (Show)++instance Buildable DMigrationActionType where+  build = \case+    DAddAction a -> build a+    DDelAction -> "remove"++-- | Describes single migration action.+--+-- In most cases it is possible to derive reasonable description for migration+-- atom automatically, this datatype exactly carries this information.+data DMigrationActionDesc = DMigrationActionDesc+  { manAction :: DMigrationActionType+    -- ^ Action on field, e.g. "set", "remove", "overwrite".+  , manField :: Text+    -- ^ Name of affected field of 'UStore'.+  , manFieldType :: T+    -- ^ Type of affected field of 'UStore' in new storage version.+  } deriving stock (Show)++-- Sad that we need to write this useless documentation instance, probably it's+-- worth generalizing @doc_group@ and @doc_item@ instructions so that they+-- could serve as multi-purpose markers.+instance DocItem DMigrationActionDesc where+  type DocItemPosition DMigrationActionDesc = 105010+  docItemSectionName = Nothing+  docItemToMarkdown _ _ = "Migration action"++-- | Add description of action, it will be used in rendering migration plan and+-- some batching implementations.+attachMigrationActionName+  :: (KnownSymbol fieldName, SingI (ToT fieldTy))+  => DMigrationActionType+  -> Label fieldName+  -> Proxy fieldTy+  -> s :-> s+attachMigrationActionName action (_ :: Label fieldName) (_ :: Proxy fieldTy) =+  doc $ DMigrationActionDesc+  { manAction = action+  , manField = symbolValT' @fieldName+  , manFieldType = demote @(ToT fieldTy)+  }++-- | Minimal possible piece of migration script.+--+-- Different atoms can be arbitrarily reordered and separated across migration+-- stages, but each single atom is treated as a whole.+--+-- Splitting migration into atoms is responsibility of migration writer.+data MigrationAtom = MigrationAtom+  { maName :: Text+  , maScript :: MigrationScript_+  , maActionsDesc :: [DMigrationActionDesc]+  } deriving stock (Show)++makeLensesWith postfixLFields ''MigrationAtom++-- | Keeps information about migration between 'UStore's with two given+-- templates.+data UStoreMigration (oldTempl :: Kind.Type) (newTempl :: Kind.Type) where+  UStoreMigration+    :: [MigrationAtom]+    -> UStoreMigration oldTempl newTempl++-- | Turn 'Migration' into a whole piece of code for transforming storage.+--+-- This is not want you'd want to use for contract deployment because of+-- gas and operation size limits that Tezos applies to transactions.+migrationToLambda+  :: UStoreMigration oldTemplate newTemplate+  -> Lambda (UStore oldTemplate) (UStore newTemplate)+migrationToLambda (UStoreMigration atoms) =+  checkedCoerce_ # foldMap (unMigrationScript . maScript) atoms # checkedCoerce_++-- | Modify all code in migration.+mapMigrationCode+  :: (forall i o. (i :-> o) -> (i :-> o))+  -> UStoreMigration os ns+  -> UStoreMigration os ns+mapMigrationCode f (UStoreMigration atoms) =+  UStoreMigration $+    atoms & traversed . maScriptL . _Wrapped' %~ f++-- | A bunch of migration atoms produced by migration writer.+newtype MigrationBlocks (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type)+                        (preRemDiff :: [DiffItem]) (preTouched :: [Symbol])+                        (postRemDiff :: [DiffItem]) (postTouched :: [Symbol]) =+  MigrationBlocks [MigrationAtom]++{- | Wrapper over 'UStore' which is currently being migrated.++In type-level arguments it keeps++* Old and new 'UStore' templates - mostly for convenience of the implementation.++* Remaining diff which yet should be covered. Here we track migration progress.+Once remaining diff is empty, migration is finished.++* Names of fields which have already been touched by migration.+Required to make getters safe.+-}+newtype MUStore (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type)+                (remDiff :: [DiffItem]) (touched :: [Symbol]) =+  MUStoreUnsafe (UStore oldTemplate)+  deriving stock Generic+  deriving anyclass IsoValue++-- | Create migration atom from code.+--+-- This is an internal function, should not be used for writing migrations.+formMigrationAtom+  :: Maybe Text+  -> Lambda UStore_ UStore_+  -> MigrationAtom+formMigrationAtom mname code =+  MigrationAtom+  { maName = name+  , maScript = MigrationScript (checkedCoercing_ code)+  , maActionsDesc = actionsDescs+  }+  where+    name = case mname of+      Just n -> n+      Nothing ->+        fmt . mconcat $ intersperse ", "+          [ build action <> " \"" <> build field <> "\""+          | DMigrationActionDesc action field _type <- actionsDescs+          ]++    actionsDescs =+      let instr = compileLorentz code+          (_, actions) = dfsInstr def (\i -> (i, pickActionDescs i)) instr+      in actions++    pickActionDescs :: Instr i o -> [DMigrationActionDesc]+    pickActionDescs i = case i of+      Ext (DOC_ITEM (SomeDocItem di)) ->+        [ d+        | Just d@DMigrationActionDesc{} <- pure $ Typeable.cast di+        ]+      _ -> []++-- | Way of distributing migration atoms among batches.+--+-- This also participates in describing migration plan and should contain+-- information which would clarify to a user why migration is splitted+-- such a way. Objects of type @batchInfo@ stand for information corresponding to+-- a batch and may include e.g. names of taken actions and gas consumption.+--+-- Type argument @structure@ stands for container where batches will be put to+-- and is usually a list ('[]').+--+-- When writing an instance of this datatype, you should tend to produce+-- as few batches as possible because Tezos transaction execution overhead+-- is quite high; though these batches should still preferably fit into gas limit.+--+-- Note that we never fail here because reaching perfect consistency with Tezos+-- gas model is beyond dreams for now, even if our model predicts that some+-- migration atom cannot be fit into gas limit, Tezos node can think differently+-- and accept the migration.+-- If your batching function can make predictions about fitting into gas limit,+-- consider including this information in @batchInfo@ type.+--+-- See batching implementations in "Lorentz.UStore.Migration.Batching" module.+data MigrationBatching (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) =+  MigrationBatching ([MigrationAtom] -> structure (batchInfo, MigrationScript_))++-- | Put each migration atom to a separate batch.+--+-- In most cases this is not what you want, but may be useful if e.g. you write+-- your migration manually.+mbBatchesAsIs :: MigrationBatching [] Text+mbBatchesAsIs = MigrationBatching $+  map (maName &&& maScript)++-- | Put the whole migration into one batch.+mbNoBatching :: MigrationBatching Identity Text+mbNoBatching = MigrationBatching $+  Identity . \atoms ->+    ( mconcat . intersperse ", " $ maName <$> atoms+    , manualConcatMigrationScripts (maScript <$> atoms)+    )++-- | Version of 'mkUStoreMigration' which allows splitting migration in batches.+--+-- Here you supply a sequence of migration blocks which then are automatically+-- distributed among migration stages.+mkUStoreBatchedMigration+  :: MigrationBlocks oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] _1+  -> UStoreMigration oldTempl newTempl+mkUStoreBatchedMigration (MigrationBlocks blocks) = UStoreMigration blocks++-- | Safe way to create migration scripts for 'UStore'.+--+-- You have to supply a code which would transform 'MUStore',+-- coverring required diff step-by-step.+-- All basic instructions work, also use @migrate*@ functions+-- from this module to operate with 'MUStore'.+--+-- This method produces a whole migration, it cannot be splitted in batches.+-- In case if your migration is too big to be applied within a single+-- transaction, use 'mkUStoreBatchedMigration'.+mkUStoreMigration+  :: Lambda+       (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[])+       (MUStore oldTempl newTempl '[] _1)+  -> UStoreMigration oldTempl newTempl+mkUStoreMigration code =+  mkUStoreBatchedMigration $+    MigrationBlocks . one . formMigrationAtom (Just "Migration") $+      forcedCoerce_ # code # forcedCoerce_++-- | Migration script splitted in batches.+--+-- This is an intermediate form of migration content and needed because+-- compiling 'UStoreMigration' is a potentially heavyweight operation,+-- and after compilation is performed you may need to get various information like+-- number of migration steps, migration script, migration plan and other.+newtype UStoreMigrationCompiled+          (oldStore :: Kind.Type) (newStore :: Kind.Type)+          (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) =+  UStoreMigrationCompiled+  { compiledMigrationContent+     :: structure (batchInfo, MigrationScript oldStore newStore)+  }++-- | Compile migration for use in production.+compileMigration+  :: (Functor t)+  => MigrationBatching t batchInfo+  -> UStoreMigration ot nt+  -> UStoreMigrationCompiled ot nt t batchInfo+compileMigration (MigrationBatching toBatches) (UStoreMigration blks) =+  UStoreMigrationCompiled (second forcedCoerce <$> toBatches blks)++-- | Get migration scripts, each to be executed in separate Tezos transaction.+migrationToScripts+  :: Traversable t+  => UStoreMigrationCompiled os ns t batchInfo+  -> t (MigrationScript os ns)+migrationToScripts = map snd . compiledMigrationContent++-- | Get migration scripts as list.+migrationToScriptsList+  :: Traversable t+  => UStoreMigrationCompiled os ns t batchInfo+  -> [MigrationScript os ns]+migrationToScriptsList = Foldable.toList . migrationToScripts++-- | Get migration script in case of simple (non-batched) migration.+migrationToScriptI+  :: UStoreMigration os ns+  -> Identity (MigrationScript os ns)+migrationToScriptI =+  migrationToScripts . compileMigration mbNoBatching++-- | Get migration script in case of simple (non-batched) migration.+migrationToScript+  :: UStoreMigration os ns+  -> MigrationScript os ns+migrationToScript =+  runIdentity . migrationToScriptI++-- | Get information about each batch.+migrationToInfo+  :: Traversable t+  => UStoreMigrationCompiled ot nt t batchInfo+  -> t batchInfo+migrationToInfo = map fst . compiledMigrationContent++-- | Number of stages in migration.+migrationStagesNum+  :: Traversable t+  => UStoreMigrationCompiled ot nt t batchInfo -> Int+migrationStagesNum = Foldable.length . migrationToScripts++-- | Render migration plan.+buildMigrationPlan+  :: (Traversable t, Buildable batchInfo)+  => UStoreMigrationCompiled ot nt t batchInfo -> Builder+buildMigrationPlan content =+  let infos = Foldable.toList $ migrationToInfo content+  in mconcat+     [ "Migration stages:\n"+     , mconcat $ zip [1..] infos <&> \(i :: Int, info) ->+        build i <> ") " <> build info <> "\n"+     ]
+ src/Lorentz/UStore/Migration/Batching.hs view
@@ -0,0 +1,113 @@+-- | Different approaches to batching.+--+-- For now we do not support perfect batching because operation size evaluation+-- (as well as gas consumption evaluation) is not implemented yet.+-- The only non-trivial batching implementation we provide is+-- 'mbSeparateLambdas'.+module Lorentz.UStore.Migration.Batching+  ( -- * Separate-lambdas batching+    SlBatchType (..)+  , SlBatchInfo (..)+  , mbSeparateLambdas+  ) where++import qualified Data.List as L+import Fmt (Buildable(..))+import System.Console.Pretty (Color(..), color)++import Lorentz.UStore.Migration.Base+import Michelson.Typed++----------------------------------------------------------------------------+-- Separating lambdas+----------------------------------------------------------------------------++-- | Type of batch.+data SlBatchType+  = SlbtData+    -- ^ Addition of any type of data.+  | SlbtLambda+    -- ^ Addition of code.+  | SlbtCustom+    -- ^ Several joined actions of different types.+  | SlbtUnknown+    -- ^ No information to chooseType about batching.+    -- This means that the given action does not contain 'DMigrationActionDesc'.+  deriving stock (Show, Eq)++slbtIsData :: SlBatchType -> Bool+slbtIsData = \case { SlbtData -> True; _ -> False }++data SlBatchInfo = SlBatchInfo+  { slbiType :: SlBatchType+  , slbiActions :: [Text]+  }++instance Buildable SlBatchInfo where+  build (SlBatchInfo ty actions) = mconcat+    [ build @Text $ case ty of+        SlbtData -> color Blue "[data]"+        SlbtLambda -> color Green "[code]"+        SlbtCustom -> color Yellow "[custom]"+        SlbtUnknown -> color Red "[unknown]"+    , " "+    , case actions of+        [] -> "-"+        [a] -> build a+        as -> foldMap (\a -> "\n  * " <> build a) as+    ]++-- | Puts all data updates in one batch, and all lambdas in separate batches,+-- one per batch.+--+-- The reason for such behaviour is that in production contracts amount of+-- changed data (be it in contract initialization or contract upgrade) is small,+-- while stored entrypoints are huge and addition of even one entrypoint often+-- barely fits into gas limit.+mbSeparateLambdas :: MigrationBatching [] SlBatchInfo+mbSeparateLambdas = MigrationBatching $ \atoms ->+  let+    atomsWithType = atoms <&> \a -> (atomType a, a)+    (dataAtoms, otherAtoms) = L.partition (slbtIsData . fst) atomsWithType+    dataMigration =+      ( SlBatchInfo SlbtData (nubCounting $ maName . snd <$> dataAtoms)+      , manualConcatMigrationScripts (maScript . snd <$> dataAtoms)+      )+    otherMigrations =+      [ (SlBatchInfo ty [maName atom], maScript atom)+      | (ty, atom) <- otherAtoms+      ]+  in dataMigration : otherMigrations+  where+    atomType :: MigrationAtom -> SlBatchType+    atomType = chooseType . maActionsDesc++    chooseType :: [DMigrationActionDesc] -> SlBatchType+    chooseType = \case+      [] -> SlbtUnknown+      xs | all isLambda xs -> SlbtLambda+      xs | all (not . isAddLambda) xs -> SlbtData+         | otherwise -> SlbtCustom++    isLambda :: DMigrationActionDesc -> Bool+    isLambda = \case { TLambda{} -> True; _ -> False } . manFieldType++    isAddLambda :: DMigrationActionDesc -> Bool+    isAddLambda a = and+      [ isLambda a+      , case manAction a of { DAddAction _ -> True; _ -> False }+      ]++-- | Similar to 'nub', counts number of invocations and attaches to text entry.+--+-- >>> nubCounting ["a", "b", "a"]+-- ["a (x2)", "b"]+nubCounting :: [Text] -> [Text]+nubCounting = \case+  [] -> []+  x : xs ->+    let ((length -> repetitions), others) = L.partition (== x) xs+        x' = if repetitions == 0+             then x+             else x <> " (x" <> show (repetitions + 1) <> ")"+    in x' : nubCounting others
+ src/Lorentz/UStore/Migration/Blocks.hs view
@@ -0,0 +1,287 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Elemental building blocks for migrations.+module Lorentz.UStore.Migration.Blocks+  ( -- * General+    mustoreToOld+  , MigrationFinishCheckPosition (..)++    -- * Elemental steps+  , migrateCoerceUnsafe+  , migrateGetField+  , migrateAddField+  , migrateRemoveField+  , migrateExtractField+  , migrateOverwriteField+  , migrateModifyField++    -- * Migration batches+  , muBlock+  , muBlockNamed+  , (<-->)+  , ($:)+  ) where++import Data.Vinyl.Derived (Label)++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Instr (dip)+import Lorentz.UStore.Instr+import Lorentz.UStore.Migration.Base+import Lorentz.UStore.Migration.Diff+import Lorentz.UStore.Types+import Util.Type+import Util.TypeLits++-- | Helper for 'mustoreToOld' which ensures that given store hasn't been+-- (partially) migrated yet.+type family RequireBeInitial (touched :: [Symbol]) :: Constraint where+  RequireBeInitial '[] = ()+  RequireBeInitial _ =+    TypeError ('Text "Migration has already been started over this store")++type family RequireUntouched (field :: Symbol) (wasTouched :: Bool)+             :: Constraint where+  RequireUntouched _ 'False = ()+  RequireUntouched field 'True = TypeError+    ('Text ("Field `" `AppendSymbol` field `AppendSymbol` "` has already been \+            \migrated and cannot be read")+    )++-- | Cast field or submap pretending that its value fits to the new type.+--+-- Useful when type of field, e.g. lambda or set of lambdas, is polymorphic+-- over storage type.+migrateCoerceUnsafe+  :: forall field oldTempl newTempl diff touched newDiff newDiff0 _1 _2 s.+     ( '(_1, newDiff0) ~ CoverDiff 'DcRemove field diff+     , '(_2, newDiff) ~ CoverDiff 'DcAdd field newDiff0+     )+  => Label field+  -> MUStore oldTempl newTempl diff touched : s+  :-> MUStore oldTempl newTempl newDiff touched : s+migrateCoerceUnsafe _ =+  forcedCoerce_++-- Migrating fields+----------------------------------------------------------------------------++-- | Get a field present in old version of 'UStore'.+migrateGetField+  :: forall field oldTempl newTempl diff touched fieldTy s.+     ( HasUField field fieldTy oldTempl+     , RequireUntouched field (field `IsElem` touched)+     )+  => Label field+  -> MUStore oldTempl newTempl diff touched : s+  :-> fieldTy : MUStore oldTempl newTempl diff touched : s+migrateGetField label =+  forcedCoerce_ @_ @(UStore oldTempl) # ustoreGetField label # dip forcedCoerce_++-- | Add a field which was not present before.+-- This covers one addition from the diff and any removals of field with given+-- name.+--+-- This function cannot overwrite existing field with the same name, if this+-- is necessary use 'migrateOverwriteField' which would declare removal+-- explicitly.+migrateAddField+  :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.+     ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcAdd field diff+     , HasUField field fieldTy newTempl+     )+  => Label field+  -> fieldTy : MUStore oldTempl newTempl diff touched : s+  :-> MUStore oldTempl newTempl newDiff (field ': touched) : s+migrateAddField label =+  attachMigrationActionName (DAddAction "add") label (Proxy @fieldTy) #+  dip (forcedCoerce_ @_ @(UStore newTempl)) # ustoreSetField label # forcedCoerce_++-- | Remove a field which should not be present in new version of storage.+-- This covers one removal from the diff.+--+-- In fact, this action could be performed automatically, but since+-- removal is a destructive operation, being explicit about it seems+-- like a good thing.+migrateRemoveField+  :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.+     ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcRemove field diff+     , HasUField field fieldTy oldTempl+     )+  => Label field+  -> MUStore oldTempl newTempl diff touched : s+  :-> MUStore oldTempl newTempl newDiff (field ': touched) : s+migrateRemoveField label =+  attachMigrationActionName DDelAction label (Proxy @fieldTy) #+  forcedCoerce_ @_ @(UStore oldTempl) # ustoreRemoveFieldUnsafe label # forcedCoerce_++-- | Get and remove a field from old version of 'UStore'.+--+-- You probably want to use this more often than plain 'migrateRemoveField'.+migrateExtractField+  :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.+     ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcRemove field diff+     , HasUField field fieldTy oldTempl+     , RequireUntouched field (field `IsElem` touched)+     )+  => Label field+  -> MUStore oldTempl newTempl diff touched : s+  :-> fieldTy : MUStore oldTempl newTempl newDiff (field ': touched) : s+migrateExtractField label =+  attachMigrationActionName DDelAction label (Proxy @fieldTy) #+  migrateGetField label # dip (migrateRemoveField label)++-- | Remove field and write new one in place of it.+--+-- This is semantically equivalent to+-- @dip (migrateRemoveField label) >> migrateAddField label@,+-- but is cheaper.+migrateOverwriteField+  :: forall field oldTempl newTempl diff touched fieldTy oldFieldTy+            marker oldMarker newDiff newDiff0 s.+     ( '(UStoreFieldExt oldMarker oldFieldTy, newDiff0) ~ CoverDiff 'DcRemove field diff+     , '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcAdd field newDiff0+     , HasUField field fieldTy newTempl+     )+  => Label field+  -> fieldTy : MUStore oldTempl newTempl diff touched : s+  :-> MUStore oldTempl newTempl newDiff (field ': touched) : s+migrateOverwriteField label =+  attachMigrationActionName (DAddAction "overwrite") label (Proxy @fieldTy) #+  dip (forcedCoerce_ @_ @(UStore newTempl)) # ustoreSetField label # forcedCoerce_++-- | Modify field which should stay in new version of storage.+-- This does not affect remaining diff.+migrateModifyField+  :: forall field oldTempl newTempl diff touched fieldTy s.+     ( HasUField field fieldTy oldTempl+     , HasUField field fieldTy newTempl+     )+  => Label field+  -> fieldTy : MUStore oldTempl newTempl diff touched : s+  :-> MUStore oldTempl newTempl diff touched : s+migrateModifyField label =+  attachMigrationActionName (DAddAction "modify") label (Proxy @fieldTy) #+  dip (forcedCoerce_ @_ @(UStore oldTempl)) # ustoreSetField label # forcedCoerce_++-- Migrating virtual submaps (strict migration)+----------------------------------------------------------------------------++{- For now we do not support this kind of migration.++"Strict" means that we want to modify maps right here rather than signal to+do modification of each entry on first access to it (which would be simpler+in some sense).++Implementing this is slightly less trivial than migrating individial fields.+1. One needs current value of UStore picked from the contract, because it's+not possible to iterate over big_map from within a contract in the current mainnet.+Even if it was, we can't assume that iteration of the whole submap would fit+into gas limit of single transaction, thus iteration should be performed+from outside of the contract by someone who knows the current storage.++2. We need to split migration in batches smartly. Too big batches would hit+operation size limit, while small ones would cause high overhead of+contract/storage deserialization.+Will be resolved in TM-330.+-}++----------------------------------------------------------------------------+-- Blocks for batched migrations+----------------------------------------------------------------------------++-- | Define a migration atom.+--+-- It will be named automatically according to the set of actions it performs+-- (via 'DMigrationActionDesc's).+-- This may be want you want for small sequences of actions, but for complex ones+-- consider using 'muBlockNamed'.+-- Names are used in rendering migration plan.+muBlock+  :: ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])+  -> MigrationBlocks o n d1 t1 d2 t2+muBlock code =+  MigrationBlocks . one . formMigrationAtom Nothing $+    forcedCoerce_ # code # forcedCoerce_++-- | Define a migration atom with given name.+--+-- Name will be used when rendering migration plan.+muBlockNamed+  :: Text+  -> ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])+  -> MigrationBlocks o n d1 t1 d2 t2+muBlockNamed name code =+  MigrationBlocks . one . formMigrationAtom (Just name) $+    forcedCoerce_ # code # forcedCoerce_++-- | Composition of migration blocks.+(<-->)+  :: MigrationBlocks o n d1 t1 d2 t2+  -> MigrationBlocks o n d2 t2 d3 t3+  -> MigrationBlocks o n d1 t1 d3 t3+MigrationBlocks blocks1 <--> MigrationBlocks blocks2 =+  MigrationBlocks (blocks1 <> blocks2)+infixl 2 <-->++{- | This is '$' operator with priority higher than '<-->'.++It allows you writing++@+mkUStoreBatchedMigration =+  muBlock $: do+    migrateAddField ...+  <-->+  muBlock $: do+    migrateRemoveField ...+@++Alternatively, @BlockArguments@ extension can be used.+-}+($:) :: (a -> b) -> a -> b+($:) = ($)+infixr 7 $:++----------------------------------------------------------------------------+-- Common+----------------------------------------------------------------------------++-- | Get the old version of storage.+--+-- This can be applied only in the beginning of migration.+--+-- In fact this function is not very useful, all required operations should+-- be available for 'MUStore', but leaving it here just in case.+mustoreToOld+  :: RequireBeInitial touched+  => MUStore oldTemplate newTemplate remDiff touched : s+  :-> UStore oldTemplate : s+mustoreToOld = forcedCoerce_++class MigrationFinishCheckPosition a where+  -- | Put this in the end of migration script to get a human-readable message+  -- about remaining diff which yet should be covered.+  -- Use of this function in migration is fully optional.+  --+  -- This function is not part of 'mkUStoreMigration' for the sake of+  -- proper error messages ordering, during development+  -- you probably want errors in migration script to be located earlier+  -- in code than errors about not fully covered diff (if you used+  -- to fix errors in the same order in which they appear).+  migrationFinish :: a++-- | This version can be used in 'mkUStoreMigration'.+instance ( i ~ (MUStore oldTempl newTempl diff touched : s)+         , o ~ (MUStore oldTempl newTempl '[] touched : s)+         , RequireEmptyDiff diff+         ) =>+         MigrationFinishCheckPosition (i :-> o) where+  migrationFinish = forcedCoerce_++-- | This version can be used in 'mkUStoreMultiMigration' as the last migration+-- block.+instance (RequireEmptyDiff d1, t1 ~ t2) =>+         MigrationFinishCheckPosition (MigrationBlocks o n d1 t1 '[] t2) where+  migrationFinish = MigrationBlocks []
+ src/Lorentz/UStore/Migration/Diff.hs view
@@ -0,0 +1,196 @@+module Lorentz.UStore.Migration.Diff+  ( FieldInfo+  , DiffKind (..)+  , DiffItem+  , BuildDiff+  , ShowDiff+  , RequireEmptyDiff++  , LinearizeUStore+  , LinearizeUStoreF+  , AllUStoreFieldsF++  , DiffCoverage (..)+  , CoverDiff+  , CoverDiffMany+  ) where++import qualified Data.Kind as Kind+import GHC.Generics ((:*:), (:+:))+import Fcf (Eval, Exp, Pure, Fst, type (=<<), type (***))+import qualified Fcf+import Fcf.Data.List (Cons)+import Fcf.Utils (TError)+import qualified GHC.Generics as G++import Lorentz.UStore.Types+import Util.Type+import Util.TypeLits++-- Diff definition+----------------------------------------------------------------------------++-- | Information about single field of UStore.+type FieldInfo = (Symbol, Kind.Type)++-- | What should happen with a particular 'UStoreItem'.+data DiffKind = ToAdd | ToDel++-- | Single piece of a diff.+type DiffItem = (DiffKind, FieldInfo)++-- Building diff+----------------------------------------------------------------------------++-- | Get information about all fields of UStore template in a list.+--+-- In particular, this recursivelly traverses template and retrives+-- names and types of fields. Semantic wrappers like 'UStoreField'+-- and '|~>' in field types are returned as-is.+type LinearizeUStore a = GLinearizeUStore (G.Rep a)++data LinearizeUStoreF (template :: Kind.Type) :: Exp [FieldInfo]+type instance Eval (LinearizeUStoreF template) = LinearizeUStore template++-- | Get only field names of UStore template.+type family AllUStoreFieldsF (template :: Kind.Type) :: Exp [Symbol] where+  AllUStoreFieldsF template = Fcf.Map Fst =<< LinearizeUStoreF template++type family GLinearizeUStore (template :: Kind.Type -> Kind.Type)+    :: [FieldInfo] where+  GLinearizeUStore (G.D1 _ x) = GLinearizeUStore x+  GLinearizeUStore (G.C1 _ x) = GLinearizeUStore x+  GLinearizeUStore (_ :+: _) = TypeError+    ('Text "Unexpected sum type in UStore template")+  GLinearizeUStore G.V1 = TypeError+    ('Text "Unexpected void-like type in UStore template")+  GLinearizeUStore G.U1 = '[]+  GLinearizeUStore (x :*: y) = GLinearizeUStore x ++ GLinearizeUStore y++  GLinearizeUStore (G.S1 ('G.MetaSel mfield _ _ _) (G.Rec0 (k |~> v))) =+    '[ '(RequireFieldName mfield, k |~> v) ]+  GLinearizeUStore (G.S1 ('G.MetaSel mfield _ _ _) (G.Rec0 (UStoreFieldExt m v))) =+    '[ '(RequireFieldName mfield, UStoreFieldExt m v) ]+  GLinearizeUStore (G.S1 _ (G.Rec0 a)) =+    LinearizeUStore a++-- | Helper to make sure that datatype field is named and then extract this name.+type family RequireFieldName (mfield :: Maybe Symbol) :: Symbol where+  RequireFieldName ('Just field) = field+  RequireFieldName 'Nothing = TypeError ('Text "Unnamed field in UStore template")++-- | Lift a list of 'FieldInfo' to 'DiffItem's via attaching given 'DiffKind'.+type family LiftToDiff (kind :: DiffKind) (items :: [FieldInfo]) :: [DiffItem] where+  LiftToDiff _ '[] = '[]+  LiftToDiff kind (item ': items) = '(kind, item) ': LiftToDiff kind items++-- | Make up a migration diff between given old and new 'UStore' templates.+type BuildDiff oldTemplate newTemplate =+  LiftToDiff 'ToAdd (LinearizeUStore newTemplate // LinearizeUStore oldTemplate)+  +++  LiftToDiff 'ToDel (LinearizeUStore oldTemplate // LinearizeUStore newTemplate)++-- Pretty-printing diff+----------------------------------------------------------------------------++-- | Renders human-readable message describing given diff.+type ShowDiff diff =+  'Text "Migration is incomplete, remaining diff:" ':$$: ShowDiffItems diff++type family ShowDiffItems (diff :: [DiffItem]) :: ErrorMessage where+  ShowDiffItems '[d] = ShowDiffItem d+  ShowDiffItems (d : ds) = ShowDiffItem d ':$$: ShowDiffItems ds++type family ShowDiffKind (kind :: DiffKind) :: Symbol where+  ShowDiffKind 'ToAdd = "+"+  ShowDiffKind 'ToDel = "-"++type family ShowUStoreElement (ty :: Kind.Type) :: ErrorMessage where+  ShowUStoreElement (UStoreFieldExt m f) =+    ShowUStoreField m f+  ShowUStoreElement (k |~> v) =+    'Text "submap " ':<>: 'ShowType k ':<>: 'Text " -> " ':<>: 'ShowType v++type family ShowDiffItem (diff :: DiffItem) :: ErrorMessage where+  ShowDiffItem '(kind, '(field, ty)) =+    'Text (ShowDiffKind kind `AppendSymbol`+           " `" `AppendSymbol`+           field `AppendSymbol`+           "`") ':<>:+    'Text ": " ':<>: ShowUStoreElement ty++-- | Helper type family which dumps error message about remaining diff+-- if such is present.+type family RequireEmptyDiff (diff :: [DiffItem]) :: Constraint where+  RequireEmptyDiff '[] = ()+  RequireEmptyDiff diff = TypeError (ShowDiff diff)++-- Diff coverage+----------------------------------------------------------------------------++-- | Cover the respective part of diff.+-- Maybe fail if such action is not required.+--+-- This type is very similar to 'DiffKind', but we still use another type as+-- 1. Their kinds will differ - no chance to mix up anything.+-- 2. One day there might appear more complex actions.+data DiffCoverage+  = DcAdd+  | DcRemove++type family PrefixSecond (a :: k2) (r :: (k1, [k2])) :: (k1, [k2]) where+  PrefixSecond a '(t, l) = '(t, (a ': l))++-- | Apply given diff coverage, returning type of affected field and modified+-- diff.+type family CoverDiff (cover :: DiffCoverage) (field :: Symbol) (diff :: [DiffItem])+            :: (Kind.Type, [DiffItem]) where+  CoverDiff cover field diff = Eval (CoverDiffF '(cover, field) diff)++type family CoverDiffF (arg :: (DiffCoverage, Symbol)) (diff :: [DiffItem])+            :: Exp (Kind.Type, [DiffItem]) where+  CoverDiffF '( 'DcAdd, field) diff = RemoveDiffF 'ToAdd field diff+  CoverDiffF '( 'DcRemove, field) diff = RemoveDiffF 'ToDel field diff++type family RemoveDiffF (kind :: DiffKind) (field :: Symbol) (diff :: [DiffItem])+            :: Exp (Kind.Type, [DiffItem]) where+  RemoveDiffF kind field ('(kind, '(field, ty)) ': diff) = Pure '(ty, diff)+  RemoveDiffF kind field (d ': diff) = (Pure *** Cons d) =<< RemoveDiffF kind field diff+  RemoveDiffF kind field '[] =+    TError ('Text (ShowDiffKindWord kind) ':<>: 'Text " field " ':<>:+            'ShowType field ':<>: 'Text " is not required")++type family ShowDiffKindWord (kind :: DiffKind) :: Symbol where+  ShowDiffKindWord 'ToAdd = "Adding"+  ShowDiffKindWord 'ToDel = "Removing"++-- | Single piece of a coverage.+type DiffCoverageItem = (DiffCoverage, FieldInfo)++-- | Apply multiple coverage steps.+type family CoverDiffMany (diff :: [DiffItem]) (covers :: [DiffCoverageItem])+            :: [DiffItem] where+  CoverDiffMany diff '[] = diff+  CoverDiffMany diff ('(dc, '(field, ty)) ': cs) =+    CoverDiffMany (HandleCoverRes field ty (CoverDiff dc field diff)) cs++type family HandleCoverRes (field :: Symbol) (ty :: Kind.Type) (res :: (Kind.Type, [DiffItem]))+            :: [DiffItem] where+  HandleCoverRes _ ty '(ty, diff) = diff+  HandleCoverRes field tyCover '(tyDiff, _) = TypeError+    ('Text "Type mismatch when covering diff for field " ':<>: 'ShowType field+     ':$$:+     'Text "Expected type `" ':<>: 'ShowType tyDiff ':<>: 'Text "` (in requested diff)"+     ':$$:+     'Text "but covered with value of type `" ':<>: 'ShowType tyCover ':<>: 'Text "`"+    )++type family EnsureDiffHasNoRemovalF (field :: Symbol) (diff :: [DiffItem])+             :: Exp [DiffItem] where+  EnsureDiffHasNoRemovalF _ '[] = Pure '[]+  EnsureDiffHasNoRemovalF field ('( 'ToDel, '(field, _)) ': _) =+    TError ('Text "Field with name " ':<>: 'ShowType field ':<>:+            'Text " is present in old version of storage"+           )+  EnsureDiffHasNoRemovalF field (d ': diff) =+    Cons d =<< EnsureDiffHasNoRemovalF field diff
+ src/Lorentz/UStore/Types.hs view
@@ -0,0 +1,284 @@+-- | 'UStore' definition and common type-level stuff.+module Lorentz.UStore.Types+  ( -- * UStore and related type definitions+    UStore (..)+  , type (|~>)(..)+  , UStoreFieldExt (..)+  , UStoreField+  , UStoreMarkerType+  , UMarkerPlainField++    -- ** Extras+  , KnownUStoreMarker (..)+  , mkFieldMarkerUKeyL+  , mkFieldUKey+  , UStoreSubmapKey+  , UStoreSubmapKeyT++    -- ** Type-lookup-by-name+  , GetUStoreKey+  , GetUStoreValue+  , GetUStoreField+  , GetUStoreFieldMarker++    -- ** Marked fields+  , PickMarkedFields++   -- * Internals+  , ElemSignature (..)+  , GetUStore+  , MSKey+  , MSValue+  , FSValue+  , FSMarker+  ) where++import Data.Default (Default)+import Control.Lens (Wrapped)+import Data.Vinyl.Derived (Label)+import qualified Data.Kind as Kind+import Data.Type.Equality (type (==))+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError, KnownSymbol)+import Test.QuickCheck (Arbitrary)++import Lorentz.Pack+import Lorentz.Doc+import Lorentz.Polymorphic+import Michelson.Typed.T+import Michelson.Typed.Haskell.Value+import Lorentz.UStore.Common+import Lorentz.Value+import Util.Type++-- | Gathers multple fields and 'BigMap's under one object.+--+-- Type argument of this datatype stands for a "store template" -+-- a datatype with one constructor and multiple fields, each containing+-- an object of type 'UStoreField' or '|~>' and corresponding to single+-- virtual field or 'BigMap' respectively.+-- It's also possible to parameterize it with a larger type which is+-- a product of types satisfying the above property.+newtype UStore (a :: Kind.Type) = UStore+  { unUStore :: BigMap ByteString ByteString+  } deriving stock (Eq, Show, Generic)+    deriving newtype (Default, Semigroup, Monoid, IsoValue,+                      MemOpHs, GetOpHs, UpdOpHs)++instance Wrapped (UStore a)++-- | Describes one virtual big map in the storage.+newtype k |~> v = UStoreSubMap { unUStoreSubMap :: Map k v }+  deriving stock (Show, Eq)+  deriving newtype (Default, Arbitrary)++-- | Describes plain field in the storage.+newtype UStoreFieldExt (m :: UStoreMarkerType) (v :: Kind.Type) = UStoreField { unUStoreField :: v }+  deriving stock (Show, Eq)+  deriving newtype Arbitrary++-- | Just a servant type.+data UStoreMarker++-- | Specific kind used to designate markers for 'UStoreFieldExt'.+--+-- We suggest that fields may serve different purposes and so annotated with+-- special markers accordingly. See example below.+--+-- This kind is implemented like that because we want markers to differ from all+-- other types in kind; herewith 'UStoreMarkerType' is still an open kind+-- (has potentially infinite number of inhabitants).+type UStoreMarkerType = UStoreMarker -> Kind.Type++-- | Just a plain field used as data.+type UStoreField = UStoreFieldExt UMarkerPlainField+data UMarkerPlainField :: UStoreMarkerType++instance Typeable template => TypeHasDoc (UStore template) where+  typeDocName _ = "Upgradeable storage"+  typeDocMdDescription =+    "Storage with not hardcoded structure, which allows upgrading the contract \+    \in place. UStore is capable of storing simple fields and multiple submaps. \+    \For simple fields key is serialized field name. For submap element big_map \+    \key is serialized `(submapName, keyValue)`."+  typeDocMdReference tp =+    customTypeDocMdReference ("UStore", DType tp) []+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep++-- | What do we serialize when constructing big_map key for accessing+-- an UStore submap.+type UStoreSubmapKey k = (MText, k)+type UStoreSubmapKeyT k = 'TPair (ToT MText) k++-- Extra attributes of fields+----------------------------------------------------------------------------++-- | Allows to specify format of key under which fields of this type are stored.+-- Useful to avoid collisions.+class KnownUStoreMarker (marker :: UStoreMarkerType) where+  -- | By field name derive key under which field should be stored.+  mkFieldMarkerUKey :: MText -> ByteString+  default mkFieldMarkerUKey :: MText -> ByteString+  mkFieldMarkerUKey = lPackValue++  -- | Display type-level information about UStore field with given marker and+  -- field value type.+  -- Used for error messages.+  type ShowUStoreField marker v :: ErrorMessage+  type ShowUStoreField marker v = 'Text "field of type " ':<>: 'ShowType v++-- | Version of 'mkFieldMarkerUKey' which accepts label.+mkFieldMarkerUKeyL+  :: forall marker field.+     (KnownUStoreMarker marker, KnownSymbol field)+  => Label field -> ByteString+mkFieldMarkerUKeyL _ =+  mkFieldMarkerUKey @marker (fieldNameToMText @field)++-- | Shortcut for 'mkFieldMarkerUKey' which accepts not marker but store template+-- and name of entry.+mkFieldUKey+  :: forall (store :: Kind.Type) field.+     (KnownSymbol field, KnownUStoreMarker (GetUStoreFieldMarker store field))+  => Label field -> ByteString+mkFieldUKey = mkFieldMarkerUKeyL @(GetUStoreFieldMarker store field)++instance KnownUStoreMarker UMarkerPlainField where++----------------------------------------------------------------------------+-- Type-safe lookup magic+----------------------------------------------------------------------------++{- Again we use generic magic to implement methods for 'Store'+(and thus 'Store' type constructor accepts a datatype, not a type-level list).++There are two reasons for this:++1. This gives us expected balanced tree of 'Or's for free.++2. This allows us selecting a map by field name, not by+e.g. type of map value. This is subjective, but looks like a good thing+for me (@martoon). On the other hand, it prevents us from sharing the+same interface between maps and 'Store'.++-}++-- | What was found on lookup by constructor name.+--+-- This keeps either type arguments of '|~>' or 'UStoreField'.+data ElemSignature+  = MapSignature Kind.Type Kind.Type+  | FieldSignature UStoreMarkerType Kind.Type++-- Again, we will use these getters instead of binding types within+-- 'MapSignature' using type equality because getters does not produce extra+-- compile errors on "field not found" cases.+type family MSKey (ms :: ElemSignature) :: Kind.Type where+  MSKey ('MapSignature k _) = k+  MSKey ('FieldSignature _ _) =+    TypeError ('Text "Expected UStore submap, but field was referred")+type family MSValue (ms :: ElemSignature) :: Kind.Type where+  MSValue ('MapSignature _ v) = v+  MSValue ('FieldSignature _ _) =+    TypeError ('Text "Expected UStore submap, but field was referred")+type family FSValue (ms :: ElemSignature) :: Kind.Type where+  FSValue ('FieldSignature _ v) = v+  FSValue ('MapSignature _ _) =+    TypeError ('Text "Expected UStore field, but submap was referred")+type family FSMarker (ms :: ElemSignature) :: UStoreMarkerType where+  FSValue ('FieldSignature m _) = m+  FSValue ('MapSignature _ _) =+    TypeError ('Text "Expected UStore field, but submap was referred")++-- | Get map signature from the constructor with a given name.+type GetUStore name a = MERequireFound name a (GLookupStore name (G.Rep a))++type family MERequireFound+  (name :: Symbol)+  (a :: Kind.Type)+  (mlr :: Maybe ElemSignature)+    :: ElemSignature where+  MERequireFound _ _ ('Just ms) = ms+  MERequireFound name a 'Nothing = TypeError+    ('Text "Failed to find plain field or submap in store template: datatype `"+     ':<>: 'ShowType a ':<>: 'Text "` has no field " ':<>: 'ShowType name)++type family GLookupStore (name :: Symbol) (x :: Kind.Type -> Kind.Type)+              :: Maybe ElemSignature where+  GLookupStore name (G.D1 _ x) = GLookupStore name x+  GLookupStore _ (_ :+: _) =+    TypeError ('Text "Templates used in UStore should have only one constructor")+  GLookupStore _ G.V1 =+    TypeError ('Text "No constructors in UStore template")++  GLookupStore name (G.C1 _ x) = GLookupStore name x++  GLookupStore name (x :*: y) = LSMergeFound name (GLookupStore name x)+                                                  (GLookupStore name y)++  -- When we encounter a field there are three cases we are interested in:+  -- 1. This field has type '|~>'. Then we check its name and return 'Just'+  -- with all required info on match, and 'Nothing' otherwise.+  -- 2. This field has type 'UStoreField'. We act in the same way+  -- as for '|~>', attaching 'ThePlainFieldKey' as key.+  -- 3. This field type is a different one. Then we expect this field to store+  -- '|~>' or 'UStoreField' somewhere deeper and try to find it there.+  GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (k |~> v))) =+    Guard ('Just name == mFieldName) ('MapSignature k v)+  GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (UStoreFieldExt m v))) =+    Guard ('Just name == mFieldName) ('FieldSignature m v)++  GLookupStore name (G.S1 _ (G.Rec0 a)) =+    GLookupStore name (G.Rep a)++  GLookupStore _ G.U1 = 'Nothing++type family LSMergeFound (name :: Symbol)+  (f1 :: Maybe ElemSignature) (f2 :: Maybe ElemSignature)+  :: Maybe ElemSignature where+  LSMergeFound _ 'Nothing 'Nothing = 'Nothing+  LSMergeFound _ ('Just ms) 'Nothing = 'Just ms+  LSMergeFound _ 'Nothing ('Just ms) = 'Just ms+  -- It's possible that there are two constructors with the same name,+  -- because main template pattern may be a sum of smaller template+  -- patterns with same constructor names.+  LSMergeFound ctor ('Just _) ('Just _) = TypeError+    ('Text "Found more than one constructor matching " ':<>: 'ShowType ctor)+++-- | Get type of submap key.+type GetUStoreKey store name = MSKey (GetUStore name store)++-- | Get type of submap value.+type GetUStoreValue store name = MSValue (GetUStore name store)++-- | Get type of plain field.+-- This ignores marker with field type.+type GetUStoreField store name = FSValue (GetUStore name store)++-- | Get kind of field.+type GetUStoreFieldMarker store name = FSMarker (GetUStore name store)++-- One more magic+----------------------------------------------------------------------------++-- | Collect all fields with the given marker.+type PickMarkedFields marker template = GPickMarkedFields marker (G.Rep template)++type family GPickMarkedFields (marker :: UStoreMarkerType) (x :: Kind.Type -> Kind.Type)+             :: [(Symbol, Kind.Type)] where+  GPickMarkedFields m (G.D1 _ x) = GPickMarkedFields m x+  GPickMarkedFields m (G.C1 _ x) = GPickMarkedFields m x+  GPickMarkedFields m (x :*: y) = GPickMarkedFields m x ++ GPickMarkedFields m y+  GPickMarkedFields _ G.U1 = '[]++  GPickMarkedFields m (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (UStoreFieldExt m v))) =+    '[ '(fieldName, v) ]+  GPickMarkedFields _ (G.S1 _ (G.Rec0 (UStoreFieldExt _ _))) =+    '[]+  GPickMarkedFields _ (G.S1 _ (G.Rec0 (_ |~> _))) =+    '[]+  GPickMarkedFields m (G.S1 _ (G.Rec0 a)) =+    PickMarkedFields m a
+ src/Lorentz/Value.hs view
@@ -0,0 +1,247 @@+-- | Re-exports typed Value, CValue, some core types, some helpers and+-- defines aliases for constructors of typed values.+--++{-+TODO [TM-280]: Move this mess somewhere (in the last MR)++This module also introduces several types for safe work with @address@ and+@contract@ types, all available types for that are represented in the following+table:+++------------------------+------------+-------------------+----------------------++| Type                   | Type safe? | What it refers to | Michelson reflection |++========================+============+===================+======================++| Address                | No         | Whole contract    | address              |++------------------------+------------+-------------------+----------------------++| EpAddress              | No         | Entrypoint        | address              |++------------------------+------------+-------------------+----------------------++| TAddress               | Yes        | Whole contract    | address              |++------------------------+------------+-------------------+----------------------++| FutureContract         | Yes        | Entrypoint        | address              |++------------------------+------------+-------------------+----------------------++| ContractRef            | Yes        | Entrypoint        | contract             |++------------------------+------------+-------------------+----------------------+++This module also provides functions for converting between this types in Haskell+world.+In Michelson world, you can use coercions and dedicated instructions from+"Lorentz.Instr".+-}+module Lorentz.Value+  ( Value+  , IsoValue (..)+  , IsoCValue (..)+  , CValue (..)++    -- * Primitive types+  , Integer+  , Natural+  , MText+  , Bool (..)+  , ByteString+  , Address+  , EpAddress (..)+  , Mutez+  , Timestamp+  , ChainId+  , KeyHash+  , PublicKey+  , Signature+  , Set+  , Map+  , M.BigMap (..)+  , M.Operation+  , Maybe (..)+  , List+  , ContractRef (..)+  , TAddress (..)+  , FutureContract (..)++  , M.EpName+  , pattern M.DefEpName+  , EntryPointCall+  , SomeEntryPointCall++    -- * Constructors+  , toMutez+  , mt+  , timestampFromSeconds+  , timestampFromUTCTime+  , timestampQuote++    -- * Conversions+  , M.coerceContractRef+  , callingTAddress+  , callingDefTAddress+  , ToAddress (..)+  , ToTAddress (..)+  , ToContractRef (..)+  , FromContractRef (..)+  , convertContractRef++    -- * Misc+  , Default (..)+  , Label (..)+  ) where++import Data.Default (Default(..))+import Data.Type.Bool (type (&&), Not)+import Data.Kind as Kind+import Data.Vinyl.Derived (Label(..))++import Lorentz.Constraints+import Michelson.Text+import Michelson.Typed+  (ContractRef(..), EntryPointCall, IsoCValue(..), IsoValue(..), SomeEntryPointCall, Value)+import qualified Michelson.Typed as M+import Michelson.Typed.CValue (CValue(..))+import qualified Lorentz.EntryPoints.Core as Ep+import Michelson.Typed.EntryPoints (EpAddress(..))+import Tezos.Address (Address)+import Tezos.Core+  (ChainId, Mutez, Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampQuote, toMutez)+import Tezos.Crypto (KeyHash, PublicKey, Signature)+import Util.TypeLits+import Util.Type++type List = []++-- TODO (this MR): Add appropriate 'CanCastTo' instances++-- | Address which remembers the parameter type of the contract it refers to.+--+-- It differs from Michelson's @contract@ type because it cannot contain+-- entrypoint, and it always refers to entire contract parameter even if this+-- contract has explicit default entrypoint.+newtype TAddress p = TAddress { unTAddress :: Address }+  deriving stock Generic+  deriving anyclass IsoValue++-- | Turn 'TAddress' to 'ContractRef' in /Haskell/ world.+--+-- This is an analogy of @address@ to @contract@ convertion in Michelson world,+-- thus you have to supply an entrypoint (or call the default one explicitly).+callingTAddress+  :: forall cp mname.+     (NiceParameterFull cp)+  => TAddress cp+  -> Ep.EntryPointRef mname+  -> ContractRef (Ep.GetEntryPointArgCustom cp mname)+callingTAddress (TAddress addr) epRef =+  withDict (niceParameterEvi @cp) $+  case Ep.parameterEntryPointCallCustom @cp epRef of+    epc@M.EntryPointCall{} -> ContractRef addr (M.SomeEpc epc)++-- | Specification of 'callTAddress' to call the default entrypoint.+callingDefTAddress+  :: forall cp.+     (NiceParameterFull cp)+  => TAddress cp+  -> ContractRef (Ep.GetDefaultEntryPointArg cp)+callingDefTAddress taddr = callingTAddress taddr Ep.CallDefault++-- | Address associated with value of @contract arg@ type.+--+-- Places where 'ContractRef' can appear are now severely limited,+-- this type gives you type-safety of 'ContractRef' but still can be used+-- everywhere.+-- This type is not a full-featured one rather a helper; in particular, once+-- pushing it on stack, you cannot return it back to Haskell world.+--+-- Note that it refers to an entrypoint of the contract, not just the contract+-- as a whole. In this sense this type differs from 'TAddress'.+--+-- Unlike with 'ContractRef', having this type you still cannot be sure that+-- the referred contract exists and need to perform a lookup before calling it.+newtype FutureContract arg = FutureContract { unFutureContract :: ContractRef arg }++instance IsoValue (FutureContract arg) where+  type ToT (FutureContract arg) = ToT EpAddress+  toVal (FutureContract contract) = toVal $ M.contractRefToAddr contract+  fromVal = error "Fetching 'FutureContract' back from Michelson is impossible"++-- | Convert something to 'Address' in /Haskell/ world.+--+-- Use this when you want to access state of the contract and are not interested+-- in calling it.+class ToAddress a where+  toAddress :: a -> Address++instance ToAddress Address where+  toAddress = id++instance ToAddress EpAddress where+  toAddress = eaAddress++instance ToAddress (TAddress cp) where+  toAddress = unTAddress++instance ToAddress (FutureContract cp) where+  toAddress = toAddress . unFutureContract++instance ToAddress (ContractRef cp) where+  toAddress = crAddress++-- | Convert something referring to a contract (not specific entrypoint)+-- to 'TAddress' in /Haskell/ world.+class ToTAddress (cp :: Kind.Type) (a :: Kind.Type) where+  toTAddress :: a -> TAddress cp++instance ToTAddress cp Address where+  toTAddress = TAddress++instance (cp ~ cp') => ToTAddress cp (TAddress cp') where+  toTAddress = id++-- | Convert something to 'ContractRef' in /Haskell/ world.+class ToContractRef (cp :: Kind.Type) (contract :: Kind.Type) where+  toContractRef :: HasCallStack => contract -> ContractRef cp++instance (cp ~ cp') => ToContractRef cp (ContractRef cp') where+  toContractRef = id++instance (NiceParameter cp, cp ~ cp') => ToContractRef cp (FutureContract cp') where+  toContractRef = unFutureContract++instance ( FailWhen cond msg+         , cond ~+            ( Ep.CanHaveEntryPoints cp &&+              Not (Ep.ParameterEntryPointsDerivation cp == Ep.EpdNone)+            )+         , msg ~+            ( 'Text "Cannot apply `ToContractRef` to `TAddress`" ':$$:+              'Text "Consider using call(Def)TAddress first`" ':$$:+              'Text "(or if you know your parameter type is primitive," ':$$:+              'Text " make sure typechecker also knows about that)" ':$$:+              'Text "For parameter `" ':<>: 'ShowType cp ':<>: 'Text "`"+            )+         , cp ~ arg, NiceParameter arg+           -- These constraints should naturally derive from ones above,+           -- but prooving that does not worth the effort+         , NiceParameterFull cp, Ep.GetDefaultEntryPointArg cp ~ cp+         ) =>+         ToContractRef arg (TAddress cp) where+  toContractRef = callingDefTAddress++-- | Convert something from 'ContractAddr' in /Haskell/ world.+class FromContractRef (cp :: Kind.Type) (contract :: Kind.Type) where+  fromContractRef :: ContractRef cp -> contract++instance (cp ~ cp') => FromContractRef cp (ContractRef cp') where+  fromContractRef = id++instance (cp ~ cp') => FromContractRef cp (FutureContract cp') where+  fromContractRef = FutureContract . fromContractRef++instance FromContractRef cp EpAddress where+  fromContractRef = M.contractRefToAddr++instance FromContractRef cp Address where+  fromContractRef = crAddress++convertContractRef+  :: forall cp contract2 contract1.+     (ToContractRef cp contract1, FromContractRef cp contract2)+  => contract1 -> contract2+convertContractRef = fromContractRef @cp . toContractRef
+ src/Lorentz/Zip.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Stack zipping.+--+-- This module provides functions for flattening stacks into tuples.+--+-- Also here we define an instance which turns any instruction,+-- not only lambdas, into a valid value.+module Lorentz.Zip+  ( ZipInstr (..)+  , ZipInstrs+  , zippingStack+  , unzippingStack+  ) where++import Prelude hiding (drop)++import qualified Data.Kind as Kind++import Lorentz.Base+import Michelson.Typed++-- | Zipping stack into tuple and back.+class ZipInstr (s :: [Kind.Type]) where+  -- | A type which contains the whole stack zipped.+  type ZippedStack s :: Kind.Type++  -- | Fold given stack into single value.+  zipInstr :: s :-> '[ZippedStack s]++  -- | Unfold given stack from a single value.+  unzipInstr :: '[ZippedStack s] :-> s++{- Further we have to work on low level because even "Lorentz.Instr" depends+   on this module.+-}++instance ZipInstr '[] where+  type ZippedStack '[] = ()+  zipInstr = I UNIT+  unzipInstr = I DROP++instance ZipInstr '[a] where+  type ZippedStack '[a] = a+  zipInstr = I Nop+  unzipInstr = I Nop++-- | Such definition seems the only possible one we can support+-- efficiently.+instance ZipInstr ((a, b) ': s) => ZipInstr (a ': b ': s) where+  type ZippedStack (a ': b ': s) = ZippedStack ((a, b) ': s)+  zipInstr = I PAIR ## zipInstr @((a, b) ': s)+  unzipInstr = unzipInstr @((a, b) ': s) ## I (DUP `Seq` CAR `Seq` DIP CDR)++-- | Require several stacks to comply 'ZipInstr' constraint.+type ZipInstrs ss = Each '[ZipInstr] ss++-- | Flatten both ends of instruction stack.+zippingStack+  :: ZipInstrs [inp, out]+  => inp :-> out -> Lambda (ZippedStack inp) (ZippedStack out)+zippingStack code = unzipInstr ## code ## zipInstr++-- | Unflatten both ends of instruction stack.+unzippingStack+  :: ZipInstrs [inp, out]+  => Lambda (ZippedStack inp) (ZippedStack out) -> inp :-> out+unzippingStack code = zipInstr ## code ## unzipInstr++instance (ZipInstr inp, ZipInstr out) => IsoValue (inp :-> out) where+  type ToT (inp :-> out) = 'TLambda (ToT (ZippedStack inp)) (ToT (ZippedStack out))+  toVal i = VLam . unLorentzInstr $ zippingStack i+  fromVal (VLam i) = zipInstr ## LorentzInstr i ## unzipInstr
+ test/Main.hs view
@@ -0,0 +1,12 @@+module Main+  ( main+  ) where++import Test.Tasty (defaultMainWithIngredients)++import Util.Test.Ingredients (ourIngredients)++import Tree (tests)++main :: IO ()+main = tests >>= defaultMainWithIngredients ourIngredients
+ test/Test/Doc.hs view
@@ -0,0 +1,156 @@+-- | Tests on automatic documentation generation.++module Test.Doc+  ( test_General_doc_scan+  , test_Dependencies_loops+  , test_Cutting_all_except_doc+  , test_fakeCoerce+  ) where++import qualified Data.Set as Set+import Fmt (build)+import Test.HUnit (assertBool, assertFailure, (@?=))+import Test.QuickCheck (total)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.Tasty.QuickCheck (testProperty)++import Lorentz (( # ))+import qualified Lorentz as L+import Michelson.Doc+import Michelson.Typed+import Util.Named++-- General tests on contract doc scan+----------------------------------------------------------------------------++newtype MyType = MyType Integer+  deriving stock (Generic)+  deriving anyclass (IsoValue)++instance TypeHasDoc MyType where+  typeDocMdDescription = ""++data MyGroup = MyGroup Text SubDoc++instance DocItem MyGroup where+  type DocItemPosition MyGroup = 91232+  docItemSectionName = Nothing+  docItemToMarkdown lvl (MyGroup name subDoc) =+    build name <> subDocToMarkdown lvl subDoc++test_General_doc_scan :: [TestTree]+test_General_doc_scan =+  [ testCase "Type declaration is found" $+      let contract = L.doc $ DType (Proxy @MyType)+          doc = L.buildLorentzDoc contract+      in case lookupDocBlockSection @DType $ cdDefinitions doc of+            Just (toList -> ds) ->+              sort ds @?= sort [DType (Proxy @MyType), DType (Proxy @Integer)]+            Nothing ->+              assertFailure "DTypes not found"++  , testCase "Dependencies of polymorphic types are found" $+      -- There once was a bug which caused, in the following scenario,+      -- 'Integer' type to be found while 'Natural' to be not, doc items+      -- discovery thought that ":!" has already been traversed and didn't+      -- pick its dependencies the second time.+      let contract = L.doc $ L.mkDEntryPointArgSimple @("a" :! Integer, "b" :! Natural)+          doc = L.buildLorentzDoc contract+          defs = cdDefinitionsSet doc+      in do+         assertBool "'Integer' declaration is present" $+            Set.member (SomeDocDefinitionItem $ DType (Proxy @Integer)) defs+         assertBool "'Natural' declaration is present" $+            Set.member (SomeDocDefinitionItem $ DType (Proxy @Natural)) defs++  , testCase "Doc group is handled correctly" $+      let contract = L.docGroup (SomeDocItem . MyGroup "a") $+                     L.doc $ DDescription "a"+          doc = L.buildLorentzDoc contract+          contents = cdContents doc+      in case lookupDocBlockSection contents of+            Just (MyGroup "a" (SubDoc subcontents) :| []) ->+               case lookupDocBlockSection subcontents of+                 Just (DDescription "a" :| []) ->+                   pass+                 _ -> assertFailure $ "Unexpected subcontents: " <> show subcontents+            _ -> assertFailure $ "Unexpected contents: " <> show contents+  ]++-- Test on loops on dependency graph of doc items+----------------------------------------------------------------------------++-- | Type, documentation for which somehow depends on itself.+newtype MyLoopedType = MyLoopedType Integer+  deriving stock (Generic)+  deriving anyclass (IsoValue)++instance TypeHasDoc MyLoopedType where+  typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyLoopedType)]+  typeDocMdDescription = ""++newtype MyMutuallyDependentType1 = MyMutuallyDependentType1 Integer+  deriving stock (Generic)+  deriving anyclass (IsoValue)++newtype MyMutuallyDependentType2 = MyMutuallyDependentType2 Integer+  deriving stock (Generic)+  deriving anyclass (IsoValue)++instance TypeHasDoc MyMutuallyDependentType1 where+  typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyMutuallyDependentType2)]+  typeDocMdDescription = ""++instance TypeHasDoc MyMutuallyDependentType2 where+  typeDocDependencies _ = [SomeTypeWithDoc (Proxy @MyMutuallyDependentType1)]+  typeDocMdDescription = ""++test_Dependencies_loops :: [TestTree]+test_Dependencies_loops =+  [ testProperty "Type depending on itself" $+      let contract = L.doc $ DType (Proxy @MyLoopedType)+      in total . contractDocToMarkdown $ L.buildLorentzDoc contract+  , testProperty "Mutually dependent types" $+      let contract = L.doc $ DType (Proxy @MyMutuallyDependentType1)+      in total . contractDocToMarkdown $ L.buildLorentzDoc contract+  ]++-- Functions semantics+----------------------------------------------------------------------------++test_Cutting_all_except_doc :: [TestTree]+test_Cutting_all_except_doc =+  [ testCase "Cleaning simple code" $+      let contract =+            L.doc (DDescription "a") #+            L.push True #+            L.if_ (L.contractName "aaa" $ L.doc $ DDescription "b") (L.sender # L.drop)+            :: '[] L.:-> '[]+          cutContract =+            L.doc (DDescription "a") #+            L.contractName "aaa" (L.doc $ DDescription "b")+      in L.renderLorentzDoc (L.cutLorentzNonDoc contract)+         @?=+         L.renderLorentzDoc cutContract++  , testCase "DocGroup is handled correctly" $+      let contract =+            L.docGroup (SomeDocItem . MyGroup "b") $+              L.doc (DDescription "a") # L.nop+          cutContract =+            L.docGroup (SomeDocItem . MyGroup "b") $+              L.doc (DDescription "a")+      in L.renderLorentzDoc (L.cutLorentzNonDoc contract)+         @?=+         L.renderLorentzDoc cutContract+  ]++test_fakeCoerce :: [TestTree]+test_fakeCoerce =+  [ testCase "Does not truncate the following documentation" $+      let contract = L.doc (DDescription "a") :: '[] L.:-> '[]+      in L.renderLorentzDoc (L.fakeCoerce # contract)+         @?=+         L.renderLorentzDoc contract+  ]
+ test/Test/DocTest.hs view
@@ -0,0 +1,73 @@+-- | Tests on doc test framework.+module Test.DocTest+  ( test_Predicates_work+  , test_Exclusion_works+  ) where++import Test.HUnit ((@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Lorentz (( # ), (/->))+import qualified Lorentz as L+import Lorentz.EntryPoints.Doc+import Lorentz.Test.Doc+import Michelson.Doc++-- A bad contract because it uses 'caseT' instead of 'entryCase'+contract1 :: L.Contract (Either Integer Natural) Integer+contract1 = L.car # L.caseT+  ( #cLeft /->+      L.doc (DDescription "Handles left") #+      L.nop+  , #cRight /->+      L.doc (DDescription "Handles right") #+      L.int+  ) # L.nil # L.pair++contractDoc1 :: ContractDoc+contractDoc1 = L.buildLorentzDoc contract1++contract2 :: L.Contract (Either Integer Natural) Integer+contract2 = L.car # L.entryCase (Proxy @PlainEntryPointsKind)+  ( #cLeft /-> L.nop+  , #cRight /-> L.int+  ) # L.nil # L.pair++contractDoc2 :: ContractDoc+contractDoc2 = L.buildLorentzDoc contract2++test_Predicates_work :: [TestTree]+test_Predicates_work =+  [ testCase "Name at top absence is detected" $+      expectDocTestFailure testContractNameAtTop contractDoc1+  , testCase "Multiple adjacent descriptions are detected" $+      expectDocTestFailure testNoAdjacentDescriptions contractDoc1+  , testCase "Absence of parameter description is detected" $+      expectDocTestFailure testDeclaresParameter contractDoc1+  , testCase "Absence of entrypoint description is detected" $+      expectDocTestFailure testEachEntrypointIsDescribed contractDoc2+  ]++-- Normally doc test suites should not be declared with 'HasCallStack', but+-- this may potentially break 'excludeDocTests' so we try this here.+testDummyWithCallStack :: HasCallStack => DocTest+testDummyWithCallStack = mkDocTest "dummy" $ \_ -> pass++test_Exclusion_works :: [TestTree]+test_Exclusion_works =+  [ testCase "Exclusion removes only expected things" $+      [ testContractNameAtTop+      , testDocNotEmpty+      , testNoAdjacentDescriptions+      , testDummyWithCallStack+      ]+      `excludeDocTests`+      [ testDocNotEmpty+      , testDummyWithCallStack+      ]+      @?=+      [ testContractNameAtTop+      , testNoAdjacentDescriptions+      ]+  ]
+ test/Test/Lorentz/Base.hs view
@@ -0,0 +1,27 @@+-- | Tests for basic Lorentz functionality.++module Test.Lorentz.Base+  ( unit_parseLorentzValue+  ) where++import Test.HUnit (Assertion, (@?=))++import Lorentz.Base (parseLorentzValue)+import Michelson.Typed (IsoValue)++-- Sum type.+data S+  = S1 Bool+  | S2+  | S3 Integer+  deriving stock (Generic, Eq, Show)+  deriving anyclass (IsoValue)++-- Product type.+type P = (Bool, Integer, S, S)++unit_parseLorentzValue :: Assertion+unit_parseLorentzValue = do+  parseLorentzValue "Left True" @?= Right (S1 True)+  parseLorentzValue @P "Pair (Pair False 20) (Pair (Right (Left Unit)) (Right (Right 15)))" @?=+    Right (False, 20, S2, S3 15)
+ test/Test/Lorentz/Conditionals.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE NoApplicativeDo, RebindableSyntax #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}++-- | Tests (and examples) on Lorentz' @if .. then .. else ..@.+module Test.Lorentz.Conditionals+  ( test_Named+  ) where++import Michelson.Test.Dummy+import Test.HUnit ((@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Lorentz++test_Named :: [TestTree]+test_Named =+  [ testCase "Named compare works good" $+      interpretLorentzLambda dummyContractEnv myContract (5 :: Natural)+        @?= Right True+  ]+  where+    myContract = do+      toNamed #x+      push @Natural 3; toNamed #y+      if #y >=. #x+        then push False+        else push True
+ test/Test/Lorentz/DeadCode.hs view
@@ -0,0 +1,43 @@+-- | Tests checking dead code avoidance in Lorentz.++module Test.Lorentz.DeadCode+  ( test_Test+  ) where++import Control.Spoon (spoon)+import Test.HUnit (assertBool, (@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import qualified Lorentz as L+import Lorentz.Base+import Lorentz.Run+import Michelson.Typed (Instr(Seq))+import qualified Michelson.Typed as T++test_Test :: [TestTree]+test_Test =+  [ testCase "Can construct normal instructions" $+      L.push @Integer 5 # L.drop+        `compilesTo` (T.PUSH (T.toVal @Integer 5) `Seq` T.DROP)++  , testCase "Dead code is cut off" $+      (L.unit # L.failWith) # L.drop+        `compilesTo` (T.UNIT `Seq` T.FAILWITH)++  , testCase "Dead code after all failing if branches is cut off" $+      (L.push True # L.if_ L.failWith L.failWith) # L.drop+        `compilesTo` (T.PUSH (T.toVal True) `Seq` T.IF T.FAILWITH T.FAILWITH)++  , testCase "Always failing DIP body is error" $+      L.dip (L.unit # L.failWith)+        & fails+  ]+  where+    compilesTo linstr instr =+      compileLorentz @'[()] linstr @?= instr+    infixr 0 `compilesTo`++    fails instr =+      assertBool "instruction construction didn't fail" . isNothing . spoon $+      compileLorentz instr
+ test/Test/Lorentz/EntryPoints.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE DeriveAnyClass #-}++-- | Tests for Lorentz compilation which uses 'LorentzCompilationWay'.+module Test.Lorentz.EntryPoints+  ( test_FieldAnnotations+  , test_TypeAnnotations+  , test_Entrypoints_lookup+  , test_Contract_call+  , test_Self_call+  ) where++import Fcf (Eval)+import Unsafe.Coerce (unsafeCoerce)+import Data.Constraint (Dict (..))+import Test.HUnit ((@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import Test.Tasty.TypeSpec (typeTest)+import Test.TypeSpec (Is, TypeSpec(..))+import Test.Util.TypeSpec (ExactlyIs)++import Lorentz ((:!), ( # ), (/->))+import qualified Lorentz as L+import Lorentz.Constraints+import Lorentz.EntryPoints+import Lorentz.Run+import Lorentz.Test+import Lorentz.Value+import Michelson.Typed+import Michelson.Untyped (FieldAnn, TypeAnn, ann, noAnn)++----------------------------------------------------------------------------+-- Entrypoints declarations+----------------------------------------------------------------------------++data MyEntryPoints1+  = Do1 Integer+  | Do2 (Integer, Integer)+  | Do3 MyEntryPoints2+  | Do4 MyParams+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPoints1a+  = Do1a Integer+  | Do2a (Integer, Integer)+  | Do3a MyEntryPoints2+  | Do4a MyParams+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPoints2+  = Do10+  | Do11 Natural+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPoints3+  = Do12 ("tuplearg" :! ("TL" :! Integer, "TR" :!  Natural), "boolarg" :! Bool)+  | Do13 ("integerarg" :! Integer, "boolarg" :! Bool)+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPoints4+  = Do14 ("viewarg1" :! L.View ("owner" :! L.Address) Natural)+  | Do15 ()+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPoints5+  = Do16 ("maybearg" :! Maybe ("maybeinner" :! Natural))+  | Do17 ()+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPoints6+  = Do18 ("lambdaarg" :! L.Lambda Natural Natural)+  | Do19 ()+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPoints7+  = Do20 ("listarg" :! [("balance" :! Natural , "address" :! L.Address)])+  | Do21 ()+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPoints8+  = Do22 ("maparg" :! (Map Natural ("balance" :! Natural , "address" :! L.Address)))+  | Do23 ()+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPoints9+  = Do24 ("maybearg" L.:? ("maybeinner" :! Natural))+  | Do25 ()+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPoints10+  = Do26 ("bigmaparg" :! L.Lambda (BigMap Natural ("balance" :! Natural , "address" :! L.Address)) ())+  | Do27 ()+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPointsWithDef+  = Default Integer+  | NonDefault Natural+  deriving stock Generic+  deriving anyclass IsoValue++data MyParams = MyParams+  { param1 :: ()+  , param2 :: ByteString+  }+  deriving stock Generic+  deriving anyclass IsoValue++-- Normally this cannot declare entrypoints because this is not a sum type.+-- But we will declare them forcibly+data MySingleEntryPoint = Dos1 Integer+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPointsDelegated+  = Dod1+  | Dod2 MyEntryPointsSubDelegated+  deriving stock Generic+  deriving anyclass IsoValue++data MyEntryPointsSubDelegated+  = Dosd1+  | Dosd2+  deriving stock Generic+  deriving anyclass IsoValue++instance ParameterHasEntryPoints MyEntryPoints1 where+  type ParameterEntryPointsDerivation MyEntryPoints1 = EpdRecursive++instance ParameterHasEntryPoints MyEntryPoints1a where+  type ParameterEntryPointsDerivation MyEntryPoints1a = EpdPlain++instance ParameterHasEntryPoints MyEntryPoints2 where+  type ParameterEntryPointsDerivation MyEntryPoints2 = EpdPlain++instance ParameterHasEntryPoints MyEntryPoints3 where+  type ParameterEntryPointsDerivation MyEntryPoints3 = EpdPlain++instance ParameterHasEntryPoints MyEntryPoints4 where+  type ParameterEntryPointsDerivation MyEntryPoints4 = EpdPlain++instance ParameterHasEntryPoints MyEntryPoints5 where+  type ParameterEntryPointsDerivation MyEntryPoints5 = EpdPlain++instance ParameterHasEntryPoints MyEntryPoints6 where+  type ParameterEntryPointsDerivation MyEntryPoints6 = EpdPlain++instance ParameterHasEntryPoints MyEntryPoints7 where+  type ParameterEntryPointsDerivation MyEntryPoints7 = EpdPlain++instance ParameterHasEntryPoints MyEntryPoints8 where+  type ParameterEntryPointsDerivation MyEntryPoints8 = EpdPlain++instance ParameterHasEntryPoints MyEntryPoints9 where+  type ParameterEntryPointsDerivation MyEntryPoints9 = EpdPlain++instance ParameterHasEntryPoints MyEntryPoints10 where+  type ParameterEntryPointsDerivation MyEntryPoints10 = EpdPlain++instance ParameterHasEntryPoints MyEntryPointsWithDef where+  type ParameterEntryPointsDerivation MyEntryPointsWithDef = EpdPlain++instance ParameterHasEntryPoints (ShouldHaveEntryPoints MySingleEntryPoint) where+  type ParameterEntryPointsDerivation (ShouldHaveEntryPoints MySingleEntryPoint) = EpdPlain++instance ParameterHasEntryPoints MyEntryPointsDelegated where+  type ParameterEntryPointsDerivation MyEntryPointsDelegated = EpdDelegate++instance ParameterHasEntryPoints MyEntryPointsSubDelegated where+  type ParameterEntryPointsDerivation MyEntryPointsSubDelegated = EpdNone++dummyContract :: L.Contract param ()+dummyContract = L.drop L.# L.unit L.# L.nil L.# L.pair++-- | Helper datatype which contains field annotations from 'NTOr'.+data FieldAnnTree t where+  Leaf :: ForbidOr t => FieldAnnTree t+  Node :: FieldAnn -> FieldAnnTree a+       -> FieldAnn -> FieldAnnTree b+       -> FieldAnnTree ('TOr a b)++deriving stock instance Eq (FieldAnnTree t)+deriving stock instance Show (FieldAnnTree t)++data TypeAnnTree t where+  TALeaf :: TypeAnn -> TypeAnnTree t+  TANodeOption :: TypeAnn -> TypeAnnTree a -> TypeAnnTree ('TOption a)+  TANodePair :: TypeAnn -> TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TPair a b)+  TANodeOr :: TypeAnn -> TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TOr a b)+  TANodeLambda :: TypeAnn -> TypeAnnTree a -> TypeAnnTree b -> TypeAnnTree ('TLambda a b)+  TANodeList :: TypeAnn -> TypeAnnTree a -> TypeAnnTree ('TList a)+  TANodeMap :: TypeAnn -> TypeAnnTree b -> TypeAnnTree ('TMap a b)+  TANodeBigMap :: TypeAnn -> TypeAnnTree b -> TypeAnnTree ('TBigMap a b)++deriving stock instance Eq (TypeAnnTree t)+deriving stock instance Show (TypeAnnTree t)++extractTypeAnnTres :: Notes t -> TypeAnnTree t+extractTypeAnnTres = \case+  NTc ta -> TALeaf ta+  NTKey ta -> TALeaf ta+  NTUnit ta -> TALeaf ta+  NTSignature ta -> TALeaf ta+  NTOption ta n1 -> TANodeOption ta (extractTypeAnnTres n1)+  NTList ta n1 -> TANodeList ta (extractTypeAnnTres n1)+  NTSet ta _ -> TALeaf ta+  NTOperation ta -> TALeaf ta+  NTContract ta _ -> TALeaf ta+  NTPair ta _ _ n1 n2 -> TANodePair ta (extractTypeAnnTres n1) (extractTypeAnnTres n2)+  NTOr ta _ _ n1 n2 -> TANodeOr ta (extractTypeAnnTres n1) (extractTypeAnnTres n2)+  NTLambda ta n1 n2 -> TANodeLambda ta (extractTypeAnnTres n1) (extractTypeAnnTres n2)+  NTMap ta _ n1 -> TANodeMap ta (extractTypeAnnTres n1)+  NTBigMap ta _ n1 -> TANodeBigMap ta (extractTypeAnnTres n1)+  NTChainId ta -> TALeaf ta++extractFieldAnnTree :: Notes t -> FieldAnnTree t+extractFieldAnnTree = \case+  NTOr _ lann rann lnotes rnotes ->+    Node lann (extractFieldAnnTree lnotes) rann (extractFieldAnnTree rnotes)+  (_ :: Notes t) ->+    -- Here we know that type is not 'TOr',+    -- and tests don't require high-quality code+    case unsafeCoerce @(Dict ()) @(Dict (ForbidOr t)) Dict of+      Dict -> Leaf++test_FieldAnnotations :: [TestTree]+test_FieldAnnotations =+  [ testCase "Simple parameter" $+      (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints2))+      @?=+      Node+        (ann "do10") Leaf+        (ann "do11") Leaf++  , testGroup "Complex parameter"+    [ testCase "Interpreting as direct list of entrypoints" $+        (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints1a))+        @?=+        Node+          noAnn (Node (ann "do1a") Leaf (ann "do2a") Leaf)+          noAnn (Node (ann "do3a") (Node noAnn Leaf noAnn Leaf) (ann "do4a") Leaf)++    , testCase "Recursive entrypoints traversal" $+        (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints1))+        @?=+        Node+          noAnn (Node (ann "do1") Leaf (ann "do2") Leaf)+          noAnn (Node+                  noAnn (Node (ann "do10") Leaf (ann "do11") Leaf)+                  (ann "do4") Leaf+                )++    , testCase "Delegating entrypoints traversal" $+        (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPointsDelegated))+        @?=+        Node (ann "dod1") Leaf+             (ann "dod2") (Node noAnn Leaf noAnn Leaf)+    ]+  ]+  where+    paramAnnTree :: FullContract cp st -> FieldAnnTree cp+    paramAnnTree = extractFieldAnnTree . fcParamNotes++test_TypeAnnotations :: [TestTree]+test_TypeAnnotations =+  [ testCase "Named field parameter" $+      (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints3))+      @?=+      (TANodeOr noAnn+       (TANodePair noAnn (TANodePair (ann "tuplearg") (TALeaf (ann "TL")) (TALeaf (ann "TR"))) (TALeaf (ann "boolarg")))+       (TANodePair noAnn (TALeaf (ann "integerarg")) (TALeaf (ann "boolarg")))+      )+  , testCase "Named field parameter for views" $+      (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints4))+      @?=+      (TANodeOr noAnn+        (TANodePair (ann "viewarg1") (TALeaf (ann "owner")) (TALeaf noAnn)) (TALeaf noAnn))++  , testCase "Maybe field parameter" $+      (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints5))+      @?=+      (TANodeOr noAnn+        (TANodeOption (ann "maybearg") (TALeaf (ann "maybeinner"))) (TALeaf noAnn))++  , testCase "Lambda field parameter" $+      (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints6))+      @?=+      (TANodeOr noAnn+        (TANodeLambda (ann "lambdaarg") (TALeaf noAnn) (TALeaf noAnn)) (TALeaf noAnn))++  , testCase "List field parameter" $+      (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints7))+      @?=+      (TANodeOr noAnn+       (TANodeList (ann "listarg") (TANodePair noAnn (TALeaf (ann "balance")) (TALeaf (ann "address")))) (TALeaf noAnn))++  , testCase "Map field parameter" $+      (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints8))+      @?=+      (TANodeOr noAnn+       (TANodeMap (ann "maparg") (TANodePair noAnn (TALeaf (ann "balance")) (TALeaf (ann "address")))) (TALeaf noAnn))++  , testCase "Maybe field parameter 2" $+      (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints9))+      @?=+      (TANodeOr noAnn+        (TANodeOption (ann "maybearg") (TALeaf (ann "maybeinner"))) (TALeaf noAnn))++  , testCase "Big map field parameter" $+      (paramAnnTree $ compileLorentzContract (dummyContract @MyEntryPoints10))+      @?=+      (TANodeOr noAnn+        (TANodeLambda (ann "bigmaparg") (TANodeBigMap noAnn (TANodePair noAnn (TALeaf (ann "balance")) (TALeaf (ann "address")))) (TALeaf noAnn)) (TALeaf noAnn))++  , testCase "Newtype" $+      (paramAnnTree $ compileLorentzContract (dummyContract @(ShouldHaveEntryPoints MySingleEntryPoint)))+      @?=+      TALeaf noAnn++  , testGroup "Primitive type parameter"+      -- Parameters used in these test cases should not require any instances+      [ testCase "Address" $+          (paramAnnTree $ compileLorentzContract (dummyContract @Address))+          @?=+          TALeaf noAnn+      , testCase "Void" $+          (paramAnnTree $ compileLorentzContract (dummyContract @(L.Void_ Integer Natural)))+          @?=+          TANodePair noAnn (TALeaf noAnn) (TANodeLambda noAnn (TALeaf noAnn) (TALeaf noAnn))+      ]+  ]+  where+    paramAnnTree :: FullContract cp st -> TypeAnnTree cp+    paramAnnTree = extractTypeAnnTres . fcParamNotes++----------------------------------------------------------------------------+-- @contract@ instruction+----------------------------------------------------------------------------++test_Entrypoints_lookup :: [TestTree]+test_Entrypoints_lookup =+  [ testGroup "Flat parameter type"+    [ typeTest "Default entrypoint arg" $ Valid @+        (GetDefaultEntryPointArg MyEntryPoints1a `Is` MyEntryPoints1a)+    , typeTest "Can get entrypoint on surface" $ Valid @+        (GetEntryPointArg MyEntryPoints1a "Do1a" `Is` Integer)+    , typeTest "Cannot get entrypoint in deep" $ Valid @+        (Eval (LookupParameterEntryPoint MyEntryPoints1a "Do11")+           `ExactlyIs` 'Nothing+        )+    ]+  , testGroup "Nested parameter type"+    [ typeTest "Default entrypoint arg" $ Valid @+        (GetDefaultEntryPointArg MyEntryPoints1 `Is` MyEntryPoints1)+    , typeTest "Can get entrypoint on surface" $ Valid @+        (GetEntryPointArg MyEntryPoints1 "Do1" `Is` Integer)+    , typeTest "Can get entrypoint in deep" $ Valid @+        (GetEntryPointArg MyEntryPoints1 "Do11" `Is` Natural)+    , typeTest "Can get entrypoint without arg" $ Valid @+        (GetEntryPointArg MyEntryPoints1 "Do10" `Is` ())+    ]+  , testGroup "Parameter type with default entrypoint"+    [ typeTest "Default entrypoint arg" $ Valid @+        (GetDefaultEntryPointArg MyEntryPointsWithDef `Is` Integer)+    , typeTest "Can get non-default entrypoint" $ Valid @+        (GetEntryPointArg MyEntryPointsWithDef "NonDefault" `Is` Natural)+    ]+  , testGroup "Delegation"+    [ typeTest "Calling immediate entrypoint works" $ Valid @+        (GetEntryPointArg MyEntryPointsDelegated "Dod1" `Is` ())+    ]+  ]++-- | A contract which accepts 'Address' as parameter and calls specific+-- entrypoint of another contract.+callerContract+  :: forall cp mname arg.+     ( arg ~ GetEntryPointArgCustom cp mname+     , NiceConstant arg, NiceParameter arg, NiceParameterFull cp+     )+  => EntryPointRef mname+  -> arg+  -> L.Contract (TAddress cp) ()+callerContract epRef arg =+  L.car # L.contractCalling @cp epRef #+  L.assertSome [mt|Contract lookup failed|] #+  L.push (toMutez 1) # L.push arg # L.transferTokens #+  L.dip (L.unit # L.nil) # L.cons # L.pair++test_Contract_call :: [TestTree]+test_Contract_call =+  [ testCase "Calling entrypoint" $+      integrationalTestExpectation $ do+        let myCallerContract = callerContract (Call @"Do11") 5+        let myTargetContract = L.car # L.caseT @MyEntryPoints2+              ( #cDo10 /-> L.push 0+              , #cDo11 /-> L.nop+              ) # L.nil # L.pair++        caller <- lOriginate myCallerContract "Caller" () (toMutez 10)+        target <- lOriginateEmpty myTargetContract "Call target"+        lCallDef caller target+        validate . Right $+          lExpectStorageConst target (5 :: Natural)++  , testCase "Calling default entrypoint" $+      integrationalTestExpectation $ do+        let myCallerContract = callerContract CallDefault 3+        let myTargetContract = L.car # L.caseT @MyEntryPointsWithDef+              ( #cDefault /-> L.nop+              , #cNonDefault /-> L.neg+              ) # L.nil # L.pair++        caller <- lOriginate myCallerContract "Caller" () (toMutez 10)+        target <- lOriginateEmpty myTargetContract "Call target"+        lCallDef caller target+        validate . Right $+          lExpectStorageConst target (3 :: Natural)+  ]++test_Self_call :: [TestTree]+test_Self_call =+  [ testCase "Calling entrypoint" $+      integrationalTestExpectation $ do+        let myContract = L.car # L.caseT @MyEntryPoints2+              ( #cDo10 /->+                  L.selfCalling @MyEntryPoints2 (Call @"Do11") #+                  L.push (toMutez 1) # L.push 5 # L.transferTokens #+                  L.dip (L.push @Integer 1 # L.nil) # L.cons # L.pair+              , #cDo11 /-> L.push @Integer 10 # L.add # L.nil # L.pair+              )++        contractRef <- lOriginate myContract "Contract" 0 (toMutez 10)+        lCallDef contractRef Do10+        validate . Right $+          lExpectStorageConst contractRef (15 :: Natural)+  ]
+ test/Test/Lorentz/Errors.hs view
@@ -0,0 +1,140 @@+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Lorentz.Errors+  ( unit_Errors+  , unit_gatherErrorTags+  , unit_Numeric_simple+  , unit_Numeric_append+  , unit_errorFromValNumeric+  ) where++import qualified Data.Bimap as Bimap+import qualified Data.HashSet as HS+import Test.HUnit (Assertion, (@?=))++import Lorentz as L+import Lorentz.Test.Integrational+import Michelson.Text (mt)++{- Checking that errors of old format still can be used fine -}++data ErrorOfOldFormat+  = ErrorCase1+  | ErrorCase2 Integer+  deriving stock Generic++deriveCustomError ''ErrorOfOldFormat++_canFailUsing :: s :-> s'+_canFailUsing = failUsing ErrorCase1++_canFailUsingArg :: Integer : s :-> s'+_canFailUsingArg = failUsingArg @ErrorOfOldFormat #cErrorCase2++-- Needed to make this module compile+unit_Errors :: IO ()+unit_Errors = pass++----------------------------------------------------------------------------+-- Numeric representation+----------------------------------------------------------------------------++unit_gatherErrorTags :: Assertion+unit_gatherErrorTags = sampleGatheredTags @?= HS.fromList [str1, str2]++unit_Numeric_simple :: Assertion+unit_Numeric_simple =+  useNumericErrors sample @?=+  (sampleNumericErrors (0, 1), Bimap.fromList [(0, str1), (1, str2)])++unit_Numeric_append :: Assertion+unit_Numeric_append =+  applyErrorTagMap newMap sample @?=+  sampleNumericErrors (5, 4)+  where+    existingMap :: ErrorTagMap+    existingMap = Bimap.fromList [(4, str2)]++    newMap = existingMap `addNewErrorTags` sampleGatheredTags++type instance ErrorArg "aa" = Bool+instance CustomErrorHasDoc "aa" where+  customErrClass = ErrClassActionException+  customErrDocMdCause = "patak"++sample :: '[ MText] :-> '[ MText]+sample =+  pushTrue #+  -- FailWithString+  if_+    (push str1 # failWith)+    pushTrue #+  -- Non-typical fail+  if_+    (push str1 # push str1 # pair # pair # failWith)+    pushTrue #+  -- FailWithStackValue+  if_+    (push str1 # pair # failWith)+    (pushTrue) #+  -- FailWithStackValue via 'failCustom'+  if_+    (pushTrue # failCustom #aa)+    (none @()) #+  -- Deeper FailWithString+  ifNone+    (unit # pushTrue # if_ (push str2 # failWith) nop)+    nop #+  -- FailWithConstantPair+  push (str2, ()) # failWith++-- Arguments are numeric codes for 'str1' and 'str2'.+sampleNumericErrors :: (Natural, Natural) -> '[ MText] :-> '[ MText]+sampleNumericErrors (code1, code2) =+  pushTrue #+  if_+    (push code1 # failWith)+    pushTrue #++  if_+    (push str1 # push str1 # pair # pair # failWith)+    pushTrue #++  if_+    (push code1 # pair # failWith)+    pushTrue #++  -- Here we lose doc item and rely on the fact that instructions are+  -- compared by transpiling them to Michelson.+  if_+    (pushTrue # push code1 # pair # failWith)+    (none @()) #++  ifNone+    (unit # pushTrue # if_ (push code2 # failWith) nop)+    nop #++  push (code2, ()) # failWith++sampleGatheredTags :: HashSet MText+sampleGatheredTags = gatherErrorTags sample++pushTrue :: forall s. s :-> Bool ': s+pushTrue = push True++str1, str2 :: MText+str1 = [mt|Aa|]+str2 = [mt|Qq|]++unit_errorFromValNumeric :: Assertion+unit_errorFromValNumeric = integrationalTestExpectation $ do+  let+    (voidSample', errorTagMap) = useNumericErrors voidSample+  ref <- lOriginate voidSample' "voidSample" () minBound+  lCall ref (mkVoid True)+  validate . Left $+    lExpectErrorNumeric errorTagMap (== VoidResult False)++voidSample :: Contract (Void_ Bool Bool) ()+voidSample = car # void_ L.not
+ test/Test/Lorentz/Extensible.hs view
@@ -0,0 +1,71 @@+module Test.Lorentz.Extensible+  ( test_Extensible+  ) where++import Data.Vinyl.Core (Rec(..))+import Test.HUnit ((@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Lorentz (toVal)+import Lorentz.Base+import Lorentz.Extensible+import Lorentz.Run+import Michelson.Interpret.Pack+import Michelson.Test.Dummy++data SumType+  = Ctor0 Natural+  | Ctor1+  | Ctor2 (Integer, Integer)+  deriving stock (Generic, Eq, Show)++values :: [SumType]+values =+  [ Ctor0 42+  , Ctor1+  , Ctor2 (-100, 500)+  ]++test_Extensible :: [TestTree]+test_Extensible =+  [ testCase "toExtVal conversion" $ do+      fmap toExtVal values @?=+        [ Extensible (0, packValue' $ toVal @Natural 42)+        , Extensible (1, packValue' $ toVal ())+        , Extensible (2, packValue' $ toVal ints)+        ]+  , testCase "fromExtVal conversion" $ do+      let extValues = [ Extensible (0, packValue' $ toVal @Natural 42)+                      , Extensible (1, packValue' $ toVal ())+                      , Extensible (2, packValue' $ toVal ints)+                      ]+      fmap fromExtVal extValues @?= fmap Right values+  , testCase "fromExtVal failure" $ do+      let invalidCtor = Extensible (3, packValue' $ toVal ())+      let invalidArg = Extensible (2, packValue' $ toVal ())+      fromExtVal @SumType invalidCtor+        @?= Left (ConstructorIndexNotFound 3)+      fromExtVal @SumType invalidArg+        @?= Left ArgumentUnpackFailed+  , testCase "wrapExt" $ do+      wrapIntoCtor2 ints @?= (Right $ Extensible (2, packValue' $ toVal ints))+  , testCase "Roundtrip" $ do+      fmap roundtrip values @?= fmap Right values+  ]+  where+    wrapIntoCtor2 initVal = do+      let initStack = (Identity initVal :& RNil)+      resStack <- interpretLorentzInstr dummyContractEnv wrapCode initStack+      let Identity res :& RNil = resStack+      return res++ints :: (Integer, Integer)+ints = (-100, 500)++wrapCode :: '[(Integer, Integer)] :-> '[Extensible SumType]+wrapCode = wrapExt #cCtor2++roundtrip :: (ExtVal value) => value -> Either ExtConversionError value+roundtrip value =+  fromExtVal $ toExtVal value
+ test/Test/Lorentz/Macro.hs view
@@ -0,0 +1,45 @@+-- | Tests for Lorentz macros.+--+-- They test logic of macros and type-level logic.  Also they serve as+-- examples of using complex macros (e. g. parameterized with+-- type-level numbers)++module Test.Lorentz.Macro+  ( unit_duupX+  , test_execute+  ) where++import Prelude hiding (drop, swap)+import Test.HUnit (Assertion, (@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Lorentz++import Michelson.Test.Dummy++unit_duupX :: Assertion+unit_duupX = do+  duupX @1 @?= dup+  duupX @2 @?= (dip dup # swap)+  duupX @3 @?= duupX3+  where+    duupX3 :: [Bool, Integer, (), Bool] :-> [(), Bool, Integer, (), Bool]+    duupX3 = dipN @2 dup # dig @2++test_execute :: [TestTree]+test_execute =+  [ testCase "Two arguments lambda" $+      let lam :: [Integer, Integer] :-> [(), Integer]+          lam = add # unit+          code = push 3 # push lam # execute # drop @()+      in interpretLorentzLambda dummyContractEnv code 5+          @?= Right 8++  , testCase "Zero arguments lambda" $+      let lam :: '[] :-> '[Integer]+          lam = push 5+          code = drop # push lam # execute+      in interpretLorentzLambda dummyContractEnv code (0 :: Integer)+          @?= Right 5+  ]
+ test/Test/Lorentz/Pack.hs view
@@ -0,0 +1,43 @@+-- | Tests for Lorentz packing/unpacking++module Test.Lorentz.Pack+  ( test_lambda_roundtrip+  ) where++import Prelude hiding (drop, swap)+import Test.HUnit (Assertion, (@?=), assertFailure)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Lorentz+import Michelson.Typed.Instr (Instr (..))+import Michelson.Typed.Util (DfsSettings (..), dfsFoldInstr)++test_lambda_roundtrip :: [TestTree]+test_lambda_roundtrip =+  [ testCase "Packing and then unpacking a Lambda does not add empty annotations" $+      lambdaRoundtripWithoutNotes lam+  ]+  where+    lam :: Lambda () ()+    lam = push @Natural 5 # drop++-- | Checks that packing and unpacking a lambda made of instructions without+-- Annotations will produce the same lambda, still without annotations.+lambdaRoundtripWithoutNotes+  :: forall i o. NiceUnpackedValue (Lambda i o)+  => Lambda i o+  -> Assertion+lambdaRoundtripWithoutNotes l = case lUnpackValue @(Lambda i o) $ lPackValue l of+  Left err -> assertFailure $ "Unpacking error: " <> show err+  Right ul -> case dfsFoldInstr dfsSettings instrNotes $ iAnyCode ul of+    [] -> ul @?= l+    notes -> assertFailure $ "Lambda has annotations: " <> show notes+  where+    dfsSettings :: DfsSettings [Text]+    dfsSettings = def { dsGoToValues = True}++    instrNotes :: Instr inp out -> [Text]+    instrNotes = \case+      InstrWithNotes n _ -> [show n]+      _ -> []
+ test/Test/Lorentz/Print.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveAnyClass #-}++-- | Tests on Lorentz contracts pretty-printing.+module Test.Lorentz.Print+  ( test_Print_parameter_annotations+  , test_Print_lambda+  , unit_Erase_annotations+  ) where++import Prelude hiding (drop, swap)+import Test.HUnit (Assertion, assertEqual, (@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Lorentz hiding (contract, unpack)+import qualified Lorentz as L+import Michelson.Printer.Util (buildRenderDoc)+import Michelson.Typed hiding (Contract)+import Michelson.Untyped (para)++data MyEntryPoints1+  = Do1 Integer+  | Do2 (Integer, Integer)+  | Do3+  deriving stock Generic+  deriving anyclass IsoValue++instance ParameterHasEntryPoints MyEntryPoints1 where+  type ParameterEntryPointsDerivation MyEntryPoints1 = EpdPlain++contract :: Contract MyEntryPoints1 ()+contract = drop # unit # nil # pair++test_Print_parameter_annotations :: [TestTree]+test_Print_parameter_annotations =+  [ testCase "Simple parameter" $+      let typedContract = compileLorentzContract contract+          untypedContract = convertFullContract typedContract+      in buildRenderDoc (para untypedContract)+         @?=+         "or (int %do1) (or (pair %do2 int int) (unit %do3))"+  ]++test_Print_lambda :: [TestTree]+test_Print_lambda =+  [ testCase "Prints correct lambda instruction" $+      let+        code :: '[Integer] :-> '[('[Integer] :-> '[()])]+        code = drop # lambda (drop # unit)+     in printLorentzValue True code+        @?=+        "{ DROP; LAMBDA int unit       { DROP;UNIT } }"+  ]++data TestParam+  = TestCon1 ("a" :! Natural, "b" :! Bool)+  | TestCon2 ()+  deriving stock Generic+  deriving anyclass IsoValue++instance ParameterHasEntryPoints TestParam where+  type ParameterEntryPointsDerivation TestParam = EpdRecursive++unit_Erase_annotations :: Assertion+unit_Erase_annotations =+  let+    myContract :: Contract TestParam ()+    myContract = cdr # nil # L.pair+    expected = "parameter (or (pair %testCon1 (nat :a) (bool :b)) (unit %testCon2));storage unit;code { CAST (pair (or (pair nat bool) unit) unit);CDR;NIL operation;PAIR };"+  in assertEqual+      "Printed Lorentz contract is supposed to have an instruction which erases\+      \all parameter annotations, but it does not match the expected output"+      expected (L.printLorentzContract True myContract)
+ test/Test/Lorentz/UParam.hs view
@@ -0,0 +1,96 @@+-- | Tests for Lorentz 'UParam'.+module Test.Lorentz.UParam+  ( test_Simple_contract+  , test_ADT_conversion+  , unit_unpackUParam+  ) where++import Data.Vinyl.Core (Rec(..))+import Data.Constraint (Dict (..))+import Test.HUnit ((@?=), assertBool, Assertion)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Michelson.Text+import Michelson.Interpret.Pack+import Lorentz ((/->))+import qualified Lorentz as L+import Lorentz.Base+import Lorentz.UParam+import Lorentz.Run+import Michelson.Test.Dummy++-- Test on simple contract+----------------------------------------------------------------------------++type Entries = ["add" ?: Natural, "id" ?: ()]++simpleCode :: '[UParam Entries, Integer] :-> '[Integer]+simpleCode = caseUParamT+  ( #add /-> L.add+  , #id /-> L.drop @()+  ) uparamFallbackFail++test_Simple_contract :: [TestTree]+test_Simple_contract =+  [ testCase "Passing parameter 1" $+      runSimpleCode 5 (mkUParam #add 3) @?= Right 8+  , testCase "Passing parameter 2" $+      runSimpleCode 5 (mkUParam #id ()) @?= Right 5+  , testCase "Passing illegal parameter" $+      assertBool "Expected failure" $+      isLeft $+      runSimpleCode 5 (UParamUnsafe ([mt|Nyan|], ""))+  ]+  where+    runSimpleCode initVal uparam = do+      let initStack = (Identity uparam :& initVal :& RNil)+      resStack <- interpretLorentzInstr dummyContractEnv simpleCode initStack+      let Identity res :& RNil = resStack+      return res++-- Test deconstruction+----------------------------------------------------------------------------++unit_unpackUParam :: Assertion+unit_unpackUParam = do+  unpk (mkUParam #add 3) @?=+    Right ([mt|add|], "3")+  unpk (mkUParam #id ()) @?=+    Right ([mt|id|], "()")+  unpk (UParamUnsafe ([mt|gy|], mempty)) @?=+    Left (NoSuchEntryPoint [mt|gy|])+  unpk (UParamUnsafe ([mt|add|], mempty)) @?=+    Left ArgumentUnpackFailed+  where+    unpk ::+      UParam Entries ->+      Either EntryPointLookupError (MText, String)+    unpk = fmap (second show) . unpackUParam @Show++-- Test ADT conversion+----------------------------------------------------------------------------++data Parameter1+  = MyEntryPoint1 Integer+  | MyEntryPoint2 ()+  deriving stock (Generic)++type ExpectedLinearization1 =+  [ "MyEntryPoint1" ?: Integer+  , "MyEntryPoint2" ?: ()+  ]++_checkLinearizedType+  :: Dict (UParamLinearized Parameter1 ~ ExpectedLinearization1)+_checkLinearizedType = Dict++test_ADT_conversion :: [TestTree]+test_ADT_conversion =+  [ testCase "Linearization 1.1" $+      uparamFromAdt (MyEntryPoint1 5)+        @?= UParamUnsafe ([mt|MyEntryPoint1|], packValue' (L.toVal @Integer 5))+  , testCase "Linearization 1.2" $+      uparamFromAdt (MyEntryPoint2 ())+        @?= UParamUnsafe ([mt|MyEntryPoint2|], packValue' (L.toVal ()))+  ]
+ test/Test/Lorentz/UStore/Behaviour.hs view
@@ -0,0 +1,172 @@+-- | Tests for Lorentz 'UStore'.+module Test.Lorentz.UStore.Behaviour+  ( test_Roundtrip+  , test_Conversions+  , test_Script+  ) where++import Data.Default (def)+import qualified Data.Map as M+import Test.HUnit (Assertion, assertFailure, (@?=))+import Test.QuickCheck (Arbitrary(..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import Lorentz.Base+import Lorentz.Instr as L+import Lorentz.Run+import Lorentz.UStore+import Michelson.Test.Dummy+import Michelson.Test.Util+import Util.Test.Arbitrary ()++data MyTemplate = MyTemplate+  { ints :: Integer |~> ()+  , bool :: UStoreField Bool+  } deriving stock (Eq, Show, Generic)++instance Arbitrary MyTemplate where+  arbitrary = MyTemplate <$> arbitrary <*> arbitrary++data MyTemplateBig = MyTemplateBig+  { small :: MyTemplate+  , bytes :: ByteString |~> Natural+  , total :: UStoreField Integer+  } deriving stock (Eq, Show, Generic)++instance Arbitrary MyTemplateBig where+  arbitrary = MyTemplateBig <$> arbitrary <*> arbitrary <*> arbitrary++test_Roundtrip :: [TestTree]+test_Roundtrip =+  [ roundtripTest (mkUStore @MyTemplate) ustoreDecomposeFull+  , roundtripTest (mkUStore @MyTemplateBig) ustoreDecomposeFull+  ]++test_Conversions :: [TestTree]+test_Conversions =+  [ testGroup "Simple store template"+    [ testCase "No action" $+        ustoreChangeTest+          ( nop+          , MyTemplate (UStoreSubMap def) (UStoreField False)+          , MyTemplate (UStoreSubMap def) (UStoreField False)+          )+    , testCase "Insert into submap" $+        ustoreChangeTest+          ( unit # push 5 # ustoreInsert #ints+          , MyTemplate (UStoreSubMap def) (UStoreField False)+          , MyTemplate (UStoreSubMap $ one (5, ())) (UStoreField False)+          )+    , testCase "Delete from submap" $+        ustoreChangeTest+          ( push 3 # ustoreDelete #ints+          , MyTemplate (UStoreSubMap $ one (3, ())) (UStoreField False)+          , MyTemplate (UStoreSubMap mempty) (UStoreField False)+          )+    , testCase "Get from submap" $+        ustoreChangeTest+          ( dup # push 0 # ustoreGet #ints #+            ifNone (push 10) (L.drop # push 11) # dip unit # ustoreInsert #ints+          , MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField False)+          , MyTemplate (UStoreSubMap $ M.fromList [(0, ()), (11, ())]) (UStoreField False)+          )+    , testCase "Set field" $+        ustoreChangeTest+          ( push True # ustoreSetField #bool+          , MyTemplate (UStoreSubMap mempty) (UStoreField False)+          , MyTemplate (UStoreSubMap mempty) (UStoreField True)+          )+    , testCase "Get field" $+        ustoreChangeTest+          ( ustoreGetField #bool #+            if_ (push 5) (push 0) # dip unit # ustoreInsert #ints+          , MyTemplate (UStoreSubMap mempty) (UStoreField False)+          , MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField False)+          )+    , testCase "Leave some entries untouched" $+        ustoreChangeTest+          ( push 0 # ustoreDelete #ints #+            unit # push 2 # ustoreInsert #ints+          , MyTemplate (UStoreSubMap $ M.fromList [(0, ()), (1, ())]) (UStoreField False)+          , MyTemplate (UStoreSubMap $ M.fromList [(1, ()), (2, ())]) (UStoreField False)+          )+    ]++  , testGroup "Non-flat store template"+    [ testCase "Custom scenario 1" $+        ustoreChangeTest+          ( push "a" # ustoreDelete #bytes #+            push 2 # push "b" # ustoreInsert #bytes #+            ustoreGetField #total # push @Integer 1 # add # ustoreSetField #total #+            unliftUStore #small #+            unit # push 0 # ustoreInsert #ints #+            push True # ustoreSetField #bool #+            liftUStore #small+          , MyTemplateBig+            { small = MyTemplate (UStoreSubMap def) (UStoreField False)+            , bytes = UStoreSubMap $ one ("a", 1)+            , total = UStoreField 10+            }+          , MyTemplateBig+            { small = MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField True)+            , bytes = UStoreSubMap $ one ("b", 2)+            , total = UStoreField 11+            }+          )+    ]+  ]+  where+    -- We accept a tuple as argument to avoid many parentheses+    ustoreChangeTest+      :: (Each [Eq, Show, Generic, UStoreConversible] '[template], HasCallStack)+      => ( '[UStore template] :-> '[UStore template]+         , template+         , template+         )+      -> Assertion+    ustoreChangeTest (instr, initStoreHs, expectedNewStore) =+      let+        initStore = mkUStore initStoreHs+        ustore =+          leftToPrettyPanic $+          interpretLorentzLambda dummyContractEnv instr initStore+      in case ustoreDecomposeFull ustore of+          Left err -> assertFailure (toString err)+          Right ustoreHs -> ustoreHs @?= expectedNewStore++test_Script :: [TestTree]+test_Script =+  [ testCase "Only fields" $+      ustoreScriptTest MyTemplate+        { ints = UStoreSubMap mempty+        , bool = UStoreField True+        }++  , testCase "Fields and submaps" $+      ustoreScriptTest MyTemplate+        { ints = UStoreSubMap $ one (5, ())+        , bool = UStoreField True+        }++  , testCase "Complex" $+      ustoreScriptTest MyTemplateBig+        { small = MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField True)+        , bytes = UStoreSubMap $ one ("b", 2)+        , total = UStoreField 11+        }+  ]+  where+    ustoreScriptTest+      :: (Each [Eq, Show, Generic, UStoreConversible] '[template], HasCallStack)+      => template+      -> Assertion+    ustoreScriptTest store =+      let+        filling = migrationToLambda (fillUStore store)+        ustoreFilled =+          leftToPrettyPanic $+          interpretLorentzLambda dummyContractEnv filling (mkUStore ())+      in case ustoreDecomposeFull ustoreFilled of+          Left err -> assertFailure (toString err)+          Right ustoreHs -> ustoreHs @?= store
+ test/Test/Lorentz/UStore/Migration/Batched.hs view
@@ -0,0 +1,76 @@+module Test.Lorentz.UStore.Migration.Batched+  ( test_Separated_lambdas+  ) where++import qualified Data.Map as M+import Test.HUnit ((@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import qualified Lorentz as L+import Lorentz.UStore+import Lorentz.UStore.Migration++import qualified Test.Lorentz.UStore.Migration.Batched.V1 as V1+import qualified Test.Lorentz.UStore.Migration.Batched.V2 as V2++initMigration :: UStoreMigration () V1.MyTemplate+initMigration = fillUStore V1.MyTemplate+  { bytes = UStoreSubMap $ M.fromList [(1, "a"), (2, "b")]+  , int1 = UStoreField 1+  , int2 = UStoreField 2+  , code1 = UStoreField L.nop+  , code2 = UStoreField L.int+  , code3 = UStoreField L.nop+  }++v2migration :: UStoreMigration V1.MyTemplate V2.MyTemplate+v2migration = mkUStoreBatchedMigration $+  muBlock $:+    L.push @Natural 1 L.#+    migrateOverwriteField #int1+  <-->+  muBlock $:+    migrateRemoveField #int2+  <-->+  muBlock $:+    -- Normally such joined blocks should not be present, but we+    -- want to test different scenarios+    L.push L.nop L.#+    migrateModifyField #code1 L.#++    migrateRemoveField #code2+  <-->+  muBlock $:+    migrateRemoveField #code3+  <-->+  migrationFinish++test_Separated_lambdas :: [TestTree]+test_Separated_lambdas =+  [ testGroup "V0 -> V1" $+      let cmigration = compileMigration mbSeparateLambdas initMigration+      in+    [ testCase "Split is correct" $+        (slbiType <$> migrationToInfo cmigration)+        @?=+        [ SlbtData+        , SlbtLambda+        , SlbtLambda+        , SlbtLambda+        ]+    ]++  , testGroup "V1 -> V2" $+      let cmigration = compileMigration mbSeparateLambdas v2migration+      in+    [ testCase "Split is correct" $+        (slbiType <$> migrationToInfo cmigration)+        @?=+        [ SlbtData+        , SlbtLambda+        , SlbtLambda+          -- Lambda removals should not be put separatelly, so one lambda is gone+        ]+    ]+  ]
+ test/Test/Lorentz/UStore/Migration/Batched/V1.hs view
@@ -0,0 +1,15 @@+module Test.Lorentz.UStore.Migration.Batched.V1+  ( MyTemplate (..)+  ) where++import Lorentz.Base+import Lorentz.UStore++data MyTemplate = MyTemplate+  { bytes :: Integer |~> ByteString+  , int1 :: UStoreField Integer+  , int2 :: UStoreField Integer+  , code1 :: UStoreField $ Lambda () ()+  , code2 :: UStoreField $ Lambda Natural Integer+  , code3 :: UStoreField $ Lambda () ()+  } deriving stock Generic
+ test/Test/Lorentz/UStore/Migration/Batched/V2.hs view
@@ -0,0 +1,12 @@+module Test.Lorentz.UStore.Migration.Batched.V2+  ( MyTemplate (..)+  ) where++import Lorentz.Base+import Lorentz.UStore++data MyTemplate = MyTemplate+  { bytes :: Integer |~> ByteString+  , int1 :: UStoreField Natural+  , code1 :: UStoreField $ Lambda () ()+  } deriving stock Generic
+ test/Test/Lorentz/UStore/Migration/FillInParts.hs view
@@ -0,0 +1,84 @@+module Test.Lorentz.UStore.Migration.FillInParts+  ( test_Migration_works+  ) where++import Fmt (pretty)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.HUnit ((@?=), assertFailure)++import qualified Lorentz as L+import Lorentz.UStore+import Lorentz.UStore.Migration+import Lorentz.UStore.Haskell+import Michelson.Text+import Michelson.Test.Dummy+import Lorentz.Run++data MyTemplateWrapper substore = MyTemplateWrapper+  { commonField :: UStoreField MText+  , custom :: substore+  } deriving stock (Eq, Show, Generic)++data MySubTemplatePart1 = MySubTemplatePart1+  { int :: UStoreField Integer+  , nat :: UStoreField Natural+  } deriving stock (Eq, Show, Generic)++part1Val :: MySubTemplatePart1+part1Val = MySubTemplatePart1{ int = UStoreField -1, nat = UStoreField 1 }++data MySubTemplatePart2 = MySubTemplatePart2+  { string :: UStoreField MText+  } deriving stock (Eq, Show, Generic)++part2Val :: MySubTemplatePart2+part2Val = MySubTemplatePart2{ string = UStoreField [mt|bb|] }++type MyTemplateV0 = MyTemplateWrapper ()++type MyTemplateV1 = MyTemplateWrapper (MySubTemplatePart1, MySubTemplatePart2)++migrationBatched :: UStoreMigration MyTemplateV0 MyTemplateV1+migrationBatched = mkUStoreBatchedMigration $+  muBlock $:+    L.push [mt|bb|] L.#+    migrateModifyField #commonField+  <-->+  fillUStoreMigrationBlock part1Val+  <-->+  fillUStoreMigrationBlock part2Val+  <-->+  migrationFinish++migrationSimple :: UStoreMigration MyTemplateV0 MyTemplateV1+migrationSimple = mkUStoreMigration $+  L.push [mt|bb|] L.# migrateModifyField #commonField L.#+  migrateFillUStore part1Val L.#+  migrateFillUStore part2Val L.#+  migrationFinish++test_Migration_works :: [TestTree]+test_Migration_works =+  [ ("simple migration", migrationSimple)+  , ("batched migration", migrationBatched)+  ] <&> \(desc, migration) ->+    testCase desc $ migratesToWith migration+      MyTemplateWrapper+      { commonField = UStoreField [mt|aa|]+      , custom = ()+      }+      MyTemplateWrapper+      { commonField = UStoreField [mt|bb|]+      , custom = (part1Val, part2Val)+      }+  where+    migratesToWith migration storeV1 expectedStoreV2 =+      either (assertFailure . toString) (@?= expectedStoreV2) $ do+        storeV2 <-+          first pretty $+          interpretLorentzLambda+            dummyContractEnv+            (migrationToLambda migration)+            (mkUStore storeV1)+        ustoreDecomposeFull storeV2
+ test/Test/Lorentz/UStore/Migration/Simple.hs view
@@ -0,0 +1,82 @@+module Test.Lorentz.UStore.Migration.Simple+  ( test_Migration_works+  ) where++import Fmt (pretty)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)+import Test.HUnit ((@?=), assertFailure)++import qualified Lorentz as L+import Lorentz.UStore+import Lorentz.UStore.Migration+import Lorentz.UStore.Migration.Diff+import Michelson.Text+import Michelson.Test.Dummy+import Lorentz.Run++import qualified Test.Lorentz.UStore.Migration.Simple.V1 as V1+import qualified Test.Lorentz.UStore.Migration.Simple.V2 as V2++_checkDiff :: Proxy (BuildDiff V1.MyTemplate V2.MyTemplate)+_checkDiff = Proxy @+  [ '( 'ToAdd, '("theName", UStoreField MText))+  , '( 'ToAdd, '("transformed", UStoreField Integer))+  , '( 'ToDel, '("useless", UStoreField MText))+  , '( 'ToDel, '("transformed", UStoreField Natural))+  ]++migrationBatched :: UStoreMigration V1.MyTemplate V2.MyTemplate+migrationBatched = mkUStoreBatchedMigration $+  muBlock $:+    migrateExtractField #useless L.#+    L.push [mt|Token-|] L.#+    L.concat L.#+    migrateAddField #theName+  <-->+  muBlock $:+    L.push 3 L.#+    migrateOverwriteField #transformed+  <-->+  migrationFinish++migrationSimple :: UStoreMigration V1.MyTemplate V2.MyTemplate+migrationSimple = mkUStoreMigration $+  migrateExtractField #useless L.#+  L.push [mt|Token-|] L.#+  L.concat L.#+  migrateAddField #theName L.#++  L.push 3 L.#+  migrateOverwriteField #transformed L.#++  migrationFinish++test_Migration_works :: [TestTree]+test_Migration_works =+  [ ("simple migration", migrationSimple)+  , ("batched migration", migrationBatched)+  ] <&> \(desc, migration) ->+    testCase desc $ migratesWith migration+      V1.MyTemplate+      { V1.bytes = UStoreSubMap mempty+      , V1.count = UStoreField 5+      , V1.useless = UStoreField [mt|pog|]+      , V1.transformed = UStoreField 10+      }+      V2.MyTemplate+      { V2.theName = UStoreField [mt|Token-pog|]+      , V2.bytes = UStoreSubMap mempty+      , V2.count = UStoreField 5+      , V2.transformed = UStoreField 3+      }+  where+    migratesWith migration storeV1 expectedStoreV2 =+      either (assertFailure . toString) (@?= expectedStoreV2) $ do+        storeV2 <-+          first pretty $+          interpretLorentzLambda+            dummyContractEnv+            (migrationToLambda migration)+            (mkUStore storeV1)+        ustoreDecomposeFull storeV2
+ test/Test/Lorentz/UStore/Migration/Simple/V1.hs view
@@ -0,0 +1,13 @@+module Test.Lorentz.UStore.Migration.Simple.V1+  ( MyTemplate (..)+  ) where++import Lorentz.UStore+import Lorentz.Value++data MyTemplate = MyTemplate+  { bytes :: Integer |~> ByteString+  , count :: UStoreField Integer+  , useless :: UStoreField MText+  , transformed :: UStoreField Natural+  } deriving stock Generic
+ test/Test/Lorentz/UStore/Migration/Simple/V2.hs view
@@ -0,0 +1,13 @@+module Test.Lorentz.UStore.Migration.Simple.V2+  ( MyTemplate (..)+  ) where++import Lorentz.UStore+import Lorentz.Value++data MyTemplate = MyTemplate+  { theName :: UStoreField MText+  , bytes :: Integer |~> ByteString+  , count :: UStoreField Integer+  , transformed :: UStoreField Integer+  } deriving stock (Eq, Show, Generic)
+ test/Test/Lorentz/UStore/SafeLift.hs view
@@ -0,0 +1,42 @@+-- | We have a constraint in 'ustoreLift' which+-- forbids nested store templates with duplicated fields.+-- This module checks this constraint will work fine.+module Test.Lorentz.UStore.SafeLift+  ( test_UStore_lift+  ) where++import Data.Typeable ((:~:)(..))+import Test.Tasty (TestTree)++import Lorentz.UStore+import Lorentz.UStore.Lift++import Test.Lorentz.UStore.SafeLift.Helpers++-- Fake tests to deceive "weeder".+-- All the check consist of typechecking some stuff, see below.+test_UStore_lift :: [TestTree]+test_UStore_lift = []++_checkDuplicates0 :: UStoreFieldsAreUnique MySimpleTemplate :~: 'True+_checkDuplicates0 = Refl++data MyTemplateBig = MyTemplateBig+  { ints :: Integer |~> Natural+  , small :: MySimpleTemplate+  } deriving stock (Generic)++_checkDuplicates1 :: UStoreFieldsAreUnique MyTemplateBig :~: 'False+_checkDuplicates1 = Refl++data MyTemplate2 = MyTemplate2+  { bool :: UStoreField Bool+  } deriving stock (Generic)++data MyTemplateSuperBig = MyTemplateSuperBig+  { ssmall :: MySimpleTemplate+  , ssmall2 :: MyTemplate2+  } deriving stock (Generic)++_checkDuplicates2 :: UStoreFieldsAreUnique MyTemplateSuperBig :~: 'False+_checkDuplicates2 = Refl
+ test/Test/Lorentz/UStore/SafeLift/Helpers.hs view
@@ -0,0 +1,14 @@+-- | Contains a template for safe lifting check.+--+-- We are going to define another template with the same field name,+-- so putting this template in a separate module.+module Test.Lorentz.UStore.SafeLift.Helpers+  ( MySimpleTemplate (..)+  ) where++import Lorentz.UStore++data MySimpleTemplate = MySimpleTemplate+  { ints :: Integer |~> ()+  , bool :: UStoreField Bool+  } deriving stock (Generic)
+ test/Test/Tasty/TypeSpec.hs view
@@ -0,0 +1,27 @@+-- | Tasty integration for TypeSpec.+module Test.Tasty.TypeSpec+  ( typeTest+  ) where++import Test.Tasty.Providers (IsTest(..), TestName, TestTree, singleTest, testPassed)+import Test.TypeSpec.Core (PrettyTypeSpec, TypeSpec(..))++data TypeTestCase =+  forall expectation. PrettyTypeSpec expectation =>+  TypeTestCase (TypeSpec expectation)++instance IsTest TypeTestCase where+  -- Implementation here is similar to the one from HUnit integration+  run _ (TypeTestCase spec) _ =+    -- According to documentation of TypeSpec, the only sensible thing we can+    -- do with spec value is to print it.+    -- TypeSpec test suites are ensured at compile time.+    return . testPassed $ show spec++  testOptions = pure []++-- | Turn a 'TypeSpec' into tasty test case.+typeTest+  :: PrettyTypeSpec expectation+  => TestName -> TypeSpec expectation -> TestTree+typeTest name spec = singleTest name (TypeTestCase spec)
+ test/Test/Util/TypeSpec.hs view
@@ -0,0 +1,20 @@+module Test.Util.TypeSpec+  ( ExactlyIs+  ) where++import Test.TypeSpec.Core+import Data.Singletons.Prelude.Eq (DefaultEq)+import Util.Type (If)+import Util.TypeLits (ErrorMessage (..))++-- | Like 'Is' but ensures that arguments match in kind.+data ExactlyIs (actual :: k) (expected :: k)+type instance EvalExpectation (ExactlyIs actual expected) =+  If (DefaultEq actual expected)+      (OK (ExactlyIs actual expected))+      (FAILED+        ('Text "Expected type: " ':<>: 'ShowType expected+          ':$$: 'Text "Actual type:   " ':<>: 'ShowType actual))++instance PrettyTypeSpec (ExactlyIs a b) where+  prettyTypeSpec _px = "Equal"
+ test/Tree.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-}