packages feed

morloc (empty) → 0.33.0

raw patch · 46 files changed

+13038/−0 lines, 46 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, bytestring, containers, directory, docopt, extra, filepath, haskell-src-meta, megaparsec, morloc, mtl, parsec, partial-order, pretty-simple, prettyprinter, prettyprinter-ansi-terminal, process, raw-strings-qq, safe, scientific, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, template-haskell, text, unordered-containers, yaml

Files

+ ChangeLog.md view
@@ -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
+ LICENSE view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ 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 <http://www.gnu.org/licenses/>.++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+<http://www.gnu.org/licenses/>.++  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+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ README.md view
@@ -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<int>` 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.
+ executable/Main.hs view
@@ -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
+ executable/Subcommands.hs view
@@ -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
+ library/Morloc.hs view
@@ -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
+ library/Morloc/CodeGenerator/Generate.hs view
@@ -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
+ library/Morloc/CodeGenerator/Grammars/Common.hs view
@@ -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 _ = "<UNKNOWN RECORD>"++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+
+ library/Morloc/CodeGenerator/Grammars/Macro.hs view
@@ -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)
+ library/Morloc/CodeGenerator/Grammars/Translator/Cpp.hs view
@@ -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 <foo.h>`+-- Include statements in C can be either wrapped in angle brackets (e.g.,+-- `<stdio.h>`) 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: <https://gcc.gnu.org/onlinedocs/cpp/Search-Path.html>. 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 <class T>+-- > struct Person+-- > {+-- >     std::vector<std::string> name;+-- >     std::vector<T> 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 <class T>+-- > std::string serialize(person<T> x, person<T> 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 <class T>+-- > bool deserialize(const std::string json, size_t &i, person<T> &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 <string>+#include <iostream>+#include <sstream>+#include <functional>+#include <vector>+#include <string>+#include <algorithm> // 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;+}+|]
+ library/Morloc/CodeGenerator/Grammars/Translator/Python3.hs view
@@ -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)+|]
+ library/Morloc/CodeGenerator/Grammars/Translator/R.hs view
@@ -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())+  }+}+|]
+ library/Morloc/CodeGenerator/Grammars/Translator/Source/CppInternals.hs view
@@ -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 <iostream>+#include <sstream>+#include <string>+#include <stdexcept>+#include <stdio.h>+#include <vector>+#include <iomanip>+#include <limits>+#include <tuple>+#include <utility> +++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 <class A> std::string serialize(A x);++template<std::size_t I = 0, class... Rs>+inline typename std::enable_if<I == sizeof...(Rs), std::string>::type+  _serialize_tuple(std::tuple<Rs...> x);++template<std::size_t I = 0, class... Rs>+inline typename std::enable_if<I < sizeof...(Rs), std::string>::type+  _serialize_tuple(std::tuple<Rs...> x);++template <class... A>+std::string serialize(std::tuple<A...> x, std::tuple<A...> schema);++template <class A>+std::string serialize(std::vector<A> x, std::vector<A> 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 <class A>+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 <class A>+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 <class A>+bool deserialize(const std::string json, size_t &i, std::vector<A> &x);++template <class A>+bool _deserialize_tuple(const std::string json, size_t &i, std::tuple<A> &x);++template <class A, class... Rest>+bool _deserialize_tuple(const std::string json, size_t &i, std::tuple<A, Rest...> &x);++template <class... Rest>+bool deserialize(const std::string json, size_t &i, std::tuple<Rest...> &x);++template <class A>+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<double>::digits10 + 2) << x;+    return(s.str());+}++std::string serialize(std::string x, std::string schema){+    std::ostringstream s;+    s << '"' << x << '"';+    return(s.str());+}++template <class A>+std::string serialize(std::vector<A> x, std::vector<A> 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 <class A>+std::string serialize(A x){+    return serialize(x, x);+}++// adapted from stackoverflow #1198260 answer from emsr+template<std::size_t I = 0, class... Rs>+inline typename std::enable_if<I == sizeof...(Rs), std::string>::type+  _serialize_tuple(std::tuple<Rs...> x)+  { return ""; }++template<std::size_t I = 0, class... Rs>+inline typename std::enable_if<I < sizeof...(Rs), std::string>::type+  _serialize_tuple(std::tuple<Rs...> x)+  {+    return serialize(std::get<I>(x)) + "," + _serialize_tuple<I + 1, Rs...>(x);+  }++template <class... A>+std::string serialize(std::tuple<A...> x, std::tuple<A...> 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 <class A>+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 <class A>+//   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 <class A>+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 <class A>+bool deserialize(const std::string json, size_t &i, std::vector<A> &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 <class A>+bool _deserialize_tuple(const std::string json, size_t &i, std::tuple<A> &x){+    A a;+    if(! deserialize(json, i, a)){+        return false;+    }+    x = std::make_tuple(a);+    return true;+}+template <class A, class... Rest>+bool _deserialize_tuple(const std::string json, size_t &i, std::tuple<A, Rest...> &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<Rest...> rs;+    if(! _deserialize_tuple(json, i, rs)){+        return false;+    }+    // cons+    x = std::tuple_cat(std::make_tuple(a), rs);+    return true;+}+template <class... Rest>+bool deserialize(const std::string json, size_t &i, std::tuple<Rest...> &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 <class A>+A deserialize(const std::string json, A output){+    size_t i = 0;+    deserialize(json, i, output);+    return output;+}++template <class... Rest>+std::tuple<Rest...> deserialize(const std::string json, std::tuple<Rest...> output){+    size_t i = 0;+    deserialize(json, i, output);+    return output;+}+|]
+ library/Morloc/CodeGenerator/Internal.hs view
@@ -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
+ library/Morloc/CodeGenerator/Namespace.hs view
@@ -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
+ library/Morloc/CodeGenerator/Nexus.hs view
@@ -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 <> "]'"
+ library/Morloc/CodeGenerator/Serial.hs view
@@ -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"
+ library/Morloc/Config.hs view
@@ -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
+ library/Morloc/Data/DAG.hs view
@@ -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'])
+ library/Morloc/Data/Doc.hs view
@@ -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
+ library/Morloc/Data/Text.hs view
@@ -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 "\"" "\""
+ library/Morloc/Error.hs view
@@ -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"
+ library/Morloc/Frontend/API.hs view
@@ -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+  }
+ library/Morloc/Frontend/Desugar.hs view
@@ -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
+ library/Morloc/Frontend/Infer.hs view
@@ -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++--+-- ----------------------------------------- <primitive>+--  g |- <primitive expr> => <primitive type> -| 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 <t0> with <t0>:<ea1> -> <ea2>+    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 ()
+ library/Morloc/Frontend/Internal.hs view
@@ -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'
+ library/Morloc/Frontend/Lang/DefaultTypes.hs view
@@ -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")]
+ library/Morloc/Frontend/Namespace.hs view
@@ -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
+ library/Morloc/Frontend/Parser.hs view
@@ -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 "<expr>" (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
+ library/Morloc/Frontend/PartialOrder.hs view
@@ -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
+ library/Morloc/Frontend/Pretty.hs view
@@ -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)
+ library/Morloc/Frontend/Treeify.hs view
@@ -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)
+ library/Morloc/Internal.hs view
@@ -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
+ library/Morloc/Language.hs view
@@ -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
+ library/Morloc/Module.hs view
@@ -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: "<username>/<reponame>"+  | 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 ("<username>/<reponame>")+  -> 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")
+ library/Morloc/Monad.hs view
@@ -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
+ library/Morloc/Namespace.hs view
@@ -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
+ library/Morloc/Pretty.hs view
@@ -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"
+ library/Morloc/ProgramBuilder/Build.hs view
@@ -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})
+ library/Morloc/Quasi.hs view
@@ -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
+ library/Morloc/System.hs view
@@ -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
+ morloc.cabal view
@@ -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 <https://github.com/morloc-project/morloc#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
+ test-suite/GoldenMakefileTests.hs view
@@ -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"]
+ test-suite/Main.hs view
@@ -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"+      ]
+ test-suite/PropertyTests.hs view
@@ -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')
+ test-suite/UnitTypeTests.hs view
@@ -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"]+    ]