diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
new file mode 100644
--- /dev/null
+++ b/CONTRIBUTING.md
@@ -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.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,662 @@
+ GNU AFFERO GENERAL PUBLIC LICENSE
+ Version 3, 19 November 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU 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.
+
+
+ Copyright (C)
+
+ 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 .
+
+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
+.
+
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/Main.hs
@@ -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
diff --git a/morley.cabal b/morley.cabal
new file mode 100644
--- /dev/null
+++ b/morley.cabal
@@ -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
diff --git a/src/Michelson/EqParam.hs b/src/Michelson/EqParam.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/EqParam.hs
@@ -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)
diff --git a/src/Michelson/Interpret.hs b/src/Michelson/Interpret.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Interpret.hs
@@ -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 -> ""
+ 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
diff --git a/src/Michelson/TypeCheck.hs b/src/Michelson/TypeCheck.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/TypeCheck.hs
@@ -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')
diff --git a/src/Michelson/TypeCheck/Helpers.hs b/src/Michelson/TypeCheck/Helpers.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/TypeCheck/Helpers.hs
@@ -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)
diff --git a/src/Michelson/TypeCheck/Instr.hs b/src/Michelson/TypeCheck/Instr.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/TypeCheck/Instr.hs
@@ -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
diff --git a/src/Michelson/TypeCheck/Types.hs b/src/Michelson/TypeCheck/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/TypeCheck/Types.hs
@@ -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
diff --git a/src/Michelson/TypeCheck/Value.hs b/src/Michelson/TypeCheck/Value.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/TypeCheck/Value.hs
@@ -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')
diff --git a/src/Michelson/Typed.hs b/src/Michelson/Typed.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
diff --git a/src/Michelson/Typed/Annotation.hs b/src/Michelson/Typed/Annotation.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/Annotation.hs
@@ -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
diff --git a/src/Michelson/Typed/Arith.hs b/src/Michelson/Typed/Arith.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/Arith.hs
@@ -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
diff --git a/src/Michelson/Typed/CValue.hs b/src/Michelson/Typed/CValue.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/CValue.hs
@@ -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
diff --git a/src/Michelson/Typed/Convert.hs b/src/Michelson/Typed/Convert.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/Convert.hs
@@ -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
diff --git a/src/Michelson/Typed/Extract.hs b/src/Michelson/Typed/Extract.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/Extract.hs
@@ -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)
diff --git a/src/Michelson/Typed/Instr.hs b/src/Michelson/Typed/Instr.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/Instr.hs
@@ -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)
diff --git a/src/Michelson/Typed/Polymorphic.hs b/src/Michelson/Typed/Polymorphic.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/Polymorphic.hs
@@ -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)
diff --git a/src/Michelson/Typed/Sing.hs b/src/Michelson/Typed/Sing.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/Sing.hs
@@ -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
diff --git a/src/Michelson/Typed/T.hs b/src/Michelson/Typed/T.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/T.hs
@@ -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
diff --git a/src/Michelson/Typed/Value.hs b/src/Michelson/Typed/Value.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/Value.hs
@@ -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
diff --git a/src/Michelson/Untyped.hs b/src/Michelson/Untyped.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Untyped.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF autoexporter #-}
diff --git a/src/Michelson/Untyped/Annotation.hs b/src/Michelson/Untyped/Annotation.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Untyped/Annotation.hs
@@ -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
diff --git a/src/Michelson/Untyped/Contract.hs b/src/Michelson/Untyped/Contract.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Untyped/Contract.hs
@@ -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
diff --git a/src/Michelson/Untyped/Instr.hs b/src/Michelson/Untyped/Instr.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Untyped/Instr.hs
@@ -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
diff --git a/src/Michelson/Untyped/Type.hs b/src/Michelson/Untyped/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Untyped/Type.hs
@@ -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
diff --git a/src/Michelson/Untyped/Value.hs b/src/Michelson/Untyped/Value.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Untyped/Value.hs
@@ -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
diff --git a/src/Morley/Aliases.hs b/src/Morley/Aliases.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Aliases.hs
@@ -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
diff --git a/src/Morley/Default.hs b/src/Morley/Default.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Default.hs
@@ -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
diff --git a/src/Morley/Ext.hs b/src/Morley/Ext.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Ext.hs
@@ -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
diff --git a/src/Morley/Lexer.hs b/src/Morley/Lexer.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Lexer.hs
@@ -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 ","
diff --git a/src/Morley/Macro.hs b/src/Morley/Macro.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Macro.hs
@@ -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), [])
diff --git a/src/Morley/Parser.hs b/src/Morley/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Parser.hs
@@ -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
diff --git a/src/Morley/Parser/Annotations.hs b/src/Morley/Parser/Annotations.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Parser/Annotations.hs
@@ -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
diff --git a/src/Morley/Runtime.hs b/src/Morley/Runtime.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Runtime.hs
@@ -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 "" 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)
diff --git a/src/Morley/Runtime/GState.hs b/src/Morley/Runtime/GState.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Runtime/GState.hs
@@ -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
diff --git a/src/Morley/Runtime/TxData.hs b/src/Morley/Runtime/TxData.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Runtime/TxData.hs
@@ -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
diff --git a/src/Morley/Test.hs b/src/Morley/Test.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Test.hs
@@ -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 #-}
diff --git a/src/Morley/Test/Dummy.hs b/src/Morley/Test/Dummy.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Test/Dummy.hs
@@ -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
+ }
diff --git a/src/Morley/Test/Gen.hs b/src/Morley/Test/Gen.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Test/Gen.hs
@@ -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)
diff --git a/src/Morley/Test/Import.hs b/src/Morley/Test/Import.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Test/Import.hs
@@ -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
diff --git a/src/Morley/Test/Integrational.hs b/src/Morley/Test/Integrational.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Test/Integrational.hs
@@ -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
diff --git a/src/Morley/Test/Unit.hs b/src/Morley/Test/Unit.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Test/Unit.hs
@@ -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
diff --git a/src/Morley/Test/Util.hs b/src/Morley/Test/Util.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Test/Util.hs
@@ -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 <> ")"
diff --git a/src/Morley/Types.hs b/src/Morley/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Types.hs
@@ -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
diff --git a/src/Tezos/Address.hs b/src/Tezos/Address.hs
new file mode 100644
--- /dev/null
+++ b/src/Tezos/Address.hs
@@ -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
diff --git a/src/Tezos/Core.hs b/src/Tezos/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Tezos/Core.hs
@@ -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
diff --git a/src/Tezos/Crypto.hs b/src/Tezos/Crypto.hs
new file mode 100644
--- /dev/null
+++ b/src/Tezos/Crypto.hs
@@ -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)
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -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
diff --git a/test/Test/Arbitrary.hs b/test/Test/Arbitrary.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Arbitrary.hs
@@ -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
diff --git a/test/Test/CValConversion.hs b/test/Test/CValConversion.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/CValConversion.hs
@@ -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
diff --git a/test/Test/Ext.hs b/test/Test/Ext.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Ext.hs
@@ -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
diff --git a/test/Test/Interpreter.hs b/test/Test/Interpreter.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Interpreter.hs
@@ -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
diff --git a/test/Test/Interpreter/Auction.hs b/test/Test/Interpreter/Auction.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Interpreter/Auction.hs
@@ -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
diff --git a/test/Test/Interpreter/CallSelf.hs b/test/Test/Interpreter/CallSelf.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Interpreter/CallSelf.hs
@@ -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
diff --git a/test/Test/Interpreter/Compare.hs b/test/Test/Interpreter/Compare.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Interpreter/Compare.hs
@@ -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."
diff --git a/test/Test/Interpreter/Conditionals.hs b/test/Test/Interpreter/Conditionals.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Interpreter/Conditionals.hs
@@ -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
diff --git a/test/Test/Interpreter/StringCaller.hs b/test/Test/Interpreter/StringCaller.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Interpreter/StringCaller.hs
@@ -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
diff --git a/test/Test/Macro.hs b/test/Test/Macro.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Macro.hs
@@ -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}
+ ]
diff --git a/test/Test/Morley/Runtime.hs b/test/Test/Morley/Runtime.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Morley/Runtime.hs
@@ -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
+ ]
+ }
+ }
diff --git a/test/Test/Parser.hs b/test/Test/Parser.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Parser.hs
@@ -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 [])
diff --git a/test/Test/Serialization/Aeson.hs b/test/Test/Serialization/Aeson.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Serialization/Aeson.hs
@@ -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))
diff --git a/test/Test/Tezos/Address.hs b/test/Test/Tezos/Address.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Tezos/Address.hs
@@ -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"
+ ]
diff --git a/test/Test/Tezos/Crypto.hs b/test/Test/Tezos/Crypto.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Tezos/Crypto.hs
@@ -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
diff --git a/test/Test/Typecheck.hs b/test/Test/Typecheck.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Typecheck.hs
@@ -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
diff --git a/test/Test/Util/Contracts.hs b/test/Test/Util/Contracts.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Util/Contracts.hs
@@ -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
diff --git a/test/Test/Util/QuickCheck.hs b/test/Test/Util/QuickCheck.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Util/QuickCheck.hs
@@ -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
diff --git a/test/Test/ValConversion.hs b/test/Test/ValConversion.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/ValConversion.hs
@@ -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)