diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,283 @@ +1.0.0 [202x.xx.xx] +------------------ + +The first stable. It will be a product that I expect other people to use for +important projects, therefore backwards compatibility will be important. The +whole system needs extensive testing in real applications. Much of this will be +done in the development of the core libraries. We will also need to add +handling for several very different languages (proofs-of-concept). + + - [ ] typeclasses + - [ ] semantic types - test in bioinformatics applications + - [ ] constraints - refined types? + - [ ] manifold hooks - caching, documentation, logging, effects + - [ ] logic engine (z3?) - from typechecking to architecture design and debugging + - [ ] ecosystem (test suite, linter, package tools, vim plugin) + - [ ] language support (Python3, R, C++, Java, Haskell, Scheme, Prolog) + - [ ] well tested core libraries + +0.34.0 [202x.xx.xx] +------------------- + + - [ ] Remove extra space printed at the end of R JSON + - [ ] Remove semicolon requirement + +0.33.0 [2020.11.03] +------------------- + +First hackage release + + * Haddock documentation + * Update README + * In help statements write universal, not concrete, types + * Make default containers non-existential (probably a bad decision?) + +0.32.0 [2020.11.01] +------------------- + + * Add record/table field access + * Fix JSON handling in nexus + * Fix nexus bug necessitated escaping quotations and braces + * Print general types in nexus help + * Resolve most GHC warnings + +0.31.0 [2020.10.29] +------------------- + + * Fix anonymous records in C++ + * Distinguish 'record', 'object', and 'table' + * Add object handling + * Add table handling + +0.30.0 [2020.10.23] +------------------- + + * Add `object` keyword for defining record types + * Add full record serialization handling (C++, py, R) + +0.29.0 [2020.10.21] +------------------- + + * Add AST directed (de)serialization framework + * Add type constructors for parameterized types + +0.28.0 [2020.10.12] +------------------- + + * Allow import/export of type aliases + * Refactor with DAGs all through the parser and typechecker + +0.27.0 [2020.10.04] +------------------- + + * Add systematic tests for data serialization + * Fix bug in C++ serialization + * Move to serialize to dedicated libraries that require no import + +0.26.0 [2020.09.27] +------------------- + +Add `type` keyword for defining type aliases + +0.25.0 [2020.09.26] +------------------- + +No explicit forall. Instead use Haskell convention of generics being lowercase +and non-generics being uppercase. + + * no more explicit "forall" + * generics are lowercase in type signatures + * non-generic types are uppercase + * normal functions are lowercase + * class constructors are uppercase (though handling for this is not yet implemented) + +0.24.0 [2020.09.22] +------------------- + +Allow integration of many instances + +0.23.0 [2020.05.14] + +Bug fixes and code cleanup + +Bug fixes / tests + - [x] [x] github issue #7 - new Var=> typechecking rule + - [x] [x] github issue #9 - rewire container type inference + - [x] [x] github issue #10 + - [x] [x] github issue #11 + + +0.22.0 [2020.04.28] +------------------- + +Implement a schema-directed composable serialization system + +Major changes + * Fully composable serialization over containers and primitives + * Improved C++ support of generic functions + * Record support for R and Python3 (not C++ yet) + * Refactor generator - replace old grammar system + * Allow arguments to be passed to general functions + (e.g., `foo x = [x]`, where no specific language is needed) + +Minor changes + * change default python3 interpreter from "python" to "python3" + * add default library and tmp paths to config handler + * test composable serialization functions in all supported languages + * allow wrapped comments in R + +Testing - grammar directed testing + * test record handling + * remove and replace out-of-date golden tests + * systematic argument handling tests + * systematic manifold form tests + * systematic interop testing + +0.21.0 [2020.03.31] +------------------- + +Major - add handling and test for many many corner cases + * Allow export of data statements + * Allow export of non-functions + * Allow functions with containers at the root + * Allow export of 0-argument functions + +Minor + * proof-of-concept composable serialization functions in C++ (cppbase) + * add python tests + * make the test output look pretty (no weird whitespace) + +0.20.0 [2020.03.23] +------------------- + + * Add composable default types + +0.19.1 [2020.02.22] +------------------- + + * bug fixes + +0.19.0 [2020.02.20] +------------------- + +Major changes + * Allow currying + * Add realization optimizations + * Refactor generator into series of clear transformations + * Added handling for dealing with ambiguous ASTs + +Minor bug fixes and updates + * Prettier code generation for C++, Python and R + * More detailed comments in generated code + * Allow tags on parenthesized types + * Fix bug in functions with multiple parameters + * Fix bug preventing loading of package metadata + +0.18.1 [2019.11.08] +------------------- + + * Fix travis + * Use C++11 for C++ builds + * Make .morloc/config optional + * Fix bug in parsing unit type: `()` + +0.18.0 [2019.11.04] +------------------- + + * Add bidirectional type system + * Allow parameterized concrete types + * Allow higher-order functions + * Allow properties to contain multiple terms + * Add many tests + * Add module system + * Allow non-primitive types in lists, tuples, and records + * Removed arq and SPARQL dependency (very fast compilation) + +0.17.4 [2019.06.29] +------------------- + + * Add C and C++ handling + * Define Ord intance for MTypeMeta + * Allow pools to be called as executables + * Add type handling to generators + * Remove redundant SPARQL queries (better performance) + * New RDF list semantics + * Use strings to represent concrete types (e.g. "char\*") + * Write pretty-printed diagnostic files to `$MORLOC_HOME/tmp` + * Handling for multiple concrete type signatures (e.g., definition of + a function in multiple languages). + * Handling for multiple abstract type signatures + * Handling for multiple function declarations + +0.17.3 [2019.06.14] +------------------- + + * Partial C support + - execution of sourced functions + - no composition + - no foreign calls + + * Partial transition to typed generators + - bound arguments are still not typed correctly + + * Use integer IDs to identify manifolds in pools and the nexus (can to make + calls between them) instead of long, mangled names. + + * Replace string names of languages (e.g., "python") with a sum type. + +0.17.2 [2019.05.05] +------------------- + + Pycon release + +0.17.1 [2019.04.26] +------------------- + + * Fix output serialization in generate code + * Fix module linking in generated code + +0.17.0 [2019.04.16] +------------------- + + * Add morloc home + * Load modules from `$MORLOCHOME/lib` + * Create monad stack + +0.16.2 [2018.03.05] +------------------- + + * Add Zenodo badge making the project citable + * Move to `morloc-project/morloc` github repo + +0.16.1 [2018.09.24] +------------------- + +Minor release consisting of internal refactoring + + * Pruned unnecessary code + * Pruned unnecessary imports + * Compliance with stricter compile flags + +0.16.0 [2018.09.14] +------------------- + + * Write RDF bools in lowercase ("true", rather than "True"), as per specs + * Stricter node typing (replace ad hoc names with elements from an ADT) + * Add very rudimentary typechecking + * Remove SPARQL server dependency (now there's a sluggish Jena dependency) + +0.15.1 [2018.09.10] +------------------- + + * Add error handling and reporting to pools + * Add type signature comments to generated pools + * Richer internal data structures + +0.15.0 [2018.09.05] +------------------- + + * Generalize code generators using grammar records + * Add Python compatibility + * Replace unit tests with golden tests + * Use docopt and USAGE template for argument handling + * Report number of arguments in nexus usage statements diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + {one line to give the program's name and a brief idea of what it does.} + Copyright (C) {year} {name of author} + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + {project} Copyright (C) {year} {fullname} + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,283 @@ +[![experimental](http://badges.github.io/stability-badges/dist/experimental.svg)](http://github.com/badges/stability-badges) +[![travis build status](https://travis-ci.org/morloc-project/morloc.svg?branch=master)](https://travis-ci.org/morloc-project/morloc) +[![github release](https://img.shields.io/github/release/morloc-project/morloc.svg?label=current+release)](https://github.com/morloc-project/morloc/releases) +[![license: GPL v3](https://img.shields.io/badge/License-GPL%20v3-blue.svg)](https://www.gnu.org/licenses/gpl-3.0) +[![DOI](https://zenodo.org/badge/75355860.svg)](https://zenodo.org/badge/latestdoi/75355860) + +`morloc` is a functional programming language where functions are imported from +foreign languages and unified under a common type system. The compiler +generates the code needed to compose functions across languages and also to +direct automation of mundane tasks such as data validation, type/format +conversions, data caching, distributed computing, and file reading/writing. The +endgame is to develop `morloc` into a query language that returns optimized +programs from an infinite library of functions and compositions of functions. + +See [the manual](https://morloc-project.github.io/docs) for more information. + +If you want to get straight to playing with code, go through the steps in the +installation section and then go to the project in `demo/01_sequence_analysis`. + +## Status + +This project is under active development with no stability guarantees until the +v1.0 release. Pull requests, issue reports, and private messages are very +welcome. + +## Installation + +Compile and install the package (requires the Haskell utility `stack`): + +```sh +git clone https://github.com/morloc-project/morloc +cd morloc +stack install --fast +``` + +`morloc` also depends on the `JSON::XS` perl module from CPAN, which can be +installed as follows: + +```sh +export PERL_MM_USE_DEFAULT=1 +export PERL_CANARY_STABILITY_NOPROMPT=1 +sudo perl -MCPAN -e 'install JSON::XS' +``` + +For Python support, you need to download the `pymorlocinternals` library from +PyPi: + +```sh +pip install pymorlocinternals +# or on Mac: +pip3 install pymorlocinternals +``` + +For R support, you need to install the `rmorlocinternals` library from github, +in an R session, run: + +```sh +R> install.packages("devtools") +R> devtools::install_github("morloc-project/rmorlocinternals") +``` + +C++ support currently requires a GNU compiler that supports C++11. + +`morloc` modules can be installed from the `morloc` +[library](https://github.com/morloclib) with the commands such as: + +```sh +morloc install cppbase +morloc install pybase +morloc install rbase +morloc install math +``` + +The `morloc install` commands will install the modules in the +`$HOME/.morloc/lib` folder. + +Last of all, if you are working in vim, you can install `morloc` syntax highlighting as follows: + +``` sh +mkdir -p ~/.vim/syntax/ +mkdir -p ~/.vim/ftdetect/ +cp vim-syntax/loc.vim ~/.vim/syntax/ +echo 'au BufRead,BufNewFile *.loc set filetype=loc' > ~/.vim/ftdetect/loc.vim +``` + +## Getting Started + +``` +export hello +hello = "Hello World" +``` + +The "export" keyword exports the variable "hello" from the module. + +Paste this into a file (e.g. "hello.loc") and then it can be imported by other +`morloc` modules or directly compiled into a program where every exported term +is a subcommand. + +``` +morloc make hello.loc +``` + +This will generate a single file named "nexus.pl". The nexus is the executable +script that the user will interact with. For this simple example, it is the +only generated file. It is currently written in Perl. + +Calling "nexus.pl" with no arguemtns or with the `-h` flag, will print a help +message: + +``` +$ ./nexus.pl -h +The following commands are exported: + hello + return: Str +``` + +The `return: Str` phrases states that hello returns a string value. + +The command `hello` can be called as shown below: + +``` +$ ./nexus.pl hello +Hello World +``` + +## Composing C++ Functions + +The following code uses only C++ functions (`fold`, `map`, `add` and `mul`). + +``` +import cppbase (fold, map, add, mul) + +export square; +export sumOfSquares; + +square x = mul x x; + +sumOfSquares xs = fold add 0 (map square xs); +``` + +If this script is pasted into the file "example-1.loc", it can be compiled as +follows: + +```sh +morloc install cppbase +morloc make example-1.loc +``` + +The `install` command clones the `cppbase` repo from github +[repo](https://github.com/morloclib/cppbase) into the local directory +`~/.morloc/lib`. The `morloc make` command will generate a file named +`nexus.pl`, which is an executable interface to the exported functions. + +You can see typed usage information for the exported functions with the `-h` flag: + +```sh +$ ./nexus.pl -h +The following commands are exported: + square + param 1: Num + return: Num + sumOfSquares + param 1: [Num] + return: Num +``` + +Then you can call the exported functions (arguments are in JSON format): + +```sh +$ ./nexus.pl sumOfSquares '[1,2,3]' +14 +``` + +The `nexus.pl` executable dispatches the command to the compiled C++ program, +`pool-cpp.out`. + + +## Language interop + +`morloc` can compose functions across languages. For example: + +``` +import math (fibonacci); +import rbase (plotVectorPDF, ints2reals); + +export fibplot + +fibplot n = plotVectorPDF (ints2reals (fibonacci n)) "fibonacci-plot.pdf"; +``` + +The `fibplot` function calculates Fibonacci numbers using a C++ function and +plots it using an R function. The R function `plotPDF` is a perfectly normal R +function with no extra boilerplate: + +``` R +plotPDF <- function(x, filename){ + pdf(filename) + plot(x) + dev.off() +} +``` + + +## The Morloc Type System + +The first level of the `morloc` type system is basically System F extended +across languages. A given function will have a general type as well as a +specialized type for each language it is implemented in. + +The map function has the types + +``` +map :: (a -> b) -> [a] -> [b] +map Cpp :: (a -> b) -> "std::vector<$1>" a -> "std::vector<$1>" b +map Python3 :: (a -> b) -> list a -> list b +``` + +The general signature looks almost the same as the Haskell equivalent (except +that `morloc` universal quantification is currently explicit). The list type +constructors for C++ are very literally "type constructors" in that they are +used to create syntactically correct C++ type strings. If the type variable `a` +is inferred to be `int`, for example, then the C++ type `std::vector` will +be used in the generated code. The same occurs in the python type constructors +`list`, except here the same Python type is generated regardless of the type of +`a`. + +The following example is available in `examples/rmsWithTypes.loc`: + +``` +import cppbase (fold, map, add, mul) + +export square; +export sumOfSquares; + +square x = mul x x; + +sumOfSquares xs = fold add 0 (map square xs); +``` + +This example cannot be compiled since none of the functions are imported or +sourced, but it can be typechecked: + +``` +morloc typecheck examples/rmsWithTypes.loc +``` + +``` +add :: Num -> Num -> Num; +add Cpp :: double -> double -> double; + +mul :: Num -> Num -> Num; +mul Cpp :: double -> double -> double; + +fold :: (b -> a -> b) -> b -> [a] -> b; +fold Cpp :: (b -> a -> b) -> b -> "std::vector<$1>" a -> b; + +map :: (a -> b) -> [a] -> [b]; +map Cpp :: (a -> b) -> "std::vector<$1>" a + -> "std::vector<$1>" b; + +square x = mul x x; +sumOfSquares xs = fold add 0 (map square xs); +``` + +The typechecker associates each sub-expression of the program with a set of +types. The specific type information in `mul` is sufficient to infer concrete +types for every other C++ function in the program. The inferred C++ type of +`sumOfSquares` is + +``` +"std::vector<$1>" double -> double +``` + +The general type for this expression is also inferred as: + +``` +List Num -> Num +``` + +The concrete type of `mul` is currently written as a binary function of +doubles. Ideally this function should accept any numbers (e.g., an `int` and a +`double`). I intend to add this functionallity eventually, perhaps with a +Haskell-style typeclass system. diff --git a/executable/Main.hs b/executable/Main.hs new file mode 100644 --- /dev/null +++ b/executable/Main.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Control.Monad (when) +import Subcommands +import System.Console.Docopt +import qualified System.Environment as SE + +patterns :: Docopt +patterns = [docoptFile|USAGE|] + +getArgOrExit :: Arguments -> Option -> IO String +getArgOrExit = getArgOrExitWith patterns + +main :: IO () +main = do + args <- parseArgsOrExit patterns =<< SE.getArgs + config <- getConfig args + when (isPresent args (command "install")) (cmdInstall args config) + -- do the following if we are processing Morloc code + when (isPresent args (argument "script")) $ do + when (isPresent args (command "make")) (cmdMake args config) + when (isPresent args (command "typecheck")) $ cmdTypecheck args config diff --git a/executable/Subcommands.hs b/executable/Subcommands.hs new file mode 100644 --- /dev/null +++ b/executable/Subcommands.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Subcommands +Description : Morloc executable subcommands +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Subcommands + ( getConfig + , cmdInstall + , cmdMake + , cmdRemove + , cmdTypecheck + ) where + +import Morloc.Namespace +import System.Console.Docopt +import qualified Morloc as M +import qualified Morloc.Config as Config +import qualified Morloc.Data.Text as MT +import qualified Morloc.Module as Mod +import qualified Morloc.Monad as MM +import qualified Morloc.Frontend.API as F + +type Subcommand = Arguments -> Config.Config -> IO () + +getArgOrDie :: Arguments -> Option -> MT.Text +getArgOrDie args opt = + case getArg args opt of + Nothing -> error ("Invalid command: Expected option '" <> show opt) + (Just x) -> MT.pack x + +-- | read the global morloc config file or return a default one +getConfig :: Arguments -> IO Config.Config +getConfig args = do + let givenPath = getArg args (longOption "config") + let isVanilla = isPresent args (longOption "vanilla") + defaultPath <- Config.getDefaultConfigFilepath + let configPath = + if isVanilla + then Nothing + else case givenPath of + (Just f) -> Just . Path . MT.pack $ f + Nothing -> Just defaultPath + -- load the config file + Config.loadMorlocConfig configPath + +getVerbosity :: Arguments -> Int +getVerbosity args = + if isPresent args (longOption "verbose") + then 1 + else 0 + +-- | handle the code, either from a file or a raw string +readScript :: Arguments -> IO (Maybe Path, Code) +readScript args = do + let input = getArgOrDie args (argument "script") + if isPresent args (longOption "expression") + then do + let code = Code input + return (Nothing, code) + else do + let filename = Path input + code <- fmap Code $ MT.readFile (MT.unpack input) + return (Just filename, code) + +-- | install a module +cmdInstall :: Subcommand +cmdInstall args conf = + (MM.runMorlocMonad (getVerbosity args) conf cmdInstall') >>= MM.writeMorlocReturn + where + cmdInstall' = do + let name = getArgOrDie args (argument "name") + if isPresent args (longOption "github") + then Mod.installModule (Mod.GithubRepo name) + else Mod.installModule (Mod.CoreGithubRepo name) + +-- | remove a previously installed module (NOT YET IMPLEMENTED) +cmdRemove :: Subcommand +cmdRemove _ _ = do + putStrLn "not removing anything" + +-- | build a Morloc program, generating the nexus and pool files +cmdMake :: Subcommand +cmdMake args config = do + (path, code) <- readScript args + MM.runMorlocMonad (getVerbosity args) config (M.writeProgram path code) >>= + MM.writeMorlocReturn + +cmdTypecheck :: Subcommand +cmdTypecheck args config = do + let expr = getArgOrDie args (argument "script") + expr' <- + if isPresent args (longOption "expression") + then return expr + else MT.readFile (MT.unpack expr) + let base = + if isPresent args (longOption "expression") + then Nothing + else Just (Path expr) + let writer = + if isPresent args (longOption "raw") + then F.ugly + else F.cute + if isPresent args (longOption "type") + then print $ F.readType expr' + else MM.runMorlocMonad + (getVerbosity args) + config + (M.typecheck base (Code expr') >>= MM.liftIO . writer) >>= + MM.writeMorlocReturn diff --git a/library/Morloc.hs b/library/Morloc.hs new file mode 100644 --- /dev/null +++ b/library/Morloc.hs @@ -0,0 +1,41 @@ +module Morloc + ( writeProgram + , typecheck + ) where + +import Morloc.Namespace +import Morloc.Frontend.Namespace (TypedDag) + +import qualified Morloc.Frontend.API as F +import Morloc.Frontend.Desugar (desugar) +import Morloc.CodeGenerator.Generate (generate) +import Morloc.ProgramBuilder.Build (buildProgram) +import Morloc.Frontend.Treeify (treeify) + +typecheck :: Maybe Path -> Code -> MorlocMonad TypedDag +typecheck path code + -- Maybe Path -> Text -> [Module] + -- parse code into unannotated modules + = F.parse path code + -- [Module] -> [Module] + -- resolve type aliases and such + >>= desugar + -- [Module] -> [Module] + -- add type annotations to sub-expressions and raise type errors + >>= F.typecheck + +-- | Build a program as a local executable +writeProgram :: + Maybe Path -- ^ source code filename (for debugging messages) + -> Code -- ^ source code text + -> MorlocMonad () +writeProgram path code + = typecheck path code + -- [Module] -> SAnno GMeta Many [CType] + >>= treeify + -- [SAnno GMeta Many [CType]] -> (Script, [Script]) + -- translate mtree into nexus and pool source code + >>= generate + -- (Script, [Script]) -> IO () + -- write the code and compile as needed + >>= buildProgram diff --git a/library/Morloc/CodeGenerator/Generate.hs b/library/Morloc/CodeGenerator/Generate.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Generate.hs @@ -0,0 +1,1040 @@ +{-| +Module : Morloc.CodeGenerator.Generate +Description : Translate AST forests into target language source code +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental + +The single @generate@ function wraps the entire AST forest to source code +translation process. + +The input the @generate@ is of type @[SAnno GMeta Many [CType]]@. The @SAnno +GMeta Many [CType]@ elements each represent a single command exported from the +main function. The @GMeta@ type stores all general information about a given +"manifold" (a node in the function graph and all its wrappings). The term +@Many@ states that there may be one of more AST describing each expression. The +term @[CType]@ states that there may be multiple concrete, language-specific +types associated with any term. + +The @generate@ function converts the @SAnno GMeta Many [CType]@ types into +@SAnno GMeta One CType@ unambiguous ASTs. This step is an important +optimization step in the morloc build pipeline. Currently the compiler uses a +flat scoring matrix for the cost of interop between languages (e.g., 0 for C++ +to C++, 1000 for anything to R, 5 for R to R since there is a function call +cost, etc). Replacing this algorithm with an empirically parameterized +performance model is a major goal. + +Additional manipulations of the AST can reduce the number of required foreign +calls, (de)serialization calls, and duplicate computation. + +The @SAnno GMeta One CType@ expression is ultimately translated into a simple +@ExprM@ type that is then passed to a language-specific translator. + +-} + +module Morloc.CodeGenerator.Generate +( + generate +) where + +import Morloc.CodeGenerator.Namespace +import Morloc.CodeGenerator.Internal +import Morloc.Data.Doc +import Morloc.Pretty (prettyType) +import qualified Morloc.Config as MC +import qualified Morloc.Data.Text as MT +import qualified Morloc.Language as Lang +import qualified Morloc.Monad as MM +import Morloc.CodeGenerator.Grammars.Common +import qualified Morloc.CodeGenerator.Nexus as Nexus +import qualified Morloc.System as MS +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Morloc.CodeGenerator.Grammars.Translator.Cpp as Cpp +import qualified Morloc.CodeGenerator.Grammars.Translator.R as R +import qualified Morloc.CodeGenerator.Grammars.Translator.Python3 as Python3 + +-- | Translate typed, abstract syntax forests into compilable code +generate :: + [SAnno GMeta Many [CType]] + -- ^ one AST forest for each command exported from main + -> MorlocMonad (Script, [Script]) + -- ^ the nexus code and the source code for each language pool +generate ms = do + -- translate modules into bitrees + (gASTs, rASTs) + -- eliminate morloc composition abstractions + <- mapM rewrite ms + -- select a single instance at each node in the tree + >>= mapM realize -- [Either (SAnno GMeta One CType) (SAnno GMeta One CType)] + -- separate unrealized (general) ASTs (uASTs) from realized ASTs (rASTs) + |>> partitionEithers + + -- Collect all call-free data + gSerial <- mapM generalSerial gASTs + + -- build nexus + -- ----------- + -- Each nexus subcommand calls one function from one one pool. + -- The call passes the pool an index for the function (manifold) that will be called. + nexus <- Nexus.generate + gSerial + [ (t, poolId m x, metaName m) + | SAnno (One (x, t)) m <- rASTs + ] + + -- find all sources files + let srcs = unique . concat . conmap (unpackSAnno getSrcs) $ rASTs + + -- for each language, collect all functions into one "pool" + pools + -- thread arguments across the tree + <- mapM parameterize rASTs + -- convert from AST to manifold tree + >>= mapM express + -- rewrite lets to minimize the number of foreign calls + >>= mapM letOptimize + -- Separate the call trees into mono-lingual segments terminated in + -- primitives or foreign calls. + >>= mapM segment |>> concat + -- Cast each call tree root as a manifold + >>= mapM rehead + -- Gather segments into pools, currently this entails gathering all + -- segments from a given language into one pool. Later it may be more + -- nuanced. + >>= pool + -- Generate the code for each pool + >>= mapM (encode srcs) + + -- return the nexus script and each pool script + return (nexus, pools) + where + -- map from nexus id to pool id + -- these differ when a declared variable is exported + poolId :: GMeta -> SExpr GMeta One TypeP -> Int + poolId _ (LamS _ (SAnno _ meta)) = metaId meta + poolId meta _ = metaId meta + + -- this is grossly inefficient ... but I'll deal with it later + getSrcs :: SExpr GMeta One c -> GMeta -> c -> [Source] + getSrcs (CallS src) g _ = src : (getSrcsFromGmeta g) + getSrcs _ g _ = getSrcsFromGmeta g + + getSrcsFromGmeta :: GMeta -> [Source] + getSrcsFromGmeta g + = concat [unresolvedPackerForward p ++ unresolvedPackerReverse p + | p <- (concat . Map.elems . metaPackers) g] + ++ Map.elems (metaConstructors g) + + +-- | Eliminate morloc function calls +-- For example: +-- foo x y = bar x (baz y) +-- bar x y = add x y +-- baz x = div x 5 +-- Can be rewritten as: +-- foo x y = add x (div y 5) +-- Notice that no morloc abstractions appear on the right hand side. +rewrite + :: SAnno GMeta Many [CType] + -> MorlocMonad (SAnno GMeta Many [CType]) +rewrite (SAnno (Many es0) g0) = do + es0' <- fmap concat $ mapM rewriteL0 es0 + return $ SAnno (Many es0') g0 + where + rewriteL0 + :: (SExpr GMeta Many [CType], [CType]) + -> MorlocMonad [(SExpr GMeta Many [CType], [CType])] + rewriteL0 (AppS (SAnno (Many es1) g1) args, c1) = do + args' <- mapM rewrite args + -- originally es1 consists of a list of CallS and LamS constructors + -- - CallS are irreducible source functions + -- - LamS are Morloc abstractions that can be reduced + -- separate LamS expressions from all others + let (es1LamS, es1CallS) = partitionEithers (map sepLamS es1) + -- rewrite the LamS expressions, each expression will yields 1 or more + es1LamS' <- fmap concat $ mapM (rewriteL1 args') es1LamS + return $ (AppS (SAnno (Many es1CallS) g1) args', c1) : es1LamS' + where + sepLamS + :: (SExpr g Many c, c) + -> Either ([EVar], SAnno g Many c) + (SExpr g Many c, c) + sepLamS (LamS vs body, _) = Left (vs, body) + sepLamS x = Right x + rewriteL0 (AccS x k, c) = do + x' <- rewrite x + return [(AccS x' k, c)] + rewriteL0 (ListS xs, c) = do + xs' <- mapM rewrite xs + return [(ListS xs', c)] + rewriteL0 (TupleS xs, c) = do + xs' <- mapM rewrite xs + return [(TupleS xs', c)] + rewriteL0 (RecS entries, c) = do + xs' <- mapM rewrite (map snd entries) + return [(RecS $ zip (map fst entries) xs', c)] + rewriteL0 (LamS vs x, c) = do + x' <- rewrite x + return [(LamS vs x', c)] + -- VarS UniS NumS LogS StrS CallS + rewriteL0 x = return [x] + + rewriteL1 + :: [SAnno g Many c] + -> ([EVar], SAnno g Many c) -- lambda variables and body + -> MorlocMonad [(SExpr g Many c, c)] + rewriteL1 args (vs, SAnno (Many es2) _) + | length vs == length args = + fmap concat $ mapM (substituteExprs (zip vs args)) es2 + | length vs > length args = MM.throwError . NotImplemented $ + "Partial function application not yet implemented (coming soon)" + | length vs < length args = MM.throwError . TypeError $ + "Type error: too many arguments applied to lambda" + rewriteL1 _ (_, SAnno (Many _) _) = error "GHC warnings tell me this is a missing case, but why?" + + + substituteExprs + :: [(EVar, SAnno g Many c)] + -> (SExpr g Many c, c) -- body + -> MorlocMonad [(SExpr g Many c, c)] -- substituted bodies + substituteExprs [] x = return [x] + substituteExprs ((v, r):rs) x = do + xs' <- substituteExpr v r x + fmap concat $ mapM (substituteExprs rs) xs' + + substituteExpr + :: EVar + -> SAnno g Many c -- replacement + -> (SExpr g Many c, c) -- expression + -> MorlocMonad [(SExpr g Many c, c)] + substituteExpr v (SAnno (Many xs) _) x@(VarS v', _) + | v == v' = return xs + | otherwise = return [x] + substituteExpr v r (AccS x k, c) = do + x' <- substituteAnno v r x + return [(AccS x' k, c)] + substituteExpr v r (ListS xs, c) = do + xs' <- mapM (substituteAnno v r) xs + return [(ListS xs', c)] + substituteExpr v r (TupleS xs, c) = do + xs' <- mapM (substituteAnno v r) xs + return [(TupleS xs', c)] + substituteExpr v r (RecS entries, c) = do + xs' <- mapM (substituteAnno v r) (map snd entries) + return [(RecS (zip (map fst entries) xs'), c)] + substituteExpr v r (LamS vs x, c) = do + x' <- substituteAnno v r x + return [(LamS vs x', c)] + substituteExpr v r (AppS f xs, c) = do + f' <- substituteAnno v r f + xs' <- mapM (substituteAnno v r) xs + return [(AppS f' xs', c)] + -- UniS NumS LogS StrS CallS + substituteExpr _ _ x = return [x] + + substituteAnno + :: EVar -- variable to replace + -> SAnno g Many c -- replacement branch set + -> SAnno g Many c -- search branch + -> MorlocMonad (SAnno g Many c) + substituteAnno v r (SAnno (Many xs) g) = do + xs' <- fmap concat $ mapM (substituteExpr v r) xs + return $ SAnno (Many xs') g + +-- | Select a single concrete language for each sub-expression. Store the +-- concrete type and the general type (if available). Select pack/unpack +-- functions. +realize + :: SAnno GMeta Many [CType] + -> MorlocMonad (Either (SAnno GMeta One ()) (SAnno GMeta One TypeP)) +realize x0 = do + -- MM.say $ " --- realize ---" + -- MM.say $ prettySAnnoMany x + -- MM.say $ " ---------------" + realizationMay <- realizeAnno 0 Nothing x0 + case realizationMay of + Nothing -> makeGAST x0 |>> Left + (Just (_, realization)) -> do + mapGCM weaveTypesGCP realization >>= rewritePartials |>> Right + where + realizeAnno + :: Int + -> Maybe Lang + -> SAnno GMeta Many [CType] + -> MorlocMonad (Maybe (Int, SAnno GMeta One CType)) + realizeAnno depth langMay (SAnno (Many xs) m) = do + asts <- mapM (\(x, cs) -> mapM (realizeExpr (depth+1) langMay x) cs) xs |>> concat + case minimumOnMay (\(s,_,_) -> s) (catMaybes asts) of + Just (i, x, c) -> do + return $ Just (i, SAnno (One (x, c)) m) + Nothing -> do + return Nothing + + realizeExpr + :: Int + -> Maybe Lang + -> SExpr GMeta Many [CType] + -> CType + -> MorlocMonad (Maybe (Int, SExpr GMeta One CType, CType)) + realizeExpr depth lang x c = do + let lang' = if isJust lang then lang else langOf c + realizeExpr' depth lang' x c + + realizeExpr' + :: Int + -> Maybe Lang + -> SExpr GMeta Many [CType] + -> CType + -> MorlocMonad (Maybe (Int, SExpr GMeta One CType, CType)) + -- always choose the primitive that is in the same language as the parent + realizeExpr' _ lang (UniS) c + | lang == langOf c = return $ Just (0, UniS, c) + | otherwise = return Nothing + realizeExpr' _ lang (NumS x) c + | lang == langOf c = return $ Just (0, NumS x, c) + | otherwise = return Nothing + realizeExpr' _ lang (LogS x) c + | lang == langOf c = return $ Just (0, LogS x, c) + | otherwise = return Nothing + realizeExpr' _ lang (StrS x) c + | lang == langOf c = return $ Just (0, StrS x, c) + | otherwise = return Nothing + -- Q: a call should also be of the same language as the parent, shouldn't it? + -- A: not necessarily, specifically if the parent includes many child calls, say in a list + realizeExpr' _ lang (CallS src) c + -- FIXME: assuming function calls have 0 cost is perhaps not realistic + | lang == langOf c = return $ Just (0, CallS src, c) + | otherwise = return Nothing + -- and a var? + realizeExpr' _ lang (VarS x) c + | lang == langOf c = return $ Just (0, VarS x, c) + | otherwise = return Nothing + realizeExpr' depth lang (AccS x k) c + | lang == langOf c = do + xMay <- realizeAnno depth lang x + case xMay of + Nothing -> return Nothing + (Just (i, x')) -> return $ Just (i, AccS x' k, c) + | otherwise = return Nothing + -- simple recursion into ListS, TupleS, and RecS + realizeExpr' depth lang (ListS xs) c + | lang == langOf c = do + xsMay <- mapM (realizeAnno depth lang) xs + case (fmap unzip . sequence) xsMay of + (Just (scores, xs')) -> return $ Just (sum scores, ListS xs', c) + Nothing -> return Nothing + | otherwise = return Nothing + realizeExpr' depth lang (TupleS xs) c + | lang == langOf c = do + xsMay <- mapM (realizeAnno depth lang) xs + case (fmap unzip . sequence) xsMay of + (Just (scores, xs')) -> return $ Just (sum scores, TupleS xs', c) + Nothing -> return Nothing + | otherwise = return Nothing + realizeExpr' depth lang (RecS entries) c + | lang == langOf c = do + xsMay <- mapM (realizeAnno depth lang) (map snd entries) + case (fmap unzip . sequence) xsMay of + (Just (scores, vals)) -> return $ Just (sum scores, RecS (zip (map fst entries) vals), c) + Nothing -> return Nothing + | otherwise = return Nothing + -- + realizeExpr' depth _ (LamS vs x) c = do + xMay <- realizeAnno depth (langOf c) x + case xMay of + (Just (score, x')) -> return $ Just (score, LamS vs x', c) + Nothing -> return Nothing + -- AppS + realizeExpr' _ Nothing _ _ = MM.throwError . OtherError $ "Expected concrete type" + realizeExpr' depth (Just lang) (AppS f xs) c = do + let lang' = (fromJust . langOf) c + fMay <- realizeAnno depth (Just lang') f + xsMay <- mapM (realizeAnno depth (Just lang')) xs + case (fMay, (fmap unzip . sequence) xsMay, Lang.pairwiseCost lang lang') of + (Just (fscore, f'), Just (scores, xs'), Just interopCost) -> + return $ Just (fscore + sum scores + interopCost, AppS f' xs', c) + _ -> return Nothing + + +-- | This function is called on trees that contain no language-specific +-- components. "GAST" refers to General Abstract Syntax Tree. The most common +-- GAST case, and the only one that is currently supported, is a expression +-- that merely rearranges data structures without calling any functions. Here +-- are a few examples: +-- +-- Constant values and containters (currently supported): +-- f1 = 5 +-- f2 = [1,2,3] +-- +-- Variable values and containers (coming soon): +-- f3 x = x +-- +-- f4 x = [1,2,x] +-- +-- Combinations of transformations on containers (possible, but not coming soon): +-- f5 :: forall a b . (a, b) -> (b, a) +-- f6 (x,y) = (y,x) +-- +-- The idea could be elaborated into a full-fledged language. +makeGAST :: SAnno GMeta Many [CType] -> MorlocMonad (SAnno GMeta One ()) +makeGAST (SAnno (Many []) m) = case metaGType m of + (Just (GType t)) -> MM.throwError . CallTheMonkeys . render + $ "Cannot build general value from type" <+> dquotes (prettyType t) + Nothing -> MM.throwError . CallTheMonkeys . render + $ "Cannot build general value from type." + <+> "You probably tried to build a module that is meant to be imported." +makeGAST (SAnno (Many ((UniS, _):_)) m) = return (SAnno (One (UniS, ())) m) +makeGAST (SAnno (Many ((VarS x, _):_)) m) = return (SAnno (One (VarS x, ())) m) +makeGAST (SAnno (Many ((NumS x, _):_)) m) = return (SAnno (One (NumS x, ())) m) +makeGAST (SAnno (Many ((LogS x, _):_)) m) = return (SAnno (One (LogS x, ())) m) +makeGAST (SAnno (Many ((StrS x, _):_)) m) = return (SAnno (One (StrS x, ())) m) +makeGAST (SAnno (Many ((AccS x k, _):_)) m) = do + x' <- makeGAST x + return (SAnno (One (AccS x' k, ())) m) +makeGAST (SAnno (Many ((ListS ss, _):_)) m) = do + ss' <- mapM makeGAST ss + return $ SAnno (One (ListS ss', ())) m +makeGAST (SAnno (Many ((TupleS ss, _):_)) m) = do + ss' <- mapM makeGAST ss + return $ SAnno (One (TupleS ss', ())) m +makeGAST (SAnno (Many ((LamS vs s, _):_)) m) = do + s' <- makeGAST s + return $ SAnno (One (LamS vs s', ())) m +makeGAST (SAnno (Many ((AppS f xs, _):_)) m) = do + f' <- makeGAST f + xs' <- mapM makeGAST xs + return $ SAnno (One (AppS f' xs', ())) m +makeGAST (SAnno (Many ((RecS es, _):_)) m) = do + vs <- mapM (makeGAST . snd) es + return $ SAnno (One (RecS (zip (map fst es) vs), ())) m +makeGAST (SAnno (Many ((CallS src, _):_)) _) + = MM.throwError . OtherError . render + $ "Function calls cannot be used in general code:" <+> pretty (srcName src) + + +-- | Serialize a simple, general data type. This type can consists only of JSON +-- primitives and containers (lists, tuples, and records) and accessors. +generalSerial :: SAnno GMeta One () -> MorlocMonad NexusCommand +generalSerial (SAnno _ GMeta{metaName = Nothing}) + = MM.throwError . OtherError $ "No general type found for call-free function" +generalSerial (SAnno _ GMeta{metaGType = Nothing}) + = MM.throwError . OtherError $ "No name found for call-free function" +generalSerial x0@(SAnno _ GMeta{ metaName = Just subcmd + , metaGType = Just (GType cmdtype)}) = generalSerial' [] x0 + where + base = NexusCommand subcmd cmdtype (dquotes "_") [] [] + + generalSerial' :: JsonPath -> SAnno GMeta One () -> MorlocMonad NexusCommand + generalSerial' _ (SAnno (One (UniS, _)) _) + = return $ base { commandJson = "null" } + generalSerial' _ (SAnno (One (NumS x, _)) _) + = return $ base { commandJson = viaShow x } + generalSerial' _ (SAnno (One (LogS x, _)) _) + = return $ base { commandJson = if x then "true" else "false" } + generalSerial' _ (SAnno (One (StrS x, _)) _) + = return $ base { commandJson = dquotes (pretty x) } + -- if a nested accessor is observed, evaluate the nested expression and + -- append the path + generalSerial' ps (SAnno (One (AccS x@(SAnno (One (AccS _ _, _)) _) k, _)) _) = do + ncmd <- generalSerial' ps x + case commandSubs ncmd of + [(ps1, arg, ps2)] -> + return $ ncmd { commandSubs = [(ps1, arg, JsonKey (unEVar k) : ps2)] } + _ -> error "Bad record access" + -- record the path to and from a record access, leave the value as null, it + -- will be set in the nexus + generalSerial' ps (SAnno (One (AccS (SAnno (One (VarS v, _)) g) k, _)) _) = + case g of + (metaGType->(Just (GType (NamT _ _ _ _)))) -> + return $ base { commandSubs = [(ps, unEVar v, [JsonKey (unEVar k)])] } + _ -> error "Attempted to use key access to non-record" + generalSerial' ps (SAnno (One (ListS xs, _)) _) = do + ncmds <- zipWithM generalSerial' + [ps ++ [JsonIndex i] | i <- [0..]] xs + return $ base + { commandJson = list (map commandJson ncmds) + , commandSubs = conmap commandSubs ncmds + } + generalSerial' ps (SAnno (One (TupleS xs, _)) _) = do + ncmds <- zipWithM generalSerial' + [ps ++ [JsonIndex i] | i <- [0..]] xs + return $ base + { commandJson = list (map commandJson ncmds) + , commandSubs = conmap commandSubs ncmds + } + generalSerial' ps (SAnno (One (RecS es, _)) _) = do + ncmds <- zipWithM generalSerial' + [ps ++ [JsonKey (unEVar k)] | k <- (map fst es)] + (map snd es) + let entries = zip (map fst es) (map commandJson ncmds) + obj = encloseSep "{" "}" "," + (map (\(k, v) -> dquotes (pretty k) <> ":" <> v) entries) + return $ base + { commandJson = obj + , commandSubs = conmap commandSubs ncmds + } + generalSerial' ps (SAnno (One (LamS vs x, _)) _) = do + ncmd <- generalSerial' ps x + return $ ncmd { commandArgs = vs } + generalSerial' ps (SAnno (One (VarS (EVar v), _)) _) = + return $ base { commandSubs = [(ps, v, [])] } + generalSerial' _ (SAnno (One _) m) = do + MM.throwError . OtherError . render $ + "Cannot serialize general type:" <+> prettyType (fromJust $ metaGType m) + +rewritePartials + :: SAnno GMeta One TypeP + -> MorlocMonad (SAnno GMeta One TypeP) +rewritePartials (SAnno (One (AppS f xs, ftype@(FunP _ _))) m) = do + let gTypeArgs = maybe (repeat Nothing) (map Just . decomposeFull) (metaGType m) + f' <- rewritePartials f + xs' <- mapM rewritePartials xs + lamGType <- makeGType $ [metaGType g | (SAnno _ g) <- xs'] ++ gTypeArgs + let vs = map EVar . take (nargs ftype) $ freshVarsAZ [] -- TODO: exclude existing arguments + ys = zipWith3 makeVar vs (decomposeFull ftype) gTypeArgs + -- unsafe, but should not fail for well-typed input + appType = last . decomposeFull $ ftype + appMeta = m {metaGType = metaGType m >>= (last . map Just . decomposeFull)} + lamMeta = m {metaGType = Just lamGType} + lamCType = ftype + + return $ SAnno (One (LamS vs (SAnno (One (AppS f' (xs' ++ ys), appType)) appMeta), lamCType)) lamMeta + where + makeGType :: [Maybe GType] -> MorlocMonad GType + makeGType ts = fmap GType . makeType . map unGType $ (map fromJust ts) + + -- make an sanno variable from variable name and type info + makeVar :: EVar -> TypeP -> Maybe GType -> SAnno GMeta One TypeP + makeVar v c g = SAnno (One (VarS v, c)) + ( m { metaGType = g + , metaName = Nothing + , metaProperties = Set.empty + , metaConstraints = Set.empty + } + ) +-- apply the pattern above down the AST +rewritePartials (SAnno (One (AppS f xs, t)) m) = do + xs' <- mapM rewritePartials xs + f' <- rewritePartials f + return $ SAnno (One (AppS f' xs', t)) m +rewritePartials (SAnno (One (LamS vs x, t)) m) = do + x' <- rewritePartials x + return $ SAnno (One (LamS vs x', t)) m +rewritePartials (SAnno (One (AccS x k, t)) m) = do + x' <- rewritePartials x + return $ SAnno (One (AccS x' k, t)) m +rewritePartials (SAnno (One (ListS xs, t)) m) = do + xs' <- mapM rewritePartials xs + return $ SAnno (One (ListS xs', t)) m +rewritePartials (SAnno (One (TupleS xs, t)) m) = do + xs' <- mapM rewritePartials xs + return $ SAnno (One (TupleS xs', t)) m +rewritePartials (SAnno (One (RecS entries, t)) m) = do + let keys = map fst entries + vals <- mapM rewritePartials (map snd entries) + return $ SAnno (One (RecS (zip keys vals), t)) m +rewritePartials x = return x + +-- | Add arguments that are required for each term. Unneeded arguments are +-- removed at each step. +parameterize + :: SAnno GMeta One TypeP + -> MorlocMonad (SAnno GMeta One (TypeP, [(EVar, Argument)])) +parameterize (SAnno (One (LamS vs x, t)) m) = do + let args0 = zip vs $ zipWith makeArgument [0..] (decomposeFull t) + x' <- parameterize' args0 x + return $ SAnno (One (LamS vs x', (t, args0))) m +parameterize (SAnno (One (CallS src, t)) m) = do + let ts = init . decomposeFull $ t + vs = map EVar (freshVarsAZ []) + args0 = zipWith makeArgument [0..] ts + return $ SAnno (One (CallS src, (t, zip vs args0))) m +parameterize x = parameterize' [] x + +-- TODO: the arguments coupled to every term should be the arguments USED +-- (not inherited) by the term. I need to ensure the argument threading +-- leads to correct passing of serialized/unserialized arguments. AppS should +-- "know" that it needs to deserialize functions that are passed to a foreign +-- call, for instance. +parameterize' + :: [(EVar, Argument)] -- arguments in parental scope (child needn't retain them) + -> SAnno GMeta One TypeP + -> MorlocMonad (SAnno GMeta One (TypeP, [(EVar, Argument)])) +-- primitives, no arguments are required for a primitive, so empty lists +parameterize' _ (SAnno (One (UniS, c)) m) = return $ SAnno (One (UniS, (c, []))) m +parameterize' _ (SAnno (One (NumS x, c)) m) = return $ SAnno (One (NumS x, (c, []))) m +parameterize' _ (SAnno (One (LogS x, c)) m) = return $ SAnno (One (LogS x, (c, []))) m +parameterize' _ (SAnno (One (StrS x, c)) m) = return $ SAnno (One (StrS x, (c, []))) m +-- VarS EVar +parameterize' args (SAnno (One (VarS v, c)) m) = do + let args' = [(v', r) | (v', r) <- args, v' == v] + return $ SAnno (One (VarS v, (c, args'))) m +-- CallS Source +parameterize' _ (SAnno (One (CallS src, c)) m) = do + return $ SAnno (One (CallS src, (c, []))) m +-- record access +parameterize' args (SAnno (One (AccS x k, c)) m) = do + x' <- parameterize' args x + return $ SAnno (One (AccS x' k, (c, args))) m +-- containers +parameterize' args (SAnno (One (ListS xs, c)) m) = do + xs' <- mapM (parameterize' args) xs + let usedArgs = map fst . unique . concat . map sannoSnd $ xs' + args' = [(v, r) | (v, r) <- args, elem v usedArgs] + return $ SAnno (One (ListS xs', (c, args'))) m +parameterize' args (SAnno (One (TupleS xs, c)) m) = do + xs' <- mapM (parameterize' args) xs + let usedArgs = map fst . unique . concat . map sannoSnd $ xs' + args' = [(v, r) | (v, r) <- args, elem v usedArgs] + return $ SAnno (One (TupleS xs', (c, args'))) m +parameterize' args (SAnno (One (RecS entries, c)) m) = do + vs' <- mapM (parameterize' args) (map snd entries) + let usedArgs = map fst . unique . concat . map sannoSnd $ vs' + args' = [(v, r) | (v, r) <- args, elem v usedArgs] + return $ SAnno (One (RecS (zip (map fst entries) vs'), (c, args'))) m +parameterize' args (SAnno (One (LamS vs x, c)) m) = do + let args' = [(v, r) | (v, r) <- args, not (elem v vs)] + startId = maximum (map (argId . snd) args) + 1 + args0 = zip vs $ map unpackArgument $ zipWith makeArgument [startId..] (decomposeFull c) + x' <- parameterize' (args' ++ args0) x + return $ SAnno (One (LamS vs x', (c, args'))) m +parameterize' args (SAnno (One (AppS x xs, c)) m) = do + x' <- parameterize' args x + xs' <- mapM (parameterize' args) xs + let usedArgs = map fst $ (sannoSnd x' ++ (unique . concat . map sannoSnd $ xs')) + args' = [(v, r) | (v, r) <- args, elem v usedArgs] + return $ SAnno (One (AppS x' xs', (c, args'))) m + +makeArgument :: Int -> TypeP -> Argument +makeArgument i (UnkP _) = PassThroughArgument i +makeArgument i t = SerialArgument i t + + +-- convert from unambiguous tree to non-segmented ExprM +express :: SAnno GMeta One (TypeP, [(EVar, Argument)]) -> MorlocMonad (ExprM Many) +express s0@(SAnno (One (_, (c0, _))) _) = express' True c0 s0 where + + express' :: Bool -> TypeP -> SAnno GMeta One (TypeP, [(EVar, Argument)]) -> MorlocMonad (ExprM Many) + + -- primitives + express' _ _ (SAnno (One (NumS x, (c, _))) _) = return $ NumM (Native c) x + express' _ _ (SAnno (One (LogS x, (c, _))) _) = return $ LogM (Native c) x + express' _ _ (SAnno (One (StrS x, (c, _))) _) = return $ StrM (Native c) x + express' _ _ (SAnno (One (UniS, (c, _))) _) = return $ NullM (Native c) + + -- record access + express' isTop pc (SAnno (One (AccS x k, _)) m) = do + x' <- express' isTop pc x >>= unpackExprM m + return (AccM x' k) + + -- containers + express' isTop _ (SAnno (One (ListS xs, (c@(ArrP _ [t]), args))) m) = do + xs' <- mapM (express' False t) xs >>= mapM (unpackExprM m) + let x = (ListM (Native c) xs') + if isTop + then do + x' <- packExprM m x + return $ ManifoldM m (map snd args) (ReturnM x') + else return x + express' _ _ (SAnno (One (ListS _, _)) _) = MM.throwError . CallTheMonkeys $ "ListS can only be ArrP type" + + express' isTop _ (SAnno (One (TupleS xs, (c@(ArrP _ ts), args))) m) = do + xs' <- zipWithM (express' False) ts xs >>= mapM (unpackExprM m) + let x = (TupleM (Native c) xs') + if isTop + then do + x' <- packExprM m x + return $ ManifoldM m (map snd args) (ReturnM x') + else return x + + express' isTop _ (SAnno (One (RecS entries, (c@(NamP _ _ _ rs), args))) m) = do + xs' <- zipWithM (express' False) (map snd rs) (map snd entries) >>= mapM (unpackExprM m) + let x = RecordM (Native c) (zip (map fst entries) xs') + if isTop + then do + x' <- packExprM m x + return $ ManifoldM m (map snd args) (ReturnM x') + else return x + + -- lambda + express' isTop _ (SAnno (One (LamS _ x@(SAnno (One (_, (c,_))) _), _)) _) = express' isTop c x + + -- var + express' _ _ (SAnno (One (VarS v, (c, rs))) _) = + case [r | (v', r) <- rs, v == v'] of + [r] -> case r of + (SerialArgument i _) -> return $ BndVarM (Serial c) i + (NativeArgument i _) -> return $ BndVarM (Native c) i + -- NOT passthrough, since it doesn't + -- After segmentation, this type will be used to resolve passthroughs everywhere + (PassThroughArgument i) -> return $ BndVarM (Serial c) i + _ -> MM.throwError . OtherError $ "Expected VarS to match exactly one argument" + + -- Apply arguments to a sourced function + -- The CallS object may be in a foreign language. These inter-language + -- connections will be snapped apart in the segment step. + express' _ pc (SAnno (One (AppS (SAnno (One (CallS src, (fc, _))) _) xs, (_, args))) m) + -- case #1 + | sameLanguage && fullyApplied = do + xs' <- zipWithM (express' False) inputs xs >>= mapM (unpackExprM m) + return . ManifoldM m (map snd args) $ + ReturnM (AppM f xs') + + -- case #2 + | sameLanguage && not fullyApplied = do + xs' <- zipWithM (express' False) inputs xs >>= mapM (unpackExprM m) + let startId = maximum (map (argId . snd) args) + 1 + lambdaTypes = drop (length xs) (map typeP2typeM inputs) + lambdaArgs = zipWith NativeArgument [startId ..] inputs + lambdaVals = zipWith BndVarM lambdaTypes [startId ..] + return . ManifoldM m (map snd args) $ + ReturnM (LamM lambdaArgs (AppM f (xs' ++ lambdaVals))) + + -- case #3 + | not sameLanguage && fullyApplied = do + xs' <- zipWithM (express' False) inputs xs >>= mapM (unpackExprM m) + return . ForeignInterfaceM (packTypeM (typeP2typeM pc)) . ManifoldM m (map snd args) $ + ReturnM (AppM f xs') + + -- case #4 + | not sameLanguage && not fullyApplied = do + xs' <- zipWithM (express' False) inputs xs >>= mapM (unpackExprM m) + let startId = maximum (map (argId . snd) args) + 1 + lambdaTypes = drop (length xs) (map typeP2typeM inputs) + lambdaArgs = zipWith NativeArgument [startId ..] inputs + lambdaVals = zipWith BndVarM lambdaTypes [startId ..] + return . ForeignInterfaceM (packTypeM (typeP2typeM pc)) + . ManifoldM m (map snd args) + $ ReturnM (LamM lambdaArgs (AppM f (xs' ++ lambdaVals))) + where + (inputs, _) = decompose fc + sameLanguage = langOf pc == langOf fc + fullyApplied = length inputs == length xs + f = SrcM (typeP2typeM fc) src + + -- CallS - direct export of a sourced function, e.g.: + express' True _ (SAnno (One (CallS src, (c, _))) m) = do + let (inputs, _) = decompose c + lambdaArgs = zipWith SerialArgument [0 ..] inputs + lambdaTypes = map (packTypeM . typeP2typeM) inputs + f = SrcM (typeP2typeM c) src + lambdaVals <- mapM (unpackExprM m) $ zipWith BndVarM lambdaTypes [0 ..] + return $ ManifoldM m lambdaArgs (ReturnM $ AppM f lambdaVals) + + -- An un-applied source call + express' False pc (SAnno (One (CallS src, (c, _))) m) = do + let (inputs, _) = decompose c + lambdaTypes = map typeP2typeM inputs + lambdaArgs = zipWith NativeArgument [0 ..] inputs + lambdaVals = zipWith BndVarM lambdaTypes [0 ..] + f = SrcM (typeP2typeM c) src + manifold = ManifoldM m lambdaArgs (ReturnM $ AppM f lambdaVals) + + if langOf pc == langOf c + then return manifold + else return $ ForeignInterfaceM (typeP2typeM pc) manifold + + express' _ _ (SAnno (One (_, (t, _))) m) = MM.throwError . CallTheMonkeys . render $ + "Invalid input to express' in module (" <> viaShow (metaName m) <> ") - type: " <> prettyTypeP t + +-- | Move let assignments to minimize number of foreign calls. This step +-- should be integrated with the optimizations performed in the realize step. +-- FIXME: replace stub +letOptimize :: ExprM Many -> MorlocMonad (ExprM Many) +letOptimize e = return e + +segment :: ExprM Many -> MorlocMonad [ExprM Many] +segment e0 + = segment' (gmetaOf e0) (argsOf e0) e0 + |>> (\(ms,e) -> e:ms) + |>> map reparameterize where + + -- This is where segmentation happens, every other match is just traversal + segment' _ args (ForeignInterfaceM t e@(ManifoldM m args' _)) = do + (ms, e') <- segment' m args' e + config <- MM.ask + case MC.buildPoolCallBase config (langOf e') (metaId m) of + (Just cmds) -> return (e':ms, PoolCallM (packTypeM t) (metaId m) cmds args) + Nothing -> MM.throwError . OtherError $ "Unsupported language: " <> MT.show' (langOf e') + + segment' m args (SerializeM _ (AppM e@(ForeignInterfaceM _ _) es)) = do + (ms, e') <- segment' m args e + (mss, es') <- mapM (segment' m args) es |>> unzip + es'' <- mapM (packExprM m) es' + return (ms ++ concat mss, AppM e' es'') + + segment' _ _ (ManifoldM m args e) = do + (ms, e') <- segment' m args e + return (ms, ManifoldM m args e') + + segment' m args (AppM e es) = do + (ms, e') <- segment' m args e + (mss, es') <- mapM (segment' m args) es |>> unzip + return (ms ++ concat mss, AppM e' es') + + segment' m args0 (LamM args1 e) = do + (ms, e') <- (segment' m (args0 ++ args1)) e + return (ms, LamM args1 e') + + segment' m args (LetM i e1 e2) = do + (ms1, e1') <- segment' m args e1 + (ms2, e2') <- segment' m args e2 + return (ms1 ++ ms2, LetM i e1' e2') + + segment' m args (AccM e k) = do + (ms, e') <- segment' m args e + return (ms, AccM e' k) + + segment' m args (ListM t es) = do + (mss, es') <- mapM (segment' m args) es |>> unzip + return (concat mss, ListM t es') + + segment' m args (TupleM t es) = do + (mss, es') <- mapM (segment' m args) es |>> unzip + return (concat mss, TupleM t es') + + segment' m args (RecordM t entries) = do + (mss, es') <- mapM (segment' m args) (map snd entries) |>> unzip + return (concat mss, RecordM t (zip (map fst entries) es')) + + segment' m args (SerializeM s e) = do + (ms, e') <- segment' m args e + return (ms, SerializeM s e') + + segment' m args (DeserializeM s e) = do + (ms, e') <- segment' m args e + return (ms, DeserializeM s e') + + segment' m args (ReturnM e) = do + (ms, e') <- segment' m args e + return (ms, ReturnM e') + + segment' _ _ e = return ([], e) + +-- Now that the AST is segmented by language, we can resolve passed-through +-- arguments where possible. +reparameterize :: (ExprM Many) -> (ExprM Many) +reparameterize e0 = snd (substituteBndArgs e0) where + substituteBndArgs :: (ExprM Many) -> ([(Int, TypeM)], ExprM Many) + substituteBndArgs (ForeignInterfaceM i e) = + let (vs, e') = substituteBndArgs e + in (vs, ForeignInterfaceM i (snd $ substituteBndArgs e')) + substituteBndArgs (ManifoldM m args e) = + let (vs, e') = substituteBndArgs e + in (vs, ManifoldM m (map (sub vs) args) e') + substituteBndArgs (AppM e es) = + let (vs, e') = substituteBndArgs e + (vss, es') = unzip $ map substituteBndArgs es + in (vs ++ concat vss, AppM e' es') + substituteBndArgs (LamM args e) = + let (vs, e') = substituteBndArgs e + in (vs, LamM (map (sub vs) args) e') + substituteBndArgs (LetM i e1 e2) = + let (vs1, e1') = substituteBndArgs e1 + (vs2, e2') = substituteBndArgs e2 + in (vs1 ++ vs2, LetM i e1' e2') + substituteBndArgs (AccM e k) = + let (vs, e') = substituteBndArgs e + in (vs, AccM e' k) + substituteBndArgs (ListM t es) = + let (vss, es') = unzip $ map substituteBndArgs es + in (concat vss, ListM t es') + substituteBndArgs (TupleM t es) = + let (vss, es') = unzip $ map substituteBndArgs es + in (concat vss, TupleM t es') + substituteBndArgs (RecordM t entries) = + let (vss, es') = unzip $ map substituteBndArgs (map snd entries) + in (concat vss, RecordM t (zip (map fst entries) es')) + substituteBndArgs (SerializeM s e) = + let (vs, e') = substituteBndArgs e + in (vs, SerializeM s e') + substituteBndArgs (DeserializeM s e) = + let (vs, e') = substituteBndArgs e + in (vs, DeserializeM s e') + substituteBndArgs (ReturnM e) = + let (vs, e') = substituteBndArgs e + in (vs, ReturnM e') + substituteBndArgs e@(BndVarM t i) = ([(i, t)], e) + substituteBndArgs e = ([], e) + + sub :: [(Int, TypeM)] -> Argument -> Argument + sub bnds r@(PassThroughArgument i) = case [t | (i', t) <- bnds, i == i'] of + ((Serial t):_) -> SerialArgument i t + ((Native t):_) -> NativeArgument i t + ((Function _ _):_) -> error "You don't need to pass functions as manifold arguments" + (Passthrough : _) -> error "What about 'Passthrough' do you not understand?" + _ -> r + sub _ r = r + +rehead :: ExprM Many -> MorlocMonad (ExprM Many) +rehead (LamM _ e) = rehead e +rehead (ManifoldM m args (ReturnM e)) = do + e' <- packExprM m e + return $ ManifoldM m args (ReturnM e') +rehead _ = MM.throwError $ CallTheMonkeys "Bad Head" + +-- Sort manifolds into pools. Within pools, group manifolds into call sets. +pool :: [ExprM Many] -> MorlocMonad [(Lang, [ExprM Many])] +pool = return . groupSort . map (\e -> (fromJust $ langOf e, e)) + +encode + :: [Source] + -> (Lang, [ExprM Many]) + -> MorlocMonad Script +encode srcs (lang, xs) = do + state <- MM.get + + let srcs' = unique [s | s <- srcs, srcLang s == lang] + + xs' <- mapM (preprocess lang) xs >>= chooseSerializer + -- translate each node in the AST to code + code <- translate lang srcs' xs' + + return $ Script + { scriptBase = "pool" + , scriptLang = lang + , scriptCode = Code . render $ code + , scriptCompilerFlags = + filter (/= "") . map packageGccFlags $ statePackageMeta state + , scriptInclude = unique . map MS.takeDirectory $ + (unique . catMaybes) (map srcPath srcs') + } + +preprocess :: Lang -> ExprM Many -> MorlocMonad (ExprM Many) +preprocess CppLang es = Cpp.preprocess es +preprocess RLang es = R.preprocess es +preprocess Python3Lang es = Python3.preprocess es +preprocess l _ = MM.throwError . PoolBuildError . render + $ "Language '" <> viaShow l <> "' has no translator" + +chooseSerializer :: [ExprM Many] -> MorlocMonad [ExprM One] +chooseSerializer xs = mapM chooseSerializer' xs where + chooseSerializer' :: ExprM Many -> MorlocMonad (ExprM One) + -- This is where the magic happens, the rest is just plumbing + chooseSerializer' (SerializeM s e) = SerializeM <$> oneSerial s <*> chooseSerializer' e + chooseSerializer' (DeserializeM s e) = DeserializeM <$> oneSerial s <*> chooseSerializer' e + -- plumbing + chooseSerializer' (ManifoldM g args e) = ManifoldM g args <$> chooseSerializer' e + chooseSerializer' (ForeignInterfaceM t e) = ForeignInterfaceM t <$> chooseSerializer' e + chooseSerializer' (LetM i e1 e2) = LetM i <$> chooseSerializer' e1 <*> chooseSerializer' e2 + chooseSerializer' (AppM e es) = AppM <$> chooseSerializer' e <*> mapM chooseSerializer' es + chooseSerializer' (LamM args e) = LamM args <$> chooseSerializer' e + chooseSerializer' (AccM e k) = AccM <$> chooseSerializer' e <*> pure k + chooseSerializer' (ListM t es) = ListM t <$> mapM chooseSerializer' es + chooseSerializer' (TupleM t es) = TupleM t <$> mapM chooseSerializer' es + chooseSerializer' (RecordM t rs) = do + ts <- mapM (chooseSerializer' . snd) rs + return $ RecordM t (zip (map fst rs) ts) + chooseSerializer' (ReturnM e ) = ReturnM <$> chooseSerializer' e + chooseSerializer' (SrcM t s) = return $ SrcM t s + chooseSerializer' (PoolCallM t i d args) = return $ PoolCallM t i d args + chooseSerializer' (BndVarM t i ) = return $ BndVarM t i + chooseSerializer' (LetVarM t i) = return $ LetVarM t i + chooseSerializer' (LogM t x) = return $ LogM t x + chooseSerializer' (NumM t x) = return $ NumM t x + chooseSerializer' (StrM t x) = return $ StrM t x + chooseSerializer' (NullM t) = return $ NullM t + + oneSerial :: SerialAST Many -> MorlocMonad (SerialAST One) + oneSerial (SerialPack _ (Many [])) = MM.throwError . SerializationError $ "No valid serializer found" + oneSerial (SerialPack v (Many ((p,s):_))) = do + s' <- oneSerial s + return $ SerialPack v (One (p, s')) + oneSerial (SerialList s) = SerialList <$> oneSerial s + oneSerial (SerialTuple ss) = SerialTuple <$> mapM oneSerial ss + oneSerial (SerialObject r v ps rs) = do + ts <- mapM (oneSerial . snd) rs + return $ SerialObject r v ps (zip (map fst rs) ts) + oneSerial (SerialNum t) = return $ SerialNum t + oneSerial (SerialBool t) = return $ SerialBool t + oneSerial (SerialString t) = return $ SerialString t + oneSerial (SerialNull t) = return $ SerialNull t + oneSerial (SerialUnknown t) = return $ SerialUnknown t + +translate :: Lang -> [Source] -> [ExprM One] -> MorlocMonad MDoc +translate lang srcs es = do + case lang of + CppLang -> Cpp.translate srcs es + RLang -> R.translate srcs es + Python3Lang -> Python3.translate srcs es + x -> MM.throwError . PoolBuildError . render + $ "Language '" <> viaShow x <> "' has no translator" + + +-------- Utility and lookup functions ---------------------------------------- + +unpackSAnno :: (SExpr g One c -> g -> c -> a) -> SAnno g One c -> [a] +unpackSAnno f (SAnno (One (e@(AccS x _), c)) g) = f e g c : unpackSAnno f x +unpackSAnno f (SAnno (One (e@(ListS xs), c)) g) = f e g c : conmap (unpackSAnno f) xs +unpackSAnno f (SAnno (One (e@(TupleS xs), c)) g) = f e g c : conmap (unpackSAnno f) xs +unpackSAnno f (SAnno (One (e@(RecS entries), c)) g) = f e g c : conmap (unpackSAnno f) (map snd entries) +unpackSAnno f (SAnno (One (e@(LamS _ x), c)) g) = f e g c : unpackSAnno f x +unpackSAnno f (SAnno (One (e@(AppS x xs), c)) g) = f e g c : conmap (unpackSAnno f) (x:xs) +unpackSAnno f (SAnno (One (e, c)) g) = [f e g c] + +mapGCM :: (g -> c -> MorlocMonad c') -> SAnno g One c -> MorlocMonad (SAnno g One c') +mapGCM f (SAnno (One (AccS x k, c)) g) = do + x' <- mapGCM f x + c' <- f g c + return $ SAnno (One (AccS x' k, c')) g +mapGCM f (SAnno (One (ListS xs, c)) g) = do + xs' <- mapM (mapGCM f) xs + c' <- f g c + return $ SAnno (One (ListS xs', c')) g +mapGCM f (SAnno (One (TupleS xs, c)) g) = do + xs' <- mapM (mapGCM f) xs + c' <- f g c + return $ SAnno (One (TupleS xs', c')) g +mapGCM f (SAnno (One (RecS entries, c)) g) = do + xs' <- mapM (mapGCM f) (map snd entries) + c' <- f g c + return $ SAnno (One (RecS (zip (map fst entries) xs'), c')) g +mapGCM f (SAnno (One (LamS vs x, c)) g) = do + x' <- mapGCM f x + c' <- f g c + return $ SAnno (One (LamS vs x', c')) g +mapGCM f (SAnno (One (AppS x xs, c)) g) = do + x' <- mapGCM f x + xs' <- mapM (mapGCM f) xs + c' <- f g c + return $ SAnno (One (AppS x' xs', c')) g +mapGCM f (SAnno (One (VarS x, c)) g) = do + c' <- f g c + return $ SAnno (One (VarS x, c')) g +mapGCM f (SAnno (One (CallS src, c)) g) = do + c' <- f g c + return $ SAnno (One (CallS src, c')) g +mapGCM f (SAnno (One (UniS, c)) g) = do + c' <- f g c + return $ SAnno (One (UniS, c')) g +mapGCM f (SAnno (One (NumS x, c)) g) = do + c' <- f g c + return $ SAnno (One (NumS x, c')) g +mapGCM f (SAnno (One (LogS x, c)) g) = do + c' <- f g c + return $ SAnno (One (LogS x, c')) g +mapGCM f (SAnno (One (StrS x, c)) g) = do + c' <- f g c + return $ SAnno (One (StrS x, c')) g + +sannoSnd :: SAnno g One (a, b) -> b +sannoSnd (SAnno (One (_, (_, x))) _) = x + +-- generate infinite list of fresh variables of form +-- ['a','b',...,'z','aa','ab',...,'zz',...] +freshVarsAZ + :: [MT.Text] -- variables to exclude + -> [MT.Text] +freshVarsAZ exclude = + filter + (\x -> not (elem x exclude)) + ([1 ..] >>= flip replicateM ['a' .. 'z'] |>> MT.pack) + +-- turn type list into a function +makeType :: [Type] -> MorlocMonad Type +makeType [] = MM.throwError . TypeError $ "empty type" +makeType [t] = return t +makeType (t:ts) = FunT <$> pure t <*> makeType ts diff --git a/library/Morloc/CodeGenerator/Grammars/Common.hs b/library/Morloc/CodeGenerator/Grammars/Common.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Grammars/Common.hs @@ -0,0 +1,341 @@ +{-| +Module : Morloc.CodeGenerator.Grammars.Common +Description : A common set of utility functions for language templates +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Morloc.CodeGenerator.Grammars.Common + ( argType + , unpackArgument + , argId + , typeOfExprM + , gmetaOf + , argsOf + , typeOfTypeM + , invertExprM + , packTypeM + , packExprM + , unpackExprM + , unpackTypeM + , nargsTypeM + , arg2typeM + , type2jsontype + , jsontype2json + , prettyArgument + , prettyExprM + , prettyTypeM + , prettyTypeP + , splitArgs + ) where + +import Morloc.Data.Doc +import Morloc.CodeGenerator.Namespace +import qualified Morloc.Data.Text as MT +import qualified Morloc.Monad as MM +import qualified Morloc.CodeGenerator.Serial as MCS + + +prettyArgument :: Argument -> MDoc +prettyArgument (SerialArgument i c) = + "Serial" <+> "x" <> pretty i <+> parens (prettyTypeP c) +prettyArgument (NativeArgument i c) = + "Native" <+> "x" <> pretty i <+> parens (prettyTypeP c) +prettyArgument (PassThroughArgument i) = + "PassThrough" <+> "x" <> pretty i + +argId :: Argument -> Int +argId (SerialArgument i _) = i +argId (NativeArgument i _) = i +argId (PassThroughArgument i ) = i + +argType :: Argument -> Maybe TypeP +argType (SerialArgument _ t) = Just t +argType (NativeArgument _ t) = Just t +argType (PassThroughArgument _) = Nothing + +unpackArgument :: Argument -> Argument +unpackArgument (SerialArgument i t) = NativeArgument i t +unpackArgument x = x + +nargsTypeM :: TypeM -> Int +nargsTypeM (Function ts _) = length ts +nargsTypeM _ = 0 + +prettyExprM :: ExprM f -> MDoc +prettyExprM e0 = (vsep . punctuate line . fst $ f e0) <> line where + manNamer :: Int -> MDoc + manNamer i = "m" <> pretty i + + f :: ExprM f -> ([MDoc], MDoc) + f (ManifoldM m args e) = + let (ms', body) = f e + decl = manNamer (metaId m) <> tupled (map prettyArgument args) + mdoc = block 4 decl body + in (mdoc : ms', manNamer (metaId m)) + f (PoolCallM t _ cmds args) = + let poolArgs = cmds ++ map prettyArgument args + in ([], "PoolCallM" <> list (poolArgs) <+> "::" <+> prettyTypeM t) + f (ForeignInterfaceM t e) = + let (ms, _) = f e + in (ms, "ForeignInterface :: " <> prettyTypeM t) + f (LetM v e1 e2) = + let (ms1', e1') = f e1 + (ms2', e2') = f e2 + in (ms1' ++ ms2', "a" <> pretty v <+> "=" <+> e1' <> line <> e2') + f (AppM fun xs) = + let (ms', fun') = f fun + (mss', xs') = unzip $ map f xs + in (ms' ++ concat mss', fun' <> tupled xs') + f (SrcM _ src) = ([], pretty (srcName src)) + f (LamM args e) = + let (ms', e') = f e + vsFull = map prettyArgument args + vsNames = map (\r -> "x" <> pretty (argId r)) args + in (ms', "\\ " <+> hsep (punctuate "," vsFull) <> "->" <+> e' <> tupled vsNames) + f (BndVarM _ i) = ([], "x" <> pretty i) + f (LetVarM _ i) = ([], "a" <> pretty i) + f (AccM e k) = + let (ms, e') = f e + in (ms, parens e' <> "@" <> pretty k) + f (ListM _ es) = + let (mss', es') = unzip $ map f es + in (concat mss', list es') + f (TupleM _ es) = + let (mss', es') = unzip $ map f es + in (concat mss', tupled es') + f (RecordM c entries) = + let (mss', es') = unzip $ map (f . snd) entries + entries' = zipWith (\k v -> pretty k <> "=" <> v) (map fst entries) es' + in (concat mss', prettyRecordPVar c <+> "{" <> tupled entries' <> "}") + f (LogM _ x) = ([], if x then "true" else "false") + f (NumM _ x) = ([], viaShow x) + f (StrM _ x) = ([], dquotes $ pretty x) + f (NullM _) = ([], "null") + f (SerializeM _ e) = + let (ms, e') = f e + in (ms, "PACK" <> tupled [e']) + f (DeserializeM _ e) = + let (ms, e') = f e + in (ms, "UNPACK" <> tupled [e']) + f (ReturnM e) = + let (ms, e') = f e + in (ms, "RETURN(" <> e' <> ")") + +prettyRecordPVar :: TypeM -> MDoc +prettyRecordPVar (Serial (NamP _ v _ _)) = prettyPVar v +prettyRecordPVar (Native (NamP _ v _ _)) = prettyPVar v +prettyRecordPVar _ = "" + +prettyPVar :: PVar -> MDoc +prettyPVar (PV _ (Just g) t) = parens (pretty g <+> pretty t) +prettyPVar (PV _ Nothing t) = parens ("*" <+> pretty t) + +prettyTypeP :: TypeP -> MDoc +prettyTypeP (UnkP v) = prettyPVar v +prettyTypeP (VarP v) = prettyPVar v +prettyTypeP (FunP t1 t2) = parens (prettyTypeP t1 <+> "->" <+> prettyTypeP t2) +prettyTypeP (ArrP v ts) = prettyPVar v <+> hsep (map prettyTypeP ts) +prettyTypeP (NamP r v _ rs) + = viaShow r <+> prettyPVar v <+> encloseSep "{" "}" "," + (zipWith (\key val -> key <+> "=" <+> val) + (map (prettyPVar . fst) rs) + (map (prettyTypeP . snd) rs)) + +prettyTypeM :: TypeM -> MDoc +prettyTypeM Passthrough = "Passthrough" +prettyTypeM (Serial c) = "Serial<" <> prettyTypeP c <> ">" +prettyTypeM (Native c) = "Native<" <> prettyTypeP c <> ">" +prettyTypeM (Function ts t) = + "Function<" <> hsep (punctuate "->" (map prettyTypeM (ts ++ [t]))) <> ">" + +-- see page 112 of my super-secret notes ... +-- example: +-- > f [g x, 42] (h 1 [1,2]) +-- converts to: +-- > let a0 = g x +-- > in let a1 = [a0, 42] +-- > in let a2 = [1,2] +-- > in let a3 = h 1 a2 +-- > in f a1 a3 +-- expression inversion will not alter expression type +invertExprM :: (ExprM f) -> MorlocMonad (ExprM f) +invertExprM (ManifoldM m args e) = do + MM.startCounter + e' <- invertExprM e + return $ ManifoldM m args e' +invertExprM (LetM v e1 e2) = do + e2' <- invertExprM e2 + return $ LetM v e1 e2' +invertExprM e@(AppM f es) = do + f' <- invertExprM f + es' <- mapM invertExprM es + v <- MM.getCounter + let t = typeOfExprM e + appM' = LetM v (AppM (terminalOf f') (map terminalOf es')) (LetVarM t v) + return $ foldl dependsOn appM' (f':es') +-- you can't pull the body of the lambda out into a let statement +invertExprM f@(LamM _ _) = return f +invertExprM (AccM e k) = do + e' <- invertExprM e + return $ dependsOn (AccM (terminalOf e') k) e' +invertExprM (ListM c es) = do + es' <- mapM invertExprM es + v <- MM.getCounter + let e = LetM v (ListM c (map terminalOf es')) (LetVarM c v) + e' = foldl (\x y -> dependsOn x y) e es' + return e' +invertExprM (TupleM c es) = do + es' <- mapM invertExprM es + v <- MM.getCounter + let e = LetM v (TupleM c (map terminalOf es')) (LetVarM c v) + e' = foldl (\x y -> dependsOn x y) e es' + return e' +invertExprM (RecordM c entries) = do + es' <- mapM invertExprM (map snd entries) + v <- MM.getCounter + let entries' = zip (map fst entries) (map terminalOf es') + e = LetM v (RecordM c entries') (LetVarM c v) + e' = foldl (\x y -> dependsOn x y) e es' + return e' +invertExprM (SerializeM p e) = do + e' <- invertExprM e + v <- MM.getCounter + let t' = packTypeM $ typeOfExprM e + return $ dependsOn (LetM v (SerializeM p (terminalOf e')) (LetVarM t' v)) e' +invertExprM (DeserializeM p e) = do + e' <- invertExprM e + v <- MM.getCounter + let t' = unpackTypeM $ typeOfExprM e + return $ dependsOn (LetM v (DeserializeM p (terminalOf e')) (LetVarM t' v)) e' +invertExprM (ReturnM e) = do + e' <- invertExprM e + return $ dependsOn (ReturnM (terminalOf e')) e' +invertExprM (PoolCallM t i cmds args) = do + v <- MM.getCounter + return $ LetM v (PoolCallM t i cmds args) (LetVarM t v) +invertExprM e = return e + +-- transfer all let-dependencies from y to x +-- +-- Technically, I should check for variable reuse in the let-chain and +-- resolve conflicts be substituting in fresh variable names. However, for +-- now, I will trust that my name generator created names that are unique +-- within the manifold. +dependsOn :: ExprM f -> ExprM f -> ExprM f +dependsOn x (LetM v e y) = LetM v e (dependsOn x y) +dependsOn x _ = x + +-- get the rightmost expression in a let-tree +terminalOf :: ExprM f -> ExprM f +terminalOf (LetM _ _ e) = terminalOf e +terminalOf e = e + +typeOfTypeM :: TypeM -> Maybe TypeP +typeOfTypeM Passthrough = Nothing +typeOfTypeM (Serial c) = Just c +typeOfTypeM (Native c) = Just c +typeOfTypeM (Function [] t) = typeOfTypeM t +typeOfTypeM (Function (ti:ts) to) + = FunP <$> typeOfTypeM ti <*> typeOfTypeM (Function ts to) + +arg2typeM :: Argument -> TypeM +arg2typeM (SerialArgument _ c) = Serial c +arg2typeM (NativeArgument _ c) = Native c +arg2typeM (PassThroughArgument _) = Passthrough + +-- | Get the manifold type of an expression +-- +-- The ExprM must have exactly enough type information to infer the type of any +-- element without reference to the element's parent. +typeOfExprM :: ExprM f -> TypeM +typeOfExprM (ManifoldM _ args e) = Function (map arg2typeM args) (typeOfExprM e) +typeOfExprM (ForeignInterfaceM t _) = t +typeOfExprM (PoolCallM t _ _ _) = t +typeOfExprM (LetM _ _ e2) = typeOfExprM e2 +typeOfExprM (AppM f xs) = case typeOfExprM f of + (Function inputs output) -> case drop (length xs) inputs of + [] -> output + inputs' -> Function inputs' output + _ -> error . MT.unpack . render $ "COMPILER BUG: application of non-function" <+> parens (prettyTypeM $ typeOfExprM f) +typeOfExprM (SrcM t _) = t +typeOfExprM (LamM args x) = Function (map arg2typeM args) (typeOfExprM x) +typeOfExprM (BndVarM t _) = t +typeOfExprM (LetVarM t _) = t +typeOfExprM (AccM e _) = typeOfExprM e +typeOfExprM (ListM t _) = t +typeOfExprM (TupleM t _) = t +typeOfExprM (RecordM t _) = t +typeOfExprM (LogM t _) = t +typeOfExprM (NumM t _) = t +typeOfExprM (StrM t _) = t +typeOfExprM (NullM t) = t +typeOfExprM (SerializeM _ e) = packTypeM (typeOfExprM e) +typeOfExprM (DeserializeM _ e) = unpackTypeM (typeOfExprM e) +typeOfExprM (ReturnM e) = typeOfExprM e + +packTypeM :: TypeM -> TypeM +packTypeM (Native t) = Serial t +packTypeM (Function _ _) = error $ "BUG: Cannot pack a function" +packTypeM t = t + +unpackTypeM :: TypeM -> TypeM +unpackTypeM (Serial t) = Native t +unpackTypeM Passthrough = error $ "BUG: Cannot unpack a passthrough type" +unpackTypeM t = t + +unpackExprM :: GMeta -> ExprM Many -> MorlocMonad (ExprM Many) +unpackExprM m e = case typeOfExprM e of + (Serial t) -> DeserializeM <$> MCS.makeSerialAST m t <*> pure e + (Passthrough) -> MM.throwError . SerializationError $ "Cannot unpack a passthrough typed expression" + _ -> return e + +packExprM :: GMeta -> ExprM Many -> MorlocMonad (ExprM Many) +packExprM m e = case typeOfExprM e of + (Native t) -> SerializeM <$> MCS.makeSerialAST m t <*> pure e + -- (Function _ _) -> error "Cannot pack a function" + _ -> return e + +type2jsontype :: TypeP -> MorlocMonad JsonType +type2jsontype (UnkP _) = MM.throwError . SerializationError $ "Invalid JSON type: UnkT" +type2jsontype (VarP (PV _ _ v)) = return $ VarJ v +type2jsontype (ArrP (PV _ _ v) ts) = ArrJ v <$> mapM type2jsontype ts +type2jsontype (FunP _ _) = MM.throwError . SerializationError $ "Invalid JSON type: FunT" +type2jsontype (NamP namType (PV _ _ v) _ rs) = do + vs <- mapM type2jsontype (map snd rs) + return $ NamJ jsontype (zip [val | (PV _ _ val, _) <- rs] vs) + where + jsontype = case namType of + NamRecord -> "record" + NamObject -> v + NamTable -> v + +jsontype2json :: JsonType -> MDoc +jsontype2json (VarJ v) = dquotes (pretty v) +jsontype2json (ArrJ v ts) = "{" <> key <> ":" <> val <> "}" where + key = dquotes (pretty v) + val = encloseSep "[" "]" "," (map jsontype2json ts) +jsontype2json (NamJ v rs) = "{" <> dquotes (pretty v) <> ":" <> encloseSep "{" "}" "," rs' <> "}" where + keys = map (dquotes . pretty) (map fst rs) + vals = map jsontype2json (map snd rs) + rs' = zipWith (\key val -> key <> ":" <> val) keys vals + +argsOf :: ExprM f -> [Argument] +argsOf (LamM args _) = args +argsOf (ManifoldM _ args _) = args +argsOf _ = [] + +gmetaOf :: ExprM f -> GMeta +gmetaOf (ManifoldM m _ _) = m +gmetaOf (LamM _ e) = gmetaOf e +gmetaOf _ = error "Malformed top-expression" + +-- divide a list of arguments based on wheither they are in a second list +splitArgs :: [Argument] -> [Argument] -> ([Argument], [Argument]) +splitArgs args1 args2 = partitionEithers $ map splitOne args1 where + splitOne :: Argument -> Either Argument Argument + splitOne r = if elem r args2 + then Left r + else Right r + diff --git a/library/Morloc/CodeGenerator/Grammars/Macro.hs b/library/Morloc/CodeGenerator/Grammars/Macro.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Grammars/Macro.hs @@ -0,0 +1,72 @@ +{-| +Module : Morloc.CodeGenerator.Grammars.Macro +Description : Expand parameters in concrete types +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.CodeGenerator.Grammars.Macro +( expandMacro + , expandType +) where + +import Morloc.CodeGenerator.Namespace +import Morloc.Data.Doc +import qualified Morloc.Data.Text as MT +import qualified Control.Monad.State as CMS +import Text.Megaparsec +import Text.Megaparsec.Char +import Data.Void (Void) +import qualified Text.Megaparsec.Char.Lexer as L + +type Parser a = CMS.StateT ParserState (Parsec Void MT.Text) a + +data ParserState = ParserState { + stateParameters :: [MT.Text] +} + +expandType + :: (MDoc -> [MDoc] -> MDoc) -- ^ make function type + -> (PVar -> [(PVar, MDoc)] -> MDoc) -- ^ make record type + -> TypeP + -> MDoc +expandType mkfun mkrec t0 = f t0 where + f :: TypeP -> MDoc + f (VarP (PV _ _ v)) = pretty v + f t@(FunP t1 _) = mkfun (f t1) (map f (decomposeFull t)) + f (ArrP (PV _ _ v) ts) = pretty $ expandMacro v (map (render . f) ts) + f (NamP _ v _ entries) = mkrec v [(k, f t) | (k, t) <- entries] + f (UnkP _) = error "Cannot build unsolved type" + +expandMacro :: MT.Text -> [MT.Text] -> MT.Text +expandMacro t [] = t +expandMacro t ps = + case runParser + (CMS.runStateT (pBase <* eof) (ParserState ps)) + "typemacro" + t of + Left err -> error (show err) + Right (es, _) -> es + +many1 :: Parser a -> Parser [a] +many1 p = do + x <- p + xs <- many p + return (x : xs) + +pBase :: Parser MT.Text +pBase = MT.concat <$> many1 (pChar <|> pMacro) + +pChar :: Parser MT.Text +pChar = MT.pack <$> many1 (noneOf ['$']) + +pMacro :: Parser MT.Text +pMacro = do + xs <- CMS.gets stateParameters + _ <- string "$" + n <- L.decimal + -- index is 1-based + let i = n - 1 + return (xs !! i) diff --git a/library/Morloc/CodeGenerator/Grammars/Translator/Cpp.hs b/library/Morloc/CodeGenerator/Grammars/Translator/Cpp.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Grammars/Translator/Cpp.hs @@ -0,0 +1,775 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +{-| +Module : Morloc.CodeGenerator.Grammars.Translator.Cpp +Description : C++ translator +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.CodeGenerator.Grammars.Translator.Cpp + ( + translate + , preprocess + ) where + +import Morloc.CodeGenerator.Namespace +import Morloc.CodeGenerator.Internal (typeP2typeM) +import Morloc.CodeGenerator.Serial ( isSerializable + , prettySerialOne + , serialAstToType + , serialAstToType' + , shallowType + ) +import Morloc.CodeGenerator.Grammars.Common +import qualified Morloc.CodeGenerator.Grammars.Translator.Source.CppInternals as Src +import Morloc.Data.Doc +import Morloc.Quasi +import qualified Morloc.System as MS +import Morloc.CodeGenerator.Grammars.Macro (expandMacro) +import qualified Morloc.Monad as MM +import qualified Data.Map as Map + +-- | @RecEntry@ stores the common name, keys, and types of records that are not +-- imported from C++ source. These records are generated as structs in the C++ +-- pool. @unifyRecords@ takes all such records and "unifies" ones with the same +-- name and keys. The unified records may have different types, but they will +-- all be instances of the same generic struct. That is, any fields that differ +-- between instances will be made generic. +data RecEntry = RecEntry { + recName :: MDoc -- ^ the automatically generated name for this anonymous type + , recFields :: [( PVar -- The field key + , Maybe TypeP -- The field type if not generic + )] +} + +-- | @RecMap@ is used to lookup up the struct name shared by all records that +-- are not imported from C++ source. +type RecMap = [((PVar, [PVar]), RecEntry)] + +-- tree rewrites +preprocess :: ExprM Many -> MorlocMonad (ExprM Many) +preprocess = invertExprM + +translate :: [Source] -> [ExprM One] -> MorlocMonad MDoc +translate srcs es = do + -- translate sources + includeDocs <- mapM + translateSource + (unique . catMaybes . map srcPath $ srcs) + + -- diagnostics + liftIO . putDoc . vsep $ "-- C++ translation --" : map prettyExprM es + + let recmap = unifyRecords . conmap collectRecords $ es + (autoDecl, autoSerial) = generateAnonymousStructs recmap + (srcDecl, srcSerial) = generateSourcedSerializers es + dispatch = makeDispatch es + signatures = map (makeSignature recmap) es + serializationCode = autoDecl ++ srcDecl ++ autoSerial ++ srcSerial + + -- translate each manifold tree, rooted on a call from nexus or another pool + mDocs <- mapM (translateManifold recmap) es + + -- create and return complete pool script + return $ makeMain includeDocs signatures serializationCode mDocs dispatch + +letNamer :: Int -> MDoc +letNamer i = "a" <> viaShow i + +manNamer :: Int -> MDoc +manNamer i = "m" <> viaShow i + +bndNamer :: Int -> MDoc +bndNamer i = "x" <> viaShow i + +serialType :: MDoc +serialType = "std::string" + +makeSignature :: RecMap -> ExprM One -> MDoc +makeSignature recmap e0@(ManifoldM _ _ _) = vsep (f e0) where + f :: ExprM One -> [MDoc] + f (ManifoldM (metaId->i) args e) = + let t = typeOfExprM e + sig = showTypeM recmap t <+> manNamer i <> tupled (map (makeArg recmap) args) <> ";" + in sig : f e + f (LetM _ e1 e2) = f e1 ++ f e2 + f (AppM e es) = f e ++ conmap f es + f (LamM _ e) = f e + f (AccM e _) = f e + f (ListM _ es) = conmap f es + f (TupleM _ es) = conmap f es + f (RecordM _ entries) = conmap f (map snd entries) + f (SerializeM _ e) = f e + f (DeserializeM _ e) = f e + f (ReturnM e) = f e + f _ = [] +makeSignature _ _ = error "Expected ManifoldM" + +makeArg :: RecMap -> Argument -> MDoc +makeArg _ (SerialArgument i _) = serialType <+> bndNamer i +makeArg recmap (NativeArgument i c) = showTypeM recmap (Native c) <+> bndNamer i +makeArg _ (PassThroughArgument i) = serialType <+> bndNamer i + +argName :: Argument -> MDoc +argName (SerialArgument i _) = bndNamer i +argName (NativeArgument i _) = bndNamer i +argName (PassThroughArgument i) = bndNamer i + +tupleKey :: Int -> MDoc -> MDoc +tupleKey i v = [idoc|std::get<#{pretty i}>(#{v})|] + +recordAccess :: MDoc -> MDoc -> MDoc +recordAccess record field = record <> "." <> field + +-- TLDR: Use `#include "foo.h"` rather than `#include ` +-- Include statements in C can be either wrapped in angle brackets (e.g., +-- ``) or in quotes (e.g., `"myfile.h"`). The difference between these +-- is implementation specific. I currently use the GCC compiler. For quoted +-- strings, it first searches relative to the working directory and then, if +-- nothing is found, searches system files. For angle brackets, it searches +-- only system files: . So +-- quoting seems more reasonable, for now. This might change only if I start +-- loading the morloc libraries into the system directories (which might be +-- reasonable), though still, quotes would work. +-- +-- UPDATE: The build system will now read the source paths from the Script +-- object and write an `-I${MORLOC_HOME}/lib/${MORLOC_PACKAGE}` argument for +-- g++. This will tell g++ where to look for headers. So now in the generated +-- source code I can just write the basename. This makes the generated code +-- neater (no hard-coded local paths), but now the g++ compiler will search +-- through all the module paths for each file, which introduces the possibility +-- of name conflicts. +translateSource + :: Path -- ^ Path to a header (e.g., `$MORLOC_HOME/lib/foo.h`) + -> MorlocMonad MDoc +translateSource path = return $ + "#include" <+> (dquotes . pretty . MS.takeFileName) path + + +serialize + :: RecMap + -> Int -- The let index `i` + -> MDoc -- A variable name pointing to e1 + -> SerialAST One + -> MorlocMonad [MDoc] +serialize recmap letIndex datavar0 s0 = do + (x, before) <- serialize' datavar0 s0 + t0 <- (showTypeM recmap . Native) <$> serialAstToType s0 + let schemaName = [idoc|#{letNamer letIndex}_schema|] + schema = [idoc|#{t0} #{schemaName};|] + final = [idoc|#{serialType} #{letNamer letIndex} = serialize(#{x}, #{schemaName});|] + return (before ++ [schema, final]) + + where + serialize' + :: MDoc -- a variable name that stores the data described by the SerialAST object + -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) + serialize' v s + | isSerializable s = return (v, []) + | otherwise = construct v s + + construct :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) + construct v (SerialPack _ (One (p, s))) = do + unpacker <- case typePackerReverse p of + [] -> MM.throwError . SerializationError $ "No unpacker found" + (src:_) -> return . pretty . srcName $ src + serialize' [idoc|#{unpacker}(#{v})|] s + + construct v lst@(SerialList s) = do + idx <- fmap pretty $ MM.getCounter + t <- serialAstToType lst + let v' = "s" <> idx + decl = [idoc|#{showType recmap t} #{v'};|] + (x, before) <- serialize' [idoc|#{v}[i#{idx}]|] s + let push = [idoc|#{v'}.push_back(#{x});|] + loop = block 4 [idoc|for(size_t i#{idx} = 0; i#{idx} < #{v}.size(); i#{idx}++)|] + (vsep (before ++ [push])) + return (v', [decl, loop]) + + construct v tup@(SerialTuple ss) = do + (ss', befores) <- fmap unzip $ zipWithM (\i s -> serialize' (tupleKey i v) s) [0..] ss + idx <- fmap pretty $ MM.getCounter + t <- serialAstToType tup + let v' = "s" <> idx + x = [idoc|#{showType recmap t} #{v'} = std::make_tuple#{tupled ss'};|] + return (v', concat befores ++ [x]); + + construct v rec@(SerialObject NamRecord _ _ rs) = do + (ss', befores) <- fmap unzip $ mapM (\(PV _ _ k,s) -> serialize' (recordAccess v (pretty k)) s) rs + idx <- fmap pretty $ MM.getCounter + t <- (showType recmap) <$> serialAstToType rec + let v' = "s" <> idx + decl = encloseSep "{" "}" "," ss' + x = [idoc|#{t} #{v'} = #{decl};|] + return (v', concat befores ++ [x]); + + construct _ s = MM.throwError . SerializationError . render + $ "construct: " <> prettySerialOne s + +-- reverse of serialize, parameters are the same +deserialize :: RecMap -> Int -> MDoc -> MDoc -> SerialAST One -> MorlocMonad [MDoc] +deserialize recmap letIndex typestr0 varname0 s0 + | isSerializable s0 = do + let schemaName = [idoc|#{letNamer letIndex}_schema|] + schema = [idoc|#{typestr0} #{schemaName};|] + deserializing = [idoc|#{typestr0} #{letNamer letIndex} = deserialize(#{varname0}, #{schemaName});|] + return [schema, deserializing] + | otherwise = do + idx <- fmap pretty $ MM.getCounter + t <- serialAstToType s0 + let rawtype = showType recmap $ t + schemaName = [idoc|#{letNamer letIndex}_schema|] + rawvar = "s" <> idx + schema = [idoc|#{rawtype} #{schemaName};|] + deserializing = [idoc|#{rawtype} #{rawvar} = deserialize(#{varname0}, #{schemaName});|] + (x, before) <- construct rawvar s0 + let final = [idoc|#{typestr0} #{letNamer letIndex} = #{x};|] + return ([schema, deserializing] ++ before ++ [final]) + + where + check :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) + check v s + | isSerializable s = return (v, []) + | otherwise = construct v s + + construct :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) + construct v (SerialPack _ (One (p, s'))) = do + packer <- case typePackerForward p of + [] -> MM.throwError . SerializationError $ "No packer found" + (x:_) -> return . pretty . srcName $ x + (x, before) <- check v s' + let deserialized = [idoc|#{packer}(#{x})|] + return (deserialized, before) + + construct v lst@(SerialList s) = do + idx <- fmap pretty $ MM.getCounter + t <- fmap (showType recmap) $ shallowType lst + let v' = "s" <> idx + decl = [idoc|#{t} #{v'};|] + (x, before) <- check [idoc|#{v}[i#{idx}]|] s + let push = [idoc|#{v'}.push_back(#{x});|] + loop = block 4 [idoc|for(size_t i#{idx} = 0; i#{idx} < #{v}.size(); i#{idx}++)|] + (vsep (before ++ [push])) + return (v', [decl, loop]) + + construct v tup@(SerialTuple ss) = do + idx <- fmap pretty $ MM.getCounter + (ss', befores) <- fmap unzip $ zipWithM (\i s -> check (tupleKey i v) s) [0..] ss + t <- shallowType tup + let v' = "s" <> idx + x = [idoc|#{showType recmap $ t} #{v'} = std::make_tuple#{tupled ss'};|] + return (v', concat befores ++ [x]); + + construct v rec@(SerialObject NamRecord _ _ rs) = do + idx <- fmap pretty $ MM.getCounter + (ss', befores) <- fmap unzip $ mapM (\(PV _ _ k,s) -> check (recordAccess v (pretty k)) s) rs + t <- fmap (showType recmap) $ shallowType rec + let v' = "s" <> idx + decl = encloseSep "{" "}" "," ss' + x = [idoc|#{t} #{v'} = #{decl};|] + return (v', concat befores ++ [x]); + + construct _ s = MM.throwError . SerializationError . render + $ "deserializeDescend: " <> prettySerialOne s + +translateManifold :: RecMap -> ExprM One -> MorlocMonad MDoc +translateManifold recmap m0@(ManifoldM _ args0 _) = do + MM.startCounter + (vsep . punctuate line . (\(x,_,_)->x)) <$> f args0 m0 + where + + f :: [Argument] + -> ExprM One + -> MorlocMonad + ( [MDoc] -- the collection of final manifolds + , MDoc -- a call tag for this expression + , [MDoc] -- a list of statements that should precede this assignment + ) + + f args (LetM i (SerializeM s e1) e2) = do + (ms1, e1', ps1) <- f args e1 + (ms2, e2', ps2) <- f args e2 + serialized <- serialize recmap i e1' s + return (ms1 ++ ms2, vsep $ ps1 ++ ps2 ++ serialized ++ [e2'], []) + + f args (LetM i (DeserializeM s e1) e2) = do + (ms1, e1', ps1) <- f args e1 + (ms2, e2', ps2) <- f args e2 + t <- showNativeTypeM recmap (typeOfExprM e1) + deserialized <- deserialize recmap i t e1' s + return (ms1 ++ ms2, vsep $ ps1 ++ ps2 ++ deserialized ++ [e2'], []) + + f _ (SerializeM _ _) = MM.throwError . SerializationError + $ "SerializeM should only appear in an assignment" + + f _ (DeserializeM _ _) = MM.throwError . SerializationError + $ "DeserializeM should only appear in an assignment" + + f args (LetM i e1 e2) = do + (ms1', e1', ps1) <- (f args) e1 + (ms2', e2', ps2) <- (f args) e2 + let t = showTypeM recmap (typeOfExprM e1) + ps = ps1 ++ ps2 ++ [[idoc|#{t} #{letNamer i} = #{e1'};|], e2'] + return (ms1' ++ ms2', vsep ps, []) + + f args (AppM (SrcM (Function inputs output) src) xs) = do + (mss', xs', pss) <- mapM (f args) xs |>> unzip3 + let + name = pretty $ srcName src + mangledName = name <> "_fun" + inputBlock = cat (punctuate "," (map (showTypeM recmap) inputs)) + sig = [idoc|#{showTypeM recmap output}(*#{mangledName})(#{inputBlock}) = &#{name};|] + return (concat mss', mangledName <> tupled xs', sig : concat pss) + + f _ (AppM _ _) = error "Can only apply functions" + + f _ (SrcM _ src) = return ([], pretty $ srcName src, []) + + f pargs (ManifoldM (metaId->i) args e) = do + (ms', body, ps1) <- f args e + let t = typeOfExprM e + decl = showTypeM recmap t <+> manNamer i <> tupled (map (makeArg recmap) args) + mdoc = block 4 decl body + mname = manNamer i + (call, ps2) <- case (splitArgs args pargs, nargsTypeM t) of + ((rs, []), _) -> return (mname <> tupled (map (bndNamer . argId) rs), []) + (([], _ ), _) -> return (mname, []) + ((rs, vs), _) -> do + let v = mname <> "_fun" + lhs <- stdFunction recmap t vs |>> (\x -> x <+> v) + castFunction <- staticCast recmap t args mname + let vs' = take + (length vs) + (map (\j -> "std::placeholders::_" <> viaShow j) ([1..] :: [Int])) + rs' = map (bndNamer . argId) rs + rhs = stdBind $ castFunction : (rs' ++ vs') + sig = nest 4 (vsep [lhs <+> "=", rhs]) <> ";" + return (v, [sig]) + return (mdoc : ms', call, ps1 ++ ps2) + + f _ (PoolCallM _ _ cmds args) = do + let bufDef = "std::ostringstream s;" + callArgs = map dquotes cmds ++ map argName args + cmd = "s << " <> cat (punctuate " << \" \" << " callArgs) <> ";" + call = [idoc|foreign_call(s.str())|] + return ([], call, [bufDef, cmd]) + + f _ (ForeignInterfaceM _ _) = MM.throwError . CallTheMonkeys $ + "Foreign interfaces should have been resolved before passed to the translators" + + f _ (LamM _ _) = undefined + + f args (AccM e k) = do + (ms, e', ps) <- f args e + return (ms, e' <> "." <> pretty k, ps) + + f args (ListM _ es) = do + (mss', es', pss) <- mapM (f args) es |>> unzip3 + let x' = encloseSep "{" "}" "," es' + return (concat mss', x', concat pss) + + f args (TupleM _ es) = do + (mss', es', pss) <- mapM (f args) es |>> unzip3 + return (concat mss', "std::make_tuple" <> tupled es', concat pss) + + f args (RecordM c entries) = do + (mss', es', pss) <- mapM (f args . snd) entries |>> unzip3 + idx <- fmap pretty $ MM.getCounter + let t = showTypeM recmap c + v' = "a" <> idx + decl = encloseSep "{" "}" "," es' + x = [idoc|#{t} #{v'} = #{decl};|] + return (concat mss', v', concat pss ++ [x]) + + f _ (BndVarM _ i) = return ([], bndNamer i, []) + f _ (LetVarM _ i) = return ([], letNamer i, []) + f _ (LogM _ x) = return ([], if x then "true" else "false", []) + f _ (NumM _ x) = return ([], viaShow x, []) + f _ (StrM _ x) = return ([], dquotes $ pretty x, []) + f _ (NullM _) = return ([], "null", []) + + f args (ReturnM e) = do + (ms, e', ps) <- f args e + return (ms, "return(" <> e' <> ");", ps) +translateManifold _ _ = error "Every ExprM object must start with a Manifold term" + +stdFunction :: RecMap -> TypeM -> [Argument] -> MorlocMonad MDoc +stdFunction recmap t args = + let argList = cat (punctuate "," (map (argTypeM recmap) args)) + in return [idoc|std::function<#{showTypeM recmap t}(#{argList})>|] + +stdBind :: [MDoc] -> MDoc +stdBind xs = [idoc|std::bind(#{args})|] where + args = cat (punctuate "," xs) + +staticCast :: RecMap -> TypeM -> [Argument] -> MDoc -> MorlocMonad MDoc +staticCast recmap t args name = do + let output = showTypeM recmap t + inputs = map (argTypeM recmap) args + argList = cat (punctuate "," inputs) + return $ [idoc|static_cast<#{output}(*)(#{argList})>(&#{name})|] + +argTypeM :: RecMap -> Argument -> MDoc +argTypeM _ (SerialArgument _ _) = serialType +argTypeM recmap (NativeArgument _ c) = showType recmap c +argTypeM _ (PassThroughArgument _) = serialType + +makeDispatch :: [ExprM One] -> MDoc +makeDispatch ms = block 4 "switch(cmdID)" (vsep (map makeCase ms)) + where + makeCase :: ExprM One -> MDoc + makeCase (ManifoldM (metaId->i) args _) = + let args' = take (length args) $ map (\j -> "argv[" <> viaShow j <> "]") ([2..] :: [Int]) + in + (nest 4 . vsep) + [ "case" <+> viaShow i <> ":" + , "result = " <> manNamer i <> tupled args' <> ";" + , "break;" + ] + makeCase _ = error "Every ExprM must start with a manifold object" + +showType :: RecMap -> TypeP -> MDoc +showType _ (UnkP _) = serialType +showType _ (VarP (PV _ _ v)) = pretty v +showType recmap t@(FunP _ _) = showTypeM recmap (typeP2typeM t) +showType recmap (ArrP (PV _ _ v) ts) = pretty $ expandMacro v (map (render . showType recmap) ts) +showType recmap (NamP _ v@(PV _ _ "struct") _ rs) = + -- handle autogenerated structs + case lookup (v, map fst rs) recmap of + (Just rec) -> recName rec <> typeParams recmap (zip (map snd (recFields rec)) (map snd rs)) + Nothing -> error "Should not happen" +showType recmap (NamP _ (PV _ _ s) ps _) = + pretty s <> encloseSep "<" ">" "," (map (showType recmap) ps) + +typeParams :: RecMap -> [(Maybe TypeP, TypeP)] -> MDoc +typeParams recmap ts + = case [showTypeM recmap (Native t) | (Nothing, t) <- ts] of + [] -> "" + ds -> encloseSep "<" ">" "," ds + +showTypeM :: RecMap -> TypeM -> MDoc +showTypeM _ Passthrough = serialType +showTypeM _ (Serial _) = serialType +showTypeM recmap (Native t) = showType recmap t +showTypeM recmap (Function ts t) + = "std::function<" <> showTypeM recmap t + <> "(" <> cat (punctuate "," (map (showTypeM recmap) ts)) <> ")>" + +-- for use in making schema, where the native type is needed +showNativeTypeM :: RecMap -> TypeM -> MorlocMonad MDoc +showNativeTypeM recmap (Serial t) = return $ showTypeM recmap (Native t) +showNativeTypeM recmap (Native t) = return $ showTypeM recmap (Native t) +showNativeTypeM _ _ = MM.throwError . OtherError $ "Expected a native or serialized type" + + +collectRecords :: ExprM One -> [(PVar, GMeta, [(PVar, TypeP)])] +collectRecords e0 = f (gmetaOf e0) e0 where + f _ (ManifoldM m _ e) = f m e + f m (ForeignInterfaceM t e) = cleanRecord m t ++ f m e + f m (PoolCallM t _ _ _) = cleanRecord m t + f m (LetM _ e1 e2) = f m e1 ++ f m e2 + f m (AppM e es) = f m e ++ conmap (f m) es + f m (LamM _ e) = f m e + f m (AccM e _) = f m e + f m (ListM t es) = cleanRecord m t ++ conmap (f m) es + f m (TupleM t es) = cleanRecord m t ++ conmap (f m) es + f m (RecordM t rs) = cleanRecord m t ++ conmap (f m . snd) rs + f m (SerializeM s e) + = cleanRecord m (Native (serialAstToType' s)) ++ f m e + f m (DeserializeM s e) + = cleanRecord m (Serial (serialAstToType' s)) ++ f m e + f m (ReturnM e) = f m e + f m (BndVarM t _) = cleanRecord m t + f m (LetVarM t _) = cleanRecord m t + f _ _ = [] + +cleanRecord :: GMeta -> TypeM -> [(PVar, GMeta, [(PVar, TypeP)])] +cleanRecord m tm = case typeOfTypeM tm of + (Just t) -> toRecord t + Nothing -> [] + where + toRecord :: TypeP -> [(PVar, GMeta, [(PVar, TypeP)])] + toRecord (UnkP _) = [] + toRecord (VarP _) = [] + toRecord (FunP t1 t2) = toRecord t1 ++ toRecord t2 + toRecord (ArrP _ ts) = conmap toRecord ts + toRecord (NamP _ v@(PV _ _ "struct") _ rs) = (v, m, rs) : conmap toRecord (map snd rs) + toRecord (NamP _ _ _ rs) = conmap toRecord (map snd rs) + +-- unify records with the same name/keys +unifyRecords + :: [(PVar -- The "v" in (NamP _ v@(PV _ _ "struct") _ rs) + , GMeta -- The GMeta object stored in the records ManifoldM term + , [(PVar, TypeP)]) -- key/type terms for this record + ] -> RecMap +unifyRecords xs + = zipWith (\i ((v,ks),es) -> ((v,ks), RecEntry (structName i v) es)) [1..] + . map (\((v,m,ks), rss) -> ((v,ks), [unifyField m fs | fs <- transpose rss])) + . map (\((v,ks), rss) -> ((v, fst (head rss),ks), map snd rss)) + -- [((record_name, record_keys), [(GMeta, [(key,type)])])] + -- associate unique pairs of record name and keys with their edge types + . groupSort + . unique + $ [((v, map fst es), (m, es)) | (v, m, es) <- xs] + +structName :: Int -> PVar -> MDoc +structName i (PV _ (Just v1) "struct") = "mlc_" <> pretty v1 <> "_" <> pretty i +structName _ (PV _ _ v) = pretty v + +unifyField :: GMeta -> [(PVar, TypeP)] -> (PVar, Maybe TypeP) +unifyField _ [] = error "Empty field" +unifyField _ rs@((v,_):_) + | not (all ((==) v) (map fst rs)) + = error $ "Bad record - unequal fields: " <> show (unique rs) + | otherwise = case unique (map snd rs) of + [t] -> (v, Just t) + _ -> (v, Nothing) + +generateAnonymousStructs :: RecMap -> ([MDoc],[MDoc]) +generateAnonymousStructs recmap + = (\xs -> (conmap fst xs, conmap snd xs)) + . map (makeSerializers recmap) + . reverse + . map snd + $ recmap + +makeSerializers :: RecMap -> RecEntry -> ([MDoc],[MDoc]) +makeSerializers recmap rec + = ([structDecl, serialDecl, deserialDecl], [serializer, deserializer]) + where + templateTerms = zipWith (<>) (repeat "T") (map pretty ([1..] :: [Int])) + rs' = zip templateTerms (recFields rec) + + params = [t | (t, (_, Nothing)) <- rs'] + rname = recName rec + rtype = rname <> recordTemplate [v | (v, (_, Nothing)) <- rs'] + fields = [(pretty k, maybe t (showType recmap) v') | (t, (PV _ _ k, v')) <- rs'] + + structDecl = structTypedefTemplate params rname fields + serialDecl = serialHeaderTemplate params rtype + deserialDecl = deserialHeaderTemplate params rtype + + serializer = serializerTemplate params rtype fields + deserializer = deserializerTemplate False params rtype fields + + + +generateSourcedSerializers :: [ExprM One] -> ([MDoc],[MDoc]) +generateSourcedSerializers + = foldl groupQuad ([],[]) + . Map.elems + . Map.mapMaybeWithKey makeSerial + . foldl collect' Map.empty + where + collect' + :: Map.Map TVar (Type, [TVar]) + -> ExprM One + -> Map.Map TVar (Type, [TVar]) + collect' m (ManifoldM g _ e) = collect' (Map.union m (metaTypedefs g)) e + collect' m (ForeignInterfaceM _ e) = collect' m e + collect' m (LetM _ e1 e2) = Map.union (collect' m e1) (collect' m e2) + collect' m (AppM e es) = Map.unions $ collect' m e : map (collect' m) es + collect' m (LamM _ e) = collect' m e + collect' m (AccM e _) = collect' m e + collect' m (ListM _ es) = Map.unions $ map (collect' m) es + collect' m (TupleM _ es) = Map.unions $ map (collect' m) es + collect' m (RecordM _ entries) = Map.unions $ map (collect' m) (map snd entries) + collect' m (SerializeM _ e) = collect' m e + collect' m (DeserializeM _ e) = collect' m e + collect' m (ReturnM e) = collect' m e + collect' m _ = m + + groupQuad :: ([a],[a]) -> (a, a, a, a) -> ([a],[a]) + groupQuad (xs,ys) (x1, y1, x2, y2) = (x1:x2:xs, y1:y2:ys) + + makeSerial :: TVar -> (Type, [TVar]) -> Maybe (MDoc, MDoc, MDoc, MDoc) + makeSerial _ (NamT _ (TV _ "struct") _ _, _) = Nothing + makeSerial (TV (Just CppLang) _) (NamT r (TV _ v) _ rs, ps) + = Just (serialDecl, serializer, deserialDecl, deserializer) where + + templateTerms = ["T" <> pretty p | (TV _ p) <- ps] + + params = map (\p -> "T" <> pretty (unTVar p)) ps + rtype = pretty v <> recordTemplate templateTerms + fields = [(pretty k, showDefType ps t) | (k, t) <- rs] + + serialDecl = serialHeaderTemplate params rtype + deserialDecl = deserialHeaderTemplate params rtype + + serializer = serializerTemplate params rtype fields + + deserializer = deserializerTemplate (r == NamObject) params rtype fields + makeSerial _ _ = Nothing + + showDefType :: [TVar] -> Type -> MDoc + showDefType ps (UnkT v@(TV _ s)) + | elem v ps = "T" <> pretty s + | otherwise = pretty s + showDefType ps (VarT v@(TV _ s)) + | elem v ps = "T" <> pretty s + | otherwise = pretty s + showDefType _ (FunT _ _) = error "Cannot serialize functions" + showDefType ps (ArrT (TV _ v) ts) = pretty $ expandMacro v (map (render . showDefType ps) ts) + showDefType ps (NamT _ (TV _ v) ts _) + = pretty v <> encloseSep "<" ">" "," (map (showDefType ps) ts) + + +makeTemplateHeader :: [MDoc] -> MDoc +makeTemplateHeader [] = "" +makeTemplateHeader ts = "template" <+> encloseSep "<" ">" "," ["class" <+> t | t <- ts] + +recordTemplate :: [MDoc] -> MDoc +recordTemplate [] = "" +recordTemplate ts = encloseSep "<" ">" "," ts + + + +-- Example +-- > template +-- > struct Person +-- > { +-- > std::vector name; +-- > std::vector info; +-- > }; +structTypedefTemplate + :: [MDoc] -- template parameters (e.g., ["T"]) + -> MDoc -- the name of the structure (e.g., "Person") + -> [(MDoc, MDoc)] -- key and type for all fields + -> MDoc -- structure definition +structTypedefTemplate params rname fields = vsep [template, struct] where + template = makeTemplateHeader params + struct = block 4 ("struct" <+> rname) + (vsep [t <+> k <> ";" | (k,t) <- fields]) <> ";" + + + +-- Example +-- > template +-- > std::string serialize(person x, person schema); +serialHeaderTemplate :: [MDoc] -> MDoc -> MDoc +serialHeaderTemplate params rtype = vsep [template, prototype] + where + template = makeTemplateHeader params + prototype = [idoc|std::string serialize(#{rtype} x, #{rtype} schema);|] + + + +-- Example: +-- > template +-- > bool deserialize(const std::string json, size_t &i, person &x); +deserialHeaderTemplate :: [MDoc] -> MDoc -> MDoc +deserialHeaderTemplate params rtype = vsep [template, prototype] + where + template = makeTemplateHeader params + prototype = [idoc|bool deserialize(const std::string json, size_t &i, #{rtype} &x);|] + + + +serializerTemplate + :: [MDoc] -- template parameters + -> MDoc -- type of thing being serialized + -> [(MDoc, MDoc)] -- key and type for all fields + -> MDoc -- output serializer function +serializerTemplate params rtype fields = [idoc| +#{makeTemplateHeader params} +std::string serialize(#{rtype} x, #{rtype} schema){ + #{schemata} + std::ostringstream json; + json << "{" << #{align $ vsep (punctuate " << ',' <<" writers)} << "}"; + return json.str(); +} +|] where + schemata = align $ vsep (map (\(k,t) -> t <+> k <> "_" <> ";") fields) + writers = map (\(k,_) -> dquotes ("\\\"" <> k <> "\\\"" <> ":") + <+> "<<" <+> [idoc|serialize(x.#{k}, #{k}_)|] ) fields + + + +deserializerTemplate + :: Bool -- build object with constructor + -> [MDoc] -- ^ template parameters + -> MDoc -- ^ type of thing being deserialized + -> [(MDoc, MDoc)] -- ^ key and type for all fields + -> MDoc -- ^ output deserializer function +deserializerTemplate isObj params rtype fields + = [idoc| +#{makeTemplateHeader params} +bool deserialize(const std::string json, size_t &i, #{rtype} &x){ + #{schemata} + try { + whitespace(json, i); + if(! match(json, "{", i)) + throw 1; + whitespace(json, i); + #{fieldParsers} + if(! match(json, "}", i)) + throw 1; + whitespace(json, i); + } catch (int e) { + return false; + } + #{assign} + return true; +} +|] where + schemata = align $ vsep (map (\(k,t) -> t <+> k <> "_" <> ";") fields) + fieldParsers = align $ vsep (punctuate parseComma (map (makeParseField . fst) fields)) + values = [k <> "_" | (k,_) <- fields] + assign = if isObj + then [idoc|#{rtype} y#{tupled values}; x = y;|] + else let obj = encloseSep "{" "}" "," values + in [idoc|#{rtype} y = #{obj}; x = y;|] + +parseComma = [idoc| +if(! match(json, ",", i)) + throw 800; +whitespace(json, i);|] + +makeParseField :: MDoc -> MDoc +makeParseField field = [idoc| +if(! match(json, "\"#{field}\"", i)) + throw 1; +whitespace(json, i); +if(! match(json, ":", i)) + throw 1; +whitespace(json, i); +if(! deserialize(json, i, #{field}_)) + throw 1; +whitespace(json, i);|] + + + +makeMain :: [MDoc] -> [MDoc] -> [MDoc] -> [MDoc] -> MDoc -> MDoc +makeMain includes signatures serialization manifolds dispatch = [idoc|#include +#include +#include +#include +#include +#include +#include // for std::transform + +#{Src.foreignCallFunction} + +#{Src.serializationHandling} + +#{vsep includes} + +#{vsep signatures} + +#{vsep serialization} + +#{vsep manifolds} + +int main(int argc, char * argv[]) +{ + int cmdID; + #{serialType} result; + cmdID = std::stoi(argv[1]); + #{dispatch} + std::cout << result << std::endl; + return 0; +} +|] diff --git a/library/Morloc/CodeGenerator/Grammars/Translator/Python3.hs b/library/Morloc/CodeGenerator/Grammars/Translator/Python3.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Grammars/Translator/Python3.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +{-| +Module : Morloc.CodeGenerator.Grammars.Translator.Python3 +Description : Python3 translator +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.CodeGenerator.Grammars.Translator.Python3 + ( + translate + , preprocess + ) where + +import Morloc.CodeGenerator.Namespace +import Morloc.CodeGenerator.Serial (isSerializable, prettySerialOne, serialAstToType) +import Morloc.CodeGenerator.Grammars.Common +import Morloc.Data.Doc +import Morloc.Quasi +import qualified Morloc.Config as MC +import qualified Morloc.Monad as MM +import qualified Morloc.Data.Text as MT +import qualified System.FilePath as SF +import qualified Data.Char as DC + +-- tree rewrites +preprocess :: ExprM Many -> MorlocMonad (ExprM Many) +preprocess = invertExprM + +translate :: [Source] -> [ExprM One] -> MorlocMonad MDoc +translate srcs es = do + -- setup library paths + lib <- fmap pretty $ MM.asks MC.configLibrary + + -- translate sources + includeDocs <- mapM + translateSource + (unique . catMaybes . map srcPath $ srcs) + + -- diagnostics + liftIO . putDoc $ (vsep $ map prettyExprM es) + + -- translate each manifold tree, rooted on a call from nexus or another pool + mDocs <- mapM translateManifold es + + -- make code for dispatching to manifolds + let dispatch = makeDispatch es + + return $ makePool lib includeDocs mDocs dispatch + +-- create an internal variable based on a unique id +letNamer :: Int -> MDoc +letNamer i = "a" <> viaShow i + +-- create namer for manifold positional arguments +bndNamer :: Int -> MDoc +bndNamer i = "x" <> viaShow i + +-- create a name for a manifold based on a unique id +manNamer :: Int -> MDoc +manNamer i = "m" <> viaShow i + +-- FIXME: should definitely use namespaces here, not `import *` +translateSource :: Path -> MorlocMonad MDoc +translateSource (Path s) = do + (Path lib) <- MM.asks configLibrary + let moduleStr = pretty + . MT.liftToText (map DC.toLower) + . MT.replace "/" "." + . MT.stripPrefixIfPresent "/" -- strip the leading slash (if present) + . MT.stripPrefixIfPresent "./" -- no path if relative to here + . MT.stripPrefixIfPresent lib -- make the path relative to the library + . MT.liftToText SF.dropExtensions + $ s + return $ "from" <+> moduleStr <+> "import *" + +tupleKey :: Int -> MDoc -> MDoc +tupleKey i v = [idoc|#{v}[#{pretty i}]|] + +selectAccessor :: NamType -> MT.Text -> MorlocMonad (MDoc -> MDoc -> MDoc) +selectAccessor NamTable "dict" = return recordAccess +selectAccessor NamRecord _ = return recordAccess +selectAccessor NamTable _ = return objectAccess +selectAccessor NamObject _ = return objectAccess + +recordAccess :: MDoc -> MDoc -> MDoc +recordAccess record field = record <> "[" <> dquotes field <> "]" + +objectAccess :: MDoc -> MDoc -> MDoc +objectAccess object field = object <> "." <> field + +serialize :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) +serialize v0 s0 = do + (ms, v1) <- serialize' v0 s0 + t <- serialAstToType s0 + schema <- typeSchema t + let v2 = "mlc_serialize" <> tupled [v1, schema] + return (v2, ms) + where + serialize' :: MDoc -> SerialAST One -> MorlocMonad ([MDoc], MDoc) + serialize' v s + | isSerializable s = return ([], v) + | otherwise = construct v s + + construct :: MDoc -> SerialAST One -> MorlocMonad ([MDoc], MDoc) + construct v (SerialPack _ (One (p, s))) = do + unpacker <- case typePackerReverse p of + [] -> MM.throwError . SerializationError $ "No unpacker found" + (src:_) -> return . pretty . srcName $ src + serialize' [idoc|#{unpacker}(#{v})|] s + + construct v (SerialList s) = do + idx <- fmap pretty $ MM.getCounter + let v' = "s" <> idx + (before, x) <- serialize' [idoc|i#{idx}|] s + let push = [idoc|#{v'}.append(#{x})|] + lst = vsep [ [idoc|#{v'} = []|] + , nest 4 (vsep ([idoc|for i#{idx} in #{v}:|] : before ++ [push])) + ] + return ([lst], v') + + construct v (SerialTuple ss) = do + (befores, ss') <- fmap unzip $ zipWithM (\i s -> construct (tupleKey i v) s) [0..] ss + idx <- fmap pretty $ MM.getCounter + let v' = "s" <> idx + x = [idoc|#{v'} = #{tupled ss'}|] + return (concat befores ++ [x], v'); + + construct v (SerialObject namType (PV _ _ constructor) _ rs) = do + accessField <- selectAccessor namType constructor + (befores, ss') <- fmap unzip $ mapM (\(PV _ _ k,s) -> serialize' (accessField v (pretty k)) s) rs + idx <- fmap pretty $ MM.getCounter + let v' = "s" <> idx + entries = zipWith (\(PV _ _ key) val -> pretty key <> "=" <> val) + (map fst rs) ss' + decl = [idoc|#{v'} = dict#{tupled (entries)};|] + return (concat befores ++ [decl], v'); + + construct _ s = MM.throwError . SerializationError . render + $ "construct: " <> prettySerialOne s + +deserialize :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) +deserialize v0 s0 + | isSerializable s0 = do + t <- serialAstToType s0 + schema <- typeSchema t + let deserializing = [idoc|mlc_deserialize(#{v0}, #{schema});|] + return (deserializing, []) + | otherwise = do + idx <- fmap pretty $ MM.getCounter + t <- serialAstToType s0 + schema <- typeSchema t + let rawvar = "s" <> idx + deserializing = [idoc|#{rawvar} = mlc_deserialize(#{v0}, #{schema});|] + (x, befores) <- check rawvar s0 + return (x, deserializing:befores) + where + check :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) + check v s + | isSerializable s = return (v, []) + | otherwise = construct v s + + construct :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) + construct v (SerialPack _ (One (p, s'))) = do + packer <- case typePackerForward p of + [] -> MM.throwError . SerializationError $ "No packer found" + (x:_) -> return . pretty . srcName $ x + (x, before) <- check v s' + let deserialized = [idoc|#{packer}(#{x})|] + return (deserialized, before) + + construct v (SerialList s) = do + idx <- fmap pretty $ MM.getCounter + let v' = "s" <> idx + (x, before) <- check [idoc|i#{idx}|] s + let push = [idoc|#{v'}.append(#{x});|] + lst = vsep [ [idoc|#{v'} = [];|] + , nest 4 (vsep ([idoc|for i#{idx} in #{v}:|] : before ++ [push])) + ] + return (v', [lst]) + + construct v (SerialTuple ss) = do + (ss', befores) <- fmap unzip $ zipWithM (\i s -> check (tupleKey i v) s) [0..] ss + idx <- fmap pretty $ MM.getCounter + let v' = "s" <> idx + x = [idoc|#{v'} = #{tupled ss'};|] + return (v', concat befores ++ [x]); + + construct v (SerialObject namType (PV _ _ constructor) _ rs) = do + idx <- fmap pretty $ MM.getCounter + accessField <- selectAccessor namType constructor + (ss', befores) <- fmap unzip $ mapM (\(PV _ _ k,s) -> check (accessField v (pretty k)) s) rs + let v' = "s" <> idx + entries = zipWith (\(PV _ _ key) val -> pretty key <> "=" <> val) + (map fst rs) ss' + decl = [idoc|#{v'} = #{pretty constructor}#{tupled entries};|] + return (v', concat befores ++ [decl]); + + construct _ s = MM.throwError . SerializationError . render + $ "deserializeDescend: " <> prettySerialOne s + + + +-- break a call tree into manifolds +translateManifold :: ExprM One -> MorlocMonad MDoc +translateManifold m0@(ManifoldM _ args0 _) = do + MM.startCounter + (vsep . punctuate line . (\(x,_,_)->x)) <$> f args0 m0 + where + + f :: [Argument] + -> ExprM One + -> MorlocMonad + ( [MDoc] -- completely generated manifolds + , MDoc -- a tag for the returned expression + , [MDoc] -- lines to precede the returned expression + ) + f pargs m@(ManifoldM (metaId->i) args e) = do + (ms', e', rs') <- f args e + let mname = manNamer i + def = "def" <+> mname <> tupled (map makeArgument args) <> ":" + mdoc = nest 4 (vsep $ def:rs' ++ [e']) + call <- return $ case (splitArgs args pargs, nargsTypeM (typeOfExprM m)) of + ((rs, []), _) -> mname <> tupled (map makeArgument rs) -- covers #1, #2 and #4 + (([], _ ), _) -> mname + ((rs, vs), _) -> makeLambda vs (mname <> tupled (map makeArgument (rs ++ vs))) -- covers #5 + return (mdoc : ms', call, []) + + f _ (PoolCallM _ _ cmds args) = do + let call = "_morloc_foreign_call(" <> list(map dquotes cmds ++ map makeArgument args) <> ")" + return ([], call, []) + + f _ (ForeignInterfaceM _ _) = MM.throwError . CallTheMonkeys $ + "Foreign interfaces should have been resolved before passed to the translators" + + f args (LetM i e1 e2) = do + (ms1', e1', rs1) <- (f args) e1 + (ms2', e2', rs2) <- (f args) e2 + let rs = rs1 ++ [ letNamer i <+> "=" <+> e1' ] ++ rs2 + return (ms1' ++ ms2', e2', rs) + + f args (AppM (SrcM _ src) xs) = do + (mss', xs', rss') <- mapM (f args) xs |>> unzip3 + return (concat mss', pretty (srcName src) <> tupled xs', concat rss') + + f _ (AppM _ _) = error "Can only apply functions" + + f _ (SrcM _ src) = return ([], pretty (srcName src), []) + + f _ (LamM _ _) = undefined -- FIXME: this is defined in R + + f _ (BndVarM _ i) = return ([], bndNamer i, []) + + f _ (LetVarM _ i) = return ([], letNamer i, []) + + f args (AccM e k) = do + (ms, e', ps) <- f args e + x <- case typeOfTypeM (typeOfExprM e) of + (Just (NamP r (PV _ _ v) _ _)) -> selectAccessor r v <*> pure e' <*> pure (pretty k) + _ -> MM.throwError . CallTheMonkeys $ "Bad record access" + return (ms, x, ps) + + f args (ListM _ es) = do + (mss', es', rss') <- mapM (f args) es |>> unzip3 + return (concat mss', list es', concat rss') + + f args (TupleM _ es) = do + (mss', es', rss') <- mapM (f args) es |>> unzip3 + return (concat mss', tupled es', concat rss') + + f args (RecordM _ entries) = do + (mss', es', rss') <- mapM (f args . snd) entries |>> unzip3 + let entries' = zipWith (\k v -> pretty k <> "=" <> v) (map fst entries) es' + return (concat mss', "OrderedDict" <> tupled entries', concat rss') + + f _ (LogM _ x) = return ([], if x then "True" else "False", []) + + f _ (NumM _ x) = return ([], viaShow x, []) + + f _ (StrM _ x) = return ([], dquotes $ pretty x, []) + + f _ (NullM _) = return ([], "None", []) + + f args (SerializeM s e) = do + (ms, e', rs1) <- f args e + (serialized, rs2) <- serialize e' s + return (ms, serialized, rs1 ++ rs2) + + f args (DeserializeM s e) = do + (ms, e', rs1) <- f args e + (deserialized, rs2) <- deserialize e' s + return (ms, deserialized, rs1 ++ rs2) + + f args (ReturnM e) = do + (ms, e', rs) <- f args e + return (ms, "return(" <> e' <> ")", rs) +translateManifold _ = error "Every ExprM object must start with a Manifold term" + + + +makeLambda :: [Argument] -> MDoc -> MDoc +makeLambda args body = "lambda" <+> hsep (punctuate "," (map makeArgument args)) <> ":" <+> body + +makeArgument :: Argument -> MDoc +makeArgument (SerialArgument v _) = bndNamer v +makeArgument (NativeArgument v _) = bndNamer v +makeArgument (PassThroughArgument v) = bndNamer v + +makeDispatch :: [ExprM One] -> MDoc +makeDispatch ms = align . vsep $ + [ align . vsep $ ["dispatch = {", indent 4 (vsep $ map entry ms), "}"] + , "f = dispatch[cmdID]" + ] + where + entry :: ExprM One -> MDoc + entry (ManifoldM (metaId->i) _ _) + = pretty i <> ":" <+> manNamer i <> "," + entry _ = error "Expected ManifoldM" + +typeSchema :: TypeP -> MorlocMonad MDoc +typeSchema t0 = f <$> type2jsontype t0 + where + f :: JsonType -> MDoc + f (VarJ v) = lst [var v, "None"] + f (ArrJ v ts) = lst [var v, lst (map f ts)] + f (NamJ "dict" es) = lst [dquotes "dict", dict (map entry es)] + f (NamJ "record" es) = lst [dquotes "record", dict (map entry es)] + f (NamJ v es) = lst [pretty v, dict (map entry es)] + + entry :: (MT.Text, JsonType) -> MDoc + entry (v, t) = pretty v <> "=" <> f t + + dict :: [MDoc] -> MDoc + dict xs = "OrderedDict" <> lst xs + + lst :: [MDoc] -> MDoc + lst xs = encloseSep "(" ")" "," xs + + var :: MT.Text -> MDoc + var v = dquotes (pretty v) + +makePool :: MDoc -> [MDoc] -> [MDoc] -> MDoc -> MDoc +makePool lib includeDocs manifolds dispatch = [idoc|#!/usr/bin/env python + +import sys +import subprocess +import json +from pymorlocinternals import (mlc_serialize, mlc_deserialize) +from collections import OrderedDict + +sys.path = ["#{lib}"] + sys.path + +#{vsep includeDocs} + +def _morloc_foreign_call(args): + try: + sysObj = subprocess.run( + args, + stdout=subprocess.PIPE, + check=True + ) + except subprocess.CalledProcessError as e: + sys.exit(str(e)) + + return(sysObj.stdout.decode("ascii")) + +#{vsep manifolds} + +if __name__ == '__main__': + try: + cmdID = int(sys.argv[1]) + except IndexError: + sys.exit("Internal error in {}: no manifold id found".format(sys.argv[0])) + except ValueError: + sys.exit("Internal error in {}: expected integer manifold id".format(sys.argv[0])) + try: + #{dispatch} + except KeyError: + sys.exit("Internal error in {}: no manifold found with id={}".format(sys.argv[0], cmdID)) + + result = f(*sys.argv[2:]) + + print(result) +|] diff --git a/library/Morloc/CodeGenerator/Grammars/Translator/R.hs b/library/Morloc/CodeGenerator/Grammars/Translator/R.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Grammars/Translator/R.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +{-| +Module : Morloc.CodeGenerator.Grammars.Translator.R +Description : R translator +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.CodeGenerator.Grammars.Translator.R + ( + translate + , preprocess + ) where + +import Morloc.CodeGenerator.Namespace +import Morloc.CodeGenerator.Serial (isSerializable, prettySerialOne, serialAstToType) +import Morloc.CodeGenerator.Grammars.Common +import Morloc.Data.Doc +import Morloc.Quasi +import qualified Morloc.Monad as MM +import qualified Morloc.Data.Text as MT + +-- tree rewrites +preprocess :: ExprM Many -> MorlocMonad (ExprM Many) +preprocess = invertExprM + +translate :: [Source] -> [ExprM One] -> MorlocMonad MDoc +translate srcs es = do + -- translate sources + includeDocs <- mapM + translateSource + (unique . catMaybes . map srcPath $ srcs) + + -- diagnostics + liftIO . putDoc $ (vsep $ map prettyExprM es) + + -- translate each manifold tree, rooted on a call from nexus or another pool + mDocs <- mapM translateManifold es + + return $ makePool includeDocs mDocs + +letNamer :: Int -> MDoc +letNamer i = "a" <> viaShow i + +bndNamer :: Int -> MDoc +bndNamer i = "x" <> viaShow i + +manNamer :: Int -> MDoc +manNamer i = "m" <> viaShow i + +translateSource :: Path -> MorlocMonad MDoc +translateSource (Path p) = do + let p' = MT.stripPrefixIfPresent "./" p + return $ "source(" <> dquotes (pretty p') <> ")" + +tupleKey :: Int -> MDoc -> MDoc +tupleKey i v = [idoc|#{v}[[#{pretty i}]]|] + +recordAccess :: MDoc -> MDoc -> MDoc +recordAccess record field = record <> "$" <> field + +serialize :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) +serialize v0 s0 = do + (ms, v1) <- serialize' v0 s0 + t <- serialAstToType s0 + schema <- typeSchema t + let v2 = "rmorlocinternals::mlc_serialize" <> tupled [v1, schema] + return (v2, ms) + where + serialize' :: MDoc -> SerialAST One -> MorlocMonad ([MDoc], MDoc) + serialize' v s + | isSerializable s = return ([], v) + | otherwise = construct v s + + construct :: MDoc -> SerialAST One -> MorlocMonad ([MDoc], MDoc) + construct v (SerialPack _ (One (p, s))) = do + unpacker <- case typePackerReverse p of + [] -> MM.throwError . SerializationError $ "No unpacker found" + (src:_) -> return . pretty . srcName $ src + serialize' [idoc|#{unpacker}(#{v})|] s + + construct v (SerialList s) = do + idx <- fmap pretty $ MM.getCounter + let v' = "s" <> idx + (before, x) <- serialize' [idoc|i#{idx}|] s + let lst = block 4 [idoc|#{v'} <- lapply(#{v}, function(i#{idx})|] (vsep (before ++ [x])) <> ")" + return ([lst], v') + + construct v (SerialTuple ss) = do + (befores, ss') <- fmap unzip $ zipWithM (\i s -> construct (tupleKey i v) s) [1..] ss + idx <- fmap pretty $ MM.getCounter + let v' = "s" <> idx + x = [idoc|#{v'} <- list#{tupled ss'}|] + return (concat befores ++ [x], v'); + + construct v (SerialObject _ _ _ rs) = do + (befores, ss') <- fmap unzip $ mapM (\(PV _ _ k,s) -> serialize' (recordAccess v (pretty k)) s) rs + idx <- fmap pretty $ MM.getCounter + let v' = "s" <> idx + entries = zipWith (\(PV _ _ key) val -> pretty key <> "=" <> val) (map fst rs) ss' + decl = [idoc|#{v'} <- list#{tupled entries};|] + return (concat befores ++ [decl], v'); + + construct _ s = MM.throwError . SerializationError . render + $ "construct: " <> prettySerialOne s + + +deserialize :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) +deserialize v0 s0 + | isSerializable s0 = do + t <- serialAstToType s0 + schema <- typeSchema t + let deserializing = [idoc|rmorlocinternals::mlc_deserialize(#{v0}, #{schema});|] + return (deserializing, []) + | otherwise = do + idx <- fmap pretty $ MM.getCounter + t <- serialAstToType s0 + schema <- typeSchema t + let rawvar = "s" <> idx + deserializing = [idoc|#{rawvar} <- rmorlocinternals::mlc_deserialize(#{v0}, #{schema});|] + (x, befores) <- check rawvar s0 + return (x, deserializing:befores) + where + check :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) + check v s + | isSerializable s = return (v, []) + | otherwise = construct v s + + construct :: MDoc -> SerialAST One -> MorlocMonad (MDoc, [MDoc]) + construct v (SerialPack _ (One (p, s'))) = do + packer <- case typePackerForward p of + [] -> MM.throwError . SerializationError $ "No packer found" + (x:_) -> return . pretty . srcName $ x + (x, before) <- check v s' + let deserialized = [idoc|#{packer}(#{x})|] + return (deserialized, before) + + construct v (SerialList s) = do + idx <- fmap pretty $ MM.getCounter + let v' = "s" <> idx + (x, before) <- check [idoc|i#{idx}|] s + let lst = block 4 [idoc|#{v'} <- lapply(#{v}, function(i#{idx})|] (vsep (before ++ [x])) <> ")" + return (v', [lst]) + + construct v (SerialTuple ss) = do + (ss', befores) <- fmap unzip $ zipWithM (\i s -> check (tupleKey i v) s) [1..] ss + idx <- fmap pretty $ MM.getCounter + let v' = "s" <> idx + x = [idoc|#{v'} <- list#{tupled ss'};|] + return (v', concat befores ++ [x]); + + construct v (SerialObject _ (PV _ _ constructor) _ rs) = do + idx <- fmap pretty $ MM.getCounter + (ss', befores) <- fmap unzip $ mapM (\(PV _ _ k,s) -> check (recordAccess v (pretty k)) s) rs + let v' = "s" <> idx + entries = zipWith (\(PV _ _ key) val -> pretty key <> "=" <> val) (map fst rs) ss' + decl = [idoc|#{v'} <- #{pretty constructor}#{tupled entries};|] + return (v', concat befores ++ [decl]); + + construct _ s = MM.throwError . SerializationError . render + $ "deserializeDescend: " <> prettySerialOne s + + + +-- break a call tree into manifolds +translateManifold :: ExprM One -> MorlocMonad MDoc +translateManifold m0@(ManifoldM _ args0 _) = do + MM.startCounter + (vsep . punctuate line . (\(x,_,_)->x)) <$> f args0 m0 + where + + + f :: [Argument] -> ExprM One -> MorlocMonad ([MDoc], MDoc, [MDoc]) + f pargs m@(ManifoldM (metaId->i) args e) = do + (ms', body, rs') <- f args e + let decl = manNamer i <+> "<- function" <> tupled (map makeArgument args) + mdoc = block 4 decl (vsep $ rs' ++ [body]) + mname = manNamer i + -- TODO: handle partials BEFORE translation + call <- return $ case (splitArgs args pargs, nargsTypeM (typeOfExprM m)) of + ((rs, []), _) -> mname <> tupled (map makeArgument rs) -- covers #1, #2 and #4 + (([], _ ), _) -> mname + ((rs, vs), _) -> makeLambda vs (mname <> tupled (map makeArgument (rs ++ vs))) -- covers #5 + return (mdoc : ms', call, []) + + f _ (PoolCallM _ _ cmds args) = do + let quotedCmds = map dquotes cmds + callArgs = "list(" <> hsep (punctuate "," (drop 1 quotedCmds ++ map makeArgument args)) <> ")" + call = ".morloc_foreign_call" <> tupled([head quotedCmds, callArgs, dquotes "_", dquotes "_"]) + return ([], call, []) + + f _ (ForeignInterfaceM _ _) = MM.throwError . CallTheMonkeys $ + "Foreign interfaces should have been resolved before passed to the translators" + + f args (LetM i e1 e2) = do + (ms1', e1', rs1) <- (f args) e1 + (ms2', e2', rs2) <- (f args) e2 + let rs = rs1 ++ [ letNamer i <+> "<-" <+> e1' ] ++ rs2 + return (ms1' ++ ms2', e2', rs) + + f args (AppM (SrcM _ src) xs) = do + (mss', xs', rss') <- mapM (f args) xs |>> unzip3 + return (concat mss', pretty (srcName src) <> tupled xs', concat rss') + + f _ (AppM _ _) = error "Can only apply functions" + + f _ (SrcM _ src) = return ([], pretty (srcName src), []) + + f args (LamM labmdaArgs e) = do + (ms', e', rs) <- f args e + let vs = map (bndNamer . argId) labmdaArgs + return (ms', "function" <> tupled vs <> "{" <+> e' <> "}", rs) + + f _ (BndVarM _ i) = return ([], bndNamer i, []) + + f _ (LetVarM _ i) = return ([], letNamer i, []) + + f args (AccM e k) = do + (ms, e', ps) <- f args e + return (ms, e' <> "$" <> pretty k, ps) + + f args (ListM t es) = do + (mss', es', rss) <- mapM (f args) es |>> unzip3 + x' <- return $ case t of + (Native (ArrP _ [VarP et])) -> case et of + (PV _ _ "numeric") -> "c" <> tupled es' + (PV _ _ "logical") -> "c" <> tupled es' + (PV _ _ "character") -> "c" <> tupled es' + _ -> "list" <> tupled es' + _ -> "list" <> tupled es' + return (concat mss', x', concat rss) + + f args (TupleM _ es) = do + (mss', es', rss) <- mapM (f args) es |>> unzip3 + return (concat mss', "list" <> tupled es', concat rss) + + f args (RecordM _ entries) = do + (mss', es', rss) <- mapM (f args . snd) entries |>> unzip3 + let entries' = zipWith (\k v -> pretty k <> "=" <> v) (map fst entries) es' + return (concat mss', "list" <> tupled entries', concat rss) + + f _ (LogM _ x) = return ([], if x then "TRUE" else "FALSE", []) + + f _ (NumM _ x) = return ([], viaShow x, []) + + f _ (StrM _ x) = return ([], dquotes $ pretty x, []) + + f _ (NullM _) = return ([], "NULL", []) + + f args (SerializeM s e) = do + (ms, e', rs1) <- f args e + (serialized, rs2) <- serialize e' s + return (ms, serialized, rs1 ++ rs2) + + f args (DeserializeM s e) = do + (ms, e', rs1) <- f args e + (deserialized, rs2) <- deserialize e' s + return (ms, deserialized, rs1 ++ rs2) + + f args (ReturnM e) = do + (ms, e', rs) <- f args e + return (ms, e', rs) +translateManifold _ = error "Every ExprM object must start with a Manifold term" + +makeLambda :: [Argument] -> MDoc -> MDoc +makeLambda args body = "function" <+> tupled (map makeArgument args) <> "{" <> body <> "}" + +makeArgument :: Argument -> MDoc +makeArgument (SerialArgument v _) = bndNamer v +makeArgument (NativeArgument v _) = bndNamer v +makeArgument (PassThroughArgument v) = bndNamer v + +-- For R, the type schema is the JSON representation of the type +typeSchema :: TypeP -> MorlocMonad MDoc +typeSchema t = do + json <- jsontype2rjson <$> type2jsontype t + -- FIXME: Need to support single quotes inside strings + return $ "'" <> json <> "'" + +jsontype2rjson :: JsonType -> MDoc +jsontype2rjson (VarJ v) = dquotes (pretty v) +jsontype2rjson (ArrJ v ts) = "{" <> key <> ":" <> val <> "}" where + key = dquotes (pretty v) + val = encloseSep "[" "]" "," (map jsontype2rjson ts) +jsontype2rjson (NamJ objType rs) = + case objType of + "data.frame" -> "{" <> dquotes "data.frame" <> ":" <> encloseSep "{" "}" "," rs' <> "}" + "record" -> "{" <> dquotes "record" <> ":" <> encloseSep "{" "}" "," rs' <> "}" + _ -> encloseSep "{" "}" "," rs' + where + keys = map (dquotes . pretty) (map fst rs) + vals = map jsontype2rjson (map snd rs) + rs' = zipWith (\key val -> key <> ":" <> val) keys vals + +makePool :: [MDoc] -> [MDoc] -> MDoc +makePool sources manifolds = [idoc|#!/usr/bin/env Rscript + +#{vsep sources} + +.morloc_run <- function(f, args){ + fails <- "" + isOK <- TRUE + warns <- list() + notes <- capture.output( + { + value <- withCallingHandlers( + tryCatch( + do.call(f, args), + error = function(e) { + fails <<- e$message; + isOK <<- FALSE + } + ), + warning = function(w){ + warns <<- append(warns, w$message) + invokeRestart("muffleWarning") + } + ) + }, + type="message" + ) + list( + value = value, + isOK = isOK, + fails = fails, + warns = warns, + notes = notes + ) +} + +# dies on error, ignores warnings and messages +.morloc_try <- function(f, args, .log=stderr(), .pool="_", .name="_"){ + x <- .morloc_run(f=f, args=args) + location <- sprintf("%s::%s", .pool, .name) + if(! x$isOK){ + cat("** R errors in ", location, "\n", file=stderr()) + cat(x$fails, "\n", file=stderr()) + stop(1) + } + if(! is.null(.log)){ + lines = c() + if(length(x$warns) > 0){ + cat("** R warnings in ", location, "\n", file=stderr()) + cat(paste(unlist(x$warns), sep="\n"), file=stderr()) + } + if(length(x$notes) > 0){ + cat("** R messages in ", location, "\n", file=stderr()) + cat(paste(unlist(x$notes), sep="\n"), file=stderr()) + } + } + x$value +} + +.morloc_unpack <- function(unpacker, x, .pool, .name){ + x <- .morloc_try(f=unpacker, args=list(as.character(x)), .pool=.pool, .name=.name) + return(x) +} + +.morloc_foreign_call <- function(cmd, args, .pool, .name){ + .morloc_try(f=system2, args=list(cmd, args=args, stdout=TRUE), .pool=.pool, .name=.name) +} + +#{vsep manifolds} + +args <- as.list(commandArgs(trailingOnly=TRUE)) +if(length(args) == 0){ + stop("Expected 1 or more arguments") +} else { + cmdID <- args[[1]] + f_str <- paste0("m", cmdID) + if(exists(f_str)){ + f <- eval(parse(text=paste0("m", cmdID))) + result <- do.call(f, args[-1]) + cat(result, "\n") + } else { + cat("Could not find manifold '", cmdID, "'\n", file=stderr()) + } +} +|] diff --git a/library/Morloc/CodeGenerator/Grammars/Translator/Source/CppInternals.hs b/library/Morloc/CodeGenerator/Grammars/Translator/Source/CppInternals.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Grammars/Translator/Source/CppInternals.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +{-| +Module : Morloc.CodeGenerator.Grammars.Translator.Source.CppInternals +Description : C++ serialization source code +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental + +The @serializationHandling@ code is copy-and-pasted from +@morloc-project/cppmorlocinternals/serial.hpp@. This is dreadful, I know, and I +will find an alternative solution soon. + +-} + + + +module Morloc.CodeGenerator.Grammars.Translator.Source.CppInternals + ( foreignCallFunction + , serializationHandling + ) where + +import Morloc.Quasi + +foreignCallFunction = [idoc| +// Handle foreign calls. This function is used inside of C++ manifolds. Any +// changes in the name will require a mirrored change in the morloc code. +std::string foreign_call(std::string cmd){ + char buffer[256]; + std::string result = ""; + FILE* pipe = popen(cmd.c_str(), "r"); + while (fgets(buffer, sizeof buffer, pipe) != NULL) { + result += buffer; + } + pclose(pipe); + return(result); +} +|] + +serializationHandling = [idoc| +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + + +std::string serialize(bool x, bool schema); +std::string serialize(int x, int schema); +std::string serialize(int x, size_t schema); +std::string serialize(int x, long schema); +std::string serialize(double x, double schema); +std::string serialize(std::string x, std::string schema); + +template std::string serialize(A x); + +template +inline typename std::enable_if::type + _serialize_tuple(std::tuple x); + +template +inline typename std::enable_if::type + _serialize_tuple(std::tuple x); + +template +std::string serialize(std::tuple x, std::tuple schema); + +template +std::string serialize(std::vector x, std::vector schema); + +bool match(const std::string json, const std::string pattern, size_t &i); +void whitespace(const std::string json, size_t &i); +std::string digit_str(const std::string json, size_t &i); +double read_double(std::string json); + +// attempt a run a parser, on failure, consume no input +template +bool try_parse(std::string json, size_t &i, A &x, bool (*f)(std::string, size_t &, A &)); + +bool deserialize(const std::string json, size_t &i, bool &x); +bool deserialize(const std::string json, size_t &i, double &x); +bool deserialize(const std::string json, size_t &i, std::string &x); + +template +bool integer_deserialize(const std::string json, size_t &i, A &x); +bool deserialize(const std::string json, size_t &i, int &x); +bool deserialize(const std::string json, size_t &i, size_t &x); +bool deserialize(const std::string json, size_t &i, long &x); + +template +bool deserialize(const std::string json, size_t &i, std::vector &x); + +template +bool _deserialize_tuple(const std::string json, size_t &i, std::tuple &x); + +template +bool _deserialize_tuple(const std::string json, size_t &i, std::tuple &x); + +template +bool deserialize(const std::string json, size_t &i, std::tuple &x); + +template +A deserialize(const std::string json, A output); + + + + +/* ---------------------------------------------------------------------- */ +/* S E R I A L I Z A T I O N */ +/* ---------------------------------------------------------------------- */ + +std::string serialize(bool x, bool schema){ + return(x? "true" : "false"); +} + +std::string serialize(int x, int schema){ + std::ostringstream s; + s << x; + return(s.str()); +} +std::string serialize(int x, size_t schema){ + std::ostringstream s; + s << x; + return(s.str()); +} +std::string serialize(int x, long schema){ + std::ostringstream s; + s << x; + return(s.str()); +} + +std::string serialize(double x, double schema){ + std::ostringstream s; + s << std::setprecision(std::numeric_limits::digits10 + 2) << x; + return(s.str()); +} + +std::string serialize(std::string x, std::string schema){ + std::ostringstream s; + s << '"' << x << '"'; + return(s.str()); +} + +template +std::string serialize(std::vector x, std::vector schema){ + A element_schema; + std::ostringstream s; + s << "["; + for(size_t i = 0; i < x.size(); i++){ + s << serialize(x[i], element_schema); + if((i+1) < x.size()){ + s << ','; + } + } + s << "]"; + return (s.str()); +} + +template +std::string serialize(A x){ + return serialize(x, x); +} + +// adapted from stackoverflow #1198260 answer from emsr +template +inline typename std::enable_if::type + _serialize_tuple(std::tuple x) + { return ""; } + +template +inline typename std::enable_if::type + _serialize_tuple(std::tuple x) + { + return serialize(std::get(x)) + "," + _serialize_tuple(x); + } + +template +std::string serialize(std::tuple x, std::tuple schema){ + std::ostringstream ss; + ss << "["; + ss << _serialize_tuple(x); + std::string json = ss.str(); + // _serialize_tuple adds a terminal comma, replaced here with the end bracket + json[json.size() - 1] = ']'; + return json; +} + + +/* ---------------------------------------------------------------------- */ +/* P A R S E R S */ +/* ---------------------------------------------------------------------- */ + +// match a constant string, nothing is consumed on failure +bool match(const std::string json, const std::string pattern, size_t &i){ + for(size_t j = 0; j < pattern.size(); j++){ + if(j + i >= json.size()){ + return false; + } + if(json[j + i] != pattern[j]){ + return false; + } + } + i += pattern.size(); + return true; +} + +void whitespace(const std::string json, size_t &i){ + while(json[i] == ' ' || json[i] == '\n' || json[i] == '\t'){ + i++; + } +} + +// parse sequences of digits from a larger string +// used as part of a larger number parser +std::string digit_str(const std::string json, size_t &i){ + std::string num = ""; + while(json[i] >= '0' && json[i] <= '9'){ + num += json[i]; + i++; + } + return num; +} + +double read_double(std::string json){ + return std::stod(json.c_str()); +} + +// attempt a run a parser, on failure, consume no input +template +bool try_parse(std::string json, size_t &i, A &x, bool (*f)(std::string, size_t &, A &)){ + size_t j = i; + if(f(json, i, x)){ + return true; + } else { + i = j; + return false; + } +} + +/* ---------------------------------------------------------------------- */ +/* D E S E R I A L I Z A T I O N */ +/* ---------------------------------------------------------------------- */ + +// All combinator functions have the following general signature: +// +// template +// bool deserialize(const std::string json, size_t &i, A &x) + +// The return value represents parse success. +// The index may be incremented even on failure. + +// combinator parser for bool +bool deserialize(const std::string json, size_t &i, bool &x){ + if(match(json, "true", i)){ + x = true; + } + else if(match(json, "false", i)){ + x = false; + } + else { + return false; + } + return true; +} + +// combinator parser for doubles +bool deserialize(const std::string json, size_t &i, double &x){ + std::string lhs = ""; + std::string rhs = ""; + char sign = '+'; + + if(json[i] == '-'){ + sign = '-'; + i++; + } + lhs = digit_str(json, i); + if(json[i] == '.'){ + i++; + rhs = digit_str(json, i); + } else { + rhs = "0"; + } + + if(lhs.size() > 0){ + x = read_double(sign + lhs + '.' + rhs); + return true; + } else { + return false; + } +} + +// combinator parser for double-quoted strings +bool deserialize(const std::string json, size_t &i, std::string &x){ + try { + x = ""; + if(! match(json, "\"", i)){ + throw 1; + } + // TODO: add full JSON specification support (escapes, magic chars, etc) + while(i < json.size() && json[i] != '"'){ + x += json[i]; + i++; + } + if(! match(json, "\"", i)){ + throw 1; + } + } catch (int e) { + return false; + } + return true; +} + +template +bool integer_deserialize(const std::string json, size_t &i, A &x){ + char sign = '+'; + if(json[i] == '-'){ + sign = '-'; + i++; + } + std::string x_str = digit_str(json, i); + if(x_str.size() > 0){ + std::stringstream sstream(sign + x_str); + sstream >> x; + return true; + } + return false; +} +bool deserialize(const std::string json, size_t &i, int &x){ + return integer_deserialize(json, i, x); +} +bool deserialize(const std::string json, size_t &i, size_t &x){ + return integer_deserialize(json, i, x); +} +bool deserialize(const std::string json, size_t &i, long &x){ + return integer_deserialize(json, i, x); +} + +// parser for vectors +template +bool deserialize(const std::string json, size_t &i, std::vector &x){ + x = {}; + try { + if(! match(json, "[", i)){ + throw 1; + } + whitespace(json, i); + while(true){ + A element; + if(deserialize(json, i, element)){ + x.push_back(element); + whitespace(json, i); + match(json, ",", i); + whitespace(json, i); + } else { + break; + } + } + whitespace(json, i); + if(! match(json, "]", i)){ + throw 1; + } + } catch (int e) { + return false; + } + return true; +} + +template +bool _deserialize_tuple(const std::string json, size_t &i, std::tuple &x){ + A a; + if(! deserialize(json, i, a)){ + return false; + } + x = std::make_tuple(a); + return true; +} +template +bool _deserialize_tuple(const std::string json, size_t &i, std::tuple &x){ + A a; + // parse the next element + if(! deserialize(json, i, a)){ + return false; + } + // skip whitespace and the comma + whitespace(json, i); + if(! match(json, ",", i)){ + return false; + } + whitespace(json, i); + // parse the rest of the elements + std::tuple rs; + if(! _deserialize_tuple(json, i, rs)){ + return false; + } + // cons + x = std::tuple_cat(std::make_tuple(a), rs); + return true; +} +template +bool deserialize(const std::string json, size_t &i, std::tuple &x){ + try { + if(! match(json, "[", i)){ + throw 1; + } + whitespace(json, i); + if(! _deserialize_tuple(json, i, x)){ + throw 1; + } + whitespace(json, i); + if(! match(json, "]", i)){ + throw 1; + } + } catch (int e) { + return false; + } + return true; +} + +template +A deserialize(const std::string json, A output){ + size_t i = 0; + deserialize(json, i, output); + return output; +} + +template +std::tuple deserialize(const std::string json, std::tuple output){ + size_t i = 0; + deserialize(json, i, output); + return output; +} +|] diff --git a/library/Morloc/CodeGenerator/Internal.hs b/library/Morloc/CodeGenerator/Internal.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Internal.hs @@ -0,0 +1,69 @@ +{-| +Module : Morloc.CodeGenerator.Internal +Description : Miscellaneous backend utilities +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.CodeGenerator.Internal +( + weaveTypes + , weaveTypesGCP + , weaveTypesGCM + , typeP2typeM +) where + +import Morloc.CodeGenerator.Namespace +import qualified Morloc.Monad as MM + +weaveTypes :: Maybe Type -> Type -> MorlocMonad TypeP +weaveTypes g0 t0 = case (g0 >>= langOf, langOf t0) of + (_, Nothing) -> MM.throwError . CallTheMonkeys + $ "Expected a language-specific type as the second argument" + (Just _, _) -> MM.throwError . CallTheMonkeys + $ "Expected a general type as the first argument" + (_, Just lang) -> return $ f lang g0 t0 + where + f :: Lang -> Maybe Type -> Type -> TypeP + + f lang (Just (UnkT (TV _ v1))) (UnkT (TV _ v2)) = UnkP (PV lang (Just v1) v2) + f lang _ (UnkT (TV _ v)) = UnkP (PV lang Nothing v) + + f lang (Just (VarT (TV _ v1))) (VarT (TV _ v2)) = VarP (PV lang (Just v1) v2) + f lang _ (VarT (TV _ v2)) = VarP (PV lang Nothing v2) + + f lang (Just (FunT t11 t12)) (FunT t21 t22) + = FunP (f lang (Just t11) t21) (f lang (Just t12) t22) + f lang _ (FunT t1 t2) + = FunP (f lang Nothing t1) (f lang Nothing t2) + + f lang (Just (ArrT (TV _ v1) ts1)) (ArrT (TV _ v2) ts2) + = ArrP (PV lang (Just v1) v2) (zipWith (f lang) (map Just ts1) ts2) + f lang _ (ArrT (TV _ v) ts) + = ArrP (PV lang Nothing v) (map (f lang Nothing) ts) + + f lang (Just (NamT _ (TV _ v1) ts1 rs1)) (NamT r2 (TV _ v2) ts2 rs2) + = NamP r2 (PV lang (Just v1) v2) (zipWith (f lang) (map Just ts1) ts2) + $ zip + (zipWith (PV lang) (map (Just . fst) rs1) (map fst rs2)) + (zipWith (f lang) (map (Just . snd) rs1) (map snd rs2)) + f lang _ (NamT r (TV _ v) ts rs) + = NamP r (PV lang Nothing v) (map (f lang Nothing) ts) + $ zip + (map (PV lang Nothing) (map fst rs)) + (map (f lang Nothing) (map snd rs)) + + +weaveTypesGCP :: GMeta -> CType -> MorlocMonad TypeP +weaveTypesGCP g (CType t) = weaveTypes (unGType <$> metaGType g) t + +weaveTypesGCM :: GMeta -> CType -> MorlocMonad TypeM +weaveTypesGCM g (CType t) = typeP2typeM <$> weaveTypes (unGType <$> metaGType g) t + +typeP2typeM :: TypeP -> TypeM +typeP2typeM f@(FunP _ _) = case decompose f of + (inputs, output) -> Function (map typeP2typeM inputs) (typeP2typeM output) +typeP2typeM (UnkP _) = Passthrough +typeP2typeM t = Native t diff --git a/library/Morloc/CodeGenerator/Namespace.hs b/library/Morloc/CodeGenerator/Namespace.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Namespace.hs @@ -0,0 +1,255 @@ +{-| +Module : Morloc.CodeGenerator.Namespace +Description : All code generator types and datastructures +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.CodeGenerator.Namespace + ( module Morloc.Namespace + -- ** Types used in final translations + , TypeM(..) + , ExprM(..) + , Argument(..) + , JsonType(..) + , PVar(..) + , TypeP(..) + , JsonPath + , JsonAccessor(..) + , NexusCommand(..) + -- ** Serialization AST + , SerialAST(..) + , TypePacker(..) + ) where + +import Morloc.Namespace +import Data.Scientific (Scientific) +import Data.Text (Text) + +-- | Stores the language, general name and concrete name for a type expression +data PVar + = PV + Lang + (Maybe Text) + Text + deriving (Show, Eq, Ord) + +-- | A solved type coupling a language specific form to an optional general form +data TypeP + = UnkP PVar + | VarP PVar + | FunP TypeP TypeP + | ArrP PVar [TypeP] + | NamP NamType PVar [TypeP] [(PVar, TypeP)] + deriving (Show, Ord, Eq) + +type JsonPath = [JsonAccessor] +data JsonAccessor + = JsonIndex Int + | JsonKey Text + +data NexusCommand = NexusCommand + { commandName :: EVar -- ^ user-exposed subcommand name in the nexus + , commandType :: Type -- ^ the general type of the expression + , commandJson :: MDoc -- ^ JSON output with null's where values will be replaced + , commandArgs :: [EVar] -- ^ list of function arguments + , commandSubs :: [(JsonPath, Text, JsonPath)] + -- ^ list of tuples with values 1) path in JSON to value needs to be replaced + -- 2) the function argument from which to pull replacement value and 3) the + -- path to the replacement value + } + +instance Typelike TypeP where + typeOf (UnkP (PV lang _ t)) = UnkT (TV (Just lang) t) + typeOf (VarP (PV lang _ t)) = VarT (TV (Just lang) t) + typeOf (FunP t1 t2) = FunT (typeOf t1) (typeOf t2) + typeOf (ArrP (PV lang _ v) ts) = ArrT (TV (Just lang) v) (map typeOf ts) + typeOf (NamP r (PV lang _ t) ps es) + = NamT r (TV (Just lang) t) + (map typeOf ps) + (zip [v | (PV _ _ v, _) <- es] (map (typeOf . snd) es)) + + decompose (FunP t1 t2) = case decompose t2 of + (ts, finalType) -> (t1:ts, finalType) + decompose t = ([], t) + +-- | A tree describing how to (de)serialize an object +data SerialAST f + = SerialPack PVar (f (TypePacker, SerialAST f)) -- ^ use an (un)pack function to simplify an object + | SerialList (SerialAST f) + | SerialTuple [SerialAST f] + | SerialObject NamType PVar [TypeP] [(PVar, SerialAST f)] -- ^ make a record, table, or object + | SerialNum PVar + | SerialBool PVar + | SerialString PVar + | SerialNull PVar + | SerialUnknown PVar + -- ^ depending on the language, this may or may not raise an error down the + -- line, the parameter contains the variable name, which is useful only for + -- source code comments. + +data TypePacker = TypePacker + { typePackerType :: TypeP + , typePackerFrom :: TypeP + , typePackerForward :: [Source] + , typePackerReverse :: [Source] + } deriving (Show, Ord, Eq) + +-- | A simplified subset of the Type record +-- functions, existential, and universal types are removed +-- language-specific info is removed +data JsonType + = VarJ Text + -- ^ {"int"} + | ArrJ Text [JsonType] + -- ^ {"list":["int"]} + | NamJ Text [(Text, JsonType)] + -- ^ {"Foo":{"bar":"A","baz":"B"}} + deriving (Show, Ord, Eq) + +-- | An argument that is passed to a manifold +data Argument + = SerialArgument Int TypeP + -- ^ A serialized (e.g., JSON string) argument. The parameters are 1) + -- argument name (e.g., x), and 2) argument type (e.g., double). Some types + -- may not be serializable. This is OK, so long as they are only used in + -- functions of the same language. + | NativeArgument Int TypeP + -- ^ A native argument with the same parameters as above + | PassThroughArgument Int + -- ^ A serialized argument that is untyped in the current language. It cannot + -- be deserialized, but will be passed eventually to a foreign argument where it + -- does have a concrete type. + deriving (Show, Ord, Eq) + +data TypeM + = Passthrough -- ^ serialized data that cannot be deserialized in this language + | Serial TypeP -- ^ serialized data that may be deserialized in this language + | Native TypeP -- ^ an unserialized native data type + | Function [TypeM] TypeM -- ^ a function of n inputs and one output (cannot be serialized) + deriving(Show, Eq, Ord) + + +-- | A grammar that describes the implementation of the pools. Expressions in +-- this grammar will be directly translated into concrete code. +data ExprM f + = ManifoldM GMeta [Argument] (ExprM f) + -- ^ A wrapper around a single source call or (in some cases) a container. + + | ForeignInterfaceM + TypeM -- required type in the calling language + (ExprM f) -- expression in the foreign language + -- ^ A generic interface to an expression in another language. Currently it + -- will be resolved only to the specfic pool call interface type, where + -- system calls pass serialized information between pools in different + -- languages. Eventually, better methods will be added for certain pairs of + -- languages. + + | PoolCallM + TypeM -- serialized return data + Int -- foreign manifold id + [MDoc] -- shell command components that preceed the passed data + [Argument] -- argument passed to the foreign function (must be serialized) + -- ^ Make a system call to another language + + | LetM Int (ExprM f) (ExprM f) + -- ^ let syntax allows fine control over order of operations in the generated + -- code. The Int is an index for a LetVarM. It is also important in languages + -- such as C++ where values need to be declared with explicit types and + -- special constructors. + + | AppM + (ExprM f) -- ManifoldM | SrcM | LamM + [(ExprM f)] + + | SrcM TypeM Source + -- ^ a within pool function call (cis) + + | LamM [Argument] (ExprM f) + -- ^ Nothing Evar will be auto generated + + | BndVarM TypeM Int + -- ^ A lambda-bound variable. BndVarM only describes variables bound as positional + -- arguments in a manifold. The are represented as integers since the name + -- will be language-specific. + -- + -- In the rewrite step, morloc declarations are removed. So the expression: + -- x = 5 + -- foo y = mul x y + -- Is rewritten as: + -- \y -> mul 5 y + -- So BndVarM does NOT include variables defined in the morloc script. It only + -- includes lambda-bound variables. The only BndVarM is `y` (`mul` is SrcM). The + -- literal name "y" is replaced, though, with the integer 1. This is required in + -- order to avoid name conflicts in concrete languages, for example consider + -- the following (perfectly legal) morloc function: + -- foo for = mul for 2 + -- If the string "for" were retained as the variable name, this would fail in + -- many language where "for" is a keyword. + + | AccM (ExprM f) EVar + -- ^ Access a field in record ExprM + + | LetVarM TypeM Int + -- ^ An internally generated variable id used in let assignments. When + -- translated into a language, the integer will be used to generate a unique + -- variable name (e.g. [a0,a1,...] or [a,b,c,...]). + + -- containers + | ListM TypeM [(ExprM f)] + | TupleM TypeM [(ExprM f)] + | RecordM TypeM [(EVar, (ExprM f))] + + -- primitives + | LogM TypeM Bool + | NumM TypeM Scientific + | StrM TypeM Text + | NullM TypeM + + -- serialization + | SerializeM (SerialAST f) (ExprM f) + | DeserializeM (SerialAST f) (ExprM f) + + | ReturnM (ExprM f) + -- ^ The return value of a manifold. I need this to distinguish between the + -- values assigned in let expressions and the final return value. In some + -- languages, this may not be necessary (e.g., R). + + +instance HasOneLanguage (TypeP) where + langOf' (UnkP (PV lang _ _)) = lang + langOf' (VarP (PV lang _ _)) = lang + langOf' (FunP t _) = langOf' t + langOf' (ArrP (PV lang _ _) _) = lang + langOf' (NamP _ (PV lang _ _) _ _) = lang + +instance HasOneLanguage (TypeM) where + langOf Passthrough = Nothing + langOf (Serial t) = langOf t + langOf (Native t) = langOf t + langOf (Function _ t) = langOf t + +instance HasOneLanguage (ExprM f) where + -- langOf :: a -> Maybe Lang + langOf' (ManifoldM _ _ e) = langOf' e + langOf' (ForeignInterfaceM t _) = langOf' t + langOf' (PoolCallM t _ _ _) = langOf' t + langOf' (LetM _ _ e2) = langOf' e2 + langOf' (AppM e _) = langOf' e + langOf' (SrcM _ src) = srcLang src + langOf' (LamM _ e) = langOf' e + langOf' (BndVarM t _) = langOf' t + langOf' (LetVarM t _) = langOf' t + langOf' (AccM e _) = langOf' e + langOf' (ListM t _) = langOf' t + langOf' (TupleM t _) = langOf' t + langOf' (RecordM t _) = langOf' t + langOf' (LogM t _) = langOf' t + langOf' (NumM t _) = langOf' t + langOf' (StrM t _) = langOf' t + langOf' (NullM t) = langOf' t + langOf' (SerializeM _ e) = langOf' e + langOf' (DeserializeM _ e) = langOf' e + langOf' (ReturnM e) = langOf' e diff --git a/library/Morloc/CodeGenerator/Nexus.hs b/library/Morloc/CodeGenerator/Nexus.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Nexus.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +{-| +Module : Morloc.CodeGenerator.Nexus +Description : Templates for generating a Perl nexus +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Morloc.CodeGenerator.Nexus + ( generate + ) where + +import Morloc.Data.Doc +import Morloc.CodeGenerator.Namespace +import Morloc.Quasi +import Morloc.Pretty (prettyType) +import qualified Morloc.Data.Text as MT +import qualified Control.Monad as CM +import qualified Morloc.Config as MC +import qualified Morloc.Language as ML +import qualified Morloc.Monad as MM + +type FData = + ( MDoc -- pool call command, (e.g., "RScript pool.R 4 --") + , MDoc -- subcommand name + , TypeP -- argument type + ) + +generate :: [NexusCommand] -> [(TypeP, Int, Maybe EVar)] -> MorlocMonad Script +generate cs xs = do + let names = [pretty name | (_, _, Just name) <- xs] ++ map (pretty . commandName) cs + fdata <- CM.mapM getFData [(t, i, n) | (t, i, Just n) <- xs] -- [FData] + return $ + Script + { scriptBase = "nexus" + , scriptLang = ML.PerlLang + , scriptCode = Code . render $ main names fdata cs + , scriptCompilerFlags = [] + , scriptInclude = [] + } + +getFData :: (TypeP, Int, EVar) -> MorlocMonad FData +getFData (t, i, n) = do + config <- MM.ask + let lang = langOf t + case MC.buildPoolCallBase config lang i of + (Just cmds) -> return (hsep cmds, pretty n, t) + Nothing -> + MM.throwError . GeneratorError $ + "No execution method found for language: " <> ML.showLangName (fromJust lang) + +main :: [MDoc] -> [FData] -> [NexusCommand] -> MDoc +main names fdata cdata = + [idoc|#!/usr/bin/env perl + +use strict; +use warnings; + +use JSON::XS; + +my $json = JSON::XS->new->canonical; + +&printResult(&dispatch(@ARGV)); + +sub printResult { + my $result = shift; + print "$result"; +} + +sub dispatch { + if(scalar(@_) == 0){ + &usage(); + } + + my $cmd = shift; + my $result = undef; + + #{mapT names} + + if($cmd eq '-h' || $cmd eq '-?' || $cmd eq '--help' || $cmd eq '?'){ + &usage(); + } + + if(exists($cmds{$cmd})){ + $result = $cmds{$cmd}(@_); + } else { + print STDERR "Command '$cmd' not found\n"; + &usage(); + } + + return $result; +} + +#{usageT fdata cdata} + +#{vsep (map functionCT cdata ++ map functionT fdata)} + +|] + +mapT names = [idoc|my %cmds = #{tupled (map mapEntryT names)};|] + +mapEntryT n = [idoc|#{n} => \&call_#{n}|] + +usageT :: [FData] -> [NexusCommand] -> MDoc +usageT fdata cdata = + [idoc| +sub usage{ + print STDERR "The following commands are exported:\n"; + #{align $ vsep (map usageLineT fdata ++ map usageLineConst cdata)} + exit 0; +} +|] + +usageLineT :: FData -> MDoc +usageLineT (_, name, t) = vsep + ( [idoc|print STDERR " #{name}\n";|] + : writeTypes (gtypeOf t) + ) + +gtypeOf (UnkP (PV _ (Just v) _)) = UnkT (TV Nothing v) +gtypeOf (VarP (PV _ (Just v) _)) = VarT (TV Nothing v) +gtypeOf (FunP t1 t2) = FunT (gtypeOf t1) (gtypeOf t2) +gtypeOf (ArrP (PV _ (Just v) _) ts) = ArrT (TV Nothing v) (map gtypeOf ts) +gtypeOf (NamP r (PV _ (Just v) _) ps es) + = NamT r (TV Nothing v) + (map gtypeOf ps) + (zip [k | (PV _ (Just k) _, _) <- es] (map (gtypeOf . snd) es)) +gtypeOf _ = UnkT (TV Nothing "?") -- this shouldn't happen + +usageLineConst :: NexusCommand -> MDoc +usageLineConst cmd = vsep + ( [idoc|print STDERR " #{pretty (commandName cmd)}\n";|] + : writeTypes (commandType cmd) + ) + +writeTypes :: Type -> [MDoc] +writeTypes t = + let (inputs, output) = decompose t + in zipWith writeType [Just i | i <- [1..]] inputs ++ [writeType Nothing output] + +writeType :: Maybe Int -> Type -> MDoc +writeType (Just i) t = [idoc|print STDERR q{ param #{pretty i}: #{prettyType t}}, "\n";|] +writeType (Nothing) t = [idoc|print STDERR q{ return: #{prettyType t}}, "\n";|] + + +functionT :: FData -> MDoc +functionT (cmd, name, t) = + [idoc| +sub call_#{name}{ + if(scalar(@_) != #{pretty n}){ + print STDERR "Expected #{pretty n} arguments to '#{name}', given " . + scalar(@_) . "\n"; + exit 1; + } + return `#{poolcall}`; +} +|] + where + n = nargs t + poolcall = hsep $ cmd : map argT [0 .. (n - 1)] + +functionCT :: NexusCommand -> MDoc +functionCT (NexusCommand cmd _ json_str args subs) = + [idoc| +sub call_#{pretty cmd}{ + if(scalar(@_) != #{pretty $ length args}){ + print STDERR "Expected #{pretty $ length args} arguments to '#{pretty cmd}', given " . scalar(@_) . "\n"; + exit 1; + } + my $json_obj = $json->decode(q{#{json_str}}); + #{align . vsep $ readArguments ++ replacements} + return ($json->encode($json_obj) . "\n"); +} +|] + where + readArguments = zipWith readJsonArg args [1..] + replacements = map (uncurry3 replaceJson) subs + +replaceJson :: JsonPath -> MT.Text -> JsonPath -> MDoc +replaceJson pathTo v pathFrom + = (access "$json_obj" pathTo) + <+> "=" + <+> (access ([idoc|$json_#{pretty v}|]) pathFrom) + <> ";" + +access :: MDoc -> JsonPath -> MDoc +access v ps = cat $ punctuate "->" (v : map pathElement ps) + +pathElement :: JsonAccessor -> MDoc +pathElement (JsonIndex i) = brackets (pretty i) +pathElement (JsonKey key) = braces (pretty key) + +readJsonArg ::EVar -> Int -> MDoc +readJsonArg v i = [idoc|my $json_#{pretty v} = $json->decode($ARGV[#{pretty i}]); |] + +argT :: Int -> MDoc +argT i = "'$_[" <> pretty i <> "]'" diff --git a/library/Morloc/CodeGenerator/Serial.hs b/library/Morloc/CodeGenerator/Serial.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/CodeGenerator/Serial.hs @@ -0,0 +1,283 @@ +{-| +Module : Morloc.CodeGenerator.Serial +Description : Process serialization trees +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.CodeGenerator.Serial + ( makeSerialAST + , findSerializationCycles + , chooseSerializationCycle + , isSerializable + , prettySerialOne + , serialAstToType + , serialAstToType' + , shallowType + ) where + +import Morloc.CodeGenerator.Namespace +import Morloc.CodeGenerator.Internal +import Morloc.Frontend.Namespace (resolve) +import qualified Morloc.Monad as MM +import qualified Data.Map as Map +import qualified Morloc.Frontend.Lang.DefaultTypes as Def +import Morloc.Pretty (prettyPackMap) +import Morloc.Data.Doc + +pv2tv :: PVar -> TVar +pv2tv (PV lang _ v) = TV (Just lang) v + +defaultListFirst :: TypeP -> TypeP +defaultListFirst t = defaultListAll t !! 0 + +defaultTupleFirst :: [TypeP] -> TypeP +defaultTupleFirst ts = defaultTupleAll ts !! 0 + +-- | A metaphor for America +dummies :: Maybe Lang -> [UnresolvedType] +dummies lang = repeat $ VarU (TV lang "dummy") + +defaultListAll :: TypeP -> [TypeP] +defaultListAll t = + [ ArrP (PV lang gtype v) [t] + | (ArrU (TV (Just lang) v) _) <- Def.defaultList (langOf t) (head (dummies (langOf t))) + ] + where + gtype = case Def.defaultList Nothing (head (dummies Nothing)) of + ((ArrU (TV _ v1) _):_) -> Just v1 + _ -> Nothing + +isList :: TypeP -> Bool +isList (ArrP (PV lang _ v) [_]) = + let ds = Def.defaultList (Just lang) (head (dummies (Just lang))) + in length [v' | (ArrU (TV _ v') _) <- ds, v == v'] > 0 +isList _ = False + +defaultTupleAll :: [TypeP] -> [TypeP] +defaultTupleAll [] = error $ "Illegal empty tuple" +defaultTupleAll ts@(t:_) = + [ ArrP (PV lang gtype v) ts + | (ArrU (TV (Just lang) v) _) <- Def.defaultTuple (langOf t) (take (length ts) (dummies (langOf t))) + ] + where + gtype = case Def.defaultTuple Nothing (take (length ts) (dummies Nothing)) of + ((ArrU (TV _ v1) _):_) -> Just v1 + _ -> Nothing + +isTuple :: TypeP -> Bool +isTuple (ArrP (PV lang _ v) ts) = + let ds = Def.defaultTuple (Just lang) (take (length ts) (dummies (Just lang))) + in length [v' | (ArrU (TV _ v') _) <- ds, v == v'] > 0 +isTuple _ = False + +isPrimitiveType :: (Maybe Lang -> [UnresolvedType]) -> TypeP -> Bool +isPrimitiveType lookupDefault t = + let xs = filter (typeEqual t) + $ [ VarP (PV lang gtype v) + | (VarU (TV (Just lang) v)) <- lookupDefault (langOf t)] + in length xs > 0 + where + gtype = case lookupDefault Nothing of + ((VarU (TV _ g)):_) -> Just g + _ -> Nothing + +-- | recurse all the way to a serializable type +serialAstToType :: SerialAST One -> MorlocMonad TypeP +serialAstToType (SerialPack _ (One (_, s))) = serialAstToType s +serialAstToType (SerialList s) = serialAstToType s |>> defaultListFirst +serialAstToType (SerialTuple ss) = mapM serialAstToType ss |>> defaultTupleFirst +serialAstToType (SerialObject r v ps rs) = do + rs' <- mapM (serialAstToType . snd) rs + return $ NamP r v ps (zip (map fst rs) rs') +serialAstToType (SerialNum x) = return $ VarP x +serialAstToType (SerialBool x) = return $ VarP x +serialAstToType (SerialString x) = return $ VarP x +serialAstToType (SerialNull x) = return $ VarP x +serialAstToType (SerialUnknown x) + = MM.throwError . SerializationError . render + $ "Cannot guess serialization type:" <+> viaShow x + +-- | recurse all the way to a serializable type, unsafe +serialAstToType' :: SerialAST One -> TypeP +serialAstToType' (SerialPack _ (One (_, s))) = serialAstToType' s +serialAstToType' (SerialList s) = defaultListFirst $ serialAstToType' s +serialAstToType' (SerialTuple ss) = defaultTupleFirst $ map serialAstToType' ss +serialAstToType' (SerialObject r v ps rs) = NamP r v ps (zip (map fst rs) (map (serialAstToType' . snd) rs)) +serialAstToType' (SerialNum x) = VarP x +serialAstToType' (SerialBool x) = VarP x +serialAstToType' (SerialString x) = VarP x +serialAstToType' (SerialNull x) = VarP x +serialAstToType' (SerialUnknown _) = error "Cannot guess serialization type" + + +-- | get only the toplevel type +shallowType :: SerialAST One -> MorlocMonad TypeP +shallowType (SerialPack _ (One (p, _))) = return (typePackerFrom p) +shallowType (SerialList s) = shallowType s |>> defaultListFirst +shallowType (SerialTuple ss) = mapM shallowType ss |>> defaultTupleFirst +shallowType (SerialObject r v ps rs) = do + ts <- mapM shallowType (map snd rs) + return $ NamP r v ps (zip (map fst rs) ts) +shallowType (SerialNum x) = return $ VarP x +shallowType (SerialBool x) = return $ VarP x +shallowType (SerialString x) = return $ VarP x +shallowType (SerialNull x) = return $ VarP x +shallowType (SerialUnknown _) = MM.throwError . SerializationError + $ "Cannot guess serialization type" + +makeSerialAST + :: GMeta + -> TypeP + -> MorlocMonad (SerialAST Many) +makeSerialAST _ (UnkP v) = return $ SerialUnknown v +makeSerialAST m t@(VarP v@(PV _ _ _)) + | isPrimitiveType Def.defaultNull t = return $ SerialNull v + | isPrimitiveType Def.defaultBool t = return $ SerialBool v + | isPrimitiveType Def.defaultString t = return $ SerialString v + | isPrimitiveType Def.defaultNumber t = return $ SerialNum v + | otherwise = makeSerialAST m (ArrP v []) +makeSerialAST _ (FunP _ _) + = MM.throwError . SerializationError + $ "Cannot serialize functions" +makeSerialAST m t@(ArrP v@(PV _ _ s) ts) + | isList t = SerialList <$> makeSerialAST m (ts !! 0) + | isTuple t = SerialTuple <$> mapM (makeSerialAST m) ts + | otherwise = case Map.lookup (pv2tv v, length ts) (metaPackers m) of + (Just ps) -> do + ps' <- mapM (resolvePacker t ts) ps + ts' <- mapM (makeSerialAST m) (map typePackerType ps') + return $ SerialPack v (Many (zip ps' ts')) + Nothing -> MM.throwError . SerializationError . render + $ "Cannot find constructor" <+> dquotes (pretty s) + <> "<" <> pretty (length ts) <> ">" + <+> "in packmap:\n" <> prettyPackMap (metaPackers m) +makeSerialAST m (NamP r v ps rs) = do + ts <- mapM (makeSerialAST m) (map snd rs) + return $ SerialObject r v ps (zip (map fst rs) ts) + +pvarEqual :: PVar -> PVar -> Bool +pvarEqual (PV lang1 _ v1) (PV lang2 _ v2) = lang1 == lang2 && v1 == v2 + +typeEqual :: TypeP -> TypeP -> Bool +typeEqual (VarP v1) (VarP v2) = pvarEqual v1 v2 +typeEqual (ArrP v1 ts1) (ArrP v2 ts2) + | length ts1 /= length ts2 = False + | otherwise = foldl (&&) (pvarEqual v1 v2) (zipWith typeEqual ts1 ts2 ) +typeEqual (NamP _ v1 _ rs1) (NamP _ v2 _ rs2) + = (pvarEqual v1 v2) + && map fst rs1 == map fst rs2 + && foldl (&&) True (zipWith typeEqual (map snd rs1) (map snd rs2)) +typeEqual _ _ = False + + +resolvePacker :: TypeP -> [TypeP] -> UnresolvedPacker -> MorlocMonad TypePacker +resolvePacker packedType ts u = do + t <- resolveType ts (unresolvedPackerCType u) + return $ TypePacker + { typePackerType = t + , typePackerFrom = packedType + , typePackerForward = unresolvedPackerForward u + , typePackerReverse = unresolvedPackerReverse u + } + +resolveType :: [TypeP] -> UnresolvedType -> MorlocMonad TypeP +resolveType [] (ForallU _ _) = MM.throwError . SerializationError $ "Packer parity error" +resolveType [] u = weaveTypes Nothing (resolve u) +resolveType (t:ts) (ForallU v u) = substituteP v t <$> resolveType ts u +resolveType (_:_) _ = MM.throwError . SerializationError $ "Packer parity error" + +-- | substitute all appearances of a given variable with a given new type +substituteP :: TVar -> TypeP -> TypeP -> TypeP +substituteP v0 r0 t0 = sub t0 + where + sub :: TypeP -> TypeP + sub t'@(UnkP _) = t' + sub t'@(VarP (PV lang _ v')) + | v0 == (TV (Just lang) v') = r0 + | otherwise = t' + sub (FunP t1 t2) = FunP (sub t1) (sub t2) + sub (ArrP v' ts) = ArrP v' (map sub ts) + sub (NamP r v' ps rs) = NamP r v' (map sub ps) [(x, sub t') | (x, t') <- rs] + +-- | Given serialization trees for two languages, where each serialization tree +-- may contain, try to find +findSerializationCycles + :: ([(SerialAST One, SerialAST One)] -> Maybe (SerialAST One, SerialAST One)) + -- ^ pruning function + -> SerialAST Many + -> SerialAST Many + -> Maybe (SerialAST One, SerialAST One) +findSerializationCycles choose x0 y0 = f x0 y0 where + f :: SerialAST Many -> SerialAST Many -> Maybe (SerialAST One, SerialAST One) + -- reduce constructs until we get down to something that has general meaning + f (SerialPack v (Many ss1)) s2 + = choose + . catMaybes + $ [ fmap (\(x,y)->(SerialPack v (One (p1,x)),y)) (f s1 s2) + | (p1,s1) <- ss1] + -- same as above, just swap the arguments + f s1 s2@(SerialPack _ _) = case f s2 s1 of + (Just (x,y)) -> Just (y,x) + Nothing -> Nothing + f (SerialList s1) (SerialList s2) = case f s1 s2 of + (Just (s1', s2')) -> Just (SerialList s1', SerialList s2') + Nothing -> Nothing + f (SerialTuple ts1) (SerialTuple ts2) + | length ts1 /= length ts1 = Nothing + | otherwise = case fmap unzip . sequence $ zipWith f ts1 ts2 of + (Just (xs,ys)) -> Just (SerialTuple xs, SerialTuple ys) + Nothing -> Nothing + f (SerialObject r1 v1 ps1 rs1) (SerialObject r2 v2 ps2 rs2) + | map fst rs1 /= map fst rs2 = Nothing + | otherwise = case fmap unzip . sequence $ zipWith f ts1 ts2 of + Nothing -> Nothing + Just (rs1', rs2') -> Just ( SerialObject r1 v1 ps1 (zip (map fst rs1) rs1') + , SerialObject r2 v2 ps2 (zip (map fst rs2) rs2')) + where + ts1 = map snd rs1 + ts2 = map snd rs1 + f (SerialNum x1) (SerialNum x2) = Just (SerialNum x1, SerialNum x2) + f (SerialBool x1) (SerialBool x2) = Just (SerialBool x1, SerialBool x2) + f (SerialString x1) (SerialString x2) = Just (SerialString x1, SerialString x2) + f (SerialNull x1) (SerialNull x2) = Just (SerialNull x1, SerialNull x2) + f (SerialUnknown v1) (SerialUnknown v2) = Just (SerialUnknown v1, SerialUnknown v2) + f _ _ = Nothing + +-- | Given a list of possible ways to (de)serialize data between two languages, +-- choose one (or none if the list is empty). Currently I just take the first +-- in the list, but different cycles may have very different performance, so +-- this will be an important optimization step later on. +chooseSerializationCycle + :: [(SerialAST One, SerialAST One)] + -> Maybe (SerialAST One, SerialAST One) +chooseSerializationCycle [] = Nothing +chooseSerializationCycle (x:_) = Just x + +-- | Determine if a SerialAST can be directly translated to JSON, if not it +-- will need to be further reduced. +isSerializable :: Functor f => SerialAST f -> Bool +isSerializable (SerialPack _ _) = False +isSerializable (SerialList x) = isSerializable x +isSerializable (SerialTuple xs) = all isSerializable xs +isSerializable (SerialObject _ _ _ rs) = all isSerializable (map snd rs) +isSerializable (SerialNum _) = True +isSerializable (SerialBool _) = True +isSerializable (SerialString _) = True +isSerializable (SerialNull _) = True +isSerializable (SerialUnknown _) = True -- are you feeling lucky? + +prettySerialOne :: SerialAST One -> MDoc +prettySerialOne (SerialPack _ _) = "SerialPack" +prettySerialOne (SerialList x) = "SerialList" <> parens (prettySerialOne x) +prettySerialOne (SerialTuple xs) = "SerialTuple" <> tupled (map prettySerialOne xs) +prettySerialOne (SerialObject r _ _ rs) + = block 4 ("SerialObject@" <> viaShow r) + $ vsep (map (\(k,v) -> parens (viaShow k) <> "=" <> prettySerialOne v) rs) +prettySerialOne (SerialNum _) = "SerialNum" +prettySerialOne (SerialBool _) = "SerialBool" +prettySerialOne (SerialString _) = "SerialString" +prettySerialOne (SerialNull _) = "SerialNull" +prettySerialOne (SerialUnknown _) = "SerialUnknown" diff --git a/library/Morloc/Config.hs b/library/Morloc/Config.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Config.hs @@ -0,0 +1,135 @@ +{-| +Module : Morloc.Config +Description : Handle local configuration +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Morloc.Config + ( Config(..) + , loadMorlocConfig + , loadDefaultMorlocConfig + , buildPoolCallBase + , getDefaultConfigFilepath + , getDefaultMorlocTmpDir + , makeLibSourceString + ) where + +import Data.Aeson (FromJSON(..), (.!=), (.:?), withObject) +import Morloc.Data.Doc +import Morloc.Namespace +import qualified Morloc.Language as ML +import qualified Data.HashMap.Strict as H +import qualified Data.Yaml.Config as YC +import qualified Morloc.Data.Text as MT +import qualified Morloc.System as MS +import Morloc.Pretty () + + +getDefaultConfigFilepath :: IO Path +getDefaultConfigFilepath = + MS.getHomeDirectory |>> MS.appendPath (Path ".morloc/config") + +instance FromJSON Path where + parseJSON = fmap Path . parseJSON + +-- FIXME: remove this chronic multiplication +instance FromJSON Config where + parseJSON = + withObject "object" $ \o -> + Config + <$> fmap Path (o .:? "home" .!= "$HOME/.morloc") + <*> fmap Path (o .:? "library" .!= "$HOME/.morloc/lib") + <*> fmap Path (o .:? "tmpdir" .!= "$HOME/.morloc/tmp" ) + <*> fmap Path (o .:? "lang_python3" .!= "python3") + <*> fmap Path (o .:? "lang_R" .!= "Rscript") + <*> fmap Path (o .:? "lang_perl" .!= "perl") + +-- | Load the default Morloc configuration, ignoring any local configurations. +loadDefaultMorlocConfig :: IO Config +loadDefaultMorlocConfig = do + defaults <- defaultFields + return $ + Config + (Path $ defaults H.! "home") + (Path $ defaults H.! "library") + (Path $ defaults H.! "tmpdir") + (Path "python") -- lang_python3 + (Path "Rscript") -- lang_R + (Path "perl") -- lang_perl + +-- | Load a Morloc config file. If no file is given (i.e., Nothing), then the +-- default configuration will be used. +loadMorlocConfig :: Maybe Path -> IO Config +loadMorlocConfig Nothing = do + defaults <- defaultFields + MS.loadYamlConfig + Nothing + (YC.useCustomEnv defaults) + loadDefaultMorlocConfig +loadMorlocConfig (Just configFile) = do + configExists <- MS.fileExists configFile + defaults <- defaultFields + if configExists + then + MS.loadYamlConfig + (Just [configFile]) + (YC.useCustomEnv defaults) + loadDefaultMorlocConfig + else + loadMorlocConfig Nothing + +-- | Create the base call to a pool (without arguments) +-- For example: +-- ./pool.R 1 -- +-- ./pool.py 1 -- +-- ./pool-cpp.out 1 -- +-- ./pool.R 1 [1,2,3] true +buildPoolCallBase + :: Config + -> Maybe Lang + -> Int + -> Maybe [MDoc] +buildPoolCallBase _ (Just CLang) i = + Just ["./" <> pretty (ML.makeExecutableName CLang "pool"), pretty i] +buildPoolCallBase _ (Just CppLang) i = + Just ["./" <> pretty (ML.makeExecutableName CppLang "pool"), pretty i] +buildPoolCallBase c (Just RLang) i = + Just [pretty (configLangR c), pretty (ML.makeExecutableName RLang "pool"), pretty i] +buildPoolCallBase c (Just Python3Lang) i = + Just [pretty (configLangPython3 c), pretty (ML.makeExecutableName Python3Lang "pool"), pretty i] +buildPoolCallBase _ _ _ = Nothing -- FIXME: add error handling + +-- A key value map +defaultFields :: IO (H.HashMap MT.Text MT.Text) +defaultFields = do + home <- fmap unPath getDefaultMorlocHome + lib <- fmap unPath getDefaultMorlocLibrary + tmp <- fmap unPath getDefaultMorlocTmpDir + return $ H.fromList [("home", home), ("library", lib), ("tmpdir", tmp)] + +-- | Get the Morloc home directory (absolute path) +getDefaultMorlocHome :: IO Path +getDefaultMorlocHome = MS.getHomeDirectory |>> MS.appendPath (Path ".morloc") + +-- | Get the Morloc library directory (absolute path). Usually this will be a +-- folder inside the home directory. +getDefaultMorlocLibrary :: IO Path +getDefaultMorlocLibrary = MS.getHomeDirectory |>> MS.appendPath (Path ".morloc/lib") + +-- | Get the Morloc default temporary directory. This will store generated +-- SPARQL queries and rdf dumps that can be used in debugging. +getDefaultMorlocTmpDir :: IO Path +getDefaultMorlocTmpDir = MS.getHomeDirectory |>> MS.appendPath (Path ".morloc/tmp") + +-- | Get a source string for a library module. This will 1) remove the +-- user-specific home directory and 2) replace '/' separators with '.'. An +-- input of Nothing indicates the input is a local file or STDIN. +makeLibSourceString :: Maybe Path -> MorlocMonad (Maybe Path) +makeLibSourceString (Just (Path x)) = do + homedir <- liftIO getDefaultMorlocLibrary + let x' = maybe x id (MT.stripPrefix (unPath homedir) x) + let x'' = maybe x' id (MT.stripPrefix "/" x') + return . Just . Path . MT.replace "/" "__" . MT.replace "." "_" $ x'' +makeLibSourceString Nothing = return Nothing diff --git a/library/Morloc/Data/DAG.hs b/library/Morloc/Data/DAG.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Data/DAG.hs @@ -0,0 +1,242 @@ +{-| +Module : Morloc.Data.DAG +Description : Functions for working with directed acyclic graphs +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.Data.DAG + ( edgelist + , insertEdge + , edges + , nodes + , lookupNode + , lookupEdge + , lookupEdgeTriple + , local + , roots + , leafs + , findCycle + , mapNode + , mapNodeM + , mapNodeWithKey + , mapNodeWithKeyM + , mapEdge + , mapEdgeWithNode + , mapNodeWithEdge + , mapEdgeWithNodeM + , lookupAliasedTerm + , lookupAliasedTermM + , synthesizeDAG + ) where + +import Morloc.Namespace +import qualified Morloc.Monad as MM +import qualified Data.Map as Map +import qualified Data.Set as Set + +edgelist :: DAG k e n -> [(k,k)] +edgelist d = concat [[(k,j) | (j,_) <- xs] | (k, (_, xs)) <- Map.toList d ] + +insertEdge :: Ord k => k -> k -> e -> DAG k e n -> DAG k e n +insertEdge k1 k2 e d = Map.alter f k1 d + where + -- f :: Maybe [(k, e)] -> Maybe [(k, e)] + f Nothing = error "Cannot add edge to non-existant node" + f (Just (n,xs)) = Just $ (n,(k2,e):xs) + +-- | Get all edges +edges :: DAG k e n -> [e] +edges = map snd . concat . map snd . Map.elems + +-- | Get all nodes +nodes :: DAG k e n -> [n] +nodes = map fst . Map.elems + +lookupNode :: Ord k => k -> DAG k e n -> Maybe n +lookupNode k d = case Map.lookup k d of + (Just (n,_)) -> Just n + Nothing -> Nothing + +lookupEdge :: (Ord k) => k -> k -> DAG k e n -> Maybe e +lookupEdge k1 k2 d = case Map.lookup k1 d of + (Just (_,xs)) -> lookup k2 xs + Nothing -> Nothing + +lookupEdgeTriple :: (Ord k) => k -> k -> DAG k e n -> Maybe (n, e, n) +lookupEdgeTriple k1 k2 d = do + (n1, xs) <- Map.lookup k1 d + e <- lookup k2 xs + (n2, _) <- Map.lookup k2 d + return (n1, e, n2) + +local :: Ord k => k -> DAG k e n -> Maybe (n, [(k, e, n)]) +local k d = do + (n1, xs) <- Map.lookup k d + ns <- mapM (flip lookupNode $ d) (map fst xs) + return $ (n1, [(k',e,n2) | (n2, (k', e)) <- zip ns xs]) + +-- | Get all roots +roots :: Ord k => DAG k e n -> [k] +roots d = Set.toList $ Set.difference parents children + where + g = edgelist d + parents = Map.keysSet d + children = Set.fromList (map snd g) + +-- | Get all leaves that have no children +leafs :: DAG k e n -> [k] +leafs d = [k | (k, (_, [])) <- Map.toList d] + +-- | Searches a DAG for a cycle, stops on the first observed cycle and returns +-- the path. +findCycle :: Ord k => DAG k e n -> Maybe [k] +findCycle d = case mapMaybe (findCycle' []) (roots d) of + [] -> Nothing + (x:_) -> Just x + where + -- findCycle' :: [k] -> k -> Maybe [k] + findCycle' seen k + | elem k seen = Just seen + | otherwise = case Map.lookup k d of + Nothing -> Nothing -- we have reached a leaf + (Just (_,xs)) -> case mapMaybe (findCycle' (k:seen)) (map fst xs) of + [] -> Nothing + (x:_) -> Just x + +-- Map function over nodes independent of the edge data +mapNode :: (n1 -> n2) -> DAG k e n1 -> DAG k e n2 +mapNode f d = Map.map (\(n, xs) -> (f n, xs)) d + +mapNodeWithKey :: (k -> n1 -> n2) -> DAG k e n1 -> DAG k e n2 +mapNodeWithKey f d = Map.mapWithKey (\k (n, xs) -> (f k n, xs)) d + +-- Map function over nodes independent of the edge data +mapNodeM :: Ord k => (n1 -> MorlocMonad n2) -> DAG k e n1 -> MorlocMonad (DAG k e n2) +mapNodeM f d + = mapM (\(k,(n,xs)) -> f n >>= (\n' -> return (k, (n',xs)))) (Map.toList d) + |>> Map.fromList + +-- Map function over nodes independent of the edge data +mapNodeWithKeyM :: Ord k => (k -> n1 -> MorlocMonad n2) -> DAG k e n1 -> MorlocMonad (DAG k e n2) +mapNodeWithKeyM f d + = mapM (\(k,(n,xs)) -> f k n >>= (\n' -> return (k, (n',xs)))) (Map.toList d) + |>> Map.fromList + +-- Map function over edges independent of the node data +mapEdge :: (e1 -> e2) -> DAG k e1 n -> DAG k e2 n +mapEdge f = Map.map (\(n, xs) -> (n, [(k, f e) | (k,e) <- xs])) + +-- | map over edges given the nodes the edge connects +mapEdgeWithNode + :: Ord k + => (n -> e1 -> n -> e2) + -> DAG k e1 n -> DAG k e2 n +mapEdgeWithNode f d = Map.mapWithKey runit d where + runit k _ = case local k d of + (Just (n1, xs)) -> (n1, [(k2, f n1 e n2) | (k2, e, n2) <- xs]) + Nothing -> error "Bad DAG" + +-- | Map node data given edges and child data +mapNodeWithEdge + :: Ord k + => (n1 -> [(k, e, n1)] -> n2) + -> DAG k e n1 -> DAG k e n2 +mapNodeWithEdge f d = Map.mapWithKey fkey d where + fkey k1 (_, xs0) = case local k1 d of + (Just (n1, xs1)) -> (f n1 xs1, xs0) + Nothing -> error "Bad DAG" + +-- | map over edges given the nodes the edge connects +mapEdgeWithNodeM + :: Ord k + => (n -> e1 -> n -> MorlocMonad e2) + -> DAG k e1 n -> MorlocMonad (DAG k e2 n) +mapEdgeWithNodeM f d = mapM runit (Map.toList d) |>> Map.fromList + where + runit (k1, _) = case local k1 d of + (Just (n1, xs)) -> do + e2s <- mapM (\(_, e, n2) -> f n1 e n2) xs + return (k1, (n1, zip (map (\(x,_,_)->x) xs) e2s)) + Nothing -> MM.throwError . CallTheMonkeys $ "Incomplete DAG, missing object" + +-- | Map a monadic function over a DAG yielding a new DAG with the same +-- topology but a new node values. If the DAG contains cycles, Nothing is +-- returned. +synthesizeDAG + :: (Ord k, Monad m) + => (k -> n1 -> [(k, e, n2)] -> m n2) + -> DAG k e n1 + -> m (Maybe (DAG k e n2)) +synthesizeDAG f d0 = synthesizeDAG' (Just Map.empty) where + -- iteratively synthesize all nodes that have met dependencies + synthesizeDAG' Nothing = return Nothing + synthesizeDAG' (Just dn) + -- stop, we have completed the mapping. Jubilation. + | Map.size d0 == Map.size dn = return (Just dn) + | otherwise = do + -- traverse the original making any nodes that now have met dependencies + dn' <- foldlM addIfPossible dn (Map.toList d0) + if Map.size dn' == Map.size dn + -- if map size hasn't changed, then nothing was added and we are stuck + then return Nothing + -- otherwise move on to the next iteration + else synthesizeDAG' (Just dn') + + -- add leaves + addIfPossible dn (k1, (n1, [])) + | Map.member k1 dn = return dn + | otherwise = do + n2 <- f k1 n1 [] + return $ Map.insert k1 (n2, []) dn + -- add nodes where all children have been processed + addIfPossible dn (k1, (n1, xs)) + | Map.member k1 dn = return dn + | otherwise = case mapM (\k -> Map.lookup k dn) (map fst xs) of + Nothing -> return dn + (Just children) -> do + let augmented = [(k,e,n2) | ((k, e), (n2, _)) <- zip xs children] + n2 <- f k1 n1 augmented + return $ Map.insert k1 (n2, xs) dn + + +lookupAliasedTerm + :: (Ord k, Eq v) + => v + -- ^ look up this term + -> k + -- ^ starting from this node + -> (n -> a) + -- ^ extract the desired data with this function + -> DAG k [(v,v)] n + -- ^ original DAG where edges are "import as" statements + -> DAG k None (v,a) + -- ^ The final DAG with no edge attribute and the +lookupAliasedTerm v0 k0 f d0 = fromJust $ lookupAliasedTermM v0 k0 (Just . f) d0 + +lookupAliasedTermM + :: (Monad m, Ord k, Eq v) + => v + -- ^ look up this term + -> k + -- ^ starting from this node + -> (n -> m a) + -- ^ extract the desired data with this function + -> DAG k [(v,v)] n + -> m (DAG k None (v,a)) +lookupAliasedTermM v0 k0 f d0 = lookupAliasedTerm' v0 k0 mempty where + lookupAliasedTerm' v k d + | Map.member k d = return d + | otherwise = case Map.lookup k d0 of + Nothing -> error "Could not find module" + (Just (n, xs)) -> do + let xs' = [ (k', [(v1,v2) | (v1,v2) <- vs, v2 == v]) + | (k', vs) <- xs + , elem v (map snd vs)] + edges' = map (\(k', _) -> (k', None)) xs' + n' <- f n + foldlM (\d2 (k2,v2) -> lookupAliasedTerm' v2 k2 d2) + (Map.insert k ((v, n'), edges') d) + (concat [zip (repeat k') (map fst vs) | (k', vs) <- xs']) diff --git a/library/Morloc/Data/Doc.hs b/library/Morloc/Data/Doc.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Data/Doc.hs @@ -0,0 +1,58 @@ +{-| +Module : Morloc.Data.Doc +Description : A wrapper around prettyprint +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental + +This module re-exports Leijen's text builder along with a few other utilities. +-} +module Morloc.Data.Doc + ( module Data.Text.Prettyprint.Doc + , module Data.Text.Prettyprint.Doc.Render.Text + , render + , render' + , textEsc' + , tupledNoFold + -- ** These are not strictly necessary, since @pretty@ could be used, but + -- they avoid the requirements of an explicity type signature. + , int + , integer + , block + ) where + +import Data.Monoid ((<>)) +import qualified Data.Text as DT +import Data.Text.Prettyprint.Doc hiding ((<>)) +import Data.Text.Prettyprint.Doc.Render.Text + +render :: Doc ann -> DT.Text +render = renderStrict . layoutPretty defaultLayoutOptions + +render' :: Doc ann -> String +render' = show -- NOTE: This ignores layouts + +int :: Int -> Doc ann +int = pretty + +integer :: Integer -> Doc ann +integer = pretty + +block :: Int -> Doc ann -> Doc ann -> Doc ann +block level header body = align . vsep $ [header, "{", indent level body, "}"] + +-- | a tupled function that does not fold long lines (folding breaks commenting) +tupledNoFold :: [Doc ann] -> Doc ann +tupledNoFold [] = "" +tupledNoFold (x:xs) = parens (foldl (\l r -> l <> "," <+> r) x xs) + +textEsc' :: DT.Text -> Doc ann +textEsc' lit = (dquotes . pretty) $ DT.concatMap escapeChar lit + where + escapeChar '\n' = "\\n" + escapeChar '\t' = "\\t" + escapeChar '\r' = "\\r" + escapeChar '"' = "\\\"" + escapeChar '\\' = "\\\\" + escapeChar c = DT.singleton c diff --git a/library/Morloc/Data/Text.hs b/library/Morloc/Data/Text.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Data/Text.hs @@ -0,0 +1,91 @@ +{-| +Module : Morloc.Data.Text +Description : All things text +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental + +This is a general wrapper around all textual representations in Morloc. +-} +module Morloc.Data.Text + ( module Data.Text + , module Data.Text.IO + , module Data.Text.Encoding + , show' + , pretty + , read' + , readMay' + , parseTSV + , unparseTSV + , unenclose + , unangle + , unquote + , undquote + , stripPrefixIfPresent + , liftToText + ) where + +import Data.Text hiding (map) +import Data.Text.Encoding +import Data.Text.IO +import qualified Data.Text.Lazy as DL +import Prelude hiding (concat, length, lines, unlines) +import qualified Safe +import qualified Text.Pretty.Simple as Pretty + +show' :: Show a => a -> Text +show' = pack . show + +read' :: Read a => Text -> a +read' = read . unpack + +readMay' :: Read a => Text -> Maybe a +readMay' = Safe.readMay . unpack + +stripPrefixIfPresent :: Text -> Text -> Text +stripPrefixIfPresent prefix text = + case stripPrefix prefix text of + (Just x) -> x + Nothing -> text + +pretty :: Show a => a -> Text +pretty = DL.toStrict . Pretty.pShowNoColor + +-- | Parse a TSV, ignore first line (header). Cells are also unquoted and +-- wrapping angles are removed. +parseTSV :: Text -> [[Maybe Text]] +parseTSV = + map (map (nonZero . undquote . unangle)) . + map (split ((==) '\t')) . Prelude.tail . lines + +liftToText :: (String -> String) -> Text -> Text +liftToText f = pack . f . unpack + +-- | Make a TSV text +unparseTSV :: [[Maybe Text]] -> Text +unparseTSV = unlines . map renderRow + where + renderRow :: [Maybe Text] -> Text + renderRow = intercalate "\t" . map renderCell + renderCell :: Maybe Text -> Text + renderCell (Nothing) = "-" + renderCell (Just x) = x + +nonZero :: Text -> Maybe Text +nonZero s = + if length s == 0 + then Nothing + else Just s + +unenclose :: Text -> Text -> Text -> Text +unenclose a b x = maybe x id (stripPrefix a x >>= stripSuffix b) + +unangle :: Text -> Text +unangle = unenclose "<" ">" + +unquote :: Text -> Text +unquote = unenclose "'" "'" + +undquote :: Text -> Text +undquote = unenclose "\"" "\"" diff --git a/library/Morloc/Error.hs b/library/Morloc/Error.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Error.hs @@ -0,0 +1,106 @@ +{-| +Module : Morloc.Error +Description : Prepare error messages from MorlocError types +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental + +MorlocError is the type used within morloc to store data related to any errors +that are encountered. Data constructors in the MorlocError type may associates +data with the error. This data may be an arbitrary message or any other type. +The @errmsg@ function in this module defines how these errors will be printed +to the user. +-} +module Morloc.Error () where + +import Morloc.Namespace +import Morloc.Pretty (prettyType) +import Morloc.Data.Doc (render) +import qualified Morloc.Data.Text as MT + +-- TODO: fix this orphan instance +instance Show MorlocError where + show = MT.unpack . errmsg + +errmsg :: MorlocError -> MT.Text +errmsg UnknownError = "UnknownError" +errmsg (InvalidRDF msg) = "Invalid RDF: " <> msg +errmsg (NotImplemented msg) = "Not yet implemented: " <> msg +errmsg (NotSupported msg) = "NotSupported: " <> msg +errmsg (UnknownLanguage lang) = + "'" <> lang <> "' is not recognized as a supported language" +errmsg (SyntaxError err) = "SyntaxError: " <> MT.show' err +errmsg (SerializationError t) = "SerializationError: " <> t +errmsg (TypeConflict t1 t2) = "TypeConflict: cannot cast " <> t1 <> " as " <> t2 +errmsg (TypeError msg) = "TypeError: " <> msg +errmsg (CannotLoadModule t) = "CannotLoadModule: " <> t +errmsg (SystemCallError cmd loc msg) = + "System call failed at (" <> + loc <> "):\n" <> " cmd> " <> cmd <> "\n" <> " msg>\n" <> msg +errmsg (PoolBuildError msg) = "PoolBuildError: " <> msg +errmsg (SelfRecursiveTypeAlias v) = "SelfRecursiveTypeAlias: " <> MT.show' v +errmsg (MutuallyRecursiveTypeAlias vs) = "MutuallyRecursiveTypeAlias: " <> MT.unwords (map MT.show' vs) +errmsg (BadTypeAliasParameters (TV _ v) exp' obs) + = "BadTypeAliasParameters: for type alias " <> MT.show' v + <> " expected " <> MT.show' exp' + <> " parameters but found " <> MT.show' obs +errmsg (ConflictingTypeAliases t1 t2) + = "ConflictingTypeAliases: (" <> MT.show' t1 <> ", " <> MT.show' t2 <> ")" +errmsg NoBenefits = + "Manifolds in this context need to be fully resolved. " <> + "This is probably due to a bug in the code." +errmsg (CallTheMonkeys msg) = + "There is a bug in the code, send this message to the maintainer: " <> msg +errmsg (GeneratorError msg) = "GeneratorError: " <> msg +errmsg MissingGeneralType = "MissingGeneralType" +errmsg AmbiguousGeneralType = "AmbiguousGeneralType" +errmsg (SubtypeError t1 t2) = "SubtypeError: (" <> MT.show' t1 <> ") <: (" <> MT.show' t2 <> ")" +errmsg ExistentialError = "ExistentialError" +errmsg UnsolvedExistentialTerm = "UnsolvedExistentialTerm" +errmsg BadExistentialCast = "BadExistentialCast" +errmsg (AccessError _) = "AccessError" +errmsg NonFunctionDerive = "NonFunctionDerive" +errmsg (UnboundVariable v) = "UnboundVariable: " <> unEVar v +errmsg OccursCheckFail = "OccursCheckFail" +errmsg EmptyCut = "EmptyCut" +errmsg TypeMismatch = "TypeMismatch" +errmsg ToplevelRedefinition = "ToplevelRedefinition" +errmsg BadRecordAccess = "BadRecordAccess" +errmsg NoAnnotationFound = "NoAnnotationFound" +errmsg (OtherError msg) = "OtherError: " <> msg +-- container errors +errmsg EmptyTuple = "EmptyTuple" +errmsg TupleSingleton = "TupleSingleton" +errmsg EmptyRecord = "EmptyRecord" +-- module errors +errmsg (MultipleModuleDeclarations mv) = "MultipleModuleDeclarations: " <> MT.unwords (map unMVar mv) +errmsg (BadImport mv ev) = "BadImport: " <> unMVar mv <> "::" <> unEVar ev +errmsg (CannotFindModule name) = "Cannot find morloc module '" <> unMVar name <> "'" +errmsg CyclicDependency = "CyclicDependency" +errmsg (SelfImport _) = "SelfImport" +errmsg BadRealization = "BadRealization" +errmsg MissingSource = "MissingSource" +-- serialization errors +errmsg (MissingPacker place t) + = "SerializationError: no packer found for type (" + <> render (prettyType (unCType t)) <> ") at " <> place +errmsg (MissingUnpacker place t) + = "SerializationError: no unpacker found for type (" + <> render (prettyType (unCType t)) <> ") at " <> place +-- type extension errors +errmsg (AmbiguousPacker _) = "AmbiguousPacker" +errmsg (AmbiguousUnpacker _) = "AmbiguousUnpacker" +errmsg (AmbiguousCast _ _) = "AmbiguousCast" +errmsg (IncompatibleRealization _) = "IncompatibleRealization" +errmsg MissingAbstractType = "MissingAbstractType" +errmsg ExpectedAbstractType = "ExpectedAbstractType" +errmsg CannotInferConcretePrimitiveType = "CannotInferConcretePrimitiveType" +errmsg ToplevelStatementsHaveNoLanguage = "ToplevelStatementsHaveNoLanguage" +errmsg InconsistentWithinTypeLanguage = "InconsistentWithinTypeLanguage" +errmsg CannotInferLanguageOfEmptyRecord = "CannotInferLanguageOfEmptyRecord" +errmsg ConflictingSignatures = "ConflictingSignatures: currently a given term can have only one type per language" +errmsg CompositionsMustBeGeneral = "CompositionsMustBeGeneral" +errmsg IllegalConcreteAnnotation = "IllegalConcreteAnnotation" +errmsg (DagMissingKey msg) = "DagMissingKey: " <> msg +errmsg TooManyRealizations = "TooManyRealizations" diff --git a/library/Morloc/Frontend/API.hs b/library/Morloc/Frontend/API.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Frontend/API.hs @@ -0,0 +1,87 @@ +{-| +Module : Morloc.Frontend.API +Description : Morloc frontend API +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Morloc.Frontend.API + ( parse + , typecheck + , runStack + , Parser.readType + , Pretty.ugly + , Pretty.cute + ) where + +import Morloc.Frontend.Namespace +import qualified Control.Monad.Except as ME +import qualified Control.Monad.Reader as MR +import qualified Control.Monad.State as MS +import qualified Control.Monad.Writer as MW +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Morloc.Data.DAG as MDD +import qualified Morloc.Data.Text as MT +import qualified Morloc.Module as Mod +import qualified Morloc.Monad as MM +import qualified Morloc.Frontend.Parser as Parser +import qualified Morloc.Frontend.Infer as Infer +import qualified Morloc.Frontend.Pretty as Pretty + +parse :: + Maybe Path + -> Code -- ^ code of the current module + -> MorlocMonad (DAG MVar Import ParserNode) +parse f (Code code) = parseImports (Parser.readProgram f code mempty) + where + parseImports + :: DAG MVar Import ParserNode + -> MorlocMonad (DAG MVar Import ParserNode) + parseImports d + | length unimported == 0 = return d + | otherwise = do + importPath <- Mod.findModule (head unimported) + Mod.loadModuleMetadata importPath + (path', code') <- openLocalModule importPath + parseImports (Parser.readProgram path' code' d) + where + g = MDD.edgelist d + parents = Map.keysSet d + children = Set.fromList (map snd g) + unimported = Set.toList $ Set.difference children parents + +-- | assume @t@ is a filename and open it, return file name and contents +openLocalModule :: Path -> MorlocMonad (Maybe Path, MT.Text) +openLocalModule filename = do + code <- liftIO $ MT.readFile (MT.unpack . unPath $ filename) + return (Just filename, code) + + +typecheck + :: DAG MVar [(EVar, EVar)] PreparedNode + -> MorlocMonad (DAG MVar [(EVar, EVar)] TypedNode) +typecheck d = do + verbosity <- MS.gets stateVerbosity + x <- liftIO $ runStack verbosity (Infer.typecheck d) + case x of + ((Right result, _), _) -> return result + ((Left err, _), _) -> MM.throwError err + +-- | currently I do nothing with the Reader and Writer monads, but I'm leaving +-- them in for now since I will need them when I plug this all into Morloc. +runStack :: Int -> Stack a -> IO ((Either MorlocError a, [MT.Text]), StackState) +runStack verbosity e + = flip MS.runStateT emptyState + . MW.runWriterT + . ME.runExceptT + . MR.runReaderT e + $ StackConfig verbosity + +emptyState = StackState + { stateVar = 0 + , stateQul = 0 + , stateSer = [] + , stateDepth = 0 + } diff --git a/library/Morloc/Frontend/Desugar.hs b/library/Morloc/Frontend/Desugar.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Frontend/Desugar.hs @@ -0,0 +1,337 @@ +{-| +Module : Morloc.Frontend.Desugar +Description : Write Module objects to resolve type aliases and such +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.Frontend.Desugar (desugar, desugarType) where + +import Morloc.Frontend.Namespace +import Morloc.Pretty () +import Morloc.Data.Doc +import qualified Morloc.Monad as MM +import qualified Morloc.Data.DAG as MDD +import qualified Morloc.Data.Text as MT +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Morloc.Frontend.PartialOrder as MTP + +desugar + :: DAG MVar Import ParserNode + -> MorlocMonad (DAG MVar [(EVar, EVar)] PreparedNode) +desugar s + -- DAG MVar Import ParserNode + = resolveImports s + -- DAG MVar (Map EVar EVar) ParserNode + >>= desugarDag + -- DAG MVar (Map EVar EVar) PreparedNode + >>= simplify + -- Add packer map + >>= addPackerMap + + +-- | Consider export/import information to determine which terms are imported +-- into each module. This step reduces the Import edge type to an m-to-n source +-- name to alias map. +resolveImports + :: DAG MVar Import ParserNode + -> MorlocMonad (DAG MVar [(EVar, EVar)] ParserNode) +resolveImports = MDD.mapEdgeWithNodeM resolveImport where + resolveImport + :: ParserNode + -> Import + -> ParserNode + -> MorlocMonad [(EVar, EVar)] + resolveImport _ (Import _ Nothing exc _) n2 + = return + . map (\x -> (x,x)) -- alias is identical + . Set.toList + $ Set.difference (parserNodeExports n2) (Set.fromList exc) + resolveImport _ (Import _ (Just inc) exc _) n2 + | length contradict > 0 + = MM.throwError . CallTheMonkeys + $ "Error: The following terms are both included and excluded: " <> + render (tupledNoFold $ map pretty contradict) + | length missing > 0 + = MM.throwError . CallTheMonkeys + $ "Error: The following terms are not exported: " <> + render (tupledNoFold $ map pretty missing) + | otherwise = return inc + where + missing = [n | (n, _) <- inc, not $ Set.member n (parserNodeExports n2)] + contradict = [n | (n, _) <- inc, elem n exc] + +desugarDag + :: DAG MVar [(EVar, EVar)] ParserNode + -> MorlocMonad (DAG MVar [(EVar, EVar)] ParserNode) +desugarDag m = do + mapM_ checkForSelfRecursion (map parserNodeTypedefs (MDD.nodes m)) + MDD.mapNodeWithKeyM (desugarParserNode m) m + +simplify + :: (DAG MVar [(EVar, EVar)] ParserNode) + -> MorlocMonad (DAG MVar [(EVar, EVar)] PreparedNode) +simplify = return . MDD.mapNode prepare where + prepare :: ParserNode -> PreparedNode + prepare n1 = PreparedNode + { preparedNodePath = parserNodePath n1 + , preparedNodeBody = parserNodeBody n1 + , preparedNodeSourceMap = parserNodeSourceMap n1 + , preparedNodeExports = parserNodeExports n1 + , preparedNodePackers = Map.empty -- This will be filled in in `addPackerMap` + , preparedNodeTypedefs = parserNodeTypedefs n1 + } + +checkForSelfRecursion :: Map.Map TVar (UnresolvedType, [TVar]) -> MorlocMonad () +checkForSelfRecursion h = mapM_ (uncurry f) [(v,t) | (v,(t,_)) <- Map.toList h] where + f :: TVar -> UnresolvedType -> MorlocMonad () + f v (VarU v') + | v == v' = MM.throwError . SelfRecursiveTypeAlias $ v + | otherwise = return () + f _ (ExistU _ _ _) = MM.throwError $ CallTheMonkeys "existential crisis" + f v (ForallU _ t) = f v t + f v (FunU t1 t2) = f v t1 >> f v t2 + f v (ArrU v0 ts) + | v == v0 = MM.throwError . SelfRecursiveTypeAlias $ v + | otherwise = mapM_ (f v) ts + f v (NamU _ _ _ rs) = mapM_ (f v) (map snd rs) + +desugarParserNode + :: DAG MVar [(EVar, EVar)] ParserNode + -> MVar + -> ParserNode + -> MorlocMonad ParserNode +desugarParserNode d k n = do + nodeBody <- mapM (desugarExpr d k) (parserNodeBody n) + return $ n { parserNodeBody = nodeBody } + +desugarExpr + :: DAG MVar [(EVar, EVar)] ParserNode + -> MVar + -> Expr + -> MorlocMonad Expr +desugarExpr _ _ e@(SrcE _) = return e +desugarExpr d k (Signature v t) = Signature v <$> desugarEType d k t +desugarExpr d k (Declaration v e) = Declaration v <$> desugarExpr d k e +desugarExpr _ _ UniE = return UniE +desugarExpr _ _ e@(VarE _) = return e +desugarExpr d k (AccE e key) = AccE <$> desugarExpr d k e <*> pure key +desugarExpr d k (ListE xs) = ListE <$> mapM (desugarExpr d k) xs +desugarExpr d k (TupleE xs) = TupleE <$> mapM (desugarExpr d k) xs +desugarExpr d k (LamE v e) = LamE v <$> desugarExpr d k e +desugarExpr d k (AppE e1 e2) = AppE <$> desugarExpr d k e1 <*> desugarExpr d k e2 +desugarExpr d k (AnnE e ts) = AnnE <$> desugarExpr d k e <*> mapM (desugarType d k) ts +desugarExpr _ _ e@(NumE _) = return e +desugarExpr _ _ e@(LogE _) = return e +desugarExpr _ _ e@(StrE _) = return e +desugarExpr d k (RecE rs) = do + es <- mapM (desugarExpr d k) (map snd rs) + return (RecE (zip (map fst rs) es)) + +desugarEType :: DAG MVar [(EVar, EVar)] ParserNode -> MVar -> EType -> MorlocMonad EType +desugarEType d k (EType t ps cs) = EType <$> desugarType d k t <*> pure ps <*> pure cs + +desugarType + :: DAG MVar [(EVar, EVar)] ParserNode + -> MVar + -> UnresolvedType + -> MorlocMonad UnresolvedType +desugarType d k t0@(VarU v) = + case lookupTypedefs v k d of + [] -> return t0 + ts'@(t':_) -> do + (t, _) <- foldlM (mergeAliases v 0) t' ts' + desugarType d k t +desugarType d k (ExistU v ts ds) = do + ts' <- mapM (desugarType d k) ts + ds' <- mapM (desugarType d k) ds + return $ ExistU v ts' ds' +desugarType d k (ForallU v t) = ForallU v <$> desugarType d k t +desugarType d k (FunU t1 t2) = FunU <$> desugarType d k t1 <*> desugarType d k t2 +desugarType d k (ArrU v ts) = + case lookupTypedefs v k d of + [] -> ArrU v <$> mapM (desugarType d k) ts + (t':ts') -> do + (t, vs) <- foldlM (mergeAliases v (length ts)) t' ts' + if length ts == length vs + -- substitute parameters into alias + then desugarType d k (foldr parsub (choiceExistential t) (zip vs (map choiceExistential ts))) + else MM.throwError $ BadTypeAliasParameters v (length vs) (length ts) +desugarType d k (NamU r v ts rs) = do + let keys = map fst rs + vals <- mapM (desugarType d k) (map snd rs) + return (NamU r v ts (zip keys vals)) + +lookupTypedefs + :: TVar + -> MVar + -> DAG MVar [(EVar, EVar)] ParserNode + -> [(UnresolvedType, [TVar])] +lookupTypedefs (TV lang v) k h + = catMaybes + . MDD.nodes + . MDD.mapNode (\(EVar v', typemap) -> Map.lookup (TV lang v') typemap) + $ MDD.lookupAliasedTerm (EVar v) k parserNodeTypedefs h + + +-- When a type alias is imported from two places, this function reconciles them, if possible +mergeAliases + :: TVar + -> Int + -> (UnresolvedType, [TVar]) + -> (UnresolvedType, [TVar]) + -> MorlocMonad (UnresolvedType, [TVar]) +mergeAliases v i t@(t1, ts1) (t2, ts2) + | i /= length ts1 = MM.throwError $ BadTypeAliasParameters v i (length ts1) + | MTP.isSubtypeOf t1' t2' + && MTP.isSubtypeOf t2' t1' + && length ts1 == length ts2 = return t + | otherwise = MM.throwError (ConflictingTypeAliases (unresolvedType2type t1) (unresolvedType2type t2)) + where + t1' = foldl (\t' v' -> ForallU v' t') t1 ts1 + t2' = foldl (\t' v' -> ForallU v' t') t2 ts2 + + +parsub :: (TVar, UnresolvedType) -> UnresolvedType -> UnresolvedType +parsub (v, t2) t1@(VarU v0) + | v0 == v = t2 -- substitute + | otherwise = t1 -- keep the original +parsub _ (ExistU _ _ _) = error "What the bloody hell is an existential doing down here?" +parsub pair (ForallU v t1) = ForallU v (parsub pair t1) +parsub pair (FunU a b) = FunU (parsub pair a) (parsub pair b) +parsub pair (ArrU v ts) = ArrU v (map (parsub pair) ts) +parsub pair (NamU r v ts rs) = NamU r v (map (parsub pair) ts) (zip (map fst rs) (map (parsub pair . snd) rs)) + + + +addPackerMap + :: (DAG MVar [(EVar, EVar)] PreparedNode) + -> MorlocMonad (DAG MVar [(EVar, EVar)] PreparedNode) +addPackerMap d = do + maybeDAG <- MDD.synthesizeDAG gatherPackers d + case maybeDAG of + Nothing -> MM.throwError CyclicDependency + (Just d') -> return d' + +gatherPackers + :: MVar -- the importing module name (currently unused) + -> PreparedNode -- data about the importing module + -> [( MVar -- the name of an imported module + , [(EVar -- the name of a term in the imported module + , EVar -- the alias in the importing module + )] + , PreparedNode -- data about the imported module + )] + -> MorlocMonad PreparedNode +gatherPackers _ n1 es = do + let packers = starpack n1 Pack + unpackers = starpack n1 Unpack + nodepackers <- makeNodePackers packers unpackers n1 + let m = Map.unionsWith (<>) $ map (\(_, e, n2) -> inheritPackers e n2) es + m' = Map.unionWith (<>) nodepackers m + return $ n1 { preparedNodePackers = m' } + +starpack :: PreparedNode -> Property -> [(EVar, UnresolvedType, [Source])] +starpack n pro + = [ (v, t, maybeToList $ lookupSource v t (preparedNodeSourceMap n)) + | (Signature v e@(EType t p _)) <- preparedNodeBody n + , isJust (langOf e) + , Set.member pro p] + where + lookupSource :: EVar -> UnresolvedType -> Map.Map (EVar, Lang) Source -> Maybe Source + lookupSource v t m = langOf t >>= (\lang -> Map.lookup (v, lang) m) + +makeNodePackers + :: [(EVar, UnresolvedType, [Source])] + -> [(EVar, UnresolvedType, [Source])] + -> PreparedNode + -> MorlocMonad (Map.Map (TVar, Int) [UnresolvedPacker]) +makeNodePackers xs ys n = + let xs' = map (\(x,y,z)->(x, choiceExistential y, z)) xs + ys' = map (\(x,y,z)->(x, choiceExistential y, z)) ys + items = [ ( packerKey t2 + , [UnresolvedPacker (packerTerm v2 n) (packerType t1) ss1 ss2]) + | (_ , t1, ss1) <- xs' + , (v2, t2, ss2) <- ys' + , packerTypesMatch t1 t2 + ] + in return $ Map.fromList items + +packerTerm :: EVar -> PreparedNode -> Maybe EVar +packerTerm v n = listToMaybe . catMaybes $ + [ termOf e + | (Signature v' e) <- preparedNodeBody n + , v == v' + , isNothing (langOf e) + ] + where + termOf :: EType -> Maybe EVar + termOf e = case splitArgs (etype e) of + (_, [VarU (TV _ term), _]) -> Just $ EVar term + (_, [ArrU (TV _ term) _, _]) -> Just $ EVar term + _ -> Nothing + +choiceExistential :: UnresolvedType -> UnresolvedType +choiceExistential (VarU v) = VarU v +choiceExistential (ExistU _ _ (t:_)) = (choiceExistential t) +choiceExistential (ExistU _ _ []) = error "Existential with no default value" +choiceExistential (ForallU v t) = ForallU v (choiceExistential t) +choiceExistential (FunU t1 t2) = FunU (choiceExistential t1) (choiceExistential t2) +choiceExistential (ArrU v ts) = ArrU v (map choiceExistential ts) +choiceExistential (NamU r v ts recs) = NamU r v (map choiceExistential ts) (zip (map fst recs) (map (choiceExistential . snd) recs)) + +packerTypesMatch :: UnresolvedType -> UnresolvedType -> Bool +packerTypesMatch t1 t2 = case (splitArgs t1, splitArgs t2) of + ((vs1@[_,_], [t11, t12]), (vs2@[_,_], [t21, t22])) + -> MTP.equivalent (qualify vs1 t11) (qualify vs2 t22) + && MTP.equivalent (qualify vs1 t12) (qualify vs2 t21) + _ -> False + +packerType :: UnresolvedType -> UnresolvedType +packerType t = case splitArgs t of + (params, [t1, _]) -> qualify params t1 + _ -> error "bad packer" + +packerKey :: UnresolvedType -> (TVar, Int) +packerKey t = case splitArgs t of + (params, [VarU v, _]) -> (v, length params) + (params, [ArrU v _, _]) -> (v, length params) + (params, [NamU _ v _ _, _]) -> (v, length params) + _ -> error "bad packer" + +qualify :: [TVar] -> UnresolvedType -> UnresolvedType +qualify [] t = t +qualify (v:vs) t = ForallU v (qualify vs t) + +splitArgs :: UnresolvedType -> ([TVar], [UnresolvedType]) +splitArgs (ForallU v u) = + let (vs, ts) = splitArgs u + in (v:vs, ts) +splitArgs (FunU t1 t2) = + let (vs, ts) = splitArgs t2 + in (vs, t1:ts) +splitArgs t = ([], [t]) + +inheritPackers + :: [( EVar -- key in THIS module descrived in the PreparedNode argument + , EVar -- alias used in the importing module + )] + -> PreparedNode + -> Map.Map (TVar, Int) [UnresolvedPacker] +inheritPackers es n = + -- names of terms exported from this module + let names = Set.fromList (map (unEVar . fst) es) + in Map.map (map toAlias) + $ Map.filter (isImported names) (preparedNodePackers n) + where + toAlias :: UnresolvedPacker -> UnresolvedPacker + toAlias n' = n' { unresolvedPackerTerm = unresolvedPackerTerm n' >>= (flip lookup) es } + + isImported :: Set.Set MT.Text -> [UnresolvedPacker] -> Bool + isImported _ [] = False + isImported names' (n0:_) = case unresolvedPackerTerm n0 of + (Just (EVar v)) -> Set.member v names' + _ -> False diff --git a/library/Morloc/Frontend/Infer.hs b/library/Morloc/Frontend/Infer.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Frontend/Infer.hs @@ -0,0 +1,1109 @@ +{-| +Module : Morloc.Frontend.Infer +Description : Core inference module +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Morloc.Frontend.Infer + ( + -- * The main type checker + typecheck + -- * Internal functions used in testing + , subtype + , substitute + , apply + , infer + , rename + , unrename + , fromType + ) where + +import Morloc.Frontend.Namespace +import Morloc.Frontend.Internal +import qualified Morloc.Frontend.PartialOrder as P +import qualified Morloc.Frontend.Lang.DefaultTypes as MLD +import qualified Morloc.Data.DAG as MDD +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Morloc.Data.Text as MT +import qualified Control.Monad.Reader as R + +import Morloc.Data.Doc hiding (putDoc) +import Morloc.Frontend.Pretty +import Data.Text.Prettyprint.Doc.Render.Terminal (putDoc, AnsiStyle) + +typecheck + :: DAG MVar [(EVar, EVar)] PreparedNode + -> Stack (DAG MVar [(EVar, EVar)] TypedNode) +typecheck d = do + maybeDAG <- MDD.synthesizeDAG typecheck' d + case maybeDAG of + Nothing -> throwError CyclicDependency + (Just d') -> do + d'' <- MDD.synthesizeDAG propagateConstructors d' + case d'' of + (Just d''') -> return d''' + Nothing -> throwError CyclicDependency + where + typecheck' + :: MVar + -> PreparedNode + -> [(MVar, [(EVar, EVar)], TypedNode)] + -> Stack TypedNode + typecheck' k n xs = do + enter $ "entering module '" <> viaShow k <> "'" + g0 <- importTypes xs + (g1, es) <- typecheckExpr g0 (preparedNodeBody n) + leave $ "module" + return $ TypedNode + { typedNodeModuleName = k + , typedNodePath = preparedNodePath n + , typedNodeBody = es + -- the typemap is really only used when typchecking modules that + -- import this module, so it technically could be removed deleted for + -- being passed to the downstream generators. + , typedNodeTypeMap = nodeTypeMapFromGamma g1 + , typedNodeSourceMap = preparedNodeSourceMap n + , typedNodeExports = preparedNodeExports n + , typedNodePackers = preparedNodePackers n + , typedNodeConstructors + = Map.fromList + . map (\src@(Source _ lang _ alias) -> (TV (Just lang) (unEVar alias), src)) + . catMaybes + . map ((flip Map.lookup) (preparedNodeSourceMap n)) + $ [ (EVar v, lang) + | (TV (Just lang) v) <- unique (conmap collectConstructors es)] + + , typedNodeTypedefs = Map.map (\(t,ps) -> (resolve t, ps)) (preparedNodeTypedefs n) + } + + + collectConstructors :: Expr -> [TVar] + collectConstructors (AnnE e ts) = collectConstructors e ++ (conmap findTVar ts) + collectConstructors (Declaration _ e) = collectConstructors e + collectConstructors (ListE es) = conmap collectConstructors es + collectConstructors (TupleE es) = conmap collectConstructors es + collectConstructors (LamE _ e) = collectConstructors e + collectConstructors (AppE e1 e2) = collectConstructors e1 ++ collectConstructors e2 + collectConstructors (RecE rs) = conmap (collectConstructors . snd) rs + collectConstructors _ = [] + + findTVar :: UnresolvedType -> [TVar] + findTVar (VarU _) = [] + findTVar (ExistU _ _ _) = [] + findTVar (ForallU _ t) = findTVar t + findTVar (FunU t1 t2) = findTVar t1 ++ findTVar t2 + findTVar (ArrU _ ts) = conmap findTVar ts + findTVar (NamU _ v _ rs) = v : conmap (findTVar . snd) rs + + propagateConstructors + :: MVar -- the importing module name (currently unused) + -> TypedNode -- data about the importing module + -> [( MVar -- the name of an imported module + , [(EVar -- the name of a term in the imported module + , EVar -- the alias in the importing module + )] + , TypedNode -- data about the imported module + )] + -> Stack TypedNode + propagateConstructors _ n1 es = do + let constructor = Map.union (typedNodeConstructors n1) + $ (Map.fromList . concat) + [inherit n2 ps | (_, ps, n2) <- es] + return $ n1 { typedNodeConstructors = constructor } + + inherit :: TypedNode -> [(EVar, EVar)] -> [(TVar, Source)] + inherit ((Map.toList . typedNodeConstructors) -> ms) es = + [ (TV lang (unEVar n'), Source n l p n') + | (TV lang _, Source n l p a) <- ms -- information from parent + , (a', n') <- es -- edge: a' imported term name + , a == a'] + + nodeTypeMapFromGamma :: Gamma -> Map.Map EVar TypeSet + nodeTypeMapFromGamma g + = Map.fromList + $ [(e,t) | AnnG (VarE e) t <- g] ++ [(v,t) | AnnG (Declaration v _) t <- g] + + importTypes :: [(MVar, [(EVar, EVar)], TypedNode)] -> Stack Gamma + importTypes xs + -- [(EVar, [TypeSet])] + = (return . groupSort . concat . map importTypes') xs + -- [(EVar, TypeSet)] + >>= mapM mergeManyTypeSets + -- [GammaIndex] + |>> map (\(v, t) -> AnnG (VarE v) t) + + importTypes' :: (MVar, [(EVar, EVar)], TypedNode) -> [(EVar, TypeSet)] + importTypes' (_, xs, n) = mapMaybe (lookupOne (typedNodeTypeMap n)) xs + + lookupOne :: Map.Map EVar TypeSet -> (EVar, EVar) -> Maybe (EVar, TypeSet) + lookupOne m (name, _) = case Map.lookup name m of + (Just t) -> return (name, t) + Nothing -> Nothing + + -- Typecheck a set of expressions within a given context (i.e., one module). + -- Return the modified context and a list of annotated expressions. + typecheckExpr :: Gamma -> [Expr] -> Stack (Gamma, [Expr]) + typecheckExpr g1 e1 = do + es <- mapM rename e1 + (g', es') <- typecheckExpr' g1 [] es + let es'' = concat [toExpr v t | (AnnG (VarE v) t) <- g'] ++ reverse es' + return $ (g', map (generalizeE . unrename . apply g') es'') + where + toExpr :: EVar -> TypeSet -> [Expr] + toExpr v (TypeSet (Just e) es) = [Signature v t | t <- (e : es)] + toExpr v (TypeSet Nothing es) = [Signature v t | t <- es] + + typecheckExpr' :: Gamma -> [Expr] -> [Expr] -> Stack (Gamma, [Expr]) + typecheckExpr' g es [] = return (g, es) + typecheckExpr' g es (x:xs) = do + (g', _, e') <- infer Nothing g x + case e' of + (Signature _ _) -> typecheckExpr' g' es xs + _ -> typecheckExpr' g' (e' : es) xs + + mergeManyTypeSets :: (EVar, [TypeSet]) -> Stack (EVar, TypeSet) + mergeManyTypeSets (v, ts) = do + gtype <- mergeGeneral $ catMaybes [gt | (TypeSet gt _) <- ts] + let concreteTypes = concat [cs | (TypeSet _ cs) <- ts] + return $ (v, TypeSet gtype concreteTypes) + + mergeGeneral :: [EType] -> Stack (Maybe EType) + mergeGeneral [] = return Nothing + mergeGeneral [e] = return (Just e) + mergeGeneral [e1, e2] = fmap Just $ mergeGeneralTwo e1 e2 + mergeGeneral (e1:es) = do + e2' <- mergeGeneral es + case e2' of + (Just e2) -> fmap Just $ mergeGeneralTwo e1 e2 + Nothing -> return Nothing + + mergeGeneralTwo :: EType -> EType -> Stack EType + mergeGeneralTwo (EType t1 ps1 cs1) (EType t2 ps2 cs2) = do + subtype t1 t2 [] + subtype t2 t1 [] + -- FIXME: implement better behavior here for joining properties + return $ EType t1 (Set.union ps1 ps2) (Set.union cs1 cs2) + + +-- | type 1 is more polymorphic than type 2 (Dunfield Figure 9) +subtype :: UnresolvedType -> UnresolvedType -> Gamma -> Stack Gamma +subtype t1 t2 g = do + enter $ prettyGreenUnresolvedType t1 <+> "<:" <+> prettyGreenUnresolvedType t2 + seeGamma g + g' <- subtype' t1 t2 g + leave "subtype" + return g' + +-- VarU vs VarT +subtype' t1@(VarU (TV lang1 a1)) t2@(VarU (TV lang2 a2)) g + -- If everything is the same, do nothing + -- + -- ----------------------------------------- <:Var + -- G[a] |- a_l <: a_l -| G[a] + | lang1 == lang2 && a1 == a2 = return g + -- If languages are different, do nothing + -- l1 != l2 b_l2 ~~> a_l1 + -- ----------------------------------------- <:Var + -- G[a] |- a_l1 <: b_l2 -| G[a] + | lang1 /= lang2 = serialConstraint t1 t2 >> return g + -- If languages are same, but types are different, raise error + | lang1 == lang2 && a1 /= a2 = throwError $ SubtypeError (unresolvedType2type t1) (unresolvedType2type t2) + +subtype' a@(ExistU (TV l1 _) _ _) b@(ExistU (TV l2 _) _ _) g + -- + -- ----------------------------------------- <:Exvar + -- G[E.a] |- E.a <: E.a -| G[E.a] + | a == b = return g + -- l1 == l2 + -- ----------------------------------------- <:AlienExvar + -- G[E.a,E.b] |- E.a <: E.b -| G[E.a,E.b], E.a ~~> E.b + | l1 /= l2 = return $ g +> UnsolvedConstraint a b + -- + -- ----------------------------------------- <:InstantiateL/<:InstantiateR + -- G[E.a] |- Ea <: Ea -| G[E.a] + | otherwise + -- formally, an `Ea notin FV(G)` check should be done here, but since the + -- types involved are all existentials, it will always pass, so I omit + -- it. + = instantiate a b g + +-- g1 |- B1 <: A1 -| g2 +-- g2 |- [g2]A2 <: [g2]B2 -| g3 +-- ----------------------------------------- <:--> +-- g1 |- A1 -> A2 <: B1 -> B2 -| g3 +subtype' (FunU a1 a2) (FunU b1 b2) g1 + -- function subtypes are *contravariant* with respect to the input, that is, + -- the subtypes are reversed so we have b1<:a1 instead of a1<:b1. + = do + g2 <- subtype b1 a1 g1 + subtype (apply g2 a2) (apply g2 b2) g2 + +-- g1 |- A1 <: B1 +-- ----------------------------------------- <:App +-- g1 |- A1 A2 <: B1 B2 -| g2 +-- unparameterized types are the same as VarT, so subtype on that instead +subtype' (ArrU v1 []) (ArrU v2 []) g + | langOf v1 == langOf v2 = subtype (VarU v1) (VarU v2) g + | otherwise = throwError . OtherError $ "Cannot compare types between languages" +subtype' t1@(ArrU v1@(TV l1 _) vs1) t2@(ArrU v2@(TV l2 _) vs2) g + | length vs1 /= length vs2 = throwError . OtherError + $ "Cannot subtype types with unequal parameter count" + | l1 /= l2 = serialConstraint t1 t2 >> return g + | v1 == v2 = compareArr vs1 vs2 g + | otherwise = throwError . OtherError $ "Shit happens" + where + compareArr :: [UnresolvedType] -> [UnresolvedType] -> Gamma -> Stack Gamma + compareArr [] [] g' = return g' + compareArr (t1':ts1') (t2':ts2') g' = do + g'' <- subtype t1' t2' g' + compareArr ts1' ts2' g'' + compareArr _ _ _ = throwError TypeMismatch + +-- subtype unordered records +subtype' (NamU _ v1 _ rs1) (NamU _ v2 _ rs2) g = do + g' <- subtype (VarU v1) (VarU v2) g + compareEntry (sort rs1) (sort rs2) g' + where + compareEntry :: [(MT.Text, UnresolvedType)] -> [(MT.Text, UnresolvedType)] -> Gamma -> Stack Gamma + compareEntry [] [] g2 = return g2 + compareEntry ((k1, t1):rs1') ((k2, t2):rs2') g2 + | l1 == l2 = do + g3 <- subtype (VarU (TV l1 k1)) (VarU (TV l2 k2)) g2 + g4 <- subtype t1 t2 g3 + compareEntry rs1' rs2' g4 + | otherwise = serialConstraint t1 t2 >> return g + where + l1 = langOf t1 + l2 = langOf t2 + compareEntry _ _ _ = throwError TypeMismatch + +-- Ea not in FV(a) +-- g1[Ea] |- A <=: Ea -| g2 +-- ----------------------------------------- <:InstantiateR +-- g1[Ea] |- A <: Ea -| g2 +subtype' a b@(ExistU _ [] _) g + | langOf a /= langOf b = return g -- incomparable + | otherwise = occursCheck a b >> instantiate a b g +-- Ea not in FV(a) +-- g1[Ea] |- Ea <=: A -| g2 +-- ----------------------------------------- <:InstantiateL +-- g1[Ea] |- Ea <: A -| g2 +subtype' a@(ExistU _ [] _) b g + | langOf a /= langOf b = return g -- incomparable + | otherwise = occursCheck b a >> instantiate a b g + +subtype' a@(ArrU v1 ps1) b@(ExistU v2 ps2 _) g + | langOf a /= langOf b = return g -- incomparable + | otherwise = subtype' (ArrU v1 ps1) (ExistU v2 ps2 []) g +subtype' (ExistU v1 ps1 _) t@(ArrU v2 ps2) g1 + | langOf v1 /= langOf v2 = return g1 -- incomparable + | length ps1 /= length ps2 = throwError . OtherError . render $ + "Expected equal number of type paramters, found:" + <+> list (map prettyGreenUnresolvedType ps1) + <+> list (map prettyGreenUnresolvedType ps2) + | otherwise = do + g2 <- foldM (\g (p1, p2) -> subtype p1 p2 g) g1 (zip ps1 ps2) + case access1 v1 g2 of + Just (rs, _, ls) -> + return $ rs ++ [SolvedG v1 t] ++ ls + Nothing -> return g2 -- it is already solved, so do nothing + +-- g1,>Ea,Ea |- [Ea/x]A <: B -| g2,>Ea,g3 +-- ----------------------------------------- <:ForallL +-- g1 |- Forall x . A <: B -| g2 +-- +subtype' (ForallU v@(TV lang _) a) b g + | lang /= langOf b = return g + | otherwise = do + a' <- newvar lang + g' <- subtype (P.substitute v a' a) b (g +> MarkG v +> a') + cut (MarkG v) g' + +-- g1,a |- A <: B -| g2,a,g3 +-- ----------------------------------------- <:ForallR +-- g1 |- A <: Forall a. B -| g2 +subtype' a (ForallU v@(TV lang _) b) g + | lang /= langOf a = return g + | otherwise = subtype a b (g +> VarG v) >>= cut (VarG v) +subtype' a b _ = throwError $ SubtypeError (unresolvedType2type a) (unresolvedType2type b) + + + +-- | Dunfield Figure 10 -- type-level structural recursion +instantiate :: UnresolvedType -> UnresolvedType -> Gamma -> Stack Gamma +instantiate t1 t2 g1 = do + say $ prettyGreenUnresolvedType t1 <+> "<=:" <+> prettyGreenUnresolvedType t2 + g2 <- instantiate' t1 t2 g1 + say $ "instantiate done" + seeGamma g2 + return g2 + +-- g1[Ea2, Ea1, Ea=Ea1->Ea2] |- A1 <=: Ea1 -| g2 +-- g2 |- Ea2 <=: [g2]A2 -| g3 +-- ----------------------------------------- InstLArr +-- g1[Ea] |- Ea <=: A1 -> A2 -| g3 +instantiate' (ExistU v@(TV lang _) [] _) (FunU t1 t2) g1 = do + ea1 <- newvar lang + ea2 <- newvar lang + g2 <- + case access1 v g1 of + Just (rs, _, ls) -> + return $ rs ++ [SolvedG v (FunU ea1 ea2), index ea1, index ea2] ++ ls + Nothing -> throwError $ OtherError "Bad thing #2" + g3 <- instantiate t1 ea1 g2 + g4 <- instantiate ea2 (apply g3 t2) g3 + return g4 +-- g1[Ea2,Ea1,Ea=Ea1->Ea2] |- Ea1 <=: A1 -| g2 +-- g2 |- [g2]A2 <=: Ea2 -| g3 +-- ----------------------------------------- InstRArr +-- g1[Ea] |- A1 -> A2 <=: Ea -| g3 +instantiate' (FunU t1 t2) (ExistU v@(TV lang _) [] _) g1 = do + ea1 <- newvar lang + ea2 <- newvar lang + g2 <- + case access1 v g1 of + Just (rs, _, ls) -> + return $ rs ++ [SolvedG v (FunU ea1 ea2), index ea1, index ea2] ++ ls + Nothing -> throwError $ OtherError "Bad thing #3" + g3 <- instantiate t1 ea1 g2 + g4 <- instantiate ea2 (apply g3 t2) g3 + return g4 +-- +-- ----------------------------------------- InstLAllR +-- +instantiate' ta@(ExistU _ _ _) tb@(ForallU v2 t2) g1 + | langOf ta /= langOf tb = return g1 + | otherwise = instantiate ta t2 (g1 +> VarG v2) >>= cut (VarG v2) +-- InstLReach or instRReach -- each rule eliminates an existential +-- Replace the rightmost with leftmost (G[a][b] --> L,a,M,b=a,R) +-- WARNING: be careful here, since the implementation adds to the front and the +-- formal syntax adds to the back. Don't change anything in the function unless +-- you really know what you are doing and have tests to confirm it. +instantiate' ta@(ExistU v1 ps1 []) tb@(ExistU v2 ps2 []) g1 = do + g2 <- foldM (\g (t1, t2) -> subtype t1 t2 g) g1 (zip ps1 ps2) + g3 <- case access2 v1 v2 g2 of + -- InstLReach + (Just (ls, _, ms, x, rs)) -> return $ ls <> (SolvedG v1 tb : ms) <> (x : rs) + Nothing -> + case access2 v2 v1 g2 of + -- InstRReach + (Just (ls, _, ms, x, rs)) -> + return $ ls <> (SolvedG v2 ta : ms) <> (x : rs) + Nothing -> return g2 + return g3 +-- g1[Ea],>Eb,Eb |- [Eb/x]B <=: Ea -| g2,>Eb,g3 +-- ----------------------------------------- InstRAllL +-- g1[Ea] |- Forall x. B <=: Ea -| g2 +instantiate' ta@(ForallU x b) tb@(ExistU _ [] _) g1 + | langOf ta /= langOf tb = return g1 + | otherwise = + instantiate + (substitute x b) -- [Eb/x]B + tb -- Ea + (g1 +> MarkG x +> ExistG x [] []) -- g1[Ea],>Eb,Eb + >>= cut (MarkG x) +-- g1 |- t +-- ----------------------------------------- InstRSolve +-- g1,Ea,g2 |- t <=: Ea -| g1,Ea=t,g2 +instantiate' ta tb@(ExistU v [] []) g1 + | langOf ta /= langOf tb = return g1 + | otherwise = + case access1 v g1 of + (Just (ls, _, rs)) -> return $ ls ++ (SolvedG v ta) : rs + Nothing -> + case lookupU v g1 of + (Just _) -> return g1 + Nothing -> + throwError . OtherError $ + "Error in InstRSolve: ta=(" <> + MT.show' ta <> ") tb=(" <> MT.show' tb <> ") g1=(" <> MT.show' g1 <> ")" +-- g1 |- t +-- ----------------------------------------- instLSolve +-- g1,Ea,g2 |- Ea <=: t -| g1,Ea=t,g2 +instantiate' ta@(ExistU v [] []) tb g1 + | langOf ta /= langOf tb = return g1 + | otherwise = + case access1 v g1 of + (Just (ls, _, rs)) -> return $ ls ++ (SolvedG v tb) : rs + Nothing -> + case lookupU v g1 of + (Just _) -> return g1 + Nothing -> error "error in InstLSolve" + +-- if defaults are involved, no solving is done, but the subtypes of parameters +-- and defaults needs to be checked. +instantiate' (ExistU _ ps1 ds1) (ExistU _ ps2 ds2) g1 = do + g2 <- foldM (\g (t1, t2) -> subtype t1 t2 g) g1 (zip ps1 ps2) + g3 <- foldM (\g d1 -> foldM (\g' d2 -> subtype d1 d2 g') g ds2) g2 ds1 + return g3 + +-- bad +instantiate' _ _ g = return g + + + +infer :: + Maybe Lang + -> Gamma + -> Expr -- ^ A subexpression from the original expression + -> Stack ( Gamma + , [UnresolvedType] -- The return types + , Expr -- The annotated expression + ) +infer l g e = do + enter $ "infer" <+> maybe "MLang" (viaShow . id) l <+> parens (prettyExpr e) + seeGamma g + o@(_, ts, _) <- infer' l g e + leave $ "infer |-" <+> encloseSep "(" ")" ", " (map prettyGreenUnresolvedType ts) + return o + +-- +-- ----------------------------------------- +-- g |- => -| g +-- +-- Uni=> +infer' Nothing g UniE = do + let t = head $ MLD.defaultNull Nothing + return (g, [t], ann UniE t) +infer' lang g UniE = do + t <- newvarRich [] [head $ MLD.defaultNull lang] lang + return (g +> t, [t], ann UniE t) + +-- Num=> +infer' Nothing g e@(NumE _) = do + let t = head $ MLD.defaultNumber Nothing + return (g, [t], ann e t) +infer' lang g e@(NumE _) = do + t <- newvarRich [] [head $ MLD.defaultNumber lang] lang + return (g +> t, [t], ann e t) + +-- Str=> +infer' Nothing g e@(StrE _) = do + let t = head $ MLD.defaultString Nothing + return (g, [t], ann e t) +infer' lang g e@(StrE _) = do + t <- newvarRich [] [head $ MLD.defaultString lang] lang + return (g +> t, [t], ann e t) + +-- Log=> +infer' Nothing g e@(LogE _) = do + let t = head $ MLD.defaultBool Nothing + return (g, [t], ann e t) +infer' lang g e@(LogE _) = do + t <- newvarRich [] [head $ MLD.defaultBool lang] lang + return (g +> t, [t], ann e t) + +-- Src=> +-- -- FIXME: the expressions are now NOT sorted ... need to fix +-- Since the expressions in a Morloc script are sorted before being +-- evaluated, the SrcE expressions will be considered before the Signature +-- and Declaration expressions. Thus every term that originates in source +-- code will be initialized here and elaborated upon with deeper type +-- information as the signatures and declarations are parsed. +-- -- NOTE: Keeping SrcE as an expression, rather than pulling it out of the +-- body, as is done with imports and exports, is justified since the type +-- system should know that a given term is from a given language since it may +-- be possible, in cases, to infer a type signature for the given language from +-- the general type signature. +infer' (Just _) _ (SrcE _) = throwError ToplevelStatementsHaveNoLanguage +infer' Nothing g1 s1@(SrcE srcs) = do + let g3 = map SrcG srcs ++ g1 + return (g3, [], s1) + +-- Signature=> +infer' (Just _) _ (Signature _ _) = throwError ToplevelStatementsHaveNoLanguage +infer' Nothing g1 (Signature v1 e1) = do + g2 <- accessWith1 isAnnG (append' e1) (ifNotFound e1) g1 + return (g2, [], Signature v1 e1) + where + + -- find a typeset + isAnnG :: GammaIndex -> Bool + isAnnG (AnnG (VarE e) _) + | v1 == e = True + | otherwise = False + isAnnG _ = False + + -- update the found typeset + append' :: EType -> GammaIndex -> Stack GammaIndex + append' e (AnnG x@(VarE _) r2) = AnnG <$> pure x <*> appendTypeSet r2 e + append' _ _ = throwError $ OtherError "Bad Gamma" + + -- create a new typeset if none was found + ifNotFound :: EType -> Gamma -> Stack Gamma + ifNotFound e g' = case (langOf . etype) e of + (Just _) -> return $ AnnG (VarE v1) (TypeSet Nothing [e]) : g' + Nothing -> return $ AnnG (VarE v1) (TypeSet (Just e) []) : g' + +-- Declaration=> +infer' (Just _) _ (Declaration _ _) = throwError ToplevelStatementsHaveNoLanguage +infer' Nothing g1 e0@(Declaration v e1) = do + (typeset3, g4, es4) <- case lookupE v g1 of + -- CheckDeclaration + (Just (_, typeset@(TypeSet t ts))) -> do + let xs1 = map etype (maybeToList t ++ ts) + tlangs = langsOf g1 typeset + langs = [lang | lang <- langsOf g1 e1, not (elem lang tlangs)] + -- Check each of the signatures against the expression. + (g2, ts2, es2) <- foldM (foldCheck e1) (g1, [], []) xs1 + (g3, ts3, es3) <- mapM newvar langs + >>= foldM (foldCheckExist v e1) (g2, ts2, es2) + typeset2 <- foldM appendTypeSet typeset (map (toEType g3) ts3) + return (generalizeTypeSet typeset2, g3, es3) + -- InferDeclaration + Nothing -> do + (g3, ts3, es3) <- foldM (foldInfer v e1) (g1, [], []) (langsOf g1 e1) + let ts4 = unique ts3 + typeset2 <- typesetFromList (map generalize ts4) + return (typeset2, g3, es3) + + e2 <- collate es4 + + let e5 = Declaration v (generalizeE e2) + + return (g4 +> AnnG e0 typeset3, [], e5) + where + + foldInfer + :: EVar + -> Expr + -> (Gamma, [UnresolvedType], [Expr]) + -> Maybe Lang + -> Stack (Gamma, [UnresolvedType], [Expr]) + foldInfer v' e' (g1', ts1, es) lang = do + (g2', ts2, e2) <- infer lang (g1' +> MarkEG v') e' + g3' <- cut (MarkEG v') g2' + return (g3', ts1 ++ ts2, e2:es) + + foldCheckExist + :: EVar + -> Expr + -> (Gamma, [UnresolvedType], [Expr]) + -> UnresolvedType + -> Stack (Gamma, [UnresolvedType], [Expr]) + foldCheckExist v' e' (g1', ts, es) t' = do + (g2', t2', e2') <- check (g1' +> MarkEG v' +> t') e' t' + g3' <- cut (MarkEG v') g2' + return (g3', t2':ts, e2':es) + + foldCheck :: + Expr + -> (Gamma, [UnresolvedType], [Expr]) + -> UnresolvedType + -> Stack (Gamma, [UnresolvedType], [Expr]) + foldCheck e' (g1', ts, es) t' = do + (g2', t2', e2') <- check g1' e' t' + say (prettyExpr e2') + return (g2', t2':ts, e2':es) + + toEType _ t = EType + { etype = t + , eprop = Set.empty + , econs = Set.empty + } + +infer' lang g e@(VarE v) = do + say $ "----------------------------------" + say $ pretty v + case (lang, lookupE v g) of + (Just _, Just (VarE v', t@(TypeSet _ []))) -> + if v' == v + then return (g, mapTS etype t, AnnE (VarE v') (mapTS etype t)) + else infer' lang g (VarE v') + -- forall M . (x:A_m) not_in + -- ------------------------------------------- Var=> + -- g |- x => A -| g + (Just _, Just (e', TypeSet _ [])) -> infer lang g e' + -- (x:A) in g + -- ------------------------------------------- Var + -- g |- x => A -| g + (_, Just (_, typeset)) -> + let ts = mapTS etype typeset + in return (g, ts, AnnE e ts) + (_, Nothing) -> throwError (UnboundVariable v) + where + mapTS :: (EType -> a) -> TypeSet -> [a] + mapTS f (TypeSet (Just a) es) = map f (a:es) + mapTS f (TypeSet Nothing es) = map f es + +infer' lang g (AccE e k) = do + (g', record_ts, e') <- infer lang g e + ts <- mapM (accessRecord k) record_ts |>> catMaybes + return (g', ts, AnnE (AccE e' k) ts) + where + accessRecord :: EVar -> UnresolvedType -> Stack (Maybe UnresolvedType) + accessRecord (EVar key) (NamU _ _ _ rs) = return $ lookup key rs + accessRecord _ _ = throwError BadRecordAccess + +-- g1,Ea,Eb,x:Ea |- e <= Eb -| g2,x:Ea,g3 +-- ----------------------------------------- -->I=> +-- g1 |- \x.e => Ea -> Eb -| g2 +-- | type 1 is more polymorphic than type 2 (Dunfield Figure 9) +infer' lang g1 (LamE v e2) = do + a <- newvar lang + b <- newvar lang + let anng = AnnG (VarE v) (fromType lang a) + g2 = g1 +> a +> b +> anng + (g3, t1, e2') <- check g2 e2 b + case fmap snd (lookupE v g3) >>= toType lang of + (Just t2) -> do + let t3 = FunU (apply g3 t2) t1 + g4 <- cut anng g3 + return (g4, [t3], ann (LamE v e2') t3) + Nothing -> throwError $ OtherError "Bad thing #4" + +{- g |- e1 => A* -| d_1 + - { d_i |- [d_i]A_i o e2 =>> C_i -| d_{i+1} } forall i in (1,2 ... k) + - ----------------------------------------- -->E + - g |- e1 e2 =>> C -| d_k + -} +infer' lang g1 (AppE e1 e2) = do + -- Anonymous lambda functions are currently not supported. So e1 currently will + -- be a VarE, an AppE, or an AnnE annotating a VarE or AppE. Anonymous lambdas + -- would roughly correspond to DeclareInfer statements while adding annotated + -- lambdas would correspond to DeclareAnnot. + + -- @as1@ will include one entry consisting of the general type `(Nothing,t)` + -- and one or more realizatoins `(Just lang, t)` + (d1, as1, e1') <- infer lang g1 e1 + + -- Map derive over every type observed for e1, the functional element. The + -- result is a list of the types and expressions derived from e2 + (g2, fs, es2') <- foldM deriveF (d1, [], []) as1 + + e2' <- collate es2' + + -- e1' - e1 with type annotations + -- e2' - e2 with type annotations (after being applied to e2) + (as2, ek') <- applyConcrete e1' e2' fs + + return (g2, as2, ek') + where + -- pair input and output types by language and construct the function type + applyConcrete :: Expr -> Expr -> [UnresolvedType] -> Stack ([UnresolvedType], Expr) + applyConcrete (AnnE e1' _) e2' fs' = do + let (tas, tcs) = unzip [ (FunU a c, c) | (FunU a c) <- fs' ] + return (tcs, AnnE (AppE (AnnE e1' tas) e2') tcs) + applyConcrete e _ _ = do + say $ prettyScream "ERROR!!!" + say $ "e =" <+> prettyExpr e + throwError . OtherError $ "bad concrete" + + deriveF :: + (Gamma, [UnresolvedType], [Expr]) + -> UnresolvedType + -> Stack (Gamma, [UnresolvedType], [Expr]) + deriveF (g', ts, es) t' = do + (g'', t'', e'') <- derive g' e2 t' + return (g'', t'':ts, e'':es) + +-- g1 |- A +-- g1 |- e <= A -| g2 +-- ----------------------------------------- Anno +-- g1 |- (e:A) => A -| g2 +infer' _ g e1@(AnnE e@(VarE v) [t]) = do + -- FIXME - I need to distinguish between the two types of annotations. There + -- are annotations that the user writes; these need to be checked. There are + -- annotations that are generated by the typechecker; these are basically + -- cached results that do not need to be checked. + -- + -- Currently I am checking the general cases, since that is the only kind of + -- annotation the user can make, but this still runs some unnecessary checks. + if langOf t == Nothing + then + case lookupE v g of + (Just _) -> checkup g e t + Nothing -> return (g, [t], e1) + else + return (g, [t], e1) +infer' _ g (AnnE e [t]) = + if langOf t == Nothing + then checkup g e t + else return (g, [t], e) +infer' _ g (AnnE e ts) = return (g, ts, e) + +-- List=> +infer' lang g1 (ListE xs1) = do + (g2, pairs) <- chainInfer lang g1 xs1 + elementType <- case (P.mostSpecific . catMaybes) (map fst pairs) of + [] -> newvar lang + (t:_) -> return t + (g3, _, xs3) <- chainCheck (zip (repeat elementType) xs1) g2 + let dts = MLD.defaultList lang elementType + containerType <- + if lang == Nothing + then return (head dts) + else newvarRich [elementType] dts lang + return (g3, [containerType], ann (ListE xs3) containerType) + +-- Tuple=> +infer' _ _ (TupleE []) = throwError EmptyTuple +infer' _ _ (TupleE [_]) = throwError TupleSingleton +infer' lang g1 (TupleE xs1) = do + (g2, pairs) <- chainInfer lang g1 xs1 + let (ts2may, xs2) = unzip pairs + ts2 <- case sequence ts2may of + Nothing -> throwError . OtherError $ "Could not infer tuple type" + (Just ts2') -> return ts2' + let dts = MLD.defaultTuple lang ts2 + containerType <- + if lang == Nothing + then return (head dts) + else newvarRich ts2 dts lang + return (g2, [containerType], ann (TupleE xs2) containerType) + +-- Record=> +infer' _ _ (RecE []) = throwError EmptyRecord +infer' lang g1 (RecE rs) = do + (g2, pairs) <- chainInfer lang g1 (map snd rs) + let (ts2may, xs2) = unzip pairs + keys = map fst rs + entries <- case sequence ts2may of + (Just ts2) -> return $ zip (map unEVar keys) ts2 + Nothing -> throwError . OtherError $ "Could not infer record type" + let dts = MLD.defaultRecord lang entries + containerType <- + if lang == Nothing + then return (head dts) + else newvarRich [NamU NamRecord (TV lang "__RECORD__") [] entries] dts lang -- see entry in Parser.hs + return (g2, [containerType], ann (RecE (zip keys xs2)) containerType) + + + +-- | Pattern matches against each type +check :: + Gamma + -> Expr -- ^ An expression which should be of the type given + -> UnresolvedType -- ^ The expected type of the expression + -> Stack ( Gamma + , UnresolvedType -- The inferred type of the expression + , Expr -- The annotated expression + ) +check g e t = do + enter $ "check" <+> parens (prettyExpr e) <> " " <> prettyGreenUnresolvedType t + seeGamma g + (g', t', e') <- check' g e t + leave $ "check |-" <+> prettyGreenUnresolvedType t' + return (g', t', e') + +-- g1,x:A |- e <= B -| g2,x:A,g3 +-- ----------------------------------------- -->I +-- g1 |- \x.e <= A -> B -| g2 +check' g1 (LamE v e1) t1@(FunU a b) = do + -- define x:A + let anng = AnnG (VarE v) (fromType (langOf t1) a) + -- check that e has the expected output type + (g2, t2, e2) <- check (g1 +> anng) e1 b + -- ignore the trailing context and (x:A), since it is out of scope + g3 <- cut anng g2 + let t3 = FunU a t2 + return (g3, t3, ann (LamE v e2) t3) + +-- g1,x |- e <= A -| g2,x,g3 +-- ----------------------------------------- Forall.I +-- g1 |- e <= Forall x.A -| g2 +check' g1 e1 t2@(ForallU x a) = do + (g2, _, e2) <- check (g1 +> VarG x) e1 a + g3 <- cut (VarG x) g2 + let t3 = apply g3 t2 + return (g3, t3, ann e2 t3) + +-- g1 |- e => A -| g2 +-- g2 |- [g2]A <: [g2]B -| g3 +-- ----------------------------------------- Sub +-- g1 |- e <= B -| g3 +check' g1 e1 b = do + (g2, ts, e2) <- infer (langOf b) g1 e1 + g3 <- foldM (\g t -> subtype (apply g t) (apply g b) g) g2 ts + return (g3, apply g3 b, anns (apply g3 e2) (map (apply g3) ts)) + + + +derive :: + Gamma + -> Expr -- the expression that is passed to the function + -> UnresolvedType -- the function type + -> Stack ( Gamma + , UnresolvedType -- output function type + , Expr -- @e@, with type annotation + ) +derive g e f = do + enter $ "derive" <+> prettyExpr e <> " " <> prettyGreenUnresolvedType f + seeGamma g + (g', t', e') <- derive' g e f + leave $ "derive |-" <+> prettyGreenUnresolvedType t' + return (g', t', e') + +-- g1 |- e <= A -| g2 +-- ----------------------------------------- -->App +-- g1 |- A->C o e =>> C -| g2 +derive' g e (FunU a b) = do + (g', a', e') <- check g e a + let b' = apply g' b + return (g', FunU a' b', apply g' e') + +-- g1,Ea |- [Ea/a]A o e =>> C -| g2 +-- ----------------------------------------- Forall App +-- g1 |- Forall x.A o e =>> C -| g2 +derive' g e (ForallU x s) = derive (g +> ExistG x [] []) e (substitute x s) + +-- g1[Ea2, Ea1, Ea=Ea1->Ea2] |- e <= Ea1 -| g2 +-- ----------------------------------------- EaApp +-- g1[Ea] |- Ea o e =>> Ea2 -| g2 +derive' g e (ExistU v@(TV lang _) [] _) = + case access1 v g of + -- replace with : -> + Just (rs, _, ls) -> do + ea1 <- newvar lang + ea2 <- newvar lang + let t' = FunU ea1 ea2 + g2 = rs ++ [SolvedG v t', index ea1, index ea2] ++ ls + (g3, a', e2) <- check g2 e ea1 + let f' = FunU a' (apply g3 ea2) + return (g3, f', e2) + -- if the variable has already been solved, use solved value + Nothing -> case lookupU v g of + (Just (FunU t1 t2)) -> do + (g2, _, e2) <- check g e t1 + return (g2, FunU t1 t2, e2) + _ -> throwError . OtherError $ "Expected a function" + +derive' _ e t = do + say $ prettyScream "ERROR!!!" + say $ "e: " <> prettyExpr e + say $ "t: " <> prettyGreenUnresolvedType t + throwError NonFunctionDerive + + + +-- ----- H E L P E R S -------------------------------------------------- + +-- | substitute all appearances of a given variable with an existential +-- [t/v]A +substitute :: TVar -> UnresolvedType -> UnresolvedType +substitute v t = P.substitute v (ExistU v [] []) t + +occursCheck :: UnresolvedType -> UnresolvedType -> Stack () +occursCheck t1 t2 = do + -- say $ "occursCheck:" <+> prettyGreenUnresolvedType t1 <+> prettyGreenUnresolvedType t2 + case Set.member t1 (P.free t2) of + True -> throwError OccursCheckFail + False -> return () + + +-- | fold a list of annotated expressions into one, preserving annotations +collate :: [Expr] -> Stack Expr +collate [] = throwError . OtherError $ "Nothing to collate" +collate [e] = return e +collate (e:es) = do + say $ "collating" <+> (align . vsep . map prettyExpr) (e:es) + e' <- foldM collateOne e es + say $ "collated to:" <+> prettyExpr e' + return e' + +-- | Merge two annotated expressions into one, fail if the expressions are not +-- equivalent. +collateOne :: Expr -> Expr -> Stack Expr +collateOne (AnnE e1 ts1) (AnnE e2 ts2) = AnnE <$> collateOne e1 e2 <*> collateTypes ts1 ts2 +-- +collateOne (AppE e11 e12) (AppE e21 e22) = AppE <$> collateOne e11 e21 <*> collateOne e12 e22 +collateOne (LamE v1 e1) (LamE v2 e2) + | v1 == v2 = LamE <$> pure v1 <*> collateOne e1 e2 + | otherwise = throwError $ OtherError "collate error #1" +collateOne e@(VarE v1) (VarE v2) + | v1 == v2 = return e + | otherwise = throwError $ OtherError "collate error #2" +-- primitives +collateOne e@UniE UniE = return e +collateOne e@(LogE _) (LogE _) = return e +collateOne e@(NumE _) (NumE _) = return e +collateOne e@(StrE _) (StrE _) = return e +-- accessors +collateOne (AccE e1 k1) (AccE e2 k2) + | k1 == k2 = AccE <$> collateOne e1 e2 <*> pure k1 + | otherwise = throwError $ OtherError "collate error: unequal access keys" +-- containers +collateOne (ListE es1) (ListE es2) + | length es1 == length es2 = ListE <$> zipWithM collateOne es1 es2 + | otherwise = throwError $ OtherError "collate error: unequal list length" +collateOne (TupleE es1) (TupleE es2) + | length es1 == length es2 = TupleE <$> zipWithM collateOne es1 es2 + | otherwise = throwError $ OtherError "collate error: unequal tuple length" +collateOne (RecE es1) (RecE es2) + | length es1 == length es2 = + RecE <$> ( + zip + <$> zipWithM returnIfEqual (map fst es1) (map fst es2) + <*> zipWithM collateOne (map snd es1) (map snd es2) + ) + | otherwise = throwError $ OtherError "collate error: unequal record length" + where + returnIfEqual :: Eq a => a -> a -> Stack a + returnIfEqual x y + | x == y = return x + | otherwise = throwError $ OtherError "expected them to be equal" +-- variable expansion +collateOne (VarE _) x = return x +collateOne x (VarE _) = return x +-- illegal +collateOne (Signature _ _) (Signature _ _) = error "the hell's a toplevel doing down here?" +collateOne (Declaration _ _) (Declaration _ _) = error "the hell's is a toplevel doing down here?" +collateOne (SrcE _) (SrcE _) = error "the hell's is a toplevel doing down here?" +collateOne e1 e2 = throwError . OtherError . render $ + nest 2 . vsep $ ["collation failure - unequal expressions:", viaShow e1, viaShow e2] + +collateTypes :: [UnresolvedType] -> [UnresolvedType] -> Stack [UnresolvedType] +collateTypes xs ys + = mapM (collateByLang . snd) + . groupSort + $ [(langOf t, t) | t <- unique (xs ++ ys)] + where + collateByLang :: [UnresolvedType] -> Stack UnresolvedType + collateByLang [] = throwError . OtherError $ "This should be impossible" + collateByLang [t] = return t + collateByLang (t1:ts) = foldM moreSpecific t1 ts + + moreSpecific :: UnresolvedType -> UnresolvedType -> Stack UnresolvedType + moreSpecific (FunU t11 t12) (FunU t21 t22) = FunU <$> moreSpecific t11 t21 <*> moreSpecific t12 t22 + moreSpecific (ArrU v1 ts1) (ArrU _ ts2) = ArrU v1 <$> zipWithM moreSpecific ts1 ts2 + moreSpecific (NamU r1 v1 ps rs1) (NamU r2 v2 _ rs2) + | v1 == v2 && r1 == r2 = NamU r1 <$> pure v1 <*> pure ps <*> zipWithM mergeEntry (sort rs1) (sort rs2) + | otherwise = throwError . OtherError $ "Cannot collate records with unequal names/langs" + where + mergeEntry (k1, t1) (k2, t2) + | k1 == k2 = (,) <$> pure k1 <*> moreSpecific t1 t2 + | otherwise = throwError . OtherError $ "Cannot collate records with unequal keys" + moreSpecific (ExistU _ _ []) t = return t + moreSpecific t (ExistU _ _ []) = return t + moreSpecific (ForallU _ _) t = return t + moreSpecific t (ForallU _ _) = return t + moreSpecific t _ = return t + + +-- | merge the new data from a signature with any prior type data +appendTypeSet :: TypeSet -> EType -> Stack TypeSet +appendTypeSet s e1 = + case ((langOf . etype) e1, s) of + -- if e is a general type, and there is no conflicting type, then set e + (Nothing, TypeSet Nothing rs) -> do + mapM_ (checkRealization e1) rs + return $ TypeSet (Just e1) rs + -- if e is a realization, and no general type is set, just add e to the list + (Just _, TypeSet Nothing rs) -> do + return $ TypeSet Nothing (e1 : [r | r <- rs, r /= e1]) + -- if e is a realization, and a general type exists, append it and check + (Just _, TypeSet (Just e2) rs) -> do + checkRealization e2 e1 + return $ TypeSet (Just e2) (e1 : [r | r <- rs, r /= e1]) + -- if e is general, and a general type exists, merge the general types + (Nothing, TypeSet (Just e2) rs) -> do + let e3 = + EType + { etype = etype e2 + , eprop = Set.union (eprop e1) (eprop e2) + , econs = Set.union (econs e1) (econs e2) + } + return $ TypeSet (Just e3) rs + +checkRealization :: EType -> EType -> Stack () +checkRealization e1 e2 = f' (etype e1) (etype e2) + where + f' :: UnresolvedType -> UnresolvedType -> Stack () + f' (FunU x1 y1) (FunU x2 y2) = f' x1 x2 >> f' y1 y2 + f' (ForallU _ x) (ForallU _ y) = f' x y + f' (ForallU _ x) y = f' x y + f' x (ForallU _ y) = f' x y + f' (ExistU _ [] _) (ExistU _ [] _) = return () + f' (ExistU v (_:xs) ds1) (ExistU w (_:ys) ds2) = f' (ExistU v xs ds1) (ExistU w ys ds2) + f' (ExistU _ _ _) (ExistU _ _ _) = throwError . OtherError $ + "BadRealization: unequal number of parameters" + f' (ExistU _ _ _) _ = return () + f' _ (ExistU _ _ _) = return () + f' t1@(FunU _ _) t2 = throwError . OtherError $ + "BadRealization: Cannot compare types '" <> MT.show' t1 <> "' to '" <> MT.show' t2 <> "'" + f' t1 t2@(FunU _ _) = throwError . OtherError $ + "BadRealization: Cannot compare types '" <> MT.show' t1 <> "' to '" <> MT.show' t2 <> "'" + f' _ _ = return () + +checkup :: Gamma -> Expr -> UnresolvedType -> Stack (Gamma, [UnresolvedType], Expr) +checkup g e t = do + say "checkup" + (g', t', e') <- check g e t + return (g', [t'], e') + +typesetFromList :: [UnresolvedType] -> Stack TypeSet +typesetFromList ts = do + say "typesetFromList" + let gentype = [makeEType t | t <- ts, (isNothing . langOf) t] + contype = [makeEType t | t <- ts, (isJust . langOf) t] + case (gentype, contype) of + ([x], cs) -> return $ TypeSet (Just x) cs + ([], cs) -> return $ TypeSet Nothing cs + _ -> throwError $ OtherError "ambiguous general type" + where + makeEType :: UnresolvedType -> EType + makeEType t = EType + { etype = t + , eprop = Set.empty + , econs = Set.empty + } + +-- Synthesize types for a list of expressions. Each expression is synthesized +-- independently, though context is passed along. The returned "Maybe Type" is +-- the type of the paired expression in the given language. +chainInfer :: Maybe Lang -> Gamma -> [Expr] -> Stack (Gamma, [(Maybe UnresolvedType, Expr)]) +chainInfer lang g0 es0 = do + say "chainInfer" + chainInfer' g0 (reverse es0) [] + where + chainInfer' :: + Gamma -> [Expr] -> [(Maybe UnresolvedType,Expr)] -> Stack (Gamma, [(Maybe UnresolvedType, Expr)]) + chainInfer' g [] xs = return (g, xs) + chainInfer' g (e:es) xs = do + (g', ts, e') <- infer lang g e + let t' = listToMaybe $ filter (\t -> langOf t == lang) ts + chainInfer' g' es ((t', e'):xs) + +chainCheck :: [(UnresolvedType, Expr)] -> Gamma -> Stack (Gamma, [UnresolvedType], [Expr]) +chainCheck xs g0 = do + (g, ts, es) <- foldM f (g0, [], []) xs + return (g, reverse ts, reverse es) + where + f :: (Gamma, [UnresolvedType], [Expr]) + -> (UnresolvedType, Expr) + -> Stack (Gamma, [UnresolvedType], [Expr]) + f (g', ts, es) (t', e') = do + (g'', t'', e'') <- check g' e' t' + return (g'', t'':ts, e'':es) + + + +-- ----- U T I L I T I E S ---------------------------------------------- + +enter :: Doc AnsiStyle -> Stack () +enter d = do + depth <- incDepth + debugLog $ pretty (take depth (repeat '-')) <> ">" <+> align d <> "\n" + +say :: Doc AnsiStyle -> Stack () +say d = do + depth <- getDepth + debugLog $ pretty (take depth (repeat ' ')) <> ":" <+> align d <> "\n" + +seeGamma :: Gamma -> Stack () +seeGamma g = say $ nest 4 $ "Gamma:" <> line <> (vsep (map prettyGammaIndex g)) + +leave :: Doc AnsiStyle -> Stack () +leave d = do + depth <- decDepth + debugLog $ "<" <> pretty (take depth (repeat '-')) <+> align d <> "\n" + +debugLog :: Doc AnsiStyle -> Stack () +debugLog d = do + verbosity <- R.asks stackConfigVerbosity + if verbosity > 0 + then (liftIO . putDoc) d + else return () diff --git a/library/Morloc/Frontend/Internal.hs b/library/Morloc/Frontend/Internal.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Frontend/Internal.hs @@ -0,0 +1,378 @@ +{-| +Module : Morloc.Frontend.Internal +Description : Utilities for type checking +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.Frontend.Internal + ( (+>) + , (++>) + , Renameable(..) + , Applicable(..) + , Typed(..) + , access1 + , access2 + , accessWith1 + , ann + , anns + , cut + , generalize + , generalizeE + , generalizeTypeSet + , index + , lookupE + , lookupU + , mapU + , mapU' + , newqul + , newvar + , newvarRich + , throwError + , serialConstraint + , incDepth + , decDepth + , getDepth + , langsOf + ) where + +import Control.Monad.Except (throwError) +import Morloc.Frontend.Namespace +import qualified Control.Monad.State as CMS +import qualified Data.Set as Set +import qualified Morloc.Data.Text as MT +import qualified Morloc.Frontend.PartialOrder as P + +class HasManyLanguages a where + langsOf :: Gamma -> a -> [Maybe Lang] + +instance HasManyLanguages TypeSet where + langsOf _ (TypeSet Nothing es) = map langOf es + langsOf _ (TypeSet (Just e) es) = langOf e : map langOf es + +instance HasManyLanguages Expr where + langsOf g0 e0 = unique $ Nothing : langsOf' g0 e0 where + langsOf' _ (SrcE srcs) = map (Just . srcLang) srcs + langsOf' _ (Signature _ t) = [langOf t] + langsOf' g (Declaration _ e) = langsOf' g e + langsOf' _ UniE = [] + langsOf' g (VarE v) = case lookupE v g of + (Just (_, ts)) -> langsOf g ts + Nothing -> [] + langsOf' g (AccE e _) = langsOf' g e + langsOf' g (ListE es) = concat . map (langsOf' g) $ es + langsOf' g (TupleE es) = concat . map (langsOf' g) $ es + langsOf' g (LamE _ e) = langsOf' g e + langsOf' g (AppE e1 e2) = langsOf' g e1 ++ langsOf' g e2 + langsOf' _ (AnnE _ ts) = map langOf ts + langsOf' _ (NumE _) = [] + langsOf' _ (LogE _) = [] + langsOf' _ (StrE _) = [] + langsOf' g (RecE entries) = concat . map (langsOf' g . snd) $ entries + +class Renameable a where + rename :: a -> Stack a + unrename :: a -> a + +instance Renameable Expr where + rename = mapU' rename + unrename = mapU unrename + +instance Renameable UnresolvedType where + rename t@(VarU _) = return t + rename (ExistU v ts ds) = ExistU <$> pure v <*> (mapM rename ts) <*> (mapM rename ds) + rename (ForallU v t) = do + v' <- rename v + t' <- rename (P.substitute v (VarU v') t) + return $ ForallU v' t' + rename (FunU t1 t2) = FunU <$> rename t1 <*> rename t2 + rename (ArrU v ts) = ArrU <$> pure v <*> mapM rename ts + rename (NamU r v ts rs) = + NamU r <$> pure v <*> mapM rename ts <*> mapM (\(x, t) -> (,) <$> pure x <*> rename t) rs + + unrename (VarU v) = VarU (unrename v) + unrename (ExistU v ts ds) = ExistU v (map unrename ts) (map unrename ds) + unrename (ForallU v t) = ForallU (unrename v) (unrename t) + unrename (FunU t1 t2) = FunU (unrename t1) (unrename t2) + unrename (ArrU v ts) = ArrU v (map unrename ts) + unrename (NamU r v ts rs) = NamU r v (map unrename ts) [(x, unrename t) | (x, t) <- rs] + +instance Renameable TVar where + unrename (TV l t) = TV l . head $ MT.splitOn "." t + rename = newqul + + +class Applicable a where + apply :: Gamma -> a -> a + +-- | Apply a context to a type (See Dunfield Figure 8). +instance Applicable UnresolvedType where + -- [G]a = a + apply _ a@(VarU _) = a + -- [G](A->B) = ([G]A -> [G]B) + apply g (FunU a b) = FunU (apply g a) (apply g b) + -- [G]ForallU a.a = forall a. [G]a + apply g (ForallU x a) = ForallU x (apply g a) + -- [G[a=t]]a = [G[a=t]]t + apply g (ExistU v ts ds) = + case lookupU v g of + -- FIXME: this seems problematic - do I keep the previous parameters or the new ones? + (Just t') -> apply g t' -- reduce an existential; strictly smaller term + Nothing -> ExistU v (map (apply g) ts) (map (apply g) ds) + apply g (ArrU v ts) = ArrU v (map (apply g) ts) + apply g (NamU r v ts rs) = NamU r v (map (apply g) ts) (map (\(n, t) -> (n, apply g t)) rs) + +instance Applicable Expr where + apply g e = mapU (apply g) e + +instance Applicable EType where + apply g e = e { etype = apply g (etype e) } + + +class Typed a where + toType :: Maybe Lang -> a -> Maybe UnresolvedType + fromType :: Maybe Lang -> UnresolvedType -> a + +instance Typed EType where + toType lang e + | (langOf . etype) e == lang = Just (etype e) + | otherwise = Nothing + fromType _ t = + EType + { etype = t + , eprop = Set.empty + , econs = Set.empty + } + + +instance Typed TypeSet where + toType Nothing (TypeSet e _) = e >>= toType Nothing + toType lang (TypeSet _ ts) = case filter (\e -> (langOf . etype) e == lang) ts of + [ ] -> Nothing + [e] -> Just (etype e) + _ -> error "a typeset can contain only one instance of each language" + + fromType Nothing t = TypeSet (Just (fromType Nothing t)) [] + fromType lang t = TypeSet Nothing [fromType lang t] + +serialConstraint :: UnresolvedType -> UnresolvedType -> Stack () +serialConstraint t1 t2 = do + s <- CMS.get + CMS.put (s {stateSer = (t1, t2):stateSer s}) + +incDepth :: Stack Int +incDepth = do + s <- CMS.get + let depth = stateDepth s + 1 + CMS.put (s {stateDepth = depth}) + return depth + +decDepth :: Stack Int +decDepth = do + s <- CMS.get + let depth = stateDepth s - 1 + CMS.put (s {stateDepth = depth}) + return depth + +getDepth :: Stack Int +getDepth = CMS.gets stateDepth + +mapU :: (UnresolvedType -> UnresolvedType) -> Expr -> Expr +mapU f (LamE v e) = LamE v (mapU f e) +mapU f (ListE es) = ListE (map (mapU f) es) +mapU f (TupleE es) = TupleE (map (mapU f) es) +mapU f (RecE rs) = RecE (zip (map fst rs) (map (mapU f . snd) rs)) +mapU f (AppE e1 e2) = AppE (mapU f e1) (mapU f e2) +mapU f (AnnE e ts) = AnnE (mapU f e) (map f ts) +mapU f (Declaration v e) = Declaration v (mapU f e) +mapU f (Signature v e) = Signature v $ e {etype = f (etype e)} +mapU _ e = e + +mapU' :: Monad m => (UnresolvedType -> m UnresolvedType) -> Expr -> m Expr +mapU' f (LamE v e) = LamE <$> pure v <*> mapU' f e +mapU' f (ListE es) = ListE <$> mapM (mapU' f) es +mapU' f (RecE rs) = do + es' <- mapM (mapU' f . snd) rs + return $ RecE (zip (map fst rs) es') +mapU' f (TupleE es) = TupleE <$> mapM (mapU' f) es +mapU' f (AppE e1 e2) = AppE <$> mapU' f e1 <*> mapU' f e2 +mapU' f (AnnE e ts) = AnnE <$> mapU' f e <*> mapM f ts +mapU' f (Declaration v e) = Declaration <$> pure v <*> mapU' f e +mapU' f (Signature v e) = do + t' <- f (etype e) + return $ Signature v (e {etype = t'}) +mapU' _ e = return e + +(+>) :: Indexable a => Gamma -> a -> Gamma +(+>) xs x = (index x) : xs + +(++>) :: Indexable a => Gamma -> [a] -> Gamma +(++>) g xs = map index (reverse xs) ++ g + +-- | remove context up to a marker +cut :: GammaIndex -> Gamma -> Stack Gamma +cut _ [] = throwError EmptyCut +cut i (x:xs) + | i == x = return xs + | otherwise = cut i xs + +-- | Look up a type annotated expression +lookupE :: EVar -> Gamma -> Maybe (Expr, TypeSet) +lookupE _ [] = Nothing +lookupE v ((AnnG (Declaration v' e) t):gs) + | v == v' = Just (e, t) + | otherwise = lookupE v gs +lookupE v ((AnnG e@(VarE v') t):gs) + | v == v' = Just (e, t) + | otherwise = lookupE v gs +lookupE v (_:gs) = lookupE v gs + +-- | Look up a solved existential type variable +lookupU :: TVar -> Gamma -> Maybe UnresolvedType +lookupU _ [] = Nothing +lookupU v ((SolvedG v' t):gs) + | v == v' = Just t + | otherwise = lookupU v gs +lookupU v (_:gs) = lookupU v gs + +access1 :: TVar -> Gamma -> Maybe (Gamma, GammaIndex, Gamma) +access1 v gs = + case findIndex (exists v) gs of + (Just 0) -> Just ([], head gs, tail gs) + (Just i) -> Just (take i gs, gs !! i, drop (i + 1) gs) + _ -> Nothing + where + exists :: TVar -> GammaIndex -> Bool + exists v1 (ExistG v2 _ _) = v1 == v2 + exists _ _ = False + +accessWith1 :: Monad m => + (GammaIndex -> Bool) -- ^ method for finding the index + -> (GammaIndex -> m GammaIndex) -- ^ alter GammaIndex + -> (Gamma -> m Gamma) -- ^ default action if the index is not found + -> Gamma -- ^ context that is searched + -> m Gamma +accessWith1 select make def g = + case findIndex select g of + (Just i) -> + case (i, g !! i) of + (0, x) -> make x >>= (\y -> return ([] <> (y : tail g))) + (_, x) -> make x >>= (\y -> return (take i g <> (y : drop (i + 1) g))) + Nothing -> def g + +access2 :: + TVar -> TVar + -> Gamma -> Maybe (Gamma, GammaIndex, Gamma, GammaIndex, Gamma) +access2 lv rv gs = + case access1 lv gs of + Just (ls, x, rs) -> + case access1 rv rs of + Just (ls', y, rs') -> Just (ls, x, ls', y, rs') + _ -> Nothing + _ -> Nothing + +ann :: Expr -> UnresolvedType -> Expr +ann (AnnE e _) t = AnnE e [t] +ann e@(Declaration _ _) _ = e +ann e@(Signature _ _) _ = e +ann e t = AnnE e [t] + +anns :: Expr -> [UnresolvedType] -> Expr +anns (AnnE e _) ts = AnnE e ts +anns e@(Declaration _ _) _ = e +anns e@(Signature _ _) _ = e +anns e ts = AnnE e ts + +-- | Deal with existentials. +-- This function is used to resolve remaining existentials when no further +-- inferences about their type can be made. If the existentials have a default +-- type, then that type can be used to replace the existential. Otherwise, the +-- existential can be cast as generic (ForallU). +generalize :: UnresolvedType -> UnresolvedType +generalize = (\t -> generalize' (existentialMap t) t) . setDefaults where + generalize' :: [(TVar, Name)] -> UnresolvedType -> UnresolvedType + generalize' [] t = t + generalize' ((e, r):xs) t = generalize' xs (generalizeOne e r t) + + setDefaults :: UnresolvedType -> UnresolvedType + setDefaults (ExistU v ps []) = ExistU v (map setDefaults ps) [] + setDefaults (ExistU _ _ (d:_)) = setDefaults d + setDefaults t@(VarU _) = t + setDefaults (ForallU v t) = ForallU v (setDefaults t) + setDefaults (FunU t1 t2) = FunU (setDefaults t1) (setDefaults t2) + setDefaults (ArrU v ts) = ArrU v (map setDefaults ts) + setDefaults (NamU r v ts es) + = NamU r v (map setDefaults ts) (zip (map fst es) (map (setDefaults . snd) es)) + + variables = [1 ..] >>= flip replicateM ['a' .. 'z'] + + existentialMap t = + zip (Set.toList (findExistentials t)) (map (Name . MT.pack) variables) + + findExistentials :: UnresolvedType -> Set.Set TVar + findExistentials (VarU _) = Set.empty + findExistentials (ExistU v ts ds) = + Set.unions + $ [Set.singleton v] + ++ map findExistentials ts + ++ map findExistentials ds + findExistentials (ForallU v t) = Set.delete v (findExistentials t) + findExistentials (FunU t1 t2) = + Set.union (findExistentials t1) (findExistentials t2) + findExistentials (ArrU _ ts) = Set.unions (map findExistentials ts) + findExistentials (NamU _ _ ts rs) + = Set.unions (map findExistentials ts ++ map (findExistentials . snd) rs) + + generalizeOne :: TVar -> Name -> UnresolvedType -> UnresolvedType + generalizeOne v0@(TV lang0 _) r0 t0 = ForallU (TV lang0 (unName r0)) (f v0 t0) + where + f :: TVar -> UnresolvedType -> UnresolvedType + f v t1@(ExistU v' [] _) + | v == v' = VarU (TV lang0 (unName r0)) + | otherwise = t1 + f v (ExistU v' ts _) + | v == v' = ArrU (TV lang0 (unName r0)) (map (f v) ts) + | otherwise = ArrU v (map (f v) ts) + f v (FunU t1 t2) = FunU (f v t1) (f v t2) + f v t1@(ForallU x t2) + | v /= x = ForallU x (f v t2) + | otherwise = t1 + f v (ArrU v' xs) = ArrU v' (map (f v) xs) + f v (NamU r v' ts xs) = NamU r v' (map (f v) ts) [(k, f v t) | (k, t) <- xs] + f _ t1 = t1 + +generalizeE :: Expr -> Expr +generalizeE = mapU generalize + +generalizeEType :: EType -> EType +generalizeEType e = e {etype = generalize (etype e)} + +generalizeTypeSet :: TypeSet -> TypeSet +generalizeTypeSet (TypeSet t ts) = + TypeSet (fmap generalizeEType t) (map generalizeEType ts) + +newvar :: Maybe Lang -> Stack UnresolvedType +newvar = newvarRich [] [] + +newvarRich + :: [UnresolvedType] + -> [UnresolvedType] -- ^ default types + -> Maybe Lang + -> Stack UnresolvedType +newvarRich ps ds lang = do + s <- CMS.get + let v = newvars !! stateVar s + CMS.put $ s {stateVar = stateVar s + 1} + return (ExistU (TV lang v) ps ds) + where + newvars = + zipWith (\x y -> MT.pack (x ++ show y)) (repeat "t") ([0 ..] :: [Integer]) + +newqul :: TVar -> Stack TVar +newqul (TV l v) = do + s <- CMS.get + let v' = TV l (v <> "." <> (MT.pack . show $ stateQul s)) -- create a new variable such as "a.0" + CMS.put $ s {stateQul = stateQul s + 1} + return v' diff --git a/library/Morloc/Frontend/Lang/DefaultTypes.hs b/library/Morloc/Frontend/Lang/DefaultTypes.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Frontend/Lang/DefaultTypes.hs @@ -0,0 +1,92 @@ +{-| +Module : Morloc.Frontend.Lang.DefaultTypes +Description : Define default types for each language +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental + +Concrete types are usually inferred from concrete function types. But in some +cases, it is necessary to guess the type. For example, in the statement @f x = +[x]@, a concrete list container is needed. When @f@ is called from another +function, the concrete list type can be inferred. But if @f@ is directly +exported, the concrete list type is unknown. Providing a concrete signature for +@f@, however, limits the use of @f@ in other functions. Thus a default type is +needed. +-} + +module Morloc.Frontend.Lang.DefaultTypes + ( defaultBool + , defaultList + , defaultNull + , defaultNumber + , defaultRecord + , defaultString + , defaultTuple + ) where + +import Morloc.Frontend.Namespace +import qualified Morloc.Data.Text as MT + +defaultList :: Maybe Lang -> UnresolvedType -> [UnresolvedType] +defaultList lang@Nothing t = [ArrU (TV lang "List") [t]] +defaultList lang@(Just Python3Lang) t = [ArrU (TV lang "list") [t]] +defaultList lang@(Just RLang) t = [ArrU (TV lang "list") [t]] +defaultList lang@(Just CLang) t = [ArrU (TV lang "$1*") [t]] +defaultList lang@(Just CppLang) t = [ArrU (TV lang "std::vector<$1>") [t]] +defaultList lang@(Just PerlLang) t = [ArrU (TV lang "array") [t]] + +defaultTuple :: Maybe Lang -> [UnresolvedType] -> [UnresolvedType] +defaultTuple lang@Nothing ts = [ArrU (TV lang (MT.pack $ "Tuple" ++ show (length ts))) ts] +defaultTuple lang@(Just Python3Lang) ts = [ArrU (TV lang "tuple") ts] +defaultTuple lang@(Just RLang) ts = [ArrU (TV lang "tuple") ts] +defaultTuple (Just CLang) _ = [] +defaultTuple lang@(Just CppLang) ts = [ArrU (TV lang t) ts] where + vars = ["$" <> MT.show' i | i <- [1 .. length ts]] + t = "std::tuple<" <> MT.intercalate "," vars <> ">" +defaultTuple lang@(Just PerlLang) ts = [ArrU (TV lang "array") ts] + +defaultRecord :: Maybe Lang -> [(MT.Text, UnresolvedType)] -> [UnresolvedType] +defaultRecord lang@Nothing entries = [NamU NamRecord (TV lang "Record") [] entries] +defaultRecord lang@(Just Python3Lang) entries = [NamU NamRecord (TV lang "dict") [] entries] +defaultRecord lang@(Just RLang) entries = [NamU NamRecord (TV lang "list") [] entries] +defaultRecord (Just CLang) _ = [] +defaultRecord lang@(Just CppLang) entries = [NamU NamRecord (TV lang "struct") [] entries] +defaultRecord lang@(Just PerlLang) entries = [NamU NamRecord (TV lang "hash") [] entries] + +defaultNull :: Maybe Lang -> [UnresolvedType] +defaultNull lang@Nothing = [VarU (TV lang "Unit")] +defaultNull lang@(Just Python3Lang) = [VarU (TV lang "None")] +defaultNull lang@(Just RLang) = [VarU (TV lang "NULL")] +defaultNull lang@(Just CLang) = [VarU (TV lang "null")] +defaultNull lang@(Just CppLang) = [VarU (TV lang "null")] +defaultNull lang@(Just PerlLang) = [VarU (TV lang "NULL")] + +defaultBool :: Maybe Lang -> [UnresolvedType] +defaultBool lang@Nothing = [VarU (TV lang "Bool")] +defaultBool lang@(Just Python3Lang) = [VarU (TV lang "bool")] +defaultBool lang@(Just RLang) = [VarU (TV lang "logical" )] +defaultBool lang@(Just CLang) = [VarU (TV lang "bool")] +defaultBool lang@(Just CppLang) = [VarU (TV lang "bool")] +defaultBool lang@(Just PerlLang) = [VarU (TV lang "bool")] + +defaultString :: Maybe Lang -> [UnresolvedType] +defaultString lang@Nothing = [VarU (TV lang "Str")] +defaultString lang@(Just Python3Lang) = [VarU (TV lang "str")] +defaultString lang@(Just RLang) = [VarU (TV lang "character")] +defaultString lang@(Just CLang) = [VarU (TV lang "char*")] +defaultString lang@(Just CppLang) = [VarU (TV lang "std::string")] +defaultString lang@(Just PerlLang) = [VarU (TV lang "str")] + +defaultNumber :: Maybe Lang -> [UnresolvedType] +defaultNumber lang@Nothing = [VarU (TV lang "Num"), VarU (TV lang "Int")] +defaultNumber lang@(Just Python3Lang) = [VarU (TV lang "float"), VarU (TV lang "int")] +defaultNumber lang@(Just RLang) = [VarU (TV lang "numeric"), VarU (TV lang "integer")] +defaultNumber lang@(Just CLang) = [VarU (TV lang "double"), VarU (TV lang "int")] +defaultNumber lang@(Just CppLang) = + [ VarU (TV lang "double") + , VarU (TV lang "int") + , VarU (TV lang "long") + , VarU (TV lang "size_t") + ] +defaultNumber lang@(Just PerlLang) = [VarU (TV lang "double")] diff --git a/library/Morloc/Frontend/Namespace.hs b/library/Morloc/Frontend/Namespace.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Frontend/Namespace.hs @@ -0,0 +1,235 @@ +{-| +Module : Morloc.Frontend.Namespace +Description : All frontend types and datastructures +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.Frontend.Namespace + ( module Morloc.Namespace + , Expr(..) + , Import(..) + , Stack + , StackState(..) + , StackConfig(..) + -- ** DAG and associated types + , ParserNode(..) + , ParserDag + , PreparedNode(..) + , PreparedDag + , TypedNode(..) + , TypedDag + -- ** Typechecking + , Gamma + , GammaIndex(..) + , EType(..) + , TypeSet(..) + , Indexable(..) + -- ** ModuleGamma paraphernalia + , ModularGamma + -- rifraf + , resolve + , substituteT + ) where + +import Morloc.Namespace +import Data.Set (Set) +import Data.Map.Strict (Map) +import Control.Monad.Except (ExceptT) +import Control.Monad.Reader (ReaderT) +import Control.Monad.State (StateT) +import Control.Monad.Writer (WriterT) +import Data.Scientific (Scientific) +import Data.Text (Text) + + + +-- This functions removes qualified and existential types. +-- * all qualified terms are replaced with UnkT +-- * all existentials are replaced with default values if a possible +-- FIXME: should I really just take the first in the list??? +resolve :: UnresolvedType -> Type +resolve (VarU v) = VarT v +resolve (FunU t1 t2) = FunT (resolve t1) (resolve t2) +resolve (ArrU v ts) = ArrT v (map resolve ts) +resolve (NamU r v ps rs) = + let ts' = map (resolve . snd) rs + ps' = map resolve ps + in NamT r v ps' (zip (map fst rs) ts') +resolve (ExistU _ _ []) = error "UnsolvedExistentialTerm" +resolve (ExistU _ _ (t:_)) = resolve t +resolve (ForallU v t) = substituteT v (UnkT v) (resolve t) + +-- | substitute all appearances of a given variable with a given new type +substituteT :: TVar -> Type -> Type -> Type +substituteT v0 r0 t0 = sub t0 + where + sub :: Type -> Type + sub t@(UnkT _) = t + sub t@(VarT v) + | v0 == v = r0 + | otherwise = t + sub (FunT t1 t2) = FunT (sub t1) (sub t2) + sub (ArrT v ts) = ArrT v (map sub ts) + sub (NamT r v ts rs) = NamT r v (map sub ts) [(x, sub t) | (x, t) <- rs] + + +-- | Terms, see Dunfield Figure 1 +data Expr + = SrcE [Source] + -- ^ import "c" from "foo.c" ("f" as yolo) + | Signature EVar EType + -- ^ x :: A; e + | Declaration EVar Expr + -- ^ x=e1; e2 + | UniE + -- ^ (()) + | VarE EVar + -- ^ (x) + | AccE Expr EVar + -- ^ person@age - access a field in a record + | ListE [Expr] + -- ^ [e] + | TupleE [Expr] + -- ^ (e1), (e1,e2), ... (e1,e2,...,en) + | LamE EVar Expr + -- ^ (\x -> e) + | AppE Expr Expr + -- ^ (e e) + | AnnE Expr [UnresolvedType] + -- ^ (e : A) + | NumE Scientific + -- ^ number of arbitrary size and precision + | LogE Bool + -- ^ boolean primitive + | StrE Text + -- ^ literal string + | RecE [(EVar, Expr)] + deriving (Show, Ord, Eq) + +-- | Extended Type that may represent a language specific type as well as sets +-- of properties and constrains. +data EType = + EType + { etype :: UnresolvedType + , eprop :: Set Property + , econs :: Set Constraint + } + deriving (Show, Eq, Ord) + +instance HasOneLanguage EType where + langOf e = langOf (etype e) + +data Import = + Import + { importModuleName :: MVar + , importInclude :: Maybe [(EVar, EVar)] + , importExclude :: [EVar] + , importNamespace :: Maybe EVar -- currently not used + } + deriving (Ord, Eq, Show) + +-- | A context, see Dunfield Figure 6 +data GammaIndex + = VarG TVar + -- ^ (G,a) + | AnnG Expr TypeSet + -- ^ (G,x:A) looked up in the (Var) and cut in (-->I) + | ExistG TVar [UnresolvedType] [UnresolvedType] + -- ^ (G,a^) unsolved existential variable + | SolvedG TVar UnresolvedType + -- ^ (G,a^=t) Store a solved existential variable + | MarkG TVar + -- ^ (G,>a^) Store a type variable marker bound under a forall + | MarkEG EVar + -- ^ ... + | SrcG Source + -- ^ source + | UnsolvedConstraint UnresolvedType UnresolvedType + -- ^ Store an unsolved serialization constraint containing one or more + -- existential variables. When the existential variables are solved, the + -- constraint will be written into the Stack state. + deriving (Ord, Eq, Show) + +type Gamma = [GammaIndex] + +data TypeSet = + TypeSet (Maybe EType) [EType] + deriving (Show, Eq, Ord) + +type ModularGamma = Map MVar (Map EVar TypeSet) + +class Indexable a where + index :: a -> GammaIndex + +instance Indexable GammaIndex where + index = id + +instance Indexable UnresolvedType where + index (ExistU t ts ds) = ExistG t ts ds + index t = error $ "Can only index ExistT, found: " <> show t + + + +type GeneralStack c e l s a + = ReaderT c (ExceptT e (WriterT l (StateT s IO))) a + +type Stack a = GeneralStack StackConfig MorlocError [Text] StackState a + +data StackConfig = + StackConfig + { stackConfigVerbosity :: Int + } + +data StackState = + StackState + { stateVar :: Int + , stateQul :: Int + , stateSer :: [(UnresolvedType, UnresolvedType)] + , stateDepth :: Int + } + deriving (Ord, Eq, Show) + + + +-- | The type returned from the Parser. It contains all the information in a +-- single module but knows NOTHING about other modules. +data ParserNode = ParserNode { + parserNodePath :: Maybe Path + , parserNodeBody :: [Expr] + , parserNodeSourceMap :: Map (EVar, Lang) Source + , parserNodeTypedefs :: Map TVar (UnresolvedType, [TVar]) + , parserNodeExports :: Set EVar +} deriving (Show, Ord, Eq) +type ParserDag = DAG MVar Import ParserNode + +-- | Node description after desugaring (substitute type aliases and resolve +-- imports/exports) +data PreparedNode = PreparedNode { + preparedNodePath :: Maybe Path + , preparedNodeBody :: [Expr] + , preparedNodeSourceMap :: Map (EVar, Lang) Source + , preparedNodeExports :: Set EVar + , preparedNodeTypedefs :: Map TVar (UnresolvedType, [TVar]) + , preparedNodePackers :: Map (TVar, Int) [UnresolvedPacker] + -- ^ The (un)packers available in this module scope. +} deriving (Show, Ord, Eq) +type PreparedDag = DAG MVar [(EVar, EVar)] ParserNode + +-- | Node description after type checking. This will later be fed into +-- `treeify` to make the SAnno objects that will be passed to Generator. +data TypedNode = TypedNode { + typedNodeModuleName :: MVar + , typedNodePath :: Maybe Path + , typedNodeBody :: [Expr] + , typedNodeTypeMap :: Map EVar TypeSet + , typedNodeSourceMap :: Map (EVar, Lang) Source + , typedNodeExports :: Set EVar + , typedNodeTypedefs :: Map TVar (Type, [TVar]) + , typedNodePackers :: Map (TVar, Int) [UnresolvedPacker] + , typedNodeConstructors :: Map TVar Source + -- ^ The (un)packers available in this module scope. +} deriving (Show, Ord, Eq) +type TypedDag = DAG MVar [(EVar, EVar)] TypedNode diff --git a/library/Morloc/Frontend/Parser.hs b/library/Morloc/Frontend/Parser.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Frontend/Parser.hs @@ -0,0 +1,642 @@ +{-| +Module : Morloc.Frontend.Parser +Description : Full parser for Morloc +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Morloc.Frontend.Parser + ( readProgram + , readType + ) where + +import Data.Void (Void) +import Morloc.Frontend.Namespace +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Morloc.Frontend.Lang.DefaultTypes as MLD +import qualified Control.Monad.State as CMS +import qualified Data.Map as Map +import qualified Data.Scientific as DS +import qualified Data.Set as Set +import qualified Data.Char as DC +import qualified Morloc.Data.Text as MT +import qualified Morloc.Language as ML +import qualified Morloc.System as MS +import qualified Text.Megaparsec.Char.Lexer as L + +type Parser a = CMS.StateT ParserState (Parsec Void MT.Text) a + +data ParserState = ParserState { + stateLang :: Maybe Lang + , stateModulePath :: Maybe Path + , stateIndex :: Int + , stateGenerics :: [TVar] -- store the observed generic variables in the current type + -- you should reset the field before parsing a new type +} + +emptyState :: ParserState +emptyState = ParserState { + stateLang = Nothing + , stateModulePath = Nothing + , stateIndex = 1 + , stateGenerics = [] +} + +newvar :: Maybe Lang -> Parser TVar +newvar lang = do + s <- CMS.get + let i = stateIndex s + CMS.put (s {stateIndex = i + 1}) + return (TV lang ("p" <> MT.show' i)) + +setLang :: Maybe Lang -> Parser () +setLang lang = do + s <- CMS.get + CMS.put (s { stateLang = lang }) + +resetGenerics :: Parser () +resetGenerics = do + s <- CMS.get + CMS.put (s { stateGenerics = [] }) + +appendGenerics :: TVar -> Parser () +appendGenerics v@(TV _ vstr) = do + s <- CMS.get + let isGeneric = maybe False (DC.isLower . fst) (MT.uncons vstr) + gs = stateGenerics s + gs' = if isGeneric then v : gs else gs + CMS.put (s {stateGenerics = gs'}) + +readProgram + :: Maybe Path + -> MT.Text + -> DAG MVar Import ParserNode + -> DAG MVar Import ParserNode +readProgram f sourceCode p = + case runParser + (CMS.runStateT (sc >> pProgram <* eof) pstate) + (maybe "" (MT.unpack . unPath) f) + sourceCode of + Left err -> error (show err) + Right (es, _) -> foldl (\d (k,xs,n) -> Map.insert k (n,xs) d) p es + where + pstate = emptyState { stateModulePath = f } + +readType :: MT.Text -> UnresolvedType +readType typeStr = + case runParser (CMS.runStateT (pTypeGen <* eof) emptyState) "" typeStr of + Left err -> error (show err) + Right (es, _) -> es + +many1 :: Parser a -> Parser [a] +many1 p = do + x <- p + xs <- many p + return (x : xs) + +-- sc stands for space consumer +sc :: Parser () +sc = L.space space1 lineComment blockComment + where + lineComment = L.skipLineComment "--" + blockComment = L.skipBlockComment "{-" "-}" + +symbol = L.symbol sc + +-- A lexer where space is consumed after every token (but not before) +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +number :: Parser DS.Scientific +number = lexeme $ L.signed sc L.scientific -- `empty` because no space is allowed + +parens :: Parser a -> Parser a +parens p = lexeme $ between (symbol "(") (symbol ")") p + +brackets :: Parser a -> Parser a +brackets p = lexeme $ between (symbol "[") (symbol "]") p + +braces :: Parser a -> Parser a +braces p = lexeme $ between (symbol "{") (symbol "}") p + +angles :: Parser a -> Parser a +angles p = lexeme $ between (symbol "<") (symbol ">") p + +reservedWords :: [MT.Text] +reservedWords = + [ "module" + , "source" + , "from" + , "where" + , "import" + , "export" + , "as" + , "True" + , "False" + , "type" + ] + +operatorChars :: String +operatorChars = ":!$%&*+./<=>?@\\^|-~#" + +delimiter :: Parser () +delimiter = many1 (symbol ";") >> return () + +op :: MT.Text -> Parser MT.Text +op o = (lexeme . try) (symbol o <* notFollowedBy (oneOf operatorChars)) + +reserved :: MT.Text -> Parser MT.Text +reserved w = try (symbol w) + +stringLiteral :: Parser MT.Text +stringLiteral = do + _ <- symbol "\"" + s <- many (noneOf ['"']) + _ <- symbol "\"" + return $ MT.pack s + +name :: Parser MT.Text +name = (lexeme . try) (p >>= check) + where + p = fmap MT.pack $ (:) <$> letterChar <*> many (alphaNumChar <|> char '_') + check x = + if elem x reservedWords + then failure Nothing Set.empty -- TODO: error message + else return x + +data Toplevel + = TModule (MVar, [(MVar, Import)], ParserNode) + | TModuleBody ModuleBody + +data ModuleBody + = MBImport Import + -- ^ module name, function name and optional alias + | MBExport EVar + | MBTypeDef TVar [TVar] UnresolvedType + | MBBody Expr + +pProgram :: Parser [(MVar, [(MVar, Import)], ParserNode)] +pProgram = do + f <- CMS.gets stateModulePath + -- allow ';' at the beginning (if you're into that sort of thing) + optional delimiter + es <- many pToplevel + let mods = [m | (TModule m) <- es] + case [e | (TModuleBody e) <- es] of + [] -> return mods + es' -> return $ makeModule f (MVar "Main") es' : mods + +pToplevel :: Parser Toplevel +pToplevel = + try (fmap TModule pModule <* optional delimiter) <|> + fmap TModuleBody (pModuleBody <* optional delimiter) + +pModule :: Parser (MVar, [(MVar, Import)], ParserNode) +pModule = do + f <- CMS.gets stateModulePath + _ <- reserved "module" + moduleName' <- name + mes <- braces (optional delimiter >> many1 pModuleBody) + return $ makeModule f (MVar moduleName') mes + +makeModule :: Maybe Path -> MVar -> [ModuleBody] -> (MVar, [(MVar, Import)], ParserNode) +makeModule f n mes = (n, edges, node) where + imports' = [x | (MBImport x) <- mes] + exports' = Set.fromList [x | (MBExport x) <- mes] + body' = [x | (MBBody x) <- mes] + srcMap = (Map.fromList . concat) + [[((srcAlias s, srcLang s), s) | s <- ss ] | (SrcE ss) <- body'] + typedefmap = Map.fromList [(v, (t, vs)) | MBTypeDef v vs t <- mes] + edges = [(importModuleName i, i) | i <- imports'] + node = ParserNode + { parserNodePath = f + , parserNodeBody = body' + , parserNodeSourceMap = srcMap + , parserNodeExports = exports' + , parserNodeTypedefs = typedefmap + } + +pModuleBody :: Parser ModuleBody +pModuleBody = + try pTypedef <* optional delimiter + <|> try pImport <* optional delimiter + <|> try pExport <* optional delimiter + <|> try pStatement' <* optional delimiter + <|> pExpr' <* optional delimiter + where + pStatement' = fmap MBBody pStatement + pExpr' = fmap MBBody pExpr + +pTypedef :: Parser ModuleBody +pTypedef = pTypedefType <|> pTypedefObject + +pTypedefType :: Parser ModuleBody +pTypedefType = do + _ <- reserved "type" + lang <- optional (try pLang) + setLang lang + (v, vs) <- pTypedefTermUnpar <|> pTypedefTermPar + _ <- symbol "=" + t <- pType + setLang Nothing + return (MBTypeDef v vs t) + +pTypedefObject :: Parser ModuleBody +pTypedefObject = do + r <- pNamType + lang <- optional (try pLang) + setLang lang + (v, vs) <- pTypedefTermUnpar <|> pTypedefTermPar + _ <- symbol "=" + constructor <- name <|> stringLiteral + entries <- braces (sepBy1 pNamEntryU (symbol ",")) >>= mapM (desugarTableEntries lang r) + let t = NamU r (TV lang constructor) (map VarU vs) entries + setLang Nothing + return $ MBTypeDef v vs t + +desugarTableEntries + :: Maybe Lang + -> NamType + -> (MT.Text, UnresolvedType) + -> Parser (MT.Text, UnresolvedType) +desugarTableEntries _ NamRecord entry = return entry +desugarTableEntries _ NamObject entry = return entry +desugarTableEntries lang NamTable (k0, t0) = (,) k0 <$> f t0 where + f :: UnresolvedType -> Parser UnresolvedType + f (ForallU v t) = ForallU v <$> f t + f t = return $ head (MLD.defaultList lang t) + +pNamType :: Parser NamType +pNamType = choice [pNamObject, pNamTable, pNamRecord] + +pNamObject :: Parser NamType +pNamObject = do + _ <- reserved "object" + return NamObject + +pNamTable :: Parser NamType +pNamTable = do + _ <- reserved "table" + return NamTable + +pNamRecord :: Parser NamType +pNamRecord = do + _ <- reserved "record" + return NamRecord + +pTypedefTermUnpar :: Parser (TVar, [TVar]) +pTypedefTermUnpar = do + v <- name + lang <- CMS.gets stateLang + return (TV lang v, []) + +pTypedefTermPar :: Parser (TVar, [TVar]) +pTypedefTermPar = do + vs <- parens (many1 name) + lang <- CMS.gets stateLang + return (TV lang (head vs), map (TV lang) (tail vs)) + +pImport :: Parser ModuleBody +pImport = do + _ <- reserved "import" + n <- name + imports <- + optional $ + parens (sepBy pImportTerm (symbol ",")) <|> fmap (\x -> [(EVar x, EVar x)]) name + return . MBImport $ + Import + { importModuleName = MVar n + , importInclude = imports + , importExclude = [] + , importNamespace = Nothing + } + +pImportTerm :: Parser (EVar, EVar) +pImportTerm = do + n <- name + a <- option n (reserved "as" >> name) + return (EVar n, EVar a) + +pExport :: Parser ModuleBody +pExport = fmap (MBExport . EVar) $ reserved "export" >> name + +pStatement :: Parser Expr +pStatement = try pDeclaration <|> pSignature + +pDeclaration :: Parser Expr +pDeclaration = try pFunctionDeclaration <|> pDataDeclaration + +pDataDeclaration :: Parser Expr +pDataDeclaration = do + v <- name + _ <- symbol "=" + e <- pExpr + return (Declaration (EVar v) e) + +pFunctionDeclaration :: Parser Expr +pFunctionDeclaration = do + v <- name + args <- many1 name + _ <- op "=" + e <- pExpr + return $ Declaration (EVar v) (curryLamE (map EVar args) e) + where + curryLamE [] e' = e' + curryLamE (v:vs') e' = LamE v (curryLamE vs' e') + +pSignature :: Parser Expr +pSignature = do + v <- name + lang <- optional (try pLang) + setLang lang + _ <- op "::" + props <- option [] (try pPropertyList) + t <- pTypeGen + constraints <- + option [] $ reserved "where" >> braces (sepBy pConstraint (symbol ";")) + setLang Nothing + return $ + Signature + (EVar v) + (EType + { etype = t + , eprop = Set.fromList props + , econs = Set.fromList constraints + }) + +pLang :: Parser Lang +pLang = do + langStr <- name + case ML.readLangName langStr of + (Just lang) -> return lang + Nothing -> fancyFailure . Set.singleton . ErrorFail + $ "Langage '" <> MT.unpack langStr <> "' is not supported" + +-- | match an optional tag that precedes some construction +tag :: Parser a -> Parser (Maybe MT.Text) +tag p = optional (try tag') + where + tag' = do + l <- name + _ <- op ":" + _ <- lookAhead p + return l + +pPropertyList :: Parser [Property] +pPropertyList = + (parens (sepBy1 pProperty (symbol ",")) <|> sepBy1 pProperty (symbol ",")) <* + op "=>" + +pProperty :: Parser Property +pProperty = do + ps <- many1 name + case ps of + ["pack"] -> return Pack + ["unpack"] -> return Unpack + ["cast"] -> return Cast + _ -> return (GeneralProperty ps) + +pConstraint :: Parser Constraint +pConstraint = fmap (Con . MT.pack) (many (noneOf ['{', '}'])) + +pExpr :: Parser Expr +pExpr = + try pAcc + <|> try pNamE + <|> try pTuple + <|> try pUni + <|> try pAnn + <|> try pApp + <|> try pStrE + <|> try pLogE + <|> try pNumE + <|> try pSrcE + <|> pListE + <|> parens pExpr + <|> pLam + <|> pVar + +pSrcE :: Parser Expr +pSrcE = do + modulePath <- CMS.gets stateModulePath + reserved "source" + language <- pLang + srcfile <- optional (reserved "from" >> stringLiteral |>> Path) + rs <- parens (sepBy1 pImportSourceTerm (symbol ",")) + srcFile <- case (modulePath, srcfile) of + -- build a path to the source file by searching + -- > source "R" from "foo.R" ("Foo" as foo, "bar") + (Just f, Just srcfile') -> return . Just $ MS.combine (MS.takeDirectory f) srcfile' + -- we are sourcing from the language base + -- > source "R" ("sqrt", "t.test" as t_test) + (Just _, Nothing) -> return Nothing + -- this case SHOULD only occur in testing where the source file does not exist + -- file non-existence will be caught later + (Nothing, s) -> return s + return $ SrcE [Source { srcName = srcVar + , srcLang = language + , srcPath = srcFile + , srcAlias = aliasVar + } | (srcVar, aliasVar) <- rs] + +pImportSourceTerm :: Parser (Name, EVar) +pImportSourceTerm = do + n <- stringLiteral + a <- option n (reserved "as" >> name) + return (Name n, EVar a) + +pNamE :: Parser Expr +pNamE = fmap RecE $ braces (sepBy1 pNamEntryE (symbol ",")) + +pNamEntryE :: Parser (EVar, Expr) +pNamEntryE = do + n <- name + _ <- symbol "=" + e <- pExpr + return (EVar n, e) + +pListE :: Parser Expr +pListE = fmap ListE $ brackets (sepBy pExpr (symbol ",")) + +pTuple :: Parser Expr +pTuple = do + _ <- op "(" + e <- pExpr + _ <- op "," + es <- sepBy1 pExpr (op ",") + _ <- op ")" + return (TupleE (e : es)) + +pUni :: Parser Expr +pUni = symbol "Null" >> return UniE + +pAcc :: Parser Expr +pAcc = do + e <- parens pExpr <|> pNamE <|> pVar + _ <- symbol "@" + f <- name + return $ AccE e (EVar f) + +pAnn :: Parser Expr +pAnn = do + e <- + parens pExpr <|> pVar <|> pListE <|> try pNumE <|> pLogE <|> pStrE + _ <- op "::" + t <- pTypeGen + return $ AnnE e [t] + +pApp :: Parser Expr +pApp = do + f <- parens pExpr <|> pVar + (e:es) <- many1 s + return $ foldl AppE (AppE f e) es + where + s = try pAnn + <|> try (parens pExpr) + <|> try pUni + <|> try pStrE + <|> try pLogE + <|> try pNumE + <|> pListE + <|> pTuple + <|> pNamE + <|> pVar + +pLogE :: Parser Expr +pLogE = pTrue <|> pFalse + where + pTrue = reserved "True" >> return (LogE True) + pFalse = reserved "False" >> return (LogE False) + +pStrE :: Parser Expr +pStrE = fmap StrE stringLiteral + +pNumE :: Parser Expr +pNumE = fmap NumE number + +pLam :: Parser Expr +pLam = do + _ <- symbol "\\" + vs <- many1 pEVar + _ <- symbol "->" + e <- pExpr + return (curryLamE vs e) + where + curryLamE [] e' = e' + curryLamE (v:vs') e' = LamE v (curryLamE vs' e') + +pVar :: Parser Expr +pVar = fmap VarE pEVar + +pEVar :: Parser EVar +pEVar = fmap EVar name + +pTypeGen :: Parser UnresolvedType +pTypeGen = do + resetGenerics + t <- pType + s <- CMS.get + return $ forallWrap (unique (reverse (stateGenerics s))) t + where + forallWrap :: [TVar] -> UnresolvedType -> UnresolvedType + forallWrap [] t = t + forallWrap (v:vs) t = ForallU v (forallWrap vs t) + +pType :: Parser UnresolvedType +pType = + pExistential + <|> try pFunU + <|> try pUniU + <|> try pNamU + <|> try pArrU + <|> try parensType + <|> pListU + <|> pTupleU + <|> pVarU + +pUniU :: Parser UnresolvedType +pUniU = do + _ <- symbol "(" + _ <- symbol ")" + lang <- CMS.gets stateLang + v <- newvar lang + return (ExistU v [] (MLD.defaultNull lang)) + +parensType :: Parser UnresolvedType +parensType = do + _ <- tag (symbol "(") + t <- parens pType + return t + +pTupleU :: Parser UnresolvedType +pTupleU = do + lang <- CMS.gets stateLang + _ <- tag (symbol "(") + ts <- parens (sepBy1 pType (symbol ",")) + return $ head (MLD.defaultTuple lang ts) + +pNamU :: Parser UnresolvedType +pNamU = do + _ <- tag (symbol "{") + entries <- braces (sepBy1 pNamEntryU (symbol ",")) + lang <- CMS.gets stateLang + return $ head (MLD.defaultRecord lang entries) + +pNamEntryU :: Parser (MT.Text, UnresolvedType) +pNamEntryU = do + n <- name + _ <- op "::" + t <- pType + return (n, t) + +pExistential :: Parser UnresolvedType +pExistential = do + v <- angles name + return (ExistU (TV Nothing v) [] []) + +pArrU :: Parser UnresolvedType +pArrU = do + lang <- CMS.gets stateLang + _ <- tag (name <|> stringLiteral) + n <- name <|> stringLiteral + args <- many1 pType' + return $ ArrU (TV lang n) args + where + pType' = try pUniU <|> try parensType <|> pVarU <|> pListU <|> pTupleU <|> pNamU + +pFunU :: Parser UnresolvedType +pFunU = do + t <- pType' + _ <- op "->" + ts <- sepBy1 pType' (op "->") + return $ foldr1 FunU (t : ts) + where + pType' = try pUniU <|> try parensType <|> try pArrU <|> pVarU <|> pListU <|> pTupleU <|> pNamU + +pListU :: Parser UnresolvedType +pListU = do + _ <- tag (symbol "[") + t <- brackets pType + lang <- CMS.gets stateLang + return $ head (MLD.defaultList lang t) + +pVarU :: Parser UnresolvedType +pVarU = try pVarConU <|> pVarGenU + +pVarConU :: Parser UnresolvedType +pVarConU = do + lang <- CMS.gets stateLang + _ <- tag stringLiteral + n <- stringLiteral + return $ VarU (TV lang n) + +pVarGenU :: Parser UnresolvedType +pVarGenU = do + lang <- CMS.gets stateLang + _ <- tag name + n <- name + let v = TV lang n + appendGenerics v -- add the term to the generic list IF generic + return $ VarU v diff --git a/library/Morloc/Frontend/PartialOrder.hs b/library/Morloc/Frontend/PartialOrder.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Frontend/PartialOrder.hs @@ -0,0 +1,168 @@ +{-| +Module : Morloc.Frontend.PartialOrder +Description : Partial order implementation for types +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.Frontend.PartialOrder ( + substitute + , free + , isSubtypeOf + , equivalent + , mostGeneral + , mostSpecific + , mostSpecificSubtypes + , (<=) +) where + +import Morloc.Frontend.Namespace +import qualified Morloc.Data.Text as MT +import qualified Data.Set as Set +import qualified Data.PartialOrd as P + +-- | substitute all appearances of a given variable with a given new type +substitute :: TVar -> UnresolvedType -> UnresolvedType -> UnresolvedType +substitute v (ForallU q r) t = + if Set.member (VarU q) (free t) + then + let q' = getNewVariable r t -- get unused variable name from [a, ..., z, aa, ...] + r' = substitute q (VarU q') r -- substitute the new variable into the unqualified type + in ForallU q' (substitute v r' t) + else + ForallU q (substitute v r t) +substitute v r t = sub t + where + sub :: UnresolvedType -> UnresolvedType + sub t'@(VarU v') + | v == v' = r + | otherwise = t' + sub (FunU t1 t2) = FunU (sub t1) (sub t2) + sub t'@(ForallU x t'') + | v /= x = ForallU x (sub t'') + | otherwise = t' -- allows shadowing of the variable + sub (ArrU v' ts) = ArrU v' (map sub ts) + sub (NamU namType v' ts rs) = NamU namType v' (map sub ts) [(x, sub t') | (x, t') <- rs] + sub (ExistU v' ps ds) = ExistU v' (map sub ps) (map sub ds) + +free :: UnresolvedType -> Set.Set UnresolvedType +free v@(VarU _) = Set.singleton v +free v@(ExistU _ [] _) = Set.singleton v +free (ExistU v ts _) = Set.unions $ Set.singleton (ArrU v ts) : map free ts +free (FunU t1 t2) = Set.union (free t1) (free t2) +free (ForallU v t) = Set.delete (VarU v) (free t) +free (ArrU _ xs) = Set.unions (map free xs) +free (NamU _ _ _ rs) = Set.unions [free t | (_, t) <- rs] + +-- Types are partially ordered, 'forall a . a' is lower (more generic) than +-- Int. But 'forall a . a -> a' cannot be compared to 'forall a . a', since +-- they are different kinds. +-- The order of types is used to choose the most specific serialization functions. +-- As far as serialization is concerned, properties and constraints do not matter. +instance P.PartialOrd UnresolvedType where + (<=) (VarU v1) (VarU v2) = v1 == v2 + (<=) (ExistU v1 [] _) (ExistU v2 [] _) = v1 == v2 + (<=) (ExistU v1 ts1 _) (ExistU v2 ts2 _) + = v1 == v2 + && length ts1 == length ts2 + && foldl (&&) True (zipWith (P.<=) ts1 ts2) + (<=) (FunU t11 t12) (FunU t21 t22) + = (P.<=) t11 t21 + && (P.<=) t22 t12 + (<=) (ArrU v1 []) (ArrU v2 []) = v1 == v2 + (<=) (ArrU v1 ts1) (ArrU v2 ts2) + = v1 == v2 + && length ts1 == length ts2 + && foldl (&&) True (zipWith (P.<=) ts1 ts2) + (<=) (NamU _ v1 _ es1) (NamU _ v2 _ es2) + = v1 == v2 + && length ts1 == length ts2 + && foldl (&&) True (zipWith (P.<=) ts1 ts2) + where + ts1 = map snd es1 + ts2 = catMaybes $ map (\(k,_) -> lookup k es2) es1 + (<=) (ForallU v t1) t2 + | (P.==) (ForallU v t1) t2 = True + | otherwise = (P.<=) (substituteFirst v t1 t2) t2 + (<=) _ _ = False + + (==) (ForallU v1 t1) (ForallU v2 t2) = + if Set.member (VarU v1) (free t2) + then + let v = getNewVariable t1 t2 + in (P.==) (substitute v1 (VarU v) t1) (substitute v2 (VarU v) t2) + else (P.==) t1 (substitute v2 (VarU v1) t2) + (==) a b = a == b + +-- Substitute all v for the first term in t2 that corresponds to v in t1. If v +-- does not occur in t1, then t1 is returned unchanged (e.g., `forall a . Int`). +substituteFirst :: TVar -> UnresolvedType -> UnresolvedType -> UnresolvedType +substituteFirst v t1 t2 = case findFirst v t1 t2 of + (Just t) -> substitute v t t1 + Nothing -> t1 + +-- | get a fresh variable name that is not used in t1 or t2 +getNewVariable :: UnresolvedType -> UnresolvedType -> TVar +getNewVariable t1 t2 = findNew variables (Set.union (allVars t1) (allVars t2)) + where + variables = [1 ..] >>= flip replicateM ['a' .. 'z'] + + findNew :: [String] -> Set.Set UnresolvedType -> TVar + findNew [] _ = error "Could not fresh variable in an infinite list ... odd" + findNew (x:xs) ts + | Set.member (VarU v) ts = findNew xs ts + | otherwise = v + where + v = TV (langOf t1) (MT.pack x) + + allVars :: UnresolvedType -> Set.Set UnresolvedType + allVars (ForallU v t) = Set.union (Set.singleton (VarU v)) (allVars t) + allVars t = free t + + +findFirst :: TVar -> UnresolvedType -> UnresolvedType -> Maybe UnresolvedType +findFirst v (VarU v') t2 + | v == v' = Just t2 + | otherwise = Nothing +findFirst v (ForallU v1 t1) (ForallU v2 t2) + | v == v1 = Nothing + | otherwise = findFirst v t1 (substitute v2 (VarU v1) t2) +findFirst v (ForallU v1 t1) t2 + | v == v1 = Nothing + | otherwise = findFirst v (substitute v1 (VarU v1) t1) t2 +findFirst v (FunU t11 t12) (FunU t21 t22) + = case (findFirst v t11 t21, findFirst v t12 t22) of + (Just t, _) -> Just t + (_, Just t) -> Just t + _ -> Nothing +findFirst v (ArrU _ ts1) (ArrU _ ts2) + = listToMaybe . catMaybes $ zipWith (findFirst v) ts1 ts2 +findFirst v (NamU _ _ _ es1) (NamU _ _ _ es2) + = listToMaybe . catMaybes $ zipWith (findFirst v) ts1 ts2 + where + ts1 = map snd es1 + ts2 = catMaybes $ map (\(k,_) -> lookup k es2) es1 +findFirst _ _ _ = Nothing + +-- | is t1 a generalization of t2? +isSubtypeOf :: UnresolvedType -> UnresolvedType -> Bool +isSubtypeOf t1 t2 = case P.compare t1 t2 of + (Just x) -> x <= EQ + _ -> False + +equivalent :: UnresolvedType -> UnresolvedType -> Bool +equivalent t1 t2 = isSubtypeOf t1 t2 && isSubtypeOf t2 t1 + +-- | find all types that are not greater than any other type +mostGeneral :: [UnresolvedType] -> [UnresolvedType] +mostGeneral ts = P.minima ts + +-- | find all types that are not less than any other type +mostSpecific :: [UnresolvedType] -> [UnresolvedType] +mostSpecific ts = P.maxima ts + +-- | find the most specific subtypes +mostSpecificSubtypes :: UnresolvedType -> [UnresolvedType] -> [UnresolvedType] +mostSpecificSubtypes t ts = mostSpecific $ filter (\t2 -> isSubtypeOf t2 t) ts diff --git a/library/Morloc/Frontend/Pretty.hs b/library/Morloc/Frontend/Pretty.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Frontend/Pretty.hs @@ -0,0 +1,145 @@ +{-| +Module : Morloc.Frontend.Pretty +Description : Pretty is as pretty does +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.Frontend.Pretty + ( module Morloc.Pretty + , cute + , ugly + , prettyExpr + , prettyGammaIndex + ) where + +import Morloc.Frontend.Namespace +import qualified Data.Map as Map +import qualified Data.Set as Set +import Morloc.Data.Doc hiding (putDoc) +import Morloc.Pretty +import Data.Text.Prettyprint.Doc.Render.Terminal (putDoc, AnsiStyle) + +cute :: DAG MVar [(EVar, EVar)] TypedNode -> IO () +cute d = mapM_ (putDoc . cute') (Map.toList d) where + cute' :: (MVar, (TypedNode, [(MVar, [(EVar, EVar)])])) -> Doc AnsiStyle + cute' (v, (n, xs)) = block 4 (pretty v) (cuteBody n xs) + +cuteBody :: TypedNode -> [(MVar, [(EVar, EVar)])] -> Doc AnsiStyle +cuteBody t xs = prettyPackMap (typedNodePackers t) <> line + <> vsep (cuteSources (typedNodeSourceMap t)) <> line + <> vsep (map (uncurry cuteImport) xs) <> line <> cuteTypedNode t + +cuteImport :: MVar -> [(EVar, EVar)] -> Doc AnsiStyle +cuteImport m xs + = "from" <+> pretty m <+> "import" + <+> tupled (map (\(v1,v2) -> pretty v1 <+> "as" <+> pretty v2) xs) + +cuteSources :: Map.Map (EVar, Lang) Source -> [Doc AnsiStyle] +cuteSources m = map (\((v,l),src) -> pretty v <> "@" <> pretty l <+> pretty src) (Map.toList m) + +cuteTypedNode :: TypedNode -> Doc AnsiStyle +cuteTypedNode t = vsep (map prettyExpr (typedNodeBody t)) + +-- FIXME: why exactly do I even have this ugly function??? +ugly :: DAG MVar [(EVar, EVar)] TypedNode -> IO () +ugly = cute + +prettyTypeSet :: TypeSet -> Doc AnsiStyle +prettyTypeSet (TypeSet Nothing ts) + = encloseSep "(" ")" ";" (map (prettyGreenUnresolvedType . etype) ts) +prettyTypeSet (TypeSet (Just t) ts) + = encloseSep "(" ")" ";" (map (prettyGreenUnresolvedType . etype) (t:ts)) + + +prettyGammaIndex :: GammaIndex -> Doc AnsiStyle +prettyGammaIndex (VarG tv) = "VarG:" <+> pretty tv +prettyGammaIndex (AnnG e ts) = "AnnG:" <+> prettyExpr e <+> prettyTypeSet ts +prettyGammaIndex (ExistG tv ts ds) + = "ExistG:" + <+> pretty tv + <+> list (map (parens . prettyGreenUnresolvedType) ts) + <+> list (map (parens . prettyGreenUnresolvedType) ds) +prettyGammaIndex (SolvedG tv t) = "SolvedG:" <+> pretty tv <+> "=" <+> prettyGreenUnresolvedType t +prettyGammaIndex (MarkG tv) = "MarkG:" <+> pretty tv +prettyGammaIndex (MarkEG ev) = "MarkG:" <+> pretty ev +prettyGammaIndex (SrcG (Source ev1 lang _ _)) = "SrcG:" <+> pretty ev1 <+> viaShow lang +prettyGammaIndex (UnsolvedConstraint t1 t2) = "UnsolvedConstraint:" <+> prettyGreenUnresolvedType t1 <+> prettyGreenUnresolvedType t2 + +prettyExpr :: Expr -> Doc AnsiStyle +prettyExpr UniE = "()" +prettyExpr (VarE s) = pretty s +prettyExpr (AccE e k) = parens (prettyExpr e) <> "@" <> pretty k +prettyExpr (LamE n e) = "\\" <> pretty n <+> "->" <+> prettyExpr e +prettyExpr (AnnE e ts) = parens + $ prettyExpr e + <+> "::" + <+> encloseSep "(" ")" "; " (map prettyGreenUnresolvedType ts) +prettyExpr (AppE e1@(LamE _ _) e2) = parens (prettyExpr e1) <+> prettyExpr e2 +prettyExpr (AppE e1 e2) = parens (prettyExpr e1) <+> parens (prettyExpr e2) +prettyExpr (NumE x) = pretty (show x) +prettyExpr (StrE x) = dquotes (pretty x) +prettyExpr (LogE x) = pretty x +prettyExpr (Declaration v e) = pretty v <+> "=" <+> prettyExpr e +prettyExpr (ListE xs) = list (map prettyExpr xs) +prettyExpr (TupleE xs) = tupled (map prettyExpr xs) +prettyExpr (SrcE []) = "" +prettyExpr (SrcE srcs@(Source _ lang (Just f) _ : _)) = + "source" <+> + viaShow lang <+> + "from" <+> + pretty f <+> + tupled + (map + (\(n, a) -> + pretty n <> + if unName n == unEVar a + then "" + else (" as" <> pretty a)) + rs) + where + rs = [(n, a) | (Source n _ _ a) <- srcs] +prettyExpr (SrcE srcs@(Source _ lang Nothing _ : _)) = + "source" <+> + viaShow lang <+> + tupled + (map + (\(n, a) -> + pretty n <> + if unName n == unEVar a + then "" + else (" as" <> pretty a)) + rs) + where + rs = [(n,a) | (Source n _ _ a) <- srcs] +prettyExpr (RecE entries) = + encloseSep + "{" + "}" + ", " + (map (\(v, e) -> pretty v <+> "=" <+> prettyExpr e) entries) +prettyExpr (Signature v e) = + pretty v <+> elang' <> "::" <+> eprop' <> etype' <> econs' + where + elang' :: Doc AnsiStyle + elang' = maybe "" (\lang -> viaShow lang <> " ") (langOf . etype $ e) + eprop' :: Doc AnsiStyle + eprop' = + case Set.toList (eprop e) of + [] -> "" + xs -> tupled (map prettyProperty xs) <+> "=> " + etype' :: Doc AnsiStyle + etype' = prettyGreenUnresolvedType (etype e) + econs' :: Doc AnsiStyle + econs' = + case Set.toList (econs e) of + [] -> "" + xs -> " where" <+> tupled (map (\(Con x) -> pretty x) xs) + +prettyProperty :: Property -> Doc ann +prettyProperty Pack = "pack" +prettyProperty Unpack = "unpack" +prettyProperty Cast = "cast" +prettyProperty (GeneralProperty ts) = hsep (map pretty ts) diff --git a/library/Morloc/Frontend/Treeify.hs b/library/Morloc/Frontend/Treeify.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Frontend/Treeify.hs @@ -0,0 +1,282 @@ +{-| +Module : Morloc.Frontend.Treeify +Description : Translate from the frontend DAG to the backend SAnno AST forest +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.Frontend.Treeify (treeify) where + +import Morloc.Frontend.Namespace +import Morloc.Data.Doc +import Morloc.Frontend.PartialOrder () +import qualified Morloc.Data.Text as MT +import qualified Morloc.Monad as MM +import qualified Morloc.Data.DAG as MDD +import qualified Data.Map as Map +import qualified Data.Set as Set +import Morloc.Frontend.Pretty () + +data TermOrigin = Declared Expr | Sourced Source + deriving(Show, Ord, Eq) + +treeify + :: DAG MVar [(EVar, EVar)] TypedNode + -> MorlocMonad [SAnno GMeta Many [CType]] +treeify d + | Map.size d == 0 = return [] + | otherwise = case MDD.roots d of + [] -> MM.throwError CyclicDependency + [k] -> case MDD.lookupNode k d of + Nothing -> MM.throwError . DagMissingKey . render $ pretty k + (Just n) -> do + -- initialize state counter to 0, used to index manifolds + MM.startCounter + mapM (collect d n) (Set.toList (typedNodeExports n)) + _ -> MM.throwError . CallTheMonkeys $ "How did you end up with so many roots?" + + +-- -- | Build the call tree for a single nexus command. The result is ambiguous, +-- -- with 1 or more possible tree topologies, each with one or more possible for +-- -- each function. +collect + :: DAG MVar [(EVar, EVar)] TypedNode + -> TypedNode + -> EVar + -> MorlocMonad (SAnno GMeta Many [CType]) +collect d n v = do + trees <- collectSExprs d n v + + -- Just look at one x, since any should emit the same GMeta (if not, then + -- something is broken upstream of GMeta is not general enough) + gmeta <- makeGMeta (Just v) n Nothing + + return $ SAnno (Many trees) gmeta + +collectSExprs + :: DAG MVar [(EVar, EVar)] TypedNode + -> TypedNode + -> EVar + -> MorlocMonad [(SExpr GMeta Many [CType], [CType])] +collectSExprs d n v = do + -- DAG MVar None (EVar, (TypedNode, [TermOrigin])) + let termTree = MDD.lookupAliasedTerm v (typedNodeModuleName n) (makeTermOrigin v) d + + -- DAG MVar None [(SExpr GMeta Many [CType], [CType])] + sexprTree <- MDD.mapNodeM (\(v',(n',ts)) -> collectTerms d v' n' ts) termTree + + -- [(SExpr GMeta Many [CType], [CType])] + let trees = concat . MDD.nodes $ sexprTree + + return trees + + +-- | Find info common across realizations of a given term in a given module +makeGMeta + :: Maybe EVar + -> TypedNode + -> Maybe GType + -> MorlocMonad GMeta +makeGMeta name n gtype = do + i <- MM.getCounter + case name >>= (flip Map.lookup) (typedNodeTypeMap n) of + (Just (TypeSet (Just e) _)) -> do + let g = (Just . GType) $ resolve (etype e) + return $ GMeta + { metaId = i + , metaGType = maybe g Just gtype + , metaName = name + , metaProperties = eprop e + , metaConstraints = econs e + , metaPackers = typedNodePackers n + , metaConstructors = typedNodeConstructors n + , metaTypedefs = typedNodeTypedefs n + } + _ -> do + return $ GMeta + { metaId = i + , metaGType = gtype + , metaName = name + , metaProperties = Set.empty + , metaConstraints = Set.empty + , metaPackers = typedNodePackers n + , metaConstructors = typedNodeConstructors n + , metaTypedefs = typedNodeTypedefs n + } + +makeTermOrigin + :: EVar + -> TypedNode + -> (TypedNode, [TermOrigin]) +makeTermOrigin v n = (n, declared ++ sourced) where + declared = [Declared e | (Declaration v' e) <- typedNodeBody n, v' == v] + sourced = map Sourced + $ filter (\s -> srcAlias s == v) (Map.elems $ typedNodeSourceMap n) + + +collectTerms + :: DAG MVar [(EVar, EVar)] TypedNode + -> EVar + -> TypedNode + -> [TermOrigin] + -> MorlocMonad [(SExpr GMeta Many [CType], [CType])] +collectTerms d v n ts = mapM (collectTerm d v n) ts + + +-- Notice that `args` is NOT an input to collectTerm. Morloc uses lexical +-- scoping, and the input to collectTerm is the origin of a term, so the +-- definition of the term is outside the scope of the parent expression. +collectTerm + :: DAG MVar [(EVar, EVar)] TypedNode + -> EVar + -> TypedNode + -> TermOrigin + -> MorlocMonad (SExpr GMeta Many [CType], [CType]) +collectTerm _ v n (Sourced src) + = case Map.lookup v (typedNodeTypeMap n) of + Nothing -> MM.throwError . CallTheMonkeys $ "No type found for this" + (Just (TypeSet _ es)) -> do + let ts = [etype e | e <- es, Just (srcLang src) == langOf e] + ts' = map resolve ts + return (CallS src, map CType ts') +collectTerm d _ n (Declared (AnnE e ts)) = do + ts' <- getCTypes ts + xs <- collectExpr d Set.empty n ts' e + case xs of + [x] -> return x + _ -> MM.throwError . GeneratorError $ + "Expected exactly one topology for a declared term" +collectTerm _ _ _ (Declared _) = MM.throwError . GeneratorError $ + "Invalid expression in CollectTerm Declared, expected AnnE" + + +collectAnno + :: DAG MVar [(EVar, EVar)] TypedNode + -> Set.Set EVar + -> TypedNode + -> Expr + -> MorlocMonad (SAnno GMeta Many [CType]) +collectAnno d args n (AnnE e ts) = do + gtype <- getGType ts + gmeta <- makeGMeta (getExprName e) n gtype + ts' <- getCTypes ts + trees <- collectExpr d args n ts' e + return $ SAnno (Many trees) gmeta +collectAnno _ _ _ _ = error "impossible bug - unannotated expression" + +getCTypes :: [UnresolvedType] -> MorlocMonad [CType] +getCTypes ts = do + let ts' = map resolve [t | t <- ts, isJust (langOf t)] + return $ map CType ts' + + + +collectExpr + :: DAG MVar [(EVar, EVar)] TypedNode + -> Set.Set EVar + -> TypedNode + -> [CType] + -> Expr + -> MorlocMonad [(SExpr GMeta Many [CType], [CType])] +collectExpr _ _ _ ts (UniE) = return [(UniS, ts)] +collectExpr _ _ _ ts (NumE x) = return [(NumS x, ts)] +collectExpr _ _ _ ts (LogE x) = return [(LogS x, ts)] +collectExpr _ _ _ ts (StrE x) = return [(StrS x, ts)] +collectExpr d args n ts (VarE v) + | Set.member v args = return [(VarS v, ts)] + | otherwise = do + xs <- collectSExprs d n v + let chosen = map (chooseTypes ts) xs + return chosen + where + -- FIXME: The typesystem should handle this. It should unroll every + -- type as far as it can be unrolled, and infer specialized types all + -- the way down. Multiple declarations of every term within a given + -- language should be allowed. The function below will only work in + -- special cases where there is A) a single instance of the term in + -- each language and B) types beneath the term (if this is a + -- composition) do not depend on the type on top. + chooseTypes + :: [CType] + -> (SExpr GMeta Many [CType], [CType]) + -> (SExpr GMeta Many [CType], [CType]) + chooseTypes ts1 (x, ts2) = + (x, [ t + | t <- ts1 + , t' <- ts2 + , langOf t == langOf t']) +collectExpr d args n ts (AccE e k) = do + e' <- collectAnno d args n e + return [(AccS e' k, ts)] +collectExpr d args n ts (ListE es) = do + es' <- mapM (collectAnno d args n) es + return [(ListS es', ts)] +collectExpr d args n ts (TupleE es) = do + es' <- mapM (collectAnno d args n) es + return [(TupleS es', ts)] +collectExpr d args n ts (RecE entries) = do + es' <- mapM (collectAnno d args n) (map snd entries) + let entries' = zip (map fst entries) es' + return [(RecS entries', ts)] +collectExpr d args n ts e@(LamE _ _) = do + case unrollLambda e of + (args', e') -> do + e'' <- collectAnno d (Set.union args (Set.fromList args')) n e' + return [(LamS args' e'', ts)] +collectExpr d args n _ (AppE e1 e2) = do + -- The topology may vary. It could be a direct binary function. Or + -- it could be a partially applied function. So it is necessary to map + -- over the Many. + (SAnno (Many fs) g1) <- collectAnno d args n e1 + e2' <- collectAnno d args n e2 + mapM (app g1 e2') fs +-- None of these should occur unless there is a bug in the code +collectExpr _ _ _ _ x@(AnnE _ _) = error $ show x +collectExpr _ _ _ _ x@(SrcE _) = error $ show x +collectExpr _ _ _ _ x@(Signature _ _) = error $ show x +collectExpr _ _ _ _ x@(Declaration _ _) = error $ show x + + + +app + :: GMeta + -> SAnno GMeta Many [CType] + -> (SExpr GMeta Many [CType], [CType]) + -> MorlocMonad (SExpr GMeta Many [CType], [CType]) +app _ e2 ((AppS f es), ts) = do + ts' <- mapM partialApplyConcrete ts + return (AppS f (es ++ [e2]), ts') +app g e2 (f, ts) = do + ts' <- mapM partialApplyConcrete ts + return (AppS (SAnno (Many [(f, ts)]) g) [e2], ts') + +partialApplyConcrete :: CType -> MorlocMonad CType +partialApplyConcrete t = + fmap CType $ partialApply (unCType t) + +partialApply :: Type -> MorlocMonad Type +partialApply (FunT _ t) = return t +partialApply _ = MM.throwError . GeneratorError $ + "Cannot partially apply a non-function type" + +getExprName :: Expr -> Maybe EVar +getExprName (VarE v) = Just v +getExprName _ = Nothing + +getGType :: [UnresolvedType] -> MorlocMonad (Maybe GType) +getGType ts = do + let ts' = map resolve [t | t <- ts, isNothing (langOf t)] + case map GType ts' of + [] -> return Nothing + [x] -> return $ Just x + xs -> MM.throwError . GeneratorError $ + "Expected 0 or 1 general types, found " <> MT.show' (length xs) + +unrollLambda :: Expr -> ([EVar], Expr) +unrollLambda (LamE v e2) = case unrollLambda e2 of + (vs, e) -> (v:vs, e) +unrollLambda (AnnE (LamE v e2) _) = case unrollLambda e2 of + (vs, e) -> (v:vs, e) +unrollLambda e = ([], e) diff --git a/library/Morloc/Internal.hs b/library/Morloc/Internal.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Internal.hs @@ -0,0 +1,139 @@ +{-| +Module : Morloc.Internal +Description : Internal utility functions +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental + +This module serves as a proto-prelude. Eventually I will probably want to +abandon the default prelude and create my own. But not just yet. +-} +module Morloc.Internal + ( ifelse + , conmap + , unique + , duplicates + , module Data.Maybe + , module Data.Either + , module Data.List.Extra + , module Control.Monad + , module Control.Monad.IO.Class + , module Data.Monoid + -- Data.Char characters + , isUpper + , isLower + -- ** selected functions from Data.Foldable + , foldlM + , foldrM + -- ** selected functions from Data.Tuple.Extra + , uncurry3 + , curry3 + , third + -- ** operators + , (|>>) -- piped fmap + , () -- Filesystem utility operators from System.FilePath + , (<|>) -- alternative operator + , (&&&) -- (a -> a') -> (b -> b') -> (a, b) -> (a', b') + , (***) -- (a -> b) -> (a -> c) -> a -> (b, c) + -- ** map and set helper functions + , keyset + , valset + , mapFold + , mapSum + , mapSumWith + -- ** safe versions of errant functions + , module Safe + , maximumOnMay + , minimumOnMay + , maximumOnDef + , minimumOnDef + ) where + +-- Don't import anything from Morloc here. This module should be VERY lowest +-- in the hierarchy, to avoid circular dependencies, since the lexer needs to +-- access it. +import Control.Monad +import Control.Monad.IO.Class +import Control.Applicative ((<|>)) +import Data.Either +import Data.Foldable (foldlM, foldrM) +import Data.List.Extra hiding (list) -- 'list' conflicts with Doc +import Data.Tuple.Extra ((***), (&&&)) +import Data.Maybe +import Data.Monoid +import Data.Char (isUpper, isLower) +import Safe hiding (at) +import System.FilePath +import qualified Data.Map as Map +import qualified Data.Set as Set + +maximumOnMay :: Ord b => (a -> b) -> [a] -> Maybe a +maximumOnMay _ [] = Nothing +maximumOnMay f xs = Just $ maximumOn f xs + +minimumOnMay :: Ord b => (a -> b) -> [a] -> Maybe a +minimumOnMay _ [] = Nothing +minimumOnMay f xs = Just $ minimumOn f xs + +maximumOnDef :: Ord b => a -> (a -> b) -> [a] -> a +maximumOnDef x _ [] = x +maximumOnDef _ f xs = maximumOn f xs + +minimumOnDef :: Ord b => a -> (a -> b) -> [a] -> a +minimumOnDef x _ [] = x +minimumOnDef _ f xs = minimumOn f xs + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (x, y, z) = f x y z + +curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d +curry3 f = \x y z -> f (x, y, z) + +third :: (a, b, c) -> c +third (_, _, x) = x + +keyset :: Ord k => Map.Map k b -> Set.Set k +keyset = Set.fromList . Map.keys + +valset :: Ord b => Map.Map k b -> Set.Set b +valset = Set.fromList . Map.elems + +mapFold :: Monoid b => (a -> b -> b) -> Map.Map k a -> b +mapFold f = Map.foldr f mempty + +mapSum :: Monoid a => Map.Map k a -> a +mapSum = Map.foldr mappend mempty + +mapSumWith :: Monoid b => (a -> b) -> Map.Map k a -> b +mapSumWith f = Map.foldr (\x y -> mappend y (f x)) mempty + +ifelse :: Bool -> a -> a -> a +ifelse True x _ = x +ifelse False _ y = y + +conmap :: (a -> [b]) -> [a] -> [b] +conmap f = concat . map f + +-- | remove duplicated elements in a list while preserving order +unique :: Ord a => [a] -> [a] +unique xs0 = unique' Set.empty xs0 where + unique' _ [] = [] + unique' set (x:xs) + | Set.member x set = unique' set xs + | otherwise = x : unique' (Set.insert x set) xs + +-- | Build an ordered list of duplicated elements +duplicates :: Ord a => [a] -> [a] +duplicates xs = unique $ filter isDuplicated xs where + -- countMap :: Ord a => Map.Map a Int + countMap = Map.fromList . map (\ks -> (head ks, length ks)) . group . sort $ xs + + -- isDuplicated :: Ord a => a -> Bool + isDuplicated k = fromJust (Map.lookup k countMap) > 1 + +-- | pipe the lhs functor into the rhs function +infixl 1 |>> + +(|>>) :: Functor f => f a -> (a -> b) -> f b +(|>>) = flip fmap diff --git a/library/Morloc/Language.hs b/library/Morloc/Language.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Language.hs @@ -0,0 +1,137 @@ +{-| +Module : Language +Description : Handling for specific languages +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental + +The purpose of this module currently is to unify language naming conventions. +We need to streamline the process of adding new languages to Morloc. This +module should serve as the starting place for adding a new language. +-} +module Morloc.Language + ( Lang(..) + , mapLang + , parseExtension + , makeExtension + , showLangName + , readLangName + , makeExecutableName + , makeSourceName + , standardizeLangName + , pairwiseCost + ) where + +import Morloc.Internal +import Data.Text (Text) + +-- | Programming languages in the Morloc ecosystem. This is the type that +-- should be used to refer to a language (don't use raw strings). Some of these +-- are languages that can be sourced (Python, R and C). Perl is currently used +-- only in generating the nexus file. +data Lang + = Python3Lang + | RLang + | CLang + | CppLang + | PerlLang + deriving (Ord, Eq, Show) + +-- | Map a function over each supported language +mapLang :: (Lang -> a) -> [a] +mapLang f = + [ f Python3Lang + , f RLang + , f CLang + , f CppLang + , f PerlLang + ] + +-- | very rough function overhead costs that can be used when no benchmark info is available +-- `Nothing` indicates that the language pair are not interoperable +pairwiseCost :: Lang -> Lang -> Maybe Int +-- functional overhead in each language +pairwiseCost CLang CLang = Just 1 +pairwiseCost CppLang CppLang = Just 1 +pairwiseCost PerlLang PerlLang = Just 10 +pairwiseCost Python3Lang Python3Lang = Just 10 +pairwiseCost RLang RLang = Just 100 +-- pairs of languages for which foreign calls are optimized +pairwiseCost CppLang CLang = Just 1 +-- cost of naive foreign function calls +pairwiseCost _ CLang = Just 100 +pairwiseCost _ CppLang = Just 100 +pairwiseCost _ Python3Lang = Just 10000 +pairwiseCost _ PerlLang = Just 10000 +pairwiseCost _ RLang = Just 1000000 + +-- | Try to determine the source language for a file from its extension +parseExtension :: Text -> Maybe Lang +parseExtension "loc" = Nothing +parseExtension "py" = Just Python3Lang +parseExtension "R" = Just RLang +parseExtension "c" = Just CLang +parseExtension "h" = Just CLang +parseExtension "cpp" = Just CppLang +parseExtension "hpp" = Just CppLang +parseExtension "pl" = Just PerlLang +parseExtension _ = Nothing + +-- | Create an extension for a given language +makeExtension :: Lang -> Text +makeExtension Python3Lang = "py" +makeExtension RLang = "R" +makeExtension CLang = "c" +makeExtension CppLang = "cpp" +makeExtension PerlLang = "pl" + +-- | Create the name of a given language. This is the internal standard name +-- for the language and the string language name used in the RDF. +showLangName :: Lang -> Text +showLangName Python3Lang = "python3" +showLangName RLang = "R" +showLangName CLang = "C" +showLangName CppLang = "Cpp" +showLangName PerlLang = "Perl" + +-- | Read the name of a given language and try to translate it +readLangName :: Text -> Maybe Lang +readLangName "python" = Just Python3Lang +readLangName "python3" = Just Python3Lang +readLangName "py" = Just Python3Lang +readLangName "R" = Just RLang +readLangName "r" = Just RLang +readLangName "C" = Just CLang +readLangName "c" = Just CLang +readLangName "cpp" = Just CppLang +readLangName "Cpp" = Just CppLang +readLangName "C++" = Just CppLang +readLangName "c++" = Just CppLang +readLangName "Perl" = Just PerlLang +readLangName "perl" = Just PerlLang +readLangName _ = Nothing + +-- | Generate a name for a pool top-level source file given a language. +makeSourceName :: + Lang + -> Text -- ^ basename + -> Text -- ^ source file basename +makeSourceName lang base = base <> "." <> makeExtension lang + +-- | Generate a name for a pool executable file given a language. For +-- interpreted languages this will be the same as the output of the +-- @makeSourceName@ function. +makeExecutableName :: + Lang + -> Text -- ^ basename + -> Text -- ^ executable file basename +makeExecutableName CLang base = base <> "-c.out" +makeExecutableName CppLang base = base <> "-cpp.out" +makeExecutableName lang base = makeSourceName lang base -- For interpreted languages + +-- TODO: Use this function at the parsing stage to standardize names +-- | Convert a given language name to the standard form of the name (e.g., "py" +-- to "python3") +standardizeLangName :: Text -> Maybe Text +standardizeLangName = fmap showLangName . readLangName diff --git a/library/Morloc/Module.hs b/library/Morloc/Module.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Module.hs @@ -0,0 +1,121 @@ +{-| +Module : Module +Description : Morloc module imports and paths +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Morloc.Module + ( ModuleSource(..) + , installModule + , findModule + , loadModuleMetadata + ) where + +import Morloc.Namespace +import Morloc.Data.Doc +import qualified Morloc.Config as Config +import qualified Morloc.Data.Text as MT +import qualified Morloc.Monad as MM +import qualified Morloc.System as MS + +import Data.Aeson (FromJSON(..), (.!=), (.:?), withObject) +import qualified Data.Yaml.Config as YC + +instance FromJSON PackageMeta where + parseJSON = withObject "object" $ \o -> + PackageMeta <$> o .:? "name" .!= "" + <*> o .:? "version" .!= "" + <*> o .:? "homepage" .!= "" + <*> o .:? "synopsis" .!= "" + <*> o .:? "description" .!= "" + <*> o .:? "category" .!= "" + <*> o .:? "license" .!= "" + <*> o .:? "author" .!= "" + <*> o .:? "maintainer" .!= "" + <*> o .:? "github" .!= "" + <*> o .:? "bug-reports" .!= "" + <*> o .:? "gcc-flags" .!= "" + +-- | Specify where a module is located +data ModuleSource + = LocalModule (Maybe MT.Text) + -- ^ A module in the working directory + | GithubRepo MT.Text + -- ^ A module stored in an arbitrary Github repo: "/" + | CoreGithubRepo MT.Text + -- ^ The repo name of a core package, e.g., "math" + +-- | Look for a local morloc module. +findModule :: MVar -> MorlocMonad Path +findModule moduleName = do + config <- MM.ask + let lib = Config.configLibrary config + let allPaths = getModulePaths lib moduleName + existingPaths <- liftIO . fmap catMaybes . mapM getFile $ allPaths + case existingPaths of + (x:_) -> return x + [] -> + MM.throwError . CannotLoadModule . render $ + "module not found among the paths:" <+> list (map pretty allPaths) + +-- | Give a module path (e.g. "/your/path/foo.loc") find the package metadata. +-- It currently only looks for a file named "package.yaml" in the same folder +-- as the main "*.loc" file. +findModuleMetadata :: Path -> IO (Maybe Path) +findModuleMetadata mainFile = + getFile $ MS.combine (MS.takeDirectory mainFile) (Path "package.yaml") + +loadModuleMetadata :: Path -> MorlocMonad () +loadModuleMetadata main = do + maybef <- liftIO $ findModuleMetadata main + meta <- + case maybef of + (Just f) -> liftIO $ YC.loadYamlSettings [MT.unpack . unPath $ f] [] YC.ignoreEnv + Nothing -> return defaultPackageMeta + state <- MM.get + MM.put (appendMeta meta state) + where + appendMeta :: PackageMeta -> MorlocState -> MorlocState + appendMeta m s = s {statePackageMeta = m : (statePackageMeta s)} + +-- | Find an ordered list of possible locations to search for a module +getModulePaths :: Path -> MVar -> [Path] +getModulePaths (Path lib) (MVar base) = map Path + [ base <> ".loc" -- "./${base}.loc" + , base <> "/" <> "main.loc" -- "${base}/main.loc" + , lib <> "/" <> base <> ".loc" -- "${LIB}/${base}.loc" + , lib <> "/" <> base <> "/" <> "main.loc" -- "${LIB}/${base}/main.loc" + , lib <> "/" <> base <> "/" <> base <> ".loc" -- "${LIB}/${base}/${base}.loc" + ] + +getFile :: Path -> IO (Maybe Path) +getFile x = do + exists <- MS.fileExists x + return $ + if exists + then Just x + else Nothing + +-- | Attempt to clone a package from github +installGithubRepo :: + MT.Text -- ^ the repo path ("/") + -> MT.Text -- ^ the url for github (e.g., "https://github.com/") + -> MorlocMonad () +installGithubRepo repo url = do + config <- MM.ask + let (Path lib) = Config.configLibrary config + let cmd = MT.unwords ["git clone", url, lib <> "/" <> repo] + MM.runCommand "installGithubRepo" cmd + +-- | Install a morloc module +installModule :: ModuleSource -> MorlocMonad () +installModule (GithubRepo repo) = + installGithubRepo repo ("https://github.com/" <> repo) +installModule (CoreGithubRepo name) = + installGithubRepo name ("https://github.com/morloclib/" <> name) +installModule (LocalModule Nothing) = + MM.throwError (NotImplemented "module installation from working directory") +installModule (LocalModule (Just _)) = + MM.throwError (NotImplemented "module installation from local directory") diff --git a/library/Morloc/Monad.hs b/library/Morloc/Monad.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Monad.hs @@ -0,0 +1,156 @@ +{-| +Module : Morloc.Monad +Description : A great big stack of monads +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental + +MorlocMonad is a monad stack that is passed throughout the morloc codebase. +Most functions that raise errors, perform IO, or access global configuration +will return `MorlocMonad a` types. The stack consists of a State, Writer, +Except, and Reader monad. +-} +module Morloc.Monad + ( MorlocReturn + , runMorlocMonad + , evalMorlocMonad + , writeMorlocReturn + , runCommand + , runCommandWith + , logFile + , logFileWith + , readLang + , say + -- * reusable counter + , startCounter + , getCounter + -- * re-exports + , module Control.Monad.Trans + , module Control.Monad.Except + , module Control.Monad.Reader + , module Control.Monad.State + , module Control.Monad.Writer + ) where + +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans +import Control.Monad.Writer +import Morloc.Error () -- for MorlocError Show instance +import Morloc.Namespace +import Morloc.Data.Doc +import System.IO (stderr) +import qualified Morloc.Data.Text as MT +import qualified Morloc.Language as ML +import qualified System.Directory as SD +import qualified System.Exit as SE +import qualified System.Process as SP + +runMorlocMonad :: + Int -> Config -> MorlocMonad a -> IO (MorlocReturn a) +runMorlocMonad v config ev = + runStateT (runWriterT (runExceptT (runReaderT ev config))) (emptyState v) + +-- | Evaluate a morloc monad +evalMorlocMonad :: + Int + -> Config -- ^ use default config object if Nothing + -> MorlocMonad a + -> IO a +evalMorlocMonad v config m = do + ((x, _), _) <- runMorlocMonad v config m + case x of + (Left err) -> error (show err) + (Right value) -> return value + +emptyState :: Int -> MorlocState +emptyState v = MorlocState { + statePackageMeta = [] + , stateVerbosity = v + , stateCounter = -1 +} + +startCounter :: MorlocMonad () +startCounter = do + s <- get + put $ s {stateCounter = 0} + +getCounter :: MorlocMonad Int +getCounter = do + s <- get + let i = stateCounter s + put $ s {stateCounter = (stateCounter s) + 1} + return i + +writeMorlocReturn :: MorlocReturn a -> IO () +writeMorlocReturn ((Left err, msgs), _) + = MT.hPutStrLn stderr (MT.unlines msgs) -- write messages + >> MT.hPutStrLn stderr (MT.show' err) -- write terminal failing message +writeMorlocReturn ((_, msgs), _) = MT.hPutStrLn stderr (MT.unlines msgs) + +-- | Execute a system call +runCommand :: + MT.Text -- function making the call (used only in debugging messages on error) + -> MT.Text -- system command + -> MorlocMonad () +runCommand loc cmd = do + liftIO . MT.putStrLn $ "$ " <> cmd + (exitCode, _, err) <- + liftIO $ SP.readCreateProcessWithExitCode (SP.shell . MT.unpack $ cmd) [] + case exitCode of + SE.ExitSuccess -> tell [MT.pack err] + _ -> throwError (SystemCallError cmd loc (MT.pack err)) |>> (\_ -> ()) + +say :: MDoc -> MorlocMonad () +say d = liftIO . putDoc $ " : " <> d <> "\n" + +-- | Execute a system call and return a function of the STDOUT +runCommandWith :: + MT.Text -- function making the call (used only in debugging messages on error) + -> (MT.Text -> a) -- ^ A function of the output (run on success) + -> MT.Text -- ^ System command + -> MorlocMonad a +runCommandWith loc f cmd = do + liftIO . MT.putStrLn $ "$ " <> cmd + (exitCode, out, err) <- + liftIO $ SP.readCreateProcessWithExitCode (SP.shell . MT.unpack $ cmd) [] + case exitCode of + SE.ExitSuccess -> return $ f (MT.pack out) + _ -> throwError (SystemCallError cmd loc (MT.pack err)) + +-- | Write a object to a file in the Morloc temporary directory +logFile :: + Show a + => String -- ^ A filename + -> a + -> MorlocMonad a +logFile s m = do + tmpdir <- asks configTmpDir + liftIO $ SD.createDirectoryIfMissing True (MT.unpack . unPath $ tmpdir) + let path = (MT.unpack . unPath $ tmpdir) <> "/" <> s + liftIO $ MT.writeFile path (MT.pretty m) + return m + +-- | Write a object to a file in the Morloc temporary directory +logFileWith :: + (Show b) + => String -- ^ A filename + -> (a -> b) -- ^ A function to convert a to something presentable + -> a + -> MorlocMonad a +logFileWith s f m = do + tmpdir <- asks configTmpDir + liftIO $ SD.createDirectoryIfMissing True (MT.unpack . unPath $ tmpdir) + let path = (MT.unpack . unPath $ tmpdir) <> "/" <> s + liftIO $ MT.writeFile path (MT.pretty (f m)) + return m + +-- | Attempt to read a language name. This is a wrapper around the +-- @Morloc.Language::readLangName@ that appropriately handles error. +readLang :: MT.Text -> MorlocMonad Lang +readLang langStr = + case ML.readLangName langStr of + (Just x) -> return x + Nothing -> throwError $ UnknownLanguage langStr diff --git a/library/Morloc/Namespace.hs b/library/Morloc/Namespace.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Namespace.hs @@ -0,0 +1,505 @@ +{-| +Module : Morloc.Namespace +Description : All types and datastructures +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} + +module Morloc.Namespace + ( + -- ** re-export supplements to Prelude + module Morloc.Internal + -- ** Synonyms + , MDoc + , DAG + -- ** Other functors + , None(..) + , One(..) + , Many(..) + -- ** Newtypes + , CType(..) + , ctype + , GType(..) + , generalType + , NamType(..) + , EVar(..) + , MVar(..) + , TVar(..) + , unTVar + , Name(..) + , Path(..) + , Code(..) + -- ** Language + , Lang(..) + -- ** Data + , Script(..) + -- ** Serialization + , UnresolvedPacker(..) + , PackMap + -------------------- + -- ** Error handling + , MorlocError(..) + -- ** Configuration + , Config(..) + -- ** Morloc monad + , MorlocMonad + , MorlocState(..) + , MorlocReturn + -- ** Package metadata + , PackageMeta(..) + , defaultPackageMeta + -- * Types + , Type(..) + , UnresolvedType(..) + , unresolvedType2type + , Source(..) + -- ** Type extensions + , Constraint(..) + , Property(..) + -- ** Types used in post-typechecking tree + , SAnno(..) + , SExpr(..) + , GMeta(..) + -- ** Typeclasses + , HasOneLanguage(..) + , Typelike(..) + ) where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Reader (ReaderT) +import Control.Monad.State (StateT) +import Control.Monad.Writer (WriterT) +import Data.Map.Strict (Map) +import Data.Monoid +import Data.Scientific (Scientific) +import Data.Set (Set) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Doc) +import Data.Void (Void) +import Morloc.Internal +import Text.Megaparsec.Error (ParseError) +import Morloc.Language (Lang(..)) + +-- | no annotations for now +type MDoc = Doc () + +-- | A general purpose Directed Acyclic Graph (DAG) +type DAG key edge node = Map key (node, [(key, edge)]) + +type MorlocMonadGen c e l s a + = ReaderT c (ExceptT e (WriterT l (StateT s IO))) a + +type MorlocReturn a = ((Either MorlocError a, [Text]), MorlocState) + +data MorlocState = MorlocState { + statePackageMeta :: [PackageMeta] + , stateVerbosity :: Int + , stateCounter :: Int +} + +type MorlocMonad a = MorlocMonadGen Config MorlocError [Text] MorlocState a + +newtype Name = Name {unName :: Text} deriving (Show, Eq, Ord) +newtype Path = Path {unPath :: Text} deriving (Show, Eq, Ord) +newtype Code = Code {unCode :: Text} deriving (Show, Eq, Ord) + +-- | Stores everything needed to build one file +data Script = + Script + { scriptBase :: !String -- ^ script basename (no extension) + , scriptLang :: !Lang -- ^ script language + , scriptCode :: !Code -- ^ full script source code + , scriptCompilerFlags :: [Text] -- ^ compiler/interpreter flags + , scriptInclude :: [Path] -- ^ paths to morloc module directories + } + deriving (Show, Ord, Eq) + +data UnresolvedPacker = + UnresolvedPacker + { unresolvedPackerTerm :: Maybe EVar + -- ^ The general import term used for this type. For example, the 'Map' + -- type may have language-specific realizations such as 'dict' or 'hash', + -- but it is imported as 'import xxx (Map)'. + , unresolvedPackerCType :: UnresolvedType + -- ^ The decomposed (unpacked) type + , unresolvedPackerForward :: [Source] + -- ^ The unpack function, there may be more than one, the compiler will make + -- a half-hearted effort to find the best one. It is called "Forward" since + -- it is moves one step towards serialization. + , unresolvedPackerReverse :: [Source] + } + deriving (Show, Ord, Eq) + +type PackMap = Map (TVar, Int) [UnresolvedPacker] + +data MorlocError + -- | Raised when assumptions about the input RDF are broken. This should not + -- occur for RDF that has been validated. + = InvalidRDF Text + -- | Raised for calls to unimplemented features + | NotImplemented Text + -- | Raised for unsupported features (such as specific languages) + | NotSupported Text + -- | Raised by parsec on parse errors + | SyntaxError (ParseError Char Void) + -- | Raised when someone didn't customize their error messages + | UnknownError + -- | Raised when an unsupported language is encountered + | UnknownLanguage Text + -- | Raised when parent and child types conflict + | TypeConflict Text Text + -- | Raised for general type errors + | TypeError Text + -- | Raised when a module cannot be loaded + | CannotLoadModule Text + -- | System call failed + | SystemCallError Text Text Text + -- | Raised when there is an error in the code generators + | GeneratorError Text + -- | Missing a serialization or deserialization function + | SerializationError Text + -- | Error in building a pool (i.e., in a compiled language) + | PoolBuildError Text + -- | Raise error if inappropriate function is called on unrealized manifold + | NoBenefits + -- | Raise when a type alias substitution fails + | SelfRecursiveTypeAlias TVar + | MutuallyRecursiveTypeAlias [TVar] + | BadTypeAliasParameters TVar Int Int + | ConflictingTypeAliases Type Type + -- | Problems with the directed acyclic graph datastructures + | DagMissingKey Text + -- | Raised when a branch is reached that should not be possible + | CallTheMonkeys Text + --------------- T Y P E E R R O R S -------------------------------------- + | MissingGeneralType + | AmbiguousGeneralType + | SubtypeError Type Type + | ExistentialError + | UnsolvedExistentialTerm + | BadExistentialCast + | AccessError Text + | NonFunctionDerive + | UnboundVariable EVar + | OccursCheckFail + | EmptyCut + | TypeMismatch + | ToplevelRedefinition + | BadRecordAccess + | NoAnnotationFound -- I don't know what this is for + | OtherError Text -- TODO: remove this option + -- container errors + | EmptyTuple + | TupleSingleton + | EmptyRecord + -- module errors + | MultipleModuleDeclarations [MVar] + | BadImport MVar EVar + | CannotFindModule MVar + | CyclicDependency + | SelfImport MVar + | BadRealization + | TooManyRealizations + | MissingSource + -- serialization errors + | MissingPacker Text CType + | MissingUnpacker Text CType + -- type extension errors + | AmbiguousPacker TVar + | AmbiguousUnpacker TVar + | AmbiguousCast TVar TVar + | IncompatibleRealization MVar + | MissingAbstractType + | ExpectedAbstractType + | CannotInferConcretePrimitiveType + | ToplevelStatementsHaveNoLanguage + | InconsistentWithinTypeLanguage + | CannotInferLanguageOfEmptyRecord + | ConflictingSignatures + | CompositionsMustBeGeneral + | IllegalConcreteAnnotation + deriving (Eq) + +data PackageMeta = + PackageMeta + { packageName :: !Text + , packageVersion :: !Text + , packageHomepage :: !Text + , packageSynopsis :: !Text + , packageDescription :: !Text + , packageCategory :: !Text + , packageLicense :: !Text + , packageAuthor :: !Text + , packageMaintainer :: !Text + , packageGithub :: !Text + , packageBugReports :: !Text + , packageGccFlags :: !Text + } + deriving (Show, Ord, Eq) + +defaultPackageMeta :: PackageMeta +defaultPackageMeta = + PackageMeta + { packageName = "" + , packageVersion = "" + , packageHomepage = "" + , packageSynopsis = "" + , packageDescription = "" + , packageCategory = "" + , packageLicense = "" + , packageAuthor = "" + , packageMaintainer = "" + , packageGithub = "" + , packageBugReports = "" + , packageGccFlags = "" + } + +-- | Configuration object that is passed with MorlocMonad +data Config = + Config + { configHome :: !Path + , configLibrary :: !Path + , configTmpDir :: !Path + , configLangPython3 :: !Path + -- ^ path to python interpreter + , configLangR :: !Path + -- ^ path to R interpreter + , configLangPerl :: !Path + -- ^ path to perl interpreter + } + deriving (Show, Ord, Eq) + + +-- ================ T Y P E C H E C K I N G ================================= + +newtype EVar = EVar { unEVar :: Text } deriving (Show, Eq, Ord) +newtype MVar = MVar { unMVar :: Text } deriving (Show, Eq, Ord) + +data TVar = TV (Maybe Lang) Text deriving (Show, Eq, Ord) + +-- | Let the TVar type behave like the EVar and MVar newtypes +unTVar :: TVar -> Text +unTVar (TV _ t) = t + +data Source = + Source + { srcName :: Name + -- ^ the name of the function in the source language + , srcLang :: Lang + , srcPath :: Maybe Path + , srcAlias :: EVar + -- ^ the morloc alias for the function (if no alias is explicitly given, + -- this will be equal to the name + } + deriving (Ord, Eq, Show) + +-- g: an annotation for the group of child trees (what they have in common) +-- f: a collection - before realization this will probably be Set +-- - after realization it will be One +-- c: an annotation for the specific child tree +data SAnno g f c = SAnno (f (SExpr g f c, c)) g + +data None = None +data One a = One a +data Many a = Many [a] + +instance Functor One where + fmap f (One x) = One (f x) + +data SExpr g f c + = UniS + | VarS EVar + | AccS (SAnno g f c) EVar + | ListS [SAnno g f c] + | TupleS [SAnno g f c] + | LamS [EVar] (SAnno g f c) + | AppS (SAnno g f c) [SAnno g f c] + | NumS Scientific + | LogS Bool + | StrS Text + | RecS [(EVar, SAnno g f c)] + | CallS Source + +-- | Description of the general manifold +data GMeta = GMeta { + metaId :: Int + , metaGType :: Maybe GType + , metaName :: Maybe EVar -- the name, if relevant + , metaProperties :: Set Property + , metaConstraints :: Set Constraint + , metaPackers :: Map (TVar, Int) [UnresolvedPacker] + -- ^ The (un)packers available in this node's module scope. FIXME: kludge + , metaConstructors :: Map TVar Source + -- ^ The constructors in this node's module scope. FIXME: kludge + , metaTypedefs :: Map TVar (Type, [TVar]) + -- ^ Everything needed to make the prototypes and serialization generic + -- functions in C++ +} deriving (Show, Ord, Eq) + +newtype CType = CType { unCType :: Type } + deriving (Show, Ord, Eq) + +newtype GType = GType { unGType :: Type } + deriving (Show, Ord, Eq) + +-- a safe alternative to the CType constructor +ctype :: Type -> CType +ctype t + | isJust (langOf t) = CType t + | otherwise = error "COMPILER BUG - incorrect assignment to concrete type" + +-- a safe alternative to the GType constructor +generalType :: Type -> GType +generalType t + | isNothing (langOf t) = GType t + | otherwise = error "COMPILER BUG - incorrect assignment to general type" + +data NamType + = NamRecord + | NamObject + | NamTable + deriving(Show, Ord, Eq) + +-- | Types, see Dunfield Figure 6 +data Type + = UnkT TVar + -- ^ Unknown type: these may be serialized forms that do not need to be + -- unserialized in the current environment but will later be passed to an + -- environment where they can be deserialized. Alternatively, terms that are + -- used within dynamic languages may need to type annotation. + | VarT TVar + -- ^ (a) + | FunT Type Type + -- ^ (A->B) -- positional parameterized types + | ArrT TVar [Type] + -- ^ f [Type] -- keyword parameterized types + | NamT NamType TVar [Type] [(Text, Type)] + -- ^ Foo { bar :: A, baz :: B } + deriving (Show, Ord, Eq) + +-- | Types, see Dunfield Figure 6 +data UnresolvedType + = VarU TVar + -- ^ (a) + | ExistU TVar [UnresolvedType] [UnresolvedType] + -- ^ (a^) will be solved into one of the other types + | ForallU TVar UnresolvedType + -- ^ (Forall a . A) + | FunU UnresolvedType UnresolvedType + -- ^ (A->B) + | ArrU TVar [UnresolvedType] -- positional parameterized types + -- ^ f [UnresolvedType] + | NamU NamType TVar [UnresolvedType] [(Text, UnresolvedType)] -- keyword parameterized types + -- ^ Foo { bar :: A, baz :: B } + deriving (Show, Ord, Eq) + +unresolvedType2type :: UnresolvedType -> Type +unresolvedType2type (VarU v) = VarT v +unresolvedType2type (FunU t1 t2) = FunT (unresolvedType2type t1) (unresolvedType2type t2) +unresolvedType2type (ArrU v ts) = ArrT v (map unresolvedType2type ts) +unresolvedType2type (NamU r v ts rs) = NamT r v (map unresolvedType2type ts) (zip (map fst rs) (map (unresolvedType2type . snd) rs)) +unresolvedType2type (ExistU _ _ _) = error "Cannot cast existential type to Type" +unresolvedType2type (ForallU _ _) = error "Cannot cast universal type as Type" + + +data Property + = Pack -- data structure to JSON + | Unpack -- JSON to data structure + | Cast -- casts from type A to B + | GeneralProperty [Text] + deriving (Show, Eq, Ord) + +-- | Eventually, Constraint should be a richer type, but for they are left as +-- unparsed lines of text +newtype Constraint = + Con Text + deriving (Show, Eq, Ord) + +class Typelike a where + typeOf :: a -> Type + + -- | Break a type into its input arguments, and final output + -- For example: decompose ((a -> b) -> [a] -> [b]) would + -- yield ([(a->b), [a]], [b]) + decompose :: a -> ([a], a) + + -- | like @decompose@ but concatentates the output type + decomposeFull :: a -> [a] + decomposeFull t = case decompose t of + (xs, x) -> (xs ++ [x]) + + nargs :: a -> Int + nargs t = case typeOf t of + (FunT _ t') -> 1 + nargs t' + _ -> 0 + +instance Typelike Type where + typeOf = id + + decompose (FunT t1 t2) = case decompose t2 of + (ts, finalType) -> (t1:ts, finalType) + decompose t = ([], t) + + +instance Typelike CType where + typeOf (CType t) = t + + decompose t0 = case (decompose (unCType t0)) of + (ts, t) -> (map CType ts, CType t) + +instance Typelike GType where + typeOf (GType t) = t + + decompose t0 = case (decompose (unGType t0)) of + (ts, t) -> (map GType ts, GType t) + +class HasOneLanguage a where + langOf :: a -> Maybe Lang + langOf' :: a -> Lang + + langOf x = Just (langOf' x) + langOf' x = fromJust (langOf x) + +instance HasOneLanguage CType where + langOf (CType t) = langOf t + +-- | Determine the language from a type, fail if the language is inconsistent. +-- Inconsistency in language should be impossible at the syntactic level, thus +-- an error in this function indicates a logical bug in the typechecker. +instance HasOneLanguage Type where + langOf (UnkT (TV lang _)) = lang + langOf (VarT (TV lang _)) = lang + langOf x@(FunT t1 t2) + | langOf t1 == langOf t2 = langOf t1 + | otherwise = error $ "inconsistent languages in" <> show x + langOf x@(ArrT (TV lang _) ts) + | all ((==) lang) (map langOf ts) = lang + | otherwise = error $ "inconsistent languages in " <> show x + langOf (NamT _ _ _ []) = error "empty records are not allowed" + langOf x@(NamT _ (TV lang _) _ ts) + | all ((==) lang) (map (langOf . snd) ts) = lang + | otherwise = error $ "inconsistent languages in " <> show x + +instance HasOneLanguage TVar where + langOf (TV lang _) = lang + +instance HasOneLanguage UnresolvedType where + langOf (VarU (TV lang _)) = lang + langOf x@(ExistU (TV lang _) ts _) + | all ((==) lang) (map langOf ts) = lang + | otherwise = error $ "inconsistent languages in " <> show x + langOf x@(ForallU (TV lang _) t) + | lang == langOf t = lang + | otherwise = error $ "inconsistent languages in " <> show x + langOf x@(FunU t1 t2) + | langOf t1 == langOf t2 = langOf t1 + | otherwise = error $ "inconsistent languages in" <> show x + langOf x@(ArrU (TV lang _) ts) + | all ((==) lang) (map langOf ts) = lang + | otherwise = error $ "inconsistent languages in " <> show x + langOf (NamU _ _ _ []) = error "empty records are not allowed" + langOf x@(NamU _ (TV lang _) _ rs) + | all ((==) lang) (map (langOf . snd) rs) = lang + | otherwise = error $ "inconsistent languages in " <> show x diff --git a/library/Morloc/Pretty.hs b/library/Morloc/Pretty.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Pretty.hs @@ -0,0 +1,247 @@ +{-| +Module : Morloc.Pretty +Description : Pretty print instances +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Morloc.Pretty + ( prettyType + , prettyGreenType + , prettyGreenUnresolvedType + , prettyScream + , prettyLinePrefixes + , prettyUnresolvedPacker + , prettyPackMap + , prettySAnnoMany + , prettySAnnoOne + ) where + +import Data.Text.Prettyprint.Doc.Render.Terminal +import Morloc.Data.Doc +import Morloc.Namespace +import qualified Morloc.Data.Text as MT +import qualified Data.Map as Map +import qualified Data.Text.Prettyprint.Doc.Render.Terminal.Internal as Style + +instance Pretty MVar where + pretty = pretty . unMVar + +instance Pretty EVar where + pretty = pretty . unEVar + +instance Pretty Path where + pretty = pretty . unPath + +instance Pretty Code where + pretty = pretty . unCode + +instance Pretty Name where + pretty = pretty . unName + +instance Pretty TVar where + pretty (TV Nothing t) = pretty t + pretty (TV (Just lang) t) = pretty t <> "@" <> pretty (show lang) + +instance Pretty Lang where + pretty = viaShow + +instance Pretty Source where + pretty (Source name lang pathmay alias) + = "source" <+> pretty lang + <> maybe "" (\path->" from" <+> dquotes (pretty path)) pathmay + <+> dquotes (pretty name) <+> "as" <+> pretty alias + +typeStyle = + Style.SetAnsiStyle + { Style.ansiForeground = Just (Vivid, Green) + , Style.ansiBackground = Nothing + , Style.ansiBold = Nothing + , Style.ansiItalics = Nothing + , Style.ansiUnderlining = Just Underlined + } + +screamStyle = + Style.SetAnsiStyle + { Style.ansiForeground = Just (Vivid, Red) + , Style.ansiBackground = Nothing + , Style.ansiBold = Nothing + , Style.ansiItalics = Nothing + , Style.ansiUnderlining = Just Underlined + } + + +prettyGreenType :: Type -> Doc AnsiStyle +prettyGreenType t = annotate typeStyle (prettyType t) + +forallVars :: UnresolvedType -> [Doc AnsiStyle] +forallVars (ForallU (TV _ v) t) = pretty v : forallVars t +forallVars _ = [] + +forallBlock :: UnresolvedType -> Doc AnsiStyle +forallBlock (ForallU _ t) = forallBlock t +forallBlock t = prettyGreenUnresolvedType t + + +prettyScream :: MT.Text -> Doc AnsiStyle +prettyScream x = annotate screamStyle (pretty x) + +prettyLinePrefixes :: MT.Text -> Doc ann -> Doc ann +prettyLinePrefixes prefix d = + pretty . MT.unlines . map (\l -> prefix <> l) $ MT.lines (render d) + + +class PrettyType a where + prettyType :: a -> Doc ann + +instance PrettyType Type where + prettyType (UnkT (TV _ v)) = "*" <> pretty v + prettyType (VarT (TV _ "Unit")) = "()" + prettyType (VarT v) = pretty v + prettyType (FunT t1@(FunT _ _) t2) = + parens (prettyType t1) <+> "->" <+> prettyType t2 + prettyType (FunT t1 t2) = prettyType t1 <+> "->" <+> prettyType t2 + prettyType (ArrT (TV Nothing "List") [t]) = brackets (prettyType t) + prettyType (ArrT v ts) = pretty v <+> hsep (map prettyType ts) + prettyType (NamT _ (TV Nothing _) _ entries) = + encloseSep "{" "}" "," + (map (\(v, e) -> pretty v <> ":" <> prettyType e) entries) + prettyType (NamT _ (TV (Just lang) t) _ entries) = + pretty t <> "@" <> viaShow lang <+> + encloseSep "{" "}" "," + (map (\(v, e) -> pretty v <> ":" <> prettyType e) entries) + + +instance PrettyType GType where + prettyType = prettyType . unGType + +instance PrettyType CType where + prettyType = prettyType . unCType + + +prettyGreenUnresolvedType :: UnresolvedType -> Doc AnsiStyle +prettyGreenUnresolvedType t = annotate typeStyle (prettyUnresolvedType t) + +prettyUnresolvedType :: UnresolvedType -> Doc AnsiStyle +prettyUnresolvedType (ExistU v ts ds) + = angles $ (pretty v) + <> list (map prettyUnresolvedType ts) + <> list (map prettyUnresolvedType ds) +prettyUnresolvedType t@(ForallU _ _) = + "forall" <+> hsep (forallVars t) <+> "." <+> forallBlock t +prettyUnresolvedType (VarU (TV _ "Unit")) = "()" +prettyUnresolvedType (VarU v) = pretty v +prettyUnresolvedType (FunU t1@(FunU _ _) t2) = + parens (prettyUnresolvedType t1) <+> "->" <+> prettyUnresolvedType t2 +prettyUnresolvedType (FunU t1 t2) = prettyUnresolvedType t1 <+> "->" <+> prettyUnresolvedType t2 +prettyUnresolvedType (ArrU v ts) = pretty v <+> hsep (map prettyUnresolvedType ts) +prettyUnresolvedType (NamU r (TV Nothing _) _ entries) = + viaShow r <> encloseSep "{" "}" ", " + (map (\(v, e) -> pretty v <+> "=" <+> prettyUnresolvedType e) entries) +prettyUnresolvedType (NamU r (TV (Just lang) t) _ entries) = + pretty t <> "@" <> viaShow lang <+> + viaShow r <> encloseSep "{" "}" ", " + (map (\(v, e) -> pretty v <+> "=" <+> prettyUnresolvedType e) entries) + +prettyUnresolvedPacker :: UnresolvedPacker -> Doc AnsiStyle +prettyUnresolvedPacker (UnresolvedPacker v t fs rs) = vsep + [ pretty v + , prettyGreenUnresolvedType t + , "forward:" <+> hsep (map (\s -> pretty (srcAlias s) <> "@" <> pretty (srcLang s)) fs) + , "reverse:" <+> hsep (map (\s -> pretty (srcAlias s) <> "@" <> pretty (srcLang s)) rs) + ] + +prettyPackMap :: PackMap -> Doc AnsiStyle +prettyPackMap m = "----- pacmaps ----\n" + <> vsep (map f (Map.toList m)) + <> "\n------------------" where + f :: ((TVar, Int), [UnresolvedPacker]) -> Doc AnsiStyle + f ((v, i), ps) = + block 4 + ("packmap" <+> pretty v <> parens (pretty i)) + (vsep $ map prettyUnresolvedPacker ps) + + +prettySAnnoMany :: SAnno GMeta Many [CType] -> MDoc +prettySAnnoMany (SAnno (Many xs0) g) = + pretty (metaId g) + <> maybe "" (\n -> " " <> pretty n) (metaName g) + <+> "::" <+> maybe "_" prettyType (metaGType g) + <> line <> indent 5 (vsep (map writeSome xs0)) + where + writeSome :: (SExpr GMeta Many [CType], [CType]) -> MDoc + writeSome (s, ts) + = "_ ::" + <+> encloseSep "{" "}" ";" (map prettyType ts) + <> line <> writeExpr s + + writeExpr :: SExpr GMeta Many [CType] -> MDoc + writeExpr (AccS x k) = pretty k <+> "from " <> nest 2 (prettySAnnoMany x) + writeExpr (ListS xs) = list (map prettySAnnoMany xs) + writeExpr (TupleS xs) = list (map prettySAnnoMany xs) + writeExpr (RecS entries) = encloseSep "{" "}" "," $ + map (\(k,v) -> pretty k <+> "=" <+> prettySAnnoMany v) entries + writeExpr (LamS vs x) + = "LamS" + <+> list (map pretty vs) + <> line <> indent 2 (prettySAnnoMany x) + writeExpr (AppS f xs) = "AppS" <+> indent 2 (vsep (prettySAnnoMany f : map prettySAnnoMany xs)) + writeExpr x = descSExpr x + +-- For example @prettySAnnoOne id Nothing@ for the most simple printer +prettySAnnoOne + :: (a -> CType) -> Maybe (a -> MDoc) -> SAnno GMeta One a -> MDoc +prettySAnnoOne getType extra s = hang 2 . vsep $ ["AST:", describe s] + where + addExtra x = case extra of + (Just f) -> " " <> f x + Nothing -> "" + + describe (SAnno (One (x@(AccS _ _), _)) _) = descSExpr x + describe (SAnno (One (x@(ListS _), _)) _) = descSExpr x + describe (SAnno (One (x@(TupleS _), _)) _) = descSExpr x + describe (SAnno (One (x@(RecS _), _)) _) = descSExpr x + describe (SAnno (One (x@(AppS f xs), c)) g) = + hang 2 . vsep $ + [ pretty (metaId g) <+> descSExpr x <+> parens (prettyType (getType c)) <> addExtra c + , describe f + ] ++ map describe xs + describe (SAnno (One (f@(LamS _ x), c)) g) = do + hang 2 . vsep $ + [ pretty (metaId g) + <+> name (getType c) g + <+> descSExpr f + <+> parens (prettyType (getType c)) + <> addExtra c + , describe x + ] + describe (SAnno (One (x, c)) g) = + pretty (metaId g) + <+> descSExpr x + <+> parens (prettyType (getType c)) + <> addExtra c + + name :: CType -> GMeta -> MDoc + name t g = + let lang = fromJust (langOf t) + in maybe + ("_" <+> viaShow lang <+> "::") + (\x -> pretty x <+> viaShow lang <+> "::") + (metaName g) + +descSExpr :: SExpr g f c -> MDoc +descSExpr (UniS) = "UniS" +descSExpr (VarS v) = "VarS" <+> pretty v +descSExpr (CallS src) + = "CallS" + <+> pretty (srcAlias src) <+> "<" <> viaShow (srcLang src) <> ">" +descSExpr (AccS _ k) = "@" <> pretty k +descSExpr (ListS _) = "ListS" +descSExpr (TupleS _) = "TupleS" +descSExpr (LamS vs _) = "LamS" <+> hsep (map pretty vs) +descSExpr (AppS _ _) = "AppS" +descSExpr (NumS _) = "NumS" +descSExpr (LogS _) = "LogS" +descSExpr (StrS _) = "StrS" +descSExpr (RecS _) = "RecS" diff --git a/library/Morloc/ProgramBuilder/Build.hs b/library/Morloc/ProgramBuilder/Build.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/ProgramBuilder/Build.hs @@ -0,0 +1,50 @@ +{-| +Module : Morloc.ProgramBuilder.Build +Description : Manage system requirements and project building for pools +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Morloc.ProgramBuilder.Build + ( buildProgram + ) where + +import Morloc.Namespace +import qualified Morloc.Data.Text as MT +import qualified Morloc.Language as ML +import qualified Morloc.Monad as MM + +import qualified System.Directory as SD + +buildProgram :: (Script, [Script]) -> MorlocMonad () +buildProgram (nexus, pools) = mapM_ build (nexus : pools) + +build :: Script -> MorlocMonad () +build s = + case scriptLang s of + Python3Lang -> liftIO $ writeInterpreted s + RLang -> liftIO $ writeInterpreted s + PerlLang -> liftIO $ writeInterpreted s + CLang -> gccBuild s "gcc" + CppLang -> gccBuild s "g++ --std=c++11" -- TODO: I need more rigorous build handling + +-- | Compile a C program +gccBuild :: Script -> MT.Text -> MorlocMonad () +gccBuild s cmd = do + let src = ML.makeSourceName (scriptLang s) (MT.pack (scriptBase s)) + let exe = ML.makeExecutableName (scriptLang s) (MT.pack (scriptBase s)) + let inc = ["-I" <> unPath i | i <- scriptInclude s] + liftIO $ MT.writeFile (MT.unpack src) (unCode (scriptCode s)) + MM.runCommand "GccBuild" $ + MT.unwords ([cmd, "-o", exe, src] ++ scriptCompilerFlags s ++ inc) + +-- | Build an interpreted script. +writeInterpreted :: Script -> IO () +writeInterpreted s = do + let f = + MT.unpack $ + ML.makeExecutableName (scriptLang s) (MT.pack (scriptBase s)) + MT.writeFile f (unCode (scriptCode s)) + p <- SD.getPermissions f + SD.setPermissions f (p {SD.executable = True}) diff --git a/library/Morloc/Quasi.hs b/library/Morloc/Quasi.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/Quasi.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +module Morloc.Quasi + ( idoc + ) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import qualified Morloc.Data.Doc as G + +import qualified Language.Haskell.Meta.Parse as MP + +import Text.Parsec + +type Parser = Parsec String () + +data I + = S String + | V String + +pIs :: Parser [I] +pIs = many1 (try pV <|> try pS <|> try pE) <* eof + +pV :: Parser I +pV = fmap V $ between (string "#{") (char '}') (many1 (noneOf "}")) + +pS :: Parser I +pS = fmap S $ many1 (noneOf "#") + +-- | match a literal '#' sign +pE :: Parser I +pE = fmap (S . return) $ char '#' <* notFollowedBy (char '}') + +-- | __i__nterpolated __doc__ument +idoc :: QuasiQuoter +idoc = + QuasiQuoter + { quoteExp = compile + , quotePat = error "Can't handle patterns" + , quoteType = error "Can't handle types" + , quoteDec = error "Can't handle declarations" + } + where + compile :: String -> Q Exp + compile txt = + case parse pIs "" txt of + Left err -> error $ show err + Right xs -> return $ AppE (VarE 'G.hcat) (ListE (map qI xs)) + where qI :: I -> Exp + qI (S x) = (LitE (StringL x)) + qI (V x) = + case MP.parseExp x of + (Right hask) -> hask -- a Haskell expression + (Left err) -> error err diff --git a/library/Morloc/System.hs b/library/Morloc/System.hs new file mode 100644 --- /dev/null +++ b/library/Morloc/System.hs @@ -0,0 +1,54 @@ +{-| +Module : Morloc.System +Description : Handle dependencies and environment setup +Copyright : (c) Zebulun Arendsee, 2020 +License : GPL-3 +Maintainer : zbwrnz@gmail.com +Stability : experimental +-} +module Morloc.System + ( loadYamlConfig + , getHomeDirectory + , appendPath + , takeDirectory + , takeFileName + , combine + , fileExists + ) where + +import Morloc.Namespace +import qualified Morloc.Data.Text as MT + +import Data.Aeson (FromJSON(..)) +import qualified Data.Yaml.Config as YC +import qualified System.Directory as Sys +import qualified System.FilePath.Posix as Path +import qualified System.Directory as SD + +combine :: Path -> Path -> Path +combine (Path x) (Path y) = Path . MT.pack $ Path.combine (MT.unpack x) (MT.unpack y) + +fileExists :: Path -> IO Bool +fileExists = SD.doesFileExist . MT.unpack . unPath + +takeDirectory :: Path -> Path +takeDirectory (Path x) = Path . MT.pack . Path.takeDirectory $ MT.unpack x + +takeFileName :: Path -> Path +takeFileName (Path x) = Path . MT.pack . Path.takeFileName $ MT.unpack x + +-- | Append POSIX paths encoded as Text +appendPath :: Path -> Path -> Path +appendPath base path = combine path base + +getHomeDirectory :: IO Path +getHomeDirectory = fmap (Path . MT.pack) Sys.getHomeDirectory + +loadYamlConfig :: + FromJSON a + => Maybe [Path] -- ^ possible locations of the config file + -> YC.EnvUsage -- ^ default values taken from the environment (or a hashmap) + -> IO a -- ^ default configuration + -> IO a +loadYamlConfig (Just fs) e _ = YC.loadYamlSettings (map (MT.unpack . unPath) fs) [] e +loadYamlConfig Nothing _ d = d diff --git a/morloc.cabal b/morloc.cabal new file mode 100644 --- /dev/null +++ b/morloc.cabal @@ -0,0 +1,179 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: d4df6b564bd5942c82443aacd8df43de1c0c279cbd59f183a720cb8e52fc1b16 + +name: morloc +version: 0.33.0 +synopsis: A multi-lingual, typed, workflow language +description: See GitHub README +category: Language, Compiler, Code Generation +homepage: https://github.com/morloc-project/morloc +bug-reports: https://github.com/morloc-project/morloc/issues +author: Zebulun Arendsee +maintainer: zbwrbz@gmail.com +copyright: 2020 Zebulun Arendsee +license: GPL-3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/morloc-project/morloc + +library + exposed-modules: + Morloc + Morloc.CodeGenerator.Generate + Morloc.CodeGenerator.Grammars.Common + Morloc.CodeGenerator.Grammars.Macro + Morloc.CodeGenerator.Grammars.Translator.Cpp + Morloc.CodeGenerator.Grammars.Translator.Python3 + Morloc.CodeGenerator.Grammars.Translator.R + Morloc.CodeGenerator.Grammars.Translator.Source.CppInternals + Morloc.CodeGenerator.Internal + Morloc.CodeGenerator.Namespace + Morloc.CodeGenerator.Nexus + Morloc.CodeGenerator.Serial + Morloc.Config + Morloc.Data.DAG + Morloc.Data.Doc + Morloc.Data.Text + Morloc.Error + Morloc.Frontend.API + Morloc.Frontend.Desugar + Morloc.Frontend.Infer + Morloc.Frontend.Internal + Morloc.Frontend.Lang.DefaultTypes + Morloc.Frontend.Namespace + Morloc.Frontend.Parser + Morloc.Frontend.PartialOrder + Morloc.Frontend.Pretty + Morloc.Frontend.Treeify + Morloc.Internal + Morloc.Language + Morloc.Module + Morloc.Monad + Morloc.Namespace + Morloc.Pretty + Morloc.ProgramBuilder.Build + Morloc.Quasi + Morloc.System + other-modules: + Paths_morloc + hs-source-dirs: + library + default-extensions: FlexibleContexts OverloadedStrings BangPatterns GeneralizedNewtypeDeriving ViewPatterns + ghc-options: -Wall -Wcompat -fwarn-unused-binds -fwarn-unused-imports -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-redundant-constraints -fno-warn-missing-signatures -fno-warn-unused-do-bind -fno-warn-orphans + build-depends: + aeson >=1.2.4.0 && <1.3 + , base >=4.7 && <5 + , bytestring >=0.10.8.2 && <0.11 + , containers >=0.5.10.2 && <0.6 + , directory >=1.3.0.2 && <1.4 + , extra >=1.6.5 && <1.7 + , filepath >=1.4.1.2 && <1.5 + , haskell-src-meta >=0.8.0.2 && <0.9 + , megaparsec >=6.4.1 && <6.5 + , mtl >=2.2.2 && <2.3 + , parsec >=3.1.13.0 && <3.2 + , partial-order >=0.1.2.1 && <0.2 + , pretty-simple >=2.1.0.0 && <2.2 + , prettyprinter >=1.2.0.1 && <1.3 + , prettyprinter-ansi-terminal >=1.1.1.2 && <1.2 + , process >=1.6.1.0 && <1.7 + , raw-strings-qq ==1.1.* + , safe >=0.3.17 && <0.4 + , scientific >=0.3.5.3 && <0.4 + , template-haskell >=2.12.0.0 && <2.13 + , text >=1.2.3.0 && <1.3 + , unordered-containers >=0.2.9.0 && <0.3 + , yaml >=0.8.29 && <0.9 + default-language: Haskell2010 + +executable morloc + main-is: Main.hs + other-modules: + Subcommands + Paths_morloc + hs-source-dirs: + executable + default-extensions: FlexibleContexts OverloadedStrings BangPatterns GeneralizedNewtypeDeriving ViewPatterns + ghc-options: -Wall -Wcompat -fwarn-unused-binds -fwarn-unused-imports -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-redundant-constraints -fno-warn-missing-signatures -fno-warn-unused-do-bind -fno-warn-orphans -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.2.4.0 && <1.3 + , base >=4.7 && <5 + , bytestring >=0.10.8.2 && <0.11 + , containers >=0.5.10.2 && <0.6 + , directory >=1.3.0.2 && <1.4 + , docopt >=0.7.0.5 && <0.8 + , extra >=1.6.5 && <1.7 + , filepath >=1.4.1.2 && <1.5 + , haskell-src-meta >=0.8.0.2 && <0.9 + , megaparsec >=6.4.1 && <6.5 + , morloc + , mtl >=2.2.2 && <2.3 + , parsec >=3.1.13.0 && <3.2 + , partial-order >=0.1.2.1 && <0.2 + , pretty-simple >=2.1.0.0 && <2.2 + , prettyprinter >=1.2.0.1 && <1.3 + , prettyprinter-ansi-terminal >=1.1.1.2 && <1.2 + , process >=1.6.1.0 && <1.7 + , raw-strings-qq ==1.1.* + , safe >=0.3.17 && <0.4 + , scientific >=0.3.5.3 && <0.4 + , template-haskell >=2.12.0.0 && <2.13 + , text >=1.2.3.0 && <1.3 + , unordered-containers >=0.2.9.0 && <0.3 + , yaml >=0.8.29 && <0.9 + default-language: Haskell2010 + +test-suite morloc-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + GoldenMakefileTests + PropertyTests + UnitTypeTests + Paths_morloc + hs-source-dirs: + test-suite + default-extensions: FlexibleContexts OverloadedStrings BangPatterns GeneralizedNewtypeDeriving ViewPatterns + ghc-options: -Wall -Wcompat -fwarn-unused-binds -fwarn-unused-imports -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-redundant-constraints -fno-warn-missing-signatures -fno-warn-unused-do-bind -fno-warn-orphans -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck >=2.10.1 && <2.11 + , aeson >=1.2.4.0 && <1.3 + , base >=4.10.1.0 && <4.11 + , bytestring >=0.10.8.2 && <0.11 + , containers >=0.5.10.2 && <0.6 + , directory >=1.3.0.2 && <1.4 + , extra >=1.6.5 && <1.7 + , filepath >=1.4.1.2 && <1.5 + , haskell-src-meta >=0.8.0.2 && <0.9 + , megaparsec >=6.4.1 && <6.5 + , morloc + , mtl >=2.2.2 && <2.3 + , parsec >=3.1.13.0 && <3.2 + , partial-order >=0.1.2.1 && <0.2 + , pretty-simple >=2.1.0.0 && <2.2 + , prettyprinter >=1.2.0.1 && <1.3 + , prettyprinter-ansi-terminal >=1.1.1.2 && <1.2 + , process >=1.6.1.0 && <1.7 + , raw-strings-qq ==1.1.* + , safe >=0.3.17 && <0.4 + , scientific >=0.3.5.3 && <0.4 + , tasty >=1.0.1.1 && <1.1 + , tasty-golden >=2.3.1.3 && <2.4 + , tasty-hunit >=0.10.0.1 && <0.11 + , tasty-quickcheck >=0.9.2 && <0.10 + , template-haskell >=2.12.0.0 && <2.13 + , text >=1.2.3.0 && <1.3 + , unordered-containers >=0.2.9.0 && <0.3 + , yaml >=0.8.29 && <0.9 + default-language: Haskell2010 diff --git a/test-suite/GoldenMakefileTests.hs b/test-suite/GoldenMakefileTests.hs new file mode 100644 --- /dev/null +++ b/test-suite/GoldenMakefileTests.hs @@ -0,0 +1,37 @@ +module GoldenMakefileTests + ( goldenMakefileTest + ) where + +import Test.Tasty +import Test.Tasty.Golden +import qualified System.Process as SP +import qualified System.Directory as SD +import qualified System.IO as SI + +goldenMakefileTest :: String -> String -> TestTree +goldenMakefileTest msg testdir = + let dir = testdir + expFile = testdir ++ "/exp.txt" + obsFile = testdir ++ "/obs.txt" + in + goldenVsFile + msg + expFile + obsFile + (makeManifoldFile dir) + +makeManifoldFile :: String -> IO () +makeManifoldFile path = do + abspath <- SD.makeAbsolute path + devnull <- SI.openFile "/dev/null" SI.WriteMode + SP.runProcess + "make" -- command + ["-C", abspath, "--quiet"] -- arguments + Nothing -- optional path to working diretory + Nothing -- optional environment + Nothing -- stdin handle + (Just devnull) -- stdout handle + (Just devnull) -- stderr handle + >>= SP.waitForProcess + + SP.callProcess "make" ["-C", abspath, "--quiet", "clean"] diff --git a/test-suite/Main.hs b/test-suite/Main.hs new file mode 100644 --- /dev/null +++ b/test-suite/Main.hs @@ -0,0 +1,181 @@ +import Test.Tasty +import qualified System.Directory as SD + +import PropertyTests (propertyTests) +import UnitTypeTests +import GoldenMakefileTests (goldenMakefileTest) + +main = do + wd <- SD.getCurrentDirectory >>= SD.makeAbsolute + let golden = \msg f -> goldenMakefileTest msg (wd ++ "/test-suite/golden-tests/" ++ f) + defaultMain $ + testGroup + "Morloc tests" + [ packerTests + , unitTypeTests + , typeOrderTests + , typeAliasTests + , propertyTests + , jsontype2jsonTests + , recordAccessTests + + , golden "import-1" "import-1" + + , golden "argument-form-1-c" "argument-form-1-c" + , golden "argument-form-1-py" "argument-form-1-py" + , golden "argument-form-1-r" "argument-form-1-r" + + , golden "argument-form-2-c" "argument-form-2-c" + , golden "argument-form-2-py" "argument-form-2-py" + , golden "argument-form-2-r" "argument-form-2-r" + + -- see github issue #7 + , golden "argument-form-3-c" "argument-form-3-c" + , golden "argument-form-3-py" "argument-form-3-py" + , golden "argument-form-3-r" "argument-form-3-r" + + , golden "argument-form-4-c" "argument-form-4-c" + , golden "argument-form-4-py" "argument-form-4-py" + , golden "argument-form-4-r" "argument-form-4-r" + + , golden "argument-form-5-c" "argument-form-5-c" + , golden "argument-form-5-py" "argument-form-5-py" + , golden "argument-form-5-r" "argument-form-5-r" + + , golden "argument-form-6-c" "argument-form-6-c" + , golden "argument-form-6-py" "argument-form-6-py" + , golden "argument-form-6-r" "argument-form-6-r" + + , golden "argument-form-7-c" "argument-form-7-c" + , golden "argument-form-7-py" "argument-form-7-py" + , golden "argument-form-7-r" "argument-form-7-r" + + , golden "argument-form-8-c" "argument-form-8-c" + , golden "argument-form-8-py" "argument-form-8-py" + , golden "argument-form-8-r" "argument-form-8-r" + + , golden "defaults-1-py" "defaults-1-py" + + , golden "interop-1-py" "interop-1-py" + , golden "interop-1-r" "interop-1-r" + , golden "interop-2" "interop-2" + + , golden "manifold-form-0" "manifold-form-0" + , golden "manifold-form-0x" "manifold-form-0x" + , golden "manifold-form-1" "manifold-form-1" + , golden "manifold-form-2" "manifold-form-2" + , golden "manifold-form-2x" "manifold-form-2x" + , golden "manifold-form-3" "manifold-form-3" + , golden "manifold-form-3x" "manifold-form-3x" + , golden "manifold-form-4_c" "manifold-form-4_c" + , golden "manifold-form-4_py" "manifold-form-4_py" + , golden "manifold-form-4_r" "manifold-form-4_r" + , golden "manifold-form-5_c" "manifold-form-5_c" + , golden "manifold-form-5_py" "manifold-form-5_py" + , golden "manifold-form-5_r" "manifold-form-5_r" + , golden "manifold-form-6_c" "manifold-form-6_c" + , golden "manifold-form-6_py" "manifold-form-6_py" + , golden "manifold-form-6_r" "manifold-form-6_r" + + -- see github issue #9 + , golden "manifold-form-7_c" "manifold-form-7_c" + , golden "manifold-form-7_py" "manifold-form-7_py" + , golden "manifold-form-7_r" "manifold-form-7_r" + + , golden "records-1-py" "records-1-py" + , golden "records-1-r" "records-1-r" + -- see github issue #8 + , golden "records-1-c" "records-1-c" + + , golden "selection-1" "selection-1" + , golden "selection-2" "selection-2" + , golden "selection-3" "selection-3" + , golden "selection-4" "selection-4" + + -- import two instances in one languages for a function + -- this is also a test of a function that is defind in a local file + , golden "multiple-instances-1-c" "multiple-instances-1-c" + , golden "multiple-instances-1-py" "multiple-instances-1-py" + , golden "multiple-instances-1-r" "multiple-instances-1-r" + -- multiple sources and a declaration + , golden "multiple-instances-2-c" "multiple-instances-2-c" + , golden "multiple-instances-2-py" "multiple-instances-2-py" + , golden "multiple-instances-2-r" "multiple-instances-2-r" + -- tests of module forms + -- where *-sid + -- s - number of sourced instances + -- i - number of imported instances + -- d - number of declared instances + , golden "module-form-00n" "module-form-00n" + , golden "module-form-011" "module-form-011" + , golden "module-form-01n" "module-form-01n" + , golden "module-form-0n0" "module-form-0n0" + , golden "module-form-0n1" "module-form-0n1" + , golden "module-form-101" "module-form-101" + , golden "module-form-10n" "module-form-10n" + , golden "module-form-110" "module-form-110" + , golden "module-form-111" "module-form-111" + , golden "module-form-1n0" "module-form-1n0" + , golden "module-form-n00" "module-form-n00" + , golden "module-form-n01" "module-form-n01" + , golden "module-form-n10" "module-form-n10" + + -- tests of serialization + -- , golden "c S" "serial-form-1-c" + -- , golden "py S" "serial-form-1-py" + -- , golden "r S" "serial-form-1-r" + , golden "C serial-form-2-c" "serial-form-2-c" + , golden "C serial-form-2-py" "serial-form-2-py" + , golden "C serial-form-2-r" "serial-form-2-r" + -- , golden "c R" "serial-form-3-c" + -- , golden "py R" "serial-form-3-py" + -- , golden "r R" "serial-form-3-r" + -- outer simple type + , golden "S(S) serial-form-4-c" "serial-form-4-c" + , golden "S(S) serial-form-4-py" "serial-form-4-py" + , golden "S(S) serial-form-4-r" "serial-form-4-r" + , golden "S(C) serial-form-5-c" "serial-form-5-c" + , golden "S(C) serial-form-5-py" "serial-form-5-py" + , golden "S(C) serial-form-5-r" "serial-form-5-r" + , golden "S(R) serial-form-6-c" "serial-form-6-c" + , golden "S(R) serial-form-6-py" "serial-form-6-py" + , golden "S(R) serial-form-6-r" "serial-form-6-r" + -- outer constructed type + , golden "C(S) serial-form-7-c" "serial-form-7-c" + , golden "C(S) serial-form-7-py" "serial-form-7-py" + , golden "C(S) serial-form-7-r" "serial-form-7-r" + , golden "C(C) serial-form-8-c" "serial-form-8-c" + , golden "C(C) serial-form-8-py" "serial-form-8-py" + , golden "C(C) serial-form-8-r" "serial-form-8-r" + , golden "C(R) serial-form-9-c" "serial-form-9-c" + , golden "C(R) serial-form-9-py" "serial-form-9-py" + , golden "C(R) serial-form-9-r" "serial-form-9-r" + -- outer record type + , golden "R(S) serial-form-10-c" "serial-form-10-c" + , golden "R(S) serial-form-10-py" "serial-form-10-py" + , golden "R(S) serial-form-10-r" "serial-form-10-r" + , golden "R(C) serial-form-11-c" "serial-form-11-c" + , golden "R(C) serial-form-11-py" "serial-form-11-py" + , golden "R(C) serial-form-11-r" "serial-form-11-r" + , golden "R(R) serial-form-12-c" "serial-form-12-c" + , golden "R(R) serial-form-12-py" "serial-form-12-py" + , golden "R(R) serial-form-12-r" "serial-form-12-r" + -- table handling + , golden "C++ table default" "table-1-c" + , golden "py3 table default" "table-1-py" + , golden "R table default" "table-1-r" + , golden "C++ table object" "table-2-c" + , golden "py3 table object" "table-2-py" + , golden "R table object" "table-2-r" + -- object handling + , golden "C++ object handling" "object-1-c" + , golden "py3 object handling" "object-1-py" + , golden "R object handling" "object-1-r" + -- record access + , golden "record-access-gen" "record-access-gen" + , golden "record-access-c" "record-access-c" + , golden "record-access-py" "record-access-py" + , golden "record-access-r" "record-access-r" + -- type identities + , golden "type-identities-c" "type-identities-c" + ] diff --git a/test-suite/PropertyTests.hs b/test-suite/PropertyTests.hs new file mode 100644 --- /dev/null +++ b/test-suite/PropertyTests.hs @@ -0,0 +1,63 @@ +module PropertyTests + ( propertyTests + ) where + +import Morloc.Namespace + +import qualified Control.Monad as CM +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Test.QuickCheck as QC +import Safe (headMay) +import Test.Tasty +import Test.Tasty.QuickCheck as TQC + +propertyTests = + testGroup + "internal list function properties" + [ TQC.testProperty "unique makes unique lists" prop_unique_unique + , TQC.testProperty "unique preserves original order" prop_unique_preserves_order + , TQC.testProperty "duplicates makes unique lists" prop_duplicates_unique + , TQC.testProperty "duplicates preserves original order" prop_duplicates_preserves_order + ] + +-- for the uniq family of functions (unique, duplicates, isSorted), I will test +-- on the numbers 1 to 5. If the desired property holds over this set, they +-- will hold over any ordered set. +one2five :: [Int] -> [Int] +one2five = map (\x -> mod (abs x) 5) + +prop_unique_unique :: [Int] -> Bool +prop_unique_unique [] = True +prop_unique_unique xs = + let xs' = one2five xs + in length (unique xs') == Set.size (Set.fromList xs') + +-- This test asserts that the first element in the original and unique list is +-- the same. This guarantee alone does not entirely guantee that the original +-- order is preserved, but it is close. +prop_unique_preserves_order :: [Int] -> Bool +prop_unique_preserves_order xs = headMay xs == headMay (unique xs) + +-- Each element in the duplicates return list is unique +prop_duplicates_unique :: [Int] -> Bool +prop_duplicates_unique [] = True +prop_duplicates_unique xs = + let xs' = duplicates (one2five xs) + in length xs' == Set.size (Set.fromList xs') + +prop_duplicates_preserves_order :: [Int] -> Bool +prop_duplicates_preserves_order xs = f Set.empty xs (duplicates xs) where + f _ _ [] = True + f _ [] _ = False + f skipped (y:rs) (y':rs') + -- if the original and duplicated elements match: + | y == y' = + -- if the current element was previously skipped + if Set.member y' skipped + -- then the duplicates function failed to respect the initial order + then False + -- else continue checking on the next elements + else f skipped rs rs' + -- otherwise store record the skipped value and continue + | otherwise = f (Set.insert y skipped) rs (y':rs') diff --git a/test-suite/UnitTypeTests.hs b/test-suite/UnitTypeTests.hs new file mode 100644 --- /dev/null +++ b/test-suite/UnitTypeTests.hs @@ -0,0 +1,1348 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +module UnitTypeTests + ( unitTypeTests + , typeOrderTests + , typeAliasTests + , jsontype2jsonTests + , packerTests + , recordAccessTests + ) where + +import Morloc.Frontend.Namespace +import Morloc.Frontend.Parser +import Morloc.CodeGenerator.Namespace +import Text.RawString.QQ +import Morloc.CodeGenerator.Grammars.Common (jsontype2json) +import qualified Morloc.Data.Doc as Doc +import qualified Morloc.Data.DAG as MDD +import Morloc.Frontend.Infer hiding(typecheck) +import Morloc.Frontend.Desugar (desugar) +import Morloc (typecheck) +import qualified Morloc.Monad as MM +import qualified Morloc.Frontend.PartialOrder as MP + +import qualified Data.Text as T +import qualified Data.PartialOrd as DP +import qualified Data.Map as Map +import Test.Tasty +import Test.Tasty.HUnit + +main :: Ord k => (n -> a) -> DAG k e n -> a +main f d = case MDD.roots d of + [] -> error "Missing or circular module" + [k] -> case Map.lookup k d of + (Just (m,_)) -> f m + _ -> error "Cannot handle multiple roots" + +mainDecMap :: TypedDag -> [(EVar, Expr)] +mainDecMap d = [(v, e) | (Declaration v e) <- main typedNodeBody d] + +-- get the toplevel type of a fully annotated expression +typeof :: [Expr] -> [UnresolvedType] +typeof es = f' . head . reverse $ es + where + f' (Signature _ e) = [etype e] + f' e@(AnnE _ ts) = ts + f' t = error ("No annotation found for: " <> show t) + +run :: T.Text -> IO (Either MorlocError TypedDag) +run code = do + ((x, _), _) <- MM.runMorlocMonad 0 emptyConfig (typecheck Nothing (Code code)) + return x + where + emptyConfig = Config + { configHome = Path "" + , configLibrary = Path "" + , configTmpDir = Path "" + , configLangPython3 = Path "" + , configLangR = Path "" + , configLangPerl = Path "" + } + +assertTerminalType :: String -> T.Text -> [UnresolvedType] -> TestTree +assertTerminalType msg code t = testCase msg $ do + result <- run code + case result of + -- the order of the list is not important, so sort before comparing + (Right es') -> assertEqual "" (sort t) (sort (typeof (main typedNodeBody es'))) + (Left err) -> error $ + "The following error was raised: " <> show err <> "\nin:\n" <> show code + +-- remove all type annotations and type signatures +unannotate :: [Expr] -> [Expr] +unannotate = mapMaybe unannotate' where + unannotate' :: Expr -> Maybe Expr + unannotate' (AnnE e t) = unannotate' e + unannotate' (ListE xs) = Just $ ListE (unannotate xs) + unannotate' (TupleE xs) = Just $ TupleE (unannotate xs) + unannotate' (LamE v e) = LamE <$> pure v <*> unannotate' e + unannotate' (AppE e1 e2) = AppE <$> unannotate' e1 <*> unannotate' e2 + unannotate' (Declaration v e) = Declaration <$> pure v <*> unannotate' e + unannotate' (Signature v t) = Nothing + unannotate' e = Just e + +-- assert the full expression with all annotations removed +assertTerminalExpr :: String -> T.Text -> Expr -> TestTree +assertTerminalExpr = assertTerminalExpr' unannotate + +-- assert the full expression with complete sub-expression annotations +assertTerminalExprWithAnnot :: String -> T.Text -> Expr -> TestTree +assertTerminalExprWithAnnot = assertTerminalExpr' id + +-- assert the last expression in the main module, process the expression with f +assertTerminalExpr' :: ([Expr] -> [Expr]) -> String -> T.Text -> Expr -> TestTree +assertTerminalExpr' f msg code expr = testCase msg $ do + result <- run code + case result of + -- the order of the list is not important, so sort before comparing + (Right es') -> + assertEqual "" expr (head . reverse . sort . f . main typedNodeBody $ es') + (Left err) -> error $ + "The following error was raised: " <> show err <> "\nin:\n" <> show code + +exprEqual :: String -> T.Text -> T.Text -> TestTree +exprEqual msg code1 code2 = + testCase msg $ do + result1 <- run code1 + result2 <- run code2 + case (result1, result2) of + (Right e1, Right e2) -> assertEqual "" e1 e2 + _ -> error $ "Expected equal" + +exprTestFull :: String -> T.Text -> T.Text -> TestTree +exprTestFull msg code expCode = + testCase msg $ do + result <- run code + case result of + (Right e) + -> assertEqual "" + (main typedNodeBody e) + (main parserNodeBody $ readProgram Nothing expCode Map.empty) + (Left err) -> error (show err) + +assertPacker :: String -> T.Text -> Map.Map (TVar, Int) [UnresolvedPacker] -> TestTree +assertPacker msg code expPacker = + testCase msg $ do + result <- run code + case result of + (Right e) + -> assertEqual "" + (main typedNodePackers e) + expPacker + (Left err) -> error (show err) + +-- assert the exact expressions +exprTestFullDec :: String -> T.Text -> [(EVar, Expr)] -> TestTree +exprTestFullDec msg code expCode = + testCase msg $ do + result <- run code + case result of + (Right e) -> assertEqual "" (mainDecMap e) expCode + (Left err) -> error (show err) + +exprTestBad :: String -> T.Text -> TestTree +exprTestBad msg code = + testCase msg $ do + result <- run code + case result of + (Right _) -> assertFailure . T.unpack $ "Expected '" <> code <> "' to fail" + (Left _) -> return () + +expectError :: String -> MorlocError -> T.Text -> TestTree +expectError msg err code = + testCase msg $ do + result <- run code + case result of + (Right _) -> assertFailure . T.unpack $ "Expected failure" + (Left err) -> return () + +testPasses :: String -> T.Text -> TestTree +testPasses msg code = + testCase msg $ do + result <- run code + case result of + (Right _) -> return () + (Left e) -> + assertFailure $ + "Expected this test to pass, but it failed with the message: " <> show e + +testEqual :: (Eq a, Show a) => String -> a -> a -> TestTree +testEqual msg x y = + testCase msg $ assertEqual "" x y + +testNotEqual :: Eq a => String -> a -> a -> TestTree +testNotEqual msg x y = + testCase msg $ assertEqual "" (x == y) False + +testTrue :: String -> Bool -> TestTree +testTrue msg x = + testCase msg $ assertEqual "" x True + +testFalse :: String -> Bool -> TestTree +testFalse msg x = + testCase msg $ assertEqual "" x False + +bool = VarU (TV Nothing "Bool") + +num = VarU (TV Nothing "Num") + +str = VarU (TV Nothing "Str") + +fun [] = error "Cannot infer type of empty list" +fun [t] = t +fun (t:ts) = FunU t (fun ts) + +forall [] t = t +forall (s:ss) t = ForallU (TV Nothing s) (forall ss t) + +forallc _ [] t = t +forallc lang (s:ss) t = ForallU (TV (Just lang) s) (forallc lang ss t) + +var s = VarU (TV Nothing s) +varc l s = VarU (TV (Just l) s) + +arrc l s ts = ArrU (TV (Just l) s) ts + +arr s ts = ArrU (TV Nothing s) ts + +lst t = arr "List" [t] + +tuple ts = ArrU v ts + where + v = (TV Nothing . T.pack) ("Tuple" ++ show (length ts)) + +record rs = NamU NamRecord (TV Nothing "Record") [] rs + +recordAccessTests = + testGroup + "Test record access" + [ assertTerminalType + "Access into anonymous record" + "{a = 5, b = \"asdf\"}@b;" + [str] + , assertTerminalType + "Access record variable" + [r| record Person = Person {a :: Num, b :: Str}; + bar :: Person; + bar@b; + |] + [str] + , assertTerminalType + "Access record-returning expression" + [r| record Person = Person {a :: Num, b :: Str}; + bar :: Num -> Person; + (bar 5)@b; + |] + [str] + , assertTerminalType + "Access into tupled" + [r| record Person = Person {a :: Num, b :: Str}; + bar :: Num -> Person; + ((bar 5)@a, (bar 6)@b); + |] + [tuple [num, str]] + , assertTerminalType + "Access multiple languages" + [r| record Person = Person {a :: Num, b :: Str}; + record R Person = Person {a :: "numeric", b :: "character"}; + bar :: Person; + bar R :: Person; + bar@b; + |] + [str, varc RLang "character"] + ] + +packerTests = + testGroup + "Test building of packer maps" + [ assertPacker "no import packer" + [r| source Cpp from "map.h" ( "mlc_packMap" as packMap + , "mlc_unpackMap" as unpackMap); + packMap :: pack => ([a],[b]) -> Map a b; + unpackMap :: unpack => Map a b -> ([a],[b]); + packMap Cpp :: pack => ([a],[b]) -> "std::map<$1,$2>" a b; + unpackMap Cpp :: unpack => "std::map<$1,$2>" a b -> ([a],[b]); + export Map; + |] + ( Map.singleton + (TV (Just CppLang) "std::map<$1,$2>", 2) + [ UnresolvedPacker { + unresolvedPackerTerm = (Just (EVar "Map")) + , unresolvedPackerCType + = forallc CppLang ["a","b"] + ( arrc CppLang "std::tuple<$1,$2>" [ arrc CppLang "std::vector<$1>" [varc CppLang "a"] + , arrc CppLang "std::vector<$1>" [varc CppLang "b"]]) + , unresolvedPackerForward + = [Source (Name "mlc_packMap") CppLang (Just (Path "map.h")) (EVar ("packMap"))] + , unresolvedPackerReverse + = [Source (Name "mlc_unpackMap") CppLang (Just (Path "map.h")) (EVar ("unpackMap"))] + } + ] + ) + + , assertPacker "with importing and aliases" + [r| module A { + source Cpp from "map.h" ( "mlc_packMap" as packMap + , "mlc_unpackMap" as unpackMap); + packMap :: pack => ([a],[b]) -> Map a b; + unpackMap :: unpack => Map a b -> ([a],[b]); + packMap Cpp :: pack => ([a],[b]) -> "std::map<$1,$2>" a b; + unpackMap Cpp :: unpack => "std::map<$1,$2>" a b -> ([a],[b]); + export Map; + }; + module Main { + import A (Map as Hash); + } + |] + ( Map.singleton + (TV (Just CppLang) "std::map<$1,$2>", 2) + [ UnresolvedPacker { + unresolvedPackerTerm = (Just (EVar "Hash")) + , unresolvedPackerCType + = forallc CppLang ["a","b"] + ( arrc CppLang "std::tuple<$1,$2>" [ arrc CppLang "std::vector<$1>" [varc CppLang "a"] + , arrc CppLang "std::vector<$1>" [varc CppLang "b"]]) + , unresolvedPackerForward + = [Source (Name "mlc_packMap") CppLang (Just (Path "map.h")) (EVar ("packMap"))] + , unresolvedPackerReverse + = [Source (Name "mlc_unpackMap") CppLang (Just (Path "map.h")) (EVar ("unpackMap"))] + } + ] + ) + ] + +jsontype2jsonTests = + testGroup + "Test conversion of JsonType's to JSON text" + [ jsontest "value" + (VarJ "int") + [r|"int"|] + , jsontest "array(value)" + (ArrJ "list" [VarJ "int"]) + [r|{"list":["int"]}|] + , jsontest "object(value)" + (NamJ "Person" [("name", VarJ "Str"), ("age", VarJ "Int")]) + [r|{"Person":{"name":"Str","age":"Int"}}|] + , jsontest "array(array)" + (ArrJ "list" [ArrJ "matrix" [VarJ "int"]]) + [r|{"list":[{"matrix":["int"]}]}|] + , jsontest "array(object)" + (ArrJ "list" [(NamJ "Person" [("name", VarJ "Str"), ("age", VarJ "Int")])]) + [r|{"list":[{"Person":{"name":"Str","age":"Int"}}]}|] + , jsontest "object(array)" + (NamJ "Person" [("name", VarJ "Str"), ("friends", ArrJ "list" [VarJ "Str"])]) + [r|{"Person":{"name":"Str","friends":{"list":["Str"]}}}|] + , jsontest "object(object)" + (NamJ "Person" + [ ("name", VarJ "Str") + , ("pet", NamJ "Animal" [("name", VarJ "Str"), ("species", VarJ "Str")]) + ]) + [r|{"Person":{"name":"Str","pet":{"Animal":{"name":"Str","species":"Str"}}}}|] + ] + where + jsontest msg t j = testEqual msg (Doc.render $ jsontype2json t) j + +typeAliasTests = + testGroup + "Test type alias substitutions" + [ assertTerminalType + "non-parametric, general type alias" + (T.unlines + [ "type Foo = A;" + , "f :: Foo -> B;" + , "f" + ] + ) + [fun [var "A", var "B"]] + , assertTerminalType + "deep type substitution: `[Foo] -> B`" + (T.unlines + [ "type Foo = A;" + , "f :: [Foo] -> B;" + , "f" + ] + ) + [fun [lst (var "A"), var "B"]] + , assertTerminalType + "deep type substitution: `[Foo] -> Foo`" + (T.unlines + [ "type Foo = A;" + , "f :: [Foo] -> Foo;" + , "f" + ] + ) + [fun [lst (var "A"), var "A"]] + , assertTerminalType + "deep type substitution: `[Foo] -> { a = Foo }`" + (T.unlines + [ "type Foo = A;" + , "f :: [Foo] -> { a :: Foo } ;" + , "f" + ] + ) + [fun [lst (var "A"), record [("a", var "A")]]] + , assertTerminalType + "parametric alias, general type alias" + (T.unlines + [ "type (Foo a b) = (a,b);" + , "f :: Foo X Y -> Z;" + , "f" + ] + ) + [fun [tuple [var "X", var "Y"], var "Z"]] + , assertTerminalType + "non-parametric alias, concrete type alias" + (T.unlines + [ "type C Num = double;" + , "f C :: Num -> \"int\";" + , "f" + ] + ) + [fun [varc CLang "double", varc CLang "int"]] + , assertTerminalType + "language-specific types are be nested" + (T.unlines + [ "type R Num = \"numeric\";" + , "f R :: [Num] -> \"integer\";" + , "f" + ] + ) + [fun [arrc RLang "list" [varc RLang "numeric"], varc RLang "integer"]] + , assertTerminalType + "no substitution is across languages" + (T.unlines + [ "type Num = \"numeric\";" + , "f R :: [Num] -> \"integer\";" + , "f" + ] + ) + [fun [arrc RLang "list" [varc RLang "Num"], varc RLang "integer"]] + , assertTerminalType + "parametric alias, concrete type alias" + (T.unlines + [ "type Cpp (Map a b) = \"std::map<$1,$2>\" a b;" + , "f Cpp :: Map \"int\" \"double\" -> \"int\";" + , "f" + ] + ) + [ fun [arrc CppLang "std::map<$1,$2>" [varc CppLang "int", varc CppLang "double"] + , varc CppLang "int"]] + , assertTerminalType + "nested in signature" + (T.unlines + [ "type Cpp (Map a b) = \"std::map<$1,$2>\" a b;" + , "f Cpp :: Map \"string\" (Map \"double\" \"int\") -> \"int\";" + , "f" + ] + ) + [ fun [arrc CppLang "std::map<$1,$2>" [varc CppLang "string" + , arrc CppLang "std::map<$1,$2>" [varc CppLang "double", varc CppLang "int"]] + , varc CppLang "int"]] + , assertTerminalType + "nested types" + (T.unlines + [ "type A = B;" + , "type B = C;" + , "foo :: A -> B -> C;" + , "foo" + ] + ) + [fun [var "C", fun [var "C", var "C"]]] + + , assertTerminalType + "existentials are resolved" + (T.unlines + [ "type Cpp (A a b) = \"map<$1,$2>\" a b;" + , "foo Cpp :: A D [B] -> X;" + , "foo" + ] + ) + [fun [ arrc CppLang "map<$1,$2>" [varc CppLang "D", arrc CppLang "std::vector<$1>" [varc CppLang "B"]] + , varc CppLang "X"]] + , expectError + "fail neatly for self-recursive type aliases" + (SelfRecursiveTypeAlias (TV Nothing "A")) + (T.unlines + [ "type A = (A,A);" + , "foo :: A -> B -> C;" + , "foo" + ] + ) + -- -- TODO: find a way to catch mutually recursive type aliases + -- , expectError + -- "fail neatly for mutually-recursive type aliases" + -- (MutuallyRecursiveTypeAlias [TV Nothing "A", TV Nothing "B"]) + -- (T.unlines + -- [ "type A = B;" + -- , "type B = A;" + -- , "foo :: A -> B -> C;" + -- , "foo" + -- ] + -- ) + , expectError + "fail on too many type aliases parameters" + (BadTypeAliasParameters (TV Nothing "A") 0 1) + (T.unlines + [ "type A = B;" + , "foo :: A Int -> C;" + , "foo" + ] + ) + , expectError + "fail on too few type aliases parameters" + (BadTypeAliasParameters (TV Nothing "A") 1 0) + (T.unlines + [ "type (A a) = (a,a);" + , "foo :: A -> C;" + , "foo" + ] + ) + -- import tests --------------------------------------- + , assertTerminalType + "non-parametric, general type alias, imported" + (T.unlines + [ "module M1 { type Foo = A; export Foo;}" + , "module Main { import M1 (Foo); f :: Foo -> B; f;}" + ] + ) + [fun [var "A", var "B"]] + , assertTerminalType + "non-parametric, general type alias, reimported" + (T.unlines + [ "module M3 { type Foo = A; export Foo;}" + , "module M2 { import M3 (Foo); export Foo;}" + , "module M1 { import M2 (Foo); export Foo;}" + , "module Main { import M1 (Foo); f :: Foo -> B; f;}" + ] + ) + [fun [var "A", var "B"]] + , assertTerminalType + "non-parametric, general type alias, imported aliased" + (T.unlines + [ "module M1 { type Foo = A; export Foo;}" + , "module Main { import M1 (Foo as Bar); f :: Bar -> B; f;}" + ] + ) + [fun [var "A", var "B"]] + , assertTerminalType + "non-parametric, general type alias, reimported aliased" + (T.unlines + [ "module M3 { type Foo1 = A; export Foo1;}" + , "module M2 { import M3 (Foo1 as Foo2); export Foo2;}" + , "module M1 { import M2 (Foo2 as Foo3); export Foo3;}" + , "module Main { import M1 (Foo3 as Foo4); f :: Foo4 -> B; f;}" + ] + ) + [fun [var "A", var "B"]] + , assertTerminalType + "non-parametric, concrete type alias, reimported aliased" + (T.unlines + [ "module M3 { type Cpp Foo1 = \"int\"; type R Foo1 = \"integer\"; export Foo1;}" + , "module M2 { import M3 (Foo1 as Foo2); export Foo2;}" + , "module M1 { import M2 (Foo2 as Foo3); export Foo3;}" + , "module Main { import M1 (Foo3 as Foo4); f Cpp :: Foo4 -> \"double\"; f;}" + ] + ) + [ fun [varc CppLang "int", varc CppLang "double"] ] + , assertTerminalType + "non-parametric, general type alias, duplicate import" + (T.unlines + [ "module M2 { type Foo = A; export Foo;}" + , "module M1 { type Foo = A; export Foo;}" + , "module Main { import M1 (Foo); import M2 (Foo); f :: Foo -> B; f;}" + ] + ) + [fun [var "A", var "B"]] + , assertTerminalType + "parametric alias, general type alias, duplicate import" + (T.unlines + [ "module M2 { type (Foo a b) = (a,b); export Foo; }" + , "module M1 { type (Foo c d) = (c,d); export Foo; }" + , "module Main { import M1 (Foo); import M2 (Foo); f :: Foo X Y -> Z; f; }" + ] + ) + [fun [tuple [var "X", var "Y"], var "Z"]] + ] + +typeOrderTests = + testGroup + "Tests of type partial ordering (subtype)" + [ testTrue + "a <: Num" + (MP.isSubtypeOf (forall ["a"] (var "a")) num) + , testFalse + "Num !< forall a . a" + (MP.isSubtypeOf num (forall ["a"] (var "a"))) + , testTrue + "forall a . (Num, a) <: (Num, Str)" + (MP.isSubtypeOf (forall ["a"] (tuple [num, var "a"])) (tuple [num, str])) + , testTrue + "forall a b . (a, b) <: (Num, Str)" + (MP.isSubtypeOf (forall ["a", "b"] (tuple [var "a", var "b"])) (tuple [num, str])) + , testTrue + "forall a . (Num, a) <: forall b . (Num, b)" + (MP.isSubtypeOf + (forall ["a"] (tuple [num, var "a"])) + (forall ["b"] (tuple [num, var "b"]))) + , testTrue + "forall a . a <: (Num, Str)" + (MP.isSubtypeOf (forall ["a"] (var "a")) (tuple [num, str])) + , testTrue + "forall a . a <: forall a b . (a, b)" + (MP.isSubtypeOf (forall ["a"] (var "a")) (forall ["a", "b"] (tuple [var "a", var "b"]))) + -- cannot compare + , testFalse + "[Num] !< Num" + (MP.isSubtypeOf (lst num) num) + , testFalse + "Num !< [Num]" + (MP.isSubtypeOf num (lst num)) + -- partial order of types + , testTrue + "forall a . [a] <= [Int]" + ((forall ["a"] (lst (var "a"))) MP.<= (lst (var "a"))) + , testFalse + "[Int] !< forall a . [a]" + ((lst (var "a")) MP.<= (forall ["a"] (lst (var "a")))) + , testTrue + "forall a . (Num, a) <= (Num, Bool)" + ((forall ["a"] (tuple [num, var "a"])) MP.<= (tuple [num, bool])) + , testFalse + "(Num, Bool) !<= forall a . (Num, a)" + ((tuple [num, bool]) MP.<= (forall ["a"] (tuple [num, var "a"]))) + , testTrue + "forall a b . (a, b) <= forall c . (Num, c)" + ((forall ["a", "b"] (tuple [var "a", var "b"])) MP.<= (forall ["c"] (tuple [num, var "c"]))) + , testFalse + "forall c . (Num, c) !<= forall a b . (a, b)" + ((forall ["c"] (tuple [num, var "c"])) MP.<= (forall ["a", "b"] (tuple [var "a", var "b"]))) + , testTrue + "forall a . a <= forall a b . (a, b)" + ((forall ["a"] (var "a")) MP.<= (forall ["a", "b"] (tuple [var "a", var "b"]))) + -- test "mostSpecific" + , testEqual + "mostSpecific [Num, Str, forall a . a] = [Num, Str]" + (MP.mostSpecific [num, str, forall ["a"] (var "a")]) + [num, str] + -- test "mostGeneral" + , testEqual + "mostGeneral [Num, Str, forall a . a] = forall a . a" + (MP.mostGeneral [num, str, forall ["a"] (var "a")]) + [forall ["a"] (var "a")] + -- test mostSpecificSubtypes + , testEqual + "mostSpecificSubtypes: Num against [forall a . a]" + (MP.mostSpecificSubtypes num [forall ["a"] (var "a")]) + [forall ["a"] (var "a")] + + -- test mostSpecificSubtypes different languages + , testEqual + "mostSpecificSubtypes: different languages" + (MP.mostSpecificSubtypes (varc RLang "num") [forallc CLang ["a"] (var "a")]) + [] + + -- test mostSpecificSubtypes for tuples + , testEqual + "mostSpecificSubtypes: tuples" + (MP.mostSpecificSubtypes + (tuple [num, num]) + [ forall ["a"] (var "a") + , forall ["a", "b"] (tuple [var "a", var "b"]) + , forall ["a", "b", "c"] (tuple [var "a", var "b", var "c"]) + ] + ) + [forall ["a", "b"] (tuple [var "a", var "b"])] + + -- test mostSpecificSubtypes for tuples + , testEqual + "mostSpecificSubtypes: with partially generic tuples" + (MP.mostSpecificSubtypes + (forall ["a"] (tuple [num, var "a"])) + [ forall ["a"] (var "a") + , forall ["a", "b"] (tuple [var "a", var "b"]) + , forall ["a"] (tuple [num, var "a"]) + , forall ["a"] (tuple [num, bool]) + , forall ["a", "b", "c"] (tuple [var "a", var "b", var "c"]) + ] + ) + [forall ["a"] (tuple [num, var "a"])] + ] + +unitTypeTests = + testGroup + "Typechecker unit tests" + -- comments + [ assertTerminalType "block comments (1)" "{- -} 42" [num] + , assertTerminalType "block comments (2)" " {--} 42{- foo -} " [num] + , assertTerminalType "line comments (3)" "-- foo\n 42" [num] + -- semicolons + , assertTerminalType "semicolons are allowed at the end" "42;" [num] + -- primitives + , assertTerminalType "primitive integer" "42" [num] + , assertTerminalType "primitive big integer" "123456789123456789123456789" [num] + , assertTerminalType "primitive decimal" "4.2" [num] + , assertTerminalType "primitive negative number" "-4.2" [num] + , assertTerminalType "primitive positive number (with sign)" "+4.2" [num] + , assertTerminalType "primitive scientific large exponent" "4.2e3000" [num] + , assertTerminalType + "primitive scientific irregular" + "123456789123456789123456789e-3000" + [num] + , assertTerminalType + "primitive big real" + "123456789123456789123456789.123456789123456789123456789" + [num] + , assertTerminalType "primitive boolean" "True" [bool] + , assertTerminalType "primitive string" "\"this is a string literal\"" [str] + , assertTerminalType "primitive integer annotation" "42 :: Num" [num] + , assertTerminalType "primitive boolean annotation" "True :: Bool" [bool] + , assertTerminalType "primitive double annotation" "4.2 :: Num" [num] + , assertTerminalType + "primitive string annotation" + "\"this is a string literal\" :: Str" + [str] + , assertTerminalType "primitive declaration" "x = True; 4.2" [num] + -- declarations + , assertTerminalType + "identity function declaration and application" + "f x = x; f 42" + [num] + , assertTerminalType + "snd function declaration and application" + "snd x y = y; snd True 42" + [num] + + , assertTerminalType + "explicit annotation within an application" + "f :: Num -> Num; f (42 :: Num)" + [num] + + -- lambdas + , assertTerminalExpr + "functions return lambda expressions" + "\\x -> 42" + (LamE (EVar "x") (NumE 42.0)) + , assertTerminalType + "functions can be passed" + "g f = f 42; g" + [forall ["a"] (fun [(fun [num, var "a"]), var "a"])] + , assertTerminalType + "function with parameterized types" + "f :: A B -> C; f" + [fun [arr "A" [var "B"], var "C"]] + , assertTerminalType "fully applied lambda (1)" "(\\x y -> x) 1 True" [num] + , assertTerminalType "fully applied lambda (2)" "(\\x -> True) 42" [bool] + , assertTerminalType "fully applied lambda (3)" "(\\x -> (\\y -> True) x) 42" [bool] + , assertTerminalType "fully applied lambda (4)" "(\\x -> (\\y -> x) True) 42" [num] + , assertTerminalType + "unapplied lambda, polymorphic (1)" + "(\\x -> True)" + [forall ["a"] (fun [var "a", bool])] + , assertTerminalType + "unapplied lambda, polymorphic (2)" + "(\\x y -> x) :: a -> b -> a" + [forall ["a", "b"] (fun [var "a", var "b", var "a"])] + , assertTerminalType + "annotated, fully applied lambda" + "((\\x -> x) :: a -> a) True" + [bool] + , assertTerminalType + "annotated, partially applied lambda" + "((\\x y -> x) :: a -> b -> a) True" + [forall ["a"] (fun [var "a", bool])] + , assertTerminalType + "recursive functions are A-OK" + "\\f -> f 5" + [forall ["a"] (fun [fun [num, var "a"], var "a"])] + + -- applications + , assertTerminalType + "primitive variable in application" + "x = True; (\\y -> y) x" + [bool] + , assertTerminalType + "function variable in application" + "f = (\\x y -> x); f 42" + [forall ["a"] (fun [var "a", num])] + , assertTerminalType + "partially applied function variable in application" + "f = (\\x y -> x); x = f 42; x" + [forall ["a"] (fun [var "a", num])] + , exprTestBad + "applications with too many arguments fail" + "f :: a; f Bool 12" + , exprTestBad + "applications with mismatched types fail (1)" + "abs :: Num -> Num; abs True" + , exprTestBad + "applications with mismatched types fail (2)" + "f = 14; g = \\x h -> h x; (g True) f" + , expectError + "applications of non-functions should fail (1)" + NonFunctionDerive + "f = 5; g = \\x -> f x; g 12" + , expectError + "applications of non-functions should fail (2)" + NonFunctionDerive + "f = 5; g = \\h -> h 5; g f" + + -- evaluation within containers + , expectError + "arguments to a function are monotypes" + (SubtypeError (unresolvedType2type num) (unresolvedType2type bool)) + "f :: a -> a; g = \\h -> (h 42, h True); g f" + , assertTerminalType + "polymorphism under lambdas (203f8c) (1)" + "f :: a -> a; g = \\h -> (h 42, h 1234); g f" + [tuple [num, num]] + , assertTerminalType + "polymorphism under lambdas (203f8c) (2)" + "f :: a -> a; g = \\h -> [h 42, h 1234]; g f" + [lst num] + + -- binding + , assertTerminalType + "annotated variables without definition are legal" + "x :: Num" + [num] + , assertTerminalType + "unannotated variables with definition are legal" + "x = 42; x" + [num] + , exprTestBad + "unannotated variables without definitions are illegal ('\\x -> y')" + "\\x -> y" + + -- parameterized types + , assertTerminalType + "parameterized type (n=1)" + "xs :: Foo A" + [arr "Foo" [var "A"]] + , assertTerminalType + "parameterized type (n=2)" + "xs :: Foo A B" + [arr "Foo" [var "A", var "B"]] + , assertTerminalType + "nested parameterized type" + "xs :: Foo (Bar A) [B]" + [arr "Foo" [arr "Bar" [var "A"], arr "List" [var "B"]]] + , assertTerminalType + "language inference in lists #1" + (T.unlines + [ "bar Cpp :: \"float\" -> \"std::vector<$1>\" \"float\";" + , "bar x = [x];" + , "bar 5;" + ]) + [arrc CppLang "std::vector<$1>" [varc CppLang "float"], lst (var "Num")] + , assertTerminalType + "language inference in lists #2" + (T.unlines + [ "mul :: Num -> Num -> Num;" + , "mul Cpp :: \"int\" -> \"int\" -> \"int\";" + , "foo = mul 2;" + , "bar Cpp :: \"int\" -> \"std::vector<$1>\" \"int\";" + , "bar x = [foo x, 42];" + , "bar 5" + ]) + [lst (var "Num"), arrc CppLang "std::vector<$1>" [varc CppLang "int"]] + + -- type signatures and higher-order functions + , assertTerminalType + "type signature: identity function" + "f :: a -> a; f 42" + [num] + , assertTerminalType + "type signature: apply function with primitives" + "apply :: (Num -> Bool) -> Num -> Bool; f :: Num -> Bool; apply f 42" + [bool] + , assertTerminalType + "type signature: generic apply function" + "apply :: (a->b) -> a -> b; f :: Num -> Bool; apply f 42" + [bool] + , assertTerminalType + "type signature: map" + "map :: (a->b) -> [a] -> [b]; f :: Num -> Bool; map f [5,2]" + [lst bool] + , assertTerminalType + "type signature: sqrt with realizations" + "sqrt :: Num -> Num; sqrt R :: \"numeric\" -> \"numeric\"; sqrt" + [ fun [num, num] + , fun [varc RLang "numeric", varc RLang "numeric"]] + + -- shadowing + , assertTerminalType + "name shadowing in lambda expressions" + "f x = (14,x); g x f = f x; g True f" + [tuple [num, bool]] + , assertTerminalType + "function passing without shadowing" + "f x = (14,x); g foo = foo True; g f" + [tuple [num, bool]] + , assertTerminalType + "shadowed qualified type variables (7ffd52a)" + "f :: a -> a; g :: a -> Num; g f" + [num] + , assertTerminalType + "non-shadowed qualified type variables (7ffd52a)" + "f :: a -> a; g :: b -> Num; g f" + [num] + + -- lists + , assertTerminalType "list of primitives" "[1,2,3]" [lst num] + , assertTerminalType + "list containing an applied variable" + "f :: a -> a; [53, f 34]" + [lst num] + , assertTerminalType "empty list" "[]" [forall ["a"] (lst (var "a"))] + , assertTerminalType + "list in function signature and application" + "f :: [Num] -> Bool; f [1]" + [bool] + , assertTerminalType + "list in generic function signature and application" + "f :: [a] -> Bool; f [1]" + [bool] + , exprTestBad "failure on heterogenous list" "[1,2,True]" + + -- tuples + , assertTerminalType + "tuple of primitives" + "(4.2, True)" + [tuple [num, bool]] + , assertTerminalType + "tuple containing an applied variable" + "f :: a -> a; (f 53, True)" + [tuple [num, bool]] + , assertTerminalType + "check 2-tuples type signature" + "f :: (Num, Str)" + [tuple [num, str]] + , assertTerminalType "1-tuples are just for grouping" "f :: (Num)" [num] + + --- FIXME - distinguish between Unit an Null + -- unit type + , assertTerminalType + "unit as input" + "f :: () -> Bool" + [fun [VarU (TV Nothing "Unit"), bool]] + + , assertTerminalType + "unit as output" + "f :: Bool -> ()" + [fun [bool, VarU (TV Nothing "Unit")]] + + -- -- TODO: reconsider what an empty tuple is + -- -- I am inclined to cast it as the unit type + -- , assertTerminalType "empty tuples are of unit type" "f :: ()" UniT + + -- records + , assertTerminalType + "primitive record statement" + "{x=42, y=\"yolo\"}" + [record [("x", num), ("y", str)]] + , assertTerminalType + "primitive record signature" + "Foo :: {x :: Num, y :: Str}" + [record [("x", num), ("y", str)]] + , assertTerminalType + "primitive record declaration" + "foo = {x = 42, y = \"yolo\"}; foo" + [record [("x", num), ("y", str)]] + , assertTerminalType + "nested records" + "Foo :: {x :: Num, y :: {bob :: Num, tod :: Str}}" + [record [("x", num), ("y", record [("bob", num), ("tod", str)])]] + , assertTerminalType + "records with variables" + "a=42; b={x=a, y=\"yolo\"}; f=\\b->b; f b" + [record [("x", num), ("y", str)]] + , assertTerminalType + "records with bound variables" + "foo a = {x=a, y=\"yolo\"}; foo 42;" + [record [("x", num), ("y", str)]] + + -- extra space + , assertTerminalType "leading space" " 42" [num] + , assertTerminalType "trailing space" "42 " [num] + + -- adding signatures to declarations + , assertTerminalType + "declaration with a signature (1)" + "f :: a -> a; f x = x; f 42" + [num] + , assertTerminalType + "declaration with a signature (2)" + "f :: Num -> Bool; f x = True; f 42" + [bool] + , assertTerminalType + "declaration with a signature (3)" + "f :: Num -> Bool; f x = True; f" + [fun [num, bool]] + , expectError + "primitive type mismatch should raise error" + (SubtypeError (unresolvedType2type num) (unresolvedType2type bool)) + "f :: Num -> Bool; f x = 9999" + + -- tags + , exprEqual + "variable tags" + "F :: Int" + "F :: foo:Int" + , exprEqual + "list tags" + "F :: [Int]" + "F :: foo:[Int]" + , exprEqual + "tags on parenthesized types" + "F :: Int" + "F :: f:(Int)" + , exprEqual + "record tags" + "F :: {x::Int, y::Str}" + "F :: foo:{x::Int, y::Str}" + , exprEqual + "nested tags (tuple)" + "F :: (Int, Str)" + "F :: foo:(i:Int, s:Str)" + , exprEqual "nested tags (list)" "F :: [Int]" "F :: xs:[x:Int]" + , exprEqual + "nested tags (record)" + "F :: {x::Int, y::Str}" + "F :: foo:{x::(i:Int), y::Str}" + + -- properties + , assertTerminalType "property syntax (1)" "f :: Foo => Num; f" [num] + , assertTerminalType "property syntax (2)" "f :: Foo bar => Num; f" [num] + , assertTerminalType "property syntax (3)" "f :: Foo a, Bar b => Num; f" [num] + , assertTerminalType "property syntax (4)" "f :: (Foo a) => Num; f" [num] + , assertTerminalType "property syntax (5)" "f :: (Foo a, Bar b) => Num; f" [num] + -- constraints + , assertTerminalType "constraint syntax (1)" "f :: Num where {ladida}; f" [num] + , assertTerminalType + "constraint syntax (1)" + "f :: Num where { ladida ; foo }; f" + [num] + + -- tests modules + , assertTerminalType "basic Main module" "module Main {[1,2,3]}" [lst num] + , (flip $ assertTerminalType "import/export") [lst num] $ + T.unlines + [ "module Foo {export x; x = 42};" + , "module Bar {export f; f :: a -> [a]};" + , "module Main {import Foo (x); import Bar (f); f x}" + ] + , (flip $ assertTerminalType "import/export") [varc RLang "numeric"] $ + T.unlines + [ "module Foo {export x; x = [1,2,3]};" + , "module Bar {export f; f R :: [\"numeric\"] -> \"numeric\"};" + , "module Main {import Foo (x); import Bar (f); f x}" + ] + + , (flip $ assertTerminalType "multiple imports") [varc Python3Lang "float", varc RLang "numeric"] $ + T.unlines + [ "module Foo {export f; f py :: [\"float\"] -> \"float\"};" + , "module Bar {export f; f R :: [\"numeric\"] -> \"numeric\"};" + , "module Main {import Foo (f); import Bar (f); f [1,2,3]}" + ] + + , assertTerminalType + "Allow gross overuse of semicolons" + ";;;;;module foo{;42; ;};" + [num] + , expectError + "fail on import of non-existing variable" + (BadImport (MVar "Foo") (EVar "x")) $ + T.unlines + ["module Foo {export y; y = 42};", "module Main {import Foo (x); x}"] + , expectError + "fail on cyclic dependency" + CyclicDependency $ + T.unlines + [ "module Foo {import Bar (y); export x; x = 42};" + , "module Bar {import Foo (x); export y; y = 88}" + ] + , expectError "fail on self import" + (SelfImport (MVar "Foo")) $ + T.unlines ["module Foo {import Foo (x); x = 42}"] + , expectError + "fail on import of non-exported variable" + (BadImport (MVar "Foo") (EVar "x")) $ + T.unlines ["module Foo {x = 42};", "module Main {import Foo (x); x}"] + + -- test realization integration + , assertTerminalType + "a realization can be defined following general type signature" + (T.unlines ["f :: Num -> Num;", "f r :: \"integer\" -> \"integer\";", "f 44"]) + [num, varc RLang "integer"] + , assertTerminalType + "realizations can map one general type to multiple specific ones" + (T.unlines ["f :: Num -> Num;", "f r :: \"integer\" -> \"numeric\";", "f 44"]) + [num, varc RLang "numeric"] + , assertTerminalType + "realizations can map multiple general type to one specific one" + (T.unlines ["f :: Num -> Nat;", "f r :: \"integer\" -> \"integer\";", "f 44"]) + [var "Nat", varc RLang "integer"] + , assertTerminalType + "multiple realizations for different languages can be defined" + (T.unlines + [ "f :: Num -> Num;" + , "f r :: \"integer\" -> \"integer\";" + , "f c :: \"int\" -> \"int\";" + , "f 44" + ]) + [num, varc CLang "int", varc RLang "integer"] + , assertTerminalType + "realizations with parameterized variables" + (T.unlines + [ "f :: [Num] -> Num;" + , "f r :: \"$1\" \"integer\" -> \"integer\";" + , "f cpp :: \"std::vector<$1>\" \"int\" -> \"int\";" + , "f [44]" + ]) + [num, varc CppLang "int", varc RLang "integer"] + , assertTerminalType + "realizations can use quoted variables" + (T.unlines + [ "sum :: [Num] -> Num;" + , "sum c :: \"$1*\" \"double\" -> \"double\";" + , "sum cpp :: \"std::vector<$1>\" \"double\" -> \"double\";" + , "sum [1,2]" + ]) + [num, varc CLang "double", varc CppLang "double"] + , assertTerminalType + "the order of general signatures and realizations does not matter (1)" + (T.unlines + [ "f r :: \"integer\" -> \"integer\";" + , "f :: Num -> Num;" + , "f c :: \"int\" -> \"int\";" + , "f 44" + ]) + [num, varc CLang "int", varc RLang "integer"] + , assertTerminalType + "the order of general signatures and realizations does not matter (2)" + (T.unlines + [ "f r :: \"integer\" -> \"integer\";" + , "f c :: \"int\" -> \"int\";" + , "f :: Num -> Num;" + , "f 44" + ]) + [num, varc CLang "int", varc RLang "integer"] + , assertTerminalType + "multiple realizations for a single language cannot be defined" + (T.unlines + [ "f r :: A -> B;" + , "f r :: C -> D;" + , "f 1" + ]) + [varc RLang "B", varc RLang "D"] + , assertTerminalType + "general signatures are optional" + (T.unlines ["f r :: \"integer\" -> \"integer\";", "f 44"]) + [varc RLang "integer"] + , assertTerminalType + "compositions can have concrete realizations" + "f r :: \"integer\" -> \"integer\"; f x = 42; f 44" + [varc RLang "integer", num] + , expectError + "arguments number in realizations must equal the general case (1)" + BadRealization $ + T.unlines + ["f :: Num -> String -> Num;", "f r :: \"integer\" -> \"integer\";", "f 44"] + , expectError + "arguments number in realizations must equal the general case (2)" + BadRealization $ + T.unlines + ["f :: Num -> Num;", "f r :: \"integer\" -> \"integer\" -> string;", "f 44"] + , assertTerminalType + "multiple realizations for one type" + (T.unlines + [ "foo :: Num -> Num;" + , "foo r :: A -> B;" + , "foo c :: C -> D;" + , "bar c :: C -> C;" + , "foo (bar 1);" + ]) + [num, varc CLang "D", varc RLang "B"] + , assertTerminalType + "concrete snd: simple test with containers" + (T.unlines + [ "snd :: (a, b) -> b;" + , "snd r :: list a b -> b;" + , "snd (1, True);" + ]) + [bool, varc RLang "logical"] + , assertTerminalType + "concrete map: single map, single f" + (T.unlines + [ "map cpp :: (a -> b) -> \"std::vector<$1>\" a -> \"std::vector<$1>\" b;" + , "f cpp :: \"double\" -> \"double\";" + , "map f [1,2]" + ]) + [arrc CppLang "std::vector<$1>" [varc CppLang "double"]] + , assertTerminalType + "concrete map: multiple maps, single f" + (T.unlines + [ "map :: (a -> b) -> [a] -> [b];" + , "map c :: (a -> b) -> \"std::vector<$1>\" a -> \"std::vector<$1>\" b;" + , "map r :: (a -> b) -> vector a -> vector b;" + , "f c :: \"double\" -> \"double\";" + , "map f [1,2]" + ]) + [ forall ["a"] (arr "List" [var "a"]) + , forallc RLang ["a"] (arrc RLang "vector" [varc RLang "a"]) + , arrc CLang "std::vector<$1>" [varc CLang "double"] + ] + , assertTerminalType + "infer type signature from concrete functions" + (T.unlines + [ "sqrt :: Num -> Num;" + , "sqrt R :: \"numeric\" -> \"numeric\";" + , "foo x = sqrt x;" + , "sqrt 42" + ]) + [num, varc RLang "numeric"] + , assertTerminalType + "calls cross-language" + (T.unlines + [ "f R :: A -> B;" + , "g Cpp :: B -> C;" + , "g (f 4);" + ]) + [varc CppLang "C"] + , assertTerminalType + "language branching" + (T.unlines + [ "id R :: a -> a;" + , "sqrt C :: \"double\" -> \"double\";" + , "sqrt R :: \"numeric\" -> \"numeric\";" + , "id (sqrt 4);" + ]) + [varc RLang "numeric"] + , assertTerminalType + "obligate foreign call" + (T.unlines + [ "foo r :: (a -> a) -> a -> a;" + , "f c :: \"int\" -> \"int\";" + , "foo f 42" + ]) + [varc RLang "numeric"] + , assertTerminalType + "obligate foreign call - tupled" + (T.unlines + [ "foo r :: (a -> a) -> a -> (a,a);" + , "f c :: \"int\" -> \"int\";" + , "foo f 42" + ]) + [arrc RLang "tuple" [varc RLang "numeric", varc RLang "numeric"]] + , assertTerminalType + "declarations represent all realizations" + (T.unlines + [ "sqrt :: Num -> Num;" + , "sqrt r :: \"integer\" -> \"numeric\";" + , "foo x = sqrt x;" + , "foo" + ]) + [fun [num, num], fun [varc RLang "integer", varc RLang "numeric"]] + + , assertTerminalType + "all internal concrete and general types are right" + (T.unlines + [ "snd :: a -> b -> b;" + , "snd Cpp :: a -> b -> b;" + , "sqrt :: Num -> Num;" + , "sqrt Cpp :: \"double\" -> \"double\";" + , "foo x = snd x (sqrt x);" + , "foo" + ]) + [fun [num, num], fun [varc CppLang "double", varc CppLang "double"]] + + , assertTerminalType + "declaration general type signatures are respected" + (T.unlines + [ "sqrt cpp :: \"double\" -> \"double\";" + , "sqrt :: a -> a;" + , "foo :: Num -> Num;" + , "foo x = sqrt x;" + , "foo" + ]) + [fun [num, num], fun [varc CppLang "double", varc CppLang "double"]] + + , assertTerminalExprWithAnnot + "all internal concrete and general types are right" + (T.unlines + [ "snd :: a -> b -> b;" + , "snd Cpp :: a -> b -> b;" + , "sqrt :: Num -> Num;" + , "sqrt Cpp :: \"double\" -> \"double\";" + , "foo x = snd x (sqrt x);" + ]) + (Declaration (EVar "foo") + (AnnE (LamE (EVar "x") + (AnnE (AppE + (AnnE (AppE + (AnnE (VarE (EVar "snd")) + [ fun [num, num, num] + , fun [varc CppLang "double", varc CppLang "double", varc CppLang "double"]]) + (AnnE (VarE (EVar "x")) + [num,varc CppLang "double"])) + [ FunU num num + , FunU (varc CppLang "double") (varc CppLang "double")]) + (AnnE (AppE + (AnnE (VarE (EVar "sqrt")) + [ FunU num num + , FunU (varc CppLang "double") (varc CppLang "double")]) + (AnnE (VarE (EVar "x")) + [ num + , varc CppLang "double"])) + [num,varc CppLang "double"])) + [num,varc CppLang "double"])) + [ FunU num num + , FunU (varc CppLang "double") (varc CppLang "double")])) + + -- internal + , exprTestFull + "every sub-expression should be annotated in output" + "f :: a -> Bool; f 42" + "f :: a -> Bool; (((f :: Num -> Bool) (42 :: Num)) :: Bool)" + + -- -- TODO: resurrect to test github issue #7 + -- , exprTestFullDec + -- "concrete types should be inferred for declared variables" + -- (T.unlines + -- [ "id :: Num -> Num;" + -- , "id C :: \"int\" -> \"int\";" + -- , "id x = x;" + -- , "y = 40;" + -- , "foo = id y;" + -- ] + -- ) + -- [ (EVar "foo", + -- AnnE (AppE + -- (AnnE (VarE (EVar "id")) [fun [num, num], fun [varc CLang "int", varc CLang "int"]]) + -- (AnnE (VarE (EVar "y")) [num, varc CLang "int"]) + -- -- ^ The purpose of this test is to assert that the above + -- -- type is defined. As of commit 'c31660a0', `y` was assigned + -- -- only the general type Num. + -- ) + -- [num, varc CLang "int"] + -- ) + -- , (EVar "id", + -- AnnE (LamE (EVar "x") + -- (AnnE (VarE (EVar "x")) + -- [num, varc CLang "int"])) + -- [fun [num, num], fun [varc CLang "int", varc CLang "int"]]) + -- , (EVar "y", AnnE (NumE 40.0) [num]) + -- ] + + -- default list evaluation of arguments + , assertTerminalType + "can infer multiple argument types" + (T.unlines + [ "ith :: [Num] -> Num -> Num;" + , "ith R :: [\"numeric\"] -> \"numeric\" -> \"numeric\";" + , "snd x = ith x 2;" + , "snd [1,2,3];" + ]) + [num, varc RLang "numeric"] + ]