packages feed

morley (empty) → 0.1.0.0

raw patch · 71 files changed

+11817/−0 lines, 71 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed

Dependencies added: HUnit, QuickCheck, aeson, aeson-options, base-noprelude, base16-bytestring, base58-bytestring, bifunctors, bytestring, containers, cryptonite, data-default, directory, filepath, fmt, formatting, hspec, hspec-golden-aeson, lens, megaparsec, memory, morley, morley-prelude, mtl, named, natural-numbers, optparse-applicative, parser-combinators, pretty-simple, quickcheck-arbitrary-adt, quickcheck-instances, singletons, syb, text, time, timerep, universum, vinyl

Files

+ CONTRIBUTING.md view
@@ -0,0 +1,32 @@+# Contribution Guidelines++## Reporting Issues++Please [open an issue](https://issues.serokell.io/newIssue?project=TM)+if you find a bug or have a feature request.+Note: you need to login (e. g. using your GitHub account) first.+Before submitting a bug report or feature request, check to make sure it hasn't already been submitted.++The more detailed your report is, the faster it can be resolved.+If you report a bug, please provide steps to reproduce this bug and revision of code in which this bug reproduces.++## Code++If you would like to contribute code to fix a bug, add a new feature, or+otherwise improve our project, merge requests are most welcome.++Our merge request template contains a [checklist](/.gitlab/merge_request_templates/default.md#white_check_mark-checklist-for-your-merge-request) of acceptance criteria for your merge request.+Please read it before you start contributing and make sure your contributions adhere to this checklist.++### Prelude++All Haskell code uses+[Universum](https://hackage.haskell.org/package/universum) as a+replacement for the default prelude.++## Makefile++We have a [Makefile](/Makefile) which provides shortcuts for the most+common developers' activities, like building with flags suitable for+development, testing, applying `stylish-haskell` and `hlint`, building+Haddock documentation.
+ 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,42 @@+# Morley: Developer tools for the Michelson Language++Morley is a library to make writing smart contracts in Michelson pleasant and+effective.++## I: A reimplementation of the Michelson Language in Haskell++- `Michelson.Untyped`: Simple data types representing Michelson smart+  contracts and expresions. We use word `Untyped` to reflect that+  Michelson type of corresponding Haskel values is not statically known+  (e. g. there is a `Value` type which is basically dynamically typed).+- `Michelson.Typed`: These modules contain more advanced types comparing to+  `Michelson.Untyped` with similar semantics. These types use `GADTs` GHC+  extension and in this representation Michelson type of each value and+  instruction is statically known. There are also some utilities to use this+  advanced machinery.+- `Michelson.TypeCheck`: A typechecker that validates ADT's that conform to+  Michelson's typing rules.+- `Michelson.Intepreter`: An intepreter for Michelson contracts which doesn't+  perform any side effects.+- `Morley.Types`: Types for macros, syntactic sugar, and interpreter directives.+- `Morley.Parser` A parser to turn a `.tz` file into an ADT.+- `Morley.Runtime`: An interpreter that executes a well-typed Morley smart+  contract in a sandbox.++## II: Testing tools (TBD)++- `Morley.REPL`: An interactive REPL with stack visualization.+- `Morley.QuickCheck`: QuickCheck generators for arbitary Michelson `Value`s,+  `LAMBDA`s and `Contract`s.+- `Morley.Sandbox`: Simulating a more realistic network environment, multiple+   smart contracts in the same sandbox.++## Issue Tracker++We use [YouTrack](https://issues.serokell.io/issues/TM) as our issue+tracker. You can login using your GitHub account to leave a comment or+create a new issue.++## For Contributors++Please see [CONTRIBUTING.md](CONTRIBUTING.md) for more information.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,323 @@+module Main+  ( main+  ) where+++import Data.Version (showVersion)+import Fmt (pretty)+import Named ((!))+import Options.Applicative+  (auto, command, eitherReader, execParser, fullDesc, header, help, helper, info, infoOption, long,+  maybeReader, metavar, option, progDesc, readerError, short, showDefault, showDefaultWith,+  strOption, subparser, switch, value)+import qualified Options.Applicative as Opt+import Paths_morley (version)+import Text.Pretty.Simple (pPrint)++import Michelson.Untyped hiding (OriginationOperation(..))+import qualified Michelson.Untyped as Un+import Morley.Ext (typeCheckMorleyContract)+import Morley.Macro (expandFlattenContract, expandValue)+import qualified Morley.Parser as P+import Morley.Runtime+  (TxData(..), originateContract, prepareContract, readAndParseContract, runContract, transfer)+import Morley.Runtime.GState (genesisAddress, genesisKeyHash)+import Tezos.Address (Address, parseAddress)+import Tezos.Core+  (Mutez, Timestamp(..), mkMutez, parseTimestamp, timestampFromSeconds, unMutez, unsafeMkMutez)+import Tezos.Crypto++data CmdLnArgs+  = Parse (Maybe FilePath) Bool+  | TypeCheck (Maybe FilePath) Bool+  | Run !RunOptions+  | Originate !OriginateOptions+  | Transfer !TransferOptions++data RunOptions = RunOptions+  { roContractFile :: !(Maybe FilePath)+  , roDBPath :: !FilePath+  , roStorageValue :: !(Value Op)+  , roTxData :: !TxData+  , roVerbose :: !Bool+  , roNow :: !(Maybe Timestamp)+  , roMaxSteps :: !Word64+  , roInitBalance :: !Mutez+  , roWrite :: !Bool+  }++data OriginateOptions = OriginateOptions+  { ooContractFile :: !(Maybe FilePath)+  , ooDBPath :: !FilePath+  , ooManager :: !KeyHash+  , ooDelegate :: !(Maybe KeyHash)+  , ooSpendable :: !Bool+  , ooDelegatable :: !Bool+  , ooStorageValue :: !(Value Op)+  , ooBalance :: !Mutez+  , ooVerbose :: !Bool+  }++data TransferOptions = TransferOptions+  { toDBPath :: !FilePath+  , toDestination :: !Address+  , toTxData :: !TxData+  , toNow :: !(Maybe Timestamp)+  , toMaxSteps :: !Word64+  , toVerbose :: !Bool+  , toDryRun :: !Bool+  }++argParser :: Opt.Parser CmdLnArgs+argParser = subparser $+  parseSubCmd <>+  typecheckSubCmd <>+  runSubCmd <>+  originateSubCmd <>+  transferSubCmd+  where+    mkCommandParser commandName parser desc =+      command commandName $+      info (helper <*> parser) $+      progDesc desc++    parseSubCmd =+      mkCommandParser "parse"+      (uncurry Parse <$> parseOptions)+      "Parse passed contract"++    typecheckSubCmd =+      mkCommandParser "typecheck"+      (uncurry TypeCheck <$> typecheckOptions)+      "Typecheck passed contract"++    runSubCmd =+      mkCommandParser "run"+      (Run <$> runOptions) $+      "Run passed contract. \+      \It's originated first and then a transaction is sent to it"++    originateSubCmd =+      mkCommandParser "originate"+      (Originate <$> originateOptions)+      "Originate passed contract. Add it to passed DB"++    transferSubCmd =+      mkCommandParser "transfer"+      (Transfer <$> transferOptions)+      "Transfer tokens to given address"++    verboseFlag :: Opt.Parser Bool+    verboseFlag = switch $+      short 'v' <>+      long "verbose" <>+      help "Whether output should be verbose"++    writeFlag :: Opt.Parser Bool+    writeFlag = switch $+      long "write" <>+      help "Whether updated DB should be written to DB file"++    dryRunFlag :: Opt.Parser Bool+    dryRunFlag = switch $+      long "dry-run" <>+      help "Do not write updated DB to DB file"++    typecheckOptions :: Opt.Parser (Maybe FilePath, Bool)+    typecheckOptions = (,)+      <$> contractFileOption+      <*> verboseFlag++    parseOptions :: Opt.Parser (Maybe FilePath, Bool)+    parseOptions = (,)+      <$> contractFileOption+      <*> switch (+        long "expand-macros" <>+        help "Whether expand macros after parsing or not")++    defaultBalance :: Mutez+    defaultBalance = unsafeMkMutez 4000000++    runOptions :: Opt.Parser RunOptions+    runOptions =+      RunOptions+        <$> contractFileOption+        <*> dbPathOption+        <*> valueOption "storage" "Initial storage of a running contract"+        <*> txData+        <*> verboseFlag+        <*> nowOption+        <*> maxStepsOption+        <*> mutezOption (Just defaultBalance)+            "balance" "Initial balance of this contract"+        <*> writeFlag++    originateOptions :: Opt.Parser OriginateOptions+    originateOptions =+      OriginateOptions+        <$> contractFileOption+        <*> dbPathOption+        <*> keyHashOption (Just genesisKeyHash) "manager" "Contract's manager"+        <*> optional+            (keyHashOption Nothing "manager" "Contract's optional delegate")+        <*> switch (long "spendable" <>+                    help "Whether the contract is spendable")+        <*> switch (long "delegatable" <>+                    help "Whether the contract is delegatable")+        <*> valueOption "storage" "Initial storage of an originating contract"+        <*> mutezOption (Just defaultBalance)+            "balance" "Initial balance of an originating contract"+        <*> verboseFlag++    transferOptions :: Opt.Parser TransferOptions+    transferOptions = do+      toDBPath <- dbPathOption+      toDestination <- addressOption Nothing "to" "Destination address"+      toTxData <- txData+      toNow <- nowOption+      toMaxSteps <- maxStepsOption+      toVerbose <- verboseFlag+      toDryRun <- dryRunFlag+      pure TransferOptions {..}++contractFileOption :: Opt.Parser (Maybe FilePath)+contractFileOption = optional $ strOption $+  long "contract" <>+  metavar "FILEPATH" <>+  help "Path to contract file"++nowOption :: Opt.Parser (Maybe Timestamp)+nowOption = optional $ option parser $+  long "now" <>+  metavar "TIMESTAMP" <>+  help "Timestamp that you want the runtime interpreter to use (default is now)"+  where+    parser =+      (timestampFromSeconds @Integer <$> auto) <|>+      maybeReader (parseTimestamp . toText)++maxStepsOption :: Opt.Parser Word64+maxStepsOption = option auto $+  value 100500 <>+  long "max-steps" <>+  metavar "INT" <>+  help "Max steps that you want the runtime interpreter to use" <>+  showDefault++dbPathOption :: Opt.Parser FilePath+dbPathOption = strOption $+  long "db" <>+  metavar "FILEPATH" <>+  value "db.json" <>+  help "Path to DB with data which is used instead of real blockchain data" <>+  showDefault++keyHashOption :: Maybe KeyHash -> String -> String -> Opt.Parser KeyHash+keyHashOption defaultValue name hInfo =+  option (eitherReader (first pretty . parseKeyHash . toText)) $+  long name <>+  maybeAddDefault pretty defaultValue <>+  help hInfo++valueOption :: String -> String -> Opt.Parser (Value Op)+valueOption name hInfo = option (eitherReader parseValue) $+  long name <>+  help hInfo+  where+    parseValue :: String -> Either String (Value Op)+    parseValue s =+      either (Left . mappend "Failed to parse value: " . show)+             (Right . expandValue)+      $ P.parseNoEnv P.value "" (toText s)++mutezOption :: Maybe Mutez -> String -> String -> Opt.Parser Mutez+mutezOption defaultValue name hInfo =+  option (maybe (readerError "Invalid mutez") pure . mkMutez =<< auto) $+  long name <>+  metavar "INT" <>+  maybeAddDefault (show . unMutez) defaultValue <>+  help hInfo++addressOption :: Maybe Address -> String -> String -> Opt.Parser Address+addressOption defAddress name hInfo =+  option (eitherReader parseAddrDo) $ mconcat+  [ long name+  , metavar "ADDRESS"+  , help hInfo+  , maybeAddDefault pretty defAddress+  ]+  where+    parseAddrDo addr =+      either (Left . mappend "Failed to parse address: " . pretty) Right $+      parseAddress $ toText addr++txData :: Opt.Parser TxData+txData =+  mkTxData+    <$> addressOption (Just genesisAddress) "sender" "Sender address"+    <*> valueOption "parameter" "Parameter of passed contract"+    <*> mutezOption (Just minBound) "amount" "Amout sent by a transaction"+  where+    mkTxData :: Address -> Value Op -> Mutez -> TxData+    mkTxData addr param amount =+      TxData+        { tdSenderAddress = addr+        , tdParameter = param+        , tdAmount = amount+        }++-- Maybe add default value and make sure it will be shown in help message.+maybeAddDefault :: Opt.HasValue f => (a -> String) -> Maybe a -> Opt.Mod f a+maybeAddDefault printer = maybe mempty addDefault+  where+    addDefault v = value v <> showDefaultWith printer++main :: IO ()+main = do+  cmdLnArgs <- execParser programInfo+  run cmdLnArgs `catchAny` (die . displayException)+  where+    programInfo = info (helper <*> versionOption <*> argParser) $+      mconcat+      [ fullDesc+      , progDesc "Morley: Haskell implementation of Michelson typechecker and interpreter"+      , header "Morley tools"+      ]++    versionOption = infoOption ("morley-" <> showVersion version)+      (long "version" <> help "Show version.")++    run :: CmdLnArgs -> IO ()+    run args = case args of+      Parse mFilename hasExpandMacros -> do+        contract <- readAndParseContract mFilename+        if hasExpandMacros+          then pPrint $ expandFlattenContract contract+          else pPrint contract+      TypeCheck mFilename _hasVerboseFlag -> do+        michelsonContract <- prepareContract mFilename+        void $ either throwM pure $+          (typeCheckMorleyContract . fmap unOp) michelsonContract+        putTextLn "Contract is well-typed"+      Run RunOptions {..} -> do+        michelsonContract <- prepareContract roContractFile+        runContract roNow roMaxSteps roInitBalance roDBPath roStorageValue michelsonContract roTxData+          ! #verbose roVerbose+          ! #dryRun (not roWrite)+      Originate OriginateOptions {..} -> do+        michelsonContract <- prepareContract ooContractFile+        let origination = Un.OriginationOperation+              { Un.ooManager = ooManager+              , Un.ooDelegate = ooDelegate+              , Un.ooSpendable = ooSpendable+              , Un.ooDelegatable = ooDelegatable+              , Un.ooStorage = ooStorageValue+              , Un.ooBalance = ooBalance+              , Un.ooContract = michelsonContract+              }+        addr <- originateContract ooDBPath origination ! #verbose ooVerbose+        putTextLn $ "Originated contract " <> pretty addr+      Transfer TransferOptions {..} -> do+        transfer toNow toMaxSteps toDBPath toDestination toTxData+          ! #verbose toVerbose+          ! #dryRun toDryRun
+ morley.cabal view
@@ -0,0 +1,304 @@+name:                morley+version:             0.1.0.0+synopsis:            Developer tools for the Michelson Language+description:+  A library to make writing smart contracts in Michelson — the smart contract+  language of the Tezos blockchain — pleasant and effective.+homepage:            https://gitlab.com/camlcase-dev/morley+license:             AGPL-3+license-file:        LICENSE+author:              camlCase, Serokell+maintainer:          john@camlcase.io+copyright:           2018 camlCase, 2019 Tocqueville Group+category:            Language+build-type:          Simple+cabal-version:       >=1.18+bug-reports:         https://issues.serokell.io/issues/TM+extra-doc-files:     CONTRIBUTING.md+                   , README.md++source-repository head+  type:     git+  location: git@gitlab.com:camlcase-dev/morley.git++library+  build-tool-depends: autoexporter:autoexporter++  hs-source-dirs:      src+  default-language:    Haskell2010+  exposed-modules:     Michelson.Interpret+                     , Michelson.TypeCheck+                     , Michelson.Typed+                     , Michelson.Typed.Value+                     , Michelson.Untyped+                     , Morley.Aliases+                     , Morley.Default+                     , Morley.Lexer+                     , Morley.Macro+                     , Morley.Ext+                     , Morley.Parser+                     , Morley.Parser.Annotations+                     , Morley.Runtime+                     , Morley.Runtime.GState+                     , Morley.Runtime.TxData+                     , Morley.Test+                     , Morley.Test.Dummy+                     , Morley.Test.Gen+                     , Morley.Test.Import+                     , Morley.Test.Integrational+                     , Morley.Test.Unit+                     , Morley.Test.Util+                     , Morley.Types+                     , Tezos.Address+                     , Tezos.Core+                     , Tezos.Crypto+  other-modules:+                       Michelson.EqParam+                     , Michelson.TypeCheck.Helpers+                     , Michelson.TypeCheck.Instr+                     , Michelson.TypeCheck.Types+                     , Michelson.TypeCheck.Value+                     , Michelson.Typed.Annotation+                     , Michelson.Typed.Arith+                     , Michelson.Typed.Convert+                     , Michelson.Typed.CValue+                     , Michelson.Typed.Extract+                     , Michelson.Typed.Instr+                     , Michelson.Typed.Polymorphic+                     , Michelson.Typed.Sing+                     , Michelson.Typed.T+                     , Michelson.Untyped.Annotation+                     , Michelson.Untyped.Contract+                     , Michelson.Untyped.Instr+                     , Michelson.Untyped.Type+                     , Michelson.Untyped.Value++  build-depends:       aeson+                     , aeson-options+                     , base-noprelude >= 4.7 && < 5+                     , base16-bytestring+                     , base58-bytestring+                     , bifunctors+                     , bytestring+                     , containers+                     , cryptonite+                     , data-default+                     , fmt+                     , formatting+                     , hspec+                     , lens+                     , megaparsec >= 7.0.0+                     , memory+                     , morley-prelude+                     , named+                     , natural-numbers+                     , QuickCheck+                     , text+                     , time+                     , timerep+                     , parser-combinators >= 1.0.0+                     , directory+                     , singletons+                     , syb+                     , mtl+                     , vinyl+  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+  default-extensions:+                       ApplicativeDo+                       AllowAmbiguousTypes+                       BangPatterns+                       ConstraintKinds+                       DataKinds+                       DeriveFoldable+                       DeriveFunctor+                       DeriveGeneric+                       DeriveTraversable+                       EmptyCase+                       FlexibleContexts+                       FlexibleInstances+                       GADTs+                       GeneralizedNewtypeDeriving+                       LambdaCase+                       MonadFailDesugaring+                       MultiParamTypeClasses+                       MultiWayIf+                       NegativeLiterals+                       OverloadedLabels+                       OverloadedStrings+                       PatternSynonyms+                       PolyKinds+                       RankNTypes+                       RecordWildCards+                       RecursiveDo+                       ScopedTypeVariables+                       StandaloneDeriving+                       TemplateHaskell+                       TupleSections+                       TypeApplications+                       TypeFamilies+                       TypeOperators+                       UndecidableInstances+                       ViewPatterns++executable morley+  hs-source-dirs:      app+  main-is:             Main.hs+  other-modules:       Paths_morley+  default-language:    Haskell2010+  build-depends:       base-noprelude >= 4.7 && < 5+                     , fmt+                     , megaparsec >= 7.0.0+                     , morley+                     , morley-prelude+                     , named+                     , optparse-applicative+                     , pretty-simple+                     , text+  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+  default-extensions:+                       ApplicativeDo+                       AllowAmbiguousTypes+                       BangPatterns+                       ConstraintKinds+                       DataKinds+                       DeriveFoldable+                       DeriveFunctor+                       DeriveGeneric+                       DeriveTraversable+                       EmptyCase+                       FlexibleContexts+                       FlexibleInstances+                       GADTs+                       GeneralizedNewtypeDeriving+                       LambdaCase+                       MonadFailDesugaring+                       MultiParamTypeClasses+                       MultiWayIf+                       NegativeLiterals+                       OverloadedLabels+                       OverloadedStrings+                       PatternSynonyms+                       PolyKinds+                       RankNTypes+                       RecordWildCards+                       RecursiveDo+                       ScopedTypeVariables+                       StandaloneDeriving+                       TemplateHaskell+                       TupleSections+                       TypeApplications+                       TypeFamilies+                       TypeOperators+                       UndecidableInstances+                       ViewPatterns++test-suite morley-test+  hs-source-dirs:      test+  main-is:             Spec.hs+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  other-modules:       Test.Arbitrary+                     , Test.CValConversion+                     , Test.Interpreter+                     , Test.Interpreter.Auction+                     , Test.Interpreter.CallSelf+                     , Test.Interpreter.Compare+                     , Test.Interpreter.Conditionals+                     , Test.Interpreter.StringCaller+                     , Test.Macro+                     , Test.Ext+                     , Test.Morley.Runtime+                     , Test.Parser+                     , Test.Serialization.Aeson+                     , Test.Tezos.Address+                     , Test.Tezos.Crypto+                     , Test.Typecheck+                     , Test.Util.Contracts+                     , Test.Util.QuickCheck+                     , Test.ValConversion+  build-depends:+                       aeson+                     , base-noprelude >= 4.7 && < 5+                     , containers+                     , directory+                     , filepath+                     , fmt+                     , formatting+                     , hspec+                     , hspec-golden-aeson+                     , HUnit+                     , lens+                     , megaparsec >= 7.0.0+                     , morley+                     , morley-prelude+                     , QuickCheck+                     , quickcheck-arbitrary-adt+                     , quickcheck-instances+                     , text+                     , time+                     , universum+                     , vinyl+  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+  default-extensions:+                       ApplicativeDo+                       AllowAmbiguousTypes+                       BangPatterns+                       ConstraintKinds+                       DataKinds+                       DeriveFoldable+                       DeriveFunctor+                       DeriveGeneric+                       DeriveTraversable+                       EmptyCase+                       FlexibleContexts+                       FlexibleInstances+                       GADTs+                       GeneralizedNewtypeDeriving+                       LambdaCase+                       MonadFailDesugaring+                       MultiParamTypeClasses+                       MultiWayIf+                       NegativeLiterals+                       OverloadedLabels+                       OverloadedStrings+                       PatternSynonyms+                       PolyKinds+                       RankNTypes+                       RecordWildCards+                       RecursiveDo+                       ScopedTypeVariables+                       StandaloneDeriving+                       TemplateHaskell+                       TupleSections+                       TypeApplications+                       TypeFamilies+                       TypeOperators+                       UndecidableInstances+                       ViewPatterns
+ src/Michelson/EqParam.hs view
@@ -0,0 +1,66 @@+-- | Functions to check whether two values are equal if their types+-- have parameters and it's not statically known whether they these+-- parameters have the same types.++module Michelson.EqParam+  ( eqParam1+  , eqParam2+  , eqParam3+  ) where++import Data.Typeable ((:~:)(..), eqT)++-- | Suppose you have a data type `X` with parameter `a` and you have+-- two values: `x1 :: X a1` and `x2 :: X a2`. You can't compare them+-- using '==', because they have different types. However, you can+-- compare them using 'eqParam1' as long as both parameters are+-- 'Typeable'.+eqParam1 ::+     forall a1 a2 t.+     ( Typeable a1+     , Typeable a2+     , Eq (t a1)+     )+  => t a1+  -> t a2+  -> Bool+eqParam1 t1 t2 = isJust @() $ do+  Refl <- eqT @a1 @a2+  guard (t1 == t2)++-- | Version of 'eqParam1' for types with 2 parameters.+eqParam2 ::+     forall a1 a2 b1 b2 t.+     ( Typeable a1+     , Typeable a2+     , Typeable b1+     , Typeable b2+     , Eq (t a1 b2)+     )+  => t a1 b1+  -> t a2 b2+  -> Bool+eqParam2 t1 t2 = isJust @() $ do+  Refl <- eqT @a1 @a2+  Refl <- eqT @b1 @b2+  guard (t1 == t2)++-- | Version of 'eqParam1' for types with 3 parameters.+eqParam3 ::+     forall a1 a2 b1 b2 c1 c2 t.+     ( Typeable a1+     , Typeable a2+     , Typeable b1+     , Typeable b2+     , Typeable c1+     , Typeable c2+     , Eq (t a1 b1 c1)+     )+  => t a1 b1 c1+  -> t a2 b2 c2+  -> Bool+eqParam3 t1 t2 = isJust @() $ do+  Refl <- eqT @a1 @a2+  Refl <- eqT @b1 @b2+  Refl <- eqT @c1 @c2+  guard (t1 == t2)
+ src/Michelson/Interpret.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE DerivingStrategies, Rank2Types #-}++-- | Module, containing function to interpret Michelson+-- instructions against given context and input stack.+module Michelson.Interpret+  ( ContractEnv (..)+  , InterpreterEnv (..)+  , InterpreterState (..)+  , MichelsonFailed (..)+  , RemainingSteps (..)+  , SomeItStack (..)+  , EvalOp++  , interpret+  , ContractReturn++  , interpretUntyped+  , InterpretUntypedError (..)+  , InterpretUntypedResult (..)+  , runInstr+  , runInstrNoGas+  ) where++import Prelude hiding (EQ, GT, LT)++import Control.Monad.Except (throwError)+import qualified Data.Aeson as Aeson+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Singletons (SingI(..))+import Data.Typeable ((:~:)(..))+import Data.Vinyl (Rec(..), (<+>))+import Fmt (Buildable(build), Builder, genericF)++import Michelson.TypeCheck+  (ExtC, SomeContract(..), SomeVal(..), TCError, TcExtHandler, eqT', runTypeCheckT,+  typeCheckContract, typeCheckVal)+import Michelson.Typed+  (CVal(..), Contract, ConversibleExt, CreateAccount(..), CreateContract(..), Instr(..),+  Operation(..), SetDelegate(..), Sing(..), T(..), TransferTokens(..), Val(..), fromUType,+  valToOpOrValue)+import qualified Michelson.Typed as T+import Michelson.Typed.Arith+import Michelson.Typed.Convert (convertContract, unsafeValToValue)+import Michelson.Typed.Polymorphic+import qualified Michelson.Untyped as U+import Tezos.Address (Address(..))+import Tezos.Core (Mutez, Timestamp(..))+import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, sha256, sha512)++-- | Environment for contract execution.+data ContractEnv = ContractEnv+  { ceNow :: !Timestamp+  -- ^ Timestamp of the block whose validation triggered this execution.+  , ceMaxSteps :: !RemainingSteps+  -- ^ Number of steps after which execution unconditionally terminates.+  , ceBalance :: !Mutez+  -- ^ Current amount of mutez of the current contract.+  , ceContracts :: Map Address (U.Contract U.Op)+  -- ^ Mapping from existing contracts' addresses to their executable+  -- representation.+  , ceSelf :: !Address+  -- ^ Address of the interpreted contract.+  , ceSource :: !Address+  -- ^ The contract that initiated the current transaction.+  , ceSender :: !Address+  -- ^ The contract that initiated the current internal transaction.+  , ceAmount :: !Mutez+  -- ^ Amount of the current transaction.+  }++-- | Represents `[FAILED]` state of a Michelson program. Contains+-- value that was on top of the stack when `FAILWITH` was called.+data MichelsonFailed where+  MichelsonFailedWith :: Val Instr t -> MichelsonFailed+  MichelsonArithError :: ArithError (CVal n) (CVal m) -> MichelsonFailed+  MichelsonGasExhaustion :: MichelsonFailed+  MichelsonFailedOther :: Text -> MichelsonFailed++deriving instance Show MichelsonFailed++instance (ConversibleExt, Buildable U.Instr) => Buildable MichelsonFailed where+  build =+    \case+      MichelsonFailedWith (v :: Val Instr t) ->+        "Reached FAILWITH instruction with " <> formatValue v+      MichelsonArithError v -> build v+      MichelsonGasExhaustion ->+        "Gas limit exceeded on contract execution"+      MichelsonFailedOther t -> build t+    where+      formatValue :: forall t . Val Instr t -> Builder+      formatValue v =+        case valToOpOrValue v of+          Nothing -> "<value with operations>"+          Just untypedV -> build untypedV++data InterpretUntypedError s+  = RuntimeFailure (MichelsonFailed, s)+  | IllTypedContract TCError+  | IllTypedParam TCError+  | IllTypedStorage TCError+  | UnexpectedParamType Text+  | UnexpectedStorageType Text+  deriving (Generic)++deriving instance (Buildable U.Instr, Show s) => Show (InterpretUntypedError s)++instance (ConversibleExt, Buildable U.Instr, Buildable s) => Buildable (InterpretUntypedError s) where+  build = genericF++data InterpretUntypedResult s where+  InterpretUntypedResult+    :: ( Typeable st+       , SingI st+       )+    => { iurOps :: [ Operation Instr ]+       , iurNewStorage :: Val Instr st+       , iurNewState   :: InterpreterState s+       }+    -> InterpretUntypedResult s++-- | Interpret a contract without performing any side effects.+interpretUntyped+  :: forall s . (ExtC, Aeson.ToJSON U.InstrExtU)+  => TcExtHandler+  -> U.Contract U.Op+  -> U.Value U.Op+  -> U.Value U.Op+  -> InterpreterEnv s+  -> s+  -> Either (InterpretUntypedError s) (InterpretUntypedResult s)+interpretUntyped typeCheckHandler U.Contract{..} paramU initStU env initState = do+    (SomeContract (instr :: Contract cp st) _ _)+       <- first IllTypedContract $ typeCheckContract typeCheckHandler+              (U.Contract para stor (U.unOp <$> code))+    paramV :::: ((_ :: Sing cp1), _)+       <- first IllTypedParam $ runTypeCheckT typeCheckHandler para $+            typeCheckVal paramU (fromUType para)+    initStV :::: ((_ :: Sing st1), _)+       <- first IllTypedStorage $ runTypeCheckT typeCheckHandler para $+            typeCheckVal initStU (fromUType stor)+    Refl <- first UnexpectedStorageType $ eqT' @st @st1+    Refl <- first UnexpectedParamType   $ eqT' @cp @cp1+    bimap RuntimeFailure constructIUR $+      toRes $ interpret instr paramV initStV env initState+  where+    toRes (ei, s) = bimap (,isExtState s) (,s) ei++    constructIUR ::+      (Typeable st, SingI st) =>+      (([Operation Instr], Val Instr st), InterpreterState s) ->+      InterpretUntypedResult s+    constructIUR ((ops, val), st) =+      InterpretUntypedResult+      { iurOps = ops+      , iurNewStorage = val+      , iurNewState = st+      }++type ContractReturn s st =+  (Either MichelsonFailed ([Operation Instr], Val Instr st), InterpreterState s)++interpret+  :: (ExtC, Aeson.ToJSON U.InstrExtU, Typeable cp, Typeable st)+  => Contract cp st+  -> Val Instr cp+  -> Val Instr st+  -> InterpreterEnv s+  -> s+  -> ContractReturn s st+interpret instr param initSt env@InterpreterEnv{..} initState = first (fmap toRes) $+  runEvalOp+    (runInstr instr (VPair (param, initSt) :& RNil))+    env+    (InterpreterState initState $ ceMaxSteps ieContractEnv)+  where+    toRes+      :: (Rec (Val instr) '[ 'TPair ('TList 'TOperation) st ])+      -> ([Operation instr], Val instr st)+    toRes (VPair (VList ops_, newSt) :& RNil) =+      (map (\(VOp op) -> op) ops_, newSt)++data SomeItStack where+  SomeItStack :: Typeable inp => Rec (Val Instr) inp -> SomeItStack++data InterpreterEnv s = InterpreterEnv+  { ieContractEnv :: ContractEnv+  , ieItHandler   :: (T.InstrExtT, SomeItStack) -> EvalOp s ()+  }++newtype RemainingSteps = RemainingSteps Word64+  deriving stock (Show)+  deriving newtype (Eq, Ord, Buildable, Num)++data InterpreterState s = InterpreterState+  { isExtState       :: s+  , isRemainingSteps :: RemainingSteps+  } deriving (Show)++type EvalOp s a =+  ExceptT MichelsonFailed+    (ReaderT (InterpreterEnv s)+       (State (InterpreterState s))) a++runEvalOp ::+     EvalOp s a+  -> InterpreterEnv s+  -> InterpreterState s+  -> (Either MichelsonFailed a, InterpreterState s)+runEvalOp act env initSt =+  flip runState initSt $ usingReaderT env $ runExceptT act++-- | Function to change amount of remaining steps stored in State monad+runInstr+  :: (ExtC, Aeson.ToJSON U.InstrExtU, Typeable inp)+  => Instr inp out+  -> Rec (Val Instr) inp+  -> EvalOp state (Rec (Val Instr) out)+runInstr i@(Seq _i1 _i2) r = runInstrImpl runInstr i r+runInstr i@Nop r = runInstrImpl runInstr i r+runInstr i r = do+  rs <- gets isRemainingSteps+  if rs == 0+  then throwError $ MichelsonGasExhaustion+  else do+    modify (\s -> s {isRemainingSteps = rs - 1})+    runInstrImpl runInstr i r++runInstrNoGas+  :: forall a b state .+  (ExtC, Aeson.ToJSON U.InstrExtU, Typeable a)+  => T.Instr a b -> Rec (Val T.Instr) a -> EvalOp state (Rec (Val T.Instr) b)+runInstrNoGas = runInstrImpl runInstrNoGas++-- | Function to interpret Michelson instruction(s) against given stack.+runInstrImpl+    :: forall state .+    (ExtC, Aeson.ToJSON U.InstrExtU)+    => (forall inp1 out1 . Typeable inp1 =>+      Instr inp1 out1+    -> Rec (Val Instr) inp1+    -> EvalOp state (Rec (Val Instr) out1)+    )+    -> (forall inp out . Typeable inp =>+      Instr inp out+    -> Rec (Val Instr) inp+    -> EvalOp state (Rec (Val Instr) out)+    )+runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r'+runInstrImpl _ Nop r = pure $ r+runInstrImpl _ (Ext nop) r = do+  handler <- asks ieItHandler+  r <$ handler (nop, SomeItStack r)+runInstrImpl _ DROP (_ :& r) = pure $ r+runInstrImpl _ DUP (a :& r) = pure $ a :& a :& r+runInstrImpl _ SWAP (a :& b :& r) = pure $ b :& a :& r+runInstrImpl _ (PUSH v) r = pure $ v :& r+runInstrImpl _ SOME (a :& r) = pure $ VOption (Just a) :& r+runInstrImpl _ NONE r = pure $ VOption Nothing :& r+runInstrImpl _ UNIT r = pure $ VUnit :& r+runInstrImpl runner (IF_NONE _bNone bJust) (VOption (Just a) :& r) = runner bJust (a :& r)+runInstrImpl runner (IF_NONE bNone _bJust) (VOption Nothing :& r) = runner bNone r+runInstrImpl _ PAIR (a :& b :& r) = pure $ VPair (a, b) :& r+runInstrImpl _ CAR (VPair (a, _b) :& r) = pure $ a :& r+runInstrImpl _ CDR (VPair (_a, b) :& r) = pure $ b :& r+runInstrImpl _ LEFT (a :& r) = pure $ (VOr $ Left a) :& r+runInstrImpl _ RIGHT (b :& r) = pure $ (VOr $ Right b) :& r+runInstrImpl runner (IF_LEFT bLeft _) (VOr (Left a) :& r) = runner bLeft (a :& r)+runInstrImpl runner (IF_LEFT _ bRight) (VOr (Right a) :& r) = runner bRight (a :& r)+runInstrImpl runner (IF_RIGHT bRight _) (VOr (Right a) :& r) = runner bRight (a :& r)+runInstrImpl runner (IF_RIGHT _ bLeft) (VOr (Left a) :& r) = runner bLeft (a :& r)+-- More here+runInstrImpl _ NIL r = pure $ VList [] :& r+runInstrImpl _ CONS (a :& VList l :& r) = pure $ VList (a : l) :& r+runInstrImpl runner (IF_CONS _ bNil) (VList [] :& r) = runner bNil r+runInstrImpl runner (IF_CONS bCons _) (VList (lh : lr) :& r) = runner bCons (lh :& VList lr :& r)+runInstrImpl _ SIZE (a :& r) = pure $ VC (CvNat $ (fromInteger . toInteger) $ evalSize a) :& r+runInstrImpl _ EMPTY_SET r = pure $ VSet Set.empty :& r+runInstrImpl _ EMPTY_MAP r = pure $ VMap Map.empty :& r+runInstrImpl runner (MAP ops) (a :& r) =+  case ops of+    (code :: Instr (MapOpInp c ': s) (b ': s)) -> do+      newList <- mapM (\(val :: Val Instr (MapOpInp c)) -> do+        res <- runner code (val :& r)+        case res of+          ((newVal :: Val Instr b) :& _) -> pure newVal)+        $ mapOpToList @c @b a+      pure $ mapOpFromList a newList :& r+runInstrImpl runner (ITER ops) (a :& r) =+  case ops of+    (code :: Instr (IterOpEl c ': s) s) ->+      case iterOpDetachOne @c a of+        (Just x, xs) -> do+          res <- runner code (x :& r)+          runner (ITER code) (xs :& res)+        (Nothing, _) -> pure r+runInstrImpl _ MEM (VC a :& b :& r) = pure $ VC (CvBool (evalMem a b)) :& r+runInstrImpl _ GET (VC a :& b :& r) = pure $ VOption (evalGet a b) :& r+runInstrImpl _ UPDATE (VC a :& b :& c :& r) = pure $ evalUpd a b c :& r+runInstrImpl runner (IF bTrue _) (VC (CvBool True) :& r) = runner bTrue r+runInstrImpl runner (IF _ bFalse) (VC (CvBool False) :& r) = runner bFalse r+runInstrImpl _ (LOOP _) (VC (CvBool False) :& r) = pure $ r+runInstrImpl runner (LOOP ops) (VC (CvBool True) :& r) = do+  res <- runner ops r+  runner (LOOP ops) res+runInstrImpl _ (LOOP_LEFT _) (VOr (Right a) :&r) = pure $ a :& r+runInstrImpl runner (LOOP_LEFT ops) (VOr (Left a) :& r) = do+  res <- runner ops (a :& r)+  runner  (LOOP_LEFT ops) res+runInstrImpl _ (LAMBDA lam) r = pure $ lam :& r+runInstrImpl runner EXEC (a :& VLam lBody :& r) = do+  res <- runner lBody (a :& RNil)+  pure $ res <+> r+runInstrImpl runner (DIP i) (a :& r) = do+  res <- runner i r+  pure $ a :& res+runInstrImpl _ FAILWITH (a :& _) = throwError $ MichelsonFailedWith a+runInstrImpl _ CAST (a :& r) = pure $ a :& r+runInstrImpl _ RENAME (a :& r) = pure $ a :& r+-- TODO+runInstrImpl _ PACK (_ :& _) = error "PACK not implemented yet"+runInstrImpl _ UNPACK (_ :& _) = error "UNPACK not implemented yet"+runInstrImpl _ CONCAT (a :& b :& r) = pure $ evalConcat a b :& r+runInstrImpl _ CONCAT' (VList a :& r) = pure $ evalConcat' a :& r+runInstrImpl _ SLICE (VC (CvNat o) :& VC (CvNat l) :& s :& r) =+  pure $ VOption (evalSlice o l s) :& r+runInstrImpl _ ISNAT (VC (CvInt i) :& r) =+  if i < 0+  then pure $ VOption Nothing :& r+  else pure $ VOption (Just $ VC (CvNat $ fromInteger i)) :& r+runInstrImpl _ ADD (VC l :& VC r :& rest) =+  (:& rest) <$> runArithOp (Proxy @Add) l r+runInstrImpl _ SUB (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Sub) l r+runInstrImpl _ MUL (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Mul) l r+runInstrImpl _ EDIV (VC l :& VC r :& rest) = pure $ evalEDivOp l r :& rest+runInstrImpl _ ABS (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Abs) a) :& rest+runInstrImpl _ NEG (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Neg) a) :& rest+runInstrImpl _ LSL (VC x :& VC s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsl) x s+runInstrImpl _ LSR (VC x :& VC s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsr) x s+runInstrImpl _ OR (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Or) l r+runInstrImpl _ AND (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @And) l r+runInstrImpl _ XOR (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Xor) l r+runInstrImpl _ NOT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Not) a) :& rest+runInstrImpl _ COMPARE (VC l :& VC r :& rest) = (:& rest) <$> runArithOp (Proxy @Compare) l r+runInstrImpl _ T.EQ (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Eq') a) :& rest+runInstrImpl _ NEQ (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Neq) a) :& rest+runInstrImpl _ T.LT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Lt) a) :& rest+runInstrImpl _ T.GT (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Gt) a) :& rest+runInstrImpl _ LE (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Le) a) :& rest+runInstrImpl _ GE (VC a :& rest) = pure $ VC (evalUnaryArithOp (Proxy @Ge) a) :& rest+runInstrImpl _ INT (VC (CvNat n) :& r) = pure $ VC (CvInt $ toInteger n) :& r+runInstrImpl _ SELF r = do+  ContractEnv{..} <- asks ieContractEnv+  pure $ VContract ceSelf :& r+runInstrImpl _ CONTRACT (VC (CvAddress addr) :& r) = do+  ContractEnv{..} <- asks ieContractEnv+  if Map.member addr ceContracts+  then pure $ VOption (Just $ VContract addr) :& r+  else pure $ VOption Nothing :& r+runInstrImpl _ TRANSFER_TOKENS (p :& VC (CvMutez mutez) :& contract :& r) =+  pure $ VOp (OpTransferTokens $ TransferTokens p mutez contract) :& r+runInstrImpl _ SET_DELEGATE (VOption mbKeyHash :& r) =+  case mbKeyHash of+    Just (VC (CvKeyHash k)) -> pure $ VOp (OpSetDelegate $ SetDelegate $ Just k) :& r+    Nothing -> pure $ VOp (OpSetDelegate $ SetDelegate $ Nothing) :& r+runInstrImpl _ CREATE_ACCOUNT+  (VC (CvKeyHash k) :& VOption mbKeyHash :&+    (VC (CvBool spendable)) :& (VC (CvMutez m)) :& r) =+  pure (VOp (OpCreateAccount $ CreateAccount k (unwrapMbKeyHash mbKeyHash) spendable m)+    :& (VC . CvAddress) (KeyAddress k) :& r)+runInstrImpl _ CREATE_CONTRACT+  (VC (CvKeyHash k) :& VOption mbKeyHash :& (VC (CvBool spendable)) :&+    (VC (CvBool delegetable)) :& (VC (CvMutez m)) :& VLam ops :& g :& r) =+  pure (VOp (OpCreateContract $+    CreateContract k (unwrapMbKeyHash mbKeyHash) spendable delegetable m g ops)+    :& (VC . CvAddress) (U.mkContractAddress $+      createOrigOp k mbKeyHash spendable delegetable m ops g) :& r)+runInstrImpl _ (CREATE_CONTRACT2 ops)+  (VC (CvKeyHash k) :& VOption mbKeyHash :& (VC (CvBool spendable)) :&+    (VC (CvBool delegetable)) :& (VC (CvMutez m)) :& g :& r) =+  pure (VOp (OpCreateContract $+    CreateContract k (unwrapMbKeyHash mbKeyHash) spendable delegetable m g ops)+    :& (VC . CvAddress) (U.mkContractAddress $+      createOrigOp k mbKeyHash spendable delegetable m ops g) :& r)+runInstrImpl _ IMPLICIT_ACCOUNT (VC (CvKeyHash k) :& r) =+  pure $ VContract (KeyAddress k) :& r+runInstrImpl _ NOW r = do+  ContractEnv{..} <- asks ieContractEnv+  pure $ VC (CvTimestamp ceNow) :& r+runInstrImpl _ AMOUNT r = do+  ContractEnv{..} <- asks ieContractEnv+  pure $ VC (CvMutez ceAmount) :& r+runInstrImpl _ BALANCE r = do+  ContractEnv{..} <- asks ieContractEnv+  pure $ VC (CvMutez ceBalance) :& r+runInstrImpl _ CHECK_SIGNATURE (VKey k :& VSignature v :&+  VC (CvBytes b) :& r) = pure $ VC (CvBool $ checkSignature k v b) :& r+runInstrImpl _ SHA256 (VC (CvBytes b) :& r) = pure $ VC (CvBytes $ sha256 b) :& r+runInstrImpl _ SHA512 (VC (CvBytes b) :& r) = pure $ VC (CvBytes $ sha512 b) :& r+runInstrImpl _ BLAKE2B (VC (CvBytes b) :& r) = pure $ VC (CvBytes $ blake2b b) :& r+runInstrImpl _ HASH_KEY (VKey k :& r) = pure $ VC (CvKeyHash $ hashKey k) :& r+runInstrImpl _ STEPS_TO_QUOTA r = do+  RemainingSteps x <- gets isRemainingSteps+  pure $ VC (CvNat $ (fromInteger . toInteger) x) :& r+runInstrImpl _ SOURCE r = do+  ContractEnv{..} <- asks ieContractEnv+  pure $ VC (CvAddress ceSource) :& r+runInstrImpl _ SENDER r = do+  ContractEnv{..} <- asks ieContractEnv+  pure $ VC (CvAddress ceSender) :& r+runInstrImpl _ ADDRESS (VContract a :& r) = pure $ VC (CvAddress a) :& r++-- | Evaluates an arithmetic operation and either fails or proceeds.+runArithOp+  :: ArithOp aop n m+  => proxy aop+  -> CVal n+  -> CVal m+  -> EvalOp s (Val instr ('Tc (ArithRes aop n m)))+runArithOp op l r = case evalOp op l r of+  Left  err -> throwError (MichelsonArithError err)+  Right res -> pure (VC res)++createOrigOp+  :: (SingI param, SingI store, ConversibleExt)+  => KeyHash+  -> Maybe (Val Instr ('Tc 'U.CKeyHash))+  -> Bool -> Bool -> Mutez+  -> Contract param store+  -> Val Instr t+  -> U.OriginationOperation+createOrigOp k mbKeyHash delegetable spendable m contract g =+  U.OriginationOperation+    { ooManager = k+    , ooDelegate = (unwrapMbKeyHash mbKeyHash)+    , ooSpendable = spendable+    , ooDelegatable = delegetable+    , ooBalance = m+    , ooStorage = unsafeValToValue g+    , ooContract = convertContract contract+    }++unwrapMbKeyHash :: Maybe (Val Instr ('Tc 'U.CKeyHash)) -> Maybe KeyHash+unwrapMbKeyHash (Just (VC (CvKeyHash keyHash))) = Just keyHash+unwrapMbKeyHash Nothing = Nothing
+ src/Michelson/TypeCheck.hs view
@@ -0,0 +1,14 @@+module Michelson.TypeCheck+  ( typeCheckContract+  , typeCheckVal+  , typeCheckList+  , typeCheckCVal+  , module M+  , eqT'+  ) where++import Michelson.TypeCheck.Instr+import Michelson.TypeCheck.Types as M+import Michelson.TypeCheck.Value++import Michelson.TypeCheck.Helpers (eqT')
+ src/Michelson/TypeCheck/Helpers.hs view
@@ -0,0 +1,391 @@+module Michelson.TypeCheck.Helpers+    ( onLeft+    , deriveSpecialVN+    , deriveSpecialFNs+    , deriveVN+    , deriveNsOr+    , deriveNsOption+    , convergeHSTEl+    , convergeHST++    , eqT'+    , assertEqT+    , checkEqT+    , typeCheckInstrErr+    , typeCheckInstrErrM+    , typeCheckImpl++    , memImpl+    , getImpl+    , updImpl+    , sliceImpl+    , concatImpl+    , concatImpl'+    , sizeImpl+    , arithImpl+    , addImpl+    , subImpl+    , mulImpl+    , edivImpl+    , compareImpl+    , unaryArithImpl+    ) where++import Prelude hiding (EQ, GT, LT)++import Control.Monad.Except (liftEither, throwError)+import Data.Default (def)+import Data.Singletons (SingI(sing))+import qualified Data.Text as T+import Data.Typeable ((:~:)(..), eqT, typeRep)++import Michelson.TypeCheck.Types+import Michelson.Typed+  (CT(..), Instr(..), Notes(..), Notes'(..), Sing(..), T(..), converge, mkNotes, notesCase, orAnn)+import Michelson.Typed.Arith (Add, ArithOp(..), Compare, Mul, Sub, UnaryArithOp(..))+import Michelson.Typed.Polymorphic+  (ConcatOp, EDivOp(..), GetOp(..), MemOp(..), SizeOp, SliceOp, UpdOp(..))++import qualified Michelson.Untyped as Un+import Michelson.Untyped.Annotation (FieldAnn, VarAnn)++-- | Function which derives special annotations+-- for PAIR instruction.+--+-- Namely, it does following transformation:+-- @+--  PAIR %@@ %@@ [ @@p.a int : @@p.b int : .. ]+--  ~+--  [ @@p (pair (int %a) (int %b) : .. ]+-- @+--+-- All relevant cases (e.g. @PAIR %myf %@@ @)+-- are handled as they should be according to spec.+deriveSpecialFNs+  :: FieldAnn -> FieldAnn+  -> VarAnn -> VarAnn+  -> (VarAnn, FieldAnn, FieldAnn)+deriveSpecialFNs "@" "@" (Un.Annotation pvn) (Un.Annotation qvn) = (vn, pfn, qfn)+  where+    ps = T.splitOn "." pvn+    qs = T.splitOn "." qvn+    fns = fst <$> takeWhile (\(a, b) -> a == b) (zip ps qs)+    vn = Un.Annotation $ T.intercalate "." fns+    pfn = Un.Annotation $ T.intercalate "." $ drop (length fns) ps+    qfn = Un.Annotation $ T.intercalate "." $ drop (length fns) qs+deriveSpecialFNs "@" qfn pvn _   = (def, Un.convAnn pvn, qfn)+deriveSpecialFNs pfn "@" _ qvn   = (def, pfn, Un.convAnn qvn)+deriveSpecialFNs pfn qfn _ _     = (def, pfn, qfn)++-- | Function which derives special annotations+-- for CDR / CAR instructions.+deriveSpecialVN :: VarAnn -> FieldAnn -> VarAnn -> VarAnn+deriveSpecialVN vn elFn pairVN+  | vn == "%" = Un.convAnn elFn+  | vn == "%%" && elFn /= def = pairVN <> Un.convAnn elFn+  | otherwise = vn++-- | Append suffix to variable annotation (if it's not empty)+deriveVN :: VarAnn -> VarAnn -> VarAnn+deriveVN suffix vn = bool (suffix <> vn) def (vn == def)++-- | Function which extracts annotations for @or@ type+-- (for left and right parts).+--+-- It extracts field/type annotations and also auto-generates variable+-- annotations if variable annotation is not provided as second argument.+deriveNsOr :: Notes ('TOr a b) -> VarAnn -> (Notes a, Notes b, VarAnn, VarAnn)+deriveNsOr ons ovn =+  let (an, bn, afn, bfn) =+        notesCase (NStar, NStar, def, def)+          (\(NTOr _ afn_ bfn_ an_ bn_) -> (an_, bn_, afn_, bfn_)) ons+      avn = deriveVN (Un.convAnn afn `orAnn` "left") ovn+      bvn = deriveVN (Un.convAnn bfn `orAnn` "right") ovn+   in (an, bn, avn, bvn)++-- | Function which extracts annotations for @option t@ type.+--+-- It extracts field/type annotations and also auto-generates variable+-- annotation for @Some@ case if it is not provided as second argument.+deriveNsOption :: Notes ('TOption a) -> VarAnn -> (Notes a, VarAnn)+deriveNsOption ons ovn =+  let (an, fn) = notesCase (NStar, def)+                    (\(NTOption _ fn_ an_) -> (an_, fn_)) ons+      avn = deriveVN (Un.convAnn fn `orAnn` "some") ovn+   in (an, avn)++convergeHSTEl+  :: (Sing t, Notes t, VarAnn)+  -> (Sing t, Notes t, VarAnn)+  -> Either Text (Sing t, Notes t, VarAnn)+convergeHSTEl (at, an, avn) (_, bn, bvn) =+  (,,) at <$> converge an bn+          <*> pure (bool def avn $ avn == bvn)++-- | Combine annotations from two given stack types+convergeHST :: HST ts -> HST ts -> Either Text (HST ts)+convergeHST SNil SNil = pure SNil+convergeHST (a ::& as) (b ::& bs) =+    liftA2 (::&) (convergeHSTEl a b) (convergeHST as bs)++-- TODO move to Util module+onLeft :: Either a c -> (a -> b) -> Either b c+onLeft = flip first++--------------------------------------------+-- Typechecker auxiliary+--------------------------------------------++checkEqT+  :: forall a b ts . (Typeable a, Typeable b, Typeable ts)+  => Un.Instr+  -> HST ts+  -> Text+  -> Either TCError (a :~: b)+checkEqT instr i m =+  eqT' @a @b `onLeft` (TCFailedOnInstr instr (SomeHST i) . ((m <> ": ") <>))++assertEqT+  :: forall a b ts . (Typeable a, Typeable b, Typeable ts)+  => Un.Instr+  -> HST ts+  -> Either TCError (a :~: b)+assertEqT instr i = checkEqT instr i "unexpected"++-- | Function @eqT'@ is a simple wrapper around @Data.Typeable.eqT@ suited+-- for use within @Either Text a@ applicative.+eqT' :: forall a b . (Typeable a, Typeable b) => Either Text (a :~: b)+eqT' = maybe (Left $+                "types not equal: "+                  <> show (typeRep (Proxy @a))+                  <> " /= "+                  <> show (typeRep (Proxy @b))+                  ) pure eqT++typeCheckInstrErr :: Un.Instr -> SomeHST -> Text -> Either TCError a+typeCheckInstrErr = Left ... TCFailedOnInstr++typeCheckInstrErrM :: Un.Instr -> SomeHST -> Text -> TypeCheckT a+typeCheckInstrErrM = throwError ... TCFailedOnInstr++typeCheckImpl+  :: TcInstrHandler+  -> [Un.Instr]+  -> SomeHST+  -> TypeCheckT SomeInstr+typeCheckImpl tcInstr [a] t = tcInstr a t+typeCheckImpl tcInstr (p_ : (r : rs)) (SomeHST (a :: HST a)) = do+  tcInstr p_ (SomeHST a) >>= \case+    p ::: ((_ :: HST a'), (b :: HST b)) ->+      typeCheckImpl tcInstr (r : rs) (SomeHST b) >>= \case+        q ::: ((_ :: HST b'), c) -> do+          Refl <- liftEither $ eqT' @a @a' `onLeft` TCOtherError+          Refl <- liftEither $ eqT' @b @b' `onLeft` TCOtherError+          pure $ (Seq p q) ::: (a, c)+        SiFail -> pure SiFail+    SiFail -> pure SiFail+typeCheckImpl _ [] (SomeHST s) = pure $ Nop ::: (s, s)++--------------------------------------------+-- Some generic instruction implementation+--------------------------------------------++-- | Generic implementation for MEMeration+memImpl+  :: forall (q :: CT) (c :: T) ts .+    (Typeable ts, Typeable q, Typeable (MemOpKey c), MemOp c)+  => Un.Instr+  -> HST ('Tc q ': c ': ts)+  -> VarAnn+  -> TcResult+memImpl instr i@(_ ::& _ ::& rs) vn =+  case eqT' @q @(MemOpKey c) of+    Right Refl -> pure (MEM ::: (i, (STc SCBool, NStar, vn) ::& rs))+    Left m     -> typeCheckInstrErr instr (SomeHST i) $+                "query element type is not equal to set's element type: " <> m++getImpl+  :: forall c getKey rs .+    ( GetOp c, Typeable (GetOpKey c)+    , Typeable (GetOpVal c)+    , SingI (GetOpVal c)+    )+  => Un.Instr+  -> HST (getKey ': c ': rs)+  -> Sing (GetOpVal c)+  -> Notes (GetOpVal c)+  -> VarAnn+  -> TcResult+getImpl instr i@(_ ::& _ ::& rs) rt vns vn = do+  case eqT' @getKey @('Tc (GetOpKey c)) of+    Right Refl -> do+      let rn = mkNotes $ NTOption def def vns+      pure $ GET ::: (i, (STOption rt, rn, vn) ::& rs)+    Left m -> typeCheckInstrErr instr (SomeHST i) $+                    "wrong key stack type" <> m++updImpl+  :: forall c updKey updParams rs .+    (UpdOp c, Typeable (UpdOpKey c), Typeable (UpdOpParams c))+  => Un.Instr+  -> HST (updKey ': updParams ': c ': rs)+  -> TcResult+updImpl instr i@(_ ::& _ ::& crs) = do+  case (eqT' @updKey @('Tc (UpdOpKey c)), eqT' @updParams @(UpdOpParams c)) of+    (Right Refl, Right Refl) -> pure $ UPDATE ::: (i, crs)+    (Left m, _) -> typeCheckInstrErr instr (SomeHST i) $+                      "wrong key stack type" <> m+    (_, Left m) -> typeCheckInstrErr instr (SomeHST i) $+                      "wrong update value stack type" <> m++sizeImpl+  :: SizeOp c+  => HST (c ': rs)+  -> VarAnn+  -> TcResult+sizeImpl i@(_ ::& rs) vn =+  pure $ SIZE ::: (i, (STc SCNat, NStar, vn) ::& rs)++sliceImpl+  :: (SliceOp c, Typeable c)+  => HST ('Tc 'CNat : 'Tc 'CNat : c : rs)+  -> Un.VarAnn+  -> TcResult+sliceImpl i@(_ ::& _ ::& (c, cn, cvn) ::& rs) vn = do+  let vn' = vn `orAnn` deriveVN "slice" cvn+      rn = mkNotes $ NTOption def def cn+  pure $ SLICE ::: (i, (STOption c, rn, vn') ::& rs)++concatImpl'+  :: (ConcatOp c, Typeable c)+  => HST ('TList c : rs)+  -> Un.VarAnn+  -> TcResult+concatImpl' i@((STList c, ln, _) ::& rs) vn = do+  let cn = notesCase NStar (\(NTList _ n) -> n) ln+  pure $ CONCAT' ::: (i, (c, cn, vn) ::& rs)++concatImpl+  :: (ConcatOp c, Typeable c)+  => HST (c : c : rs)+  -> Un.VarAnn+  -> TcResult+concatImpl i@((c, cn1, _) ::& (_, cn2, _) ::& rs) vn = do+  cn <- converge cn1 cn2 `onLeft` TCFailedOnInstr (Un.CONCAT vn) (SomeHST i)+  pure $ CONCAT ::: (i, (c, cn, vn) ::& rs)++-- | Helper function to construct instructions for binary arithmetic+--erations.+arithImpl+  :: ( Typeable (ArithRes aop n m)+     , SingI (ArithRes aop n m)+     , Typeable ('Tc (ArithRes aop n m) ': s)+     )+  => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes aop n m) ': s)+  -> HST ('Tc n ': 'Tc m ': s)+  -> VarAnn+  -> TcResult+arithImpl mkInstr i@(_ ::& _ ::& rs) vn =+  pure $ mkInstr ::: (i, (sing, NStar, vn) ::& rs)++addImpl+  :: (Typeable rs, Typeable a, Typeable b)+  => Sing a -> Sing b+  -> HST ('Tc a ': 'Tc b ': rs)+  -> VarAnn+  -> TcResult+addImpl SCInt SCInt = arithImpl @Add ADD+addImpl SCInt SCNat = arithImpl @Add ADD+addImpl SCNat SCInt = arithImpl @Add ADD+addImpl SCNat SCNat = arithImpl @Add ADD+addImpl SCInt SCTimestamp = arithImpl @Add ADD+addImpl SCTimestamp SCInt = arithImpl @Add ADD+addImpl SCMutez SCMutez = arithImpl @Add ADD+addImpl _ _ = \i vn -> typeCheckInstrErr (Un.ADD vn) (SomeHST i) ""++edivImpl+  :: (Typeable rs, Typeable a, Typeable b)+  => Sing a -> Sing b+  -> HST ('Tc a ': 'Tc b ': rs)+  -> VarAnn+  -> TcResult+edivImpl SCInt SCInt = edivImplDo+edivImpl SCInt SCNat = edivImplDo+edivImpl SCNat SCInt = edivImplDo+edivImpl SCNat SCNat = edivImplDo+edivImpl SCMutez SCMutez = edivImplDo+edivImpl SCMutez SCNat = edivImplDo+edivImpl _ _ = \i vn -> typeCheckInstrErr (Un.EDIV vn) (SomeHST i) ""++edivImplDo+  :: ( EDivOp n m+     , SingI (EModOpRes n m)+     , Typeable (EModOpRes n m)+     , SingI (EDivOpRes n m)+     , Typeable (EDivOpRes n m)+     )+  => HST ('Tc n ': 'Tc m ': s)+  -> VarAnn+  -> TcResult+edivImplDo i@(_ ::& _ ::& rs) vn =+  pure $ EDIV ::: (i, (sing, NStar, vn) ::& rs)++subImpl+  :: (Typeable rs, Typeable a, Typeable b)+  => Sing a -> Sing b+  -> HST ('Tc a ': 'Tc b ': rs)+  -> VarAnn+  -> TcResult+subImpl SCInt SCInt = arithImpl @Sub SUB+subImpl SCInt SCNat = arithImpl @Sub SUB+subImpl SCNat SCInt = arithImpl @Sub SUB+subImpl SCNat SCNat = arithImpl @Sub SUB+subImpl SCTimestamp SCTimestamp = arithImpl @Sub SUB+subImpl SCTimestamp SCInt = arithImpl @Sub SUB+subImpl SCMutez SCMutez = arithImpl @Sub SUB+subImpl _ _ = \i vn -> typeCheckInstrErr (Un.SUB vn) (SomeHST i) ""++mulImpl+  :: (Typeable rs, Typeable a, Typeable b)+  => Sing a -> Sing b+  -> HST ('Tc a ': 'Tc b ': rs)+  -> VarAnn+  -> TcResult+mulImpl SCInt SCInt = arithImpl @Mul MUL+mulImpl SCInt SCNat = arithImpl @Mul MUL+mulImpl SCNat SCInt = arithImpl @Mul MUL+mulImpl SCNat SCNat = arithImpl @Mul MUL+mulImpl SCNat SCMutez = arithImpl @Mul MUL+mulImpl SCMutez SCNat = arithImpl @Mul MUL+mulImpl _ _ = \i vn -> typeCheckInstrErr (Un.MUL vn) (SomeHST i) ""++compareImpl+  :: (Typeable rs, Typeable a, Typeable b)+  => Sing a -> Sing b+  -> HST ('Tc a ': 'Tc b ': rs)+  -> VarAnn+  -> TcResult+compareImpl SCBool SCBool = arithImpl @Compare COMPARE+compareImpl SCNat SCNat = arithImpl @Compare COMPARE+compareImpl SCAddress SCAddress = arithImpl @Compare COMPARE+compareImpl SCInt SCInt = arithImpl @Compare COMPARE+compareImpl SCString SCString = arithImpl @Compare COMPARE+compareImpl SCBytes SCBytes = arithImpl @Compare COMPARE+compareImpl SCTimestamp SCTimestamp = arithImpl @Compare COMPARE+compareImpl SCKeyHash SCKeyHash = arithImpl @Compare COMPARE+compareImpl SCMutez SCMutez = arithImpl @Compare COMPARE+compareImpl _ _ = \i vn -> typeCheckInstrErr (Un.COMPARE vn) (SomeHST i) ""++-- | Helper function to construct instructions for binary arithmetic+--erations.+unaryArithImpl+  :: ( Typeable (UnaryArithRes aop n)+     , SingI (UnaryArithRes aop n)+     , Typeable ('Tc (UnaryArithRes aop n) ': s)+     )+  => Instr ('Tc n ': s) ('Tc (UnaryArithRes aop n) ': s)+  -> HST ('Tc n ': s)+  -> VarAnn+  -> TcResult+unaryArithImpl mkInstr i@(_ ::& rs) vn =+  pure $ mkInstr ::: (i, (sing, NStar, vn) ::& rs)
+ src/Michelson/TypeCheck/Instr.hs view
@@ -0,0 +1,807 @@+-- | Module, providing functions for conversion from+-- instruction and value representation from @Michelson.Type@ module+-- to strictly-typed GADT-based representation from @Michelson.Value@ module.+--+-- This conversion is labeled as type check because that's what we are obliged+-- to do on our way.+--+-- Type check algorithm relies on the property of Michelson language that each+-- instruction on a given input stack type produces a definite output stack+-- type.+-- Michelson contract defines concrete types for storage and parameter, from+-- which input stack type is deduced. Then this type is being combined with+-- each subsequent instruction, producing next stack type after each+-- application.+--+-- Function @typeCheck@ takes list of instructions and returns value of type+-- @Instr inp out@ along with @HST inp@ and @HST out@ all wrapped into+-- @SomeInstr@ data type. This wrapping is done to satsify Haskell type+-- system (which has no support for dependent types).+-- Functions @typeCheckInstr@, @typeCheckVal@ behave similarly.+--+-- When a recursive call is made within @typeCheck@, @typeCheckInstr@ or+-- @typeCheckVal@, result of a call is unwrapped from @SomeInstr@ and type+-- information from @HST inp@ and @HST out@ is being used to assert that+-- recursive call returned instruction of expected type+-- (error is thrown otherwise).+module Michelson.TypeCheck.Instr+    ( typeCheckContract+    , typeCheckVal+    , typeCheckList+    ) where++import Prelude hiding (EQ, GT, LT)++import Control.Monad.Except (liftEither, throwError, withExceptT)+import Data.Default (def)+import Data.Singletons (SingI(sing))+import Data.Typeable ((:~:)(..))++import Michelson.TypeCheck.Helpers+import Michelson.TypeCheck.Types+import Michelson.TypeCheck.Value+import Michelson.Typed+  (Abs, And, CT(..), Contract, ContractInp, ContractOut, Eq', Ge, Gt, Instr(..), IterOp(..), Le,+  Lsl, Lsr, Lt, MapOp(..), Neg, Neq, Not, Notes(..), Notes'(..), Or, Sing(..), T(..), Val(..), Xor,+  converge, convergeAnns, extractNotes, fromUType, mkNotes, notesCase, orAnn, withSomeSingCT,+  withSomeSingT, ( # ))++import qualified Michelson.Untyped as Un+import Michelson.Untyped.Annotation (VarAnn)++typeCheckContract+  :: ExtC+  => TcExtHandler+  -> Un.Contract Un.Instr+  -> Either TCError SomeContract+typeCheckContract nh c = runTypeCheckT nh (Un.para c) $ typeCheckContractImpl c++typeCheckContractImpl+  :: ExtC+  => Un.Contract Un.Instr+  -> TypeCheckT SomeContract+typeCheckContractImpl (Un.Contract mParam mStorage pCode) = do+  code <- maybe (throwError $ TCOtherError "no instructions in contract code")+                pure (nonEmpty pCode)+  withSomeSingT (fromUType mParam) $ \(paramS :: Sing param) ->+    withSomeSingT (fromUType mStorage) $ \(storageS :: Sing st) -> do+      storageNote <-+        liftEither $ extractNotes mStorage storageS `onLeft` \m -> TCOtherError $+                        "failed to extract annotations for storage: " <> m+      paramNote <-+        liftEither $ extractNotes mParam paramS `onLeft` \m -> TCOtherError $+                        "failed to extract annotations for parameter: " <> m+      let inpNote = mkNotes (NTPair def def def paramNote storageNote)+      let inp = (STPair paramS storageS, inpNote, def) ::& SNil+      typeCheckNE code (SomeHST inp) >>= \case+        SiFail -> do+          let outNote = mkNotes (NTPair def def def NStar storageNote)+              out = (STPair (STList STOperation) storageS, outNote, def)+                      ::& SNil+          pure $ SomeContract (FAILWITH :: Instr (ContractInp param st) (ContractOut st)) inp out+        instr ::: ((inp' :: HST inp), (out :: HST out)) -> do+          let mkIErr m = TCOtherError $+                          "contract input type violates convention: " <> m+          let mkOErr m = TCOtherError $+                          "contract output type violates convention: " <> m+          liftEither $ do+            Refl <- eqT' @out @(ContractOut st) `onLeft` mkOErr+            Refl <- eqT' @inp @(ContractInp param st) `onLeft` mkIErr+            let outN = outNotes out+            _ <- converge outN (N $ NTPair def def def NStar storageNote)+                    `onLeft` mkOErr+            pure $ SomeContract instr inp' out+  where+    outNotes :: HST '[o] -> Notes o+    outNotes ((_, n, _) ::& SNil) = n++-- | Like 'typeCheck', but for non-empty lists.+typeCheckNE+  :: ExtC+  => NonEmpty Un.Instr+  -> SomeHST+  -> TypeCheckT SomeInstr+typeCheckNE (x :| xs) = typeCheckImpl typeCheckInstr (x : xs)++-- | Function @typeCheckList@ converts list of Michelson instructions+-- given in representation from @Michelson.Type@ module to representation+-- in strictly typed GADT.+--+-- Types are checked along the way which is neccessary to construct a+-- strictly typed value.+--+-- As a second argument, @typeCheckList@ accepts input stack type representation.+typeCheckList+  :: ExtC+  => [Un.Instr]+  -> SomeHST+  -> TypeCheckT SomeInstr+typeCheckList = typeCheckImpl typeCheckInstr++-- | Function @typeCheckVal@ converts a single Michelson value+-- given in representation from @Michelson.Type@ module to representation+-- in strictly typed GADT.+--+-- As a second argument, @typeCheckVal@ accepts expected type of value.+--+-- Type checking algorithm pattern-matches on parse value representation,+-- expected type @t@ and constructs @Val t@ value.+--+-- If there was no match on a given pair of value and expected type,+-- that is interpreted as input of wrong type and type check finishes with+-- error.+typeCheckVal+  :: ExtC+  => Un.Value Un.Op+  -> T+  -> TypeCheckT SomeVal+typeCheckVal = typeCheckValImpl typeCheckInstr++-- | Function @typeCheckInstr@ converts a single Michelson instruction+-- given in representation from @Michelson.Type@ module to representation+-- in strictly typed GADT.+--+-- As a second argument, @typeCheckInstr@ accepts input stack type representation.+--+-- Type checking algorithm pattern-matches on given instruction, input stack+-- type and constructs strictly typed GADT value, checking necessary type+-- equalities when neccessary.+--+-- If there was no match on a given pair of instruction and input stack,+-- that is interpreted as input of wrong type and type check finishes with+-- error.+typeCheckInstr+  :: ExtC+  => TcInstrHandler++typeCheckInstr (Un.EXT ext) si@(SomeHST it) = do+  nh <- gets tcExtHandler+  nfs <- gets tcExtFrames+  (nfs', res) <- nh ext nfs si+  modify $ \te -> te {tcExtFrames = nfs'}+  case res of+    Just tExt -> pure $ Ext tExt ::: (it, it)+    Nothing   -> pure $ Nop ::: (it, it)++typeCheckInstr Un.DROP (SomeHST i@(_ ::& rs)) = pure (DROP ::: (i, rs))++typeCheckInstr (Un.DUP _vn) (SomeHST i@(a ::& rs)) =+  pure (DUP ::: (i, (a ::& a::& rs)))++typeCheckInstr Un.SWAP (SomeHST i@(a ::& b ::& rs)) =+  pure (SWAP ::: (i, b ::& a ::& rs))++typeCheckInstr instr@(Un.PUSH vn mt mval) (SomeHST i) = do+  val :::: (t, n) <- typeCheckVal mval (fromUType mt)+  notes <- liftEither $ (extractNotes mt t >>= converge n)+              `onLeft` TCFailedOnInstr instr (SomeHST i)+  pure $ PUSH val ::: (i, (t, notes, vn) ::& i)++typeCheckInstr (Un.SOME tn vn fn) (SomeHST i@((at, an, _) ::& rs)) = do+  let n = mkNotes (NTOption tn fn an)+  pure (SOME ::: (i, (STOption at, n, vn) ::& rs))++typeCheckInstr instr@(Un.NONE tn vn fn elMt) (SomeHST i) = do+  withSomeSingT (fromUType elMt) $ \elT -> do+    let t = STOption elT+    notes <- liftEither $ extractNotes (Un.Type (Un.TOption fn elMt) tn) t+              `onLeft` TCFailedOnInstr instr (SomeHST i)+    pure $ NONE ::: (i, (t, notes, vn) ::& i)++typeCheckInstr (Un.UNIT tn vn) (SomeHST i) = do+  let ns = mkNotes $ NTUnit tn+  pure $ UNIT ::: (i, (STUnit, ns, vn) ::& i)++typeCheckInstr (Un.IF_NONE mp mq) (SomeHST i@((STOption a, ons, ovn) ::& rs) ) = do+  let (an, avn) = deriveNsOption ons ovn+  genericIf IF_NONE Un.IF_NONE mp mq rs ((a, an, avn) ::& rs) i++typeCheckInstr (Un.PAIR tn vn pfn qfn) (SomeHST i@((a, an, avn) ::&+                                             (b, bn, bvn) ::& rs)) = do+  let (vn', pfn', qfn') = deriveSpecialFNs pfn qfn avn bvn+      ns = mkNotes $ NTPair tn pfn' qfn' an bn+  pure (PAIR ::: (i, (STPair a b, ns, vn `orAnn` vn') ::& rs))++typeCheckInstr (Un.CAR vn _) (SomeHST i@((STPair a _, NStar, _) ::& rs)) =+  pure (CAR ::: (i, (a, NStar, vn) ::& rs))+typeCheckInstr instr@(Un.CAR vn fn)+            (SomeHST i@(( STPair a b+                       , N (NTPair pairTN pfn qfn pns qns)+                       , pairVN ) ::& rs)) = do+  pfn' <- liftEither $ convergeAnns fn pfn+              `onLeft` TCFailedOnInstr instr (SomeHST i)+  let vn' = deriveSpecialVN vn pfn' pairVN+      i' = ( STPair a b+            , N (NTPair pairTN pfn' qfn pns qns)+            , pairVN ) ::& rs+  pure $ CAR ::: (i', (a, pns, vn') ::& rs)++typeCheckInstr (Un.CDR vn _) (SomeHST i@((STPair _ b, NStar, _) ::& rs)) =+  pure (CDR ::: (i, (b, NStar, vn) ::& rs))+typeCheckInstr instr@(Un.CDR vn fn)+          (SomeHST i@(( STPair a b+                      , N (NTPair pairTN pfn qfn pns qns)+                      , pairVN ) ::& rs)) = do+  qfn' <- liftEither $ convergeAnns fn qfn+              `onLeft` TCFailedOnInstr instr (SomeHST i)+  let vn' = deriveSpecialVN vn qfn' pairVN+      i' = ( STPair a b+            , N (NTPair pairTN pfn qfn' pns qns)+            , pairVN ) ::& rs+  pure $ CDR ::: (i', (b, qns, vn') ::& rs)++typeCheckInstr instr@(Un.LEFT tn vn pfn qfn bMt) (SomeHST i@((a, an, _) ::& rs)) =+  withSomeSingT (fromUType bMt) $ \b -> do+    bn <- liftEither $ extractNotes bMt b+              `onLeft` TCFailedOnInstr instr (SomeHST i)+    let ns = mkNotes $ NTOr tn pfn qfn an bn+    pure (LEFT ::: (i, (STOr a b, ns, vn) ::& rs))++typeCheckInstr instr@(Un.RIGHT tn vn pfn qfn aMt) (SomeHST i@((b, bn, _) ::& rs)) =+  withSomeSingT (fromUType aMt) $ \a -> do+    an <- liftEither $ extractNotes aMt a+              `onLeft` TCFailedOnInstr instr (SomeHST i)+    let ns = mkNotes $ NTOr tn pfn qfn an bn+    pure (RIGHT ::: (i, (STOr a b, ns, vn) ::& rs))++typeCheckInstr (Un.IF_LEFT mp mq) (SomeHST i@((STOr a b, ons, ovn) ::& rs) ) = do+  let (an, bn, avn, bvn) = deriveNsOr ons ovn+      ait = (a, an, avn) ::& rs+      bit = (b, bn, bvn) ::& rs+  genericIf IF_LEFT Un.IF_LEFT mp mq ait bit i++typeCheckInstr (Un.IF_RIGHT mq mp) (SomeHST i@((STOr a b, ons, ovn) ::& rs) ) = do+  let (an, bn, avn, bvn) = deriveNsOr ons ovn+      ait = (a, an, avn) ::& rs+      bit = (b, bn, bvn) ::& rs+  genericIf IF_RIGHT Un.IF_RIGHT mq mp bit ait i++typeCheckInstr instr@(Un.NIL tn vn elMt) (SomeHST i) =+  withSomeSingT (fromUType elMt) $ \elT -> liftEither $ do+    let t = STList elT+    notes <- extractNotes (Un.Type (Un.TList elMt) tn) t+              `onLeft` TCFailedOnInstr instr (SomeHST i)+    pure $ NIL ::: (i, (t, notes, vn) ::& i)++typeCheckInstr instr@(Un.CONS vn) (SomeHST i@(((at :: Sing a), an, _)+                              ::& (STList (_ :: Sing a'), ln, _) ::& rs)) =+  case eqT' @a @a' of+    Right Refl -> liftEither $  do+      n <- converge ln (mkNotes $ NTList def an)+              `onLeft` TCFailedOnInstr instr (SomeHST i)+      pure $ CONS ::: (i, (STList at, n, vn) ::& rs)+    Left m -> typeCheckInstrErrM instr (SomeHST i) $+                "list element type is different from one "+                <> "that is being CONSed: " <> m+++typeCheckInstr (Un.IF_CONS mp mq) (SomeHST i@((STList a, ns, vn) ::& rs) ) = do+  let an = notesCase NStar (\(NTList _ an_) -> an_) ns+      ait =+        (a, an, vn <> "hd") ::& (STList a, ns, vn <> "tl") ::& rs+  genericIf IF_CONS Un.IF_CONS mp mq ait rs i++typeCheckInstr (Un.SIZE vn) (SomeHST i@((STList _, _, _) ::& _) ) = liftEither $ sizeImpl i vn+typeCheckInstr (Un.SIZE vn) (SomeHST i@((STSet _, _, _) ::& _) ) = liftEither $ sizeImpl i vn+typeCheckInstr (Un.SIZE vn) (SomeHST i@((STMap _ _, _, _) ::& _) ) = liftEither $ sizeImpl i vn+typeCheckInstr (Un.SIZE vn) (SomeHST i@((STc SCString, _, _) ::& _) ) = liftEither $  sizeImpl i vn+typeCheckInstr (Un.SIZE vn) (SomeHST i@((STc SCBytes, _, _) ::& _) ) = liftEither $ sizeImpl i vn++typeCheckInstr (Un.EMPTY_SET tn vn (Un.Comparable mk ktn)) (SomeHST i) =+  withSomeSingCT mk $ \k ->+    pure $ EMPTY_SET ::: (i, (STSet k, mkNotes $ NTSet tn ktn, vn) ::& i)++typeCheckInstr instr@(Un.EMPTY_MAP tn vn (Un.Comparable mk ktn) mv) (SomeHST i) =+  withSomeSingT (fromUType mv) $ \v ->+  withSomeSingCT mk $ \k -> liftEither $ do+    vns <- extractNotes mv v+              `onLeft` TCFailedOnInstr instr (SomeHST i)+    let ns = mkNotes $ NTMap tn ktn vns+    pure $ EMPTY_MAP ::: (i, (STMap k v, ns, vn) ::& i)++typeCheckInstr instr@(Un.MAP vn mp) (SomeHST i@((STList v, ns, _vn) ::& rs) ) = do+  let vns = notesCase NStar (\(NTList _ v') -> v') ns+  typeCheckList (Un.unOp <$> mp)+                      (SomeHST $ (v, vns, def) ::& rs) >>= \case+    SiFail -> pure SiFail+    someInstr@(_ ::: (_, (out :: HST out))) ->+      case out of+        (_ :: Sing b, _, _) ::& _ ->+          mapImpl @b instr someInstr i+                  (\rt rn -> (::&) (STList rt, mkNotes $ NTList def rn, vn))+        _ -> liftEither $ typeCheckInstrErr instr (SomeHST i) $+              "iteration expression has wrong output stack type (empty stack)"++typeCheckInstr instr@(Un.MAP vn mp) (SomeHST i@((STMap k v, ns, _vn) ::& rs) ) = do+  let (kns, vns) = notesCase (def, NStar) (\(NTMap _ k' v') -> (k', v')) ns+      pns = mkNotes $ NTPair def def def (mkNotes $ NTc kns) vns+  typeCheckList (Un.unOp <$> mp)+                      (SomeHST $ ((STPair (STc k) v), pns, def) ::& rs) >>= \case+    SiFail -> pure SiFail+    someInstr@(_ ::: (_, (out :: HST out))) ->+      case out of+        (_ :: Sing b, _, _) ::& _ ->+          mapImpl @b instr someInstr i+                  (\rt rn -> (::&) (STMap k rt, mkNotes $ NTMap def kns rn, vn))+        _ -> liftEither $ typeCheckInstrErr instr (SomeHST i) $+              "iteration expression has wrong output stack type (empty stack)"++-- case `Un.HSTER []` is wrongly typed by definition+-- (as it is required to at least drop an element), so we don't consider it++typeCheckInstr instr@(Un.ITER (i1 : ir)) (SomeHST i@((STSet e, n, _) ::& _)) = do+  let en = notesCase NStar (\(NTSet _ en_) -> mkNotes $ NTc en_) n+  iterImpl (STc e) en instr (i1 :| ir) i+typeCheckInstr instr@(Un.ITER (i1 : ir)) (SomeHST i@((STList e, n, _) ::& _)) = do+  let en = notesCase NStar (\(NTList _ en_) -> en_) n+  iterImpl e en instr (i1 :| ir) i+typeCheckInstr instr@(Un.ITER (i1 : ir)) (SomeHST i@((STMap k v, n, _) ::& _)) = do+  let en = notesCase NStar (\(NTMap _ kns vns) ->+              mkNotes $ NTPair def def def (mkNotes $ NTc kns) vns) n+  iterImpl (STPair (STc k) v) en instr (i1 :| ir) i++typeCheckInstr instr@(Un.MEM vn)+           (SomeHST i@((STc _, _, _) ::& (STSet _, _, _) ::& _)) =+  liftEither $ memImpl instr i vn+typeCheckInstr instr@(Un.MEM vn)+           (SomeHST i@((STc _, _, _) ::& (STMap _ _, _, _) ::& _)) =+  liftEither $ memImpl instr i vn+typeCheckInstr instr@(Un.MEM vn)+           (SomeHST i@((STc _, _, _) ::& (STBigMap _ _, _, _) ::& _)) =+  liftEither $ memImpl instr i vn++typeCheckInstr instr@(Un.GET vn) (SomeHST i@(_ ::& (STMap _ vt, cn, _) ::& _)) =+  liftEither $ getImpl instr i vt (notesCase NStar (\(NTMap _ _ v) -> v) cn) vn+typeCheckInstr instr@(Un.GET vn) (SomeHST i@(_ ::& (STBigMap _ vt, cn, _) ::& _)) =+  liftEither $ getImpl instr i vt (notesCase NStar (\(NTBigMap _ _ v) -> v) cn) vn++typeCheckInstr instr@Un.UPDATE (SomeHST i@(_ ::& _ ::& (STMap _ _, _, _) ::& _)) =+  liftEither $ updImpl instr i+typeCheckInstr instr@Un.UPDATE (SomeHST i@(_ ::& _ ::& (STBigMap _ _, _, _)+                                             ::& _)) =+  liftEither $ updImpl instr i+typeCheckInstr instr@Un.UPDATE (SomeHST i@(_ ::& _ ::& (STSet _, _, _) ::& _)) =+  liftEither $ updImpl instr i++typeCheckInstr (Un.IF mp mq) (SomeHST i@((STc SCBool, _, _) ::& rs) ) =+  genericIf IF Un.IF mp mq rs rs i++typeCheckInstr instr@(Un.LOOP is)+           (SomeHST i@((STc SCBool, _, _) ::& (rs :: HST rs)) ) = do+  typeCheckList (fmap Un.unOp is) (SomeHST rs) >>= \case+    SiFail -> pure SiFail+    subI ::: ((_ :: HST rs'), (o :: HST o)) -> liftEither $ do+      Refl <- assertEqT @rs @rs' instr i+      case (eqT' @o @('Tc 'CBool ': rs), SomeHST o) of+        (Right Refl, SomeHST (_ ::& rs' :: HST o')) -> do+            Refl <- assertEqT @o @o' instr i+            pure $ LOOP subI ::: (i, rs')+        (Left m, _) ->+          typeCheckInstrErr instr (SomeHST i) $+                    "iteration expression has wrong output stack type: " <> m+        _ -> typeCheckInstrErr instr (SomeHST i) $+                        "iteration expression has wrong output stack type"++typeCheckInstr instr@(Un.LOOP_LEFT is)+           (SomeHST i@((STOr (at :: Sing a) (bt :: Sing b), ons, ovn)+                      ::& (rs :: HST rs)) ) = do+  let (an, bn, avn, bvn) = deriveNsOr ons ovn+      ait = (at, an, avn) ::& rs+  typeCheckList (fmap Un.unOp is) (SomeHST ait) >>= \case+    SiFail -> pure SiFail+    subI ::: ((_ :: HST rs'), (o :: HST o)) -> liftEither $ do+      Refl <- assertEqT @(a ': rs) @rs' instr i+      case (eqT' @o @('TOr a b ': rs), SomeHST o) of+        (Right Refl, SomeHST ((STOr _ bt', ons', ovn') ::& rs' :: HST o')) -> do+            Refl <- assertEqT @o @o' instr i+            let (_, bn', _, bvn') = deriveNsOr ons' ovn'+            br <- convergeHSTEl (bt, bn, bvn) (bt', bn', bvn')+                    `onLeft` TCFailedOnInstr instr (SomeHST i)+            pure $ LOOP_LEFT subI ::: (i, br ::& rs')+        (Left m, _) -> typeCheckInstrErr instr (SomeHST i) $+                        "iteration expression has wrong output stack type: " <> m+        _ -> typeCheckInstrErr instr (SomeHST i) $+                        "iteration expression has wrong output stack type"++typeCheckInstr instr@(Un.LAMBDA vn imt omt is) (SomeHST i) = do+  withSomeSingT (fromUType imt) $ \(it :: Sing it) -> do+    withSomeSingT (fromUType omt) $ \(ot :: Sing ot) -> do+      ins <- liftEither $ extractNotes imt it+              `onLeft` TCFailedOnInstr instr (SomeHST i)+      ons <- liftEither $ extractNotes omt ot+              `onLeft` TCFailedOnInstr instr (SomeHST i)+      -- further processing is extracted into another function because+      -- otherwise I encountered some weird GHC error with that code+      -- located right here+      lamImpl instr is vn it ins ot ons i++typeCheckInstr instr@(Un.EXEC vn) (SomeHST i@(((_ :: Sing t1), _, _)+                              ::& (STLambda (_ :: Sing t1') t2, ln, _)+                              ::& rs)) = do+  let t2n = notesCase NStar (\(NTLambda _ _ n) -> n) ln+  case eqT' @t1 @t1' of+    Right Refl -> pure $ EXEC ::: (i, (t2, t2n, vn) ::& rs)+    Left m -> typeCheckInstrErrM instr (SomeHST i) $+                "lambda is given argument with wrong type: " <> m++typeCheckInstr instr@(Un.DIP is) (SomeHST i@(a ::& (s :: HST s))) =+  typeCheckList (fmap Un.unOp is) (SomeHST s) >>= \case+    SiFail -> pure SiFail+    subI ::: ((_ :: HST s'), t) -> liftEither $ do+      Refl <- assertEqT @s @s' instr i+      pure $ DIP subI ::: (i, a ::& t)++typeCheckInstr Un.FAILWITH _ = pure SiFail++typeCheckInstr instr@(Un.CAST vn mt)+           (SomeHST i@(((e :: Sing e), (en :: Notes e), evn) ::& rs)) =+  withSomeSingT (fromUType mt) $ \(_ :: Sing e') ->+    case eqT' @e @e' of+      Right Refl ->+        case extractNotes mt e of+          Right en' ->+            case converge en en' of+              Right ns ->+                pure $ CAST ::: (i, (e, ns, vn `orAnn` evn) ::& rs)+              Left m -> err m+          Left m -> err m+      Left m -> err m+    where+      err = \m -> typeCheckInstrErrM instr (SomeHST i) $+                  "cast to incompatible type: " <> m++typeCheckInstr (Un.RENAME vn) (SomeHST i@((at, an, _) ::& rs)) =+  pure $ RENAME ::: (i, (at, an, vn) ::& rs)++typeCheckInstr instr@(Un.UNPACK vn mt) (SomeHST i@((STc SCBytes, _, _) ::& rs)) =+  withSomeSingT (fromUType mt) $ \t -> liftEither $ do+    tns <- extractNotes mt t+            `onLeft` TCFailedOnInstr instr (SomeHST i)+    let ns = mkNotes $ NTOption def def tns+    pure $ UNPACK ::: (i, (STOption t, ns, vn) ::& rs)++typeCheckInstr (Un.PACK vn) (SomeHST i@(_ ::& rs)) =+  pure $ PACK ::: (i, (STc SCBytes, NStar, vn) ::& rs)++typeCheckInstr (Un.CONCAT vn) (SomeHST i@((STc SCBytes, _, _) ::&+                                    (STc SCBytes, _, _) ::& _)) =+  liftEither $ concatImpl i vn+typeCheckInstr (Un.CONCAT vn) (SomeHST i@((STc SCString, _, _) ::&+                                    (STc SCString, _, _) ::& _)) =+  liftEither $ concatImpl i vn+typeCheckInstr (Un.CONCAT vn) (SomeHST i@((STList (STc SCBytes), _, _) ::& _)) =+  liftEither $  concatImpl' i vn+typeCheckInstr (Un.CONCAT vn) (SomeHST i@((STList (STc SCString), _, _) ::& _)) =+  liftEither $ concatImpl' i vn+++typeCheckInstr (Un.SLICE vn) (SomeHST i@((STc SCNat, _, _) ::&+                                   (STc SCNat, _, _) ::&+                                   (STc SCString, _, _) ::& _)) =+  liftEither $ sliceImpl i vn+typeCheckInstr (Un.SLICE vn) (SomeHST i@((STc SCNat, _, _) ::&+                                   (STc SCNat, _, _) ::&+                                   (STc SCBytes, _, _) ::& _)) =+  liftEither $ sliceImpl i vn++typeCheckInstr (Un.ISNAT vn') (SomeHST i@((STc SCInt, _, oldVn) ::& rs)) = do+  let vn = vn' `orAnn` oldVn+  pure $ ISNAT ::: (i, (STOption (STc SCNat), NStar, vn) ::& rs)++typeCheckInstr (Un.ADD vn) (SomeHST i@((STc a, _, _) ::&+                                 (STc b, _, _) ::& _)) = liftEither $ addImpl a b i vn++typeCheckInstr (Un.SUB vn) (SomeHST i@((STc a, _, _) ::&+                                 (STc b, _, _) ::& _)) = liftEither $ subImpl a b i vn++typeCheckInstr (Un.MUL vn) (SomeHST i@((STc a, _, _) ::&+                                 (STc b, _, _) ::& _)) = liftEither $ mulImpl a b i vn++typeCheckInstr (Un.EDIV vn) (SomeHST i@((STc a, _, _) ::&+                                  (STc b, _, _) ::& _)) = liftEither $ edivImpl a b i vn++typeCheckInstr (Un.ABS vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Abs ABS i vn++typeCheckInstr Un.NEG (SomeHST i@((STc SCInt, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Neg NEG i def++typeCheckInstr (Un.LSL vn) (SomeHST i@((STc SCNat, _, _) ::&+                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @Lsl LSL i vn++typeCheckInstr (Un.LSR vn) (SomeHST i@((STc SCNat, _, _) ::&+                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @Lsr LSR i vn++typeCheckInstr (Un.OR vn) (SomeHST i@((STc SCBool, _, _) ::&+                         (STc SCBool, _, _) ::& _)) = liftEither $ arithImpl @Or OR i vn+typeCheckInstr (Un.OR vn) (SomeHST i@((STc SCNat, _, _) ::&+                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @Or OR i vn++typeCheckInstr (Un.AND vn) (SomeHST i@((STc SCInt, _, _) ::&+                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @And AND i vn+typeCheckInstr (Un.AND vn) (SomeHST i@((STc SCNat, _, _) ::&+                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @And AND i vn+typeCheckInstr (Un.AND vn) (SomeHST i@((STc SCBool, _, _) ::&+                         (STc SCBool, _, _) ::& _)) = liftEither $ arithImpl @And AND i vn++typeCheckInstr (Un.XOR vn) (SomeHST i@((STc SCBool, _, _) ::&+                         (STc SCBool, _, _) ::& _)) = liftEither $ arithImpl @Xor XOR i vn+typeCheckInstr (Un.XOR vn) (SomeHST i@((STc SCNat, _, _) ::&+                         (STc SCNat, _, _) ::& _)) = liftEither $ arithImpl @Xor XOR i vn++typeCheckInstr (Un.NOT vn) (SomeHST i@((STc SCNat, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Not NOT i vn+typeCheckInstr (Un.NOT vn) (SomeHST i@((STc SCBool, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Not NOT i vn+typeCheckInstr (Un.NOT vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Not NOT i vn++typeCheckInstr (Un.COMPARE vn) (SomeHST i@((STc a, _, _) ::&+                                 (STc b, _, _) ::& _)) = liftEither $ compareImpl a b i vn++typeCheckInstr (Un.EQ vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Eq' EQ i vn++typeCheckInstr (Un.NEQ vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Neq NEQ i vn++typeCheckInstr (Un.LT vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Lt LT i vn++typeCheckInstr (Un.GT vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Gt GT i vn++typeCheckInstr (Un.LE vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Le LE i vn++typeCheckInstr (Un.GE vn) (SomeHST i@((STc SCInt, _, _) ::& _)) =+  liftEither $ unaryArithImpl @Ge GE i vn++typeCheckInstr (Un.INT vn) (SomeHST i@((STc SCNat, _, _) ::& rs)) =+  pure $ INT ::: (i, (STc SCInt, NStar, vn) ::& rs)++typeCheckInstr instr@(Un.SELF vn) shst@(SomeHST i) = do+  cpType <- gets tcContractParam+  let t = fromUType cpType+  withSomeSingT t $ \(singcp :: Sing cp) -> do+    nt <- liftEither $ extractNotes cpType singcp `onLeft` TCFailedOnInstr instr shst+    pure $ SELF @cp ::: (i, (sing @('TContract cp), N (NTContract Un.noAnn nt), vn) ::& i)++typeCheckInstr instr@(Un.CONTRACT vn mt)+           (SomeHST i@((STc SCAddress, _, _) ::& rs)) =+  withSomeSingT (fromUType mt) $ \t -> liftEither $ do+    tns <- extractNotes mt t+            `onLeft` TCFailedOnInstr instr (SomeHST i)+    let ns = mkNotes $ NTOption def def $ mkNotes $ NTContract def tns+    pure $ CONTRACT ::: (i, (STOption $ STContract t, ns, vn) ::& rs)++typeCheckInstr instr@(Un.TRANSFER_TOKENS vn) (SomeHST i@(((_ :: Sing p'), _, _)+  ::& (STc SCMutez, _, _) ::& (STContract (_ :: Sing p), _, _) ::& rs)) = do+  case eqT' @p @p' of+    Right Refl ->+      pure $ TRANSFER_TOKENS ::: (i, (STOperation, NStar, vn) ::& rs)+    Left m ->+      typeCheckInstrErrM instr (SomeHST i) $ "mismatch of contract param type: " <> m++typeCheckInstr (Un.SET_DELEGATE vn)+           (SomeHST i@((STOption (STc SCKeyHash), _, _) ::& rs)) = do+  pure $ SET_DELEGATE ::: (i, (STOperation, NStar, vn) ::& rs)++typeCheckInstr (Un.CREATE_ACCOUNT ovn avn)+           (SomeHST i@((STc SCKeyHash, _, _)+             ::& (STOption (STc SCKeyHash), _, _) ::& (STc SCBool, _, _)+             ::& (STc SCMutez, _, _) ::& rs)) =+  pure $ CREATE_ACCOUNT ::: (i, (STOperation, NStar, ovn) ::&+                                 (STc SCAddress, NStar, avn) ::& rs)++typeCheckInstr instr@(Un.CREATE_CONTRACT ovn avn)+           (SomeHST i@((STc SCKeyHash, _, _)+             ::& (STOption (STc SCKeyHash), _, _)+             ::& (STc SCBool, _, _) ::& (STc SCBool, _, _)+             ::& (STc SCMutez, _, _)+             ::& (STLambda (STPair _ (_ :: Sing g1))+                   (STPair (STList STOperation) (_ :: Sing g2)), ln, _)+                        ::& ((_ :: Sing g3), gn3, _) ::& rs)) = do+  let (gn1, gn2) = notesCase (NStar, NStar)+                    (\(NTLambda _ l r) ->+                      (,) (notesCase NStar (\(NTPair _ _ _ _ n) -> n) l)+                          (notesCase NStar (\(NTPair _ _ _ _ n) -> n) r)) ln+  liftEither $ either (\m -> typeCheckInstrErr instr (SomeHST i) $+                  "mismatch of contract storage type: " <> m) pure $ do+    Refl <- eqT' @g1 @g2+    Refl <- eqT' @g2 @g3+    gn12 <- converge gn1 gn2+    _ <- converge gn12 gn3+    pure $ CREATE_CONTRACT ::: (i, (STOperation, NStar, ovn) ::&+                                     (STc SCAddress, NStar, avn) ::& rs)++typeCheckInstr instr@(Un.CREATE_CONTRACT2 ovn avn contract)+           (SomeHST i@((STc SCKeyHash, _, _)+             ::& (STOption (STc SCKeyHash), _, _)+             ::& (STc SCBool, _, _)+             ::& (STc SCBool, _, _)+             ::& (STc SCMutez, _, _)+             ::& ((_ :: Sing g), gn, _) ::& rs)) = do+  (SomeContract (contr :: Contract i' g') _ out) <-+      flip withExceptT (typeCheckContractImpl $ fmap Un.unOp contract)+                       (\err -> TCFailedOnInstr instr (SomeHST i)+                                    ("failed to type check contract: " <> show err))+  liftEither $ do+    Refl <- checkEqT @g @g' instr i "contract storage type mismatch"+    void $ converge gn (outNotes out) `onLeft` TCFailedOnInstr instr (SomeHST i)+    pure $ CREATE_CONTRACT2 contr ::: (i, (STOperation, NStar, ovn) ::&+                                          (STc SCAddress, NStar, avn) ::& rs)+  where+    outNotes :: HST '[ 'TPair ('TList 'TOperation) g' ] -> Notes g'+    outNotes ((_, n, _) ::& SNil) =+      notesCase NStar (\(NTPair _ _ _ _ n') -> n') n++typeCheckInstr (Un.IMPLICIT_ACCOUNT vn)+           (SomeHST i@((STc SCKeyHash, _, _) ::& rs)) =+  pure $ IMPLICIT_ACCOUNT ::: (i, (STContract STUnit, NStar, vn) ::& rs)++typeCheckInstr (Un.NOW vn) (SomeHST i) =+  pure $ NOW ::: (i, (STc SCTimestamp, NStar, vn) ::& i)++typeCheckInstr (Un.AMOUNT vn) (SomeHST i) =+  pure $ AMOUNT ::: (i, (STc SCMutez, NStar, vn) ::& i)++typeCheckInstr (Un.BALANCE vn) (SomeHST i) =+  pure $ BALANCE ::: (i, (STc SCMutez, NStar, vn) ::& i)++typeCheckInstr (Un.CHECK_SIGNATURE vn)+           (SomeHST i@((STKey, _, _)+             ::& (STSignature, _, _) ::& (STc SCBytes, _, _) ::& rs)) =+  pure $ CHECK_SIGNATURE ::: (i, (STc SCBool, NStar, vn) ::& rs)++typeCheckInstr (Un.SHA256 vn)+           (SomeHST i@((STc SCBytes, _, _) ::& rs)) =+  pure $ SHA256 ::: (i, (STc SCBytes, NStar, vn) ::& rs)++typeCheckInstr (Un.SHA512 vn)+           (SomeHST i@((STc SCBytes, _, _) ::& rs)) =+  pure $ SHA512 ::: (i, (STc SCBytes, NStar, vn) ::& rs)++typeCheckInstr (Un.BLAKE2B vn)+           (SomeHST i@((STc SCBytes, _, _) ::& rs)) =+  pure $ BLAKE2B ::: (i, (STc SCBytes, NStar, vn) ::& rs)++typeCheckInstr (Un.HASH_KEY vn)+           (SomeHST i@((STKey, _, _) ::& rs)) =+  pure $ HASH_KEY ::: (i, (STc SCKeyHash, NStar, vn) ::& rs)++typeCheckInstr (Un.STEPS_TO_QUOTA vn) (SomeHST i) =+  pure $ STEPS_TO_QUOTA ::: (i, (STc SCNat, NStar, vn) ::& i)++typeCheckInstr (Un.SOURCE vn) (SomeHST i) =+  pure $ SOURCE ::: (i, (STc SCAddress, NStar, vn) ::& i)++typeCheckInstr (Un.SENDER vn) (SomeHST i) =+  pure $ SENDER ::: (i, (STc SCAddress, NStar, vn) ::& i)++typeCheckInstr (Un.ADDRESS vn) (SomeHST i@((STContract _, _, _) ::& rs)) =+  pure $ ADDRESS ::: (i, (STc SCAddress, NStar, vn) ::& rs)++typeCheckInstr instr sit = typeCheckInstrErrM instr sit ""++-- | Helper function for two-branch if where each branch is given a single+-- value.+genericIf+  :: forall bti bfi cond rs .+    (Typeable bti, Typeable bfi, ExtC)+  => (forall s'.+        Instr bti s' ->+        Instr bfi s' ->+        Instr (cond ': rs) s'+     )+  -> ([Un.Op] -> [Un.Op] -> Un.Instr)+  -> [Un.Op]+  -> [Un.Op]+  -> HST bti+  -> HST bfi+  -> HST (cond ': rs)+  -> TypeCheckT SomeInstr+genericIf cons mCons mbt mbf bti bfi i@(_ ::& _) =+  liftA2 (,) (typeCheckList (Un.unOp <$> mbt) (SomeHST bti))+             (typeCheckList (Un.unOp <$> mbf) (SomeHST bfi)) >>= liftEither . \case+  (p ::: ((_ :: HST pi), (po :: HST po)), q ::: ((_ :: HST qi), (qo :: HST qo))) -> do+    Refl <- assertEqT @bti @pi instr i+    Refl <- assertEqT @bfi @qi instr i+    Refl <- checkEqT @qo @po instr i+                  "branches have different output stack types"+    o <- convergeHST po qo `onLeft` TCFailedOnInstr instr (SomeHST i)+    pure $ cons p q ::: (i, o)+  (SiFail, q ::: ((_ :: HST qi), (qo :: HST qo))) -> do+    Refl <- assertEqT @bfi @qi instr i+    -- TODO TM-27 There shall be no `PUSH VUnit`, rewrite this code+    pure $ cons (PUSH VUnit # FAILWITH) q ::: (i, qo)+  (p ::: ((_ :: HST pi), (po :: HST po)), SiFail) -> do+    Refl <- assertEqT @bti @pi instr i+    -- TODO TM-27 There shall be no `PUSH VUnit`, rewrite this code+    pure $ cons p (PUSH VUnit # FAILWITH) ::: (i, po)+  _ -> pure SiFail++  where+    instr = mCons mbt mbf++mapImpl+  :: forall b c rs .+  ( MapOp c b+  , Typeable b+  , Typeable (MapOpInp c)+  , Typeable (MapOpRes c b)+  )+  => Un.Instr+  -> SomeInstr+  -> HST (c ': rs)+  -> (forall v' . (Typeable v', SingI v') =>+        Sing v' -> Notes v' -> HST rs -> HST (MapOpRes c v' ': rs))+  -> TypeCheckT SomeInstr+mapImpl instr someInstr i@(_ ::& _) mkRes =+  case someInstr of+    SiFail -> pure SiFail+    sub ::: ((_ :: HST subi), (subo :: HST subo)) -> liftEither $ do+      Refl <- assertEqT @subi @(MapOpInp c ': rs) instr i+      case SomeHST subo of+        SomeHST ((b :: Sing b', bn, _bvn) ::& (rs' :: HST rs') :: HST subo') -> do+          Refl <- assertEqT @b @b' instr i+          Refl <- assertEqT @subo @subo' instr i+          Refl <- checkEqT @rs @rs' instr i $+                      "iteration expression has wrong output stack type"+          pure $ MAP sub ::: (i, mkRes b bn rs')+        _ -> typeCheckInstrErr instr (SomeHST i) $+              "iteration expression has wrong output stack type (empty stack)"++iterImpl+  :: forall c rs .+    ( IterOp c+    , SingI (IterOpEl c)+    , Typeable (IterOpEl c)+    , ExtC+    )+  => Sing (IterOpEl c)+  -> Notes (IterOpEl c)+  -> Un.Instr+  -> NonEmpty Un.Op+  -> HST (c ': rs)+  -> TypeCheckT SomeInstr+iterImpl et en instr mp i@((_, _, lvn) ::& rs) = do+  let evn = deriveVN "elt" lvn+  typeCheckNE (fmap Un.unOp mp) (SomeHST ((et, en, evn) ::& rs)) >>= \case+    SiFail -> pure SiFail+    subI ::: ((_ :: HST i), (o :: HST o)) -> liftEither $ do+      Refl <- assertEqT @i @(IterOpEl c ': rs) instr i+      Refl <- checkEqT @o @rs instr i+                "iteration expression has wrong output stack type"+      pure $ ITER subI ::: (i, o)++lamImpl+  :: forall it ot ts .+    ( Typeable it, Typeable ts, Typeable ot+    , ExtC+    , SingI it, SingI ot+    )+  => Un.Instr+  -> [Un.Op]  -> VarAnn+  -> Sing it -> Notes it+  -> Sing ot -> Notes ot+  -> HST ts+  -> TypeCheckT SomeInstr+lamImpl instr is vn it ins ot ons i = do+  typeCheckList (fmap Un.unOp is) (SomeHST $ (it, ins, def) ::& SNil) >>=+    \case+      SiFail -> pure SiFail+      lam ::: ((_ :: HST li), (lo :: HST lo)) -> liftEither $ do+        Refl <- assertEqT @'[ it ] @li instr i+        case (eqT' @'[ ot ] @lo, SomeHST lo) of+          (Right Refl, SomeHST ((_, ons', _) ::& SNil :: HST lo')) -> do+              Refl <- assertEqT @lo @lo' instr i+              onsr <- converge ons ons'+                        `onLeft` TCFailedOnInstr instr (SomeHST i)+              let ns = mkNotes $ NTLambda def ins onsr+              pure (LAMBDA (VLam lam) ::: (i, (STLambda it ot, ns, vn) ::& i))+          (Right Refl, _) ->+            typeCheckInstrErr instr (SomeHST i)+              "wrong output type of lambda's expression (wrong stack size)"+          (Left m, _) -> typeCheckInstrErr instr (SomeHST i) $+                          "wrong output type of lambda's expression: " <> m
+ src/Michelson/TypeCheck/Types.hs view
@@ -0,0 +1,185 @@+module Michelson.TypeCheck.Types+    ( HST (..)+    , SomeHST (..)+    , SomeInstr (..)+    , SomeVal (..)+    , SomeContract (..)+    , SomeValC (..)+    , TCError (..)+    , ExtC+    , TcInstrHandler+    , TcExtHandler+    , TcExtFrames+    , TcResult+    , TypeCheckEnv (..)+    , TypeCheckT+    , runTypeCheckT+    ) where++import Data.Singletons (SingI)+import Fmt (Buildable(..), pretty, (+|), (|+), (||+))+import Prelude hiding (EQ, GT, LT)+import qualified Text.Show++import Michelson.Typed (ConversibleExt, Notes(..), Sing(..), T(..), fromSingT)+import Michelson.Typed.Extract (toUType)+import Michelson.Typed.Instr+import Michelson.Typed.Value++import qualified Michelson.Untyped as U+import Michelson.Untyped.Annotation (VarAnn)++-- | Data type holding type information for stack (Heterogeneous Stack Type).+--+-- This data type is used along with instruction data type @Instr@+-- to carry information about its input and output stack types.+--+-- That is, if there is value @instr :: Instr inp out@, along with this+-- @instr@ one may carry @inpHST :: HST inp@ and @outHST :: HST out@ which will+-- contain whole information about input and output stack types for @instr@.+--+-- Data type @HST@ is very similar to @Data.Vinyl.Rec@,+-- but is specialized for a particular purpose.+-- In particular, definition of @HST (t1 ': t2 ': ... tn ': '[])@ requires+-- constraints @(Typeable t1, Typeable t2, ..., Typeable tn)@ as well as+-- constraints @(Typeable '[ t1 ], Typeable '[ t1, t2 ], ...)@.+-- These applications of @Typeable@ class are required for convenient usage+-- of type encoded by @HST ts@ with some functions from @Data.Typeable@.+--+-- Data type @HST@ (Heterogeneous Stack Type) is a heterogenuous list of triples.+-- First element of triple is a type singleton which is due to main motivation+-- behind @HST@, namely for it to be used as representation of @Instr@ type+-- data for pattern-matching.+-- Second element of triple is a structure, holding field and type annotations+-- for a given type.+-- Third element of triple is an optional variable annotation for the stack+-- element.+data HST (ts :: [T])  where+  SNil :: HST '[]+  (::&) :: (Typeable xs, Typeable x, SingI x)+        => (Sing x, Notes x, VarAnn)+        -> HST xs+        -> HST (x ': xs)++instance Show (HST ts) where+  show SNil = "[]"+  show (r ::& rs) = "[ " <> showDo (r ::& rs) <> " ]"+    where+      showDo :: HST (t ': ts_) -> String+      showDo ((a, _notes, _vn) ::& (b ::& c)) =+          show (fromSingT a) <> ", " <> showDo (b ::& c)+      showDo ((a, _notes, _vn) ::& SNil) = show (fromSingT a)++infixr 7 ::&++-- | No-argument type wrapper for @HST@ data type.+data SomeHST where+  SomeHST :: Typeable ts => HST ts -> SomeHST++deriving instance Show SomeHST++-- | Data type holding both instruction and+-- type representations of instruction's input and output.+--+-- Intput and output stack types are wrapped inside the type and @Typeable@+-- constraints are provided to allow convenient unwrapping.+data SomeInstr where+  (:::) :: (Typeable inp, Typeable out)+        => Instr inp out+        -> (HST inp, HST out)+        -> SomeInstr+  SiFail :: SomeInstr++  -- TODO use this constructor (to have closer reflection of expression)+  -- SiFail :: Typeable inp => Instr cp inp out -> HST inp -> SomeInstr cp++instance Show InstrExtT => Show SomeInstr where+  show (i ::: (inp, out)) = show i <> " :: " <> show inp <> " -> " <> show out+  show SiFail = "failed"++-- | Data type, holding strictly-typed Michelson value along with its+-- type singleton.+data SomeVal where+    (::::) :: (SingI t, Typeable t)+           => Val Instr t+           -> (Sing t, Notes t)+           -> SomeVal++-- | Data type, holding strictly-typed Michelson value along with its+-- type singleton.+data SomeValC where+    (:--:) :: (SingI t, Typeable t)+           => CVal t -> Sing t -> SomeValC++data SomeContract where+  SomeContract+    :: (Typeable st, SingI st, SingI cp, Typeable cp)+    => Contract cp st+    -> HST (ContractInp cp st)+    -> HST (ContractOut st)+    -> SomeContract++deriving instance Show InstrExtT => Show SomeContract++-- | Type check error+data TCError =+    TCFailedOnInstr U.Instr SomeHST Text+  | TCFailedOnValue (U.Value U.Op) T Text+  | TCOtherError Text++instance Buildable U.Instr => Buildable TCError where+  build = \case+    TCFailedOnInstr instr (SomeHST t) custom ->+      "Error checking expression " +| instr+          |+ " against input stack type " +| t+          ||+ bool (": " +| custom |+ "") "" (null custom)+    TCFailedOnValue v t custom ->+      "Error checking value " +| v+          |+ " against type " +| toUType t+          |+ bool (": " +| custom |+ "") "" (null custom)+    TCOtherError e ->+      "Error occurred during type check: " +| e |+ ""++instance Buildable U.Instr => Show TCError where+  show = pretty++instance Buildable U.Instr => Exception TCError++-- | State for type checking @nop@+type TcExtFrames = [(U.InstrExtU, SomeHST)]++-- | Constraints on InstrExtT and untyped Instr+-- which are required for type checking+type ExtC+   = ( Show InstrExtT+     , Eq U.InstrExtU+     , Typeable InstrExtT+     , Buildable U.Instr+     , ConversibleExt)++type TypeCheckT a =+  ExceptT TCError+    (State TypeCheckEnv) a++-- | Function for typeChecking a @nop@ and updating state+-- TypeCheckT is used because inside+-- inside of TEST_ASSERT could be PRINT/STACKTYPE/etc extended instructions.+type TcExtHandler+  = U.InstrExtU -> TcExtFrames -> SomeHST -> TypeCheckT (TcExtFrames, Maybe InstrExtT)++-- | The typechecking state+data TypeCheckEnv = TypeCheckEnv+  { tcExtHandler    :: TcExtHandler+  , tcExtFrames     :: TcExtFrames+  , tcContractParam :: U.Type+  }++runTypeCheckT :: TcExtHandler -> U.Type -> TypeCheckT a -> Either TCError a+runTypeCheckT nh param act = evaluatingState (TypeCheckEnv nh [] param) $ runExceptT act++type TcResult = Either TCError SomeInstr++type TcInstrHandler+   = U.Instr+    -> SomeHST+      -> TypeCheckT SomeInstr
+ src/Michelson/TypeCheck/Value.hs view
@@ -0,0 +1,175 @@+module Michelson.TypeCheck.Value+    ( typeCheckValImpl+    , typeCheckCVal+    ) where++import Control.Monad.Except (liftEither, throwError)+import Data.Default (def)+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Typeable ((:~:)(..))+import Prelude hiding (EQ, GT, LT)++import Michelson.TypeCheck.Helpers+import Michelson.TypeCheck.Types+import Michelson.Typed+  (CT(..), ConversibleExt, Instr(..), InstrExtT, Notes(..), Notes'(..), Sing(..), T(..), converge,+  mkNotes, withSomeSingCT, withSomeSingT)+import Michelson.Typed.Value (CVal(..), Val(..))+import qualified Michelson.Untyped as Un+import Tezos.Address (parseAddress)+import Tezos.Core (mkMutez, parseTimestamp, timestampFromSeconds)+import Tezos.Crypto (parseKeyHash, parsePublicKey, parseSignature)++typeCheckCVal :: Un.Value op -> CT -> Maybe SomeValC+typeCheckCVal (Un.ValueInt i) CInt = pure $ CvInt i :--: SCInt+typeCheckCVal (Un.ValueInt i) CNat+  | i >= 0 = pure $ CvNat (fromInteger i) :--: SCNat+typeCheckCVal (Un.ValueInt (mkMutez . fromInteger -> Just mtz)) CMutez =+  pure $ CvMutez mtz :--: SCMutez+typeCheckCVal (Un.ValueString s) CString =+  pure $ CvString s :--: SCString+typeCheckCVal (Un.ValueString (parseAddress -> Right s)) CAddress =+  pure $ CvAddress s :--: SCAddress+typeCheckCVal (Un.ValueString (parseKeyHash -> Right s)) CKeyHash =+  pure $ CvKeyHash s :--: SCKeyHash+typeCheckCVal (Un.ValueString (parseTimestamp -> Just t)) CTimestamp =+  pure $ CvTimestamp t :--: SCTimestamp+typeCheckCVal (Un.ValueInt i) CTimestamp =+  pure $ CvTimestamp (timestampFromSeconds i) :--: SCTimestamp+typeCheckCVal (Un.ValueBytes (Un.InternalByteString s)) CBytes =+  pure $ CvBytes s :--: SCBytes+typeCheckCVal Un.ValueTrue CBool = pure $ CvBool True :--: SCBool+typeCheckCVal Un.ValueFalse CBool = pure $ CvBool False :--: SCBool+typeCheckCVal _ _ = Nothing++typeCheckCVals+  :: forall t op . Typeable t+  => [Un.Value op]+  -> CT+  -> Either (Un.Value op, Text) [CVal t]+typeCheckCVals mvs t = traverse check mvs+  where+    check mv = do+      v :--: (_ :: Sing t') <-+        maybe (Left (mv, "failed to typecheck cval")) pure $ typeCheckCVal mv t+      Refl <- eqT' @t @t' `onLeft` (,) mv+      pure v++-- | Function @typeCheckValImpl@ converts a single Michelson value+-- given in representation from @Michelson.Type@ module to representation+-- in strictly typed GADT.+--+-- As a third argument, @typeCheckValImpl@ accepts expected type of value.+--+-- Type checking algorithm pattern-matches on parse value representation,+-- expected type @t@ and constructs @Val t@ value.+--+-- If there was no match on a given pair of value and expected type,+-- that is interpreted as input of wrong type and type check finishes with+-- error.+typeCheckValImpl+  :: (Show InstrExtT, ConversibleExt, Eq Un.InstrExtU)+  => TcInstrHandler+  -> Un.Value Un.Op+  -> T+  -> TypeCheckT SomeVal+typeCheckValImpl _ mv t@(Tc ct) =+  maybe (throwError $ TCFailedOnValue mv t "")+        (\(v :--: cst) -> pure $ VC v :::: (STc cst, NStar))+        (typeCheckCVal mv ct)+typeCheckValImpl _ (Un.ValueString (parsePublicKey -> Right s)) TKey =+  pure $ VKey s :::: (STKey, NStar)++typeCheckValImpl _ (Un.ValueString (parseSignature -> Right s)) TSignature =+  pure $ VSignature s :::: (STSignature, NStar)++typeCheckValImpl _ (Un.ValueString (parseAddress -> Right s)) (TContract pt) =+  withSomeSingT pt $ \p ->+    pure $ VContract s :::: (STContract p, NStar)+typeCheckValImpl _ Un.ValueUnit TUnit = pure $ VUnit :::: (STUnit, NStar)+typeCheckValImpl tcDo (Un.ValuePair ml mr) (TPair lt rt) = do+  l :::: (lst, ln) <- typeCheckValImpl tcDo ml lt+  r :::: (rst, rn) <- typeCheckValImpl tcDo mr rt+  let ns = mkNotes $ NTPair def def def ln rn+  pure $ VPair (l, r) :::: (STPair lst rst, ns)+typeCheckValImpl tcDo (Un.ValueLeft ml) (TOr lt rt) = do+  l :::: (lst, ln) <- typeCheckValImpl tcDo ml lt+  withSomeSingT rt $ \rst ->+    pure $ VOr (Left l) :::: ( STOr lst rst+                             , mkNotes $ NTOr def def def ln NStar )+typeCheckValImpl tcDo (Un.ValueRight mr) (TOr lt rt) = do+  r :::: (rst, rn) <- typeCheckValImpl tcDo mr rt+  withSomeSingT lt $ \lst ->+    pure $ VOr (Right r) :::: ( STOr lst rst+                              , mkNotes $ NTOr def def def NStar rn )+typeCheckValImpl tcDo (Un.ValueSome mv) (TOption vt) = do+  v :::: (vst, vns) <- typeCheckValImpl tcDo mv vt+  let ns = mkNotes $ NTOption def def vns+  pure $ VOption (Just v) :::: (STOption vst, ns)+typeCheckValImpl _ Un.ValueNone (TOption vt) =+  withSomeSingT vt $ \vst ->+    pure $ VOption Nothing :::: (STOption vst, NStar)++typeCheckValImpl tcDo (Un.ValueSeq mels) (TList vt) =+  withSomeSingT vt $ \vst -> do+    (els, ns) <- typeCheckValsImpl tcDo mels vt+    pure $ VList els :::: (STList vst, mkNotes $ NTList def ns)++typeCheckValImpl _ (Un.ValueSeq mels) (TSet vt) =+  withSomeSingCT vt $ \vst -> do+    els <- liftEither $ typeCheckCVals mels vt+            `onLeft` \(cv, err) -> TCFailedOnValue cv (Tc vt) $+                                      "wrong type of set element: " <> err+    pure $ VSet (S.fromList els) :::: (STSet vst, NStar)++typeCheckValImpl tcDo (Un.ValueMap mels) (TMap kt vt) =+  withSomeSingT vt $ \vst ->+  withSomeSingCT kt $ \kst -> do+    ks <- liftEither $  typeCheckCVals (map (\(Un.Elt k _) -> k) mels) kt+            `onLeft` \(cv, err) -> TCFailedOnValue cv (Tc kt) $+                                      "wrong type of map key: " <> err+    (vals, vns) <- typeCheckValsImpl tcDo (map (\(Un.Elt _ v) -> v) mels) vt+    let ns = mkNotes $ NTMap def def vns+    pure $ VMap (M.fromList $ zip ks vals) :::: (STMap kst vst, ns)++typeCheckValImpl tcDo v@(Un.ValueLambda (fmap Un.unOp -> mp)) t@(TLambda mi mo) =+  withSomeSingT mi $ \(it :: Sing it) ->+  withSomeSingT mo $ \(ot :: Sing ot) ->+    typeCheckImpl tcDo mp (SomeHST $ (it, NStar, def) ::& SNil) >>= \case+      SiFail -> pure $ VLam FAILWITH :::: (STLambda it ot, NStar)+      lam ::: ((li :: HST li), (lo :: HST lo)) -> do+        Refl <- liftEither $ eqT' @li @'[ it ] `onLeft` unexpectedErr+        case (eqT' @'[ ot ] @lo, SomeHST lo, SomeHST li) of+          (Right Refl,+           SomeHST ((_, ons, _) ::& SNil :: HST lo'),+           SomeHST ((_, ins, _) ::& SNil :: HST li')) -> do+            Refl <- liftEither $ eqT' @lo @lo' `onLeft` unexpectedErr+            Refl <- liftEither $ eqT' @li @li' `onLeft` unexpectedErr+            let ns = mkNotes $ NTLambda def ins ons+            pure $ VLam lam :::: (STLambda it ot, ns)+          (Right _, _, _) ->+            throwError $ TCFailedOnValue v t+                    "wrong output type of lambda's value (wrong stack size)"+          (Left m, _, _) ->+            throwError $ TCFailedOnValue v t $+                    "wrong output type of lambda's value: " <> m+  where+    unexpectedErr m = TCFailedOnValue v t ("unexpected " <> m)++typeCheckValImpl _ v t = throwError $ TCFailedOnValue v t ""++typeCheckValsImpl+  :: forall t . (Typeable t, Show InstrExtT, ConversibleExt, Eq Un.InstrExtU)+  => TcInstrHandler+  -> [Un.Value Un.Op]+  -> T+  -> TypeCheckT ([Val Instr t], Notes t)+typeCheckValsImpl tcDo mvs t = foldM check ([], NStar) mvs+  where+    check (res, ns) mv = do+      v :::: ((_ :: Sing t'), vns) <- typeCheckValImpl tcDo mv t+      Refl <- liftEither $ eqT' @t @t'+                `onLeft` (TCFailedOnValue mv t . ("wrong element type " <>))+      ns' <- liftEither $ converge ns vns `onLeft` TCFailedOnValue mv t+      pure (v : res, ns')
+ src/Michelson/Typed.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Michelson/Typed/Annotation.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE DataKinds, GADTs #-}++-- | Module, providing @Notes t@ data type, which holds annotations for a+-- given type @t@.+--+-- Annotation type @Notes t@ is a tree, each leaf is either a star (@*@) or a+-- constructor holding some annotation data for a given type @t@.+-- Star corresponds to the case when given Michelson type contains no+-- annotations.+--+-- This module also provides type class 'Converge' along with some+-- utility functions which are used to combine two annotations trees+-- `a` and `b` into a new one `c` in such a way that `c` can be obtained from+-- both `a` and `b` by replacing some @*@ leafs with type or/and field+-- annotations.++module Michelson.Typed.Annotation+  ( Notes (..)+  , Notes' (..)+  , converge+  , convergeAnns+  , notesCase+  , isStar+  , mkNotes+  , orAnn+  ) where++import Data.Default (Default(..))++import Michelson.Typed.T (T(..))+import Michelson.Untyped.Annotation (Annotation, FieldAnn, TypeAnn, unifyAnn)++-- | Data type, holding annotation data for a given Michelson type @t@+-- or @*@ in case no data is provided for the tree.+--+-- There is a little semantical duplication between data type constructors.+-- Semantics behind 'NStar' constructor are exactly same as semantics behind+-- 'N' constructor with relevant 'Notes'' constructor be given all default+-- values (which means all annotations are empty).+--+-- Constructor 'NStar' is given as a tiny optimization to allow handling+-- no-annotation case completely for free (see 'converge' and 'mkNotes'+-- functions).+data Notes t = N (Notes' t) | NStar++-- | Helper function for work with 'Notes' data type.+--+-- @+--  notesCase f g notes+-- @+--+-- is equivalent to+--+-- @+--  case notes of+--    NStar -> f+--    N v -> g v+-- @+--+notesCase :: r -> (Notes' t -> r) -> Notes t -> r+notesCase a _ NStar = a+notesCase _ f (N b) = f b++-- | Data type, holding annotation data for a given Michelson type @t@.+--+-- Each constructor corresponds to exactly one constructor of 'T'+-- and holds all type and field annotations that can be attributed to a+-- Michelson type corrspoding to @t@.+data Notes' t where+  NTc         :: TypeAnn -> Notes' ('Tc ct)+  NTKey       :: TypeAnn -> Notes' 'TKey+  NTUnit      :: TypeAnn -> Notes' 'TUnit+  NTSignature :: TypeAnn -> Notes' 'TSignature+  NTOption    :: TypeAnn -> FieldAnn -> Notes t -> Notes' ('TOption t)+  NTList      :: TypeAnn -> Notes t -> Notes' ('TList t)+  NTSet       :: TypeAnn -> TypeAnn -> Notes' ('TSet ct)+  NTOperation :: TypeAnn -> Notes' 'TOperation+  NTContract  :: TypeAnn -> Notes t -> Notes' ('TContract t)+  NTPair      :: TypeAnn -> FieldAnn -> FieldAnn+               -> Notes p -> Notes q -> Notes' ('TPair p q)+  NTOr        :: TypeAnn -> FieldAnn -> FieldAnn+               -> Notes p -> Notes q -> Notes' ('TOr p q)+  NTLambda    :: TypeAnn -> Notes p -> Notes q -> Notes' ('TLambda p q)+  NTMap       :: TypeAnn -> TypeAnn -> Notes v -> Notes' ('TMap k v)+  NTBigMap   :: TypeAnn -> TypeAnn -> Notes v -> Notes' ('TBigMap k v)++-- | Check whether given annotations object is @*@.+isStar :: Notes t -> Bool+isStar NStar = True+isStar _ = False++isDef :: (Eq t, Default t) => t -> Bool+isDef = (== def)++-- | Checks whether given notes @n@ can be immediately converted to star+-- and returns either @NStar@ or @N n@.+--+-- Given @n :: Notes' t@ can be immediately converted to star iff all nested+-- @(sn :: Notes t) == NStar@ and for each annotation @an@: @an == def@.+mkNotes :: Notes' t -> Notes t+mkNotes (NTOption tn fn ns) | isStar ns && isDef tn && isDef fn   = NStar+mkNotes (NTList tn ns)      | isStar ns && isDef tn               = NStar+mkNotes (NTSet tn en)       | isDef tn && isDef en                = NStar+mkNotes (NTContract tn ns)  | isStar ns && isDef tn               = NStar+mkNotes (NTPair tn fn1 fn2 ns1 ns2)+  | isStar ns1 && isStar ns2 && isDef tn && isDef fn1 && isDef fn2 = NStar+mkNotes (NTOr tn fn1 fn2 ns1 ns2)+  | isStar ns1 && isStar ns2 && isDef tn && isDef fn1 && isDef fn2 = NStar+mkNotes (NTLambda tn ns1 ns2)+  | isStar ns1 && isStar ns2 && isDef tn                           = NStar+mkNotes (NTMap tn kn vns)+  | isStar vns && isDef tn && isDef kn                             = NStar+mkNotes (NTc t) | isDef t                                         = NStar+mkNotes (NTKey t) | isDef t                                       = NStar+mkNotes (NTUnit t) | isDef t                                      = NStar+mkNotes (NTSignature t) | isDef t                                 = NStar+mkNotes (NTOperation t) | isDef t                                 = NStar+mkNotes n = N n++orAnn :: Annotation t -> Annotation t -> Annotation t+orAnn a b = bool a b (a == def)++-- | Combines two annotations trees `a` and `b` into a new one `c`+-- in such a way that `c` can be obtained from both `a` and `b` by replacing+-- some @*@ leafs with type or/and field annotations.+converge' :: Notes' t -> Notes' t -> Either Text (Notes' t)+converge' (NTc a) (NTc b) = NTc <$> convergeAnns a b+converge' (NTKey a) (NTKey b) = NTKey <$> convergeAnns a b+converge' (NTUnit a) (NTUnit b) = NTUnit <$> convergeAnns a b+converge' (NTSignature a) (NTSignature b) =+    NTSignature <$> convergeAnns a b+converge' (NTOption a f n) (NTOption b g m) =+  NTOption <$> convergeAnns a b <*> convergeAnns f g <*> converge n m+converge' (NTList a n) (NTList b m) =+  NTList <$> convergeAnns a b <*> converge n m+converge' (NTSet a n) (NTSet b m) =+  NTSet <$> convergeAnns a b <*> convergeAnns n m+converge' (NTOperation a) (NTOperation b) =+  NTOperation <$> convergeAnns a b+converge' (NTContract a n) (NTContract b m) =+  NTContract <$> convergeAnns a b <*> converge n m+converge' (NTPair a pF qF pN qN) (NTPair b pG qG pM qM) =+  NTPair <$> convergeAnns a b <*> convergeAnns pF pG+          <*> convergeAnns qF qG <*> converge pN pM <*> converge qN qM+converge' (NTOr a pF qF pN qN) (NTOr b pG qG pM qM) =+  NTOr <$> convergeAnns a b <*> convergeAnns pF pG <*> convergeAnns qF qG+          <*> converge pN pM <*> converge qN qM+converge' (NTLambda a pN qN) (NTLambda b pM qM) =+  NTLambda <$> convergeAnns a b <*> converge pN pM <*> converge qN qM+converge' (NTMap a kN vN) (NTMap b kM vM) =+  NTMap <$> convergeAnns a b <*> convergeAnns kN kM <*> converge vN vM+converge' (NTBigMap a kN vN) (NTBigMap b kM vM) =+  NTBigMap <$> convergeAnns a b <*> convergeAnns kN kM <*> converge vN vM++-- | Same as 'converge'' but works with 'Notes' data type.+converge :: Notes t -> Notes t -> Either Text (Notes t)+converge NStar a = pure a+converge a NStar = pure a+converge (N a) (N b) = N <$> converge' a b++-- | Converge two type or field notes (which may be wildcards).+convergeAnns+  :: Show (Annotation tag)+  => Annotation tag -> Annotation tag -> Either Text (Annotation tag)+convergeAnns a b = maybe (Left $ "Annotations do not converge: "+                            <> show a <> " /= " <> show b)+                          pure $ unifyAnn a b
+ src/Michelson/Typed/Arith.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeFamilies #-}++-- | Module, containing some boilerplate for support of+-- arithmetic operations in Michelson language.++module Michelson.Typed.Arith+  ( ArithOp (..)+  , UnaryArithOp (..)+  , ArithError (..)+  , ArithErrorType (..)+  , Add+  , Sub+  , Mul+  , Abs+  , Neg+  , Or+  , And+  , Xor+  , Not+  , Lsl+  , Lsr+  , Compare+  , Eq'+  , Neq+  , Lt+  , Gt+  , Le+  , Ge+  ) where++import Data.Bits (complement, shift, xor, (.&.), (.|.))+import Fmt (Buildable(build))++import Michelson.Typed.CValue (CVal(..))+import Michelson.Typed.T (CT(..))+import Tezos.Core (addMutez, mulMutez, subMutez, timestampFromSeconds, timestampToSeconds)++-- | Class for binary arithmetic operation.+--+-- Takes binary operation marker as @op@ parameter,+-- types of left operand @n@ and right operand @m@.+class ArithOp aop (n :: CT) (m :: CT) where++  -- | Type family @ArithRes@ denotes the type resulting from+  -- computing operation @op@ from operands of types @n@ and @m@.+  --+  -- For instance, adding integer to natural produces integer,+  -- which is reflected in following instance of type family:+  -- @ArithRes Add CNat CInt = CInt@.+  type ArithRes aop n m :: CT++  -- | Evaluate arithmetic operation on given operands.+  evalOp :: proxy aop -> CVal n -> CVal m -> Either (ArithError (CVal n) (CVal m)) (CVal (ArithRes aop n m))++-- | Denotes the error type occured in the arithmetic operation.+data ArithErrorType+  = AddOverflow+  | MulOverflow+  | SubUnderflow+  deriving (Show, Eq, Ord)++-- | Represents an arithmetic error of the operation.+data ArithError n m+  = MutezArithError ArithErrorType n m+  deriving (Show, Eq, Ord)++-- | Marker data type for add operation.+class UnaryArithOp aop (n :: CT) where+  type UnaryArithRes aop n :: CT+  evalUnaryArithOp :: proxy aop -> CVal n -> CVal (UnaryArithRes aop n)++data Add+data Sub+data Mul+data Abs+data Neg++data Or+data And+data Xor+data Not+data Lsl+data Lsr++data Compare+data Eq'+data Neq+data Lt+data Gt+data Le+data Ge++instance ArithOp Add 'CNat 'CInt where+  type ArithRes Add 'CNat 'CInt = 'CInt+  evalOp _ (CvNat i) (CvInt j) = Right $ CvInt (toInteger i + j)+instance ArithOp Add 'CInt 'CNat where+  type ArithRes Add 'CInt 'CNat = 'CInt+  evalOp _ (CvInt i) (CvNat j) = Right $ CvInt (i + toInteger j)+instance ArithOp Add 'CNat 'CNat where+  type ArithRes Add 'CNat 'CNat = 'CNat+  evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i + j)+instance ArithOp Add 'CInt 'CInt where+  type ArithRes Add 'CInt 'CInt = 'CInt+  evalOp _ (CvInt i) (CvInt j) = Right $ CvInt (i + j)+instance ArithOp Add 'CTimestamp 'CInt where+  type ArithRes Add 'CTimestamp 'CInt = 'CTimestamp+  evalOp _ (CvTimestamp i) (CvInt j) =+    Right $ CvTimestamp $ timestampFromSeconds $ timestampToSeconds i + j+instance ArithOp Add 'CInt 'CTimestamp where+  type ArithRes Add 'CInt 'CTimestamp = 'CTimestamp+  evalOp _ (CvInt i) (CvTimestamp j) =+    Right $ CvTimestamp $ timestampFromSeconds $ timestampToSeconds j + i+instance ArithOp Add 'CMutez 'CMutez where+  type ArithRes Add 'CMutez 'CMutez = 'CMutez+  evalOp _ n@(CvMutez i) m@(CvMutez j) = res+    where+      res = maybe (Left $ MutezArithError AddOverflow n m) (Right . CvMutez) $ i `addMutez` j++instance ArithOp Sub 'CNat 'CInt where+  type ArithRes Sub 'CNat 'CInt = 'CInt+  evalOp _ (CvNat i) (CvInt j) = Right $ CvInt (toInteger i - j)+instance ArithOp Sub 'CInt 'CNat where+  type ArithRes Sub 'CInt 'CNat = 'CInt+  evalOp _ (CvInt i) (CvNat j) = Right $ CvInt (i - toInteger j)+instance ArithOp Sub 'CNat 'CNat where+  type ArithRes Sub 'CNat 'CNat = 'CInt+  evalOp _ (CvNat i) (CvNat j) = Right $ CvInt (toInteger i - toInteger j)+instance ArithOp Sub 'CInt 'CInt where+  type ArithRes Sub 'CInt 'CInt = 'CInt+  evalOp _ (CvInt i) (CvInt j) = Right $ CvInt (i - j)+instance ArithOp Sub 'CTimestamp 'CInt where+  type ArithRes Sub 'CTimestamp 'CInt = 'CTimestamp+  evalOp _ (CvTimestamp i) (CvInt j) =+    Right $ CvTimestamp $ timestampFromSeconds $ timestampToSeconds i - j+instance ArithOp Sub 'CTimestamp 'CTimestamp where+  type ArithRes Sub 'CTimestamp 'CTimestamp = 'CInt+  evalOp _ (CvTimestamp i) (CvTimestamp j) =+    Right $ CvInt $ timestampToSeconds i - timestampToSeconds j+instance ArithOp Sub 'CMutez 'CMutez where+  type ArithRes Sub 'CMutez 'CMutez = 'CMutez+  evalOp _ n@(CvMutez i) m@(CvMutez j) = res+    where+      res = maybe (Left $ MutezArithError SubUnderflow n m) (Right . CvMutez) $ i `subMutez` j++instance ArithOp Mul 'CNat 'CInt where+  type ArithRes Mul 'CNat 'CInt = 'CInt+  evalOp _ (CvNat i) (CvInt j) = Right $ CvInt (toInteger i * j)+instance ArithOp Mul 'CInt 'CNat where+  type ArithRes Mul 'CInt 'CNat = 'CInt+  evalOp _ (CvInt i) (CvNat j) = Right $ CvInt (i * toInteger j)+instance ArithOp Mul 'CNat 'CNat where+  type ArithRes Mul 'CNat 'CNat = 'CNat+  evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i * j)+instance ArithOp Mul 'CInt 'CInt where+  type ArithRes Mul 'CInt 'CInt = 'CInt+  evalOp _ (CvInt i) (CvInt j) = Right $ CvInt (i * j)+instance ArithOp Mul 'CNat 'CMutez where+  type ArithRes Mul 'CNat 'CMutez = 'CMutez+  evalOp _ n@(CvNat i) m@(CvMutez j) = res+    where+      res = maybe (Left $ MutezArithError MulOverflow n m) (Right . CvMutez) $ j `mulMutez` i+instance ArithOp Mul 'CMutez 'CNat where+  type ArithRes Mul 'CMutez 'CNat = 'CMutez+  evalOp _ n@(CvMutez i) m@(CvNat j) = res+    where+      res = maybe (Left $ MutezArithError MulOverflow n m) (Right . CvMutez) $ i `mulMutez` j++instance UnaryArithOp Abs 'CInt where+  type UnaryArithRes Abs 'CInt = 'CNat+  evalUnaryArithOp _ (CvInt i) = CvNat (fromInteger $ abs i)++instance UnaryArithOp Neg 'CInt where+  type UnaryArithRes Neg 'CInt = 'CInt+  evalUnaryArithOp _ (CvInt i) = CvInt (-i)++instance ArithOp Or 'CNat 'CNat where+  type ArithRes Or 'CNat 'CNat = 'CNat+  evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i .|. j)+instance ArithOp Or 'CBool 'CBool where+  type ArithRes Or 'CBool 'CBool = 'CBool+  evalOp _ (CvBool i) (CvBool j) = Right $ CvBool (i .|. j)++instance ArithOp And 'CInt 'CNat where+  type ArithRes And 'CInt 'CNat = 'CInt+  evalOp _ (CvInt i) (CvNat j) = Right $ CvInt (i .&. fromIntegral j)+instance ArithOp And 'CNat 'CNat where+  type ArithRes And 'CNat 'CNat = 'CNat+  evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i .&. j)+instance ArithOp And 'CBool 'CBool where+  type ArithRes And 'CBool 'CBool = 'CBool+  evalOp _ (CvBool i) (CvBool j) = Right $ CvBool (i .&. j)++instance ArithOp Xor 'CNat 'CNat where+  type ArithRes Xor 'CNat 'CNat = 'CNat+  evalOp _ (CvNat i) (CvNat j) = Right $ CvNat (i `xor` j)+instance ArithOp Xor 'CBool 'CBool where+  type ArithRes Xor 'CBool 'CBool = 'CBool+  evalOp _ (CvBool i) (CvBool j) = Right $ CvBool (i `xor` j)++-- Todo add condition when shift >= 256+instance ArithOp Lsl 'CNat 'CNat where+  type ArithRes Lsl 'CNat 'CNat = 'CNat+  evalOp _ (CvNat i) (CvNat j) =+    Right $ CvNat (fromInteger $ shift (toInteger i) (fromIntegral j))++instance ArithOp Lsr 'CNat 'CNat where+  type ArithRes Lsr 'CNat 'CNat = 'CNat+  evalOp _ (CvNat i) (CvNat j) =+    Right $ CvNat (fromInteger $ shift (toInteger i) (-(fromIntegral j)))++instance UnaryArithOp Not 'CInt where+  type UnaryArithRes Not 'CInt = 'CInt+  evalUnaryArithOp _ (CvInt i) = CvInt (complement i)+instance UnaryArithOp Not 'CNat where+  type UnaryArithRes Not 'CNat = 'CInt+  evalUnaryArithOp _ (CvNat i) = CvInt (complement $ toInteger i)+instance UnaryArithOp Not 'CBool where+  type UnaryArithRes Not 'CBool = 'CBool+  evalUnaryArithOp _ (CvBool i) = CvBool (not i)++instance ArithOp Compare 'CBool 'CBool where+  type ArithRes Compare 'CBool 'CBool = 'CInt+  evalOp _ (CvBool i) (CvBool j) =+    Right $ CvInt $ toInteger $ fromEnum (compare i j) - 1+instance ArithOp Compare 'CAddress 'CAddress where+  type ArithRes Compare 'CAddress 'CAddress = 'CInt+  evalOp _ (CvAddress i) (CvAddress j) =+    Right $ CvInt $ toInteger $ fromEnum (compare i j) - 1+instance ArithOp Compare 'CNat 'CNat where+  type ArithRes Compare 'CNat 'CNat = 'CInt+  evalOp _ (CvNat i) (CvNat j) =+    Right $ CvInt $ toInteger $ fromEnum (compare i j) - 1+instance ArithOp Compare 'CInt 'CInt where+  type ArithRes Compare 'CInt 'CInt = 'CInt+  evalOp _ (CvInt i) (CvInt j) =+    Right $ CvInt $ toInteger $ fromEnum (compare i j) - 1+instance ArithOp Compare 'CString 'CString where+  type ArithRes Compare 'CString 'CString = 'CInt+  evalOp _ (CvString i) (CvString j) =+    Right $ CvInt $ toInteger $ fromEnum (compare i j) - 1+instance ArithOp Compare 'CBytes 'CBytes where+  type ArithRes Compare 'CBytes 'CBytes = 'CInt+  evalOp _ (CvBytes i) (CvBytes j) =+    Right $ CvInt $ toInteger $ fromEnum (compare i j) - 1+instance ArithOp Compare 'CTimestamp 'CTimestamp where+  type ArithRes Compare 'CTimestamp 'CTimestamp = 'CInt+  evalOp _ (CvTimestamp i) (CvTimestamp j) =+    Right $ CvInt $ toInteger $ fromEnum (compare i j) - 1+instance ArithOp Compare 'CMutez 'CMutez where+  type ArithRes Compare 'CMutez 'CMutez = 'CInt+  evalOp _ (CvMutez i) (CvMutez j) = Right $+    CvInt $ toInteger $ fromEnum (compare i j) - 1+instance ArithOp Compare 'CKeyHash 'CKeyHash where+  type ArithRes Compare 'CKeyHash 'CKeyHash = 'CInt+  evalOp _ (CvKeyHash i) (CvKeyHash j) =+    Right $ CvInt $ toInteger $ fromEnum (compare i j) - 1++instance UnaryArithOp Eq' 'CInt where+  type UnaryArithRes Eq' 'CInt = 'CBool+  evalUnaryArithOp _ (CvInt i) = CvBool (i == 0)++instance UnaryArithOp Neq 'CInt where+  type UnaryArithRes Neq 'CInt = 'CBool+  evalUnaryArithOp _ (CvInt i) = CvBool (i /= 0)+++instance UnaryArithOp Lt 'CInt where+  type UnaryArithRes Lt 'CInt = 'CBool+  evalUnaryArithOp _ (CvInt i) = CvBool (i < 0)++instance UnaryArithOp Gt 'CInt where+  type UnaryArithRes Gt 'CInt = 'CBool+  evalUnaryArithOp _ (CvInt i) = CvBool (i > 0)++instance UnaryArithOp Le 'CInt where+  type UnaryArithRes Le 'CInt = 'CBool+  evalUnaryArithOp _ (CvInt i) = CvBool (i <= 0)++instance UnaryArithOp Ge 'CInt where+  type UnaryArithRes Ge 'CInt = 'CBool+  evalUnaryArithOp _ (CvInt i) = CvBool (i >= 0)+++instance Buildable ArithErrorType where+  build AddOverflow = "add overflow"+  build MulOverflow = "mul overflow"+  build SubUnderflow = "sub overflow"++instance (Show n, Show m) => Buildable (ArithError n m) where+  build (MutezArithError errType n m) = "Mutez "+    <> build errType <> " with " <> show n <> ", " <> show m
+ src/Michelson/Typed/CValue.hs view
@@ -0,0 +1,109 @@+-- | Module, containing CVal data type+-- which represents Michelson comparable values.++module Michelson.Typed.CValue+  ( CVal (..)+  , ToCVal+  , FromCVal+  , toCVal+  , fromCVal+  ) where++import Michelson.Typed.T (CT(..), ToCT)+import Tezos.Address (Address)+import Tezos.Core (Mutez, Timestamp)+import Tezos.Crypto (KeyHash)++-- | Representation of comparable value+-- in Michelson language.+--+-- By specification, we're allowed to compare+-- only following types: int, nat, string, bytes,+-- mutez, bool, key_hash, timestamp, address.+--+-- Only these values can be used as map keys+-- or set elements.+data CVal t where+  CvInt       :: Integer -> CVal 'CInt+  CvNat       :: Natural -> CVal 'CNat+  CvString    :: Text -> CVal 'CString+  CvBytes     :: ByteString -> CVal 'CBytes+  CvMutez     :: Mutez -> CVal 'CMutez+  CvBool      :: Bool -> CVal 'CBool+  CvKeyHash   :: KeyHash -> CVal 'CKeyHash+  CvTimestamp :: Timestamp -> CVal 'CTimestamp+  CvAddress   :: Address -> CVal 'CAddress++deriving instance Show (CVal t)+deriving instance Eq (CVal t)+deriving instance Ord (CVal t)++-- | Converts a single Haskell value into @CVal@ representation.+class ToCVal a where+  toCVal :: a -> CVal (ToCT a)++-- | Converts a @CVal@ value into a single Haskell value.+class FromCVal t where+  fromCVal :: CVal (ToCT t) -> t++-- ToCVal, FromCVal instances++instance FromCVal Integer where+  fromCVal (CvInt i) = i++instance FromCVal Natural where+  fromCVal (CvNat i) = i++instance FromCVal Text where+  fromCVal (CvString s) = s++instance FromCVal Bool where+  fromCVal (CvBool b) = b++instance FromCVal ByteString where+  fromCVal (CvBytes b) = b++instance FromCVal Mutez where+  fromCVal (CvMutez m) = m++instance FromCVal KeyHash where+  fromCVal (CvKeyHash k) = k++instance FromCVal Timestamp where+  fromCVal (CvTimestamp t) = t++instance FromCVal Address where+  fromCVal (CvAddress a) = a++instance ToCVal Integer where+  toCVal = CvInt++instance ToCVal Int where+  toCVal = CvInt . fromIntegral++instance ToCVal Word64 where+  toCVal = CvNat . fromIntegral++instance ToCVal Natural where+  toCVal = CvNat++instance ToCVal Text where+  toCVal = CvString++instance ToCVal ByteString where+  toCVal = CvBytes++instance ToCVal Bool where+  toCVal = CvBool++instance ToCVal Mutez where+  toCVal = CvMutez++instance ToCVal KeyHash where+  toCVal = CvKeyHash++instance ToCVal Timestamp where+  toCVal = CvTimestamp++instance ToCVal Address where+  toCVal = CvAddress
+ src/Michelson/Typed/Convert.hs view
@@ -0,0 +1,265 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Michelson.Typed.Convert+  ( convertContract+  , instrToOps+  , unsafeValToValue+  , valToOpOrValue+  , Conversible (..)+  , ConversibleExt+  ) where++import qualified Data.Map as Map+import Data.Singletons (SingI(sing))++import Michelson.Typed.CValue+import Michelson.Typed.Extract (toUType)+import Michelson.Typed.Instr as Instr+import Michelson.Typed.Sing (fromSingCT, fromSingT)+import Michelson.Typed.T (CT(..), T(..))+import Michelson.Typed.Value+import qualified Michelson.Untyped as Un+import Tezos.Address (formatAddress)+import Tezos.Core (unMutez)+import Tezos.Crypto (formatKeyHash, formatPublicKey, formatSignature)++class Conversible ext1 ext2 where+  convert :: ext1 -> ext2++type ConversibleExt = Conversible (ExtT Instr) (Un.ExtU Un.InstrAbstract Un.Op)++convertContract+  :: forall param store . (SingI param, SingI store, ConversibleExt)+  => Contract param store -> Un.Contract Un.Op+convertContract contract =+  Un.Contract+    { para = toUType $ fromSingT (sing @param)+    , stor = toUType $ fromSingT (sing @store)+    , code = instrToOps contract+    }++-- | Function @unsafeValToValue@ converts typed @Val@ to untyped @Value@+-- from @Michelson.Untyped.Value@ module+--+-- VOp cannot be represented in @Value@ from untyped types, so calling this function+-- on it will cause an error+unsafeValToValue :: (ConversibleExt, HasCallStack) => Val Instr t -> Un.Value Un.Op+unsafeValToValue = fromMaybe (error err) . valToOpOrValue+  where+    err =+      "unexpected unsafeValToValue call trying to convert VOp to untyped Value"++-- | Convert a typed 'Val' to an untyped 'Value', or fail if it contains operations+-- which are unrepresentable there.+valToOpOrValue ::+     forall t . ConversibleExt+  => Val Instr t+  -> Maybe (Un.Value Un.Op)+valToOpOrValue = \case+  VC cVal -> Just $ cValToValue cVal+  VKey b -> Just $ Un.ValueString $ formatPublicKey b+  VUnit -> Just $ Un.ValueUnit+  VSignature b -> Just $ Un.ValueString $ formatSignature b+  VOption (Just x) -> Un.ValueSome <$> valToOpOrValue x+  VOption Nothing -> Just $ Un.ValueNone+  VList l -> Un.ValueSeq <$> mapM valToOpOrValue l+  VSet s -> Just $ Un.ValueSeq $ map cValToValue $ toList s+  VOp _op -> Nothing+  VContract b -> Just $ Un.ValueString $ formatAddress b+  VPair (l, r) -> Un.ValuePair <$> valToOpOrValue l <*> valToOpOrValue r+  VOr (Left x) -> Un.ValueLeft <$> valToOpOrValue x+  VOr (Right x) -> Un.ValueRight <$> valToOpOrValue x+  VLam ops -> Just $ Un.ValueLambda $ instrToOps ops+  VMap m ->+    fmap Un.ValueMap . forM (Map.toList m) $ \(k, v) ->+      Un.Elt (cValToValue k) <$> valToOpOrValue v+  VBigMap m ->+    fmap Un.ValueMap . forM (Map.toList m) $ \(k, v) ->+      Un.Elt (cValToValue k) <$> valToOpOrValue v++cValToValue :: CVal t -> Un.Value Un.Op+cValToValue cVal = case cVal of+  CvInt i -> Un.ValueInt i+  CvNat i -> Un.ValueInt $ toInteger i+  CvString s -> Un.ValueString s+  CvBytes b -> Un.ValueBytes $ Un.InternalByteString b+  CvMutez m -> Un.ValueInt $ toInteger $ unMutez m+  CvBool True -> Un.ValueTrue+  CvBool False -> Un.ValueFalse+  CvKeyHash h -> Un.ValueString $ formatKeyHash h+  CvTimestamp t -> Un.ValueString $ show t+  CvAddress a -> Un.ValueString $ formatAddress a++instrToOps :: ConversibleExt => Instr inp out -> [Un.Op]+instrToOps instr = Un.Op <$> handleInstr instr+  where+    handleInstr :: Instr inp out -> [Un.Instr]+    handleInstr (Seq i1 i2) = handleInstr i1 <> handleInstr i2+    handleInstr Nop = []+    handleInstr (Ext nop) = [Un.EXT $ convert nop]+    handleInstr DROP = [Un.DROP]+    handleInstr DUP = [Un.DUP Un.noAnn]+    handleInstr SWAP = [Un.SWAP]+    handleInstr i@(PUSH val) = handle i+      where+        handle :: Instr inp1 (t ': s) -> [Un.Instr]+        handle (PUSH _ :: Instr inp1 (t ': s)) =+          let value = unsafeValToValue val+              --- ^ safe because PUSH cannot have operation as argument+          in [Un.PUSH Un.noAnn (toUType $ fromSingT (sing @t)) value]+        handle _ = error "unexcepted call"+    handleInstr i@NONE = handle i+      where+        handle :: Instr inp1 ('TOption a ': inp1) -> [Un.Instr]+        handle (NONE :: Instr inp1 ('TOption a ': inp1)) =+          [Un.NONE Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @a))]+        handle _ = error "unexcepted call"+    handleInstr SOME = [Un.SOME Un.noAnn Un.noAnn Un.noAnn]+    handleInstr UNIT = [Un.UNIT Un.noAnn Un.noAnn]+    handleInstr (IF_NONE i1 i2) = [Un.IF_NONE (instrToOps i1) (instrToOps i2)]+    handleInstr PAIR = [Un.PAIR Un.noAnn Un.noAnn Un.noAnn Un.noAnn]+    handleInstr CAR = [Un.CAR Un.noAnn Un.noAnn]+    handleInstr CDR = [Un.CDR Un.noAnn Un.noAnn]+    handleInstr i@LEFT = handle i+      where+        handle :: Instr (a ': s) ('TOr a b ': s) -> [Un.Instr]+        handle (LEFT :: Instr (a ': s) ('TOr a b ': s)) =+          [Un.LEFT Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @b))]+        handle _ = error "unexcepted call"+    handleInstr i@(RIGHT) = handle i+      where+        handle :: Instr (b ': s) ('TOr a b ': s) -> [Un.Instr]+        handle (RIGHT :: Instr (b ': s) ('TOr a b ': s)) =+          [Un.RIGHT Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @a))]+        handle _ = error "unexcepted call"+    handleInstr (IF_LEFT i1 i2) = [Un.IF_LEFT (instrToOps i1) (instrToOps i2)]+    handleInstr (IF_RIGHT i1 i2) = [Un.IF_RIGHT (instrToOps i1) (instrToOps i2)]+    handleInstr i@(NIL) = handle i+      where+        handle :: Instr s ('TList p ': s) -> [Un.Instr]+        handle (NIL :: Instr s ('TList p ': s)) =+          [Un.NIL Un.noAnn Un.noAnn (toUType $ fromSingT (sing @p))]+        handle _ = error "unexcepted call"+    handleInstr CONS = [Un.CONS Un.noAnn]+    handleInstr (IF_CONS i1 i2) = [Un.IF_CONS (instrToOps i1) (instrToOps i2)]+    handleInstr SIZE = [Un.SIZE Un.noAnn]+    handleInstr i@EMPTY_SET = handle i+      where+        handle :: Instr s ('TSet e ': s) -> [Un.Instr]+        handle (EMPTY_SET :: Instr s ('TSet e ': s)) =+          [Un.EMPTY_SET Un.noAnn Un.noAnn (Un.Comparable (fromSingCT (sing @e)) Un.noAnn)]+        handle _ = error "unexcepted call"+    handleInstr i@EMPTY_MAP = handle i+      where+        handle :: Instr s ('TMap a b ': s) -> [Un.Instr]+        handle (EMPTY_MAP :: Instr s ('TMap a b ': s)) =+          [Un.EMPTY_MAP Un.noAnn Un.noAnn (Un.Comparable (fromSingCT (sing @a)) Un.noAnn)+           (toUType $ fromSingT (sing @b))+          ]+        handle _ = error "unexcepted call"+    handleInstr (MAP op) = [Un.MAP Un.noAnn $ instrToOps op]+    handleInstr (ITER op) = [Un.ITER $ instrToOps op]+    handleInstr MEM = [Un.MEM Un.noAnn]+    handleInstr GET = [Un.GET Un.noAnn]+    handleInstr UPDATE = [Un.UPDATE]+    handleInstr (IF op1 op2) = [Un.IF (instrToOps op1) (instrToOps op2)]+    handleInstr (LOOP op) = [Un.LOOP (instrToOps op)]+    handleInstr (LOOP_LEFT op) = [Un.LOOP_LEFT (instrToOps op)]+    handleInstr i@(LAMBDA l) = handle i+      where+        handle :: Instr s ('TLambda i o ': s) -> [Un.Instr]+        handle (LAMBDA _ :: Instr s ('TLambda i o ': s)) =+          [Un.LAMBDA Un.noAnn (toUType $ fromSingT (sing @i))+            (toUType $ fromSingT (sing @i)) (convertLambdaBody l)+          ]+        handle _ = error "unexcepted call"+        convertLambdaBody :: Val Instr ('TLambda i o) -> [Un.Op]+        convertLambdaBody (VLam ops) = instrToOps ops+    handleInstr EXEC = [Un.EXEC Un.noAnn]+    handleInstr (DIP op) = [Un.DIP (instrToOps op)]+    handleInstr FAILWITH = [Un.FAILWITH]+    handleInstr i@(CAST) = handle i+      where+        handle :: Instr (a ': s) (a ': s) -> [Un.Instr]+        handle (CAST :: Instr (a ': s) (a ': s)) =+          [Un.CAST Un.noAnn (toUType $ fromSingT (sing @a))]+        handle _ = error "unexcepted call"+    handleInstr RENAME = [Un.RENAME Un.noAnn]+    handleInstr PACK = [Un.PACK Un.noAnn]+    handleInstr i@(UNPACK) = handle i+      where+        handle :: Instr ('Tc 'CBytes ': s) ('TOption a ': s) -> [Un.Instr]+        handle (UNPACK :: Instr ('Tc 'CBytes ': s) ('TOption a ': s)) =+          [Un.UNPACK Un.noAnn (toUType $ fromSingT (sing @a))]+        handle _ = error "unexcepted call"+    handleInstr CONCAT = [Un.CONCAT Un.noAnn]+    handleInstr CONCAT' = [Un.CONCAT Un.noAnn]+    handleInstr SLICE = [Un.SLICE Un.noAnn]+    handleInstr ISNAT = [Un.ISNAT Un.noAnn]+    handleInstr ADD = [Un.ADD Un.noAnn]+    handleInstr SUB = [Un.SUB Un.noAnn]+    handleInstr MUL = [Un.MUL Un.noAnn]+    handleInstr EDIV = [Un.EDIV Un.noAnn]+    handleInstr ABS = [Un.ABS Un.noAnn]+    handleInstr NEG = [Un.NEG]+    handleInstr LSL = [Un.LSL Un.noAnn]+    handleInstr LSR = [Un.LSR Un.noAnn]+    handleInstr OR = [Un.OR Un.noAnn]+    handleInstr AND = [Un.AND Un.noAnn]+    handleInstr XOR = [Un.XOR Un.noAnn]+    handleInstr NOT = [Un.NOT Un.noAnn]+    handleInstr COMPARE = [Un.COMPARE Un.noAnn]+    handleInstr Instr.EQ = [Un.EQ Un.noAnn]+    handleInstr NEQ = [Un.NEQ Un.noAnn]+    handleInstr Instr.LT = [Un.LT Un.noAnn]+    handleInstr Instr.GT = [Un.GT Un.noAnn]+    handleInstr LE = [Un.LE Un.noAnn]+    handleInstr GE = [Un.GE Un.noAnn]+    handleInstr INT = [Un.INT Un.noAnn]+    handleInstr SELF = [Un.SELF Un.noAnn]+    handleInstr i@CONTRACT = handle i+      where+        handle :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)+               -> [Un.Instr]+        handle (CONTRACT :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)) =+          [Un.CONTRACT Un.noAnn (toUType $ fromSingT (sing @p))]+        handle _ = error "unexcepted call"+    handleInstr TRANSFER_TOKENS = [Un.TRANSFER_TOKENS Un.noAnn]+    handleInstr SET_DELEGATE = [Un.SET_DELEGATE Un.noAnn]+    handleInstr CREATE_ACCOUNT = [Un.CREATE_ACCOUNT Un.noAnn Un.noAnn]+    handleInstr CREATE_CONTRACT = [Un.CREATE_CONTRACT Un.noAnn Un.noAnn]+    handleInstr i@(CREATE_CONTRACT2 _) = handle i+      where+        handle :: Instr ('Tc 'CKeyHash ': 'TOption ('Tc 'CKeyHash)+                    ': 'Tc 'CBool ': 'Tc 'CBool ': 'Tc 'CMutez ': g ': s)+                   ('TOperation ': 'Tc 'CAddress ': s) -> [Un.Instr]+        handle (CREATE_CONTRACT2 ops :: Instr ('Tc 'CKeyHash+                    ': 'TOption ('Tc 'CKeyHash)+                    ': 'Tc 'CBool ': 'Tc 'CBool ': 'Tc 'CMutez ': g ': s)+                   ('TOperation ': 'Tc 'CAddress ': s)) =+          case ops of+            (code :: Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ]) ->+              let contract = Un.Contract (toUType $ fromSingT (sing @p))+                    (toUType $ fromSingT (sing @g)) (instrToOps code) in+              [Un.CREATE_CONTRACT2 Un.noAnn Un.noAnn contract]+        handle _ = error "unexcepted call"+    handleInstr IMPLICIT_ACCOUNT = [Un.IMPLICIT_ACCOUNT Un.noAnn]+    handleInstr NOW = [Un.NOW Un.noAnn]+    handleInstr AMOUNT = [Un.AMOUNT Un.noAnn]+    handleInstr BALANCE = [Un.BALANCE Un.noAnn]+    handleInstr CHECK_SIGNATURE = [Un.CHECK_SIGNATURE Un.noAnn]+    handleInstr SHA256 = [Un.SHA256 Un.noAnn]+    handleInstr SHA512 = [Un.SHA512 Un.noAnn]+    handleInstr BLAKE2B = [Un.BLAKE2B Un.noAnn]+    handleInstr HASH_KEY = [Un.HASH_KEY Un.noAnn]+    handleInstr STEPS_TO_QUOTA = [Un.STEPS_TO_QUOTA Un.noAnn]+    handleInstr SOURCE = [Un.SOURCE Un.noAnn]+    handleInstr SENDER = [Un.SENDER Un.noAnn]+    handleInstr ADDRESS = [Un.ADDRESS Un.noAnn]++-- It's an orphan instance, but it's better than checking all cases manually.+-- We can also move this convertion to the place where `Instr` is defined,+-- but then there will be a very large module (as we'll have to move a lot of+-- stuff as well).+instance (ConversibleExt, Eq Un.InstrExtU) => Eq (Instr inp out) where+  i1 == i2 = instrToOps i1 == instrToOps i2
+ src/Michelson/Typed/Extract.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE DataKinds, GADTs #-}++-- Module, containing functions to convert @Michelson.Types.Type@ to+-- @Michelson.Typed.T.T@ Michelson type representation (type stripped off all+-- annotations) and to @Michelson.Typed.Annotation.Notes@ value (which contains+-- field and type annotations for a given Michelson type).+--+-- I.e. @Michelson.Types.Type@ is split to value @t :: T@ and value of type+-- @Notes t@ for which @t@ is a type representation of value @t@.+module Michelson.Typed.Extract+  ( extractNotes+  , fromUType+  , mkUType+  , toUType+  ) where++import Michelson.Typed.Annotation (Notes(..), Notes'(..), mkNotes)+import Michelson.Typed.Sing (Sing(..), fromSingCT, fromSingT)+import Michelson.Typed.T (T(..))+import qualified Michelson.Untyped as Un++-- | Extracts 'T' type from 'Michelson.Untyped.Type'.+fromUType :: Un.Type -> T+fromUType (Un.Type wholeT _) = conv wholeT+  where+    conv (Un.Tc ct) = Tc ct+    conv Un.TKey = TKey+    conv Un.TUnit = TUnit+    conv Un.TSignature = TSignature+    conv (Un.TOption _ t) = TOption (fromUType t)+    conv (Un.TList t) = TList (fromUType t)+    conv (Un.TSet (Un.Comparable ct _)) = TSet ct+    conv Un.TOperation = TOperation+    conv (Un.TContract t) = TContract (fromUType t)+    conv (Un.TPair _ _ lT rT) = TPair (fromUType lT) (fromUType rT)+    conv (Un.TOr _ _ lT rT) = TOr (fromUType lT) (fromUType rT)+    conv (Un.TLambda lT rT) = TLambda (fromUType lT) (fromUType rT)+    conv (Un.TMap (Un.Comparable key _) val) = TMap key (fromUType val)+    conv (Un.TBigMap (Un.Comparable key _) val) = TBigMap key (fromUType val)+++mkUType :: Sing x -> Notes x -> Un.Type+mkUType sing notes = case (sing, notes) of+  (STc ct, N (NTc tn))              -> mt (Un.Tc (fromSingCT ct)) tn+  (STc ct, NStar)                    -> mt (Un.Tc (fromSingCT ct)) na+  (STKey, N (NTKey tn))             -> mt Un.TKey tn+  (STKey, NStar)                     -> mt Un.TKey na+  (STUnit, N (NTUnit tn))           -> mt Un.TUnit tn+  (STUnit, NStar)                    -> mt Un.TUnit na+  (STSignature, N (NTSignature tn)) -> mt Un.TSignature tn+  (STSignature,NStar)                -> mt Un.TSignature na+  (STOption t,N (NTOption tn fn n)) -> mt (Un.TOption fn (mkUType t n)) tn+  ((STOption t), NStar)              -> mt (Un.TOption na (mkUType t NStar)) na+  (STList t, N (NTList tn n))       -> mt (Un.TList (mkUType t n)) tn+  (STList t, NStar)                  -> mt (Un.TList (mkUType t NStar)) na+  (STSet ct, N (NTSet tn n))        -> mt (Un.TSet $ mkComp ct n) tn+  (STSet ct, NStar)                  -> mt (Un.TSet $ mkComp ct na) na+  (STOperation, N (NTOperation tn)) -> mt Un.TOperation tn+  (STOperation, NStar)               -> mt Un.TOperation na+  (STContract t, N (NTContract tn n)) ->+    mt (Un.TContract (mkUType t n)) tn+  (STContract t, NStar)              -> mt (Un.TContract (mkUType t NStar)) na+  (STPair tl tr, N (NTPair tn fl fr nl nr)) ->+    mt (Un.TPair fl fr (mkUType tl nl) (mkUType tr nr)) tn+  (STPair tl tr, NStar) ->+    mt (Un.TPair na na (mkUType tl NStar) (mkUType tr NStar)) na+  (STOr tl tr, N (NTOr tn fl fr nl nr)) ->+    mt (Un.TOr fl fr (mkUType tl nl) (mkUType tr nr)) tn+  (STOr tl tr, NStar) ->+    mt (Un.TOr na na (mkUType tl NStar) (mkUType tr NStar)) na+  (STLambda p q, N (NTLambda tn np nq)) ->+    mt (Un.TLambda (mkUType p np) (mkUType q nq)) tn+  (STLambda p q, NStar) ->+    mt (Un.TLambda (mkUType p NStar) (mkUType q NStar)) na+  (STMap k v, N (NTMap tn nk nv)) ->+    mt (Un.TMap (mkComp k nk) (mkUType v nv)) tn+  (STMap k v, NStar) ->+    mt (Un.TMap (mkComp k na) (mkUType v NStar)) na+  (STBigMap k v, N (NTBigMap tn nk nv)) ->+    mt (Un.TBigMap (mkComp k nk) (mkUType v nv)) tn+  (STBigMap k v, NStar) ->+    mt (Un.TBigMap (mkComp k na) (mkUType v NStar)) na+ where+  mkComp t a = Un.Comparable (fromSingCT t) a+  mt = Un.Type+  na = Un.noAnn++-- | Extracts @Notes t@ type from 'Michelson.Type.Type' and corresponding+-- singleton.+extractNotes :: Un.Type -> Sing t -> Either Text (Notes t)+extractNotes (Un.Type wholeT tn) s = conv wholeT s+  where+    conv :: Un.T -> Sing t -> Either Text (Notes t)+    conv (Un.Tc ct) (STc cst)+      | fromSingCT cst == ct = pure $ mkNotes $ NTc tn+    conv Un.TKey STKey = pure $ mkNotes $ NTKey tn+    conv Un.TUnit STUnit = pure $ mkNotes $ NTUnit tn+    conv Un.TSignature STSignature = pure $ mkNotes $ NTSignature tn+    conv (Un.TOption fn t) (STOption st) =+      mkNotes . NTOption tn fn <$> extractNotes t st+    conv (Un.TList t) (STList st) = do+      mkNotes . NTList tn <$> extractNotes t st+    conv (Un.TSet (Un.Comparable et sn)) (STSet est)+      | fromSingCT est == et = pure $ mkNotes $ NTSet tn sn+    conv Un.TOperation STOperation = pure $ mkNotes $ NTOperation tn+    conv (Un.TContract t) (STContract st) =+      mkNotes . NTContract tn <$> extractNotes t st+    conv (Un.TPair pf qf pt qt) (STPair spt sqt) =+      liftA2 (mkNotes ... NTPair tn pf qf)+             (extractNotes pt spt)+             (extractNotes qt sqt)+    conv (Un.TOr pf qf pt qt) (STOr spt sqt) = do+      liftA2 (mkNotes ... NTOr tn pf qf)+             (extractNotes pt spt)+             (extractNotes qt sqt)+    conv (Un.TLambda pt qt) (STLambda spt sqt) = do+      liftA2 (mkNotes ... NTLambda tn)+             (extractNotes pt spt)+             (extractNotes qt sqt)+    conv (Un.TMap (Un.Comparable kt kn) vt) (STMap kst svt)+       | fromSingCT kst == kt = mkNotes . NTMap tn kn  <$> extractNotes vt svt+    conv (Un.TBigMap (Un.Comparable kt kn) vt) (STBigMap kst svt)+      | fromSingCT kst == kt =+        mkNotes . NTBigMap tn kn  <$> extractNotes vt svt+    conv a (fromSingT -> b) =+      Left $ "failed to construct annotation, provided types do not match: "+                <> show a <> " /= " <> show b++-- | Converts from 'T' to 'Michelson.Type.Type'.+toUType :: T -> Un.Type+toUType t = Un.Type (convert t) Un.noAnn+  where+    convert :: T -> Un.T+    convert (Tc a) = Un.Tc a+    convert (TKey) = Un.TKey+    convert (TUnit) = Un.TUnit+    convert (TSignature) = Un.TSignature+    convert (TOption a) = Un.TOption Un.noAnn (toUType a)+    convert (TList a) = Un.TList (toUType a)+    convert (TSet a) = Un.TSet $ Un.Comparable a Un.noAnn+    convert (TOperation) = Un.TOperation+    convert (TContract a) = Un.TContract (toUType a)+    convert (TPair a b) =+      Un.TPair Un.noAnn Un.noAnn (toUType a) (toUType b)+    convert (TOr a b) =+      Un.TOr Un.noAnn Un.noAnn (toUType a) (toUType b)+    convert (TLambda a b) =+      Un.TLambda (toUType a) (toUType b)+    convert (TMap a b) =+      Un.TMap (Un.Comparable a Un.noAnn) (toUType b)+    convert (TBigMap a b) =+      Un.TBigMap (Un.Comparable a Un.noAnn) (toUType b)
+ src/Michelson/Typed/Instr.hs view
@@ -0,0 +1,247 @@+-- | Module, containing data types for Michelson value.++module Michelson.Typed.Instr+  ( Instr (..)+  , (#)+  , Contract+  , ExtT+  , InstrExtT+  ) where++import Data.Kind (Type)+import Data.Singletons (SingI)++import Michelson.Typed.Arith+import Michelson.Typed.Polymorphic+import Michelson.Typed.T (CT(..), T(..))+import Michelson.Typed.Value (ContractInp, ContractOut, Val(..))++-- | Infix version of @Seq@ constructor.+--+-- One can represent sequence of Michelson opertaions as follows:+-- @SWAP; DROP; DUP;@ -> @SWAP # DROP # DUP@.+(#) :: Typeable b => Instr a b -> Instr b c -> Instr a c+(#) = Seq++infixl 0 #++-- | ExtT is extension of Instr by Morley instructions+type family ExtT (instr :: [T] -> [T] -> Type) :: Type++type InstrExtT = ExtT Instr++-- | Representation of Michelson instruction or sequence+-- of instructions.+--+-- Each Michelson instruction is represented by exactly one+-- constructor of this data type. Sequence of instructions+-- is represented with use of @Seq@ constructor in following+-- way: @SWAP; DROP ; DUP;@ -> @SWAP `Seq` DROP `Seq` DUP@.+-- Special case where there are no instructions is represented+-- by constructor @Nop@, e.g. @IF_NONE {} { SWAP; DROP; }@ ->+-- @IF_NONE Nop (SWAP `Seq` DROP)@.+--+-- Type parameter @inp@ states for input stack type. That is,+-- type of the stack that is required for operation to execute.+--+-- Type parameter @out@ states for output stack type or type+-- of stack that will be left after instruction's execution.++-- pva701: Typeable constraints are added during TM-29.+-- Maybe it makes sense to think how to eliminate them+-- if they break something+data Instr (inp :: [T]) (out :: [T]) where+  Seq :: Typeable b => Instr a b -> Instr b c -> Instr a c+  -- | Nop operation. Missing in Michelson spec, added to parse construction+  -- like  `IF {} { SWAP; DROP; }`.+  Nop :: Instr s s++  Ext :: ExtT Instr -> Instr s s++  DROP :: Instr (a ': s) s+  DUP  :: Instr (a ': s) (a ': a ': s)+  SWAP :: Instr (a ': b ': s) (b ': a ': s)+  PUSH :: forall t s . SingI t => Val Instr t -> Instr s (t ': s)+  SOME :: Instr (a ': s) ('TOption a ': s)+  NONE :: forall a s . SingI a => Instr s ('TOption a ': s)+  UNIT :: Instr s ('TUnit ': s)+  IF_NONE+    :: (Typeable a, Typeable s)+    => Instr s s'+    -> Instr (a ': s) s'+    -> Instr ('TOption a ': s) s'+  PAIR :: Instr (a ': b ': s) ('TPair a b ': s)+  CAR :: Instr ('TPair a b ': s) (a ': s)+  CDR :: Instr ('TPair a b ': s) (b ': s)+  LEFT :: forall a b s . SingI b => Instr (a ': s) ('TOr a b ': s)+  RIGHT :: forall a b s . SingI a => Instr (b ': s) ('TOr a b ': s)+  IF_LEFT+    :: (Typeable s, Typeable a, Typeable b)+    => Instr (a ': s) s'+    -> Instr (b ': s) s'+    -> Instr ('TOr a b ': s) s'+  IF_RIGHT+    :: (Typeable s, Typeable b, Typeable a)+    => Instr (b ': s) s'+    -> Instr (a ': s) s'+    -> Instr ('TOr a b ': s) s'+  NIL :: SingI p => Instr s ('TList p ': s)+  CONS :: Instr (a ': 'TList a ': s) ('TList a ': s)+  IF_CONS+    :: (Typeable s, Typeable a)+    => Instr (a ': 'TList a ': s) s'+    -> Instr s s'+    -> Instr ('TList a ': s) s'+  SIZE :: SizeOp c => Instr (c ': s) ('Tc 'CNat ': s)+  EMPTY_SET :: SingI e => Instr s ('TSet e ': s)+  EMPTY_MAP :: (SingI a, SingI b) => Instr s ('TMap a b ': s)+  MAP :: (Typeable (MapOpInp c ': s), MapOp c b)+      => Instr (MapOpInp c ': s) (b ': s)+      -> Instr (c ': s) (MapOpRes c b ': s)+  ITER :: (Typeable (IterOpEl c ': s), IterOp c) => Instr (IterOpEl c ': s) s -> Instr (c ': s) s+  MEM :: MemOp c => Instr ('Tc (MemOpKey c) ': c ': s) ('Tc 'CBool ': s)+  GET+    :: GetOp c+    => Instr ('Tc (GetOpKey c) ': c ': s) ('TOption (GetOpVal c) ': s)+  UPDATE+    :: UpdOp c+    => Instr ('Tc (UpdOpKey c) ': UpdOpParams c ': c ': s) (c ': s)+  IF :: Typeable s+     => Instr s s'+     -> Instr s s'+     -> Instr ('Tc 'CBool ': s) s'+  LOOP :: Typeable s+       => Instr s ('Tc 'CBool ': s)+       -> Instr ('Tc 'CBool ': s) s+  LOOP_LEFT+    :: (Typeable a, Typeable s)+    => Instr (a ': s) ('TOr a b ': s)+    -> Instr ('TOr a b ': s) (b ': s)+  LAMBDA :: forall i o s . (SingI i, SingI o)+         => Val Instr ('TLambda i o) -> Instr s ('TLambda i o ': s)+  EXEC :: Typeable t1 => Instr (t1 ': 'TLambda t1 t2 ': s) (t2 ': s)+  DIP :: Typeable a => Instr a c -> Instr (b ': a) (b ': c)+  FAILWITH :: Instr (a ': s) t+  CAST :: forall a s . SingI a => Instr (a ': s) (a ': s)+  RENAME :: Instr (a ': s) (a ': s)+  PACK :: Instr (a ': s) ('Tc 'CBytes ': s)+  UNPACK :: SingI a => Instr ('Tc 'CBytes ': s) ('TOption a ': s)+  CONCAT :: ConcatOp c => Instr (c ': c ': s) (c ': s)+  CONCAT' :: ConcatOp c => Instr ('TList c ': s) (c ': s)+  SLICE+    :: SliceOp c+    => Instr ('Tc 'CNat ': 'Tc 'CNat ': c ': s) ('TOption c ': s)+  ISNAT :: Instr ('Tc 'CInt ': s) ('TOption ('Tc 'CNat) ': s)+  ADD+    :: ArithOp Add n m+    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Add n m) ': s)+  SUB+    :: ArithOp Sub n m+    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Sub n m) ': s)+  MUL+    :: ArithOp Mul n m+    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Mul n m) ': s)+  EDIV+    :: EDivOp n m+    => Instr ('Tc n ': 'Tc m ': s)+                 (('TOption ('TPair ('Tc (EDivOpRes n m))+                                      ('Tc (EModOpRes n m)))) ': s)+  ABS+    :: UnaryArithOp Abs n+    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Abs n) ': s)+  NEG+    :: UnaryArithOp Neg n+    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Neg n) ': s)+  LSL+    :: ArithOp Lsl n m+    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Lsl n m) ': s)+  LSR+    :: ArithOp Lsr n m+    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Lsr n m) ': s)+  OR+    :: ArithOp Or n m+    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Or n m) ': s)+  AND+    :: ArithOp And n m+    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes And n m) ': s)+  XOR+    :: ArithOp Xor n m+    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Xor n m) ': s)+  NOT+    :: UnaryArithOp Not n+    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Not n) ': s)+  COMPARE+    :: ArithOp Compare n m+    => Instr ('Tc n ': 'Tc m ': s) ('Tc (ArithRes Compare n m) ': s)+  EQ+    :: UnaryArithOp Eq' n+    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Eq' n) ': s)+  NEQ+    :: UnaryArithOp Neq n+    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Neq n) ': s)+  LT+    :: UnaryArithOp Lt n+    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Lt n) ': s)+  GT+    :: UnaryArithOp Gt n+    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Gt n) ': s)+  LE+    :: UnaryArithOp Le n+    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Le n) ': s)+  GE+    :: UnaryArithOp Ge n+    => Instr ('Tc n ': s) ('Tc (UnaryArithRes Ge n) ': s)+  INT :: Instr ('Tc 'CNat ': s) ('Tc 'CInt ': s)+  SELF :: forall (cp :: T) s . Instr s ('TContract cp ': s)+  CONTRACT+    :: SingI p => Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)+  TRANSFER_TOKENS+    :: Typeable p => Instr (p ': 'Tc 'CMutez ': 'TContract p ': s)+                   ('TOperation ': s)+  SET_DELEGATE+    :: Instr ('TOption ('Tc 'CKeyHash) ': s) ('TOperation ': s)++  CREATE_ACCOUNT+    :: Instr+        ('Tc 'CKeyHash ': 'TOption ('Tc 'CKeyHash) ': 'Tc 'CBool+         ': 'Tc 'CMutez ': s) ('TOperation ': 'Tc 'CAddress ': s)++  CREATE_CONTRACT+    :: (SingI p, SingI g, Typeable p, Typeable g)+    => Instr+        ('Tc 'CKeyHash ': 'TOption ('Tc 'CKeyHash) ': 'Tc 'CBool+          ': 'Tc 'CBool ': 'Tc 'CMutez+          ': 'TLambda ('TPair p g)+                       ('TPair ('TList 'TOperation) g) ': g ': s)+        ('TOperation ': 'Tc 'CAddress ': s)+  CREATE_CONTRACT2+    :: (SingI p, SingI g, Typeable p, Typeable g)+    => Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ]+    -> Instr ('Tc 'CKeyHash ':+              'TOption ('Tc 'CKeyHash) ':+              'Tc 'CBool ':+              'Tc 'CBool ':+              'Tc 'CMutez ':+               g ': s)+             ('TOperation ': 'Tc 'CAddress ': s)++  IMPLICIT_ACCOUNT+    :: Instr ('Tc 'CKeyHash ': s) ('TContract 'TUnit ': s)+  NOW :: Instr s ('Tc 'CTimestamp ': s)+  AMOUNT :: Instr s ('Tc 'CMutez ': s)+  BALANCE :: Instr s ('Tc 'CMutez ': s)+  CHECK_SIGNATURE+    :: Instr ('TKey ': 'TSignature ': 'Tc 'CBytes ': s)+                   ('Tc 'CBool ': s)+  SHA256 :: Instr ('Tc 'CBytes ': s) ('Tc 'CBytes ': s)+  SHA512 :: Instr ('Tc 'CBytes ': s) ('Tc 'CBytes ': s)+  BLAKE2B :: Instr ('Tc 'CBytes ': s) ('Tc 'CBytes ': s)+  HASH_KEY :: Instr ('TKey ': s) ('Tc 'CKeyHash ': s)+  STEPS_TO_QUOTA :: Instr s ('Tc 'CNat ': s)+  SOURCE :: Instr s ('Tc 'CAddress ': s)+  SENDER :: Instr s ('Tc 'CAddress ': s)+  ADDRESS :: Instr ('TContract a ': s) ('Tc 'CAddress ': s)++deriving instance Show (ExtT Instr) => Show (Instr inp out)++type Contract cp st = Instr (ContractInp cp st) (ContractOut st)
+ src/Michelson/Typed/Polymorphic.hs view
@@ -0,0 +1,225 @@+-- | Module, containing type classes for operating with Michelson values+-- in the context of polymorphic stack type operations.++module Michelson.Typed.Polymorphic+  ( EDivOp (..)+  , MemOp (..)+  , MapOp (..)+  , IterOp (..)+  , SizeOp (..)+  , GetOp (..)+  , UpdOp (..)+  , SliceOp (..)+  , ConcatOp (..)+  ) where++import qualified Data.ByteString as B+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T++import Michelson.Typed.CValue (CVal(..))+import Michelson.Typed.T (CT(..), T(..))+import Michelson.Typed.Value (Val(..))++import Tezos.Core (divModMutez, divModMutezInt)++class MemOp (c :: T) where+  type MemOpKey c :: CT+  evalMem :: CVal (MemOpKey c) -> Val cp c -> Bool+instance MemOp ('TSet e) where+  type MemOpKey ('TSet e) = e+  evalMem e (VSet s) = e `S.member` s+instance MemOp ('TMap k v) where+  type MemOpKey ('TMap k v) = k+  evalMem k (VMap m) = k `M.member` m+instance MemOp ('TBigMap k v) where+  type MemOpKey ('TBigMap k v) = k+  evalMem k (VBigMap m) = k `M.member` m++class MapOp (c :: T) (b :: T) where+  type MapOpInp c :: T+  type MapOpRes c b :: T+  mapOpToList :: Val instr c -> [Val instr (MapOpInp c)]+  mapOpFromList :: Val instr c -> [Val instr b] -> Val instr (MapOpRes c b)+instance MapOp ('TMap k v) v' where+  type MapOpInp ('TMap k v) = 'TPair ('Tc k) v+  type MapOpRes ('TMap k v) v' = 'TMap k v'+  mapOpToList (VMap m) = map (\(k, v) -> VPair (VC k, v)) $ M.toAscList m+  mapOpFromList (VMap m) l =+    VMap $ M.fromList $ zip (map fst $ M.toAscList m) l+instance MapOp ('TList e) e' where+  type MapOpInp ('TList e) = e+  type MapOpRes ('TList e) e' = 'TList e'+  mapOpToList (VList l) = l+  mapOpFromList (VList _) l' = VList l'++class IterOp (c :: T) where+  type IterOpEl c :: T+  iterOpDetachOne ::+    Val instr c -> (Maybe (Val instr (IterOpEl c)), Val instr c)+instance IterOp ('TMap k v) where+  type IterOpEl ('TMap k v) = 'TPair ('Tc k) v+  iterOpDetachOne (VMap m) =+    ((VPair . (\(k, v) -> (VC k, v))) <$> M.lookupMin m, VMap $ M.deleteMin m)+instance IterOp ('TList e) where+  type IterOpEl ('TList e) = e+  iterOpDetachOne (VList l) =+    case l of+      x : xs -> (Just x, VList xs)+      [] -> (Nothing, VList [])+instance IterOp ('TSet e) where+  type IterOpEl ('TSet e) = 'Tc e+  iterOpDetachOne (VSet s) = (VC <$> S.lookupMin s, VSet $ S.deleteMin s)++class SizeOp (c :: T) where+  evalSize :: Val cp c -> Int+instance SizeOp ('Tc 'CString) where+  evalSize (VC (CvString s)) = length s+instance SizeOp ('Tc 'CBytes) where+  evalSize (VC (CvBytes b)) = length b+instance SizeOp ('TSet a) where+  evalSize (VSet s) = S.size s+instance SizeOp ('TList a) where+  evalSize (VList l) = length l+instance SizeOp ('TMap k v) where+  evalSize (VMap m) = M.size m++class UpdOp (c :: T) where+  type UpdOpKey c :: CT+  type UpdOpParams c :: T+  evalUpd+    :: CVal (UpdOpKey c)+    -> Val cp (UpdOpParams c) -> Val cp c -> Val cp c+instance UpdOp ('TMap k v) where+  type UpdOpKey ('TMap k v) = k+  type UpdOpParams ('TMap k v) = 'TOption v+  evalUpd k (VOption o) (VMap m) =+    case o of+      Just newV -> VMap $ M.insert k newV m+      Nothing -> VMap $ M.delete k m+instance UpdOp ('TBigMap k v) where+  type UpdOpKey ('TBigMap k v) = k+  type UpdOpParams ('TBigMap k v) = 'TOption v+  evalUpd k (VOption o) (VBigMap m) =+    case o of+      Just newV -> VBigMap $ M.insert k newV m+      Nothing -> VBigMap $ M.delete k m+instance UpdOp ('TSet a) where+  type UpdOpKey ('TSet a) = a+  type UpdOpParams ('TSet a) = 'Tc 'CBool+  evalUpd k (VC (CvBool b)) (VSet s) =+    case b of+      True -> VSet $ S.insert k s+      False -> VSet $ S.delete k s++class GetOp (c :: T) where+  type GetOpKey c :: CT+  type GetOpVal c :: T+  evalGet :: CVal (GetOpKey c) -> Val cp c -> Maybe (Val cp (GetOpVal c))+instance GetOp ('TBigMap k v) where+  type GetOpKey ('TBigMap k v) = k+  type GetOpVal ('TBigMap k v) = v+  evalGet k (VBigMap m) = k `M.lookup` m+instance GetOp ('TMap k v) where+  type GetOpKey ('TMap k v) = k+  type GetOpVal ('TMap k v) = v+  evalGet k (VMap m) = k `M.lookup` m++class ConcatOp (c :: T) where+  evalConcat :: Val cp c -> Val cp c -> Val cp c+  evalConcat' :: [Val cp c] -> Val cp c+instance ConcatOp ('Tc 'CString) where+  evalConcat (VC (CvString s1)) (VC (CvString s2)) = (VC . CvString) (s1 <> s2)+  evalConcat' l =+    (VC . CvString . fromString) $ concat $ (map (\(VC (CvString s)) -> toString s)) l+instance ConcatOp ('Tc 'CBytes) where+  evalConcat (VC (CvBytes b1)) (VC (CvBytes b2)) = (VC . CvBytes) (b1 <> b2)+  evalConcat' l =+    (VC . CvBytes) $ foldr (<>) mempty (map (\(VC (CvBytes b)) -> b) l)+instance ConcatOp ('TList t) where+  evalConcat (VList l1) (VList l2) = VList $ l1 <> l2+  evalConcat' l =+    VList $ concat $ map (\(VList l') -> l') l++class SliceOp (c :: T) where+  evalSlice :: Natural -> Natural -> Val cp c -> Maybe (Val cp c)+instance SliceOp ('Tc 'CString) where+  evalSlice o l (VC (CvString s)) =+    if o > fromIntegral (length s) || o + l > fromIntegral (length s)+    then Nothing+    else (Just . VC . CvString . toText) $ sliceText o l s+    where+      sliceText :: Natural -> Natural -> Text -> Text+      sliceText o' l' s' =+        T.drop ((fromIntegral . toInteger) o') $+          T.take ((fromIntegral . toInteger) l') s'+instance SliceOp ('Tc 'CBytes) where+  evalSlice o l (VC (CvBytes b)) =+    if o > fromIntegral (length b) || o + l > fromIntegral (length b)+    then Nothing+    else (Just . VC . CvBytes) $ sliceBytes o l b+    where+      sliceBytes :: Natural -> Natural -> ByteString -> ByteString+      sliceBytes o' l' b' =+        B.drop ((fromIntegral . toInteger) o') $+          B.take ((fromIntegral . toInteger) l') b'++class EDivOp (n :: CT) (m :: CT) where+  type EDivOpRes n m :: CT+  type EModOpRes n m :: CT+  evalEDivOp+    :: CVal n+    -> CVal m+    -> Val instr ('TOption ('TPair ('Tc (EDivOpRes n m))+                                     ('Tc (EModOpRes n m))))++instance EDivOp 'CInt 'CInt where+  type EDivOpRes 'CInt 'CInt = 'CInt+  type EModOpRes 'CInt 'CInt = 'CNat+  evalEDivOp (CvInt i) (CvInt j) =+    if j == 0+      then VOption $ Nothing+      else VOption $ Just $+        VPair (VC $ CvInt (div i j), VC $ CvNat $ fromInteger (mod i j))+instance EDivOp 'CInt 'CNat where+  type EDivOpRes 'CInt 'CNat = 'CInt+  type EModOpRes 'CInt 'CNat = 'CNat+  evalEDivOp (CvInt i) (CvNat j) =+    if j == 0+      then VOption $ Nothing+      else VOption $ Just $+        VPair (VC $ CvInt (div i (toInteger j)), VC $ CvNat $ (mod (fromInteger i) j))+instance EDivOp 'CNat 'CInt where+  type EDivOpRes 'CNat 'CInt = 'CInt+  type EModOpRes 'CNat 'CInt = 'CNat+  evalEDivOp (CvNat i) (CvInt j) =+    if j == 0+      then VOption $ Nothing+      else VOption $ Just $+        VPair (VC $ CvInt (div (toInteger i) j), VC $ CvNat $ (mod i (fromInteger j)))+instance EDivOp 'CNat 'CNat where+  type EDivOpRes 'CNat 'CNat = 'CNat+  type EModOpRes 'CNat 'CNat = 'CNat+  evalEDivOp (CvNat i) (CvNat j) =+    if j == 0+      then VOption $ Nothing+      else VOption $ Just $+        VPair (VC $ CvNat (div i j), VC $ CvNat $ (mod i j))+instance EDivOp 'CMutez 'CMutez where+  type EDivOpRes 'CMutez 'CMutez = 'CNat+  type EModOpRes 'CMutez 'CMutez = 'CMutez+  evalEDivOp (CvMutez i) (CvMutez j) =+    VOption $+    i `divModMutez` j <&> \case+      (quotient, remainder) ->+        VPair (VC $ CvNat (fromIntegral quotient), VC $ CvMutez remainder)++instance EDivOp 'CMutez 'CNat where+  type EDivOpRes 'CMutez 'CNat = 'CMutez+  type EModOpRes 'CMutez 'CNat = 'CMutez+  evalEDivOp (CvMutez i) (CvNat j) =+    VOption $+    i `divModMutezInt` j <&> \case+      (quotient, remainder) ->+        VPair (VC $ CvMutez quotient, VC $ CvMutez remainder)
+ src/Michelson/Typed/Sing.hs view
@@ -0,0 +1,229 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Module, providing singleton boilerplate for+-- 'T' and 'CT' data types.+--+-- Some functions from Data.Singletons are provided alternative version here.+-- Some instances which are usually generated with TH are manually implemented+-- as they require some specific constraints, namely 'Typeable' and/or+-- 'Converge', not provided in instances generated by TH.++module Michelson.Typed.Sing+  (+    Sing (..)+  , withSomeSingT+  , withSomeSingCT+  , fromSingT+  , fromSingCT+  ) where++import Data.Kind (Type)+import Data.Singletons (Sing(..), SingI(..))++import Michelson.Typed.T (CT(..), T(..))++-- | Instance of data family 'Sing' for 'CT'.+data instance Sing :: CT -> Type where+  SCInt :: Sing  'CInt+  SCNat :: Sing  'CNat+  SCString :: Sing  'CString+  SCBytes :: Sing  'CBytes+  SCMutez :: Sing  'CMutez+  SCBool :: Sing  'CBool+  SCKeyHash :: Sing  'CKeyHash+  SCTimestamp :: Sing  'CTimestamp+  SCAddress :: Sing  'CAddress++-- | Instance of data family 'Sing' for 'T'.+-- Custom instance is implemented in order to inject 'Typeable'+-- constraint for some of constructors.+data instance Sing :: T -> Type where+  STc :: (SingI a, Typeable a) => Sing a -> Sing ( 'Tc a)+  STKey :: Sing  'TKey+  STUnit :: Sing  'TUnit+  STSignature :: Sing  'TSignature+  STOption :: (SingI a, Typeable a) => Sing a -> Sing ( 'TOption a)+  STList :: (SingI a, Typeable a) => Sing a -> Sing ( 'TList a )+  STSet :: (SingI a, Typeable a) => Sing a -> Sing ( 'TSet a )+  STOperation  :: Sing 'TOperation+  STContract   :: (SingI a, Typeable a)+                => Sing a -> Sing ( 'TContract a )+  STPair       :: (SingI a, SingI b, Typeable a, Typeable b)+                => Sing a -> Sing b -> Sing ('TPair a b)+  STOr         :: (SingI a, SingI b, Typeable a, Typeable b)+                => Sing a -> Sing b -> Sing ('TOr a b)+  STLambda     :: (SingI a, SingI b, Typeable a, Typeable b)+                => Sing a -> Sing b -> Sing ('TLambda a b)+  STMap        :: (SingI a, SingI b, Typeable a, Typeable b)+                => Sing a -> Sing b -> Sing ('TMap a b)+  STBigMap    :: (SingI a, SingI b, Typeable a, Typeable b)+                => Sing a -> Sing b -> Sing ('TBigMap a b)++---------------------------------------------+-- Singleton-related instances for CT+---------------------------------------------++-- | Version of 'SomeSing' with 'Typeable' constraint,+-- specialized for use with 'CT' kind.+data SomeSingCT where+  SomeSingCT :: forall (a :: CT). (SingI a, Typeable a) => Sing a -> SomeSingCT++-- | Version of 'withSomeSing' with 'Typeable' constraint+-- provided to processing function.+--+-- Required for not to erase this useful constraint when doing+-- conversion from value of type 'CT' to its singleton representation.+withSomeSingCT+  :: CT -> (forall (a :: CT). (SingI a, Typeable a) => Sing a -> r) -> r+withSomeSingCT ct f = (\(SomeSingCT s) -> f s) (toSingCT ct)++fromSingCT :: Sing (a :: CT) -> CT+fromSingCT SCInt = CInt+fromSingCT SCNat = CNat+fromSingCT SCString = CString+fromSingCT SCBytes = CBytes+fromSingCT SCMutez = CMutez+fromSingCT SCBool = CBool+fromSingCT SCKeyHash = CKeyHash+fromSingCT SCTimestamp = CTimestamp+fromSingCT SCAddress = CAddress++-- | Version of 'toSing' which creates 'SomeSingCT'.+toSingCT :: CT -> SomeSingCT+toSingCT CInt = SomeSingCT SCInt+toSingCT CNat = SomeSingCT SCNat+toSingCT CString = SomeSingCT SCString+toSingCT CBytes = SomeSingCT SCBytes+toSingCT CMutez = SomeSingCT SCMutez+toSingCT CBool = SomeSingCT SCBool+toSingCT CKeyHash = SomeSingCT SCKeyHash+toSingCT CTimestamp = SomeSingCT SCTimestamp+toSingCT CAddress = SomeSingCT SCAddress++instance SingI  'CInt where+  sing = SCInt+instance SingI  'CNat where+  sing = SCNat+instance SingI  'CString where+  sing = SCString+instance SingI  'CBytes where+  sing = SCBytes+instance SingI  'CMutez where+  sing = SCMutez+instance SingI  'CBool where+  sing = SCBool+instance SingI  'CKeyHash where+  sing = SCKeyHash+instance SingI  'CTimestamp where+  sing = SCTimestamp+instance SingI  'CAddress where+  sing = SCAddress++---------------------------------------------+-- Singleton-related helpers for T+--------------------------------------------+++-- | Version of 'SomeSing' with 'Typeable' constraint,+-- specialized for use with 'T' kind.+data SomeSingT where+  SomeSingT :: forall (a :: T). (Typeable a, SingI a)+            => Sing a -> SomeSingT++-- | Version of 'withSomeSing' with 'Typeable' constraint+-- provided to processing function.+--+-- Required for not to erase these useful constraints when doing+-- conversion from value of type 'T' to its singleton representation.+withSomeSingT+  :: T+  -> (forall (a :: T). (Typeable a, SingI a) => Sing a -> r)+  -> r+withSomeSingT t f = (\(SomeSingT s) -> f s) (toSingT t)++-- | Version of 'fromSing' specialized for use with+-- @data instance Sing :: T -> Type@ which requires 'Typeable'+-- constraint for some of its constructors+fromSingT :: Sing (a :: T) -> T+fromSingT (STc t) = Tc (fromSingCT t)+fromSingT STKey = TKey+fromSingT STUnit = TUnit+fromSingT STSignature = TSignature+fromSingT (STOption t) = TOption (fromSingT t)+fromSingT (STList t) = TList (fromSingT t)+fromSingT (STSet t) = TSet (fromSingCT t)+fromSingT STOperation = TOperation+fromSingT (STContract t) = TContract (fromSingT t)+fromSingT (STPair a b) = TPair (fromSingT a) (fromSingT b)+fromSingT (STOr a b) = TOr (fromSingT a) (fromSingT b)+fromSingT (STLambda a b) = TLambda (fromSingT a) (fromSingT b)+fromSingT (STMap a b) = TMap (fromSingCT a) (fromSingT b)+fromSingT (STBigMap a b) = TBigMap (fromSingCT a) (fromSingT b)++-- | Version of 'toSing' which creates 'SomeSingT'.+toSingT :: T -> SomeSingT+toSingT (Tc ct) = withSomeSingCT ct $ \ctSing -> SomeSingT $ STc ctSing+toSingT TKey = SomeSingT STKey+toSingT TUnit = SomeSingT STUnit+toSingT TSignature = SomeSingT STSignature+toSingT (TOption t) = withSomeSingT t $ \tSing -> SomeSingT $ STOption tSing+toSingT (TList t) = withSomeSingT t $ \tSing -> SomeSingT $ STList tSing+toSingT (TSet ct) = withSomeSingCT ct $ \ctSing -> SomeSingT $ STSet ctSing+toSingT TOperation = SomeSingT STOperation+toSingT (TContract t) =+  withSomeSingT t $ \tSing -> SomeSingT $ STContract tSing+toSingT (TPair l r) =+  withSomeSingT l $ \lSing ->+  withSomeSingT r $ \rSing ->+    SomeSingT $ STPair lSing rSing+toSingT (TOr l r) =+  withSomeSingT l $ \lSing ->+  withSomeSingT r $ \rSing ->+    SomeSingT $ STOr lSing rSing+toSingT (TLambda l r) =+  withSomeSingT l $ \lSing ->+  withSomeSingT r $ \rSing ->+    SomeSingT $ STLambda lSing rSing+toSingT (TMap l r) =+  withSomeSingCT l $ \lSing ->+  withSomeSingT r $ \rSing ->+    SomeSingT $ STMap lSing rSing+toSingT (TBigMap l r) =+  withSomeSingCT l $ \lSing ->+  withSomeSingT r $ \rSing ->+    SomeSingT $ STBigMap lSing rSing++instance (SingI t, Typeable t) => SingI ( 'Tc (t :: CT)) where+  sing = STc sing+instance SingI  'TKey where+  sing = STKey+instance SingI  'TUnit where+  sing = STUnit+instance SingI  'TSignature where+  sing = STSignature+instance (SingI a, Typeable a) => SingI ( 'TOption (a :: T)) where+  sing = STOption sing+instance (SingI a, Typeable a) => SingI ( 'TList (a :: T)) where+  sing = STList sing+instance (SingI a, Typeable a) => SingI ( 'TSet (a :: CT)) where+  sing = STSet sing+instance SingI 'TOperation where+  sing = STOperation+instance (SingI a, Typeable a) =>+          SingI ( 'TContract (a :: T)) where+  sing = STContract sing+instance (SingI a, Typeable a, Typeable b, SingI b) =>+          SingI ( 'TPair a b) where+  sing = STPair sing sing+instance (SingI a, Typeable a, Typeable b, SingI b) =>+          SingI ( 'TOr a b) where+  sing = STOr sing sing+instance (SingI a, Typeable a, Typeable b, SingI b) =>+          SingI ( 'TLambda a b) where+  sing = STLambda sing sing+instance (SingI a, Typeable a, Typeable b, SingI b) =>+          SingI ( 'TMap a b) where+  sing = STMap sing sing+instance (SingI a, Typeable a, Typeable b, SingI b) =>+          SingI ( 'TBigMap a b) where+  sing = STBigMap sing sing
+ src/Michelson/Typed/T.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DataKinds #-}++-- | Module, providing 'CT' and 'T' data types, representing Michelson+-- language types without annotations.+module Michelson.Typed.T+  ( CT (..)+  , T (..)+  , ToCT+  , ToT+  ) where++import Michelson.Untyped.Type (CT(..), ToCT)+import Tezos.Address (Address)+import Tezos.Core (Mutez, Timestamp)+import Tezos.Crypto (KeyHash, PublicKey, Signature)++-- | Michelson language type with annotations stripped off.+data T =+    Tc CT+  | TKey+  | TUnit+  | TSignature+  | TOption T+  | TList T+  | TSet CT+  | TOperation+  | TContract T+  | TPair T T+  | TOr T T+  | TLambda T T+  | TMap CT T+  | TBigMap CT T+  deriving (Eq, Show)++-- | Type function that converts a regular Haskell type into a @T@ type.+-- TODO: what should be done with 'TBigMap'?+type family ToT t :: T where+  ToT Integer = 'Tc (ToCT Integer)+  ToT Int = 'Tc (ToCT Int)+  ToT Natural = 'Tc (ToCT Natural)+  ToT Word64 = 'Tc (ToCT Word64)+  ToT Text = 'Tc (ToCT Text)+  ToT Bool = 'Tc (ToCT Bool)+  ToT ByteString = 'Tc (ToCT ByteString)+  ToT Mutez = 'Tc (ToCT Mutez)+  ToT Address = 'Tc (ToCT Address)+  ToT KeyHash = 'Tc (ToCT KeyHash)+  ToT Timestamp = 'Tc (ToCT Timestamp)++  ToT () = 'TUnit+  ToT (a, b) = 'TPair (ToT a) (ToT b)+  ToT [a] = 'TList (ToT a)+  ToT (Maybe a) = 'TOption (ToT a)+  ToT (Either a b) = 'TOr (ToT a) (ToT b)+  ToT (Set k) = 'TSet (ToCT k)+  ToT (Map k v) = 'TMap (ToCT k) (ToT v)+  ToT PublicKey = 'TKey+  ToT Signature = 'TSignature
+ src/Michelson/Typed/Value.hs view
@@ -0,0 +1,258 @@+-- | Module, containing data types for Michelson value.++module Michelson.Typed.Value+  ( Val (..)+  , ContractInp+  , ContractOut+  , CreateAccount (..)+  , CreateContract (..)+  , CVal (..)+  , Operation (..)+  , SetDelegate (..)+  , TransferTokens (..)+  , ToVal+  , FromVal+  , toVal+  , fromVal+  ) where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Singletons (SingI)++import Michelson.EqParam+import Michelson.Typed.CValue (CVal(..), FromCVal, ToCVal, fromCVal, toCVal)+import Michelson.Typed.T (T(..), ToT)+import Tezos.Address (Address)+import Tezos.Core (Mutez, Timestamp)+import Tezos.Crypto (KeyHash, PublicKey, Signature)++-- | Data type, representing operation, list of which is returned+-- by Michelson contract (according to calling convention).+--+-- These operations are to be further executed against system state+-- after the contract execution.+data Operation instr where+  OpTransferTokens :: Typeable p => TransferTokens instr p -> Operation instr+  OpSetDelegate :: SetDelegate -> Operation instr+  OpCreateAccount :: CreateAccount -> Operation instr+  OpCreateContract+    :: ( Show (instr (ContractInp cp st) (ContractOut st)), SingI cp, SingI st+       , Typeable t, Typeable cp, Typeable st)+    => CreateContract instr t cp st+    -> Operation instr++deriving instance Show (Operation instr)+instance Eq (Operation instr) where+  op1 == op2 = case (op1, op2) of+    (OpTransferTokens tt1, OpTransferTokens tt2) -> eqParam1 tt1 tt2+    (OpTransferTokens _, _) -> False+    (OpSetDelegate sd1, OpSetDelegate sd2) -> sd1 == sd2+    (OpSetDelegate _, _) -> False+    (OpCreateAccount ca1, OpCreateAccount ca2) -> ca1 == ca2+    (OpCreateAccount _, _) -> False+    (OpCreateContract cc1, OpCreateContract cc2) -> eqParam3 cc1 cc2+    (OpCreateContract _, _) -> False++data TransferTokens instr p = TransferTokens+  { ttContractParameter :: !(Val instr p)+  , ttAmount :: !Mutez+  , ttContract :: !(Val instr ('TContract p))+  } deriving (Show, Eq)++data SetDelegate = SetDelegate+  { sdMbKeyHash :: !(Maybe KeyHash)+  } deriving (Show, Eq)++data CreateAccount = CreateAccount+  { caManager :: !KeyHash+  , caDelegate :: !(Maybe KeyHash)+  , caSpendable :: !Bool+  , caBalance :: !Mutez+  } deriving (Show, Eq)++data CreateContract instr t cp st+  = ( Show (instr (ContractInp cp st) (ContractOut st))+    , Eq (instr (ContractInp cp st) (ContractOut st))+    )+  => CreateContract+  { ccManager :: !KeyHash+  , ccDelegate :: !(Maybe KeyHash)+  , ccSpendable :: !Bool+  , ccDelegatable :: !Bool+  , ccBalance :: !Mutez+  , ccStorageVal :: !(Val instr t)+  , ccContractCode :: !(instr (ContractInp cp st) (ContractOut st))+  }++deriving instance Show (CreateContract instr t cp st)+deriving instance Eq (CreateContract instr t cp st)++type ContractInp param st = '[ 'TPair param st ]+type ContractOut st = '[ 'TPair ('TList 'TOperation) st ]++-- | Representation of Michelson value.+--+-- Type parameter @instr@ stands for Michelson instruction+-- type, i.e. data type to represent an instruction of language.+data Val instr t where+  VC :: CVal t -> Val instr ('Tc t)+  VKey :: PublicKey -> Val instr 'TKey+  VUnit :: Val instr 'TUnit+  VSignature :: Signature -> Val instr 'TSignature+  VOption :: Maybe (Val instr t) -> Val instr ('TOption t)+  VList :: [Val instr t] -> Val instr ('TList t)+  VSet :: Set (CVal t) -> Val instr ('TSet t)+  VOp :: Operation instr -> Val instr 'TOperation+  VContract :: Address -> Val instr ('TContract p)+  VPair :: (Val instr l, Val instr r) -> Val instr ('TPair l r)+  VOr :: Either (Val instr l) (Val instr r) -> Val instr ('TOr l r)+  VLam+    :: ( Show (instr '[inp] '[out])+       , Eq (instr '[inp] '[out])+       )+    => instr (inp ': '[]) (out ': '[]) -> Val instr ('TLambda inp out)+  VMap :: Map (CVal k) (Val instr v) -> Val instr ('TMap k v)+  VBigMap :: Map (CVal k) (Val instr v) -> Val instr ('TBigMap k v)++deriving instance Show (Val instr t)+deriving instance Eq (Val instr t)++-- TODO: actually we should handle big maps with something close+-- to following:+--+--  VBigMap :: BigMap op ref k v -> Val cp ('TBigMap k v)+--+-- data ValueOp v+--     = New v+--     | Upd v+--     | Rem+--     | NotExisted+--+-- data BigMap op ref k v = BigMap+--  { bmRef :: ref k v, bmChanges :: Map (CVal k) (ValueOp (Val cp v)) }+++-- | Converts a complex Haskell structure into @Val@ representation.+class ToVal a where+  toVal :: a -> Val instr (ToT a)++-- | Converts a @Val@ value into complex Haskell type.+class FromVal t where+  fromVal :: Val instr (ToT t) -> t++-- ToVal / FromVal instances++-- @gromak: we can write the following code instead of these+-- instances below, but I am not sure whether it's a good idea.+-- Note: if it breaks compilation for you, try to clean and+-- rebuild from scratch. It seems to compile fine.+-- instance {-# OVERLAPPABLE #-} ('Tc (ToCT t) ~ ToT t, FromCVal t) => FromVal t where+--   fromVal (VC cval) = fromCVal cval++instance FromVal Integer where+  fromVal (VC cval) = fromCVal cval++instance FromVal Natural where+  fromVal (VC cval) = fromCVal cval++instance FromVal Text where+  fromVal (VC cval) = fromCVal cval++instance FromVal Bool where+  fromVal (VC cval) = fromCVal cval++instance FromVal ByteString where+  fromVal (VC cval) = fromCVal cval++instance FromVal Mutez where+  fromVal (VC cval) = fromCVal cval++instance FromVal KeyHash where+  fromVal (VC cval) = fromCVal cval++instance FromVal Timestamp where+  fromVal (VC cval) = fromCVal cval++instance FromVal Address where+  fromVal (VC cval) = fromCVal cval++instance FromVal () where+  fromVal VUnit = ()++instance FromVal a => FromVal [a] where+  fromVal (VList lVals) = map fromVal lVals++instance FromVal a => FromVal (Maybe a) where+  fromVal (VOption Nothing) = Nothing+  fromVal (VOption (Just val)) = Just $ fromVal val++instance (FromVal a, FromVal b) => FromVal (Either a b) where+  fromVal (VOr (Left l)) = Left $ fromVal l+  fromVal (VOr (Right r)) = Right $ fromVal r++instance (FromVal a, FromVal b) => FromVal (a, b) where+  fromVal (VPair (a, b)) = (fromVal a, fromVal b)++instance (Ord k, FromCVal k) => FromVal (Set k) where+  fromVal (VSet s) = Set.map fromCVal s++instance (Ord k, FromCVal k, FromVal a) => FromVal (Map k a) where+  fromVal (VMap m) = Map.map fromVal $ Map.mapKeys fromCVal m++instance ToVal () where+  toVal _ = VUnit++instance ToVal Integer where+  toVal = VC . toCVal++instance ToVal Int where+  toVal = VC . toCVal++instance ToVal Word64 where+  toVal = VC . toCVal++instance ToVal Natural where+  toVal = VC . toCVal++instance ToVal Text where+  toVal = VC . toCVal++instance ToVal ByteString where+  toVal = VC . toCVal++instance ToVal Bool where+  toVal = VC . toCVal++instance ToVal Mutez where+  toVal = VC . toCVal++instance ToVal KeyHash where+  toVal = VC . toCVal++instance ToVal Timestamp where+  toVal = VC . toCVal++instance ToVal Address where+  toVal = VC . toCVal++instance ToVal a => ToVal (Maybe a) where+  toVal Nothing = VOption Nothing+  toVal (Just a) = VOption (Just $ toVal a)++instance (ToVal a, ToVal b) => ToVal (Either a b) where+  toVal (Left l) = VOr $ Left $ toVal l+  toVal (Right r) = VOr $ Right $ toVal r++instance (ToVal a, ToVal b) => ToVal (a, b) where+  toVal (l, r) = VPair (toVal l, toVal r)++instance ToVal x => ToVal [x] where+  toVal = VList . map toVal++instance ToCVal k => ToVal (Set k) where+  toVal = VSet . Set.map toCVal++-- Note: the instance produces Map not BigMap+instance (ToCVal k, ToVal a) => ToVal (Map k a) where+  toVal = VMap . Map.mapKeys toCVal . Map.map toVal
+ src/Michelson/Untyped.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Michelson/Untyped/Annotation.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++-- | Michelson annotations in untyped model.++module Michelson.Untyped.Annotation+  ( Annotation (..)+  , pattern WithAnn+  , TypeAnn+  , FieldAnn+  , VarAnn+  , noAnn+  , ann+  , unifyAnn+  , ifAnnUnified+  , disjoinVn+  , convAnn+  ) where++import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Data (Data(..))+import Data.Default (Default(..))+import qualified Data.Text as T+import Fmt (Buildable(build), Builder, (+|), (|+))+import qualified Text.Show++newtype Annotation tag = Annotation T.Text+  deriving stock (Eq, Data, Functor, Generic)+  deriving newtype (IsString)++instance Default (Annotation tag) where+  def = Annotation ""++instance Show (Annotation FieldTag) where+  show (Annotation x) = "%" <> toString x++instance Show (Annotation VarTag) where+  show (Annotation x) = "@" <> toString x++instance Show (Annotation TypeTag) where+  show (Annotation x) = ":" <> toString x++data TypeTag+data FieldTag+data VarTag++type TypeAnn = Annotation TypeTag+type FieldAnn = Annotation FieldTag+type VarAnn = Annotation VarTag++instance Buildable TypeAnn where+  build = buildAnnotation ":"++instance Buildable FieldAnn where+  build = buildAnnotation "%"++instance Buildable VarAnn where+  build = buildAnnotation "@"++buildAnnotation :: Builder -> Annotation tag -> Builder+buildAnnotation prefix a@(Annotation text)+  | a == noAnn = ""+  | otherwise = prefix +| text |+ ""++noAnn :: Annotation a+noAnn = Annotation ""++ann :: T.Text -> Annotation a+ann = Annotation++instance Semigroup VarAnn where+  Annotation a <> Annotation b+    | a == "" || b == "" = ann $ a <> b+    | otherwise          = ann $ a <> "." <> b++instance Monoid VarAnn where+    mempty = noAnn++unifyAnn :: Annotation tag -> Annotation tag -> Maybe (Annotation tag)+unifyAnn (Annotation ann1) (Annotation ann2)+  | ann1 == "" || ann2 == "" = Just $ ann $ ann1 <> ann2+  | ann1 == ann2 = Just $ ann ann1+  | otherwise  = Nothing++ifAnnUnified :: Annotation tag -> Annotation tag -> Bool+ifAnnUnified a1 a2 = isJust $ a1 `unifyAnn` a2++disjoinVn :: VarAnn -> (VarAnn, VarAnn)+disjoinVn (Annotation a) = case T.findIndex (== '.') $ T.reverse a of+  Just ((n - 1 -) -> pos) -> (ann $ T.take pos a, ann $ T.drop (pos + 1) a)+  Nothing                 -> (noAnn, ann a)+  where+    n = T.length a++convAnn :: Annotation tag1 -> Annotation tag2+convAnn (Annotation a) = Annotation a++pattern WithAnn :: Annotation tag -> Annotation tag+pattern WithAnn ann <- ann@(Annotation (toString -> _:_))++deriveJSON defaultOptions ''Annotation
+ src/Michelson/Untyped/Contract.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++-- | Michelson contract in untyped model.++module Michelson.Untyped.Contract+  ( Parameter+  , Storage+  , Contract (..)+  ) where++import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Data (Data(..))+import Fmt (genericF)+import Formatting.Buildable (Buildable(build))++import Michelson.Untyped.Type (Type)++type Parameter = Type+type Storage = Type+data Contract op = Contract+  { para :: Parameter+  , stor :: Storage+  , code :: [op]+  } deriving stock (Eq, Show, Functor, Data, Generic)++instance Buildable op => Buildable (Contract op) where+  build = genericF++deriveJSON defaultOptions ''Contract
+ src/Michelson/Untyped/Instr.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++-- | Michelson instructions in untyped model.++module Michelson.Untyped.Instr+  ( InstrAbstract (..)+  , Instr+  , Op (..)+  , ExtU+  , InstrExtU++  -- * Contract's address+  , OriginationOperation (..)+  , mkContractAddress+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as BSL+import Data.Data (Data(..))+import qualified Data.Kind as K+import Formatting.Buildable (Buildable)++import Michelson.Untyped.Annotation (FieldAnn, TypeAnn, VarAnn)+import Michelson.Untyped.Contract (Contract)+import Michelson.Untyped.Type (Comparable, Type)+import Michelson.Untyped.Value (Value)+import Tezos.Address (Address, mkContractAddressRaw)+import Tezos.Core (Mutez)+import Tezos.Crypto (KeyHash)++-------------------------------------+-- Flattened types after macroexpander+-------------------------------------+type InstrExtU = ExtU InstrAbstract Op+type Instr = InstrAbstract Op+newtype Op = Op {unOp :: Instr}+  deriving stock (Generic)++deriving instance Eq (ExtU InstrAbstract Op) => Eq Op+deriving instance Show (ExtU InstrAbstract Op) => Show Op+deriving instance Buildable Instr => Buildable Op++-------------------------------------+-- Abstract instruction+-------------------------------------++-- | ExtU is extension of InstrAbstract by Morley instructions+type family ExtU (instr :: K.Type -> K.Type) :: K.Type -> K.Type++-- | Michelson instruction with abstract parameter `op`.  This+-- parameter is necessary, because at different stages of our pipeline+-- it will be different. Initially it can contain macros and+-- non-flattened instructions, but then it contains only vanilla+-- Michelson instructions.+data InstrAbstract op+  = EXT               (ExtU InstrAbstract op)+  | DROP+  | DUP               VarAnn+  | SWAP+  | PUSH              VarAnn Type (Value op)+  | SOME              TypeAnn VarAnn FieldAnn+  | NONE              TypeAnn VarAnn FieldAnn Type+  | UNIT              TypeAnn VarAnn+  | IF_NONE           [op] [op]+  | PAIR              TypeAnn VarAnn FieldAnn FieldAnn+  | CAR               VarAnn FieldAnn+  | CDR               VarAnn FieldAnn+  | LEFT              TypeAnn VarAnn FieldAnn FieldAnn Type+  | RIGHT             TypeAnn VarAnn FieldAnn FieldAnn Type+  | IF_LEFT           [op] [op]+  | IF_RIGHT          [op] [op]+  | NIL               TypeAnn VarAnn Type+  | CONS              VarAnn -- TODO add TypeNote param+  | IF_CONS           [op] [op]+  | SIZE              VarAnn+  | EMPTY_SET         TypeAnn VarAnn Comparable+  | EMPTY_MAP         TypeAnn VarAnn Comparable Type+  | MAP               VarAnn [op]+  | ITER              [op]+  | MEM               VarAnn+  | GET               VarAnn+  | UPDATE+  | IF                [op] [op]+  | LOOP              [op]+  | LOOP_LEFT         [op]+  | LAMBDA            VarAnn Type Type [op]+  -- TODO check on alphanet whether we can pass TypeNote+  | EXEC              VarAnn+  | DIP               [op]+  | FAILWITH+  | CAST              VarAnn Type+  | RENAME            VarAnn+  | PACK              VarAnn+  | UNPACK            VarAnn Type+  | CONCAT            VarAnn+  | SLICE             VarAnn+  | ISNAT             VarAnn+  | ADD               VarAnn+  | SUB               VarAnn+  | MUL               VarAnn+  | EDIV              VarAnn+  | ABS               VarAnn+  -- TODO why no varnote for NEG+  | NEG+  | LSL               VarAnn+  | LSR               VarAnn+  | OR                VarAnn+  | AND               VarAnn+  | XOR               VarAnn+  | NOT               VarAnn+  | COMPARE           VarAnn+  | EQ                VarAnn+  | NEQ               VarAnn+  | LT                VarAnn+  | GT                VarAnn+  | LE                VarAnn+  | GE                VarAnn+  | INT               VarAnn+  | SELF              VarAnn+  | CONTRACT          VarAnn Type+  | TRANSFER_TOKENS   VarAnn+  | SET_DELEGATE      VarAnn+  | CREATE_ACCOUNT    VarAnn VarAnn+  | CREATE_CONTRACT   VarAnn VarAnn+  | CREATE_CONTRACT2  VarAnn VarAnn (Contract op)+  | IMPLICIT_ACCOUNT  VarAnn+  | NOW               VarAnn+  | AMOUNT            VarAnn+  | BALANCE           VarAnn+  | CHECK_SIGNATURE   VarAnn+  | SHA256            VarAnn+  | SHA512            VarAnn+  | BLAKE2B           VarAnn+  | HASH_KEY          VarAnn+  | STEPS_TO_QUOTA    VarAnn+  | SOURCE            VarAnn+  | SENDER            VarAnn+  | ADDRESS           VarAnn+  deriving (Generic)++deriving instance (Eq op, Eq (ExtU InstrAbstract op)) => Eq (InstrAbstract op)+deriving instance (Show op, Show (ExtU InstrAbstract op)) => Show (InstrAbstract op)+deriving instance Functor (ExtU InstrAbstract) => Functor InstrAbstract+deriving instance (Data op, Data (ExtU InstrAbstract op)) => Data (InstrAbstract op)++-- deriving instance (Buildable op, Buildable (ExtU InstrAbstract op)) => Buildable (InstrAbstract op)+-- instance Buildable op => Buildable (InstrAbstract op) where+--   build = genericF++----------------------------------------------------------------------------+-- Contract's address computation+--+-- Note: it might be a bit weird place for this functionality, but it's the+-- lowest layer where all necessary Michelson types are defined. We may+-- reconsider it later.+----------------------------------------------------------------------------++-- | Data necessary to originate a contract.+data OriginationOperation = OriginationOperation+  { ooManager :: !KeyHash+  -- ^ Manager of the contract.+  , ooDelegate :: !(Maybe KeyHash)+  -- ^ Optional delegate.+  , ooSpendable :: !Bool+  -- ^ Whether the contract is spendable.+  , ooDelegatable :: !Bool+  -- ^ Whether the contract is delegatable.+  , ooBalance :: !Mutez+  -- ^ Initial balance of the contract.+  , ooStorage :: !(Value Op)+  -- ^ Initial storage value of the contract.+  , ooContract :: !(Contract Op)+  -- ^ The contract itself.+  } deriving (Generic)++deriving instance Show (ExtU InstrAbstract Op) => Show OriginationOperation++-- | Compute address of a contract from its origination operation.+--+-- TODO [TM-62] It's certainly imprecise, real Tezos implementation doesn't+-- use JSON, but we don't need precise format yet, so we just use some+-- serialization format (JSON because we have necessary instances already).+mkContractAddress :: Aeson.ToJSON InstrExtU => OriginationOperation -> Address+mkContractAddress = mkContractAddressRaw . BSL.toStrict . Aeson.encode++----------------------------------------------------------------------------+-- JSON serialization+----------------------------------------------------------------------------++instance Aeson.ToJSON Instr => Aeson.ToJSON Op+instance Aeson.FromJSON Instr => Aeson.FromJSON Op+instance (Aeson.ToJSON op, Aeson.ToJSON (ExtU InstrAbstract op)) => Aeson.ToJSON (InstrAbstract op)+instance (Aeson.FromJSON op, Aeson.FromJSON (ExtU InstrAbstract op)) => Aeson.FromJSON (InstrAbstract op)+instance Aeson.FromJSON Op => Aeson.FromJSON OriginationOperation+instance Aeson.ToJSON Op => Aeson.ToJSON OriginationOperation
+ src/Michelson/Untyped/Type.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++-- | Michelson types represented in untyped model.++module Michelson.Untyped.Type+  ( Type (..)+  , Comparable (..)+  , compToType+  , typeToComp+  , T (..)+  , CT (..)+  , ToCT+  , pattern Tint+  , pattern Tnat+  , pattern Tstring+  , pattern Tbytes+  , pattern Tmutez+  , pattern Tbool+  , pattern Tkey_hash+  , pattern Ttimestamp+  , pattern Taddress+  , tint+  , tnat+  , tstring+  , tbytes+  , tmutez+  , tbool+  , tkeyHash+  , ttimestamp+  , taddress+  , isAtomicType+  , isKey+  , isSignature+  , isComparable+  , isMutez+  , isKeyHash+  , isBool+  , isString+  , isInteger+  , isTimestamp+  , isNat+  , isInt+  , isBytes+  ) where++import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Data (Data(..))+import Data.Text.Lazy.Builder (Builder)+import Fmt ((+|), (|+))+import Formatting.Buildable (Buildable(build))++import Michelson.Untyped.Annotation+import Tezos.Address (Address)+import Tezos.Core (Mutez, Timestamp)+import Tezos.Crypto (KeyHash)++-- Annotated type+data Type = Type T TypeAnn+  deriving (Eq, Show, Data, Generic)++instance Buildable Type where+  build (Type t a) = t |+ " " +| a |+ ""++-- Annotated Comparable Sub-type+data Comparable = Comparable CT TypeAnn+  deriving (Eq, Show, Data, Generic)++instance Buildable Comparable where+  build (Comparable ct a)+    | a == noAnn = build ct+    | otherwise = ct |+ " " +| a |+ ""++compToType :: Comparable -> Type+compToType (Comparable ct tn) = Type (Tc ct) tn++typeToComp :: Type -> Maybe Comparable+typeToComp (Type (Tc ct) tn) = Just $ Comparable ct tn+typeToComp _ = Nothing++-- Michelson Type+data T =+    Tc CT+  | TKey+  | TUnit+  | TSignature+  | TOption FieldAnn Type+  | TList Type+  | TSet Comparable+  | TOperation+  | TContract Type+  | TPair FieldAnn FieldAnn Type Type+  | TOr FieldAnn FieldAnn Type Type+  | TLambda Type Type+  | TMap Comparable Type+  | TBigMap Comparable Type+  deriving (Eq, Show, Data, Generic)++instance Buildable T where+  build =+    \case+      Tc ct -> build ct+      TKey -> "key"+      TUnit -> "unit"+      TSignature -> "signature"+      TOption fa t -> "option (" +| t |+ " " +| fa |+ ")"+      TList t -> "list (" +| t |+ ")"+      TSet c -> "set (" +| c |+ ")"+      TOperation -> "operation"+      TContract t -> "contract " +| t |+ ""+      TPair fa1 fa2 t1 t2 ->+        "pair (" +| t1 |+ " " +| fa1 |+ ")"+         +| " (" +| t2 |+ " " +| fa2 |+ ")"+      TOr fa1 fa2 t1 t2 ->+        "or ("   +| t1 |+ " " +| fa1 |+ ")"+         +| " (" +| t2 |+ " " +| fa2 |+ ")"+      TLambda t1 t2 -> build2 "lambda" t1 t2+      TMap t1 t2 -> build2 "map" t1 t2+      TBigMap t1 t2 -> build2 "big_map" t1 t2+    where+      -- build something with 2 type parameters+      build2 :: (Buildable t1, Buildable t2) => Builder -> t1 -> t2 -> Builder+      build2 name t1 t2 = name |+ " (" +| t1 |+ " " +| t2 |+ ")"++-- Comparable Sub-Type+data CT =+    CInt+  | CNat+  | CString+  | CBytes+  | CMutez+  | CBool+  | CKeyHash+  | CTimestamp+  | CAddress+  deriving (Eq, Ord, Show, Data, Enum, Bounded, Generic)++-- | Type function that converts a regular Haskell type into a comparable type+-- (which has kind @CT@)+type family ToCT a :: CT where+  ToCT Integer = 'CInt+  ToCT Int = 'CInt+  ToCT Natural = 'CNat+  ToCT Word64 = 'CNat+  ToCT Text = 'CString+  ToCT Bool = 'CBool+  ToCT ByteString = 'CBytes+  ToCT Mutez = 'CMutez+  ToCT Address = 'CAddress+  ToCT KeyHash = 'CKeyHash+  ToCT Timestamp = 'CTimestamp++instance Buildable CT where+  build =+    \case+      CInt -> "int"+      CNat -> "nat"+      CString -> "string"+      CBytes -> "bytes"+      CMutez -> "mutez"+      CBool -> "bool"+      CKeyHash -> "key_hash"+      CTimestamp -> "timestamp"+      CAddress -> "address"++pattern Tint :: T+pattern Tint <- Tc CInt++pattern Tnat :: T+pattern Tnat <- Tc CNat++pattern Tstring :: T+pattern Tstring <- Tc CString++pattern Tbytes :: T+pattern Tbytes <- Tc CBytes++pattern Tmutez :: T+pattern Tmutez <- Tc CMutez++pattern Tbool :: T+pattern Tbool <- Tc CBool++pattern Tkey_hash :: T+pattern Tkey_hash <- Tc CKeyHash++pattern Ttimestamp :: T+pattern Ttimestamp <- Tc CTimestamp++pattern Taddress :: T+pattern Taddress <- Tc CAddress++tint :: T+tint = Tc CInt++tnat :: T+tnat = Tc CNat++tstring :: T+tstring = Tc CString++tbytes :: T+tbytes = Tc CBytes++tmutez :: T+tmutez = Tc CMutez++tbool :: T+tbool = Tc CBool++tkeyHash :: T+tkeyHash = Tc CKeyHash++ttimestamp :: T+ttimestamp = Tc CTimestamp++taddress :: T+taddress = Tc CAddress++isAtomicType :: Type -> Bool+isAtomicType t@(Type _ (Annotation "")) =+    isComparable t || isKey t || isUnit t || isSignature t || isOperation t+isAtomicType _ = False++isKey :: Type -> Bool+isKey (Type TKey _) = True+isKey _              = False++isUnit :: Type -> Bool+isUnit (Type TUnit _) = True+isUnit _               = False++isSignature :: Type -> Bool+isSignature (Type TSignature _) = True+isSignature _                    = False++isOperation :: Type -> Bool+isOperation (Type TOperation _) = True+isOperation _                    = False++isComparable :: Type -> Bool+isComparable (Type (Tc _) _) = True+isComparable _ = False++isMutez :: Type -> Bool+isMutez (Type (Tc CMutez) _) = True+isMutez _ = False++isTimestamp :: Type -> Bool+isTimestamp (Type (Tc CTimestamp) _) = True+isTimestamp _ = False++isKeyHash :: Type -> Bool+isKeyHash (Type (Tc CKeyHash) _) = True+isKeyHash _ = False++isBool  :: Type -> Bool+isBool (Type (Tc CBool) _) = True+isBool _ = False++isString  :: Type -> Bool+isString (Type (Tc CString) _) = True+isString _ = False++isInteger :: Type -> Bool+isInteger a = isNat a || isInt a || isMutez a || isTimestamp a++isNat  :: Type -> Bool+isNat (Type (Tc CNat) _) = True+isNat _ = False++isInt  :: Type -> Bool+isInt (Type (Tc CInt) _) = True+isInt _ = False++isBytes :: Type -> Bool+isBytes (Type (Tc CBytes) _) = True+isBytes _ = False++----------------------------------------------------------------------------+-- JSON serialization+----------------------------------------------------------------------------++deriveJSON defaultOptions ''Type+deriveJSON defaultOptions ''Comparable+deriveJSON defaultOptions ''T+deriveJSON defaultOptions ''CT
+ src/Michelson/Untyped/Value.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++-- | Untyped Michelson values (i. e. type of a value is not statically known).++module Michelson.Untyped.Value+  ( Value (..)+  , Elt (..)++  -- Internal types to avoid orphan instances+  , InternalByteString(..)+  , unInternalByteString+  ) where++import Data.Aeson (FromJSON(..), ToJSON(..))+import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Data (Data(..))+import Data.Text.Lazy.Builder (Builder)+import Fmt (hexF, (+|), (|+))+import Formatting.Buildable (Buildable)+import qualified Formatting.Buildable as Buildable++data Value op =+    ValueInt     Integer+  | ValueString  Text+  | ValueBytes   InternalByteString+  | ValueUnit+  | ValueTrue+  | ValueFalse+  | ValuePair    (Value op) (Value op)+  | ValueLeft    (Value op)+  | ValueRight   (Value op)+  | ValueSome    (Value op)+  | ValueNone+  | ValueSeq     [Value op]+  -- ^ A sequence of elements: can be a list or a set.+  -- We can't distinguish lists and sets during parsing.+  | ValueMap     [Elt op]+  | ValueLambda  [op]+  deriving stock (Eq, Show, Functor, Data, Generic)++data Elt op = Elt (Value op) (Value op)+  deriving stock (Eq, Show, Functor, Data, Generic)++-- | ByteString does not have an instance for ToJSON and FromJSON, to+-- avoid orphan type class instances, make a new type wrapper around it.+newtype InternalByteString = InternalByteString ByteString+  deriving stock (Data, Eq, Show)++unInternalByteString :: InternalByteString -> ByteString+unInternalByteString (InternalByteString bs) = bs++instance Buildable op => Buildable (Value op) where+  build =+    \case+      ValueInt i -> Buildable.build i+      ValueString s -> "\"" +| s |+ "\""+      ValueBytes (InternalByteString b) -> "0x" <> hexF b+      ValueUnit -> "Unit"+      ValueTrue -> "True"+      ValueFalse -> "False"+      ValuePair a b -> "(Pair " +| a |+ " " +| b |+ ")"+      ValueLeft v -> "(Left " +| v |+ ")"+      ValueRight v -> "(Right " +| v |+ ")"+      ValueSome v -> "(Some " +| v |+ ")"+      ValueNone -> "None"+      ValueSeq vs -> buildList vs+      ValueMap els -> buildList els+      ValueLambda ops -> buildList ops+    where+      buildList :: Buildable a => [a] -> Builder+      buildList items =+        "{" <>+        mconcat (intersperse "; " $ map Buildable.build items) <>+        "}"++instance Buildable op => Buildable (Elt op) where+  build (Elt a b) = "Elt " +| a |+ " " +| b |+ ""++----------------------------------------------------------------------------+-- JSON serialization+----------------------------------------------------------------------------++-- it is not possible to derives these automatically because+-- ByteString does not have a ToJSON or FromJSON instance++instance ToJSON InternalByteString where+  toJSON = toJSON @Text . decodeUtf8 . unInternalByteString++instance FromJSON InternalByteString where+  parseJSON = fmap (InternalByteString . encodeUtf8 @Text) . parseJSON++deriveJSON defaultOptions ''Value+deriveJSON defaultOptions ''Elt
+ src/Morley/Aliases.hs view
@@ -0,0 +1,11 @@+-- | Some simple aliases for Michelson types.++module Morley.Aliases+  ( UntypedContract+  , UntypedValue+  ) where++import qualified Michelson.Untyped as Untyped++type UntypedValue = Untyped.Value Untyped.Op+type UntypedContract = Untyped.Contract Untyped.Op
+ src/Morley/Default.hs view
@@ -0,0 +1,21 @@+module Morley.Default+  ( permute2Def , permute3Def+  , Default (..)+  ) where++import Control.Applicative.Permutations (toPermutationWithDefault, runPermutation)+import Data.Default (def, Default)++{- Permutation Parsers -}++permute2Def :: (Default a, Default b, Monad f, Alternative f) => f a -> f b -> f (a,b)+permute2Def a b = runPermutation $+  (,) <$> toPermutationWithDefault def a+      <*> toPermutationWithDefault def b++permute3Def :: (Default a, Default b, Default c, Monad f, Alternative f) =>+                f a -> f b -> f c -> f (a,b,c)+permute3Def a b c = runPermutation $+  (,,) <$> toPermutationWithDefault def a+       <*> toPermutationWithDefault def b+       <*> toPermutationWithDefault def c
+ src/Morley/Ext.hs view
@@ -0,0 +1,210 @@+module Morley.Ext+  ( interpretMorleyUntyped+  , interpretMorley+  , typeCheckMorleyContract+  , typeCheckHandler+  , interpretHandler+  ) where++import Control.Monad.Except (liftEither, throwError)+import Data.Default (def)+import Data.Map.Lazy (Map, insert, lookup)+import qualified Data.Map.Lazy as Map+import Data.Singletons (Sing)+import qualified Data.Text as T+import Data.Typeable ((:~:)(..))+import Data.Vinyl (Rec(..))++import Michelson.Interpret+  (ContractEnv, ContractReturn, EvalOp, InterpretUntypedError, InterpretUntypedResult,+  InterpreterEnv(..), InterpreterState(..), MichelsonFailed(..), SomeItStack(..), interpret,+  interpretUntyped, runInstrNoGas)+import Michelson.TypeCheck+import Michelson.TypeCheck.Helpers (convergeHST, eqT')+import Michelson.TypeCheck.Types (HST)+import Michelson.Typed (Val, converge, extractNotes, mkUType)+import qualified Michelson.Typed as T+import Michelson.Untyped (CT(..), InstrAbstract(..))+import Morley.Types++interpretMorleyUntyped+  :: Contract Op+  -> Value Op+  -> Value Op+  -> ContractEnv+  -> Either (InterpretUntypedError MorleyLogs) (InterpretUntypedResult MorleyLogs)+interpretMorleyUntyped c v1 v2 cenv =+  interpretUntyped typeCheckHandler c v1 v2 (InterpreterEnv cenv interpretHandler) def++interpretMorley+  :: (Typeable cp, Typeable st)+  => T.Contract cp st+  -> Val T.Instr cp+  -> Val T.Instr st+  -> ContractEnv+  -> ContractReturn MorleyLogs st+interpretMorley c param initSt env =+  interpret c param initSt (InterpreterEnv env interpretHandler) def++typeCheckMorleyContract :: Contract Instr -> Either TCError SomeContract+typeCheckMorleyContract = typeCheckContract typeCheckHandler++typeCheckHandler :: UExtInstr -> TcExtFrames -> SomeHST -> TypeCheckT (TcExtFrames, Maybe ExtInstr)+typeCheckHandler ext nfs hst@(SomeHST hs) =+  case ext of+    STACKTYPE s -> fitError $ const (nfs, Nothing) <$> checkStackType noBoundVars s hs+    FN t sf     -> fitError $ (, Nothing) <$> checkFn t sf hst nfs+    FN_END      -> fitError $ const (safeTail nfs, Nothing) <$> checkFnEnd hst nfs+    UPRINT pc   -> verifyPrint pc $> (nfs, Just $ PRINT pc)+    UTEST_ASSERT UTestAssert{..} -> do+      verifyPrint tassComment+      si <- typeCheckList (unOp <$> tassInstrs) hst+      case si of+        SiFail -> thErr "TEST_ASSERT has to return Bool, but it's failed"+        instr ::: (_ :: HST inp, ((_ :: (Sing b, T.Notes b, VarAnn)) ::& (_ :: HST out1))) -> do+          Refl <- liftEither $+                    first (const $ TCOtherError "TEST_ASSERT has to return Bool, but returned something else") $+                      eqT' @b @('T.Tc 'CBool)+          pure (nfs, Just $ TEST_ASSERT $ TestAssert tassName tassComment instr)+        _ -> thErr "TEST_ASSERT has to return Bool, but the stack is empty"+  where+    lhs = lengthHST hs+    thErr = throwError . TCOtherError++    verifyPrint :: PrintComment -> TypeCheckT ()+    verifyPrint (PrintComment pc) = do+      let checkStRef (Left _) = pure ()+          checkStRef (Right (StackRef (fromIntegral -> i)))+            | i < 0     = thErr $ "Stack reference is negative " <> show i+            | i >= lhs  = thErr $ "Stack reference is out of the stack: " <> show i <> " >= " <> show lhs+            | otherwise = pure ()+      traverse_ checkStRef pc++    safeTail :: [a] -> [a]+    safeTail (_:as) = as+    safeTail [] = []++    fitError = liftEither . first (TCFailedOnInstr (EXT ext) hst . flip uextErrorText hs)++interpretHandler :: (ExtInstr, SomeItStack) -> EvalOp MorleyLogs ()+interpretHandler (PRINT (PrintComment pc), SomeItStack st) = do+  let getEl (Left l) = l+      getEl (Right (StackRef i)) =+        fromMaybe (error "StackRef " <> show i <> " has to exist in the stack after typechecking, but it doesn't") $+        rat st (fromIntegral i)+  modify (\s -> s {isExtState = MorleyLogs $ mconcat (map getEl pc) : unMorleyLogs (isExtState s)})+interpretHandler (TEST_ASSERT (TestAssert nm pc (instr :: T.Instr inp1 ('T.Tc 'T.CBool ': out1) )),+            SomeItStack (st :: Rec (Val T.Instr) inp2)) = do+  Refl <- liftEither $ first (error "TEST_ASSERT input stack doesn't match") $ eqT' @inp1 @inp2+  runInstrNoGas instr st >>= \case+    (T.VC (T.CvBool False) :& RNil) -> do+      interpretHandler (PRINT pc, SomeItStack st)+      throwError $ MichelsonFailedOther $ "TEST_ASSERT " <> nm <> " failed"+    _  -> pass++-- | Various type errors possible when checking a @NopInstr@ with the+-- @nopHandler@+data UExtError =+    LengthMismatch StackTypePattern Int+  | VarError Text StackFn+  | TypeMismatch StackTypePattern Int Text+  | TyVarMismatch Var Type StackTypePattern Int Text+  | FnEndMismatch (Maybe (UExtInstr, SomeHST))+  | StkRestMismatch StackTypePattern SomeHST SomeHST Text+  | UnexpectedUExt UExtInstr++-- | Print error messages+uextErrorText :: UExtError -> HST xs -> Text+uextErrorText (LengthMismatch stk n) it = T.concat+  ["Unexpected length of stack: pattern ", show stk, " has length ", show n+  , ", but actual stack is", show it+  ]+uextErrorText (VarError t sf) _ = "In definition of " <> show t <> ": VarError " <> show sf+uextErrorText (TypeMismatch s n e) it = T.concat+  [ "TypeMismatch: Pattern ", show s, " failed on stack ", show it+  , "at index ", show n, " with \"", e, "\""+  ]+uextErrorText (TyVarMismatch v t s n e) it = T.concat+  [ "TyVarMismatch: Variable ", show v, " is bound to type ", show t+  , "but pattern ", show s, " failed on stack ", show it, "at index ", show n+  , " with \"", e, "\""+  ]+uextErrorText (FnEndMismatch n) it = "FnEndMismatch: " <> show n <> " on " <> show it+uextErrorText (UnexpectedUExt n) it = "UnexpectedUExt: " <> show n <> " on " <> show it+uextErrorText (StkRestMismatch s (SomeHST r) (SomeHST r') e) it = T.concat+  ["StkRestMismatch on stack ", show it+  , " in pattern " , show s+  , " against stacks ", show r, " and ", show r'+  , " with error: ", e+  ]++-- | Check that the optional "forall" variables are consistent if present+checkVars :: Text -> StackFn -> Either UExtError ()+checkVars t sf = case quantifiedVars sf of+  Just qs+    | varSet (inPattern sf) /= qs -> Left $ VarError t sf+  _ -> pure ()++-- | Checks the pattern in @FN@ and pushes a @ExtFrame@ onto the state+checkFn :: Text -> StackFn -> SomeHST -> TcExtFrames -> Either UExtError TcExtFrames+checkFn t sf si@(SomeHST it) nfs = do+  checkVars t sf+  second (const $ (FN t sf, si) : nfs) (checkStackType noBoundVars (inPattern sf) it)++-- |  Pops a @ExtFrame@ off the state and checks an @FN_END@ based on it+checkFnEnd :: SomeHST -> TcExtFrames -> Either UExtError BoundVars+checkFnEnd (SomeHST it') (nf@(nop, SomeHST it):_) = case nop of+  FN t sf -> do+    checkVars t sf+    m <- checkStackType noBoundVars (inPattern sf) it+    checkStackType m (outPattern sf) it'+  _ -> Left $ FnEndMismatch (Just nf)+checkFnEnd _ _ = Left $ FnEndMismatch Nothing++data BoundVars = BoundVars (Map Var Type) (Maybe SomeHST)++noBoundVars :: BoundVars+noBoundVars = BoundVars Map.empty Nothing++-- | Check that a @StackTypePattern@ matches the type of the current stack+checkStackType :: Typeable xs => BoundVars -> StackTypePattern -> HST xs+               -> Either UExtError BoundVars+checkStackType (BoundVars vars boundStkRest) s it = go vars 0 s it+  where+    go :: Typeable xs => Map Var Type -> Int -> StackTypePattern -> HST xs+       -> Either UExtError BoundVars+    go m _ StkRest sr = case boundStkRest of+      Nothing -> pure $ BoundVars m (Just $ SomeHST sr)+      Just si@(SomeHST sr') ->+        bimap (StkRestMismatch s (SomeHST sr) si)+              (const $ BoundVars m (Just si))+              (eqHST sr sr')+    go m _ StkEmpty SNil = pure $ BoundVars m Nothing+    go _ n StkEmpty _    = Left $ LengthMismatch s n+    go _ n _ SNil        = Left $ LengthMismatch s n+    go m n (StkCons (TyCon t) ts) ((xt, xann, _) ::& xs) = do+      tann <- first (TypeMismatch s n) (extractNotes t xt)+      void $ first (TypeMismatch s n) (converge tann xann)+      go m (n + 1) ts xs+    go m n (StkCons (VarID v) ts) ((xt, xann, _) ::& xs) =+      case lookup v m of+        Nothing -> let t = mkUType xt xann in go (insert v t m) (n + 1) ts xs+        Just t -> do+          tann <- first (TyVarMismatch v t s n) (extractNotes t xt)+          void $ first (TyVarMismatch v t s n) (converge tann xann)+          go m (n + 1) ts xs++eqHST :: (Typeable as, Typeable bs) => HST as -> HST bs -> Either Text (as :~: bs)+eqHST (it :: HST xs) (it' :: HST ys) = do+  Refl <- (eqT' @xs @ys)+  convergeHST it it'+  return Refl++lengthHST :: HST xs -> Int+lengthHST (_ ::& xs) = 1 + lengthHST xs+lengthHST SNil = 0++rat :: Rec (Val T.Instr) xs -> Int -> Maybe Text+rat (x :& _) 0 = Just $ show x+rat (_ :& xs) i = rat xs (i - 1)+rat RNil _ = Nothing
+ src/Morley/Lexer.hs view
@@ -0,0 +1,55 @@+module Morley.Lexer (+    lexeme+  , mSpace+  , symbol+  , symbol'+  , string'+  , parens+  , braces+  , brackets+  , brackets'+  , semicolon+  , comma+  ) where++import Morley.Types (Parser)++import Data.Char (toLower)+import qualified Data.Text as T+import Text.Megaparsec (between, MonadParsec, Tokens)+import Text.Megaparsec.Char (space1, string)+import qualified Text.Megaparsec.Char.Lexer as L++-- Lexing+lexeme :: Parser a -> Parser a+lexeme = L.lexeme mSpace++mSpace :: Parser ()+mSpace = L.space space1 (L.skipLineComment "#") (L.skipBlockComment "/*" "*/")++symbol :: Tokens Text -> Parser (Tokens Text)+symbol = L.symbol mSpace++symbol' :: Text -> Parser (Tokens Text)+symbol' str = symbol str <|> symbol (T.map toLower str)++string' :: (MonadParsec e s f, Tokens s ~ Text) => Text -> f Text+string' str = string str <|> string (T.map toLower str)++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++brackets :: Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")++brackets' :: Parser a -> Parser a+brackets' = between (string "[") (string "]")++semicolon :: Parser (Tokens Text)+semicolon = symbol ";"++comma :: Parser (Tokens Text)+comma = symbol ","
+ src/Morley/Macro.hs view
@@ -0,0 +1,201 @@+module Morley.Macro+  (+    -- * For utilities+    expandFlattenContract+  , expandValue++    -- * For parsing+  , mapLeaves++    -- * Internals exported for tests+  , expand+  , expandFlat+  , expandPapair+  , expandUnpapair+  , expandCadr+  , expandSetCadr+  , expandMapCadr+  , flatten++  ) where++import Generics.SYB (everywhere, mkT)++import Morley.Types+  (CadrStruct(..), Contract(..), Elt(..), ExpandedInstr, ExpandedOp(..), FieldAnn, Instr,+  InstrAbstract(..), LetMacro(..), Macro(..), Op(..), PairStruct(..), ParsedOp(..), TypeAnn,+  UExtInstrAbstract(..), Value(..), VarAnn, ann, noAnn)++expandFlat :: [ParsedOp] -> [Op]+expandFlat = fmap Op . concatMap flatten . fmap expand++-- | Expand and flatten and instructions in parsed contract.+expandFlattenContract :: Contract ParsedOp -> Contract Op+expandFlattenContract Contract {..} =+  Contract para stor (expandFlat $ code)++-- Probably, some SYB can be used here+expandValue :: Value ParsedOp -> Value Op+expandValue = \case+  ValuePair l r -> ValuePair (expandValue l) (expandValue r)+  ValueLeft x -> ValueLeft (expandValue x)+  ValueRight x -> ValueRight (expandValue x)+  ValueSome x -> ValueSome (expandValue x)+  ValueSeq valueList -> ValueSeq (map expandValue valueList)+  ValueMap eltList -> ValueMap (map expandElt eltList)+  ValueLambda opList -> ValueLambda (expandFlat $ opList)+  x -> fmap (unsafeCastPrim . expand) x++expandElt :: Elt ParsedOp -> Elt Op+expandElt (Elt l r) = Elt (expandValue l) (expandValue r)++flatten :: ExpandedOp -> [Instr]+flatten (SEQ_EX s) = concatMap flatten s+flatten (PRIM_EX o) = [flattenInstr o]++unsafeCastPrim :: ExpandedOp -> Op+unsafeCastPrim (PRIM_EX x) = Op (fmap unsafeCastPrim x)+unsafeCastPrim _           = error "unexpected constructor"++-- Here used SYB approach instead pattern matching+-- flattenInstr (IF_NONE l r) = IF_NONE (concatMap flatten l) (concatMap flatten r)+-- flattenInstr (IF_LEFT l r) = IF_LEFT (concatMap flatten l) (concatMap flatten r)+-- ...+flattenInstr :: ExpandedInstr -> Instr+flattenInstr = fmap unsafeCastPrim . everywhere (mkT flattenOps)+  where+    flattenOps :: [ExpandedOp] -> [ExpandedOp]+    flattenOps [] = []+    flattenOps (SEQ_EX s : xs) = s ++ flattenOps xs+    flattenOps (x@(PRIM_EX _) : xs) = x : flattenOps xs++expand :: ParsedOp -> ExpandedOp+expand (MAC m)  = SEQ_EX $ expandMacro m+expand (PRIM i) = PRIM_EX $ expand <$> i+expand (SEQ s)  = SEQ_EX $ expand <$> s+expand (LMAC l)  = SEQ_EX $ expandLetMac l+  where+    expandLetMac :: LetMacro -> [ExpandedOp]+    expandLetMac LetMacro {..} =+      [ PRIM_EX $ EXT (FN lmName lmSig)+      , SEQ_EX $ expand <$> lmExpr+      , PRIM_EX $ EXT FN_END+      ]++expandMacro :: Macro -> [ExpandedOp]+expandMacro = \case+  CMP i v            -> [PRIM_EX (COMPARE v), xo i]+  IFX i bt bf        -> [xo i, PRIM_EX (IF (xp bt) (xp bf))]+  IFCMP i v bt bf    -> PRIM_EX <$> [COMPARE v, expand <$> i, IF (xp bt) (xp bf)]+  IF_SOME bt bf      -> [PRIM_EX (IF_NONE (xp bf) (xp bt))]+  FAIL               -> PRIM_EX <$> [UNIT noAnn noAnn, FAILWITH]+  ASSERT             -> xol $ IF [] [MAC FAIL]+  ASSERTX i          -> [expand $ MAC $ IFX i [] [MAC FAIL]]+  ASSERT_CMP i       -> [expand $ MAC $ IFCMP i noAnn [] [MAC FAIL]]+  ASSERT_NONE        -> xol $ IF_NONE [] [MAC FAIL]+  ASSERT_SOME        -> xol $ IF_NONE [MAC FAIL] []+  ASSERT_LEFT        -> xol $ IF_LEFT [] [MAC FAIL]+  ASSERT_RIGHT       -> xol $ IF_LEFT [MAC FAIL] []+  PAPAIR ps t v      -> expand <$> expandPapair ps t v+  UNPAIR ps          -> expand <$> expandUnpapair ps+  CADR c v f         -> expand <$> expandCadr c v f+  SET_CADR c v f     -> expand <$> expandSetCadr c v f+  MAP_CADR c v f ops -> expand <$> expandMapCadr c v f ops+  DIIP 1 ops         -> [PRIM_EX $ DIP (xp ops)]+  DIIP n ops         -> xol $  DIP [MAC $ DIIP (n - 1) ops]+  DUUP 1 v           -> [PRIM_EX $ DUP v]+  DUUP n v           -> [xo (DIP [MAC $ DUUP (n - 1) v]), PRIM_EX SWAP]+  where+    xol = one . xo+    xo = PRIM_EX . fmap expand+    xp = fmap expand++-- the correctness of type-annotation expansion is currently untested, as these+-- expansions are not explicitly documented in the Michelson Specification+expandPapair :: PairStruct -> TypeAnn -> VarAnn -> [ParsedOp]+expandPapair ps t v = case ps of+  P (F a) (F b) -> [PRIM $ PAIR t v (snd a) (snd b)]+  P (F a) r     -> PRIM <$> [ DIP [MAC $ PAPAIR r noAnn noAnn]+                            , PAIR t v (snd a) noAnn]+  P l     (F b) -> [ MAC $ PAPAIR l noAnn noAnn+                   , PRIM $ PAIR t v noAnn (snd b)]+  P l     r     -> [ MAC $ PAPAIR l noAnn noAnn+                   , PRIM $ DIP [MAC $ PAPAIR r noAnn noAnn]+                   , PRIM $ PAIR t v noAnn noAnn]+  F _           -> [] -- Do nothing in this case.+  -- It's impossible from the structure of PairStruct and considered cases above,+  -- but if it accidentally happened let's just do nothing.++expandUnpapair :: PairStruct -> [ParsedOp]+expandUnpapair = \case+  P (F (v,f)) (F (w,g)) -> PRIM <$> [ DUP noAnn+                                    , CAR v f+                                    , DIP [PRIM $ CDR w g]]+  P (F (v, f)) r        -> PRIM <$> [ DUP noAnn+                                    , CAR v f+                                    , DIP [PRIM $ CDR noAnn noAnn,+                                           MAC $ UNPAIR r]]+  P l     (F (v, f))    -> [ PRIM (DUP noAnn)+                           , PRIM (DIP [PRIM $ CDR v f])+                           , PRIM $ CAR noAnn noAnn+                           , MAC $ UNPAIR l]+  P l      r            -> [ MAC unpairOne+                           , PRIM $ DIP [MAC $ UNPAIR r]+                           , MAC $ UNPAIR l]+  F _                   -> [] -- Do nothing in this case.+  -- It's impossible from the structure of PairStruct and considered cases above,+  -- but if it accidentally happened let's just do nothing.+  where+    unpairOne = UNPAIR (P fn fn)+    fn = F (noAnn, noAnn)++expandCadr :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp]+expandCadr cs v f = case cs of+  []    -> []+  A:[]  -> [PRIM $ CAR v f]+  D:[]  -> [PRIM $ CDR v f]+  A:css -> [PRIM $ CAR noAnn noAnn, MAC $ CADR css v f]+  D:css -> [PRIM $ CDR noAnn noAnn, MAC $ CADR css v f]++expandSetCadr :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp]+expandSetCadr cs v f = PRIM <$> case cs of+  []   -> []+  A:[] -> [DUP noAnn, CAR noAnn f, DROP,+           -- ↑ These operations just check that the left element of pair has %f+           CDR (ann "%%") noAnn, SWAP, PAIR noAnn v f (ann "@")]+  D:[] -> [DUP noAnn, CDR noAnn f, DROP,+           -- ↑ These operations just check that the right element of pair has %f+           CAR (ann "%%") noAnn, PAIR noAnn v (ann "@") f]+  A:css -> [DUP noAnn, DIP [PRIM carN, MAC $ SET_CADR css noAnn f], cdrN, SWAP, pairN]+  D:css -> [DUP noAnn, DIP [PRIM cdrN, MAC $ SET_CADR css noAnn f], carN, pairN]+  where+    carN = CAR noAnn noAnn+    cdrN = CDR noAnn noAnn+    pairN = PAIR noAnn v noAnn noAnn++expandMapCadr :: [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ParsedOp]+expandMapCadr cs v f ops = case cs of+  []    -> []+  A:[]  -> PRIM <$> [DUP noAnn, cdrN, DIP [PRIM $ CAR noAnn f, SEQ ops], SWAP, pairN]+  D:[]  -> concat [PRIM <$> [DUP noAnn, CDR noAnn f], [SEQ ops], PRIM <$> [SWAP, carN, pairN]]+  A:css -> PRIM <$> [DUP noAnn, DIP [PRIM $ carN, MAC $ MAP_CADR css noAnn f ops], cdrN, SWAP, pairN]+  D:css -> PRIM <$> [DUP noAnn, DIP [PRIM $ cdrN, MAC $ MAP_CADR css noAnn f ops], carN, pairN]+  where+    carN = CAR noAnn noAnn+    cdrN = CDR noAnn noAnn+    pairN = PAIR noAnn v noAnn noAnn++mapLeaves :: [(VarAnn, FieldAnn)] -> PairStruct -> PairStruct+mapLeaves fs p = evalState (leavesST p) fs++leavesST :: PairStruct -> State [(VarAnn, FieldAnn)] PairStruct+leavesST (P l r) = do+  l' <- leavesST l+  r' <- leavesST r+  return $ P l' r'+leavesST (F _) = do+  f <- state getLeaf+  return $ F f+  where+    getLeaf (a:as) = (a, as)+    getLeaf _      = ((noAnn, noAnn), [])
+ src/Morley/Parser.hs view
@@ -0,0 +1,920 @@+module Morley.Parser+  ( program+  , parseNoEnv+  , ops+  , ParserException (..)+  , stringLiteral+  , type_+  , value+  , stackType+  , printComment+  ) where++import Prelude hiding (many, note, some, try)++import Control.Applicative.Permutations (intercalateEffect, toPermutation)+import qualified Data.ByteString.Base16 as B16+import qualified Data.Char as Char+import Data.Default (Default)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T++import Text.Megaparsec+  (choice, customFailure, eitherP, many, manyTill, notFollowedBy, parse, satisfy, sepEndBy, some,+  takeWhile1P, try)+import Text.Megaparsec.Char (alphaNumChar, char, lowerChar, string, upperChar)+import qualified Text.Megaparsec.Char.Lexer as L++import Morley.Lexer+import qualified Morley.Macro as Macro+import Morley.Parser.Annotations+import Morley.Types (CustomParserException(..), ParsedOp(..), Parser, ParserException(..))+import qualified Morley.Types as Mo++-------------------------------------------------------------------------------+-- Top-Level Parsers+-------------------------------------------------------------------------------+++-- Contracts+------------------++-- | Michelson contract with let definitions+program :: Mo.Parsec CustomParserException T.Text (Mo.Contract ParsedOp)+program = runReaderT programInner Mo.noLetEnv++programInner :: Parser (Mo.Contract ParsedOp)+programInner = do+  mSpace+  env <- fromMaybe Mo.noLetEnv <$> (optional letBlock)+  local (const env) contract++-- | Parse with empty environment+parseNoEnv :: Parser a -> String -> T.Text+       -> Either (Mo.ParseErrorBundle T.Text CustomParserException) a+parseNoEnv p = parse (runReaderT p Mo.noLetEnv)++-- | Michelson contract+contract :: Parser (Mo.Contract ParsedOp)+contract = do+  mSpace+  (p,s,c) <- intercalateEffect semicolon $+              (,,) <$> toPermutation parameter+                   <*> toPermutation storage+                   <*> toPermutation code+  return $ Mo.Contract p s c++-- Contract Blocks+------------------++-- | let block parser+letBlock :: Parser Mo.LetEnv+letBlock = do+  symbol "let"+  symbol "{"+  ls <- local (const Mo.noLetEnv) letInner+  symbol "}"+  semicolon+  return ls++parameter :: Parser Mo.Type+parameter = do void $ symbol "parameter"; type_++storage :: Parser Mo.Type+storage = do void $ symbol "storage"; type_++code :: Parser [ParsedOp]+code = do void $ symbol "code"; ops++-- Michelson expressions+------------------------+value :: Parser (Mo.Value ParsedOp)+value = lexeme $ valueInner <|> parens valueInner++type_ :: Parser Mo.Type+type_ = (ti <|> parens ti) <|> (customFailure UnknownTypeException)+  where+    ti = snd <$> (lexeme $ typeInner (pure Mo.noAnn))++ops :: Parser [Mo.ParsedOp]+ops = do+  lms <- asks Mo.letMacros+  let op' = choice [ (Mo.PRIM . Mo.EXT) <$> nopInstr+                   , Mo.LMAC <$> mkLetMac lms+                   , Mo.PRIM <$> prim+                   , Mo.MAC <$> macro+                   , primOrMac+                   , Mo.SEQ <$> ops+                   ]+  braces $ sepEndBy op' semicolon++-------------------------------------------------------------------------------+-- Let block+-------------------------------------------------------------------------------++-- | Element of a let block+data Let = LetM Mo.LetMacro | LetV Mo.LetValue | LetT Mo.LetType++-- | Incrementally build the let environment+letInner :: Parser Mo.LetEnv+letInner = do+  env <- ask+  l <- lets+  semicolon+  (local (addLet l) letInner) <|> return (addLet l env)++-- | add a Let to the environment in the correct place+addLet :: Let -> Mo.LetEnv -> Mo.LetEnv+addLet l (Mo.LetEnv lms lvs lts) = case l of+  LetM lm -> Mo.LetEnv (Map.insert (Mo.lmName lm) lm lms) lvs lts+  LetV lv -> Mo.LetEnv lms (Map.insert (Mo.lvName lv) lv lvs) lts+  LetT lt -> Mo.LetEnv lms lvs (Map.insert (Mo.ltName lt) lt lts)++lets :: Parser Let+lets = choice [ (LetM <$> (try letMacro))+              , (LetV <$> (try letValue))+              , (LetT <$> (try letType))+              ]++-- | build a let name parser from a leading character parser+letName :: Parser Char -> Parser T.Text+letName p = lexeme $ do+  v <- p+  let validChar x = Char.isAscii x && (Char.isAlphaNum x || x == '\'' || x == '_')+  vs <- many (satisfy validChar)+  return $ T.pack (v:vs)++letMacro :: Parser Mo.LetMacro+letMacro = lexeme $ do+  n <- letName lowerChar+  symbol "::"+  s <- stackFn+  symbol "="+  o <- ops+  return $ Mo.LetMacro n s o++letType :: Parser Mo.LetType+letType = lexeme $ do+  symbol "type"+  n <- letName lowerChar+  symbol "="+  t <- type_+  case t of+    (Mo.Type t' a) ->+      if a == Mo.noAnn+      then return $ Mo.LetType n (Mo.Type t' (Mo.ann n))+      else return $ Mo.LetType n t++letValue :: Parser Mo.LetValue+letValue = lexeme $ do+  n <- letName upperChar+  symbol "::"+  t <- type_+  symbol "="+  v <- value+  return $ Mo.LetValue n t v++-- | make a parser from a string+mkParser :: (a -> T.Text) -> a -> Parser a+mkParser f a = (try $ symbol (f a)) >> return a++mkLetMac :: Map Text Mo.LetMacro -> Parser Mo.LetMacro+mkLetMac lms = choice $ mkParser Mo.lmName <$> (Map.elems lms)++mkLetVal :: Map Text Mo.LetValue -> Parser Mo.LetValue+mkLetVal lvs = choice $ mkParser Mo.lvName <$> (Map.elems lvs)++mkLetType :: Map Text Mo.LetType -> Parser Mo.LetType+mkLetType lts = choice $ mkParser Mo.ltName <$> (Map.elems lts)++stackFn :: Parser Mo.StackFn+stackFn = do+  vs <- (optional (symbol "forall" >> some varID <* symbol "."))+  a <- stackType+  symbol "->"+  b <- stackType+  return $ Mo.StackFn (Set.fromList <$> vs) a b++tyVar :: Parser Mo.TyVar+tyVar = (Mo.TyCon <$> type_) <|> (Mo.VarID <$> varID)++lowerAlphaNumChar :: Parser Char+lowerAlphaNumChar = satisfy (\x -> Char.isLower x || Char.isDigit x)++varID :: Parser Mo.Var+varID = lexeme $ do+  v <- lowerChar+  vs <- many lowerAlphaNumChar+  return $ Mo.Var (T.pack (v:vs))++-------------------------------------------------------------------------------+-- Value Parsers+-------------------------------------------------------------------------------++valueInner :: Parser (Mo.Value Mo.ParsedOp)+valueInner = choice $+  [ intLiteral, stringLiteral, bytesLiteral, unitValue+  , trueValue, falseValue, pairValue, leftValue, rightValue+  , someValue, noneValue, seqValue, mapValue, lambdaValue, dataLetValue+  ]++dataLetValue :: Parser (Mo.Value ParsedOp)+dataLetValue = do+  lvs <- asks Mo.letValues+  Mo.lvVal <$> (mkLetVal lvs)++-- Literals+intLiteral :: Parser (Mo.Value a)+intLiteral = try $ Mo.ValueInt <$> (L.signed (return ()) L.decimal)++bytesLiteral :: Parser (Mo.Value a)+bytesLiteral = try $ do+  symbol "0x"+  hexdigits <- takeWhile1P Nothing Char.isHexDigit+  let (bytes, remain) = B16.decode $ encodeUtf8 hexdigits+  if remain == ""+  then return . Mo.ValueBytes . Mo.InternalByteString $ bytes+  else customFailure OddNumberBytesException++stringLiteral :: Parser (Mo.Value ParsedOp)+stringLiteral = try $ Mo.ValueString <$>+  (T.pack <$>+    ( (++) <$>+        (concat <$> (string "\"" >> many validChar)) <*>+        (manyTill (lineBreakChar <|> (customFailure $ UnexpectedLineBreak)) (string "\""))+    )+  )+  where+      validChar :: Parser String+      validChar =+        try strEscape <|>+          try ((:[]) <$> satisfy (\x -> x /= '"' && x /= '\n' && x /= '\r'))+      lineBreakChar :: Parser Char+      lineBreakChar = char '\n' <|> char '\r'++strEscape :: Parser String+strEscape = char '\\' >> esc+  where+    esc = (char 't' >> return "\t")+      <|> (char 'b' >> return "\b")+      <|> (char '\\' >> return "\\")+      <|> (char '"' >> return "\"")+      <|> (char 'n' >> return "\n")+      <|> (char 'r' >> return "\r")+++unitValue :: Parser (Mo.Value ParsedOp)+unitValue = do symbol "Unit"; return Mo.ValueUnit++trueValue :: Parser (Mo.Value ParsedOp)+trueValue = do symbol "True"; return Mo.ValueTrue++falseValue :: Parser (Mo.Value ParsedOp)+falseValue = do symbol "False"; return Mo.ValueFalse++pairValue :: Parser (Mo.Value ParsedOp)+pairValue = core <|> tuple+  where+    core = do symbol "Pair"; a <- value; Mo.ValuePair a <$> value+    tuple = try $ do+      symbol "("+      a <- value+      comma+      b <- tupleInner <|> value+      symbol ")"+      return $ Mo.ValuePair a b+    tupleInner = try $ do+      a <- value+      comma+      b <- tupleInner <|> value+      return $ Mo.ValuePair a b++leftValue :: Parser (Mo.Value ParsedOp)+leftValue = do void $ symbol "Left"; Mo.ValueLeft <$> value++rightValue :: Parser (Mo.Value ParsedOp)+rightValue = do void $ symbol "Right"; Mo.ValueRight <$> value++someValue :: Parser (Mo.Value ParsedOp)+someValue = do void $ symbol "Some"; Mo.ValueSome <$> value++noneValue :: Parser (Mo.Value ParsedOp)+noneValue = do symbol "None"; return Mo.ValueNone++lambdaValue :: Parser (Mo.Value ParsedOp)+lambdaValue = Mo.ValueLambda <$> ops++seqValue :: Parser (Mo.Value ParsedOp)+seqValue = Mo.ValueSeq <$> (try $ braces $ sepEndBy value semicolon)++eltValue :: Parser (Mo.Elt ParsedOp)+eltValue = do void $ symbol "Elt"; Mo.Elt <$> value <*> value++mapValue :: Parser (Mo.Value ParsedOp)+mapValue = Mo.ValueMap <$> (try $ braces $ sepEndBy eltValue semicolon)++-------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------+field :: Parser (Mo.FieldAnn, Mo.Type)+field = lexeme (fi <|> parens fi)+  where+    fi = typeInner noteF++typeInner :: Parser Mo.FieldAnn -> Parser (Mo.FieldAnn, Mo.Type)+typeInner fp = choice $ (\x -> x fp) <$>+  [ t_ct, t_key, t_unit, t_signature, t_option, t_list, t_set, t_operation+  , t_contract, t_pair, t_or, t_lambda, t_map, t_big_map, t_letType+  ]++t_letType :: Parser fp -> Parser (fp, Mo.Type)+t_letType fp = do+  lts <- asks Mo.letTypes+  lt <- Mo.ltSig <$> (mkLetType lts)+  f <- fp+  return (f, lt)++-- Comparable Types+comparable :: Parser Mo.Comparable+comparable = let c = do ct' <- ct; Mo.Comparable ct' <$> noteTDef in parens c <|> c++t_ct :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_ct fp = do ct' <- ct; (f,t) <- fieldType fp; return (f, Mo.Type (Mo.Tc ct') t)++ct :: Parser Mo.CT+ct = (symbol "int" >> return Mo.CInt)+  <|> (symbol "nat" >> return Mo.CNat)+  <|> (symbol "string" >> return Mo.CString)+  <|> (symbol "bytes" >> return Mo.CBytes)+  <|> (symbol "mutez" >> return Mo.CMutez)+  <|> (symbol "bool" >> return Mo.CBool)+  <|> (symbol "key_hash" >> return Mo.CKeyHash)+  <|> (symbol "timestamp" >> return Mo.CTimestamp)+  <|> (symbol "address" >> return Mo.CAddress)++-- Protocol Types+t_key :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_key       fp = do symbol "key"; (f,t) <- fieldType fp; return (f, Mo.Type Mo.TKey t)++t_signature :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_signature fp = do symbol "signature"; (f, t) <- fieldType fp; return (f, Mo.Type Mo.TSignature t)++t_operation :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_operation fp = do symbol "operation"; (f, t) <- fieldType fp; return (f, Mo.Type Mo.TOperation t)++t_contract :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_contract  fp = do symbol "contract"; (f, t) <- fieldType fp; a <- type_; return (f, Mo.Type (Mo.TContract a) t)+--(do symbol "address"; (f, t) <- ft; return (f, Mo.Type Mo.CAddress t)++-- Abstraction Types+t_unit :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_unit fp = do+  symbol "unit" <|> symbol "()"+  (f,t) <- fieldType fp+  return (f, Mo.Type Mo.TUnit t)++t_pair :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_pair fp = core <|> tuple+  where+    core = do+      symbol "pair"+      (f, t) <- fieldType fp+      (l, a) <- field+      (r, b) <- field+      return (f, Mo.Type (Mo.TPair l r a b) t)+    tuple = try $ do+      symbol "("+      (l, a) <- field+      comma+      (r, b) <- tupleInner <|> field+      symbol ")"+      (f, t) <- fieldType fp+      return (f, Mo.Type (Mo.TPair l r a b) t)+    tupleInner = try $ do+      (l, a) <- field+      comma+      (r, b) <- tupleInner <|> field+      return (Mo.noAnn, Mo.Type (Mo.TPair l r a b) Mo.noAnn)++t_or :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_or fp = core <|> bar+  where+    core = do+      symbol "or"+      (f, t) <- fieldType fp+      (l, a) <- field+      (r, b) <- field+      return (f, Mo.Type (Mo.TOr l r a b) t)+    bar = try $ do+      symbol "("+      (l, a) <- field+      symbol "|"+      (r, b) <- barInner <|> field+      symbol ")"+      (f, t) <- fieldType fp+      return (f, Mo.Type (Mo.TOr l r a b) t)+    barInner = try $ do+      (l, a) <- field+      symbol "|"+      (r, b) <- barInner <|> field+      return (Mo.noAnn, Mo.Type (Mo.TOr l r a b) Mo.noAnn)++t_option :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_option fp = do+  symbol "option"+  (f, t) <- fieldType fp+  (fa, a) <- field+  return (f, Mo.Type (Mo.TOption fa a) t)++t_lambda :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_lambda fp = core <|> slashLambda+  where+    core = do+      symbol "lambda"+      (f, t) <- fieldType fp+      a <- type_+      b <- type_+      return (f, Mo.Type (Mo.TLambda a b) t)+    slashLambda = do+      symbol "\\"+      (f, t) <- fieldType fp+      a <- type_+      symbol "->"+      b <- type_+      return (f, Mo.Type (Mo.TLambda a b) t)++-- Container types+t_list :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_list fp = core <|> bracketList+  where+    core = do+      symbol "list"+      (f, t) <- fieldType fp+      a <- type_+      return (f, Mo.Type (Mo.TList a) t)+    bracketList = do+      a <- brackets type_+      (f, t) <- fieldType fp+      return (f, Mo.Type (Mo.TList a) t)++t_set :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_set fp = core <|> braceSet+  where+    core = do+      symbol "set"+      (f, t) <- fieldType fp+      a <- comparable+      return (f, Mo.Type (Mo.TSet a) t)+    braceSet = do+      a <- braces comparable+      (f, t) <- fieldType fp+      return (f, Mo.Type (Mo.TSet a) t)++t_map :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_map fp = (do symbol "map"; (f, t) <- fieldType fp; a <- comparable; b <- type_; return (f, Mo.Type (Mo.TMap a b) t))++t_big_map :: (Default a) => Parser a -> Parser (a, Mo.Type)+t_big_map fp = (do symbol "big_map"; (f, t) <- fieldType fp; a <- comparable; b <- type_; return (f, Mo.Type (Mo.TBigMap a b) t))++-------------------------------------------------------------------------------+-- Primitive Instruction Parsers+-------------------------------------------------------------------------------+prim :: Parser Mo.ParsedInstr+prim = choice+  [ dropOp, dupOp, swapOp, pushOp, someOp, noneOp, unitOp, ifNoneOp+  , carOp, cdrOp, leftOp, rightOp, ifLeftOp, ifRightOp, nilOp, consOp, ifConsOp+  , sizeOp, emptySetOp, emptyMapOp, iterOp, memOp, getOp, updateOp+  , loopLOp, loopOp, lambdaOp, execOp, dipOp, failWithOp, castOp, renameOp+  , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, addOp, subOp+  , mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp+  , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, selfOp, contractOp+  , transferTokensOp, setDelegateOp, createAccountOp, createContract2Op+  , createContractOp, implicitAccountOp, nowOp, amountOp, balanceOp, checkSigOp+  , sha256Op, sha512Op, blake2BOp, hashKeyOp, stepsToQuotaOp, sourceOp, senderOp+  ]++-- Control Structures++failWithOp :: Parser Mo.ParsedInstr+failWithOp = do symbol' "FAILWITH"; return Mo.FAILWITH++loopOp :: Parser Mo.ParsedInstr+loopOp  = do void $ symbol' "LOOP"; Mo.LOOP <$> ops++loopLOp :: Parser Mo.ParsedInstr+loopLOp = do void $ symbol' "LOOP_LEFT"; Mo.LOOP_LEFT <$> ops++execOp :: Parser Mo.ParsedInstr+execOp = do void $ symbol' "EXEC"; Mo.EXEC <$> noteVDef++dipOp :: Parser Mo.ParsedInstr+dipOp = do void $ symbol' "DIP"; Mo.DIP <$> ops++-- Stack Operations++dropOp :: Parser Mo.ParsedInstr+dropOp = do symbol' "DROP"; return Mo.DROP;++dupOp :: Parser Mo.ParsedInstr+dupOp = do void $ symbol' "DUP"; Mo.DUP <$> noteVDef++swapOp :: Parser Mo.ParsedInstr+swapOp = do symbol' "SWAP"; return Mo.SWAP;++pushOp :: Parser Mo.ParsedInstr+pushOp = do+  symbol' "PUSH"+  v <- noteVDef+  (try $ pushLet v) <|> (push' v)+  where+    pushLet v = do+      lvs <- asks Mo.letValues+      lv <- mkLetVal lvs+      return $ Mo.PUSH v (Mo.lvSig lv) (Mo.lvVal lv)+    push' v = do a <- type_; Mo.PUSH v a <$> value++unitOp :: Parser Mo.ParsedInstr+unitOp = do symbol' "UNIT"; (t, v) <- notesTV; return $ Mo.UNIT t v++lambdaOp :: Parser Mo.ParsedInstr+lambdaOp = do symbol' "LAMBDA"; v <- noteVDef; a <- type_; b <- type_;+              Mo.LAMBDA v a b <$> ops++-- Generic comparison++eqOp :: Parser Mo.ParsedInstr+eqOp = do void $ symbol' "EQ"; Mo.EQ <$> noteVDef++neqOp :: Parser Mo.ParsedInstr+neqOp = do void $ symbol' "NEQ"; Mo.NEQ <$> noteVDef++ltOp :: Parser Mo.ParsedInstr+ltOp = do void $ symbol' "LT"; Mo.LT <$> noteVDef++gtOp :: Parser Mo.ParsedInstr+gtOp = do void $ symbol' "GT"; Mo.GT <$> noteVDef++leOp :: Parser Mo.ParsedInstr+leOp = do void $ symbol' "LE"; Mo.LE <$> noteVDef++geOp :: Parser Mo.ParsedInstr+geOp = do void $ symbol' "GE"; Mo.GE <$> noteVDef++-- ad-hoc comparison++compareOp :: Parser Mo.ParsedInstr+compareOp = do void $ symbol' "COMPARE"; Mo.COMPARE <$> noteVDef++-- Operations on booleans++orOp :: Parser Mo.ParsedInstr+orOp = do void $ symbol' "OR";  Mo.OR <$> noteVDef++andOp :: Parser Mo.ParsedInstr+andOp = do void $ symbol' "AND"; Mo.AND <$> noteVDef++xorOp :: Parser Mo.ParsedInstr+xorOp = do void $ symbol' "XOR"; Mo.XOR <$> noteVDef++notOp :: Parser Mo.ParsedInstr+notOp = do void $ symbol' "NOT"; Mo.NOT <$> noteVDef++-- Operations on integers and natural numbers++addOp :: Parser Mo.ParsedInstr+addOp = do void $ symbol' "ADD"; Mo.ADD <$> noteVDef++subOp :: Parser Mo.ParsedInstr+subOp = do void $ symbol' "SUB"; Mo.SUB <$> noteVDef++mulOp :: Parser Mo.ParsedInstr+mulOp = do void $ symbol' "MUL"; Mo.MUL <$> noteVDef++edivOp :: Parser Mo.ParsedInstr+edivOp = do void $ symbol' "EDIV";Mo.EDIV <$> noteVDef++absOp :: Parser Mo.ParsedInstr+absOp = do void $ symbol' "ABS"; Mo.ABS <$> noteVDef++negOp :: Parser Mo.ParsedInstr+negOp = do symbol' "NEG"; return Mo.NEG;++-- Bitwise logical operators++lslOp :: Parser Mo.ParsedInstr+lslOp = do void $ symbol' "LSL"; Mo.LSL <$> noteVDef++lsrOp :: Parser Mo.ParsedInstr+lsrOp = do void $ symbol' "LSR"; Mo.LSR <$> noteVDef++-- Operations on string's++concatOp :: Parser Mo.ParsedInstr+concatOp = do void $ symbol' "CONCAT"; Mo.CONCAT <$> noteVDef++sliceOp :: Parser Mo.ParsedInstr+sliceOp = do void $ symbol' "SLICE"; Mo.SLICE <$> noteVDef++-- Operations on pairs+pairOp :: Parser Mo.ParsedInstr+pairOp = do symbol' "PAIR"; (t, v, (p, q)) <- notesTVF2; return $ Mo.PAIR t v p q++carOp :: Parser Mo.ParsedInstr+carOp = do symbol' "CAR"; (v, f) <- notesVF; return $ Mo.CAR v f++cdrOp :: Parser Mo.ParsedInstr+cdrOp = do symbol' "CDR"; (v, f) <- notesVF; return $ Mo.CDR v f++-- Operations on collections (sets, maps, lists)++emptySetOp :: Parser Mo.ParsedInstr+emptySetOp = do symbol' "EMPTY_SET"; (t, v) <- notesTV;+                Mo.EMPTY_SET t v <$> comparable++emptyMapOp :: Parser Mo.ParsedInstr+emptyMapOp = do symbol' "EMPTY_MAP"; (t, v) <- notesTV; a <- comparable;+                Mo.EMPTY_MAP t v a <$> type_++memOp :: Parser Mo.ParsedInstr+memOp = do void $ symbol' "MEM"; Mo.MEM <$> noteVDef++updateOp :: Parser Mo.ParsedInstr+updateOp = do symbol' "UPDATE"; return Mo.UPDATE++iterOp :: Parser Mo.ParsedInstr+iterOp = do void $ symbol' "ITER"; Mo.ITER <$> ops++sizeOp :: Parser Mo.ParsedInstr+sizeOp = do void $ symbol' "SIZE"; Mo.SIZE <$> noteVDef++mapOp :: Parser Mo.ParsedInstr+mapOp = do symbol' "MAP"; v <- noteVDef; Mo.MAP v <$> ops++getOp :: Parser Mo.ParsedInstr+getOp = do void $ symbol' "GET"; Mo.GET <$> noteVDef++nilOp :: Parser Mo.ParsedInstr+nilOp = do symbol' "NIL"; (t, v) <- notesTV; Mo.NIL t v <$> type_++consOp :: Parser Mo.ParsedInstr+consOp = do void $ symbol' "CONS"; Mo.CONS <$> noteVDef++ifConsOp :: Parser Mo.ParsedInstr+ifConsOp = do symbol' "IF_CONS"; a <- ops; Mo.IF_CONS a <$> ops++-- Operations on options++someOp :: Parser Mo.ParsedInstr+someOp = do symbol' "SOME"; (t, v, f) <- notesTVF; return $ Mo.SOME t v f++noneOp :: Parser Mo.ParsedInstr+noneOp = do symbol' "NONE"; (t, v, f) <- notesTVF; Mo.NONE t v f <$> type_++ifNoneOp :: Parser Mo.ParsedInstr+ifNoneOp = do symbol' "IF_NONE"; a <- ops; Mo.IF_NONE a <$> ops++-- Operations on unions++leftOp :: Parser Mo.ParsedInstr+leftOp = do symbol' "LEFT"; (t, v, (f, f')) <- notesTVF2;+               Mo.LEFT t v f f' <$> type_++rightOp :: Parser Mo.ParsedInstr+rightOp = do symbol' "RIGHT"; (t, v, (f, f')) <- notesTVF2;+               Mo.RIGHT t v f f' <$> type_++ifLeftOp :: Parser Mo.ParsedInstr+ifLeftOp = do symbol' "IF_LEFT"; a <- ops; Mo.IF_LEFT a <$> ops++ifRightOp :: Parser Mo.ParsedInstr+ifRightOp = do symbol' "IF_RIGHT"; a <- ops; Mo.IF_RIGHT a <$> ops++-- Operations on contracts++createContractOp :: Parser Mo.ParsedInstr+createContractOp = do symbol' "CREATE_CONTRACT"; v <- noteVDef;+                       Mo.CREATE_CONTRACT v <$> noteVDef++createContract2Op :: Parser Mo.ParsedInstr+createContract2Op = do symbol' "CREATE_CONTRACT"; v <- noteVDef; v' <- noteVDef;+                       Mo.CREATE_CONTRACT2 v v' <$> braces contract++createAccountOp :: Parser Mo.ParsedInstr+createAccountOp = do symbol' "CREATE_ACCOUNT"; v <- noteVDef; v' <- noteVDef;+                       return $ Mo.CREATE_ACCOUNT v v'++transferTokensOp :: Parser Mo.ParsedInstr+transferTokensOp = do void $ symbol' "TRANSFER_TOKENS"; Mo.TRANSFER_TOKENS <$> noteVDef++setDelegateOp :: Parser Mo.ParsedInstr+setDelegateOp = do void $ symbol' "SET_DELEGATE"; Mo.SET_DELEGATE <$> noteVDef++balanceOp :: Parser Mo.ParsedInstr+balanceOp = do void $ symbol' "BALANCE"; Mo.BALANCE <$> noteVDef++contractOp :: Parser Mo.ParsedInstr+contractOp = do void $ symbol' "CONTRACT"; Mo.CONTRACT <$> noteVDef <*> type_++sourceOp :: Parser Mo.ParsedInstr+sourceOp = do void $ symbol' "SOURCE"; Mo.SOURCE <$> noteVDef++senderOp :: Parser Mo.ParsedInstr+senderOp = do void $ symbol' "SENDER"; Mo.SENDER <$> noteVDef++amountOp :: Parser Mo.ParsedInstr+amountOp = do void $ symbol' "AMOUNT"; Mo.AMOUNT <$> noteVDef++implicitAccountOp :: Parser Mo.ParsedInstr+implicitAccountOp = do void $ symbol' "IMPLICIT_ACCOUNT"; Mo.IMPLICIT_ACCOUNT <$> noteVDef++selfOp :: Parser Mo.ParsedInstr+selfOp = do void $ symbol' "SELF"; Mo.SELF <$> noteVDef++addressOp :: Parser Mo.ParsedInstr+addressOp = do void $ symbol' "ADDRESS"; Mo.ADDRESS <$> noteVDef++-- Special Operations+nowOp :: Parser Mo.ParsedInstr+nowOp = do void $ symbol' "NOW"; Mo.NOW <$> noteVDef++stepsToQuotaOp :: Parser Mo.ParsedInstr+stepsToQuotaOp = do void $ symbol' "STEPS_TO_QUOTA"; Mo.STEPS_TO_QUOTA <$> noteVDef++-- Operations on bytes+packOp :: Parser Mo.ParsedInstr+packOp = do void $ symbol' "PACK"; Mo.PACK <$> noteVDef++unpackOp :: Parser Mo.ParsedInstr+unpackOp = do symbol' "UNPACK"; v <- noteVDef; Mo.UNPACK v <$> type_++-- Cryptographic Primitives++checkSigOp :: Parser Mo.ParsedInstr+checkSigOp = do void $ symbol' "CHECK_SIGNATURE"; Mo.CHECK_SIGNATURE <$> noteVDef++blake2BOp :: Parser Mo.ParsedInstr+blake2BOp = do void $ symbol' "BLAKE2B"; Mo.BLAKE2B <$> noteVDef++sha256Op :: Parser Mo.ParsedInstr+sha256Op = do void $ symbol' "SHA256"; Mo.SHA256 <$> noteVDef++sha512Op :: Parser Mo.ParsedInstr+sha512Op = do void $ symbol' "SHA512"; Mo.SHA512 <$> noteVDef++hashKeyOp :: Parser Mo.ParsedInstr+hashKeyOp = do void $ symbol' "HASH_KEY"; Mo.HASH_KEY <$> noteVDef++{- Type operations -}+castOp :: Parser Mo.ParsedInstr+castOp = do void $ symbol' "CAST"; Mo.CAST <$> noteVDef <*> type_;++renameOp :: Parser Mo.ParsedInstr+renameOp = do void $ symbol' "RENAME"; Mo.RENAME <$> noteVDef++isNatOp :: Parser Mo.ParsedInstr+isNatOp = do void $ symbol' "ISNAT"; Mo.ISNAT <$> noteVDef++intOp :: Parser Mo.ParsedInstr+intOp = do void $ symbol' "INT"; Mo.INT <$> noteVDef++-------------------------------------------------------------------------------+-- Macro Parsers+-------------------------------------------------------------------------------+cmpOp :: Parser Mo.ParsedInstr+cmpOp = eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp++macro :: Parser Mo.Macro+macro = do symbol' "CMP"; a <- cmpOp; Mo.CMP a <$> noteVDef+  <|> do symbol' "IF_SOME"; a <- ops; Mo.IF_SOME a <$> ops+  <|> do symbol' "FAIL"; return Mo.FAIL+  <|> do void $ symbol' "ASSERT_CMP"; Mo.ASSERT_CMP <$> cmpOp+  <|> do symbol' "ASSERT_NONE"; return Mo.ASSERT_NONE+  <|> do symbol' "ASSERT_SOME"; return Mo.ASSERT_SOME+  <|> do symbol' "ASSERT_LEFT"; return Mo.ASSERT_LEFT+  <|> do symbol' "ASSERT_RIGHT"; return Mo.ASSERT_RIGHT+  <|> do void $ symbol' "ASSERT_"; Mo.ASSERTX <$> cmpOp+  <|> do symbol' "ASSERT"; return Mo.ASSERT+  <|> do string' "DI"; n <- num "I"; symbol' "P"; Mo.DIIP (n + 1) <$> ops+  <|> do string' "DU"; n <- num "U"; symbol' "P"; Mo.DUUP (n + 1) <$> noteVDef+  <|> unpairMac+  <|> cadrMac+  <|> setCadrMac+  where+   num str = fromIntegral . length <$> some (string' str)++pairMac :: Parser Mo.Macro+pairMac = do+  a <- pairMacInner+  symbol' "R"+  (tn, vn, fns) <- permute3Def noteTDef noteV (some noteF)+  let ps = Macro.mapLeaves ((Mo.noAnn,) <$> fns) a+  return $ Mo.PAPAIR ps tn vn++pairMacInner :: Parser Mo.PairStruct+pairMacInner = do+  string' "P"+  l <- (string' "A" >> return (Mo.F (Mo.noAnn, Mo.noAnn))) <|> pairMacInner+  r <- (string' "I" >> return (Mo.F (Mo.noAnn, Mo.noAnn))) <|> pairMacInner+  return $ Mo.P l r++unpairMac :: Parser Mo.Macro+unpairMac = do+  string' "UN"+  a <- pairMacInner+  symbol' "R"+  (vns, fns) <- permute2Def (some noteV) (some noteF)+  return $ Mo.UNPAIR (Macro.mapLeaves (zip vns fns) a)++cadrMac :: Parser Mo.Macro+cadrMac = lexeme $ do+  string' "C"+  a <- some $ try $ cadrInner <* notFollowedBy (string' "R")+  b <- cadrInner+  symbol' "R"+  (vn, fn) <- notesVF+  return $ Mo.CADR (a ++ pure b) vn fn++cadrInner :: Parser Mo.CadrStruct+cadrInner = (string' "A" >> return Mo.A) <|> (string' "D" >> return Mo.D)++setCadrMac :: Parser Mo.Macro+setCadrMac = do+  string' "SET_C"+  a <- some cadrInner+  symbol' "R"+  (v, f) <- notesVF+  return $ Mo.SET_CADR a v f++mapCadrMac :: Parser Mo.Macro+mapCadrMac = do+  string' "MAP_C"+  a <- some cadrInner+  symbol' "R"+  (v, f) <- notesVF+  Mo.MAP_CADR a v f <$> ops++ifCmpMac :: Parser Mo.Macro+ifCmpMac = symbol' "IFCMP" >> Mo.IFCMP <$> cmpOp <*> noteVDef <*> ops <*> ops++ifOrIfX :: Parser Mo.ParsedOp+ifOrIfX = do+  symbol' "IF"+  a <- eitherP cmpOp ops+  case a of+    Left cmp -> Mo.MAC <$> (Mo.IFX cmp <$> ops <*> ops)+    Right op -> Mo.PRIM <$> (Mo.IF op <$> ops)++-- Some of the operations and macros have the same prefixes in their names+-- So this case should be handled separately+primOrMac :: Parser Mo.ParsedOp+primOrMac = ((Mo.MAC <$> ifCmpMac) <|> ifOrIfX)+  <|> ((Mo.MAC <$> mapCadrMac) <|> (Mo.PRIM <$> mapOp))+  <|> (try (Mo.PRIM <$> pairOp) <|> Mo.MAC <$> pairMac)++-------------------------------------------------------------------------------+-- Morley Instructions+-------------------------------------------------------------------------------++nopInstr :: Parser Mo.ParsedUExtInstr+nopInstr = choice [stackOp, testAssertOp, printOp]++stackOp :: Parser Mo.ParsedUExtInstr+stackOp = symbol' "STACKTYPE" >> Mo.STACKTYPE <$> stackType++testAssertOp :: Parser Mo.ParsedUExtInstr+testAssertOp = symbol' "TEST_ASSERT" >> Mo.UTEST_ASSERT <$> testAssert++printOp :: Parser Mo.ParsedUExtInstr+printOp = symbol' "PRINT" >> Mo.UPRINT <$> printComment++testAssert :: Parser Mo.ParsedUTestAssert+testAssert = do+  n <- lexeme (T.pack <$> some alphaNumChar)+  c <- printComment+  o <- ops+  return $ Mo.UTestAssert n c o++printComment :: Parser Mo.PrintComment+printComment = do+  string "\""+  let validChar = T.pack <$> some (satisfy (\x -> x /= '%' && x /= '"'))+  c <- many (Right <$> stackRef <|> Left <$> validChar)+  symbol "\""+  return $ Mo.PrintComment c++stackRef :: Parser Mo.StackRef+stackRef = do+  string "%"+  n <- brackets' L.decimal+  return $ Mo.StackRef n++stackType :: Parser Mo.StackTypePattern+stackType = symbol "'[" >> (emptyStk <|> stkCons <|> stkRest)+  where+    emptyStk = try $ symbol "]" >> return Mo.StkEmpty+    stkRest = try $ symbol "..." >> symbol "]" >> return Mo.StkRest+    stkCons = try $ do+      t <- tyVar+      s <- (symbol "," >> stkCons <|> stkRest) <|> emptyStk+      return $ Mo.StkCons t s
+ src/Morley/Parser/Annotations.hs view
@@ -0,0 +1,89 @@+module Morley.Parser.Annotations+  ( note+  , noteT+  , noteV+  , noteF+  , noteF2+  , noteTDef+  , noteVDef+  , _noteFDef+  , notesTVF+  , notesTVF2+  , notesTV+  , notesVF+  , fieldType+  , permute2Def+  , permute3Def+  ) where++import Prelude hiding (many, note, some, try)++import Control.Applicative.Permutations+  (runPermutation, toPermutationWithDefault)+import Data.Char (isAlpha, isAlphaNum, isAscii)+import qualified Data.Text as T+import Text.Megaparsec (satisfy, takeWhileP, try)+import Text.Megaparsec.Char (string)++import Morley.Default+import Morley.Lexer+import Morley.Types (Parser)+import qualified Morley.Types as Mo++-- General T/V/F Annotation parser+note :: T.Text -> Parser T.Text+note c = lexeme $ string c >> (note' <|> emptyNote)+  where+    emptyNote = pure ""+    note' = do+      a <- string "@"+           <|> string "%%"+           <|> string "%"+           <|> T.singleton <$> satisfy (\ x -> isAlpha x && isAscii x)+      let validChar x =+            isAscii x && (isAlphaNum x || x == '\\' || x == '.' || x == '_')+      b <- takeWhileP Nothing validChar+      return $ T.append a b++noteT :: Parser Mo.TypeAnn+noteT = Mo.ann <$> note ":"++noteV :: Parser Mo.VarAnn+noteV = Mo.ann <$> note "@"++noteF :: Parser Mo.FieldAnn+noteF = Mo.ann <$> note "%"++noteF2 :: Parser (Mo.FieldAnn, Mo.FieldAnn)+noteF2 = do a <- noteF; b <- noteF; return (a, b)++parseDef :: Default a => Parser a -> Parser a+parseDef a = try a <|> pure def++noteTDef :: Parser Mo.TypeAnn+noteTDef = parseDef noteT++noteVDef :: Parser Mo.VarAnn+noteVDef = parseDef noteV++_noteFDef :: Parser Mo.FieldAnn+_noteFDef = parseDef noteF++notesTVF :: Parser (Mo.TypeAnn, Mo.VarAnn, Mo.FieldAnn)+notesTVF = permute3Def noteT noteV noteF++notesTVF2 :: Parser (Mo.TypeAnn, Mo.VarAnn, (Mo.FieldAnn, Mo.FieldAnn))+notesTVF2 = permute3Def noteT noteV noteF2++notesTV :: Parser (Mo.TypeAnn, Mo.VarAnn)+notesTV = permute2Def noteT noteV++notesVF :: Parser (Mo.VarAnn, Mo.FieldAnn)+notesVF  = permute2Def noteV noteF++fieldType :: Default a+          => Parser a+          -> Parser (a, Mo.TypeAnn)+fieldType fp = runPermutation $+  (,) <$> toPermutationWithDefault  def     fp+      <*> toPermutationWithDefault Mo.noAnn noteT
+ src/Morley/Runtime.hs view
@@ -0,0 +1,442 @@+-- | Interpreter of a contract in Morley language.++module Morley.Runtime+       (+         -- * High level interface for end user+         originateContract+       , runContract+       , transfer++       -- * Other helpers+       , readAndParseContract+       , prepareContract++       -- * Re-exports+       , ContractState (..)+       , AddressState (..)+       , TxData (..)++       -- * For testing+       , InterpreterOp (..)+       , InterpreterRes (..)+       , InterpreterError (..)+       , interpreterPure+       ) where++import Control.Lens (at, makeLenses, (%=), (.=), (<>=))+import Control.Monad.Except (Except, runExcept, throwError)+import Data.Default (def)+import qualified Data.Map.Strict as Map+import Data.Text.IO (getContents)+import Fmt (Buildable(build), blockListF, fmtLn, nameF, pretty, (+|), (|+))+import Named ((:!), (:?), arg, argDef, defaults, (!))+import Text.Megaparsec (parse)++import Michelson.Interpret+  (ContractEnv(..), InterpretUntypedError(..), InterpretUntypedResult(..), InterpreterState(..),+  RemainingSteps(..))+import Michelson.TypeCheck (TCError)+import Michelson.Typed+  (CreateContract(..), Instr, Operation(..), TransferTokens(..), Val(..), convertContract,+  unsafeValToValue)+import Michelson.Untyped (Contract(..), Op(..), OriginationOperation(..), Value, mkContractAddress)+import Morley.Aliases (UntypedContract)+import Morley.Ext (interpretMorleyUntyped, typeCheckMorleyContract)+import Morley.Macro (expandFlattenContract)+import qualified Morley.Parser as P+import Morley.Runtime.GState+import Morley.Runtime.TxData+import Morley.Types (MorleyLogs(..), ParsedOp, noMorleyLogs)+import Tezos.Address (Address(..))+import Tezos.Core (Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez)+import Tezos.Crypto (parseKeyHash)++----------------------------------------------------------------------------+-- Auxiliary types+----------------------------------------------------------------------------++-- | Operations executed by interpreter.+-- In our model one Michelson's operation (`operation` type in Michelson)+-- corresponds to 0 or 1 interpreter operation.+--+-- Note: 'Address' is not part of 'TxData', because 'TxData' is+-- supposed to be provided by the user, while 'Address' can be+-- computed by our code.+data InterpreterOp+  = OriginateOp !OriginationOperation+  -- ^ Originate a contract.+  | TransferOp Address+               TxData+  -- ^ Send a transaction to given address which is assumed to be the+  -- address of an originated contract.+  deriving (Show)++-- | Result of a single execution of interpreter.+data InterpreterRes = InterpreterRes+  { _irGState :: !GState+  -- ^ New 'GState'.+  , _irOperations :: [InterpreterOp]+  -- ^ List of operations to be added to the operations queue.+  , _irUpdates :: ![GStateUpdate]+  -- ^ Updates applied to 'GState'.+  , _irPrintedLogs :: [MorleyLogs]+  -- ^ During execution a contract can print logs,+  -- all logs are kept until all called contracts are executed+  , _irSourceAddress :: !(Maybe Address)+  -- ^ As soon as transfer operation is encountered, this address is+  -- set to its input.+  , _irRemainingSteps :: !RemainingSteps+  } deriving (Show)++makeLenses ''InterpreterRes++-- | Errors that can happen during contract interpreting.+data InterpreterError+  = IEUnknownContract !Address+  -- ^ The interpreted contract hasn't been originated.+  | IEInterpreterFailed !(Contract Op)+                        !(InterpretUntypedError MorleyLogs)+  -- ^ Interpretation of Michelson contract failed.+  | IEAlreadyOriginated !Address+                        !ContractState+  -- ^ A contract is already originated.+  | IEUnknownSender !Address+  -- ^ Sender address is unknown.+  | IEUnknownManager !Address+  -- ^ Manager address is unknown.+  | IENotEnoughFunds !Address !Mutez+  -- ^ Sender doesn't have enough funds.+  | IEFailedToApplyUpdates !GStateUpdateError+  -- ^ Failed to apply updates to GState.+  | IEIllTypedContract !TCError+  -- ^ A contract is ill-typed.+  deriving (Show)++instance Buildable InterpreterError where+  build =+    \case+      IEUnknownContract addr -> "The contract is not originated " +| addr |+ ""+      IEInterpreterFailed _ err -> "Michelson interpreter failed: " +| err |+ ""+      IEAlreadyOriginated addr cs ->+        "The following contract is already originated: " +| addr |++        ", " +| cs |+ ""+      IEUnknownSender addr -> "The sender address is unknown " +| addr |+ ""+      IEUnknownManager addr -> "The manager address is unknown " +| addr |+ ""+      IENotEnoughFunds addr amount ->+        "The sender (" +| addr |++        ") doesn't  have enough funds (has only " +| amount |+ ")"+      IEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ ""+      IEIllTypedContract err -> "The contract is ill-typed " +| err |+ ""++instance Exception InterpreterError where+  displayException = pretty++----------------------------------------------------------------------------+-- Interface+----------------------------------------------------------------------------++-- | Read and parse a contract from give path or `stdin` (if the+-- argument is 'Nothing'). The contract is not expanded.+readAndParseContract :: Maybe FilePath -> IO (Contract ParsedOp)+readAndParseContract mFilename = do+  code <- readCode mFilename+  let filename = fromMaybe "<stdin>" mFilename+  either (throwM . P.ParserException) pure $+    parse P.program filename code+  where+    readCode :: Maybe FilePath -> IO Text+    readCode = maybe getContents readFile++-- | Read a contract using 'readAndParseContract', expand and+-- flatten. The contract is not type checked.+prepareContract :: Maybe FilePath -> IO (Contract Op)+prepareContract mFile = expandFlattenContract <$> readAndParseContract mFile++-- | Originate a contract. Returns the address of the originated+-- contract.+originateContract ::+     FilePath -> OriginationOperation -> "verbose" :! Bool -> IO Address+originateContract dbPath origination verbose =+  -- pass 100500 as maxSteps, because it doesn't matter for origination,+  -- as well as 'now'+  mkContractAddress origination <$+  interpreter Nothing 100500 dbPath [OriginateOp origination] verbose+  ! defaults++-- | Run a contract. The contract is originated first (if it's not+-- already) and then we pretend that we send a transaction to it.+runContract+  :: Maybe Timestamp+  -> Word64+  -> Mutez+  -> FilePath+  -> Value Op+  -> Contract Op+  -> TxData+  -> "verbose" :! Bool+  -> "dryRun" :! Bool+  -> IO ()+runContract maybeNow maxSteps initBalance dbPath storageValue contract txData+  verbose (arg #dryRun -> dryRun) =+  interpreter maybeNow maxSteps dbPath operations verbose ! #dryRun dryRun+  where+    -- We hardcode some random key hash here as delegate to make sure that:+    -- 1. Contract's address won't clash with already originated one (because+    -- it may have different storage value which may be confusing).+    -- 2. If one uses this functionality twice with the same contract and+    -- other data, the contract will have the same address.+    delegate =+      either (error . mappend "runContract can't parse delegate: " . pretty) id $+      parseKeyHash "tz1YCABRTa6H8PLKx2EtDWeCGPaKxUhNgv47"+    origination = OriginationOperation+      { ooManager = genesisKeyHash+      , ooDelegate = Just delegate+      , ooSpendable = False+      , ooDelegatable = False+      , ooBalance = initBalance+      , ooStorage = storageValue+      , ooContract = contract+      }+    addr = mkContractAddress origination+    operations =+      [ OriginateOp origination+      , TransferOp addr txData+      ]++-- | Send a transaction to given address with given parameters.+transfer ::+     Maybe Timestamp+  -> Word64+  -> FilePath+  -> Address+  -> TxData+  -> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()+transfer maybeNow maxSteps dbPath destination txData =+  interpreter maybeNow maxSteps dbPath [TransferOp destination txData]++----------------------------------------------------------------------------+-- Interpreter+----------------------------------------------------------------------------++-- | Interpret a contract on some global state (read from file) and+-- transaction data (passed explicitly).+interpreter ::+     Maybe Timestamp+  -> Word64+  -> FilePath+  -> [InterpreterOp]+  -> "verbose" :! Bool -> "dryRun" :? Bool -> IO ()+interpreter maybeNow maxSteps dbPath operations+  (arg #verbose -> verbose)+  (argDef #dryRun False -> dryRun)+    = do+  now <- maybe getCurrentTime pure maybeNow+  gState <- readGState dbPath+  let eitherRes =+        interpreterPure now (RemainingSteps maxSteps) gState operations+  InterpreterRes {..} <- either throwM pure eitherRes+  when (verbose && not (null _irUpdates)) $ do+    fmtLn $ nameF "Updates:" (blockListF _irUpdates)+    putTextLn $ "Remaining gas: " <> pretty _irRemainingSteps+  forM_ _irPrintedLogs $ \(MorleyLogs logs) -> do+    mapM_ putTextLn logs+    putTextLn "" -- extra break line to separate logs from two sequence contracts+  unless dryRun $+    writeGState dbPath _irGState++-- | Implementation of interpreter outside 'IO'.  It reads operations,+-- interprets them one by one and updates state accordingly.+interpreterPure ::+  Timestamp -> RemainingSteps -> GState -> [InterpreterOp] -> Either InterpreterError InterpreterRes+interpreterPure now maxSteps gState ops =+    runExcept (execStateT (statefulInterpreter now) initialState)+  where+    initialState = InterpreterRes+      { _irGState = gState+      , _irOperations = ops+      , _irUpdates = mempty+      , _irPrintedLogs = def+      , _irSourceAddress = Nothing+      , _irRemainingSteps = maxSteps+      }++statefulInterpreter+  :: Timestamp+  -> StateT InterpreterRes (Except InterpreterError) ()+statefulInterpreter now = do+  curGState <- use irGState+  mSourceAddr <- use irSourceAddress+  remainingSteps <- use irRemainingSteps+  use irOperations >>= \case+    [] -> pass+    (op:opsTail) ->+      either throwError (processIntRes opsTail) $+      interpretOneOp now remainingSteps mSourceAddr curGState op+  where+    processIntRes opsTail InterpreterRes {..} = do+      irGState .= _irGState+      irOperations .= opsTail <> _irOperations+      irUpdates <>= _irUpdates+      irPrintedLogs <>= _irPrintedLogs+      irSourceAddress %= (<|> _irSourceAddress)+      irRemainingSteps .= _irRemainingSteps+      statefulInterpreter now++-- | Run only one interpreter operation and update 'GState' accordingly.+interpretOneOp+  :: Timestamp+  -> RemainingSteps+  -> Maybe Address+  -> GState+  -> InterpreterOp+  -> Either InterpreterError InterpreterRes+interpretOneOp _ remainingSteps _ gs (OriginateOp origination) = do+  void $ first IEIllTypedContract $+    typeCheckMorleyContract (unOp <$> ooContract origination)+  let originatorAddress = KeyAddress (ooManager origination)+  originatorBalance <- case gsAddresses gs ^. at (originatorAddress) of+    Nothing -> Left (IEUnknownManager originatorAddress)+    Just (asBalance -> oldBalance)+      | oldBalance < ooBalance origination ->+        Left (IENotEnoughFunds originatorAddress oldBalance)+      | otherwise ->+        -- Subtraction is safe because we have checked its+        -- precondition in guard.+        Right (oldBalance `unsafeSubMutez` ooBalance origination)+  let+    updates =+      [ GSAddAddress address (ASContract contractState)+      , GSSetBalance originatorAddress originatorBalance+      ]+  case applyUpdates updates gs of+    Left _ -> Left (IEAlreadyOriginated address contractState)+    Right newGS -> Right $+      InterpreterRes+      { _irGState = newGS+      , _irOperations = mempty+      , _irUpdates = updates+      , _irPrintedLogs = def+      , _irSourceAddress = Nothing+      , _irRemainingSteps = remainingSteps+      }+  where+    contractState = ContractState+      { csBalance = ooBalance origination+      , csStorage = ooStorage origination+      , csContract = ooContract origination+      }+    address = mkContractAddress origination+interpretOneOp now remainingSteps mSourceAddr gs (TransferOp addr txData) = do+    let sourceAddr = fromMaybe (tdSenderAddress txData) mSourceAddr+    let senderAddr = tdSenderAddress txData+    decreaseSenderBalance <- case addresses ^. at senderAddr of+      Nothing -> Left (IEUnknownSender senderAddr)+      Just (asBalance -> balance)+        | balance < tdAmount txData ->+          Left (IENotEnoughFunds senderAddr balance)+        | otherwise ->+          -- Subtraction is safe because we have checked its+          -- precondition in guard.+          Right (GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData))+    let onlyUpdates updates = Right (updates, [], noMorleyLogs, remainingSteps)+    (otherUpdates, sideEffects, logs, newRemSteps) <- case (addresses ^. at addr, addr) of+      (Nothing, ContractAddress _) ->+        Left (IEUnknownContract addr)+      (Nothing, KeyAddress _) -> do+        let+          addrState = ASSimple (tdAmount txData)+          upd = GSAddAddress addr addrState+        onlyUpdates [upd]+      (Just (ASSimple oldBalance), _) -> do+        -- can't overflow if global state is correct (because we can't+        -- create money out of nowhere)+        let+          newBalance = oldBalance `unsafeAddMutez` tdAmount txData+          upd = GSSetBalance addr newBalance+        onlyUpdates [upd]+      (Just (ASContract cs), _) -> do+        let+          contract = csContract cs+          contractEnv = ContractEnv+            { ceNow = now+            , ceMaxSteps = remainingSteps+            , ceBalance = csBalance cs+            , ceContracts = Map.mapMaybe extractContract addresses+            , ceSelf = addr+            , ceSource = sourceAddr+            , ceSender = senderAddr+            , ceAmount = tdAmount txData+            }+        InterpretUntypedResult+          { iurOps = sideEffects+          , iurNewStorage = newValue+          , iurNewState = InterpreterState printedLogs newRemainingSteps+          }+          <- first (IEInterpreterFailed contract) $+                interpretMorleyUntyped contract (tdParameter txData)+                                 (csStorage cs) contractEnv+        let+          newValueU = unsafeValToValue newValue+          -- can't overflow if global state is correct (because we can't+          -- create money out of nowhere)+          newBalance = csBalance cs `unsafeAddMutez` tdAmount txData+          updBalance = GSSetBalance addr newBalance+          updStorage = GSSetStorageValue addr newValueU+          updates =+            [ updBalance+            , updStorage+            ]+        Right (updates, sideEffects, printedLogs, newRemainingSteps)++    let+      updates = decreaseSenderBalance:otherUpdates++    newGState <- first IEFailedToApplyUpdates $ applyUpdates updates gs++    return InterpreterRes+      { _irGState = newGState+      , _irOperations = mapMaybe (convertOp addr) sideEffects+      , _irUpdates = updates+      , _irPrintedLogs = [logs]+      , _irSourceAddress = Just sourceAddr+      , _irRemainingSteps = newRemSteps+      }+  where+    addresses :: Map Address AddressState+    addresses = gsAddresses gs++    extractContract :: AddressState -> Maybe UntypedContract+    extractContract =+      \case ASSimple {} -> Nothing+            ASContract cs -> Just (csContract cs)++----------------------------------------------------------------------------+-- Simple helpers+----------------------------------------------------------------------------++-- The argument is the address of the contract that generation this operation.+convertOp :: Address -> Operation Instr -> Maybe InterpreterOp+convertOp interpretedAddr =+  \case+    OpTransferTokens tt ->+      let txData =+            TxData+              { tdSenderAddress = interpretedAddr+              , tdParameter = unsafeValToValue (ttContractParameter tt)+              , tdAmount = ttAmount tt+              }+          VContract destAddress = ttContract tt+       in Just (TransferOp destAddress txData)+    OpSetDelegate {} -> Nothing+    OpCreateAccount {} -> Nothing+    OpCreateContract cc ->+      let origination = OriginationOperation+            { ooManager = ccManager cc+            , ooDelegate = ccDelegate cc+            , ooSpendable = ccSpendable cc+            , ooDelegatable = ccDelegatable cc+            , ooBalance = ccBalance cc+            , ooStorage = unsafeValToValue (ccStorageVal cc)+            , ooContract = convertContract (ccContractCode cc)+            }+       in Just (OriginateOp origination)
+ src/Morley/Runtime/GState.hs view
@@ -0,0 +1,218 @@+-- | Global blockchain state (emulated).++module Morley.Runtime.GState+       (+         -- * Auxiliary types+         ContractState (..)+       , AddressState (..)+       , asBalance++       -- * GState+       , GState (..)+       , genesisAddress+       , genesisAddressText+       , genesisKeyHash+       , initGState+       , readGState+       , writeGState++       -- * Operations on GState+       , GStateUpdate (..)+       , GStateUpdateError (..)+       , applyUpdate+       , applyUpdates+       ) where++import Control.Lens (at)+import qualified Data.Aeson as Aeson+import Data.Aeson.Options (defaultOptions)+import Data.Aeson.TH (deriveJSON)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map.Strict as Map+import Fmt (genericF, pretty, (+|), (|+))+import Formatting.Buildable (Buildable(build))+import System.IO.Error (IOError, isDoesNotExistError)++import Morley.Aliases (UntypedContract, UntypedValue)+import Morley.Types ()+import Tezos.Address (Address(..))+import Tezos.Core (Mutez)+import Tezos.Crypto (KeyHash, parseKeyHash)++-- | State of a contract with code.+data ContractState = ContractState+  { csBalance :: !Mutez+  -- ^ Amount of mutez owned by this contract.+  , csStorage :: !UntypedValue+  -- ^ Storage value associated with this contract.+  , csContract :: !UntypedContract+  -- ^ Contract itself (untyped).+  } deriving (Show, Generic, Eq)++instance Buildable ContractState where+  build = genericF++deriveJSON defaultOptions ''ContractState++-- | State of an arbitrary address.+data AddressState+  = ASSimple !Mutez+  -- ^ For contracts without code we store only its balance.+  | ASContract !ContractState+  -- ^ For contracts with code we store more state represented by+  -- 'ContractState'.+  deriving (Show, Generic, Eq)++instance Buildable AddressState where+  build =+    \case+      ASSimple balance -> "Balance = " +| balance |+ ""+      ASContract cs -> build cs++deriveJSON defaultOptions ''AddressState++-- | Extract balance from 'AddressState'.+asBalance :: AddressState -> Mutez+asBalance =+  \case+    ASSimple b -> b+    ASContract cs -> csBalance cs++-- | Persistent data passed to Morley contracts which can be updated+-- as result of contract execution.+data GState = GState+  { gsAddresses :: Map Address AddressState+  -- ^ All known addresses and their state.+  } deriving Show++deriveJSON defaultOptions ''GState++-- | Initially this address has a lot of money.+genesisAddressText :: Text+genesisAddressText = "tz1Yz3VPaCNB5FjhdEVnSoN8Xv3ZM8g2LYhw"++-- | KeyHash of genesis address.+genesisKeyHash :: KeyHash+genesisKeyHash =+  either (error . mappend "genesisKeyHash: " . pretty) id $+  parseKeyHash genesisAddressText++-- | Initially this address has a lot of money.+genesisAddress :: Address+genesisAddress = KeyAddress genesisKeyHash++-- | Initial 'GState'. It's supposed to be used if no 'GState' is+-- provided. For now it's empty, but we can hardcode some dummy data+-- in the future.+initGState :: GState+initGState =+  GState+  { gsAddresses = Map.fromList+    [ (genesisAddress, ASSimple maxBound)+    ]+  }++data GStateParseError =+  GStateParseError String+  deriving Show++instance Exception GStateParseError where+  displayException (GStateParseError str) = "Failed to parse GState: " <> str++-- | Read 'GState' from a file.+readGState :: FilePath -> IO GState+readGState fp = (LBS.readFile fp >>= parseFile) `catch` onExc+  where+    parseFile :: LByteString -> IO GState+    parseFile = either (throwM . GStateParseError) pure . Aeson.eitherDecode'+    onExc :: IOError -> IO GState+    onExc exc+      | isDoesNotExistError exc = pure initGState+      | otherwise = throwM exc++-- | Write 'GState' to a file.+writeGState :: FilePath -> GState -> IO ()+writeGState fp gs = LBS.writeFile fp (Aeson.encode gs)++-- | Updates that can be applied to 'GState'.+data GStateUpdate+  = GSAddAddress !Address+                 !AddressState+  | GSSetStorageValue !Address+                      !UntypedValue+  | GSSetBalance !Address+                 !Mutez+  deriving (Show, Eq)++instance Buildable GStateUpdate where+  build =+    \case+      GSAddAddress addr st ->+        "Add address " +| addr |+ " with state " +| st |+ ""+      GSSetStorageValue addr val ->+        "Set storage value of address " +| addr |+ " to " +| val |+ ""+      GSSetBalance addr balance ->+        "Set balance of address " +| addr |+ " to " +| balance |+ ""++data GStateUpdateError+  = GStateAddressExists !Address+  | GStateUnknownAddress !Address+  | GStateNotContract !Address+  deriving (Show)++instance Buildable GStateUpdateError where+  build =+    \case+      GStateAddressExists addr -> "Address already exists: " <> build addr+      GStateUnknownAddress addr -> "Unknown address: " <> build addr+      GStateNotContract addr -> "Address doesn't have contract: " <> build addr++-- | Apply 'GStateUpdate' to 'GState'.+applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState+applyUpdate =+  \case+    GSAddAddress addr st ->+      maybeToRight (GStateAddressExists addr) . addAddress addr st+    GSSetStorageValue addr newValue -> setStorageValue addr newValue+    GSSetBalance addr newBalance -> setBalance addr newBalance++-- | Apply a list of 'GStateUpdate's to 'GState'.+applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState+applyUpdates = flip (foldM (flip applyUpdate))++-- | Add an address if it hasn't been added before.+addAddress :: Address -> AddressState -> GState -> Maybe GState+addAddress addr st gs+    | addr `Map.member` accounts = Nothing+    | otherwise = Just (gs {gsAddresses = accounts & at addr .~ Just st})+  where+    accounts = gsAddresses gs++-- | Updare storage value associated with given address.+setStorageValue ::+     Address -> UntypedValue -> GState -> Either GStateUpdateError GState+setStorageValue addr newValue = updateAddressState addr modifier+  where+    modifier (ASSimple _) = Left (GStateNotContract addr)+    modifier (ASContract cs) = Right $ ASContract $ cs { csStorage = newValue }++-- | Updare storage value associated with given address.+setBalance :: Address -> Mutez -> GState -> Either GStateUpdateError GState+setBalance addr newBalance = updateAddressState addr (Right . modifier)+  where+    modifier (ASSimple _) = ASSimple newBalance+    modifier (ASContract cs) = ASContract (cs {csBalance = newBalance})++updateAddressState ::+     Address+  -> (AddressState -> Either GStateUpdateError AddressState)+  -> GState+  -> Either GStateUpdateError GState+updateAddressState addr f gs =+  case addresses ^. at addr of+    Nothing -> Left (GStateUnknownAddress addr)+    Just as -> do+      newState <- f as+      return $ gs { gsAddresses = addresses & at addr .~ Just newState }+  where+    addresses = gsAddresses gs
+ src/Morley/Runtime/TxData.hs view
@@ -0,0 +1,19 @@+-- | 'TxData' type and associated functionality.++module Morley.Runtime.TxData+       ( TxData (..)+       ) where++import Michelson.Untyped (Op, Value)+import Morley.Types (UExtInstr)+import Tezos.Address (Address)+import Tezos.Core (Mutez)++-- | Data associated with a particular transaction.+data TxData = TxData+  { tdSenderAddress :: !Address+  , tdParameter :: !(Value Op)+  , tdAmount :: !Mutez+  }++deriving instance Show UExtInstr => Show TxData
+ src/Morley/Test.hs view
@@ -0,0 +1,3 @@+-- | Module, containing some utilities for testing Michelson contracts using+-- Haskell testing frameworks (hspec and QuickCheck in particular).+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
+ src/Morley/Test/Dummy.hs view
@@ -0,0 +1,58 @@+-- | Dummy data to be used in tests where it's not essential.++module Morley.Test.Dummy+  ( dummyNow+  , dummyMaxSteps+  , dummyContractEnv+  , dummyOrigination+  ) where++import Michelson.Interpret (ContractEnv(..), RemainingSteps)+import Michelson.Untyped+import Morley.Runtime.GState (genesisAddress, genesisKeyHash)+import Tezos.Core (Timestamp(..), unsafeMkMutez)++-- | Dummy timestamp, can be used to specify current `NOW` value or+-- maybe something else.+dummyNow :: Timestamp+dummyNow = Timestamp 100++-- | Dummy value for maximal number of steps a contract can+-- make. Intentionally quite large, because most likely if you use+-- dummy value you don't want the interpreter to stop due to gas+-- exhaustion. On the other hand, it probably still prevents the+-- interpreter from working for eternity.+dummyMaxSteps :: RemainingSteps+dummyMaxSteps = 100500++-- | Dummy 'ContractEnv' with some reasonable hardcoded values. You+-- can override values you are interested in using record update+-- syntax.+dummyContractEnv :: ContractEnv+dummyContractEnv = ContractEnv+  { ceNow = dummyNow+  , ceMaxSteps = dummyMaxSteps+  , ceBalance = unsafeMkMutez 100+  , ceContracts = mempty+  , ceSelf = genesisAddress+  , ceSource = genesisAddress+  , ceSender = genesisAddress+  , ceAmount = unsafeMkMutez 100+  }++-- | 'OriginationOperation' with most data hardcoded to some+-- reasonable values. Contract and initial values must be passed+-- explicitly, because otherwise it hardly makes sense.+dummyOrigination ::+     Value Op+  -> Contract Op+  -> OriginationOperation+dummyOrigination storage contract = OriginationOperation+  { ooManager = genesisKeyHash+  , ooDelegate = Nothing+  , ooSpendable = False+  , ooDelegatable = False+  , ooBalance = unsafeMkMutez 100+  , ooStorage = storage+  , ooContract = contract+  }
+ src/Morley/Test/Gen.hs view
@@ -0,0 +1,76 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Utilities for arbitrary data generation in property tests.++module Morley.Test.Gen+  ( minTimestamp+  , maxTimestamp+  , midTimestamp+  ) where++import Data.Time.Calendar (Day, addDays, diffDays)+import Data.Time.Clock (UTCTime(..))+import Data.Time.Format (defaultTimeLocale, parseTimeM)+import Test.QuickCheck (Arbitrary(..), choose)++import Michelson.Typed (CT(..), CVal(..), T(..), Val(..))+import Tezos.Core+  (Mutez(..), Timestamp, timestampFromSeconds, timestampFromUTCTime, timestampToSeconds,+  unsafeMkMutez)++instance Arbitrary (CVal 'CKeyHash) where+  arbitrary = CvKeyHash <$> arbitrary+instance Arbitrary (CVal 'CMutez) where+  arbitrary = CvMutez <$> arbitrary+instance Arbitrary (CVal 'CInt) where+  arbitrary = CvInt <$> arbitrary+instance Arbitrary (CVal a) => Arbitrary (Val instr ('Tc a)) where+  arbitrary = VC <$> arbitrary+instance Arbitrary (Val instr a) => Arbitrary (Val instr ('TList a)) where+  arbitrary = VList <$> arbitrary+instance Arbitrary (Val instr 'TUnit) where+  arbitrary = pure VUnit+instance (Arbitrary (Val instr a), Arbitrary (Val instr b))+    => Arbitrary (Val instr ('TPair a b)) where+  arbitrary = VPair ... (,) <$> arbitrary <*> arbitrary++minDay :: Day+minDay = fromMaybe (error "failed to parse day 2008-11-01") $+            parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2008-11-01"++maxDay :: Day+maxDay = fromMaybe (error "failed to parse day 2024-11-01") $+            parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2024-11-01"++minSec :: Integer+minSec = 0++maxSec :: Integer+maxSec = 86399++-- | Minimal (earliest) timestamp used for @Arbitrary (CVal 'CTimestamp)@+minTimestamp :: Timestamp+minTimestamp = timestampFromUTCTime $ UTCTime minDay (fromInteger minSec)++-- | Maximal (latest) timestamp used for @Arbitrary (CVal 'CTimestamp)@+maxTimestamp :: Timestamp+maxTimestamp = timestampFromUTCTime $ UTCTime maxDay (fromInteger maxSec)++-- | Median of 'minTimestamp' and 'maxTimestamp'.+-- Useful for testing (exactly half of generated dates will be before and after+-- this date).+midTimestamp :: Timestamp+midTimestamp = timestampFromUTCTime $+  UTCTime ( ((maxDay `diffDays` minDay) `div` 2) `addDays` minDay)+          (fromInteger $ (maxSec - minSec) `div` 2)++instance Arbitrary (CVal 'CTimestamp) where+  arbitrary = CvTimestamp <$> arbitrary++instance Arbitrary Mutez where+  arbitrary = unsafeMkMutez <$> choose (unMutez minBound, unMutez maxBound)++instance Arbitrary Timestamp where+  arbitrary =+    timestampFromSeconds @Int <$>+    choose (timestampToSeconds minTimestamp, timestampToSeconds maxTimestamp)
+ src/Morley/Test/Import.hs view
@@ -0,0 +1,91 @@+-- | Functions to import contracts to be used in tests.++module Morley.Test.Import+  ( specWithContract+  , specWithTypedContract+  , importContract+  , ImportContractError (..)+  ) where++import Control.Exception (IOException, mapException)+import Data.Typeable ((:~:)(..), TypeRep, eqT, typeRep)+import Fmt (Buildable(build), pretty, (+|), (|+), (||+))+import Test.Hspec (Spec, describe, expectationFailure, it, runIO)++import Michelson.TypeCheck (SomeContract(..), TCError)+import Michelson.Typed (Contract)+import qualified Michelson.Untyped as U+import Morley.Aliases (UntypedContract)+import Morley.Ext (typeCheckMorleyContract)+import Morley.Runtime (prepareContract)+import Morley.Types (ParserException(..))++-- | Import contract and use it in the spec. Both versions of contract are+-- passed to the callback function (untyped and typed).+--+-- If contract's import failed, a spec with single failing expectation+-- will be generated (so tests will run unexceptionally, but a failing+-- result will notify about problem).+specWithContract+  :: (Typeable cp, Typeable st)+  => FilePath -> ((UntypedContract, Contract cp st) -> Spec) -> Spec+specWithContract file execSpec =+  either errorSpec (describe ("Test contract " <> file) . execSpec)+    =<< runIO+          ( (Right <$> importContract file)+            `catch` (\(e :: ImportContractError) -> pure $ Left $ displayException e)+            `catch` \(e :: IOException) -> pure $ Left $ displayException e )+  where+    errorSpec = it ("Type check contract " <> file) . expectationFailure++-- | A version of 'specWithContract' which passes only the typed+-- representation of the contract.+specWithTypedContract+  :: (Typeable cp, Typeable st)+  => FilePath -> (Contract cp st -> Spec) -> Spec+specWithTypedContract file execSpec = specWithContract file (execSpec . snd)++-- | Import contract from a given file path.+--+-- This function reads file, parses and type checks contract.+--+-- This function may throw 'IOException' and 'ImportContractError'.+importContract+  :: forall cp st .+    (Typeable cp, Typeable st)+  => FilePath -> IO (UntypedContract, Contract cp st)+importContract file = do+  contract <- mapException ICEParse $ prepareContract (Just file)+  SomeContract (instr :: Contract cp' st') _ _+    <- assertEither ICETypeCheck $ pure $ typeCheckMorleyContract $+        U.unOp <$> contract+  case (eqT @cp @cp', eqT @st @st') of+    (Just Refl, Just Refl) -> pure (contract, instr)+    (Nothing, _) -> throwM $+      ICEUnexpectedParamType (U.para contract) (typeRep (Proxy @cp))+    _ -> throwM (ICEUnexpectedStorageType (U.stor contract) (typeRep (Proxy @st)))+  where+    assertEither err action = either (throwM . err) pure =<< action++-- | Error type for 'importContract' function.+data ImportContractError+  = ICEUnexpectedParamType !U.Type !TypeRep+  | ICEUnexpectedStorageType !U.Type !TypeRep+  | ICEParse !ParserException+  | ICETypeCheck !TCError+  deriving Show++instance Buildable ImportContractError where+  build =+    \case+      ICEUnexpectedParamType actual expected ->+        "Unexpected parameter type: " +| actual |++        ", expected: " +| expected ||+ ""+      ICEUnexpectedStorageType actual expected ->+        "Unexpected storage type: " +| actual |++        ", expected: " +| expected ||+ ""+      ICEParse e -> "Failed to parse the contract: " +| e |+ ""+      ICETypeCheck e -> "The contract is ill-typed: " +| e |+ ""++instance Exception ImportContractError where+  displayException = pretty
+ src/Morley/Test/Integrational.hs view
@@ -0,0 +1,172 @@+-- | Utilities for integrational testing.++module Morley.Test.Integrational+  ( IntegrationalValidator+  , SuccessValidator+  , integrationalTestExpectation+  , integrationalTestProperty+  , simplerIntegrationalTestExpectation+  , simplerIntegrationalTestProperty++  -- * Validators+  , composeValidators+  , expectStorageValue+  , expectStorageConstant+  , expectBalance+  , expectGasExhaustion+  ) where++import Control.Lens (at)+import qualified Data.List as List+import Fmt (blockListF, pretty, (+|), (|+))+import Test.Hspec (Expectation, expectationFailure)+import Test.QuickCheck (Property)++import Michelson.Interpret (InterpretUntypedError(..), MichelsonFailed(..), RemainingSteps)+import Morley.Aliases (UntypedValue)+import Morley.Runtime (InterpreterError(..), InterpreterOp(..), InterpreterRes(..), interpreterPure)+import Morley.Runtime.GState+import Morley.Test.Dummy+import Morley.Test.Util (failedProp, succeededProp)+import Tezos.Address (Address)+import Tezos.Core (Mutez, Timestamp)++-- | Validator for integrational testing.+-- If an error is expected, it should be 'Left' with validator for errors.+-- Otherwise it should check final global state and its updates.+type IntegrationalValidator = Either (InterpreterError -> Bool) SuccessValidator++type SuccessValidator = (GState -> [GStateUpdate] -> Either Text ())++-- | Integrational test that executes given operations and validates+-- them using given validator. It can fail using 'Expectation'+-- capability.+integrationalTestExpectation ::+  Timestamp -> RemainingSteps -> [InterpreterOp] -> IntegrationalValidator -> Expectation+integrationalTestExpectation =+  integrationalTest (maybe pass (expectationFailure . toString))++-- | Integrational test that executes given operations and validates+-- them using given validator. It can fail using 'Property'+-- capability. It can be used with QuickCheck's @forAll@ to make a+-- property-based test with arbitrary data.+integrationalTestProperty ::+  Timestamp -> RemainingSteps -> [InterpreterOp] -> IntegrationalValidator -> Property+integrationalTestProperty = integrationalTest (maybe succeededProp failedProp)++-- | 'integrationalTestExpectation' which uses dummy now and max steps.+simplerIntegrationalTestExpectation :: [InterpreterOp] -> IntegrationalValidator -> Expectation+simplerIntegrationalTestExpectation =+  integrationalTestExpectation dummyNow dummyMaxSteps++-- | 'integrationalTestProperty' which uses dummy now and max steps.+simplerIntegrationalTestProperty :: [InterpreterOp] -> IntegrationalValidator -> Property+simplerIntegrationalTestProperty =+  integrationalTestProperty dummyNow dummyMaxSteps++integrationalTest ::+     (Maybe Text -> res)+  -> Timestamp+  -> RemainingSteps+  -> [InterpreterOp]+  -> IntegrationalValidator+  -> res+integrationalTest howToFail now maxSteps operations validator =+  validateResult+    howToFail+    validator+    (interpreterPure now maxSteps initGState operations)++validateResult ::+     (Maybe Text -> res)+  -> IntegrationalValidator+  -> Either InterpreterError InterpreterRes+  -> res+validateResult howToFail validator result =+  case (validator, result) of+    (Left validateError, Left err)+      | validateError err -> doNotFail+    (_, Left err) ->+      doFail $ "Unexpected interpreter error: " <> pretty err+    (Left _, Right _) ->+      doFail $ "Interpreter unexpectedly didn't fail"+    (Right validateUpdates, Right ir)+      | Left bad <- validateUpdates (_irGState ir) (_irUpdates ir) ->+        doFail $+        "Updates are incorrect: " +| bad |+ ". Updates are: \n" +|+        blockListF (_irUpdates ir) |+ ""+      | otherwise -> doNotFail+  where+    doNotFail = howToFail Nothing+    doFail = howToFail . Just++----------------------------------------------------------------------------+-- Validators to be used within 'IntegrationalValidator'+----------------------------------------------------------------------------++-- | Check that storage value is updated for given address. Takes a+-- predicate that is used to check the value.+--+-- It works even if updates are not filtered (i. e. a value can be+-- updated more than once).+expectStorageValue ::+     Address+  -> (UntypedValue -> Either Text ())+  -> SuccessValidator+expectStorageValue addr predicate _ updates =+  case List.find checkAddr (reverse updates) of+    Nothing -> Left $ "Storage of " +| addr |+ " is not updated"+    Just (GSSetStorageValue _ val) ->+      first (("Storage of " +| addr |+ "is updated incorrectly: ") <>) $+      predicate val+    -- 'checkAddr' ensures that only 'GSSetStorageValue' can be found+    Just _ -> error "expectStorageValue: internal error"+  where+    checkAddr (GSSetStorageValue addr' _) = addr' == addr+    checkAddr _ = False++-- | Like 'expectStorageValue', but expects a constant.+expectStorageConstant ::+     Address+  -> UntypedValue+  -> SuccessValidator+expectStorageConstant addr expected =+  expectStorageValue addr predicate+  where+    predicate val+      | val == expected = pass+      | otherwise = Left $ "expected " +| expected |+ ""++-- | Check that eventually address has some particular balance.+expectBalance :: Address -> Mutez -> SuccessValidator+expectBalance addr balance gs _ =+  case gsAddresses gs ^. at addr of+    Nothing ->+      Left $+      "Expected " +| addr |+ " to have balance " +| balance |++      ", but it's unknown"+    Just (asBalance -> realBalance)+      | realBalance == balance -> pass+      | otherwise ->+        Left $+        "Expected " +| addr |+ " to have balance " +| balance |++        ", but its balance is " +| realBalance |+ ""++-- | Compose two success validators.+--+-- For example:+--+-- expectBalance bal addr `composeValidators`+-- expectStorageConstant addr2 ValueUnit+composeValidators ::+     SuccessValidator+  -> SuccessValidator+  -> SuccessValidator+composeValidators val1 val2 gState updates =+  val1 gState updates >> val2 gState updates++expectGasExhaustion :: InterpreterError -> Bool+expectGasExhaustion =+  \case+    IEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> True+    _ -> False
+ src/Morley/Test/Unit.hs view
@@ -0,0 +1,53 @@+-- | Utility functions for unit testing.++module Morley.Test.Unit+  ( ContractReturn+  , ContractPropValidator+  , contractProp+  , contractPropVal+  ) where++import Michelson.Interpret (ContractEnv, ContractReturn)+import Michelson.Typed (Contract, Instr, ToT, ToVal(..), Val(..))+import Morley.Ext (interpretMorley)+import Morley.Types (MorleyLogs)++-- | Type for contract execution validation.+--+-- It's a function which is supplied with contract execution output+-- (failure or new storage with operation list).+--+-- Function returns a property which type is designated by type variable @prop@+-- and might be 'Test.QuickCheck.Property' or 'Test.Hspec.Expectation'+-- or anything else relevant.+type ContractPropValidator st prop = ContractReturn MorleyLogs st -> prop++-- | Contract's property tester against given input.+-- Takes contract environment, initial storage and parameter,+-- interprets contract on this input and invokes validation function.+contractProp+  :: ( ToVal param, ToVal storage+     , ToT param ~ cp, ToT storage ~ st+     , Typeable cp, Typeable st+     )+  => Contract cp st+  -> ContractPropValidator st prop+  -> ContractEnv+  -> param+  -> storage+  -> prop+contractProp instr check env param initSt =+  contractPropVal instr check env (toVal param) (toVal initSt)++-- | Version of 'contractProp' which takes 'Val' as arguments instead+-- of regular Haskell values.+contractPropVal+  :: (Typeable cp, Typeable st)+  => Contract cp st+  -> ContractPropValidator st prop+  -> ContractEnv+  -> Val Instr cp+  -> Val Instr st+  -> prop+contractPropVal instr check env param initSt =+  check $ interpretMorley instr param initSt env
+ src/Morley/Test/Util.hs view
@@ -0,0 +1,33 @@+-- | Testing utility functions used by testing framework itself or+-- intended to be used by test writers.++module Morley.Test.Util+  ( failedProp+  , succeededProp+  , qcIsLeft+  , qcIsRight+  ) where++import Test.QuickCheck.Property (Property, Result(..), failed, property)++----------------------------------------------------------------------------+-- Property+----------------------------------------------------------------------------++-- | A 'Property' that always failes with given message.+failedProp :: Text -> Property+failedProp r = property $ failed { reason = toString r }++-- | A 'Property' that always succeeds.+succeededProp :: Property+succeededProp = property True++-- | The 'Property' holds on `Left a`.+qcIsLeft :: Show b => Either a b -> Property+qcIsLeft (Left _)  = property True+qcIsLeft (Right x) = failedProp $ "expected Left, got Right (" <> show x <> ")"++-- | The 'Property' holds on `Right b`.+qcIsRight :: Show a => Either a b -> Property+qcIsRight (Right _) = property True+qcIsRight (Left x)  = failedProp $ "expected Right, got Left (" <> show x <> ")"
+ src/Morley/Types.hs view
@@ -0,0 +1,428 @@+{-# OPTIONS_GHC -Wno-orphans #-}+-- pva701: ^ this is needed for Buildable Instr.+-- I couldn't define it in Utyped.Instr+-- because GHC doesn't know what particular type would be ExtU+-- and generates an error about overlapping instances,+-- when I try to use genericF.+-- Also it's not possible to implement it using deriving instances+-- because InstrAbstract isn't newtype.+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++module Morley.Types+  (+   -- * Rexported from Michelson.Types+    Parameter+  , Storage+  , Contract (..)+  , Value (..)+  , Elt (..)+  , InstrAbstract (..)+  , Instr+  , Op (..)+  , TypeAnn+  , FieldAnn+  , VarAnn+  , ann+  , noAnn+  , Type (..)+  , Comparable (..)+  , T (..)+  , CT (..)+  , Annotation (..)+  , InternalByteString(..)+  , unInternalByteString++  -- Parser types+  , CustomParserException (..)+  , Parser+  , Parsec+  , ParseErrorBundle+  , ParserException (..)+  , LetEnv (..)+  , noLetEnv++  , UExtInstrAbstract(..)++  -- * Morley Parsed instruction types+  , ParsedInstr+  , ParsedOp (..)+  , ParsedUTestAssert+  , ParsedUExtInstr++  -- * Morley Expanded instruction types+  , ExpandedInstr+  , ExpandedOp (..)+  , UExtInstr++  -- * Michelson Instructions and Instruction Macros+  , PairStruct (..)+  , CadrStruct (..)+  , Macro (..)++  -- * Morley Instructions+  , ExtInstr(..)+  , TestAssert (..)+  , UTestAssert (..)+  , PrintComment (..)+  , StackTypePattern (..)+  , StackRef(..)++  , MorleyLogs (..)+  , noMorleyLogs+  --  * Let-block+  , StackFn(..)+  , Var (..)+  , TyVar (..)+  , varSet+  , LetMacro (..)+  , LetValue (..)+  , LetType (..)+  ) where+++import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Data (Data(..))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import Fmt (Buildable(build), Builder, genericF, listF)+import Text.Megaparsec (ParseErrorBundle, Parsec, ShowErrorComponent(..), errorBundlePretty)+import qualified Text.Show (show)++import Michelson.EqParam (eqParam2)+import Michelson.Typed (instrToOps)+import qualified Michelson.Typed as T+import Michelson.Untyped+  (Annotation(..), CT(..), Comparable(..), Contract(..), Elt(..), ExtU, FieldAnn, Instr,+  InstrAbstract(..), InternalByteString(..), Op(..), Parameter, Storage, T(..), Type(..), TypeAnn,+  Value(..), VarAnn, ann, noAnn, unInternalByteString)+import Morley.Default (Default(..))++-------------------------------------+-- Types for the parser+-------------------------------------++data CustomParserException+  = UnknownTypeException+  | OddNumberBytesException+  | UnexpectedLineBreak+  deriving (Eq, Data, Ord, Show)++instance ShowErrorComponent CustomParserException where+  showErrorComponent UnknownTypeException = "unknown type"+  showErrorComponent OddNumberBytesException = "odd number bytes"+  showErrorComponent UnexpectedLineBreak = "unexpected linebreak"++type Parser = ReaderT LetEnv (Parsec CustomParserException T.Text)++instance Default a => Default (Parser a) where+  def = pure def++data ParserException =+  ParserException (ParseErrorBundle T.Text CustomParserException)++instance Show ParserException where+  show (ParserException bundle) = errorBundlePretty bundle++instance Exception ParserException where+  displayException (ParserException bundle) = errorBundlePretty bundle++instance Buildable ParserException where+  build = build @String . show++-- | The environment containing lets from the let-block+data LetEnv = LetEnv+  { letMacros :: Map Text LetMacro+  , letValues :: Map Text LetValue+  , letTypes  :: Map Text LetType+  } deriving (Show, Eq)++noLetEnv :: LetEnv+noLetEnv = LetEnv Map.empty Map.empty Map.empty++-------------------------------------+-- Types produced by parser+-------------------------------------++-- TODO Move this to Morley.Untyped+-- | Implementation-specific instructions embedded in a @NOP@ primitive, which+-- mark a specific point during a contract's typechecking or execution.+--+-- These instructions are not allowed to modify the contract's stack, but may+-- impose additional constraints that can cause a contract to report errors in+-- type-checking or testing.+--+-- Additionaly, some implementation-specific language features such as+-- type-checking of @LetMacro@s are implemented using this mechanism+-- (specifically @FN@ and @FN_END@).+data UExtInstrAbstract op =+    STACKTYPE StackTypePattern -- ^ Matches current stack against a type-pattern+  | FN T.Text StackFn          -- ^ Begin a typed stack function (push a @TcExtFrame@)+  | FN_END                     -- ^ End a stack function (pop a @TcExtFrame@)+  | UTEST_ASSERT (UTestAssert op)   -- ^ Copy the current stack and run an inline assertion on it+  | UPRINT PrintComment         -- ^ Print a comment with optional embedded @StackRef@s+  deriving (Eq, Show, Data, Generic, Functor)++instance Buildable op => Buildable (UExtInstrAbstract op) where+  build = genericF++-- TODO replace ParsedOp in UExtInstr with op+-- to reflect Parsed, Epxanded and Flattened phase++type instance ExtU InstrAbstract = UExtInstrAbstract+type instance T.ExtT T.Instr = ExtInstr++---------------------------------------------------++type ParsedUTestAssert = UTestAssert ParsedOp++type ParsedUExtInstr = UExtInstrAbstract ParsedOp++type ParsedInstr = InstrAbstract ParsedOp++-- | Unexpanded instructions produced directly by the @ops@ parser, which+-- contains primitive Michelson Instructions, inline-able macros and sequences+data ParsedOp+  = PRIM ParsedInstr -- ^ Primitive Michelson instruction+  | MAC Macro        -- ^ Built-in Michelson macro defined by the specification+  | LMAC LetMacro    -- ^ User-defined macro with instructions to be inlined+  | SEQ [ParsedOp]   -- ^ A sequence of instructions+  deriving (Eq, Show, Data, Generic)++instance Buildable ParsedInstr where+  build = genericF++instance Buildable ParsedOp where+  build = genericF++-------------------------------------+-- Types after macroexpander+-------------------------------------++type ExpandedInstr = InstrAbstract ExpandedOp++data ExpandedOp+  = PRIM_EX ExpandedInstr+  | SEQ_EX [ExpandedOp]+  deriving stock (Eq, Show, Data, Generic)++instance Buildable ExpandedInstr where+  build = genericF++instance Buildable ExpandedOp where+  build = genericF++type UExtInstr = UExtInstrAbstract Op++instance Buildable Instr where+  build = genericF++---------------------------------------------------++data TestAssert where+  TestAssert+    :: (Typeable inp, Typeable out)+    => T.Text+    -> PrintComment+    -> T.Instr inp ('T.Tc 'CBool ': out)+    -> TestAssert++deriving instance Show TestAssert++instance Eq TestAssert where+  TestAssert   name1 pattern1 instr1+    ==+    TestAssert name2 pattern2 instr2+    = and+    [ name1 == name2+    , pattern1 == pattern2+    , instr1 `eqParam2` instr2+    ]++data ExtInstr+  = TEST_ASSERT TestAssert+  | PRINT PrintComment+  deriving (Show, Eq)++instance T.Conversible ExtInstr (UExtInstrAbstract Op) where+  convert (PRINT pc) = UPRINT pc+  convert (TEST_ASSERT (TestAssert nm pc i)) =+    UTEST_ASSERT $ UTestAssert nm pc (instrToOps i)++---------------------------------------------------++-- | Morley interpreter state+newtype MorleyLogs = MorleyLogs+  { unMorleyLogs :: [T.Text]+  } deriving stock (Eq, Show)+    deriving newtype (Default, Buildable)++noMorleyLogs :: MorleyLogs+noMorleyLogs = MorleyLogs []++---------------------------------------------------++data PairStruct+  = F (VarAnn, FieldAnn)+  | P PairStruct PairStruct+  deriving (Eq, Show, Data, Generic)++instance Buildable PairStruct where+  build = genericF++data CadrStruct+  = A+  | D+  deriving (Eq, Show, Data, Generic)++instance Buildable CadrStruct where+  build = genericF++-- | Built-in Michelson Macros defined by the specification+data Macro+  = CMP ParsedInstr VarAnn+  | IFX ParsedInstr [ParsedOp] [ParsedOp]+  | IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp]+  | FAIL+  | PAPAIR PairStruct TypeAnn VarAnn+  | UNPAIR PairStruct+  | CADR [CadrStruct] VarAnn FieldAnn+  | SET_CADR [CadrStruct] VarAnn FieldAnn+  | MAP_CADR [CadrStruct] VarAnn FieldAnn [ParsedOp]+  | DIIP Integer [ParsedOp]+  | DUUP Integer VarAnn+  | ASSERT+  | ASSERTX ParsedInstr+  | ASSERT_CMP ParsedInstr+  | ASSERT_NONE+  | ASSERT_SOME+  | ASSERT_LEFT+  | ASSERT_RIGHT+  | IF_SOME [ParsedOp] [ParsedOp]+  deriving (Eq, Show, Data, Generic)++instance Buildable Macro where+  build = genericF++---------------------------------------------------++-- | A reference into the stack+newtype StackRef = StackRef Integer+  deriving (Eq, Show, Data, Generic)++instance Buildable StackRef where+  build (StackRef i) = "%[" <> build i <> "]"++newtype Var = Var T.Text deriving (Eq, Show, Ord, Data, Generic)++instance Buildable Var where+  build = genericF++-- | A type-variable or a type-constant+data TyVar =+    VarID Var+  | TyCon Type+  deriving (Eq, Show, Data, Generic)++instance Buildable TyVar where+  build = genericF++-- | A stack pattern-match+data StackTypePattern+ = StkEmpty+ | StkRest+ | StkCons TyVar StackTypePattern+  deriving (Eq, Show, Data, Generic)++-- | Convert 'StackTypePattern' to a list of types. Also returns+-- 'Bool' which is 'True' if the pattern is a fixed list of types and+-- 'False' if it's a pattern match on the head of the stack.+stackTypePatternToList :: StackTypePattern -> ([TyVar], Bool)+stackTypePatternToList StkEmpty = ([], True)+stackTypePatternToList StkRest = ([], False)+stackTypePatternToList (StkCons t pat) =+  first (t :) $ stackTypePatternToList pat++instance Buildable StackTypePattern where+  build = listF . pairToList . stackTypePatternToList+    where+      pairToList :: ([TyVar], Bool) -> [Builder]+      pairToList (types, fixed)+        | fixed = map build types+        | otherwise = map build types ++ ["..."]++-- | A stack function that expresses the type signature of a @LetMacro@+data StackFn = StackFn+  { quantifiedVars :: Maybe (Set Var)+  , inPattern :: StackTypePattern+  , outPattern :: StackTypePattern+  } deriving (Eq, Show, Data, Generic)++instance Buildable StackFn where+  build = genericF++-- | Get the set of variables in a stack pattern+varSet :: StackTypePattern -> Set Var+varSet StkEmpty = Set.empty+varSet StkRest = Set.empty+varSet (StkCons (VarID v) stk) = v `Set.insert` (varSet stk)+varSet (StkCons _ stk) = varSet stk++-- | A programmer-defined macro+data LetMacro = LetMacro+  { lmName :: T.Text+  , lmSig :: StackFn+  , lmExpr :: [ParsedOp]+  } deriving (Eq, Show, Data, Generic)++instance Buildable LetMacro where+  build = genericF++-- | A programmer-defined constant+data LetValue = LetValue+  { lvName :: T.Text+  , lvSig :: Type+  , lvVal :: (Value ParsedOp)+  } deriving (Eq, Show)++-- | A programmer-defined type-synonym+data LetType = LetType+  { ltName :: T.Text+  , ltSig :: Type+  } deriving (Eq, Show)++-- A print format with references into the stack+newtype PrintComment = PrintComment+  { unPrintComment :: [Either T.Text StackRef]+  } deriving (Eq, Show, Data, Generic)++instance Buildable PrintComment where+  build = foldMap (either build build) . unPrintComment++-- An inline test assertion+data UTestAssert op = UTestAssert+  { tassName :: T.Text+  , tassComment :: PrintComment+  , tassInstrs :: [op]+  } deriving (Eq, Show, Functor, Data, Generic)++instance Buildable code => Buildable (UTestAssert code) where+  build = genericF++deriveJSON defaultOptions ''ParsedOp+deriveJSON defaultOptions ''UExtInstrAbstract+deriveJSON defaultOptions ''PrintComment+deriveJSON defaultOptions ''StackTypePattern+deriveJSON defaultOptions ''StackRef+deriveJSON defaultOptions ''StackFn+deriveJSON defaultOptions ''Var+deriveJSON defaultOptions ''TyVar+deriveJSON defaultOptions ''LetMacro+deriveJSON defaultOptions ''LetValue+deriveJSON defaultOptions ''LetType+deriveJSON defaultOptions ''UTestAssert+deriveJSON defaultOptions ''PairStruct+deriveJSON defaultOptions ''CadrStruct+deriveJSON defaultOptions ''Macro
+ src/Tezos/Address.hs view
@@ -0,0 +1,157 @@+-- | Address in Tezos.++module Tezos.Address+  ( Address (..)+  , mkKeyAddress+  , mkContractAddressRaw++  -- * Formatting+  , formatAddress+  , parseAddress+  ) where++import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encoding as Aeson+import qualified Data.Aeson.Types as AesonTypes+import qualified Data.ByteString as BS+import Fmt (fmt, hexF, pretty)+import qualified Formatting.Buildable as Buildable+import Test.QuickCheck (Arbitrary(..), oneof, vector)++import Tezos.Crypto++-- | Data type corresponding to address structure in Tezos.+data Address+  = KeyAddress !KeyHash+  -- ^ `tz` address which is a hash of a public key.+  | ContractAddress !ByteString+  -- ^ `KT` address which corresponds to a callable contract.+  -- It's a hash of origination command.+  -- TODO: we should probably have a `Hash` type.+  deriving (Show, Eq, Ord)++-- | Smart constructor for 'KeyAddress'.+mkKeyAddress :: PublicKey -> Address+mkKeyAddress = KeyAddress . hashKey++-- | Smart constructor for 'ContractAddress'. Its argument is+-- serialized origination operation.+--+-- Note: it's quite unsafe to pass 'ByteString', because we can pass+-- some garbage which is not a serialized origination operation, but+-- this operation includes contract itself and necessary types are+-- defined in 'Michelson.*'. So we have to serialize this data outside+-- this module and pass it here as a 'ByteString'. Alternatively we+-- could add some constraint, but it would be almost as unsafe as+-- passing a 'ByteString'. For this reason we add `Raw` suffix to this+-- function and provide a safer function in 'Michelson.Untyped.Instr'.+-- We may reconsider it later.+mkContractAddressRaw :: ByteString -> Address+mkContractAddressRaw = ContractAddress . blake2b160 . blake2b160++----------------------------------------------------------------------------+-- Formatting/parsing+----------------------------------------------------------------------------++formatAddress :: Address -> Text+formatAddress =+  \case+    KeyAddress h -> formatKeyHash h+    ContractAddress bs -> encodeBase58Check (contractAddressPrefix <> bs)++instance Buildable.Buildable Address where+  build = Buildable.build . formatAddress++-- | Errors that can happen during address parsing.+data ParseAddressError+  = ParseAddressWrongBase58Check+  -- ^ Address is not in Base58Check format.+  | ParseAddressBothFailed !CryptoParseError !ParseContractAddressError+  -- ^ Both address parsers failed with some error.+  deriving (Show, Eq)++instance Buildable.Buildable ParseAddressError where+  build =+    \case+      ParseAddressWrongBase58Check -> "Wrong base58check format"+      ParseAddressBothFailed pkErr contractErr ->+        mconcat+        [ "Address is neither `KeyAddress` ("+        , Buildable.build pkErr+        , "), nor `ContractAddress` ("+        , Buildable.build contractErr+        , ")"+        ]++parseAddress :: Text -> Either ParseAddressError Address+parseAddress addressText =+  case parseKeyHash addressText of+    Left CryptoParseWrongBase58Check -> Left ParseAddressWrongBase58Check+    Left keyAddrErr -> first (ParseAddressBothFailed keyAddrErr) $+      parseContractAddress addressText+    Right keyHash -> Right (KeyAddress keyHash)++data ParseContractAddressError+  = ParseContractAddressWrongBase58Check+  | ParseContractAddressWrongTag !ByteString+  | ParseContractAddressWrongSize !Int+  deriving (Show, Eq)++instance Buildable.Buildable ParseContractAddressError where+  build =+    \case+      ParseContractAddressWrongBase58Check ->+        "Wrong base58check format"+      ParseContractAddressWrongTag tag ->+        "Wrong tag for a contract address: " <> fmt (hexF tag)+      ParseContractAddressWrongSize s ->+        "Wrong size for a contract address: " <> Buildable.build s++parseContractAddress :: Text -> Either ParseContractAddressError Address+parseContractAddress text =+  case decodeBase58CheckWithPrefix contractAddressPrefix text of+    Left (B58CheckWithPrefixWrongPrefix prefix) ->+      Left (ParseContractAddressWrongTag prefix)+    Left B58CheckWithPrefixWrongEncoding ->+      Left ParseContractAddressWrongBase58Check+    -- We know that the length must be 20.+    -- Currently it's hardcoded here, later we'll probably have a `Hash` type.+    Right bs | length bs == 20 -> Right (ContractAddress bs)+             | otherwise -> Left $ ParseContractAddressWrongSize (length bs)++-- It's a magic constant used by Tezos to encode a contract address.+-- It was deduced empirically.+contractAddressPrefix :: ByteString+contractAddressPrefix = "\2\90\121"++----------------------------------------------------------------------------+-- Aeson instances+----------------------------------------------------------------------------++instance ToJSON Address where+  toJSON = Aeson.String . formatAddress+  toEncoding = Aeson.text . formatAddress++instance ToJSONKey Address where+  toJSONKey = AesonTypes.toJSONKeyText formatAddress++instance FromJSON Address where+  parseJSON =+    Aeson.withText "Address" $+    either (fail . pretty) pure . parseAddress++instance FromJSONKey Address where+  fromJSONKey =+    AesonTypes.FromJSONKeyTextParser+      (either (fail . pretty) pure . parseAddress)++----------------------------------------------------------------------------+-- Arbitrary+----------------------------------------------------------------------------++instance Arbitrary Address where+  arbitrary = oneof [genKeyAddress, genContractAddress]+    where+      genKeyAddress = KeyAddress <$> arbitrary+      genContractAddress = ContractAddress . BS.pack <$> vector 20
+ src/Tezos/Core.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}++-- | Core primitive Tezos types.++module Tezos.Core+  (+    -- * Mutez+    Mutez (unMutez)+  , mkMutez+  , unsafeMkMutez+  , addMutez+  , unsafeAddMutez+  , subMutez+  , unsafeSubMutez+  , mulMutez+  , divModMutez+  , divModMutezInt++    -- * Timestamp+  , Timestamp (..)+  , timestampToSeconds+  , timestampFromSeconds+  , timestampFromUTCTime+  , timestampPlusSeconds+  , formatTimestamp+  , parseTimestamp+  , getCurrentTime+  ) where++import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Data (Data(..))+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Data.Time.LocalTime (utc, utcToZonedTime, zonedTimeToUTC)+import Data.Time.RFC3339 (formatTimeRFC3339, parseTimeRFC3339)+import Formatting.Buildable (Buildable(build))++----------------------------------------------------------------------------+-- Mutez+----------------------------------------------------------------------------++-- | Mutez is a wrapper over integer data type. 1 mutez is 1 token (μTz).+newtype Mutez = Mutez+  { unMutez :: Word64+  } deriving stock (Show, Eq, Ord, Data, Generic)+    deriving newtype (Enum, Buildable)++instance Bounded Mutez where+  minBound = Mutez 0+  -- 2⁶³ - 1+  -- This value was checked against the reference implementation.+  maxBound = Mutez 9223372036854775807++-- | Safely create 'Mutez' checking for overflow.+mkMutez :: Word64 -> Maybe Mutez+mkMutez n+  | n <= unMutez maxBound = Just (Mutez n)+  | otherwise = Nothing+{-# INLINE mkMutez #-}++-- | Partial function for 'Mutez' creation, it's pre-condition is that+-- the argument must not exceed the maximal 'Mutez' value.+unsafeMkMutez :: HasCallStack => Word64 -> Mutez+unsafeMkMutez n =+  fromMaybe (error $ "mkMutez: overflow (" <> show n <> ")") (mkMutez n)+{-# INLINE unsafeMkMutez #-}++-- | Addition of 'Mutez' values. Returns 'Nothing' in case of overflow.+addMutez :: Mutez -> Mutez -> Maybe Mutez+addMutez (unMutez -> a) (unMutez -> b) =+  mkMutez (a + b) -- (a + b) can't overflow if 'Mutez' values are valid+{-# INLINE addMutez #-}++-- | Partial addition of 'Mutez', should be used only if you're+-- sure there'll be no overflow.+unsafeAddMutez :: HasCallStack => Mutez -> Mutez -> Mutez+unsafeAddMutez = fromMaybe (error "unsafeAddMutez: overflow") ... addMutez++-- | Subtraction of 'Mutez' values. Returns 'Nothing' when the+-- subtrahend is greater than the minuend, and 'Just' otherwise.+subMutez :: Mutez -> Mutez -> Maybe Mutez+subMutez (unMutez -> a) (unMutez -> b)+  | a >= b = Just (Mutez (a - b))+  | otherwise = Nothing+{-# INLINE subMutez #-}++-- | Partial subtraction of 'Mutez', should be used only if you're+-- sure there'll be no underflow.+unsafeSubMutez :: HasCallStack => Mutez -> Mutez -> Mutez+unsafeSubMutez = fromMaybe (error "unsafeSubMutez: underflow") ... subMutez++-- | Multiplication of 'Mutez' and an integral number. Returns+-- 'Nothing' in case of overflow.+mulMutez :: Integral a => Mutez -> a -> Maybe Mutez+mulMutez (unMutez -> a) b+    | res <= toInteger (unMutez maxBound) = Just (Mutez (fromInteger res))+    | otherwise = Nothing+  where+    res = toInteger a * toInteger b+{-# INLINE mulMutez #-}++-- | Euclidian division of two 'Mutez' values.+divModMutez :: Mutez -> Mutez -> Maybe (Word64, Mutez)+divModMutez a (unMutez -> b) = first unMutez <$> divModMutezInt a b++-- | Euclidian division of  'Mutez' and a number.+divModMutezInt :: Integral a => Mutez -> a -> Maybe (Mutez, Mutez)+divModMutezInt (toInteger . unMutez -> a) (toInteger -> b)+  | b <= 0 = Nothing+  | otherwise = Just $ bimap toMutez toMutez (a `divMod` b)+  where+    toMutez :: Integer -> Mutez+    toMutez = Mutez . fromInteger++----------------------------------------------------------------------------+-- Timestamp+----------------------------------------------------------------------------++-- | Time in the real world.+-- Use the functions below to convert it to/from Unix time in seconds.+newtype Timestamp = Timestamp+  { unTimestamp :: POSIXTime+  } deriving stock (Show, Eq, Ord, Data, Generic)++timestampToSeconds :: Integral a => Timestamp -> a+timestampToSeconds = round . unTimestamp+{-# INLINE timestampToSeconds #-}++timestampFromSeconds :: Integral a => a -> Timestamp+timestampFromSeconds = Timestamp . fromIntegral+{-# INLINE timestampFromSeconds #-}++timestampFromUTCTime :: UTCTime -> Timestamp+timestampFromUTCTime = Timestamp . utcTimeToPOSIXSeconds+{-# INLINE timestampFromUTCTime #-}++-- | Add given amount of seconds to a 'Timestamp'.+timestampPlusSeconds :: Timestamp -> Integer -> Timestamp+timestampPlusSeconds ts sec = timestampFromSeconds (timestampToSeconds ts + sec)++-- | Display timestamp in human-readable way as used by Michelson.+-- Uses UTC timezone, though maybe we should take it as an argument.+formatTimestamp :: Timestamp -> Text+formatTimestamp =+  formatTimeRFC3339 . utcToZonedTime utc . posixSecondsToUTCTime . unTimestamp++instance Buildable Timestamp where+  build = build . formatTimestamp++-- | Parse textual representation of 'Timestamp'.+parseTimestamp :: Text -> Maybe Timestamp+parseTimestamp = fmap (timestampFromUTCTime . zonedTimeToUTC) . parseTimeRFC3339++-- | Return current time as 'Timestamp'.+getCurrentTime :: IO Timestamp+getCurrentTime = Timestamp <$> getPOSIXTime++----------------------------------------------------------------------------+-- JSON+----------------------------------------------------------------------------++deriveJSON defaultOptions ''Mutez+deriveJSON defaultOptions ''Timestamp
+ src/Tezos/Crypto.hs view
@@ -0,0 +1,316 @@+-- | Cryptographic primitives used in Tezos.++module Tezos.Crypto+  ( -- * Cryptographic primitive types+    PublicKey+  , SecretKey+  , Signature+  , KeyHash (..)+  , toPublic++  -- * Formatting+  , CryptoParseError (..)+  , formatPublicKey+  , parsePublicKey+  , formatSecretKey+  , parseSecretKey+  , formatSignature+  , parseSignature+  , formatKeyHash+  , parseKeyHash++  -- * Signing+  , sign+  , checkSignature++  -- * Hashing+  , hashKey+  , blake2b+  , blake2b160+  , sha256+  , sha512++  -- * Utilities+  , encodeBase58Check+  , decodeBase58Check+  , B58CheckWithPrefixError (..)+  , decodeBase58CheckWithPrefix+  ) where++import Crypto.Error (CryptoError, CryptoFailable, eitherCryptoError)+import Crypto.Hash (Blake2b_160, Blake2b_256, Digest, SHA256, SHA512, hash)+import Crypto.Number.Serialize (os2ip)+import qualified Crypto.PubKey.Ed25519 as Ed25519+import Crypto.Random (drgNewSeed, seedFromInteger, withDRG)+import Data.Aeson (FromJSON(..), ToJSON(..))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encoding as Aeson+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base58 as Base58+import Data.Coerce (coerce)+import Fmt (fmt, hexF, pretty)+import qualified Formatting.Buildable as Buildable+import Test.QuickCheck (Arbitrary(..), vector)++----------------------------------------------------------------------------+-- Types, instances, conversions+----------------------------------------------------------------------------++-- | ED25519 public cryptographic key.+newtype PublicKey = PublicKey+  { unPublicKey :: Ed25519.PublicKey+  } deriving (Show, Eq)++instance Arbitrary PublicKey where+  arbitrary = toPublic <$> arbitrary++-- | ED25519 secret cryptographic key.+newtype SecretKey = SecretKey+  { unSecretKey :: Ed25519.SecretKey+  } deriving (Show, Eq)++instance Arbitrary SecretKey where+  arbitrary = do+    seed <- BS.pack <$> vector 32+    let chachaSeed = drgNewSeed . seedFromInteger . os2ip $ seed+        (sk, _) = withDRG chachaSeed Ed25519.generateSecretKey+    return (SecretKey sk)++-- | Create a public key from a secret key.+toPublic :: SecretKey -> PublicKey+toPublic = PublicKey . Ed25519.toPublic . unSecretKey++-- | ED25519 cryptographic signature.+newtype Signature = Signature+  { unSignature :: Ed25519.Signature+  } deriving (Show, Eq)++instance Arbitrary Signature where+  arbitrary = sign <$> arbitrary <*> (encodeUtf8 @String <$> arbitrary)++-- | b58check of a public key.+newtype KeyHash = KeyHash+  { unKeyHash :: ByteString+  } deriving (Show, Eq, Ord)++instance Arbitrary KeyHash where+  arbitrary = hashKey <$> arbitrary++----------------------------------------------------------------------------+-- Magic bytes+--+-- These magic bytes were deduced empirically by taking sample data+-- (public and secret keys, signatures, etc.), decoding it and+-- noticing that all of them have the same start bytes.+-- Tests prove that they are valid (if they were invalid, parse* functions+-- would return some crypto primitive for which underlying crypto would+-- work differently).+----------------------------------------------------------------------------++publicKeyTag :: ByteString+publicKeyTag = "\13\15\37\217"++secretKeyTag :: ByteString+secretKeyTag = "\13\15\58\7"++signatureTag :: ByteString+signatureTag = "\9\245\205\134\18"++keyHashTag :: ByteString+keyHashTag = "\6\161\159"++----------------------------------------------------------------------------+-- Formatting+----------------------------------------------------------------------------++-- | Error that can happen during parsing of cryptographic primitive types.+data CryptoParseError+  = CryptoParseWrongBase58Check+  | CryptoParseWrongTag !ByteString+  | CryptoParseCryptoError CryptoError+  deriving (Show, Eq)++instance Buildable.Buildable CryptoParseError where+  build =+    \case+      CryptoParseWrongBase58Check -> "Wrong base58check encoding of bytes"+      CryptoParseWrongTag tag -> "Prefix is wrong tag: " <> fmt (hexF tag)+      CryptoParseCryptoError err ->+        "Cryptographic library reported an error: " <>+        Buildable.build (displayException err)++formatPublicKey :: PublicKey -> Text+formatPublicKey = formatImpl publicKeyTag . unPublicKey++instance Buildable.Buildable PublicKey where+  build = Buildable.build . formatPublicKey++parsePublicKey :: Text -> Either CryptoParseError PublicKey+parsePublicKey = parseImpl publicKeyTag Ed25519.publicKey++formatSecretKey :: SecretKey -> Text+formatSecretKey = formatImpl secretKeyTag . unSecretKey++instance Buildable.Buildable SecretKey where+  build = Buildable.build . formatSecretKey++parseSecretKey :: Text -> Either CryptoParseError SecretKey+parseSecretKey = parseImpl secretKeyTag Ed25519.secretKey++formatSignature :: Signature -> Text+formatSignature = formatImpl signatureTag . unSignature++instance Buildable.Buildable Signature where+  build = Buildable.build . formatSignature++parseSignature :: Text -> Either CryptoParseError Signature+parseSignature = parseImpl signatureTag Ed25519.signature++formatKeyHash :: KeyHash -> Text+formatKeyHash = formatImpl keyHashTag . unKeyHash++instance Buildable.Buildable KeyHash where+  build = Buildable.build . formatKeyHash++parseKeyHash :: Text -> Either CryptoParseError KeyHash+parseKeyHash = parseImpl keyHashTag pure++formatImpl :: ByteArray.ByteArrayAccess x => ByteString -> x -> Text+formatImpl tag = encodeBase58Check . mappend tag . ByteArray.convert++parseImpl+  :: Coercible x res+  => ByteString+  -> (ByteString -> CryptoFailable x)+  -> Text+  -> Either CryptoParseError res+parseImpl expectedTag constructor text = do+  let convertErr :: B58CheckWithPrefixError -> CryptoParseError+      convertErr =+        \case B58CheckWithPrefixWrongPrefix prefix -> CryptoParseWrongTag prefix+              B58CheckWithPrefixWrongEncoding -> CryptoParseWrongBase58Check+  payload <- first convertErr $ decodeBase58CheckWithPrefix expectedTag text+  bimap CryptoParseCryptoError coerce $+    eitherCryptoError $ constructor payload++----------------------------------------------------------------------------+-- JSON encoding/decoding+----------------------------------------------------------------------------++instance ToJSON PublicKey where+  toJSON = Aeson.String . formatPublicKey+  toEncoding = Aeson.text . formatPublicKey++instance FromJSON PublicKey where+  parseJSON =+    Aeson.withText "PublicKey" $+    either (fail . pretty) pure . parsePublicKey++instance ToJSON Signature where+  toJSON = Aeson.String . formatSignature+  toEncoding = Aeson.text . formatSignature++instance FromJSON Signature where+  parseJSON =+    Aeson.withText "Signature" $+    either (fail . pretty) pure . parseSignature++instance ToJSON KeyHash where+  toJSON = Aeson.String . formatKeyHash+  toEncoding = Aeson.text . formatKeyHash++instance FromJSON KeyHash where+  parseJSON =+    Aeson.withText "KeyHash" $+    either (fail . pretty) pure . parseKeyHash++----------------------------------------------------------------------------+-- Signing+----------------------------------------------------------------------------++-- | Sign a message using the secret key.+sign :: SecretKey -> ByteString -> Signature+sign sk =+  Signature .+  Ed25519.sign (unSecretKey sk) (unPublicKey (toPublic sk)) . blake2b++-- | Check that a sequence of bytes has been signed with a given key.+checkSignature :: PublicKey -> Signature -> ByteString -> Bool+checkSignature (PublicKey pk) (Signature sig) bytes =+  Ed25519.verify pk (blake2b bytes) sig++----------------------------------------------------------------------------+-- Hashing+----------------------------------------------------------------------------++-- | Compute the b58check of a public key hash.+hashKey :: PublicKey -> KeyHash+hashKey (PublicKey pk) =+  KeyHash (fromDigest @Blake2b_160 $ hash @ByteString $ ByteArray.convert pk)++-- | Compute a cryptographic hash of a bytestring using the+-- Blake2b_256 cryptographic hash function. It's used by the BLAKE2B+-- instruction in Michelson.+blake2b :: ByteString -> ByteString+blake2b = fromDigest @Blake2b_256 . hash++-- | Compute a cryptographic hash of a bytestring using the+-- Blake2b_160 cryptographic hash function.+blake2b160 :: ByteString -> ByteString+blake2b160 = fromDigest @Blake2b_160 . hash++-- | Compute a cryptographic hash of a bytestring using the+-- Sha256 cryptographic hash function.+sha256 :: ByteString -> ByteString+sha256 = fromDigest @SHA256 . hash++-- | Compute a cryptographic hash of a bytestring using the+-- Sha512 cryptographic hash function.+sha512 :: ByteString -> ByteString+sha512 = fromDigest @SHA512 . hash++fromDigest :: forall a. Digest a -> ByteString+fromDigest = ByteArray.convert++----------------------------------------------------------------------------+-- Utility functions+----------------------------------------------------------------------------++-- | Encode a bytestring in Base58Check format.+encodeBase58Check :: ByteString -> Text+encodeBase58Check =+  decodeUtf8 . Base58.encodeBase58 Base58.bitcoinAlphabet . withCheckSum+  where+    withCheckSum :: ByteString -> ByteString+    withCheckSum bs = bs <> checkSum bs++-- | Decode a bytestring from Base58Check format.+decodeBase58Check :: Text -> Maybe ByteString+decodeBase58Check text = do+  bytes <- Base58.decodeBase58 Base58.bitcoinAlphabet (encodeUtf8 text)+  let (payload, chk) = BS.splitAt (length bytes - 4) bytes+  guard $ chk == checkSum payload+  return payload++checkSum :: ByteString -> ByteString+checkSum = BS.take 4 . (sha256 . sha256)++data B58CheckWithPrefixError+  = B58CheckWithPrefixWrongPrefix ByteString+  | B58CheckWithPrefixWrongEncoding+  deriving (Show)++-- | Parse a base58check encoded value expecting some prefix. If the+-- actual prefix matches the expected one, it's stripped of and the+-- resulting payload is returned.+decodeBase58CheckWithPrefix ::+     ByteString -> Text -> Either B58CheckWithPrefixError ByteString+decodeBase58CheckWithPrefix prefix text =+  case decodeBase58Check text of+    Nothing -> Left B58CheckWithPrefixWrongEncoding+    Just bs ->+      let (actualPrefix, payload) = BS.splitAt (length prefix) bs+       in if actualPrefix == prefix+          then Right payload+          else Left (B58CheckWithPrefixWrongPrefix actualPrefix)
+ test/Spec.hs view
@@ -0,0 +1,33 @@+module Main+  ( main+  ) where++import Test.Hspec (hspec)++import qualified Test.CValConversion as CVal+import qualified Test.Interpreter as Interpreter+import qualified Test.Macro as Macro+import qualified Test.Morley.Runtime as Morley.Runtime+import qualified Test.Ext as Ext+import qualified Test.Parser as Parser+import qualified Test.Serialization.Aeson as Serialization.Aeson+import qualified Test.Tezos.Address as Tezos.Address+import qualified Test.Tezos.Crypto as Tezos.Crypto+import qualified Test.Typecheck as Typecheck+import qualified Test.ValConversion as Val++main :: IO ()+main = hspec $ do+  Parser.spec+  Macro.spec+  Typecheck.typeCheckSpec+  Ext.typeCheckHandlerSpec+  Ext.interpretHandlerSpec+  Interpreter.spec+  Tezos.Crypto.spec+  Tezos.Address.spec+  Morley.Runtime.spec+  Serialization.Aeson.spec+  Interpreter.spec+  Val.spec+  CVal.spec
+ test/Test/Arbitrary.hs view
@@ -0,0 +1,255 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Arbitrary () where++import Prelude hiding (EQ, GT, LT)++import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Test.QuickCheck (Arbitrary(..), Gen, choose, elements, listOf, oneof, vector)+import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary(..))+import Test.QuickCheck.Instances.Text ()++import Michelson.Untyped+  (Annotation(..), CT(..), Comparable(..), Contract(..), Elt(..), FieldAnn, InstrAbstract(..),+  InternalByteString(..), Op(..), T(..), Type(..), TypeAnn, Value(..), VarAnn)+import Morley.Test ()+import Morley.Types (StackTypePattern(..), TyVar(..), UExtInstr, UExtInstrAbstract(..), Var(..))+import Tezos.Core (Mutez(..))++instance Arbitrary InternalByteString where+  arbitrary = InternalByteString . T.encodeUtf8 . T.pack <$> listOf arbitrary++instance Arbitrary Var where+  arbitrary = Var <$> arbitrary++instance Arbitrary TyVar where+  arbitrary = oneof [VarID <$> arbitrary, TyCon <$> arbitrary]++instance Arbitrary StackTypePattern where+  arbitrary = oneof [pure StkEmpty, pure StkRest, StkCons <$> arbitrary <*> arbitrary]++-- TODO extend Arbitrary UExtInstr with other constructors+instance Arbitrary UExtInstr where+  arbitrary = oneof [STACKTYPE <$> arbitrary]++instance ToADTArbitrary Op+instance Arbitrary Op where+  arbitrary = Op <$> arbitrary++instance ToADTArbitrary Mutez++instance ToADTArbitrary TypeAnn+instance Arbitrary TypeAnn where+  arbitrary = Annotation <$> arbitrary++instance ToADTArbitrary FieldAnn+instance Arbitrary FieldAnn where+  arbitrary = Annotation <$> arbitrary++instance ToADTArbitrary VarAnn+instance Arbitrary VarAnn where+  arbitrary = Annotation <$> arbitrary++smallSize :: Gen Int+smallSize = choose (0, 3)++instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Contract op)+instance (Arbitrary op) => Arbitrary (Contract op) where+  arbitrary = Contract <$> arbitrary <*> arbitrary <*> arbitrary++instance (Arbitrary op, ToADTArbitrary op, Arbitrary (UExtInstrAbstract op)) => ToADTArbitrary (InstrAbstract op)+instance (Arbitrary op, Arbitrary (UExtInstrAbstract op)) => Arbitrary (InstrAbstract op) where+  arbitrary =+    oneof+      [ EXT <$> arbitrary+      , pure DROP+      , DUP <$> arbitrary+      , pure SWAP+      , PUSH <$> arbitrary <*> arbitrary <*> arbitrary+      , SOME <$> arbitrary <*> arbitrary <*> arbitrary+      , NONE <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , UNIT <$> arbitrary <*> arbitrary+      , (do size1 <- smallSize+            size2 <- smallSize+            l1 <- vector size1+            l2 <- vector size2+            pure $ IF_NONE l1 l2+        )+      , PAIR <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , CAR <$> arbitrary <*> arbitrary+      , CDR <$> arbitrary <*> arbitrary+      , LEFT <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , RIGHT <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , (do size1 <- smallSize+            size2 <- smallSize+            l1 <- vector size1+            l2 <- vector size2+            pure $ IF_LEFT l1 l2+        )+      , (do size1 <- smallSize+            size2 <- smallSize+            l1 <- vector size1+            l2 <- vector size2+            pure $ IF_RIGHT l1 l2+        )+      , NIL <$> arbitrary <*> arbitrary <*> arbitrary+      , CONS <$> arbitrary+      , (do size1 <- smallSize+            size2 <- smallSize+            l1 <- vector size1+            l2 <- vector size2+            pure $ IF_CONS l1 l2+        )+      , SIZE <$> arbitrary+      , EMPTY_SET <$> arbitrary <*> arbitrary <*> arbitrary+      , EMPTY_MAP <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , (do size1 <- smallSize+            l1 <- vector size1+            MAP <$> arbitrary <*> pure l1+        )+      , (do size1 <- smallSize+            l1 <- vector size1+            pure $ ITER l1+        )+      , MEM <$> arbitrary+      , GET <$> arbitrary+      , pure UPDATE+      , (do size1 <- smallSize+            size2 <- smallSize+            l1 <- vector size1+            l2 <- vector size2+            pure $ IF l1 l2+        )+      , (do size1 <- smallSize+            l1 <- vector size1+            pure $ LOOP l1+        )+      , (do size1 <- smallSize+            l1 <- vector size1+            pure $ LOOP_LEFT l1+        )+      , (do size1 <- smallSize+            l1 <- vector size1+            LAMBDA <$> arbitrary <*> arbitrary <*> arbitrary <*> pure l1+        )+      , EXEC <$> arbitrary+      , (do size1 <- smallSize+            l1 <- vector size1+            pure $ DIP l1+        )+      , pure FAILWITH+      , CAST <$> arbitrary <*> arbitrary+      , RENAME <$> arbitrary+      , PACK <$> arbitrary+      , UNPACK <$> arbitrary <*> arbitrary+      , CONCAT <$> arbitrary+      , SLICE <$> arbitrary+      , ISNAT <$> arbitrary+      , ADD <$> arbitrary+      , SUB <$> arbitrary+      , MUL <$> arbitrary+      , EDIV <$> arbitrary+      , ABS <$> arbitrary+      , pure NEG+      , LSL <$> arbitrary+      , LSR <$> arbitrary+      , OR <$> arbitrary+      , AND <$> arbitrary+      , XOR <$> arbitrary+      , NOT <$> arbitrary+      , COMPARE <$> arbitrary+      , EQ <$> arbitrary+      , NEQ <$> arbitrary+      , LT <$> arbitrary+      , GT <$> arbitrary+      , LE <$> arbitrary+      , GE <$> arbitrary+      , INT <$> arbitrary+      , SELF <$> arbitrary+      , CONTRACT <$> arbitrary <*> arbitrary+      , TRANSFER_TOKENS <$> arbitrary+      , SET_DELEGATE <$> arbitrary+      , CREATE_ACCOUNT <$> arbitrary <*> arbitrary+      , CREATE_CONTRACT <$> arbitrary <*> arbitrary+      , CREATE_CONTRACT2 <$> arbitrary <*> arbitrary <*> arbitrary+      , IMPLICIT_ACCOUNT <$> arbitrary+      , NOW <$> arbitrary+      , AMOUNT <$> arbitrary+      , BALANCE <$> arbitrary+      , CHECK_SIGNATURE <$> arbitrary+      , SHA256 <$> arbitrary+      , SHA512 <$> arbitrary+      , BLAKE2B <$> arbitrary+      , HASH_KEY <$> arbitrary+      , STEPS_TO_QUOTA <$> arbitrary+      , SOURCE <$> arbitrary+      , SENDER <$> arbitrary+      , ADDRESS <$> arbitrary+      ]++instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Value op)+instance (Arbitrary op) => Arbitrary (Value op) where+  arbitrary =+    oneof+      [ ValueInt <$> arbitrary+      , ValueString <$> arbitrary+      , ValueBytes <$> arbitrary+      , pure ValueUnit+      , pure ValueTrue+      , pure ValueFalse+      , ValuePair <$> arbitrary <*> arbitrary+      , ValueLeft <$> arbitrary+      , ValueRight <$> arbitrary+      , ValueSome <$> arbitrary+      , pure ValueNone+      , (do size1 <- smallSize+            l1 <- vector size1+            pure $ ValueSeq l1+        )+      , (do size1 <- smallSize+            l1 <- vector size1+            pure $ ValueMap l1+        )+      , (do size1 <- smallSize+            l1 <- vector size1+            pure $ ValueLambda l1+        )+      ]++instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Elt op)+instance (Arbitrary op) => Arbitrary (Elt op) where+  arbitrary = Elt <$> arbitrary <*> arbitrary++instance ToADTArbitrary Type+instance Arbitrary Type where+  arbitrary = Type <$> arbitrary <*> arbitrary++instance ToADTArbitrary T+instance Arbitrary T where+  arbitrary =+    oneof+      [ Tc <$> arbitrary+      , pure TKey+      , pure TUnit+      , pure TSignature+      , TOption <$> arbitrary <*> arbitrary+      , TList <$> arbitrary+      , TSet <$> arbitrary+      , pure TOperation+      , TContract <$> arbitrary+      , TPair <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , TOr <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+      , TLambda <$> arbitrary <*> arbitrary+      , TMap <$> arbitrary <*> arbitrary+      , TBigMap <$> arbitrary <*> arbitrary+      ]++instance ToADTArbitrary CT+instance Arbitrary CT where+  arbitrary =  elements [minBound .. maxBound]++instance ToADTArbitrary Comparable+instance Arbitrary Comparable where+  arbitrary = Comparable <$> arbitrary <*> arbitrary
+ test/Test/CValConversion.hs view
@@ -0,0 +1,32 @@+-- | Testing of toCVal / fromCVal conversions++module Test.CValConversion+  ( spec+  ) where++import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec.QuickCheck (prop)++import Michelson.Typed (CVal(..), fromCVal, toCVal)++-- | Spec to test toCVal / fromCVal conversions.+spec :: Spec+spec = do+  describe "ToCVal / FromCVal tests" $ do+    it "ToCVal / FromCVal manual tests" $ do+      toCVal @Int 10 `shouldBe` CvInt 10+      toCVal @Integer 10 `shouldBe` CvInt 10+      toCVal @Integer (-10) `shouldBe` CvInt (-10)+      toCVal @Word64 10 `shouldBe` CvNat 10+      toCVal @Natural 10 `shouldBe` CvNat 10+      toCVal @Text "abc" `shouldBe` CvString "abc"+      toCVal True `shouldBe` CvBool True+      fromCVal (CvInt 10) `shouldBe` (10 :: Integer)+      fromCVal (CvString "abc") `shouldBe` ("abc" :: Text)+      fromCVal (CvBool True) `shouldBe` True++    describe "ToCVal / FromCVal property tests" $ do+      prop "ToCVal / FromCVal: Integer"+        $ \v -> fromCVal (toCVal @Integer v) == v+      prop "ToCVal / FromCVal: Bool"+        $ \v -> fromCVal (toCVal @Bool v) == v
+ test/Test/Ext.hs view
@@ -0,0 +1,82 @@+module Test.Ext+  ( typeCheckHandlerSpec+  , interpretHandlerSpec+  ) where++import Test.Hspec (Expectation, Spec, describe, expectationFailure, it, shouldSatisfy)++import Michelson.Interpret (InterpreterState(..))+import Michelson.TypeCheck (HST(..), SomeHST(..), runTypeCheckT)+import Michelson.Typed (CVal(..), Instr, Val(..), extractNotes, fromUType, withSomeSingT)+import qualified Michelson.Typed as T+import Michelson.Untyped (CT(..), T(..), Type(..), ann, noAnn)+import Morley.Ext (interpretMorley, typeCheckHandler)+import Morley.Test (specWithTypedContract)+import Morley.Test.Dummy (dummyContractEnv)+import Morley.Types+  (MorleyLogs(..), StackTypePattern(..), TyVar(..), UExtInstr, UExtInstrAbstract(..))++interpretHandlerSpec :: Spec+interpretHandlerSpec = describe "interpretHandler PRINT/TEST_ASSERT tests" $+  specWithTypedContract "contracts/testassert_square.tz" $ \c -> do+    it "TEST_ASSERT assertion passed" $ do+      runTest True c 100 100+      runTest True c 1 1+    it "TEST_ASSERT assertion failed" $ do+      runTest False c 0 100+      runTest False c -1 -2+  where+    runTest corr contract x y = do+      let x' = VC $ CvInt x :: Val Instr ('T.Tc 'T.CInt)+      let y' = VC $ CvInt y :: Val Instr ('T.Tc 'T.CInt)+      let area' = VC $ CvInt $ x * y :: Val Instr ('T.Tc 'T.CInt)+      let check (a, InterpreterState s _) =+            if corr then isRight a && s == MorleyLogs ["Area is " <> show area']+            else isLeft a && s == MorleyLogs ["Sides are " <> show x' <> " x " <> show y']+      interpretMorley contract (VPair (x', y')) VUnit dummyContractEnv `shouldSatisfy` check++typeCheckHandlerSpec :: Spec+typeCheckHandlerSpec = describe "typeCheckHandler STACKTYPE tests" $ do+  it "Correct test on [] pattern" $ runNopTest test1 True+  it "Correct test on [a, b] pattern" $ runNopTest test2 True+  it "Correct test on [a, b, ...] pattern" $ runNopTest test3 True+  it "Correct test on [a, b, ...] pattern and stack [a, b]" $ runNopTest test4 True++  it "Failed test on [] pattern and stack [a]" $ runNopTest test5 False+  it "Failed test on [a, b] pattern and stack [a, b, c]" $ runNopTest test6 False+  it "Failed test on [a, b] pattern and stack [a]" $ runNopTest test7 False+  it "Failed test on [a, b, ...] pattern and stack [a]" $ runNopTest test8 False+  it "Failed test on [a, b] pattern and stack [a, c]" $ runNopTest test9 False+  where+    p2 = StkCons (TyCon t1) (StkCons (TyCon t2) StkEmpty)+    p3 = StkCons (TyCon t1) (StkCons (TyCon t2) StkRest)++    test1 = (STACKTYPE StkEmpty, convertToHST [])+    test2 = (STACKTYPE p2, convertToHST [t1, t2])+    test3 = (STACKTYPE p3, convertToHST [t1, t2, t3])+    test4 = (STACKTYPE p3, convertToHST [t1, t2])++    test5 = (STACKTYPE StkEmpty, convertToHST [t1])+    test6 = (STACKTYPE p2, convertToHST [t1, t2, t3])+    test7 = (STACKTYPE p2, convertToHST [t1])+    test8 = (STACKTYPE p3, convertToHST [t1])+    test9 = (STACKTYPE p2, convertToHST [t1, t3])++    t1 = Type (TOption (ann "f") (Type TKey (ann "key"))) (ann "opt")+    t2 = Type (TPair (ann "f") (ann "s") (Type TUnit "x") (Type TSignature "s")) noAnn+    t3 = Type (Tc CInt) (ann "tint")++    convertToHST :: [Type] -> SomeHST+    convertToHST [] = SomeHST SNil+    convertToHST (t : ts) = withSomeSingT (fromUType t) $ \sing ->+      let nt = either (const $ error "unexpected trouble with extracting annotations") id (extractNotes t sing) in+      case convertToHST ts of+        SomeHST is -> SomeHST ((sing, nt, noAnn) ::& is)++    nh (ni, si) = runTypeCheckT typeCheckHandler (Type TKey noAnn) $ typeCheckHandler ni [] si++    runNopTest :: (UExtInstr, SomeHST) -> Bool -> Expectation+    runNopTest tcase correct = case (nh tcase, correct) of+      (Right _, False) -> expectationFailure $ "Test expected to fail but it passed"+      (Left e, True)   -> expectationFailure $ "Test expected to pass but it failed with error: " <> show e+      _                -> pass
+ test/Test/Interpreter.hs view
@@ -0,0 +1,124 @@+module Test.Interpreter+  ( spec+  ) where++import Fmt (pretty)+import Test.Hspec (Expectation, Spec, describe, expectationFailure, it, shouldBe, shouldSatisfy)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Property, label, (.&&.), (===))++import Michelson.Interpret (ContractEnv(..), ContractReturn, MichelsonFailed(..), RemainingSteps)+import Michelson.Typed (CT(..), CVal(..), Instr(..), T(..), Val(..), fromVal, toVal, ( # ))+import Morley.Ext (interpretMorley)+import Morley.Test (ContractPropValidator, contractProp, specWithTypedContract)+import Morley.Test.Dummy (dummyContractEnv)+import Morley.Test.Util (failedProp)+import Morley.Types (MorleyLogs)+import Test.Interpreter.Auction (auctionSpec)+import Test.Interpreter.CallSelf (selfCallerSpec)+import Test.Interpreter.Compare (compareSpec)+import Test.Interpreter.Conditionals (conditionalsSpec)+import Test.Interpreter.StringCaller (stringCallerSpec)++spec :: Spec+spec = describe "Advanced type interpreter tests" $ do+  let contractResShouldBe (res, _) expected =+        case res of+          Left err -> expectationFailure $ "Unexpected failure: " <> pretty err+          Right (_ops, v) -> v `shouldBe` expected++  specWithTypedContract "contracts/basic5.tz" $ \contract ->+    it "Basic test" $+      interpretMorley contract VUnit (toVal [1 :: Integer]) dummyContractEnv+        `contractResShouldBe` (toVal [13 :: Integer, 100])++  specWithTypedContract "contracts/increment.tz" $ \contract ->+    it "Basic test" $+      interpretMorley contract VUnit (toVal @Integer 23) dummyContractEnv+        `contractResShouldBe` (toVal @Integer 24)++  specWithTypedContract "contracts/fail.tz" $ \contract ->+    it "Fail test" $+      interpretMorley contract VUnit VUnit dummyContractEnv+        `shouldSatisfy` (isLeft . fst)++  specWithTypedContract "contracts/mutez_add_overflow.tz" $ \contract ->+    it "Mutez add overflow test" $+      interpretMorley contract VUnit VUnit dummyContractEnv+        `shouldSatisfy` (isLeft . fst)++  specWithTypedContract "contracts/mutez_sub_underflow.tz" $ \contract ->+    it "Mutez sub underflow test" $+      interpretMorley contract VUnit VUnit dummyContractEnv+        `shouldSatisfy` (isLeft . fst)++  specWithTypedContract "contracts/basic1.tz" $ \contract -> do+    prop "Random check" $ \input ->+      contractProp @_ @[Integer] contract (validateBasic1 input)+      dummyContractEnv () input++  auctionSpec+  compareSpec+  conditionalsSpec+  stringCallerSpec+  selfCallerSpec++  specWithTypedContract "contracts/steps_to_quota_test1.tz" $ \contract -> do+    it "Amount of steps should reduce" $ do+      validateStepsToQuotaTest+        (interpretMorley contract VUnit (VC (CvNat 0)) dummyContractEnv) 4++  specWithTypedContract "contracts/steps_to_quota_test2.tz" $ \contract -> do+    it "Amount of steps should reduce" $ do+      validateStepsToQuotaTest+        (interpretMorley contract VUnit (VC (CvNat 0)) dummyContractEnv) 8++  specWithTypedContract "contracts/gas_exhaustion.tz" $ \contract -> do+    it "Contract should fail due to gas exhaustion" $ do+      let dummyStr = toVal @Text "x"+      case fst $ interpretMorley contract dummyStr dummyStr dummyContractEnv of+        Right _ -> expectationFailure "expecting contract to fail"+        Left MichelsonGasExhaustion -> pass+        Left _ -> expectationFailure "expecting another failure reason"++validateBasic1+  :: [Integer] -> ContractPropValidator ('TList ('Tc 'CInt)) Property+validateBasic1 input (Right (ops, res), _) =+    (fromVal res === [sum input + 12, 100])+    .&&.+    (label "returned no ops" $ null ops)+validateBasic1 _ (Left e, _) = failedProp $ show e++validateStepsToQuotaTest ::+     ContractReturn MorleyLogs ('Tc 'CNat) -> RemainingSteps -> Expectation+validateStepsToQuotaTest res numOfSteps =+  case fst res of+    Right ([], VC (CvNat x)) ->+      (fromInteger . toInteger) x `shouldBe` ceMaxSteps dummyContractEnv - numOfSteps+    _ -> expectationFailure "unexpected contract result"++--------------------+-- Examples+--------------------++-- | @myInstr@ is an equivalent to Michelson code:+--+--    PUSH int 223;+--    SOME;+--    IF_NONE { DUP; } { SWAP; };+--    ADD;+--    PUSH nat 12+--    ADD;+_myInstr :: Typeable s => Instr ('Tc 'CInt : s) ('Tc 'CInt : s)+_myInstr =+  PUSH (VC $ CvInt 223) #+  SOME #+  IF_NONE DUP SWAP #+  ADD #+  PUSH (VC $ CvNat 12) #+  ADD++_myInstr2 :: Typeable a => Instr a ('TOption ('Tc 'CInt) : a)+_myInstr2 =+  PUSH (VOption $ Just $ VC $ CvInt 223) #+  Nop
+ test/Test/Interpreter/Auction.hs view
@@ -0,0 +1,135 @@+-- | Module, containing spec to test auction.tz contract.+--+-- This spec is an example of using testing capabilities of morley.+module Test.Interpreter.Auction+  ( auctionSpec+  ) where++import Test.Hspec (Spec, it, parallel, shouldSatisfy)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Property, arbitrary, choose, counterexample, (.&&.), (===))+import Test.QuickCheck.Gen (unGen)+import Test.QuickCheck.Property (expectFailure, forAll, withMaxSuccess)+import Test.QuickCheck.Random (mkQCGen)++import Michelson.Interpret (ContractEnv(..))+import Michelson.Typed (CVal(..), Operation(..), ToT, TransferTokens(..), Val(..))+import Morley.Test (ContractPropValidator, contractProp, midTimestamp, specWithTypedContract)+import Morley.Test.Dummy+import Morley.Test.Util (failedProp)+import Tezos.Address (Address(..))+import Tezos.Core (Mutez, Timestamp, timestampPlusSeconds, unMutez, unsafeMkMutez, unsafeSubMutez)+import Tezos.Crypto (KeyHash)++type Storage = (Timestamp, (Mutez, KeyHash))+type Param = KeyHash++-- | Spec to test auction.tz contract.+--+-- This spec serves as an example on how to test contract with both unit tests+-- and QuickCheck.+auctionSpec :: Spec+auctionSpec = parallel $ do+  -- Test auction.tz, everything should be fine+  specWithTypedContract "contracts/auction.tz" $ \contract -> do+    it "Bid after end of auction triggers failure" $+      contractProp contract+        (flip shouldSatisfy (isLeft . fst))+        (env { ceAmount = unsafeMkMutez 1200 })+        keyHash2+        (aBitBeforeMidTimestamp, (unsafeMkMutez 1000, keyHash1))++    prop "Random check (sparse distribution)" $ withMaxSuccess 200 $+      qcProp contract arbitrary arbitrary++    prop "Random check (dense end of auction)" $+      qcProp contract denseTime arbitrary++    prop "Random check (dense amount)" $+      qcProp contract arbitrary denseAmount++  -- Test slightly modified version of auction.tz, it must fail.+  -- This block is given purely for demonstration of that tests are smart+  -- enough to filter common mistakes.+  specWithTypedContract "contracts/auction-buggy.tz" $ \contract -> do+    prop "Random check (dense end of auction)" $+      expectFailure $ qcProp contract denseTime arbitrary++    prop "Random check (dense amount)" $+      expectFailure $ qcProp contract arbitrary denseAmount++  where+    qcProp contract eoaGen amountGen =+      forAll ((,) <$> eoaGen <*> ((,) <$> amountGen <*> arbitrary)) $+        \s p ->+          let validate = validateAuction env p s+           in contractProp contract validate env p s++    aBitBeforeMidTimestamp = midTimestamp `timestampPlusSeconds` -1+    -- ^ 1s before NOW++    denseTime = timestampPlusSeconds midTimestamp <$> choose (-4, 4)+    denseAmount = unsafeMkMutez . (midAmount +) . fromInteger <$> choose (-4, 4)++    env = dummyContractEnv+            { ceNow = midTimestamp+            , ceAmount = unsafeMkMutez midAmount+            }+    midAmount = unMutez (maxBound `unsafeSubMutez` minBound) `div` 2++keyHash1 :: KeyHash+keyHash1 = unGen arbitrary (mkQCGen 300406) 0++keyHash2 :: KeyHash+keyHash2 = unGen arbitrary (mkQCGen 142917) 0++-- | This validator checks the result of auction.tz execution.+--+-- It checks following properties:+--+-- * Current timestamp is before end of auction+-- * Amount of new bid is higher than previous one+--+-- In case of successful execution:+--+-- * End of auction timestamp in updated storage is unchanged+-- * Amount in updated storage is equal to @AMOUNT@ of transaction+-- * Key hash in updated storage is equal to contract's parameter+-- * Script returned exactly one operation, @TransferTokens@, which+--   returns money back to the previous bidder+validateAuction+  :: ContractEnv+  -> Param+  -> Storage+  -> ContractPropValidator (ToT Storage) Property+validateAuction env newKeyHash (endOfAuction, (amount, keyHash)) (resE, _)+  | ceNow env > endOfAuction+      = counterexample "Failure didn't trigger on end of auction" $ isLeft resE+  | ceAmount env <= amount+      = counterexample ("Failure didn't trigger on attempt to bid"+                        <> " with amount <= than previous bid") $ isLeft resE+  | Left e <- resE+      = failedProp $ "Unexpected script fail: " <> show e++  | Right (_, (VPair ( VC (CvTimestamp endOfAuction'), _))) <- resE+  , endOfAuction /= endOfAuction'+      = failedProp "End of auction timestamp of contract changed"++  | Right (_, (VPair (_, VPair (VC (CvMutez amount'), _)))) <- resE+  , amount' /= ceAmount env+      = failedProp $ "Storage updated to wrong value: new amount"+                      <> " is not equal to amount of transaction"+  | Right (_, (VPair (_, VPair (_, VC (CvKeyHash keyHash'))))) <- resE+  , keyHash' /= newKeyHash+      = failedProp $ "Storage updated to wrong value: new key hash"+                      <> " is not equal to contract's parameter"++  | Right (ops, _) <- resE+     = let counterE msg =+              counterexample $ "Invalid money back operation (" <> msg <> ")"+        in case ops of+            OpTransferTokens (TransferTokens VUnit retAmount (VContract retAddr)) : [] ->+              counterE "wrong amount" (retAmount === amount)+                .&&.+              counterE "wrong address" (KeyAddress keyHash === retAddr)+            _ -> failedProp $ "Unexpected operation list: " <> show ops
+ test/Test/Interpreter/CallSelf.hs view
@@ -0,0 +1,110 @@+-- | Tests for the contract that calls self several times.++module Test.Interpreter.CallSelf+  ( selfCallerSpec+  ) where++import Test.Hspec (Expectation, Spec, it, parallel, shouldBe)+import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)+import Test.QuickCheck (Gen, choose, forAll)++import Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..))+import Michelson.Typed+import Michelson.Untyped (OriginationOperation(..), mkContractAddress)+import qualified Michelson.Untyped as Untyped+import Morley.Aliases (UntypedContract)+import Morley.Runtime (InterpreterOp(..), TxData(..))+import Morley.Runtime.GState+import Morley.Test (ContractPropValidator, contractProp, specWithContract)+import Morley.Test.Dummy+import Morley.Test.Integrational++selfCallerSpec :: Spec+selfCallerSpec =+  parallel $+  specWithContract "contracts/call_self_several_times.tz" $ \selfCaller ->+  specImpl selfCaller++data Fixture = Fixture+  { fMaxSteps :: RemainingSteps+  , fParameter :: !Word64+  } deriving Show++gasForOneExecution :: Num a => a+gasForOneExecution = 19++gasForLastExecution :: Num a => a+gasForLastExecution = 20++fExpectSuccess :: Fixture -> Bool+fExpectSuccess Fixture {..} =+  -- note: fParameter must be ≥ 1+  fMaxSteps >= fromIntegral ((fParameter - 1) * gasForOneExecution + gasForLastExecution)++genFixture :: Gen Fixture+genFixture =+  Fixture <$> (RemainingSteps <$> choose (minGas, maxGas)) <*> choose (minCalls, maxCalls)+  where+    minCalls = 1+    maxCalls = 10+    minGas = 0+    maxGas = gasForOneExecution * maxCalls++type Parameter = 'Tc 'CInt+type Storage = 'Tc 'CNat++specImpl ::+     (UntypedContract, Contract Parameter Storage)+  -> Spec+specImpl (uSelfCaller, selfCaller) = modifyMaxSuccess (min 10) $ do+  it ("With parameter 1 single execution consumes " <>+      show @_ @Int gasForLastExecution <> " gas") $+    contractProp selfCaller (unitValidator gasForLastExecution) unitContractEnv+    (1 :: Integer) (0 :: Natural)++  it ("With parameter 2 single execution consumes " <>+      show @_ @Int gasForOneExecution <> " gas") $+    contractProp selfCaller (unitValidator gasForOneExecution) unitContractEnv+    (2 :: Integer) (0 :: Natural)++  prop propertyDescription $+    forAll genFixture $ \fixture ->+      integrationalTestProperty dummyNow (fMaxSteps fixture)+      (operations fixture) (integValidator fixture)+  where+    -- Environment for unit test+    unitContractEnv = dummyContractEnv+    -- Validator for unit test+    unitValidator ::+      RemainingSteps -> ContractPropValidator Storage Expectation+    unitValidator gasDiff (_, isRemainingSteps -> remSteps) =+      remSteps `shouldBe` ceMaxSteps unitContractEnv - gasDiff++    propertyDescription =+      "calls itself as many times as you pass to it as a parameter, " <>+      "it fails due to gas limit if the number is large, otherwise the " <>+      "storage is updated to the number of calls"++    operations :: Fixture -> [InterpreterOp]+    operations fixture = [originateOp, transferOp fixture]++    origination :: OriginationOperation+    origination = dummyOrigination (Untyped.ValueInt 0) uSelfCaller+    address = mkContractAddress origination+    originateOp = OriginateOp origination++    txData :: Fixture -> TxData+    txData fixture = TxData+      { tdSenderAddress = genesisAddress+      , tdParameter = Untyped.ValueInt (fromIntegral $ fParameter fixture)+      , tdAmount = minBound+      }+    transferOp fixture = TransferOp address (txData fixture)++    integValidator :: Fixture -> IntegrationalValidator+    integValidator fixture+      | fExpectSuccess fixture =+        let expectedStorage =+              Untyped.ValueInt (fromIntegral $ fParameter fixture)+         in Right $ expectStorageConstant address expectedStorage+      | otherwise = Left expectGasExhaustion
+ test/Test/Interpreter/Compare.hs view
@@ -0,0 +1,52 @@+-- | Module, containing spec to test compare.tz contract.+module Test.Interpreter.Compare+  ( compareSpec+  ) where++import Test.Hspec (Spec, it, parallel)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Property, (===))+import Test.QuickCheck.Property (withMaxSuccess)++import Michelson.Interpret (InterpreterState, MichelsonFailed)+import Michelson.Typed (ToT, Val(..), fromVal)+import Morley.Test (contractProp, specWithTypedContract)+import Morley.Test.Dummy+import Morley.Test.Util (failedProp)+import Morley.Types (MorleyLogs)+import Tezos.Core (Mutez, unsafeMkMutez)++type Param = (Mutez, Mutez)+type ContractStorage instr = Val instr (ToT [Bool])+type ContractResult x instr+   = ( Either MichelsonFailed ([x], ContractStorage instr)+     , InterpreterState MorleyLogs)++-- | Spec to test compare.tz contract.+compareSpec :: Spec+compareSpec = parallel $ do++  specWithTypedContract "contracts/compare.tz" $ \contract -> do+    let+      contractProp' inputParam =+        contractProp contract (validate (mkExpected inputParam))+        dummyContractEnv inputParam initStorage++    it "success test" $+      contractProp' (unsafeMkMutez 10, unsafeMkMutez 11)++    prop "Random check" $ withMaxSuccess 200 contractProp'+  where+    initStorage :: [Bool]+    initStorage = []++    mkExpected :: Param -> [Bool]+    mkExpected (a, b) = [a == b, a > b, a < b, a >= b, a <= b]++    validate+      :: [Bool]+      -> ContractResult x instr+      -> Property+    validate e (Right ([], fromVal -> l), _) = l === e+    validate _ (Left _, _) = failedProp "Unexpected fail of sctipt."+    validate _ _ = failedProp "Invalid result got."
+ test/Test/Interpreter/Conditionals.hs view
@@ -0,0 +1,50 @@+-- | Module, containing spec to test conditionals.tz contract.+module Test.Interpreter.Conditionals+  ( conditionalsSpec+  ) where++import Test.Hspec (Spec, it, parallel)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Property, (===))+import Test.QuickCheck.Instances.Text ()+import Test.QuickCheck.Property (withMaxSuccess)++import Michelson.Interpret (InterpreterState, MichelsonFailed)+import Michelson.Typed (CVal(..), ToT, Val(..))+import Morley.Test (contractProp, specWithTypedContract)+import Morley.Test.Dummy (dummyContractEnv)+import Morley.Test.Util (failedProp, qcIsLeft, qcIsRight)+import Morley.Types (MorleyLogs)++type Param = Either Text (Maybe Integer)+type ContractStorage instr = Val instr (ToT Text)+type ContractResult x instr+   = ( Either MichelsonFailed ([x], ContractStorage instr)+     , InterpreterState MorleyLogs)++-- | Spec to test conditionals.tz contract.+conditionalsSpec :: Spec+conditionalsSpec = parallel $ do++  specWithTypedContract "contracts/conditionals.tz" $ \contract -> do+    let+      contractProp' inputParam =+        contractProp contract (validate inputParam) dummyContractEnv inputParam+        ("storage" :: Text)++    it "success 1 test" $+      contractProp' $ Left "abc"++    prop "Random check" $ withMaxSuccess 200 contractProp'+  where+    validate+      :: Show x+      => Param+      -> ContractResult x instr+      -> Property+    validate (Left a) (Right ([], VC (CvString b)), _) = a === b+    validate (Right Nothing) r = qcIsLeft $ fst r+    validate (Right (Just a)) r+      | a < 0 = qcIsLeft $ fst r+      | otherwise = qcIsRight $ fst r+    validate _ res = failedProp $ "Unexpected result: " <> show res
+ test/Test/Interpreter/StringCaller.hs view
@@ -0,0 +1,84 @@+-- | Tests for the 'stringCaller.tz' contract.++module Test.Interpreter.StringCaller+  ( stringCallerSpec+  ) where++import Test.Hspec (Spec, it, parallel)+import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)+import Test.QuickCheck.Instances.Text ()++import Michelson.Typed+import Michelson.Untyped (OriginationOperation(..), mkContractAddress)+import qualified Michelson.Untyped as Untyped+import Morley.Aliases (UntypedContract, UntypedValue)+import Morley.Runtime (InterpreterOp(..), TxData(..))+import Morley.Runtime.GState+import Morley.Test (specWithContract)+import Morley.Test.Dummy+import Morley.Test.Integrational+import Tezos.Address (formatAddress)+import Tezos.Core++stringCallerSpec :: Spec+stringCallerSpec =+  parallel $+  specWithContract "contracts/stringCaller.tz" $ \stringCaller ->+  specWithContract "contracts/idString.tz" $ \idString ->+  specImpl stringCaller idString++specImpl ::+     (UntypedContract, Contract ('Tc 'CString) ('Tc 'CAddress))+  -> (UntypedContract, Contract ('Tc 'CString) ('Tc 'CString))+  -> Spec+specImpl (uStringCaller, _stringCaller) (uIdString, _idString) = do+  it "stringCaller calls idString and updates its storage with a constant" $+    simplerIntegrationalTestExpectation+      (operations newValueConstant)+      (Right (updatesValidator newValueConstant))++  -- The test is trivial, so it's kinda useless to run it many times+  modifyMaxSuccess (const 2) $+    prop "stringCaller calls idString and updates its storage with an arbitrary value" $+      \(Untyped.ValueString -> newValue) -> simplerIntegrationalTestProperty+        (operations newValue)+        (Right (updatesValidator newValue))+  where+    newValueConstant = Untyped.ValueString "caller"++    idStringOrigination :: OriginationOperation+    idStringOrigination =+      dummyOrigination (Untyped.ValueString "hello") uIdString+    originateIdString = OriginateOp idStringOrigination+    idStringAddress = mkContractAddress idStringOrigination++    stringCallerOrigination :: OriginationOperation+    stringCallerOrigination =+      dummyOrigination (Untyped.ValueString $ formatAddress idStringAddress)+      uStringCaller+    originateStringCaller = OriginateOp stringCallerOrigination+    stringCallerAddress = mkContractAddress stringCallerOrigination++    txData :: UntypedValue -> TxData+    txData newValue = TxData+      { tdSenderAddress = genesisAddress+      , tdParameter = newValue+      , tdAmount = minBound+      }+    transferToStringCaller newValue =+      TransferOp stringCallerAddress (txData newValue)++    operations newValue =+      [ originateIdString+      , originateStringCaller+      , transferToStringCaller newValue+      ]++    -- `stringCaller.tz` transfers 2 mutez.+    expectedIdStringBalance =+      ooBalance idStringOrigination `unsafeAddMutez` unsafeMkMutez 2++    updatesValidator :: UntypedValue -> SuccessValidator+    updatesValidator newValue =+      expectStorageConstant idStringAddress newValue `composeValidators`+      expectBalance idStringAddress expectedIdStringBalance
+ test/Test/Macro.hs view
@@ -0,0 +1,173 @@+module Test.Macro+  ( spec+  ) where++import Morley.Macro+import Morley.Types+import Test.Hspec (Expectation, Spec, describe, it, shouldBe)++spec :: Spec+spec = describe "Macros tests" $ do+  it "expand test" expandTest+  it "expandFlat test" expandFlatTest+  it "papair test" expandPapairTest+  it "unpapair test" expandUnpapairTest+  it "expandCadr test" expandCadrTest+  it "expandSetCadr test" expandSetCadrTest+  it "expandMapCadr test" expandMapCadrTest+  it "mapLeaves test" mapLeavesTest+  it "flatten test" flattenTest+  it "expandValue test" expandValueTest++expandPapairTest :: Expectation+expandPapairTest = do+  expandPapair pair n n `shouldBe` [PRIM $ PAIR n n n n]+  expandPapair (P leaf pair) n n `shouldBe`+    [PRIM $ DIP [MAC $ PAPAIR pair n n], PRIM $ PAIR n n n n]+  expandFlat [MAC $ PAPAIR (P pair leaf) n n] `shouldBe`+    Op <$> [PAIR n n n n, PAIR n n n n]+  expandFlat [MAC $ PAPAIR (P pair pair) n n] `shouldBe`+    Op <$> [PAIR n n n n, DIP [Op $ PAIR n n n n], PAIR n n n n]+  where+    n = noAnn+    leaf = F (n, n)+    pair = P leaf leaf++expandUnpapairTest :: Expectation+expandUnpapairTest = do+  expandUnpapair pair `shouldBe`+    [PRIM $ DUP n, PRIM $ CAR n n, PRIM $ DIP [PRIM $ CDR n n]]+  expandFlat [MAC $ UNPAIR $ P leaf pair] `shouldBe`+    Op <$> [DUP n, CAR n n, DIP $ Op <$> [CDR n n, DUP n, CAR n n, DIP [Op $ CDR n n]]]+  expandFlat [MAC $ UNPAIR $ P pair leaf] `shouldBe`+    Op <$> [DUP n, DIP [Op $ CDR n n],  CAR n n, DUP n, CAR n n, DIP [Op $ CDR n n]]+  expandFlat [MAC $ UNPAIR $ P pair pair] `shouldBe`+    fmap Op ( expandP ++ [DIP $ Op <$> expandP] ++ expandP)+  where+    expandP = [DUP n, CAR n n, DIP [Op $ CDR n n]]+    n = noAnn+    leaf = F (n, n)+    pair = P leaf leaf++expandCadrTest :: Expectation+expandCadrTest = do+  expandCadr (A:[]) v f `shouldBe` [PRIM $ CAR v f]+  expandCadr (D:[]) v f `shouldBe` [PRIM $ CDR v f]+  expandCadr (A:xs) v f `shouldBe` [PRIM $ CAR n n, MAC $ CADR xs v f]+  expandCadr (D:xs) v f `shouldBe` [PRIM $ CDR n n, MAC $ CADR xs v f]+  where+    v = ann "var"+    f = ann "field"+    n = noAnn+    xs = [A, D]++expandSetCadrTest :: Expectation+expandSetCadrTest = do+  expandSetCadr [A] v f `shouldBe` PRIM <$> [ DUP noAnn, CAR noAnn f, DROP+                                            , CDR (ann "%%") noAnn, SWAP, PAIR noAnn v f (ann "@")]+  expandSetCadr [D] v f `shouldBe` PRIM <$> [ DUP noAnn, CDR noAnn f, DROP+                                            , CAR (ann "%%") noAnn, PAIR noAnn v (ann "@") f]+  expandSetCadr (A:xs) v f `shouldBe`+    PRIM <$> [DUP noAnn, DIP [PRIM carN, MAC $ SET_CADR xs noAnn f], cdrN, SWAP, pairN]+  expandSetCadr (D:xs) v f `shouldBe`+    PRIM <$> [DUP noAnn, DIP [PRIM cdrN, MAC $ SET_CADR xs noAnn f], carN, pairN]+  where+    v = ann "var"+    f = ann "field"+    xs = [A, D]+    carN = CAR noAnn noAnn+    cdrN = CDR noAnn noAnn+    pairN = PAIR noAnn v noAnn noAnn++expandMapCadrTest :: Expectation+expandMapCadrTest = do+  expandMapCadr [A] v f ops `shouldBe`+    PRIM <$> [DUP noAnn, cdrN, DIP [PRIM $ CAR noAnn f, SEQ ops], SWAP, pairN]+  expandMapCadr [D] v f ops `shouldBe`+    concat [PRIM <$> [DUP noAnn, CDR noAnn f], [SEQ ops], PRIM <$> [SWAP, carN, pairN]]+  expandMapCadr (A:xs) v f ops `shouldBe`+    PRIM <$> [DUP noAnn, DIP [PRIM $ carN, MAC $ MAP_CADR xs noAnn f ops], cdrN, SWAP, pairN]+  expandMapCadr (D:xs) v f ops `shouldBe`+    PRIM <$> [DUP noAnn, DIP [PRIM $ cdrN, MAC $ MAP_CADR xs noAnn f ops], carN, pairN]+  where+    v = ann "var"+    f = ann "field"+    n = noAnn+    xs = [A, D]+    ops = [PRIM $ DUP n]+    carN = CAR noAnn noAnn+    cdrN = CDR noAnn noAnn+    pairN = PAIR noAnn v noAnn noAnn++mapLeavesTest :: Expectation+mapLeavesTest = do+  mapLeaves [(v, f), (v, f)] pair `shouldBe` P (F (v, f)) (F (v, f))+  mapLeaves annotations (P pair (F (n, n))) `shouldBe`+    P (P (leaf "var1" "field1") (leaf "var2" "field2")) (leaf "var3" "field3")+  mapLeaves annotations (P pair pair) `shouldBe`+    P (P (leaf "var1" "field1") (leaf "var2" "field2")) (P (leaf "var3" "field3") (F (n, n)))+  where+    annotations = zip (ann <$> ["var1", "var2", "var3"]) (ann <$> ["field1", "field2", "field3"])+    n = noAnn+    v = ann "var"+    f = ann "field"+    leaf v' f' = F (ann v', ann f')+    pair = P (F (n, n)) (F (n, n))++flattenTest :: Expectation+flattenTest = do+  flatten (SEQ_EX [PRIM_EX $ SWAP, PRIM_EX $ SWAP]) `shouldBe`+    [SWAP, SWAP]+  flatten (SEQ_EX [SEQ_EX [SEQ_EX [PRIM_EX $ SWAP], PRIM_EX $ SWAP], PRIM_EX $ SWAP]) `shouldBe`+    [SWAP, SWAP, SWAP]++expandFlatTest :: Expectation+expandFlatTest = do+  expandFlat [papair] `shouldBe` Op <$> [DIP [Op $ PAIR n n n n], PAIR n n n n]+  expandFlat [diiiip] `shouldBe` Op <$> [DIP [Op $ DIP [Op $ DIP [Op $ DIP[Op $ SWAP]]]]]+  where+    n = noAnn+    papair :: ParsedOp+    papair =+      MAC (PAPAIR (P (F (n, n)) (P (F (n, n)) (F (n, n)))) n n)+    diiiip :: ParsedOp+    diiiip = MAC (DIIP 4 [PRIM SWAP])++expandTest :: Expectation+expandTest = do+  expand diip `shouldBe` expandedDiip+  expand (PRIM $ IF [diip] [diip]) `shouldBe` (PRIM_EX $ IF [expandedDiip] [expandedDiip])+  expand (SEQ [diip, diip]) `shouldBe` (SEQ_EX $ [expandedDiip, expandedDiip])+  where+    diip :: ParsedOp+    diip = MAC (DIIP 2 [PRIM SWAP])+    expandedDiip :: ExpandedOp+    expandedDiip = SEQ_EX [PRIM_EX (DIP [SEQ_EX [PRIM_EX (DIP [PRIM_EX SWAP])]])]++expandValueTest :: Expectation+expandValueTest = do+  expandValue parsedPair `shouldBe` expandedPair+  expandValue parsedPapair `shouldBe` expandedPapair+  expandValue parsedLambdaWithMac `shouldBe` expandedLambdaWithMac+  where+    parsedPair :: Value ParsedOp+    parsedPair = ValuePair (ValueInt 5) (ValueInt 5)++    expandedPair :: Value Op+    expandedPair = ValuePair (ValueInt 5) (ValueInt 5)++    parsedPapair :: Value ParsedOp+    parsedPapair = ValuePair (ValuePair (ValueInt 5) (ValueInt 5)) (ValueInt 5)++    expandedPapair :: Value Op+    expandedPapair = ValuePair (ValuePair (ValueInt 5) (ValueInt 5)) (ValueInt 5)++    parsedLambdaWithMac :: Value ParsedOp+    parsedLambdaWithMac = ValueLambda+      [MAC (PAPAIR (P (F (noAnn, noAnn)) (P (F (noAnn, noAnn)) (F (noAnn, noAnn)))) noAnn noAnn)]++    expandedLambdaWithMac :: Value Op+    expandedLambdaWithMac = ValueLambda+      [ Op {unOp = DIP [Op {unOp = PAIR noAnn noAnn noAnn noAnn}]}+      , Op {unOp = PAIR noAnn noAnn noAnn noAnn}+      ]
+ test/Test/Morley/Runtime.hs view
@@ -0,0 +1,152 @@+-- | Tests for Morley.Runtime.++module Test.Morley.Runtime+  ( spec+  ) where++import Control.Lens (at)+import Fmt (pretty)+import Test.Hspec+  (Expectation, Spec, context, describe, expectationFailure, it, parallel, runIO, shouldBe,+  shouldSatisfy, specify)++import Michelson.Interpret (ContractEnv(..), InterpretUntypedError(..), InterpretUntypedResult(..))+import Michelson.Typed (unsafeValToValue)+import Michelson.Untyped+import Morley.Ext (interpretMorleyUntyped)+import Morley.Runtime+import Morley.Runtime.GState (GState(..), initGState)+import Morley.Test.Dummy (dummyContractEnv, dummyMaxSteps, dummyNow, dummyOrigination)+import Morley.Types (MorleyLogs)+import Tezos.Address (Address(..))+import Tezos.Core (unsafeMkMutez)++spec :: Spec+spec = describe "Morley.Runtime" $ do+  illTypedContract <- runIO $+    prepareContract (Just "contracts/ill-typed/sum-strings.tz")++  -- Safe to run in parallel, because 'interpreterPure' is pure.+  describe "interpreterPure" $ parallel $ do+    context "Updates storage value of executed contract" $ do+      specify "contract1" $ updatesStorageValue contractAux1+      specify "contract2" $ updatesStorageValue contractAux2+    it "Fails to originate an already originated contract" failsToOriginateTwice+    it "Fails to originate an ill-typed contract"+      (failsToOriginateIllTyped (ValueString "") illTypedContract)++----------------------------------------------------------------------------+-- Test code+----------------------------------------------------------------------------++-- | Data type, that containts contract and its auxiliary data.+--+-- This type is mostly used for testing purposes.+data ContractAux = ContractAux+  { caContract :: !(Contract Op)+  , caEnv :: !ContractEnv+  , caStorage :: !(Value Op)+  , caParameter :: !(Value Op)+  }++data UnexpectedFailed =+  UnexpectedFailed (InterpretUntypedError MorleyLogs)+  deriving (Show)++instance Exception UnexpectedFailed++updatesStorageValue :: ContractAux -> Expectation+updatesStorageValue ca = either throwM handleResult $ do+  let+    contract = caContract ca+    ce = caEnv ca+    origination = (dummyOrigination (caStorage ca) contract)+      { ooBalance = ceBalance ce+      }+    addr = mkContractAddress origination+    txData = TxData+      { tdSenderAddress = ceSender ce+      , tdParameter = caParameter ca+      , tdAmount = unsafeMkMutez 100+      }+    interpreterOps =+      [ OriginateOp origination+      , TransferOp addr txData+      ]+  (addr,) <$> interpreterPure dummyNow dummyMaxSteps initGState interpreterOps+  where+    toNewStorage :: InterpretUntypedResult MorleyLogs -> Value Op+    toNewStorage InterpretUntypedResult {..} = unsafeValToValue iurNewStorage++    handleResult :: (Address, InterpreterRes) -> Expectation+    handleResult (addr, ir) = do+      expectedValue <-+        either (throwM . UnexpectedFailed) (pure . toNewStorage) $+        interpretMorleyUntyped+                  (caContract ca) (caParameter ca) (caStorage ca) (caEnv ca)+      case gsAddresses (_irGState ir) ^. at addr of+        Nothing -> expectationFailure $ "Address not found: " <> pretty addr+        Just (ASContract cs) -> csStorage cs `shouldBe` expectedValue+        Just _ -> expectationFailure $ "Address has unexpected state " <> pretty addr++failsToOriginateTwice :: Expectation+failsToOriginateTwice =+  simpleTest ops isAlreadyOriginated+  where+    contract = caContract contractAux1+    origination = dummyOrigination (caStorage contractAux1) contract+    ops = [OriginateOp origination, OriginateOp origination]+    isAlreadyOriginated (Left (IEAlreadyOriginated {})) = True+    isAlreadyOriginated _ = False++failsToOriginateIllTyped :: Value Op -> Contract Op -> Expectation+failsToOriginateIllTyped initialStorage illTypedContract =+  simpleTest ops isIllTypedContract+  where+    origination = dummyOrigination initialStorage illTypedContract+    ops = [OriginateOp origination]+    isIllTypedContract (Left (IEIllTypedContract {})) = True+    isIllTypedContract _ = False++simpleTest ::+     [InterpreterOp]+  -> (Either InterpreterError InterpreterRes -> Bool)+  -> Expectation+simpleTest ops predicate =+  interpreterPure dummyNow dummyMaxSteps initGState ops `shouldSatisfy`+  predicate++----------------------------------------------------------------------------+-- Data+----------------------------------------------------------------------------++contractAux1 :: ContractAux+contractAux1 = ContractAux+  { caContract = contract+  , caEnv = dummyContractEnv+  , caStorage = ValueTrue+  , caParameter = ValueString "aaa"+  }+  where+    contract :: Contract Op+    contract = Contract+      { para = Type tstring noAnn+      , stor = Type tbool noAnn+      , code =+        [ Op $ CDR noAnn noAnn+        , Op $ NIL noAnn noAnn $ Type TOperation noAnn+        , Op $ PAIR noAnn noAnn noAnn noAnn+        ]+      }++contractAux2 :: ContractAux+contractAux2 = contractAux1+  { caContract = (caContract contractAux1)+    { code =+      [ Op $ CDR noAnn noAnn+      , Op $ NOT noAnn+      , Op $ NIL noAnn noAnn $ Type TOperation noAnn+      , Op $ PAIR noAnn noAnn noAnn noAnn+      ]+    }+  }
+ test/Test/Parser.hs view
@@ -0,0 +1,151 @@+module Test.Parser+  ( spec+  ) where++import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy)+import Text.Megaparsec (parse)++import Morley.Parser as P+import Morley.Types as Mo++import Test.Util.Contracts (getIllTypedContracts, getWellTypedContracts)++spec :: Spec+spec = describe "Parser tests" $ do+  it "Successfully parses contracts examples from contracts/" parseContractsTest+  it "Test stringLiteral" stringLiteralTest+  it "IF parsers test" ifParsersTest+  it "MAP parsers test" mapParsersTest+  it "PAIR parsers test" pairParsersTest+  it "pair type parser test" pairTypeParserTest+  it "or type parser test" orTypeParserTest+  it "lambda type parser test" lambdaTypeParserTest+  it "list type parser test" listTypeParserTest+  it "set type parser test" setTypeParserTest+  it "pair constructor test" pairTest+  it "value parser test" valueParserTest+  it "printComment parser test" printCommentParserTest++parseContractsTest :: Expectation+parseContractsTest = do+  files <- mappend <$> getWellTypedContracts <*> getIllTypedContracts+  mapM_ checkFile files++checkFile :: FilePath -> Expectation+checkFile file = do+  code <- readFile file+  parse P.program file code `shouldSatisfy` isRight++valueParserTest :: Expectation+valueParserTest = do+  P.parseNoEnv P.value "" "{PUSH int 5;}" `shouldBe`+    (Right $ Mo.ValueLambda [Mo.PRIM (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5))])+  P.parseNoEnv P.value "" "{1; 2}" `shouldBe`+    (Right $ Mo.ValueSeq [Mo.ValueInt 1, Mo.ValueInt 2])+  P.parseNoEnv P.value "" "{Elt 1 2; Elt 3 4}" `shouldBe`+    (Right $ Mo.ValueMap [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)])++stringLiteralTest :: Expectation+stringLiteralTest = do+  P.parseNoEnv P.stringLiteral "" "\"\"" `shouldSatisfy` isRight+  P.parseNoEnv P.stringLiteral "" "\" \\t \\b \\n\\r  \"" `shouldSatisfy` isRight+  P.parseNoEnv P.stringLiteral "" "\"abacaba \\t \n\n\r\"" `shouldSatisfy` isRight+  P.parseNoEnv P.stringLiteral "" "\"abacaba \\t \n\n\r a\"" `shouldSatisfy` isLeft+  P.parseNoEnv P.stringLiteral "" "\"abacaba \\t \\n\\n\\r" `shouldSatisfy` isLeft++ifParsersTest :: Expectation+ifParsersTest = do+  P.parseNoEnv P.ops "" "{IF {} {};}" `shouldBe`+    (Prelude.Right [Mo.PRIM $ Mo.IF [] []])+  P.parseNoEnv P.ops "" "{IFEQ {} {};}" `shouldBe`+    (Prelude.Right [Mo.MAC $ Mo.IFX (Mo.EQ noAnn) [] []])+  P.parseNoEnv P.ops "" "{IFCMPEQ {} {};}" `shouldBe`+    (Prelude.Right [Mo.MAC $ Mo.IFCMP (Mo.EQ noAnn) noAnn [] []])++mapParsersTest :: Expectation+mapParsersTest = do+  parseNoEnv P.ops "" "{MAP {};}" `shouldBe`+    (Prelude.Right [Mo.PRIM $ Mo.MAP noAnn []])+  parseNoEnv P.ops "" "{MAP_CAR {};}" `shouldBe`+    (Prelude.Right [Mo.MAC $ Mo.MAP_CADR [Mo.A] noAnn noAnn []])++pairParsersTest :: Expectation+pairParsersTest = do+  P.parseNoEnv P.ops "" "{PAIR;}" `shouldBe`+    Prelude.Right [Mo.PRIM $ PAIR noAnn noAnn noAnn noAnn]+  P.parseNoEnv P.ops "" "{PAIR %a;}" `shouldBe`+    Prelude.Right [MAC $ PAPAIR (P (F (noAnn, Mo.ann "a")) (F (noAnn,noAnn))) noAnn noAnn]+  P.parseNoEnv P.ops "" "{PAPAIR;}" `shouldBe`+    Prelude.Right+      [MAC $+        PAPAIR (P (F (noAnn,noAnn)) (P (F (noAnn,noAnn)) (F (noAnn,noAnn))))+          noAnn noAnn+      ]++pairTypeParserTest :: Expectation+pairTypeParserTest = do+  P.parseNoEnv P.type_ "" "pair unit unit" `shouldBe` Right unitPair+  P.parseNoEnv P.type_ "" "(unit, unit)" `shouldBe` Right unitPair+  where+    unitPair :: Mo.Type+    unitPair =+      Mo.Type (Mo.TPair noAnn noAnn (Mo.Type Mo.TUnit noAnn) (Mo.Type Mo.TUnit noAnn)) noAnn++orTypeParserTest :: Expectation+orTypeParserTest = do+  P.parseNoEnv P.type_ "" "or unit unit" `shouldBe` Right unitOr+  P.parseNoEnv P.type_ "" "(unit | unit)" `shouldBe` Right unitOr+  where+    unitOr :: Mo.Type+    unitOr =+      Mo.Type (Mo.TOr noAnn noAnn (Mo.Type Mo.TUnit noAnn) (Mo.Type Mo.TUnit noAnn)) noAnn++lambdaTypeParserTest :: Expectation+lambdaTypeParserTest = do+  P.parseNoEnv P.type_ "" "lambda unit unit" `shouldBe` Right lambdaUnitUnit+  P.parseNoEnv P.type_ "" "\\unit -> unit" `shouldBe` Right lambdaUnitUnit+  where+    lambdaUnitUnit :: Mo.Type+    lambdaUnitUnit =+      Mo.Type (Mo.TLambda (Mo.Type Mo.TUnit noAnn) (Mo.Type Mo.TUnit noAnn)) noAnn++listTypeParserTest :: Expectation+listTypeParserTest = do+  P.parseNoEnv P.type_ "" "list unit" `shouldBe` Right unitList+  P.parseNoEnv P.type_ "" "[unit]" `shouldBe` Right unitList+  where+    unitList :: Mo.Type+    unitList =+      Mo.Type (Mo.TList (Mo.Type Mo.TUnit noAnn)) noAnn++setTypeParserTest :: Expectation+setTypeParserTest = do+  P.parseNoEnv P.type_ "" "set int" `shouldBe` Right intSet+  P.parseNoEnv P.type_ "" "{int}" `shouldBe` Right intSet+  where+    intSet :: Mo.Type+    intSet =+      Mo.Type (Mo.TSet (Mo.Comparable Mo.CInt noAnn)) noAnn++pairTest :: Expectation+pairTest = do+  P.parseNoEnv P.value "" "Pair Unit Unit" `shouldBe` Right unitPair+  P.parseNoEnv P.value "" "(Unit, Unit)" `shouldBe` Right unitPair+  where+    unitPair :: Mo.Value Mo.ParsedOp+    unitPair = Mo.ValuePair Mo.ValueUnit Mo.ValueUnit++printCommentParserTest :: Expectation+printCommentParserTest = do+  P.parseNoEnv P.printComment "" "\"Sides are %[0] x %[1]\"" `shouldBe`+    Right (PrintComment [Left "Sides are ", Right (StackRef 0), Left " x ", Right (StackRef 1)])+  P.parseNoEnv P.printComment "" "\"%[0] x\"" `shouldBe`+    Right (PrintComment [Right (StackRef 0), Left " x"])+  P.parseNoEnv P.printComment "" "\"%[0]x%[1]\"" `shouldBe`+    Right (PrintComment [Right (StackRef 0), Left "x", Right (StackRef 1)])+  P.parseNoEnv P.printComment "" "\"%[0]%[1]\"" `shouldBe`+    Right (PrintComment [Right (StackRef 0), Right (StackRef 1)])+  P.parseNoEnv P.printComment "" "\"xxx\"" `shouldBe`+    Right (PrintComment [Left "xxx"])+  P.parseNoEnv P.printComment "" "\"\"" `shouldBe`+    Right (PrintComment [])
+ test/Test/Serialization/Aeson.hs view
@@ -0,0 +1,53 @@+module Test.Serialization.Aeson+  ( spec+  ) where++import Data.Aeson (FromJSON, ToJSON)+import Test.Aeson.GenericSpecs (roundtripADTSpecs, roundtripSpecs)+import Test.Hspec (Spec)+import Test.QuickCheck (Arbitrary)++import Michelson.Untyped (Contract, Elt, FieldAnn, InstrAbstract, Op, TypeAnn, Value, VarAnn)+import Tezos.Core (Mutez, Timestamp)++import Test.Arbitrary ()+import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary)++-- Note: if we want to enforce a particular JSON format, we can extend+-- these test with golden tests (it's easy with `hspec-golden-aeson`).++-- For types with one constructor and/or without 'ToADTArbitrary' instance.+test :: forall a.+  (Arbitrary a, ToJSON a, FromJSON a, Typeable a)+  => Proxy a+  -> Spec+test = roundtripSpecs++-- For types with 'ToADTArbitrary' instance.+testADT :: forall a.+  (Show a, Eq a, Arbitrary a, ToADTArbitrary a, ToJSON a, FromJSON a)+  => Proxy a+  -> Spec+testADT = roundtripADTSpecs++spec :: Spec+spec = do+  -- Core Tezos types+  test (Proxy @Timestamp)+  test (Proxy @Mutez)++  -- Michelson types+  testADT (Proxy @Op)++  -- these are actually all the same thing (Annotation a),+  -- where a is a phantom type,+  -- but let's test them in case they+  -- ever change for some reason+  test (Proxy @TypeAnn)+  test (Proxy @FieldAnn)+  test (Proxy @VarAnn)++  test (Proxy @(Contract Op))+  testADT (Proxy @(InstrAbstract Op))+  test (Proxy @(Value Op))+  test (Proxy @(Elt Op))
+ test/Test/Tezos/Address.hs view
@@ -0,0 +1,35 @@+-- | Tests for 'Tezos.Address'.++module Test.Tezos.Address+  ( spec+  ) where++import Test.Hspec (Spec, describe, it, shouldSatisfy)++import Tezos.Address (Address, formatAddress, parseAddress)++import Test.Util.QuickCheck (ShowThroughBuild(..), aesonRoundtrip, roundtripSpecSTB)++spec :: Spec+spec = describe "Tezos.Address" $ do+  describe "parseAddress" $ do+    it "Successfully parses valid sample data" $+      forM_ sampleAddresses (\a -> bimap STB STB (parseAddress a) `shouldSatisfy` isRight)+    it "Fails to parse invalid data" $ do+      forM_ invalidAddresses (\a -> bimap STB STB (parseAddress a) `shouldSatisfy` isLeft)+    describe "Formatting" $ do+      describe "Roundtrip (parse . format ≡ pure)" $ do+        roundtripSpecSTB formatAddress parseAddress+      describe "Roundtrip (JSON encoding/deconding)" $ do+        aesonRoundtrip @Address+  where+    sampleAddresses =+      [ "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"+      , "KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE45"+      ]+    invalidAddresses =+      [ ""+      , "1"+      , "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUZU"+      , "KT1G4hcQj2STN86GwC1XAkPtwPPhgfPKuE46"+      ]
+ test/Test/Tezos/Crypto.hs view
@@ -0,0 +1,171 @@+-- | Tests for 'Tezos.Crypto'.++module Test.Tezos.Crypto+  ( spec+  ) where++import Fmt (fmt, hexF, pretty)+import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy)++import Tezos.Crypto++import Test.Util.QuickCheck (aesonRoundtrip, roundtripSpecSTB)++spec :: Spec+spec = describe "Tezos.Crypto" $ do+  describe "Signing" $ do+    describe "Formatting" $ do+      describe "parsePublicKey" $ do+        it "Successfully parses valid sample data" $+          mapM_ (parsePublicKeySample . sdPublicKey) sampleSignatures+        it "Fails to parse invalid data" $ do+          parsePublicKeyInvalid "aaa"+          parsePublicKeyInvalid+            "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3v"+          parsePublicKeyInvalid+            "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb"+      describe "parseSignature" $ do+        it "Successfully parses valid sample data" $+          mapM_ (parseSignatureSample . sdSignature) sampleSignatures+        it "Fails to parse invalid data" $ do+          parseSignatureInvalid "bbb"+          parseSignatureInvalid+            "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V"+          parseSignatureInvalid+            "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vB"+      describe "Roundtrip (parse . format ≡ pure)" $ do+        roundtripSpecSTB formatPublicKey parsePublicKey+        roundtripSpecSTB formatSecretKey parseSecretKey+        roundtripSpecSTB formatSignature parseSignature+        roundtripSpecSTB formatKeyHash parseKeyHash+      describe "Roundtrip (JSON encoding/deconding)" $ do+        aesonRoundtrip @PublicKey+        aesonRoundtrip @Signature+        aesonRoundtrip @KeyHash+    describe "checkSignature" $ do+      it "Works on sample data" $ mapM_ checkSignatureSample sampleSignatures+  describe "Bytes hashing" $ do+    hashingSpec "blake2b" blake2b blake2bHashes+    hashingSpec "sha256" sha256 sha256Hashes+    hashingSpec "sha512" sha512 sha512Hashes+  describe "Key hashing" $+    it "Works on sample data" $ mapM_ hashKeySample sampleKeyHashes++----------------------------------------------------------------------------+-- Signing+----------------------------------------------------------------------------++data SignatureData = SignatureData+  { sdPublicKey :: !Text+  , sdBytes :: !ByteString+  , sdSignature :: !Text+  , sdValid :: !Bool+  }++-- These signatures have been produced by `tezos-client`.+sampleSignatures :: [SignatureData]+sampleSignatures =+  [ SignatureData+    { sdPublicKey = "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V"+    , sdBytes = "\0"+    , sdSignature = "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb"+    , sdValid = True+    }+  , SignatureData+    { sdPublicKey = "edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH"+    , sdBytes = "\0\0"+    , sdSignature = "edsigtj8LhbJ2B3qhZvqzA49raG65dydFcWZW9b9L7ntF3bb29zxaBFFL8SM1jeBUY66hG122znyVA4wpzLdwxcNZwSK3Szu7iD"+    , sdValid = True+    }+  , SignatureData+    { sdPublicKey = "edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH"+    , sdBytes = "kot"+    , sdSignature = "edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb"+    , sdValid = False+    }+  ]++parsePublicKeySample :: Text -> Expectation+parsePublicKeySample publicKeyText =+  parsePublicKey publicKeyText `shouldSatisfy` isRight++parsePublicKeyInvalid :: Text -> Expectation+parsePublicKeyInvalid invalidPublicKeyText =+  parsePublicKey invalidPublicKeyText `shouldSatisfy` isLeft++parseSignatureSample :: Text -> Expectation+parseSignatureSample publicKeyText =+  parseSignature publicKeyText `shouldSatisfy` isRight++parseSignatureInvalid :: Text -> Expectation+parseSignatureInvalid invalidSignatureText =+  parseSignature invalidSignatureText `shouldSatisfy` isLeft++checkSignatureSample :: SignatureData -> Expectation+checkSignatureSample sd =+  checkSignature publicKey signature (sdBytes sd) `shouldBe` sdValid sd+  where+    publicKey = partialParse parsePublicKey (sdPublicKey sd)+    signature = partialParse parseSignature (sdSignature sd)++----------------------------------------------------------------------------+-- Hashing+----------------------------------------------------------------------------++-- These values have been computed using the following contract:+{-+parameter string;+storage bytes;+code { CDR; SHA512; # replace with desired function+       NIL operation; PAIR;};++-}++blake2bHashes, sha256Hashes, sha512Hashes :: [(ByteString, Text)]+blake2bHashes =+  [ ("\0", "03170a2e7597b7b7e3d84c05391d139a62b157e78786d8c082f29dcf4c111314")  -- 0x00+  , ("\0\0", "9ee6dfb61a2fb903df487c401663825643bb825d41695e63df8af6162ab145a6")  -- 0x0000+  ]+sha256Hashes =+  [ ("\0", "6e340b9cffb37a989ca544e6bb780a2c78901d3fb33738768511a30617afa01d")  -- 0x00+  , ("\0\0", "96a296d224f285c67bee93c30f8a309157f0daa35dc5b87e410b78630a09cfc7")  -- 0x0000+  ]+sha512Hashes =+  [ ("\0", "b8244d028981d693af7b456af8efa4cad63d282e19ff14942c246e50d9351d22704a802a71c3580b6370de4ceb293c324a8423342557d4e5c38438f0e36910ee")  -- 0x00+  , ("#", "d369286ac86b60fa920f6464d26becacd9f4c8bd885b783407cdcaa74fafd45a8b56b364b63f6256c3ceef26278a1c7799d4243a8149b5ede5ce1d890b5c7236")  -- 0x23+  ]++hashingSpec :: String -> (ByteString -> ByteString) -> [(ByteString, Text)] -> Spec+hashingSpec funcName hashFunc pairs = do+  describe funcName $ do+    forM_ pairs $ \(bs, bsHashHex) -> do+      it ("correctly computes hash of 0x" <> fmt (hexF bs)) $+        fmt (hexF (hashFunc bs)) `shouldBe` bsHashHex++----------------------------------------------------------------------------+-- Key hashing+----------------------------------------------------------------------------++sampleKeyHashes :: [(Text, Text)]+sampleKeyHashes =+  [ ("edpkupH22qrz1sNQt5HSvWfRJFfyJ9dhNbZLptE6GR4JbMoBcACZZH"+    , "tz1NaZzLvdDBLfV2LWC6F4SJfNV2jHdZJXkJ"+    )+  , ("edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V"+    , "tz1Yz3VPaCNB5FjhdEVnSoN8Xv3ZM8g2LYhw"+    )+  ]++hashKeySample :: (Text, Text) -> Expectation+hashKeySample (pkText, keyHashText) = hashKey pk `shouldBe` keyHash+  where+    pk = partialParse parsePublicKey pkText+    keyHash = partialParse parseKeyHash keyHashText++----------------------------------------------------------------------------+-- Utils+----------------------------------------------------------------------------++-- If passed textual data is invalid, it's a programmer mistake.+partialParse :: (Text -> Either CryptoParseError a) -> Text -> a+partialParse parse = either (error . pretty) id . parse
+ test/Test/Typecheck.hs view
@@ -0,0 +1,39 @@+module Test.Typecheck+  ( typeCheckSpec+  ) where++import Test.Hspec (Expectation, Spec, describe, expectationFailure, it)++import Michelson.Untyped (Contract(..), Op(..))+import Morley.Ext (typeCheckMorleyContract)+import Morley.Runtime (prepareContract)++import Test.Util.Contracts (getIllTypedContracts, getWellTypedContracts)++typeCheckSpec :: Spec+typeCheckSpec = describe "Typechecker tests" $ do+  it "Successfully typechecks contracts examples from contracts/" goodContractsTest+  it "Reports errors on contracts examples from contracts/ill-typed" badContractsTest+  where+    doTC = either (Left . displayException) (\_ -> pure ()) .+            typeCheckMorleyContract . fmap unOp++    goodContractsTest = mapM_ (checkFile doTC True) =<< getWellTypedContracts++    badContractsTest = mapM_ (checkFile doTC False) =<< getIllTypedContracts+++checkFile :: (Contract Op -> Either String ()) -> Bool -> FilePath -> Expectation+checkFile doTypeCheck wellTyped file = do+  c <- prepareContract (Just file)+  case doTypeCheck c of+    Left err+      | wellTyped ->+        expectationFailure $+        "Typechecker unexpectedly failed on " <> show file <> ": " <> err+      | otherwise -> pass+    Right _+      | not wellTyped ->+        expectationFailure $+        "Typechecker unexpectedly considered " <> show file <> " well-typed."+      | otherwise -> pass
+ test/Test/Util/Contracts.hs view
@@ -0,0 +1,25 @@+-- | Utility functions to read sample contracts (for testing).++module Test.Util.Contracts+       ( getIllTypedContracts+       , getWellTypedContracts+       ) where++import Data.List (isSuffixOf)+import System.Directory (listDirectory)+import System.FilePath ((</>))++getIllTypedContracts :: IO [FilePath]+getIllTypedContracts = getContracts "contracts/ill-typed"++getWellTypedContracts :: IO [FilePath]+getWellTypedContracts = getContracts "contracts"++getContracts :: FilePath -> IO [FilePath]+getContracts dir = mapMaybe convertPath <$> listDirectory dir+  where+    convertPath :: FilePath -> Maybe FilePath+    convertPath fileName+      | (isSuffixOf ".tz" fileName) || (isSuffixOf ".mtz" fileName) =+        Just (dir </> fileName)+      | otherwise = Nothing
+ test/Test/Util/QuickCheck.hs view
@@ -0,0 +1,115 @@+{-+Copyright (c) 2017 IOHK++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+-}++-- | Testing utilities to be used with QuickCheck++module Test.Util.QuickCheck+  ( ShowThroughBuild (..)++  -- * Roundtrip properties+  , roundtripSpec+  , roundtripSpecSTB+  , aesonRoundtrip++  -- * 'Gen' helpers+  , runGen+  ) where++import Data.Aeson (FromJSON(..), ToJSON(..))+import qualified Data.Aeson as Aeson+import Data.Typeable (typeRep)+import Fmt (Buildable, pretty)+import Test.Hspec (Spec)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary, Property, (===))+import Test.QuickCheck.Gen (Gen, unGen)+import Test.QuickCheck.Random (mkQCGen)+import qualified Text.Show (show)++----------------------------------------------------------------------------+-- 'Show'ing a value though 'Buildable' type class.+-- Useful because QuickCheck uses 'Show'.+----------------------------------------------------------------------------++newtype ShowThroughBuild a = STB+  { unSTB :: a+  } deriving (Eq, Ord, Arbitrary)++instance {-# OVERLAPPABLE #-} Buildable a => Show (ShowThroughBuild a) where+  show = pretty . unSTB++instance Show (ShowThroughBuild ByteString) where+  show = show . unSTB++----------------------------------------------------------------------------+-- Formatting+----------------------------------------------------------------------------++-- | This 'Spec' contains a property based test for conversion from+-- some @x@ to some @y@ and back to @x@ (it should successfully return+-- the initial @x@).+roundtripSpec ::+     forall x y err.+     ( Show x+     , Typeable x+     , Arbitrary x+     , Eq x+     , Show err+     , Eq err+     )+  => (x -> y)+  -> (y -> Either err x)+  -> Spec+roundtripSpec xToY yToX = prop typeName check+  where+    typeName = show $ typeRep (Proxy @x)+    check :: x -> Property+    check x = yToX (xToY x) === Right x++-- | Version of 'roundtripSpec' which shows values using 'Buildable' instance.+roundtripSpecSTB ::+     forall x y err.+     ( Show (ShowThroughBuild x)+     , Typeable x+     , Arbitrary x+     , Eq x+     , Show (ShowThroughBuild err)+     , Eq err+     )+  => (x -> y)+  -> (y -> Either err x)+  -> Spec+roundtripSpecSTB xToY yToX = roundtripSpec (xToY . unSTB) (bimap STB STB . yToX)++aesonRoundtrip ::+     forall x. (Show (ShowThroughBuild x), ToJSON x, FromJSON x, Typeable x, Arbitrary x, Eq x)+  => Spec+aesonRoundtrip = roundtripSpecSTB (Aeson.encode @x) Aeson.eitherDecode++----------------------------------------------------------------------------+-- Gen+----------------------------------------------------------------------------++-- | Get something out of a quickcheck 'Gen' without having to do IO+runGen :: Gen a -> a+runGen g = unGen g (mkQCGen 31415926) 30
+ test/Test/ValConversion.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Testing of toVal / fromVal conversions++module Test.ValConversion+  ( spec+  ) where++import Test.Hspec (Spec, describe, it, shouldBe)+import Test.QuickCheck (Arbitrary)++import Michelson.Typed (CVal(..), FromVal, ToT, ToVal, Val(..), fromVal, toVal)++import Test.Util.QuickCheck (roundtripSpec)++-- | Spec to test toVal / fromVal conversions.+spec :: Spec+spec = do+  describe "ToVal / FromVal tests" $ do+    it "ToVal / FromVal manual tests" $ do+      check () $ (\case VUnit -> True;)+      check (10 :: Integer) $ (\case (VC (CvInt 10)) -> True; _ -> False)+      check ("abc" :: Text) $ (\case (VC (CvString "abc")) -> True; _ -> False)+      check (Just "abc" :: Maybe Text)+          $ (\case (VOption (Just (VC (CvString "abc")))) -> True; _ -> False)+      check (Left "abc" :: Either Text Text)+          $ (\case (VOr (Left (VC (CvString "abc")))) -> True; _ -> False)+      check (Left "abc" :: Either Text Integer)+          $ (\case (VOr (Left (VC (CvString "abc")))) -> True; _ -> False)+      check ((10, "abc") :: (Integer, Text))+          $ (\case (VPair (VC (CvInt 10), VC (CvString "abc"))) -> True; _ -> False)+      check (["abc", "cde"] :: [Text])+          $ (\case (VList [ VC (CvString "abc")+                          , VC (CvString "cde")]) -> True; _ -> False)++    describe "ToVal / FromVal property tests" $ do+      roundtrip @Integer+      roundtrip @Bool+      roundtrip @[Bool]+      roundtrip @(Maybe Integer)+      roundtrip @(Maybe (Maybe Integer))+      roundtrip @(Either Bool Integer)+      roundtrip @(Set Integer)+      roundtrip @(Set Integer)+      roundtrip @(Set Bool)+      roundtrip @(Map Integer Integer)+      roundtrip @(Map Integer Bool)+      roundtrip @(Map Integer (Maybe (Either Bool Bool)))+  where+    check :: ToVal a => a -> (Val instr (ToT a) -> Bool) -> IO ()+    check v p = p (toVal v) `shouldBe` True++    roundtrip :: forall a.+      (Show a, Eq a, Arbitrary a, Typeable a, ToVal a, FromVal a) => Spec+    roundtrip = roundtripSpec @a @_ @Void toVal (Right . fromVal)