symantic-base 0.0.2.20200708 → 0.1.0.20210703

raw patch · 32 files changed

+1924/−1366 lines, 32 filesdep +containersdep +hashabledep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, hashable, template-haskell, transformers, unordered-containers

API changes (from Hackage documentation)

Files

• .envrc +1/−0
• COPYING +0/−674
• Makefile +44/−0
• cabal.project +1/−0
• default.nix +27/−0
• flake.lock +38/−0
• flake.nix +13/−0
• src/Symantic/Base.hs +0/−17
• src/Symantic/Base/ADT.hs +0/−198
• src/Symantic/Base/Algebrable.hs +0/−128
• src/Symantic/Base/Composable.hs +0/−61
• src/Symantic/Base/CurryN.hs +0/−40
• src/Symantic/Base/Fixity.hs +0/−115
• src/Symantic/Base/Permutable.hs +0/−73
• src/Symantic/Base/Routable.hs +0/−20
• src/Symantic/Dityped.hs +7/−0
• src/Symantic/Dityped/ADT.hs +198/−0
• src/Symantic/Dityped/CurryN.hs +40/−0
• src/Symantic/Dityped/Derive.hs +87/−0
• src/Symantic/Dityped/Lang.hs +246/−0
• src/Symantic/Typed.hs +17/−0
• src/Symantic/Typed/Data.hs +211/−0
• src/Symantic/Typed/Derive.hs +87/−0
• src/Symantic/Typed/Fixity.hs +115/−0
• src/Symantic/Typed/Lang.hs +154/−0
• src/Symantic/Typed/ObserveSharing.hs +330/−0
• src/Symantic/Typed/Optimize.hs +41/−0
• src/Symantic/Typed/Reify.hs +68/−0
• src/Symantic/Typed/View.hs +116/−0
• stack.yaml +0/−1
• stack.yaml.lock +0/−12
• symantic-base.cabal +83/−27

@@ -0,0 +1,1 @@+use flake

@@ -1,674 +0,0 @@-                    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:--    <program>  Copyright (C) <year>  <name of author>-    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>.

@@ -0,0 +1,44 @@+override REPL_OPTIONS += -ignore-dot-ghci++cabal := $(wildcard *.cabal)+package := $(notdir ./$(cabal:.cabal=))+version := $(shell sed -ne 's/^version: *\(.*\)/\1/p' $(cabal))+project := $(patsubst %.cabal,%,$(cabal))++all: build+build:+	cabal build $(CABAL_BUILD_FLAGS)+clean c:+	cabal clean+repl:+	cabal repl $(CABAL_REPL_FLAGS) $(project)+ghcid:+	ghcid -c 'cabal repl $(CABAL_REPL_FLAGS) $(project) --repl-options "$(REPL_OPTIONS)"' --reverse-errors++doc:+	cabal haddock --haddock-css ocean --haddock-hyperlink-source++tag:+	git tag --merged | grep -Fqx "$(package)-$(version)" || \+	git tag -f -s -m "$(package) v$(version)" $(package)-$(version)++tar:+	cabal sdist+	cabal haddock --haddock-for-hackage --enable-doc+upload: LANG=C+upload: tar+	cabal upload $(CABAL_UPLOAD_FLAGS) dist-newstyle/sdist/$(package)-$(version).tar.gz+	cabal upload $(CABAL_UPLOAD_FLAGS) --documentation dist-newstyle/$(package)-$(version)-docs.tar.gz+%/publish: CABAL_UPLOAD_FLAGS+=--publish+%/publish: %+	+publish: upload/publish++nix-build:+	nix -L build+nix-relock:+	nix flake update --recreate-lock-file+nix-repl:+	nix -L develop --command cabal repl $(CABAL_REPL_FLAGS)+nix-shell:+	nix -L develop

@@ -0,0 +1,1 @@+packages:.

@@ -0,0 +1,27 @@+{ pkgs ? import <nixpkgs> {}+, ghc ? null+, withHoogle ? false+}:+let+  haskellPackages =+    if ghc == null+    then pkgs.haskellPackages+    else pkgs.haskell.packages.${ghc};+  hs = haskellPackages.extend (with pkgs.haskell.lib; hself: hsuper: {+      symantic-base = buildFromSdist (hself.callCabal2nix "symantic-base" ./. {});+  });+in hs.symantic-base // {+  shell = hs.shellFor {+    doBenchmark = true;+    packages = p: [ p.symantic-base ];+    nativeBuildInputs = [+      hs.cabal-install+      hs.ghcid+      hs.haskell-language-server+      hs.hlint+    ];+    buildInputs = [+    ];+    inherit withHoogle;+  };+}

@@ -0,0 +1,38 @@+{+  "nodes": {+    "flake-utils": {+      "locked": {+        "lastModified": 1623875721,+        "narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=",+        "owner": "numtide",+        "repo": "flake-utils",+        "rev": "f7e004a55b120c02ecb6219596820fcd32ca8772",+        "type": "github"+      },+      "original": {+        "owner": "numtide",+        "repo": "flake-utils",+        "type": "github"+      }+    },+    "nixpkgs": {+      "locked": {+        "narHash": "sha256-3C35/g5bJ3KH67fOpxTkqDpfJ1CHYrO2bbl+fPgqfMQ=",+        "path": "/nix/store/6g7dgkinzm4rvwmpfp9avklsb4hiqals-nixpkgs-patched",+        "type": "path"+      },+      "original": {+        "id": "nixpkgs",+        "type": "indirect"+      }+    },+    "root": {+      "inputs": {+        "flake-utils": "flake-utils",+        "nixpkgs": "nixpkgs"+      }+    }+  },+  "root": "root",+  "version": 7+}

@@ -0,0 +1,13 @@+{+inputs.nixpkgs.url = "flake:nixpkgs";+#inputs.nixpkgs.url = "github:NixOS/nixpkgs";+inputs.flake-utils.url = "github:numtide/flake-utils";+outputs = inputs:+  inputs.flake-utils.lib.eachDefaultSystem (system: let+    pkgs = inputs.nixpkgs.legacyPackages.${system};+    in {+      defaultPackage = import ./default.nix { inherit pkgs; };+      devShell = (import ./default.nix { inherit pkgs; }).shell;+    }+  );+}

@@ -1,17 +0,0 @@-module Symantic.Base- ( module Symantic.Base.ADT- , module Symantic.Base.Algebrable- , module Symantic.Base.Composable- , module Symantic.Base.CurryN- , module Symantic.Base.Fixity- , module Symantic.Base.Permutable- , module Symantic.Base.Routable- ) where--import Symantic.Base.ADT-import Symantic.Base.Algebrable-import Symantic.Base.Composable-import Symantic.Base.CurryN-import Symantic.Base.Fixity-import Symantic.Base.Permutable-import Symantic.Base.Routable

@@ -1,198 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE UndecidableInstances #-}--- | EOT (Either of Tuples) to/from ADT (Algebraic Data Type).--- to produce or consume custom ADT with @('<:>')@ and @('<+>')@.------ This is like what is done in @generic-sop@:--- https://hackage.haskell.org/package/generics-sop-0.5.1.0/docs/src/Generics.SOP.GGP.html#gSumFrom--- but using directly 'Either' and 'Tuples'--- instead of passing by the intermediary GADTs @NP@ and @NS@.-module Symantic.Base.ADT where--import Data.Either (Either(..))-import Data.Void (Void, absurd)-import Data.Function (($), (.), id, const)-import GHC.Generics as Generics---- * Type family 'EoT'--- Return an 'Either' of 'Tuples' from the given 'ADT',--- matching the nesting occuring when using @('<:>')@ and ('<+>')@--- and their associativity and precedence,--- with no parenthesis messing around.-type family EoT (adt :: [[*]]) :: * where-  -- This is 'absurd'-  EoT '[] = Void-  -- There Is No Alternative-  EoT '[ ps ] = Tuples ps-  -- The right associativity of @('<+>')@-  -- puts leaves on 'Left' and nodes on 'Right'-  EoT (ps ': ss) = Either (Tuples ps) (EoT ss)---- * Type family 'Tuples'--- | Return the type of 'snd'-nested 2-tuples--- from the given list of types.-type family Tuples (as :: [*]) :: (r :: *) where-  Tuples '[] = ()-  Tuples '[a] = a-  Tuples (a ': rest) = (a, Tuples rest)---- * Type 'ADT'--- | Normalized type-level representation of an Algebraic Data Type.-type ADT (adt :: *) = ListOfRepSums (Rep adt) '[]---- ** Type family 'ListOfRepSums'--- | Collect the alternatives in a continuation passing-style.-type family ListOfRepSums (a :: * -> *) (ss :: [[*]]) :: [[*]]-type instance ListOfRepSums (a:+:b)     ss = ListOfRepSums a (ListOfRepSums b ss)--- | Meta-information for datatypes-type instance ListOfRepSums (M1 D _c a) ss = ListOfRepSums a ss--- | Meta-information for constructors-type instance ListOfRepSums (M1 C _c a) ss = ListOfRepProducts a '[] ': ss--- | Empty datatypes-type instance ListOfRepSums V1          ss = ss---- ** Type family 'ListOfRepProducts'--- | Collect the records in a continuation passing-style.-type family ListOfRepProducts (a :: * -> *) (ps :: [*]) :: [*]-type instance ListOfRepProducts (a:*:b)     ps = ListOfRepProducts a (ListOfRepProducts b ps)--- | Meta-information for record selectors-type instance ListOfRepProducts (M1 S _c a) ps = TypeOfRepField a ': ps--- | Constructor without fields-type instance ListOfRepProducts U1          ps = ps---- ** Type family 'TypeOfRepField'-type family TypeOfRepField (a :: * -> *) :: *-type instance TypeOfRepField (K1 _i a) = a---- * Class 'RepOfEoT'-type RepOfEoT a = RepOfEithers (Rep a) '[]---- | Morph the 'Either' of 'Tuples' corresponding to an 'ADT'--- into a constructor of this 'ADT'.--- This is the reverse of 'eotOfadt'.-adtOfeot :: Generic a => RepOfEoT a => EoT (ADT a) -> a-adtOfeot eot = Generics.to $ repOfEithers @_ @'[] eot id absurd---- ** Class 'RepOfEithers'-class RepOfEithers (a :: * -> *) ss where-  -- | Parse the 'Either' (list-like) binary tree of 'EoT'-  -- into the @(':+:')@ (balanced) binary tree of 'Rep',-  -- using continuation passing-style for performance.-  repOfEithers ::-   EoT (ListOfRepSums a ss) ->-   -- the 'a' 'Rep' is the current alternative in the 'EoT'-   (a x -> r) ->-   -- the 'a' 'Rep' is a following alternative in the 'EoT'-   (EoT ss -> r) ->-   r-instance (RepOfEithers a (ListOfRepSums b ss), RepOfEithers b ss) => RepOfEithers (a:+:b) ss where-  repOfEithers eot ok ko =-    -- try to parse 'a' on the current 'eot'-    repOfEithers @a @(ListOfRepSums b ss) eot-     (ok . L1)-     (\next ->-      -- parsing 'a' failed-      -- try to parse 'b' on the 'Right' of the current 'eot'-      repOfEithers @b @ss next-       (ok . R1)-       ko -- parsing 'b' failed: backtrack-     )-instance RepOfEithers a ss => RepOfEithers (M1 D c a) ss where-  repOfEithers eot ok = repOfEithers @a @ss eot (ok . M1)-instance RepOfTuples a '[] => RepOfEithers (M1 C c a) (ps ': ss) where-  repOfEithers eot ok ko =-    case eot of-     -- 'EoT' is a leaf, and 'Rep' too: parsing succeeds-     Left ts -> ok $ M1 $ repOfTuples @a @'[] ts const-     -- 'EoT' is a node, but 'Rep' is a leaf: parsing fails-     Right ss -> ko ss-instance RepOfTuples a '[] => RepOfEithers (M1 C c a) '[] where-  repOfEithers eot ok _ko = ok $ M1 $ repOfTuples @_ @'[] eot const-instance RepOfEithers V1 ss where-  repOfEithers eot _ok ko = ko eot---- ** Class 'RepOfTuples'-class RepOfTuples (a :: * -> *) (xs::[*]) where-  -- | Parse the 'Tuples' (list-like) binary tree of 'EoT'-  -- into the @(':*:')@ (balanced) binary tree of 'Rep',-  -- using continuation passing-style for performance.-  repOfTuples ::-   Tuples (ListOfRepProducts a xs) ->-   (a x -> Tuples xs -> r) -> r-instance (RepOfTuples a (ListOfRepProducts b ps), RepOfTuples b ps) => RepOfTuples (a:*:b) ps where-  repOfTuples ts k =-    -- uncons 'a'-    repOfTuples @a @(ListOfRepProducts b ps) ts-     (\a ts' ->-      -- uncons 'b'-      repOfTuples @b @ps ts'-        (\b -> k (a:*:b)))-instance RepOfField a => RepOfTuples (M1 S c a) (p ': ps) where-  repOfTuples (a, ts) k = k (M1 (repOfField a)) ts-instance RepOfField a => RepOfTuples (M1 S c a) '[] where-  repOfTuples a k = k (M1 (repOfField a)) ()-instance RepOfTuples U1 ps where-  repOfTuples ts k = k U1 ts---- ** Class 'RepOfField'-class RepOfField (a :: * -> *) where-  repOfField :: TypeOfRepField a -> a x-instance RepOfField (K1 i a) where-  repOfField = K1---- * Class 'EoTOfRep'-type EoTOfRep a = EithersOfRep (Rep a) '[]---- | Morph the constructor of an 'ADT'--- into the corresponding 'Either' of 'Tuples' of this 'ADT'.--- This is the reverse of 'adtOfeot'.-eotOfadt :: Generic a => EoTOfRep a => a -> EoT (ADT a)-eotOfadt = eithersOfRepL @_ @'[] . Generics.from---- ** Class 'EithersOfRep'-class EithersOfRep (a :: * -> *) ss where-  eithersOfRepL :: a x    -> EoT (ListOfRepSums a ss)-  eithersOfRepR :: EoT ss -> EoT (ListOfRepSums a ss)-instance (EithersOfRep a (ListOfRepSums b ss), EithersOfRep b ss) =>- EithersOfRep (a:+:b) ss where-  eithersOfRepL = \case-   L1 a -> eithersOfRepL @a @(ListOfRepSums b ss) a-   R1 b -> eithersOfRepR @a @(ListOfRepSums b ss) (eithersOfRepL @b @ss b)-  eithersOfRepR ss = eithersOfRepR @a @(ListOfRepSums b ss) (eithersOfRepR @b @ss ss)-instance EithersOfRep a ss => EithersOfRep (M1 D c a) ss where-  eithersOfRepL (M1 a) = eithersOfRepL @a @ss a-  eithersOfRepR = eithersOfRepR @a @ss-instance TuplesOfRep a '[] => EithersOfRep (M1 C c a) '[] where-  eithersOfRepL (M1 a) = tuplesOfRep @_ @'[] a ()-  eithersOfRepR = absurd-instance TuplesOfRep a '[] => EithersOfRep (M1 C c a) (ps ': ss) where-  eithersOfRepL (M1 a) = Left $ tuplesOfRep @_ @'[] a ()-  eithersOfRepR = Right-instance EithersOfRep V1 ss where-  eithersOfRepL = \case {}-  eithersOfRepR = id---- ** Class 'TuplesOfRep'-class TuplesOfRep (a :: * -> *) (ps::[*]) where-  tuplesOfRep :: a x -> Tuples ps -> Tuples (ListOfRepProducts a ps)-instance (TuplesOfRep a (ListOfRepProducts b ps), TuplesOfRep b ps) => TuplesOfRep (a:*:b) ps where-  tuplesOfRep (a:*:b) ps =-    tuplesOfRep @a @(ListOfRepProducts b ps) a-     (tuplesOfRep @b @ps b ps)-instance TuplesOfRep U1 ps where-  tuplesOfRep U1 xs = xs-instance FieldOfRep a => TuplesOfRep (M1 S c a) (x ': ps) where-  tuplesOfRep (M1 a) xs = (fieldOfRep a, xs)-instance FieldOfRep a => TuplesOfRep (M1 S c a) '[] where-  tuplesOfRep (M1 a) _xs = fieldOfRep a---- ** Class 'FieldOfRep'-class FieldOfRep (a :: * -> *) where-  fieldOfRep :: a x -> TypeOfRepField a-instance FieldOfRep (K1 i a) where-  fieldOfRep (K1 a) = a

@@ -1,128 +0,0 @@-module Symantic.Base.Algebrable where--import Data.Either (Either)-import Data.Function ((.))-import Data.Maybe (Maybe(..))-import Data.Proxy (Proxy(..))-import GHC.Generics (Generic)--import Symantic.Base.ADT-import Symantic.Base.CurryN-import Symantic.Base.Composable---- | @('adt' @@SomeADT some_expr)@--- wrap\/unwrap @(some_expr)@ input\/output value--- to\/from the Algebraic Data Type @(SomeADT)@.--- @(SomeADT)@ must have a 'Generic' instance--- (using the @DeriveGeneric@ language extension to GHC).-adt ::- forall adt repr k.- Dimapable repr =>- Generic adt =>- RepOfEoT adt =>- EoTOfRep adt =>- repr (EoT (ADT adt) -> k) k ->- repr (adt -> k) k-adt = dimap adtOfeot eotOfadt---- * Class 'Tupable'-class Tupable repr where-  default (<:>) :: Transformable repr => Tupable (UnTrans repr) =>-           repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k-  (<:>) :: repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k-  (<:>) = trans2 (<:>)-infixr 4 <:>---- ** Class 'Unitable'-class Unitable repr where-  default unit :: Transformable repr => Unitable (UnTrans repr) =>-          repr (() -> k) k-  unit :: repr (() -> k) k-  unit = noTrans unit---- ** Class 'Constant'-class Constant repr where-  default constant :: Transformable repr => Constant (UnTrans repr) =>-              a -> repr (a -> k) k-  constant :: a -> repr (a -> k) k-  constant = noTrans . constant---- * Class 'Eitherable'-class Eitherable repr where-  default (<+>) :: Transformable repr => Eitherable (UnTrans repr) =>-           repr (a->k) k -> repr (b->k) k -> repr (Either a b -> k) k-  (<+>) :: repr (a->k) k -> repr (b->k) k -> repr (Either a b->k) k-  (<+>) = trans2 (<+>)--- NOTE: yes infixr, not infixl like <|>,--- in order to run left-most checks first.-infixr 3 <+>---- ** Class 'Emptyable'-class Emptyable repr where-  default empty :: Transformable repr => Emptyable (UnTrans repr) =>-           repr k k-  empty :: repr k k-  empty = noTrans empty---- ** Class 'Optionable'-class Optionable repr where-  default option :: Transformable repr => Optionable (UnTrans repr) =>-            repr k k -> repr k k-  option :: repr k k -> repr k k-  option = trans1 option-  default optional :: Transformable repr => Optionable (UnTrans repr) =>-              repr (a->k) k -> repr (Maybe a->k) k-  optional :: repr (a->k) k -> repr (Maybe a->k) k-  optional = trans1 optional---- * Class 'Repeatable'-class Repeatable repr where-  default many0 :: Transformable repr => Repeatable (UnTrans repr) =>-           repr (a->k) k -> repr ([a]->k) k-  many0 :: repr (a->k) k -> repr ([a]->k) k-  many0 = trans1 many0-  default many1 :: Transformable repr => Repeatable (UnTrans repr) =>-           repr (a->k) k -> repr ([a]->k) k-  many1 :: repr (a->k) k -> repr ([a]->k) k-  many1 = trans1 many1---- * Class 'Substractable'-class Substractable repr where-  default (<->) :: Transformable repr => Substractable (UnTrans repr) =>-           repr a k -> repr k' k' -> repr a k-  (<->) :: repr a k -> repr k' k' -> repr a k-  (<->) = trans2 (<->)-infixr 3 <->---- * Class 'Dicurryable'-class Dicurryable repr where-  dicurry ::-   CurryN args =>-   proxy args ->-   (args-..->r) -> -- construction-   (r->Tuples args) -> -- destruction-   repr (args-..->k) k ->-   repr (r->k) k-  default dicurry ::-   Transformable repr =>-   Dicurryable (UnTrans repr) =>-   CurryN args =>-   proxy args ->-   (args-..->r) ->-   (r->Tuples args) ->-   repr (args-..->k) k ->-   repr (r->k) k-  dicurry args constr destr = trans1 (dicurry args constr destr)--construct ::- forall args a k repr.- Dicurryable repr =>- Generic a =>- EoTOfRep a =>- CurryN args =>- Tuples args ~ EoT (ADT a) =>- (args ~ Args (args-..->a)) =>- (args-..->a) ->- repr (args-..->k) k ->- repr (a -> k) k-construct f = dicurry (Proxy::Proxy args) f eotOfadt

@@ -1,61 +0,0 @@-module Symantic.Base.Composable where--import Data.Function ((.))---- * Class 'Composable'-class Composable repr where-  default (<.>) :: Transformable repr => Composable (UnTrans repr) =>-           repr a b -> repr b c -> repr a c-  (<.>) :: repr a b -> repr b c -> repr a c-  (<.>) = trans2 (<.>)-infixr 4 <.>---- * Class 'Voidable'-class Voidable repr where-  default void :: Transformable repr => Voidable (UnTrans repr) =>-          a -> repr (a -> b) k -> repr b k-  void :: a -> repr (a -> b) k -> repr b k-  void a = trans1 (void a)---- * Class 'Transformable'--- | Used with @DefaultSignatures@ and default methods,--- in the symantics class definition,--- it then avoids on an interpreter instance--- to define unused methods.-class Transformable repr where-  -- | The underlying representation that @(repr)@ transforms.-  type UnTrans repr :: * -> * -> *-  -- | Lift the underlying representation to @(repr)@.-  -- Useful to define a combinator that does nothing -  -- in a transformation.-  noTrans :: UnTrans repr a b -> repr a b-  -- | Unlift a representation. Useful when a transformation-  -- combinator needs to access the 'UnTrans'formed representation,-  -- or at the end to get the underlying 'UnTrans'formed representation-  -- from the inferred @(repr)@ value.-  unTrans :: repr a b -> UnTrans repr a b-  -- | Convenient helper lifing an unary operator,-  -- but also enables to identify unary operators.-  trans1 :: (UnTrans repr a b -> UnTrans repr c d) -> repr a b -> repr c d-  trans1 f = noTrans . f . unTrans-  -- | Convenient helper lifting a binary operator,-  -- but also enables to identify binary operators.-  trans2 :: (UnTrans repr a b -> UnTrans repr c d -> UnTrans repr e f) -> repr a b -> repr c d -> repr e f-  trans2 f x y = noTrans (f (unTrans x) (unTrans y))---- ** Type 'IdentityTrans'--- | A 'Transformable' that does nothing.-newtype IdentityTrans repr a k- =      IdentityTrans- {    unIdentityTrans :: repr a k }-instance Transformable (IdentityTrans repr) where-  type UnTrans (IdentityTrans repr) = repr-  noTrans = IdentityTrans-  unTrans = unIdentityTrans---- * Class 'Dimapable'-class Dimapable repr where-  default dimap :: Transformable repr => Dimapable (UnTrans repr) =>-           (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k-  dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k-  dimap a2b b2a = trans1 (dimap a2b b2a)

@@ -1,40 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-module Symantic.Base.CurryN where--import Data.Function (($), (.))--import Symantic.Base.ADT (Tuples)---- * Class 'CurryN'--- | Produce and consume 'Tuples'.--- Not actually useful for the Generic side of this module,--- but related through the use of 'Tuples'.-class CurryN args where-  -- Like 'curry' but for an arbitrary number of nested 2-tuples.-  curryN :: (Tuples args -> res) -> args-..->res-  -- Like 'uncurry' but for an arbitrary number of nested 2-tuples.-  uncurryN :: (args-..->res) -> Tuples args -> res-  -- Like 'fmap' on @('->')@ but for an arbitrary number of arguments.-  mapresultN :: (a->b) -> (args-..->a) -> args-..->b-instance CurryN '[a] where-  curryN = ($)-  uncurryN = ($)-  mapresultN = (.)-instance CurryN (b ': as) => CurryN (a ': b ': as) where-  curryN f x = curryN @(b ': as) (\xs -> f (x, xs))-  uncurryN f (x, xs) = uncurryN @(b ': as) (f x) xs-  mapresultN f as2r = mapresultN @(b ': as) f . as2r---- ** Type family ('-..->')-type family (args :: [*]) -..-> (r :: *) :: * where-  '[]        -..-> r = r-  (a : args) -..-> r = a -> args -..-> r--- ** Type family 'Args'-type family Args (f :: *) :: [*] where-  Args (a -> r) = a : Args r-  Args r = '[]--- ** Type family 'Result'-type family Result (as :: *) :: * where-  Result (a -> r) = Result r-  Result r = r

@@ -1,115 +0,0 @@-module Symantic.Base.Fixity where--import Data.Bool-import Data.Eq (Eq(..))-import Data.Function ((.))-import Data.Int (Int)-import Data.Maybe (Maybe(..))-import Data.Ord (Ord(..))-import Data.Semigroup-import Data.String (String, IsString(..))-import Text.Show (Show(..))---- * Type 'Fixity'-data Fixity- =   Fixity1 Unifix- |   Fixity2 Infix- deriving (Eq, Show)---- ** Type 'Unifix'-data Unifix- =   Prefix  { unifix_precedence :: Precedence }- |   Postfix { unifix_precedence :: Precedence }- deriving (Eq, Show)---- ** Type 'Infix'-data Infix- =   Infix- {   infix_associativity :: Maybe Associativity- ,   infix_precedence    :: Precedence- } deriving (Eq, Show)--infixL :: Precedence -> Infix-infixL = Infix (Just AssocL)--infixR :: Precedence -> Infix-infixR = Infix (Just AssocR)--infixB :: Side -> Precedence -> Infix-infixB = Infix . Just . AssocB--infixN :: Precedence -> Infix-infixN = Infix Nothing--infixN0 :: Infix-infixN0 = infixN 0--infixN5 :: Infix-infixN5 = infixN 5---- | Given 'Precedence' and 'Associativity' of its parent operator,--- and the operand 'Side' it is in,--- return whether an 'Infix' operator--- needs to be enclosed by a 'Pair'.-isPairNeeded :: (Infix, Side) -> Infix -> Bool-isPairNeeded (po, lr) op =-  infix_precedence op < infix_precedence po-  || infix_precedence op == infix_precedence po-  && not associate-  where-  associate =-    case (lr, infix_associativity po) of-     (_, Just AssocB{})   -> True-     (SideL, Just AssocL) -> True-     (SideR, Just AssocR) -> True-     _ -> False---- | If 'isPairNeeded' is 'True',--- enclose the given 'IsString' by given 'Pair',--- otherwise returns the same 'IsString'.-pairIfNeeded ::- Semigroup s => IsString s =>- Pair -> (Infix, Side) -> Infix ->- s -> s-pairIfNeeded (o,c) po op s =-  if isPairNeeded po op-  then fromString o <> s <> fromString c-  else s---- * Type 'Precedence'-type Precedence = Int---- ** Class 'PrecedenceOf'-class PrecedenceOf a where-  precedence :: a -> Precedence-instance PrecedenceOf Fixity where-  precedence (Fixity1 uni) = precedence uni-  precedence (Fixity2 inf) = precedence inf-instance PrecedenceOf Unifix where-  precedence = unifix_precedence-instance PrecedenceOf Infix where-  precedence = infix_precedence---- * Type 'Associativity'-data Associativity- =   AssocL      -- ^ Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@- |   AssocR      -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@- |   AssocB Side -- ^ Associate to both sides, but to 'Side' when reading.- deriving (Eq, Show)---- ** Type 'Side'-data Side- =   SideL -- ^ Left- |   SideR -- ^ Right- deriving (Eq, Show)---- ** Type 'Pair'-type Pair = (String, String)-pairAngle   :: Pair-pairBrace   :: Pair-pairBracket :: Pair-pairParen   :: Pair-pairAngle   = ("<",">")-pairBrace   = ("{","}")-pairBracket = ("[","]")-pairParen   = ("(",")")

@@ -1,73 +0,0 @@-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-module Symantic.Base.Permutable where--import Data.Function ((.))-import Data.Maybe (Maybe(..), fromJust)--import Symantic.Base.Composable-import Symantic.Base.Algebrable---- * Class 'Permutable'-class Permutable repr where-  -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.-  type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr-  type Permutation repr = Permutation (UnTrans repr)-  permutable :: Permutation repr (a->k) k -> repr (a->k) k-  perm :: repr (a->k) k -> Permutation repr (a->k) k-  noPerm :: Permutation repr k k-  permWithDefault :: a -> repr (a->k) k -> Permutation repr (a->k) k-  optionalPerm ::-   Eitherable repr => Dimapable repr => Permutable repr =>-   repr (a->k) k -> Permutation repr (Maybe a -> k) k-  optionalPerm = permWithDefault Nothing . dimap Just fromJust--(<&>) ::- Permutable repr =>- Tupable (Permutation repr) =>- repr (a->k) k ->- Permutation repr (b->k) k ->- Permutation repr ((a,b)->k) k-x <&> y = perm x <:> y--(<?&>) ::- Eitherable repr =>- Dimapable repr =>- Permutable repr =>- Tupable (Permutation repr) =>- repr (a->k) k ->- Permutation repr (b->k) k ->- Permutation repr ((Maybe a,b)->k) k-x <?&> y = optionalPerm x <:> y--(<*&>) ::- Eitherable repr =>- Repeatable repr =>- Dimapable repr =>- Permutable repr =>- Tupable (Permutation repr) =>- repr (a->k) k ->- Permutation repr (b->k) k ->- Permutation repr (([a],b)->k) k-x <*&> y = permWithDefault [] (many1 x) <:> y--(<+&>) ::- Eitherable repr =>- Repeatable repr =>- Dimapable repr =>- Permutable repr =>- Tupable (Permutation repr) =>- repr (a->k) k ->- Permutation repr (b->k) k ->- Permutation repr (([a],b)->k) k-x <+&> y = perm (many1 x) <:> y--infixr 4 <&>-infixr 4 <?&>-infixr 4 <*&>-infixr 4 <+&>--{-# INLINE (<&>)  #-}-{-# INLINE (<?&>) #-}-{-# INLINE (<*&>) #-}-{-# INLINE (<+&>) #-}

@@ -1,20 +0,0 @@-module Symantic.Base.Routable where--import Data.Eq (Eq)-import Text.Show (Show)--import Symantic.Base.Composable---- * Class 'Routable'-class Routable repr where-  (<!>) = trans2 (<!>)-  default (<!>) :: Transformable repr => Routable (UnTrans repr) =>-           repr a k -> repr b k -> repr (a:!:b) k-  (<!>) :: repr a k -> repr b k -> repr (a:!:b) k-infixr 3 <!>---- ** Type (':!:')--- | Like @(,)@ but @infixr@.-data (:!:) a b = a:!:b- deriving (Eq,Show)-infixr 3 :!:

@@ -0,0 +1,7 @@+module Symantic.Dityped+ ( module Symantic.Dityped.Derive+ , module Symantic.Dityped.Lang+ ) where++import Symantic.Dityped.Derive+import Symantic.Dityped.Lang

@@ -0,0 +1,198 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}+-- | EOT (Either of Tuples) to/from ADT (Algebraic Data Type).+-- to produce or consume custom ADT with @('<:>')@ and @('<+>')@.+--+-- This is like what is done in @generic-sop@:+-- https://hackage.haskell.org/package/generics-sop-0.5.1.0/docs/src/Generics.SOP.GGP.html#gSumFrom+-- but using directly 'Either' and 'Tuples'+-- instead of passing by the intermediary GADTs @NP@ and @NS@.+module Symantic.Dityped.ADT where++import Data.Either (Either(..))+import Data.Void (Void, absurd)+import Data.Function (($), (.), id, const)+import GHC.Generics as Generics++-- * Type family 'EoT'+-- Return an 'Either' of 'Tuples' from the given 'ADT',+-- matching the nesting occuring when using @('<:>')@ and ('<+>')@+-- and their associativity and precedence,+-- with no parenthesis messing around.+type family EoT (adt :: [[*]]) :: * where+  -- This is 'absurd'+  EoT '[] = Void+  -- There Is No Alternative+  EoT '[ ps ] = Tuples ps+  -- The right associativity of @('<+>')@+  -- puts leaves on 'Left' and nodes on 'Right'+  EoT (ps ': ss) = Either (Tuples ps) (EoT ss)++-- * Type family 'Tuples'+-- | Return the type of 'snd'-nested 2-tuples+-- from the given list of types.+type family Tuples (as :: [*]) :: (r :: *) where+  Tuples '[] = ()+  Tuples '[a] = a+  Tuples (a ': rest) = (a, Tuples rest)++-- * Type 'ADT'+-- | Normalized type-level representation of an Algebraic Data Type.+type ADT (adt :: *) = ListOfRepSums (Rep adt) '[]++-- ** Type family 'ListOfRepSums'+-- | Collect the alternatives in a continuation passing-style.+type family ListOfRepSums (a :: * -> *) (ss :: [[*]]) :: [[*]]+type instance ListOfRepSums (a:+:b)     ss = ListOfRepSums a (ListOfRepSums b ss)+-- | Meta-information for datatypes+type instance ListOfRepSums (M1 D _c a) ss = ListOfRepSums a ss+-- | Meta-information for constructors+type instance ListOfRepSums (M1 C _c a) ss = ListOfRepProducts a '[] ': ss+-- | Empty datatypes+type instance ListOfRepSums V1          ss = ss++-- ** Type family 'ListOfRepProducts'+-- | Collect the records in a continuation passing-style.+type family ListOfRepProducts (a :: * -> *) (ps :: [*]) :: [*]+type instance ListOfRepProducts (a:*:b)     ps = ListOfRepProducts a (ListOfRepProducts b ps)+-- | Meta-information for record selectors+type instance ListOfRepProducts (M1 S _c a) ps = TypeOfRepField a ': ps+-- | Constructor without fields+type instance ListOfRepProducts U1          ps = ps++-- ** Type family 'TypeOfRepField'+type family TypeOfRepField (a :: * -> *) :: *+type instance TypeOfRepField (K1 _i a) = a++-- * Class 'RepOfEoT'+type RepOfEoT a = RepOfEithers (Rep a) '[]++-- | Morph the 'Either' of 'Tuples' corresponding to an 'ADT'+-- into a constructor of this 'ADT'.+-- This is the reverse of 'eotOfadt'.+adtOfeot :: Generic a => RepOfEoT a => EoT (ADT a) -> a+adtOfeot eot = Generics.to $ repOfEithers @_ @'[] eot id absurd++-- ** Class 'RepOfEithers'+class RepOfEithers (a :: * -> *) ss where+  -- | Parse the 'Either' (list-like) binary tree of 'EoT'+  -- into the @(':+:')@ (balanced) binary tree of 'Rep',+  -- using continuation passing-style for performance.+  repOfEithers ::+   EoT (ListOfRepSums a ss) ->+   -- the 'a' 'Rep' is the current alternative in the 'EoT'+   (a x -> r) ->+   -- the 'a' 'Rep' is a following alternative in the 'EoT'+   (EoT ss -> r) ->+   r+instance (RepOfEithers a (ListOfRepSums b ss), RepOfEithers b ss) => RepOfEithers (a:+:b) ss where+  repOfEithers eot ok ko =+    -- try to parse 'a' on the current 'eot'+    repOfEithers @a @(ListOfRepSums b ss) eot+     (ok . L1)+     (\next ->+      -- parsing 'a' failed+      -- try to parse 'b' on the 'Right' of the current 'eot'+      repOfEithers @b @ss next+       (ok . R1)+       ko -- parsing 'b' failed: backtrack+     )+instance RepOfEithers a ss => RepOfEithers (M1 D c a) ss where+  repOfEithers eot ok = repOfEithers @a @ss eot (ok . M1)+instance RepOfTuples a '[] => RepOfEithers (M1 C c a) (ps ': ss) where+  repOfEithers eot ok ko =+    case eot of+     -- 'EoT' is a leaf, and 'Rep' too: parsing succeeds+     Left ts -> ok $ M1 $ repOfTuples @a @'[] ts const+     -- 'EoT' is a node, but 'Rep' is a leaf: parsing fails+     Right ss -> ko ss+instance RepOfTuples a '[] => RepOfEithers (M1 C c a) '[] where+  repOfEithers eot ok _ko = ok $ M1 $ repOfTuples @_ @'[] eot const+instance RepOfEithers V1 ss where+  repOfEithers eot _ok ko = ko eot++-- ** Class 'RepOfTuples'+class RepOfTuples (a :: * -> *) (xs::[*]) where+  -- | Parse the 'Tuples' (list-like) binary tree of 'EoT'+  -- into the @(':*:')@ (balanced) binary tree of 'Rep',+  -- using continuation passing-style for performance.+  repOfTuples ::+   Tuples (ListOfRepProducts a xs) ->+   (a x -> Tuples xs -> r) -> r+instance (RepOfTuples a (ListOfRepProducts b ps), RepOfTuples b ps) => RepOfTuples (a:*:b) ps where+  repOfTuples ts k =+    -- uncons 'a'+    repOfTuples @a @(ListOfRepProducts b ps) ts+     (\a ts' ->+      -- uncons 'b'+      repOfTuples @b @ps ts'+        (\b -> k (a:*:b)))+instance RepOfField a => RepOfTuples (M1 S c a) (p ': ps) where+  repOfTuples (a, ts) k = k (M1 (repOfField a)) ts+instance RepOfField a => RepOfTuples (M1 S c a) '[] where+  repOfTuples a k = k (M1 (repOfField a)) ()+instance RepOfTuples U1 ps where+  repOfTuples ts k = k U1 ts++-- ** Class 'RepOfField'+class RepOfField (a :: * -> *) where+  repOfField :: TypeOfRepField a -> a x+instance RepOfField (K1 i a) where+  repOfField = K1++-- * Class 'EoTOfRep'+type EoTOfRep a = EithersOfRep (Rep a) '[]++-- | Morph the constructor of an 'ADT'+-- into the corresponding 'Either' of 'Tuples' of this 'ADT'.+-- This is the reverse of 'adtOfeot'.+eotOfadt :: Generic a => EoTOfRep a => a -> EoT (ADT a)+eotOfadt = eithersOfRepL @_ @'[] . Generics.from++-- ** Class 'EithersOfRep'+class EithersOfRep (a :: * -> *) ss where+  eithersOfRepL :: a x    -> EoT (ListOfRepSums a ss)+  eithersOfRepR :: EoT ss -> EoT (ListOfRepSums a ss)+instance (EithersOfRep a (ListOfRepSums b ss), EithersOfRep b ss) =>+ EithersOfRep (a:+:b) ss where+  eithersOfRepL = \case+   L1 a -> eithersOfRepL @a @(ListOfRepSums b ss) a+   R1 b -> eithersOfRepR @a @(ListOfRepSums b ss) (eithersOfRepL @b @ss b)+  eithersOfRepR ss = eithersOfRepR @a @(ListOfRepSums b ss) (eithersOfRepR @b @ss ss)+instance EithersOfRep a ss => EithersOfRep (M1 D c a) ss where+  eithersOfRepL (M1 a) = eithersOfRepL @a @ss a+  eithersOfRepR = eithersOfRepR @a @ss+instance TuplesOfRep a '[] => EithersOfRep (M1 C c a) '[] where+  eithersOfRepL (M1 a) = tuplesOfRep @_ @'[] a ()+  eithersOfRepR = absurd+instance TuplesOfRep a '[] => EithersOfRep (M1 C c a) (ps ': ss) where+  eithersOfRepL (M1 a) = Left $ tuplesOfRep @_ @'[] a ()+  eithersOfRepR = Right+instance EithersOfRep V1 ss where+  eithersOfRepL = \case {}+  eithersOfRepR = id++-- ** Class 'TuplesOfRep'+class TuplesOfRep (a :: * -> *) (ps::[*]) where+  tuplesOfRep :: a x -> Tuples ps -> Tuples (ListOfRepProducts a ps)+instance (TuplesOfRep a (ListOfRepProducts b ps), TuplesOfRep b ps) => TuplesOfRep (a:*:b) ps where+  tuplesOfRep (a:*:b) ps =+    tuplesOfRep @a @(ListOfRepProducts b ps) a+     (tuplesOfRep @b @ps b ps)+instance TuplesOfRep U1 ps where+  tuplesOfRep U1 xs = xs+instance FieldOfRep a => TuplesOfRep (M1 S c a) (x ': ps) where+  tuplesOfRep (M1 a) xs = (fieldOfRep a, xs)+instance FieldOfRep a => TuplesOfRep (M1 S c a) '[] where+  tuplesOfRep (M1 a) _xs = fieldOfRep a++-- ** Class 'FieldOfRep'+class FieldOfRep (a :: * -> *) where+  fieldOfRep :: a x -> TypeOfRepField a+instance FieldOfRep (K1 i a) where+  fieldOfRep (K1 a) = a

@@ -0,0 +1,40 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+module Symantic.Dityped.CurryN where++import Data.Function (($), (.))++import Symantic.Dityped.ADT (Tuples)++-- * Class 'CurryN'+-- | Produce and consume 'Tuples'.+-- Not actually useful for the Generic side of this module,+-- but related through the use of 'Tuples'.+class CurryN args where+  -- Like 'curry' but for an arbitrary number of nested 2-tuples.+  curryN :: (Tuples args -> res) -> args-..->res+  -- Like 'uncurry' but for an arbitrary number of nested 2-tuples.+  uncurryN :: (args-..->res) -> Tuples args -> res+  -- Like 'fmap' on @('->')@ but for an arbitrary number of arguments.+  mapresultN :: (a->b) -> (args-..->a) -> args-..->b+instance CurryN '[a] where+  curryN = ($)+  uncurryN = ($)+  mapresultN = (.)+instance CurryN (b ': as) => CurryN (a ': b ': as) where+  curryN f x = curryN @(b ': as) (\xs -> f (x, xs))+  uncurryN f (x, xs) = uncurryN @(b ': as) (f x) xs+  mapresultN f as2r = mapresultN @(b ': as) f . as2r++-- ** Type family ('-..->')+type family (args :: [*]) -..-> (r :: *) :: * where+  '[]        -..-> r = r+  (a : args) -..-> r = a -> args -..-> r+-- ** Type family 'Args'+type family Args (f :: *) :: [*] where+  Args (a -> r) = a : Args r+  Args r = '[]+-- ** Type family 'Result'+type family Result (as :: *) :: * where+  Result (a -> r) = Result r+  Result r = r

@@ -0,0 +1,87 @@+{-# LANGUAGE ConstraintKinds #-} -- For type class synonyms+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DefaultSignatures #-} -- For adding LiftDerived* constraints+module Symantic.Dityped.Derive where++import Data.Function ((.))+import Data.Kind (Type)++-- * Type family 'Derived'+-- | The representation that @(repr)@ derives to.+type family Derived (repr :: Type -> Type -> Type) :: Type -> Type -> Type++-- * Class 'Derivable'+-- | Derivable an interpreter to a another interpreter+-- determined by the 'Derived' open type family.+-- This is mostly useful when running the interpreter stack,+-- but also when going back from an initial encoding to a final one.+--+-- Note that 'derive' and 'liftDerived' are not necessarily reciprocical functions.+class Derivable repr where+  derive :: repr a ka -> Derived repr a ka++-- * Class 'LiftDerived'+-- | Lift the 'Derived' interpreter of an interpreter, to that interpreter.+-- This is mostly useful to give default values to class methods+-- in order to skip their definition for interpreters+-- where 'liftDerived' can already apply the right semantic.+--+-- Note that 'derive' and 'liftDerived' are not necessarily reciprocical functions.+class LiftDerived repr where+  liftDerived :: Derived repr a ka -> repr a ka++-- * Class 'LiftDerived1'+-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with a single argument.+class LiftDerived1 repr where+  liftDerived1 ::+    (Derived repr a ka -> Derived repr b kb) ->+    repr a ka -> repr b kb+  liftDerived1 f = liftDerived . f . derive+  default liftDerived1 ::+    LiftDerived repr => Derivable repr =>+    (Derived repr a ka -> Derived repr b kb) ->+    repr a ka -> repr b kb++-- * Class 'LiftDerived2'+-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with two arguments.+class LiftDerived2 repr where+  liftDerived2 ::+    (Derived repr a ka -> Derived repr b kb -> Derived repr c kc) ->+    repr a ka -> repr b kb -> repr c kc+  liftDerived2 f a b = liftDerived (f (derive a) (derive b))+  default liftDerived2 ::+    LiftDerived repr => Derivable repr =>+    (Derived repr a ka -> Derived repr b kb -> Derived repr c kc) ->+    repr a ka -> repr b kb -> repr c kc++-- * Class 'LiftDerived3'+-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with three arguments.+class LiftDerived3 repr where+  liftDerived3 ::+    (Derived repr a ka -> Derived repr b kb -> Derived repr c kc -> Derived repr d kd) ->+    repr a ka -> repr b kb -> repr c kc -> repr d kd+  liftDerived3 f a b c = liftDerived (f (derive a) (derive b) (derive c))+  default liftDerived3 ::+    LiftDerived repr => Derivable repr =>+    (Derived repr a ka -> Derived repr b kb -> Derived repr c kc -> Derived repr d kd) ->+    repr a ka -> repr b kb -> repr c kc -> repr d kd++-- * Class 'LiftDerived4'+-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with three arguments.+class LiftDerived4 repr where+  liftDerived4 ::+    (Derived repr a ka -> Derived repr b kb -> Derived repr c kc -> Derived repr d kd -> Derived repr e ke) ->+    repr a ka -> repr b kb -> repr c kc -> repr d kd -> repr e ke+  liftDerived4 f a b c d = liftDerived (f (derive a) (derive b) (derive c) (derive d))+  default liftDerived4 ::+    LiftDerived repr => Derivable repr =>+    (Derived repr a ka -> Derived repr b kb -> Derived repr c kc -> Derived repr d kd -> Derived repr e ke) ->+    repr a ka -> repr b kb -> repr c kc -> repr d kd -> repr e ke++-- * Type synonyms @FromDerived*@+-- | Convenient type synonym for using 'liftDerived' on symantic class @(sym)@.+type FromDerived  sym repr = ( LiftDerived  repr, sym (Derived repr) )+type FromDerived1 sym repr = ( LiftDerived1 repr, sym (Derived repr) )+type FromDerived2 sym repr = ( LiftDerived2 repr, sym (Derived repr) )+type FromDerived3 sym repr = ( LiftDerived3 repr, sym (Derived repr) )+type FromDerived4 sym repr = ( LiftDerived4 repr, sym (Derived repr) )

@@ -0,0 +1,246 @@+{-# LANGUAGE TypeFamilyDependencies #-} -- For Permutation+{-# LANGUAGE UndecidableInstances #-} -- For Permutation+module Symantic.Dityped.Lang where++import Data.Either (Either)+import Data.Eq (Eq)+import Data.Function ((.))+import Data.Maybe (Maybe(..), fromJust)+import Data.Proxy (Proxy(..))+import GHC.Generics (Generic)+import Text.Show (Show)++import Symantic.Dityped.ADT+import Symantic.Dityped.CurryN+import Symantic.Dityped.Derive++-- * Class 'Composable'+class Composable repr where+  (<.>) :: repr a b -> repr b c -> repr a c+  (<.>) = liftDerived2 (<.>)+  default (<.>) ::+    FromDerived2 Composable repr =>+    repr a b -> repr b c -> repr a c+infixr 4 <.>++-- ** Class 'Constant'+class Constant repr where+  constant :: a -> repr (a -> k) k+  constant = liftDerived . constant+  default constant ::+    FromDerived Constant repr =>+    a -> repr (a -> k) k++-- * Class 'Dicurryable'+class Dicurryable repr where+  dicurry ::+    CurryN args =>+    proxy args ->+    (args-..->r) -> -- construction+    (r->Tuples args) -> -- destruction+    repr (args-..->k) k ->+    repr (r->k) k+  dicurry args constr destr = liftDerived1 (dicurry args constr destr)+  default dicurry ::+    FromDerived1 Dicurryable repr =>+    CurryN args =>+    proxy args ->+    (args-..->r) ->+    (r->Tuples args) ->+    repr (args-..->k) k ->+    repr (r->k) k++construct ::+  forall args a k repr.+  Dicurryable repr =>+  Generic a =>+  EoTOfRep a =>+  CurryN args =>+  Tuples args ~ EoT (ADT a) =>+  (args ~ Args (args-..->a)) =>+  (args-..->a) ->+  repr (args-..->k) k ->+  repr (a -> k) k+construct f = dicurry (Proxy::Proxy args) f eotOfadt++-- * Class 'Dimapable'+class Dimapable repr where+  dimap :: (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k+  dimap a2b b2a = liftDerived1 (dimap a2b b2a)+  default dimap ::+    FromDerived1 Dimapable repr =>+    (a->b) -> (b->a) -> repr (a->k) k -> repr (b->k) k++-- * Class 'Eitherable'+class Eitherable repr where+  (<+>) :: repr (a->k) k -> repr (b->k) k -> repr (Either a b->k) k+  (<+>) = liftDerived2 (<+>)+  default (<+>) ::+    FromDerived2 Eitherable repr =>+    repr (a->k) k -> repr (b->k) k -> repr (Either a b -> k) k+-- NOTE: yes infixr, not infixl like <|>,+-- in order to run left-most checks first.+infixr 3 <+>++-- | @('adt' @@SomeADT some_expr)@+-- wrap\/unwrap @(some_expr)@ input\/output value+-- to\/from the Algebraic Data Type @(SomeADT)@.+-- @(SomeADT)@ must have a 'Generic' instance+-- (using the @DeriveGeneric@ language extension to GHC).+adt ::+  forall adt repr k.+  Dimapable repr =>+  Generic adt =>+  RepOfEoT adt =>+  EoTOfRep adt =>+  repr (EoT (ADT adt) -> k) k ->+  repr (adt -> k) k+adt = dimap adtOfeot eotOfadt++-- ** Class 'Emptyable'+class Emptyable repr where+  empty :: repr k k+  empty = liftDerived empty+  default empty ::+    FromDerived Emptyable repr =>+    repr k k++-- ** Class 'Optionable'+class Optionable repr where+  option :: repr k k -> repr k k+  optional :: repr (a->k) k -> repr (Maybe a->k) k+  option = liftDerived1 option+  optional = liftDerived1 optional+  default option ::+    FromDerived1 Optionable repr =>+    repr k k -> repr k k+  default optional ::+    FromDerived1 Optionable repr =>+    repr (a->k) k -> repr (Maybe a->k) k++-- * Class 'Permutable'+class Permutable repr where+  -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.+  type Permutation (repr:: * -> * -> *) = (r :: * -> * -> *) | r -> repr+  type Permutation repr = Permutation (Derived repr)+  permutable :: Permutation repr (a->k) k -> repr (a->k) k+  perm :: repr (a->k) k -> Permutation repr (a->k) k+  noPerm :: Permutation repr k k+  permWithDefault :: a -> repr (a->k) k -> Permutation repr (a->k) k+  optionalPerm ::+    Eitherable repr => Dimapable repr => Permutable repr =>+    repr (a->k) k -> Permutation repr (Maybe a -> k) k+  optionalPerm = permWithDefault Nothing . dimap Just fromJust++(<&>) ::+  Permutable repr =>+  Tupable (Permutation repr) =>+  repr (a->k) k ->+  Permutation repr (b->k) k ->+  Permutation repr ((a,b)->k) k+x <&> y = perm x <:> y++(<?&>) ::+  Eitherable repr =>+  Dimapable repr =>+  Permutable repr =>+  Tupable (Permutation repr) =>+  repr (a->k) k ->+  Permutation repr (b->k) k ->+  Permutation repr ((Maybe a,b)->k) k+x <?&> y = optionalPerm x <:> y++(<*&>) ::+  Eitherable repr =>+  Repeatable repr =>+  Dimapable repr =>+  Permutable repr =>+  Tupable (Permutation repr) =>+  repr (a->k) k ->+  Permutation repr (b->k) k ->+  Permutation repr (([a],b)->k) k+x <*&> y = permWithDefault [] (many1 x) <:> y++(<+&>) ::+  Eitherable repr =>+  Repeatable repr =>+  Dimapable repr =>+  Permutable repr =>+  Tupable (Permutation repr) =>+  repr (a->k) k ->+  Permutation repr (b->k) k ->+  Permutation repr (([a],b)->k) k+x <+&> y = perm (many1 x) <:> y++infixr 4 <&>+infixr 4 <?&>+infixr 4 <*&>+infixr 4 <+&>++{-# INLINE (<&>)  #-}+{-# INLINE (<?&>) #-}+{-# INLINE (<*&>) #-}+{-# INLINE (<+&>) #-}++-- * Class 'Repeatable'+class Repeatable repr where+  many0 :: repr (a->k) k -> repr ([a]->k) k+  many1 :: repr (a->k) k -> repr ([a]->k) k+  many0 = liftDerived1 many0+  many1 = liftDerived1 many1+  default many0 ::+    FromDerived1 Repeatable repr =>+    repr (a->k) k -> repr ([a]->k) k+  default many1 ::+    FromDerived1 Repeatable repr =>+    repr (a->k) k -> repr ([a]->k) k++-- * Class 'Routable'+class Routable repr where+  (<!>) :: repr a k -> repr b k -> repr (a:!:b) k+  (<!>) = liftDerived2 (<!>)+  default (<!>) ::+    FromDerived2 Routable repr =>+    repr a k -> repr b k -> repr (a:!:b) k+infixr 3 <!>++-- ** Type (':!:')+-- | Like @(,)@ but @infixr@.+-- Mostly useful for clarity when using 'Routable'.+data (:!:) a b = a:!:b+ deriving (Eq, Show)+infixr 3 :!:++-- * Class 'Substractable'+class Substractable repr where+  (<->) :: repr a k -> repr k' k' -> repr a k+  (<->) = liftDerived2 (<->)+  default (<->) ::+    FromDerived2 Substractable repr =>+    repr a k -> repr k' k' -> repr a k+infixr 3 <->++-- * Class 'Tupable'+class Tupable repr where+  (<:>) :: repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k+  (<:>) = liftDerived2 (<:>)+  default (<:>) ::+    FromDerived2 Tupable repr =>+    repr (a->k) k -> repr (b->k) k -> repr ((a,b)->k) k+infixr 4 <:>++-- ** Class 'Unitable'+class Unitable repr where+  unit :: repr (() -> k) k+  unit = liftDerived unit+  default unit ::+    FromDerived Unitable repr =>+    repr (() -> k) k++-- * Class 'Voidable'+class Voidable repr where+  default void ::+    FromDerived1 Voidable repr =>+    a -> repr (a -> b) k -> repr b k+  void :: a -> repr (a -> b) k -> repr b k+  void a = liftDerived1 (void a)

@@ -0,0 +1,17 @@+module Symantic.Typed+ ( module Symantic.Typed.Data+ , module Symantic.Typed.Derive+ , module Symantic.Typed.Lang+ , module Symantic.Typed.ObserveSharing+ , module Symantic.Typed.Optimize+ , module Symantic.Typed.Reify+ , module Symantic.Typed.View+ ) where++import Symantic.Typed.Data+import Symantic.Typed.Derive+import Symantic.Typed.Lang+import Symantic.Typed.ObserveSharing+import Symantic.Typed.Optimize+import Symantic.Typed.Reify+import Symantic.Typed.View

@@ -0,0 +1,211 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+module Symantic.Typed.Data where++import Data.Bool (Bool)+import Data.Either (Either)+import Data.Kind (Constraint, Type)+import Data.Maybe (Maybe)+import Type.Reflection (Typeable, (:~~:)(..), eqTypeRep, typeRep)+import qualified Data.Eq as Eq+import qualified Data.Maybe as Maybe+import qualified Data.Function as Fun++import Symantic.Typed.Lang+import Symantic.Typed.Derive++-- * Type 'SomeData'+data SomeData repr a =+  forall able.+  ( Derivable (Data able repr)+  , Typeable able+  ) => SomeData (Data able repr a)++type instance Derived (SomeData repr) = repr+instance Derivable (SomeData repr) where+  derive (SomeData x) = derive x++-- ** Type 'TypedRepr'+type TypedRepr = Type -> Type++-- ** Type 'Data'+-- TODO: neither data families nor data instances+-- can have phantom roles with GHC-9's RoleAnnotations,+-- hence 'Data.Coerce.coerce' cannot be used on them for now.+-- https://gitlab.haskell.org/ghc/ghc/-/issues/8177+-- https://gitlab.haskell.org/ghc/ghc/-/wikis/roles#proposal-roles-for-type-families+data family Data+  (able :: TypedRepr -> Constraint)+  :: TypedRepr -> TypedRepr+type instance Derived (Data able repr) = repr++-- | Convenient utility to pattern-match a 'SomeData'.+pattern Data :: Typeable able => Data able repr a -> SomeData repr a+pattern Data x <- (unSomeData -> Maybe.Just x)++-- | @(unSomeData c :: 'Maybe' ('Data' able repr a))@+-- extract the data-constructor from the given 'SomeData'+-- iif. it belongs to the @('Data' able repr a)@ data-instance.+unSomeData ::+  forall able repr a.+  Typeable able =>+  SomeData repr a -> Maybe (Data able repr a)+unSomeData (SomeData (c::Data c repr a)) =+  case typeRep @able `eqTypeRep` typeRep @c of+    Maybe.Just HRefl -> Maybe.Just c+    Maybe.Nothing -> Maybe.Nothing++-- Abstractable+data instance Data Abstractable repr a where+  (:@) :: SomeData repr (a->b) -> SomeData repr a -> Data Abstractable repr b+  Lam :: (SomeData repr a -> SomeData repr b) -> Data Abstractable repr (a->b)+  Lam1 :: (SomeData repr a -> SomeData repr b) -> Data Abstractable repr (a->b)+  Var :: repr a -> Data Abstractable repr a+  -- FIXME: add constructors+instance+  ( Abstractable repr+  ) => Derivable (Data Abstractable repr) where+  derive = \case+    f :@ x -> derive f .@ derive x+    Lam f -> lam (\x -> derive (f (SomeData (Var x))))+    Lam1 f -> lam1 (\x -> derive (f (SomeData (Var x))))+    Var x -> var x+instance+  ( Abstractable repr+  ) => Abstractable (SomeData repr) where+  f .@ x = SomeData (f :@ x)+  lam f = SomeData (Lam f)+  lam1 f = SomeData (Lam1 f)+  var = Fun.id+  ($) = lam1 (\f -> lam1 (\x -> f .@ x))+  (.) = lam1 (\f -> lam1 (\g -> lam1 (\x -> f .@ (g .@ x))))+  const = lam1 (\x -> lam1 (\_y -> x))+  flip = lam1 (\f -> lam1 (\x -> lam1 (\y -> f .@ y .@ x)))+  id = lam1 (\x -> x)++-- Anythingable+data instance Data Anythingable repr a where+  Anything :: repr a -> Data Anythingable repr a+instance+  ( Anythingable repr+  ) =>+  Derivable (Data Anythingable repr) where+  derive = \case+    Anything x -> anything x+instance Anythingable (SomeData repr)+instance Anythingable (Data Anythingable repr)++-- Bottomable+data instance Data Bottomable repr a where+  Bottom :: Data Bottomable repr a+instance Bottomable repr => Derivable (Data Bottomable repr) where+  derive Bottom{} = bottom++-- Constantable+data instance Data (Constantable c) repr a where+  Constant :: {-Typeable c =>-} c -> Data (Constantable c) repr c+instance Constantable c repr => Derivable (Data (Constantable c) repr) where+  derive = \case+    Constant x -> constant x+instance+  ( Constantable c repr+  , Typeable c+  ) => Constantable c (SomeData repr) where+  constant c = SomeData (Constant c)+instance {-Typeable c =>-} Constantable c (Data (Constantable c) repr) where+  constant = Constant++-- Eitherable+data instance Data Eitherable repr a where+  Left :: Data Eitherable repr (l -> Either l r)+  Right :: Data Eitherable repr (r -> Either l r)+instance Eitherable repr => Derivable (Data Eitherable repr) where+  derive = \case+    Left -> left+    Right -> right+instance+  ( Eitherable repr+  ) => Eitherable (SomeData repr) where+  left = SomeData Left+  right = SomeData Right+instance Eitherable (Data Eitherable repr) where+  left = Left+  right = Right++-- Equalable+data instance Data Equalable repr a where+  Equal :: Eq.Eq a => Data Equalable repr (a -> a -> Bool)+instance Equalable repr => Derivable (Data Equalable repr) where+  derive = \case+    Equal -> equal+instance+  ( Equalable repr+  ) => Equalable (SomeData repr) where+  equal = SomeData Equal+instance Equalable (Data Equalable repr) where+  equal = Equal++-- IfThenElseable+data instance Data IfThenElseable repr a where+  IfThenElse ::+    SomeData repr Bool ->+    SomeData repr a ->+    SomeData repr a ->+    Data IfThenElseable repr a+instance IfThenElseable repr => Derivable (Data IfThenElseable repr) where+  derive = \case+    IfThenElse test ok ko -> ifThenElse (derive test) (derive ok) (derive ko)+instance+  ( IfThenElseable repr+  ) => IfThenElseable (SomeData repr) where+  ifThenElse test ok ko = SomeData (IfThenElse test ok ko)+instance IfThenElseable repr => IfThenElseable (Data IfThenElseable repr) where+  ifThenElse test ok ko = IfThenElse (SomeData test) (SomeData ok) (SomeData ko)++-- Listable+data instance Data Listable repr a where+  Cons :: Data Listable repr (a -> [a] -> [a])+  Nil :: Data Listable repr [a]+infixr 4 `Cons`+instance Listable repr => Derivable (Data Listable repr) where+  derive = \case+    Cons -> cons+    Nil -> nil+instance+  ( Listable repr+  ) => Listable (SomeData repr) where+  cons = SomeData Cons+  nil = SomeData Nil+instance Listable (Data Listable repr) where+  cons = Cons+  nil = Nil++-- Maybeable+data instance Data Maybeable repr a where+  Nothing :: Data Maybeable repr (Maybe a)+  Just :: Data Maybeable repr (a -> Maybe a)+instance Maybeable repr => Derivable (Data Maybeable repr) where+  derive = \case+    Nothing -> nothing+    Just -> just+instance+  ( Maybeable repr+  ) => Maybeable (SomeData repr) where+  nothing = SomeData Nothing+  just = SomeData Just+instance Maybeable (Data Maybeable repr) where+  nothing = Nothing+  just = Just

@@ -0,0 +1,87 @@+{-# LANGUAGE ConstraintKinds #-} -- For type class synonyms+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DefaultSignatures #-} -- For adding LiftDerived* constraints+module Symantic.Typed.Derive where++import Data.Function ((.))+import Data.Kind (Type)++-- * Type family 'Derived'+-- | The representation that @(repr)@ derives to.+type family Derived (repr :: Type -> Type) :: Type -> Type++-- * Class 'Derivable'+-- | Derivable an interpreter to a another interpreter+-- determined by the 'Derived' open type family.+-- This is mostly useful when running the interpreter stack,+-- but also when going back from an initial encoding to a final one.+--+-- Note that 'derive' and 'liftDerived' are not necessarily reciprocical functions.+class Derivable repr where+  derive :: repr a -> Derived repr a++-- * Class 'LiftDerived'+-- | Lift the 'Derived' interpreter of an interpreter, to that interpreter.+-- This is mostly useful to give default values to class methods+-- in order to skip their definition for interpreters+-- where 'liftDerived' can already apply the right semantic.+--+-- Note that 'derive' and 'liftDerived' are not necessarily reciprocical functions.+class LiftDerived repr where+  liftDerived :: Derived repr a -> repr a++-- * Class 'LiftDerived1'+-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with a single argument.+class LiftDerived1 repr where+  liftDerived1 ::+    (Derived repr a -> Derived repr b) ->+    repr a -> repr b+  liftDerived1 f = liftDerived . f . derive+  default liftDerived1 ::+    LiftDerived repr => Derivable repr =>+    (Derived repr a -> Derived repr b) ->+    repr a -> repr b++-- * Class 'LiftDerived2'+-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with two arguments.+class LiftDerived2 repr where+  liftDerived2 ::+    (Derived repr a -> Derived repr b -> Derived repr c) ->+    repr a -> repr b -> repr c+  liftDerived2 f a b = liftDerived (f (derive a) (derive b))+  default liftDerived2 ::+    LiftDerived repr => Derivable repr =>+    (Derived repr a -> Derived repr b -> Derived repr c) ->+    repr a -> repr b -> repr c++-- * Class 'LiftDerived3'+-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with three arguments.+class LiftDerived3 repr where+  liftDerived3 ::+    (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d) ->+    repr a -> repr b -> repr c -> repr d+  liftDerived3 f a b c = liftDerived (f (derive a) (derive b) (derive c))+  default liftDerived3 ::+    LiftDerived repr => Derivable repr =>+    (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d) ->+    repr a -> repr b -> repr c -> repr d++-- * Class 'LiftDerived4'+-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with three arguments.+class LiftDerived4 repr where+  liftDerived4 ::+    (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d -> Derived repr e) ->+    repr a -> repr b -> repr c -> repr d -> repr e+  liftDerived4 f a b c d = liftDerived (f (derive a) (derive b) (derive c) (derive d))+  default liftDerived4 ::+    LiftDerived repr => Derivable repr =>+    (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d -> Derived repr e) ->+    repr a -> repr b -> repr c -> repr d -> repr e++-- * Type synonyms @FromDerived*@+-- | Convenient type synonym for using 'liftDerived' on symantic class @(sym)@.+type FromDerived  sym repr = ( LiftDerived  repr, sym (Derived repr) )+type FromDerived1 sym repr = ( LiftDerived1 repr, sym (Derived repr) )+type FromDerived2 sym repr = ( LiftDerived2 repr, sym (Derived repr) )+type FromDerived3 sym repr = ( LiftDerived3 repr, sym (Derived repr) )+type FromDerived4 sym repr = ( LiftDerived4 repr, sym (Derived repr) )

@@ -0,0 +1,115 @@+module Symantic.Typed.Fixity where++import Data.Bool+import Data.Eq (Eq(..))+import Data.Function ((.))+import Data.Int (Int)+import Data.Maybe (Maybe(..))+import Data.Ord (Ord(..))+import Data.Semigroup+import Data.String (String, IsString(..))+import Text.Show (Show(..))++-- * Type 'Fixity'+data Fixity+ =   Fixity1 Unifix+ |   Fixity2 Infix+ deriving (Eq, Show)++-- ** Type 'Unifix'+data Unifix+ =   Prefix  { unifix_precedence :: Precedence }+ |   Postfix { unifix_precedence :: Precedence }+ deriving (Eq, Show)++-- ** Type 'Infix'+data Infix+ =   Infix+ {   infix_associativity :: Maybe Associativity+ ,   infix_precedence    :: Precedence+ } deriving (Eq, Show)++infixL :: Precedence -> Infix+infixL = Infix (Just AssocL)++infixR :: Precedence -> Infix+infixR = Infix (Just AssocR)++infixB :: Side -> Precedence -> Infix+infixB = Infix . Just . AssocB++infixN :: Precedence -> Infix+infixN = Infix Nothing++infixN0 :: Infix+infixN0 = infixN 0++infixN5 :: Infix+infixN5 = infixN 5++-- | Given 'Precedence' and 'Associativity' of its parent operator,+-- and the operand 'Side' it is in,+-- return whether an 'Infix' operator+-- needs to be enclosed by a 'Pair'.+isPairNeeded :: (Infix, Side) -> Infix -> Bool+isPairNeeded (po, lr) op =+  infix_precedence op < infix_precedence po+  || infix_precedence op == infix_precedence po+  && not associate+  where+  associate =+    case (lr, infix_associativity po) of+     (_, Just AssocB{})   -> True+     (SideL, Just AssocL) -> True+     (SideR, Just AssocR) -> True+     _ -> False++-- | If 'isPairNeeded' is 'True',+-- enclose the given 'IsString' by given 'Pair',+-- otherwise returns the same 'IsString'.+pairIfNeeded ::+ Semigroup s => IsString s =>+ Pair -> (Infix, Side) -> Infix ->+ s -> s+pairIfNeeded (o,c) po op s =+  if isPairNeeded po op+  then fromString o <> s <> fromString c+  else s++-- * Type 'Precedence'+type Precedence = Int++-- ** Class 'PrecedenceOf'+class PrecedenceOf a where+  precedence :: a -> Precedence+instance PrecedenceOf Fixity where+  precedence (Fixity1 uni) = precedence uni+  precedence (Fixity2 inf) = precedence inf+instance PrecedenceOf Unifix where+  precedence = unifix_precedence+instance PrecedenceOf Infix where+  precedence = infix_precedence++-- * Type 'Associativity'+data Associativity+ =   AssocL      -- ^ Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@+ |   AssocR      -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@+ |   AssocB Side -- ^ Associate to both sides, but to 'Side' when reading.+ deriving (Eq, Show)++-- ** Type 'Side'+data Side+ =   SideL -- ^ Left+ |   SideR -- ^ Right+ deriving (Eq, Show)++-- ** Type 'Pair'+type Pair = (String, String)+pairAngle   :: Pair+pairBrace   :: Pair+pairBracket :: Pair+pairParen   :: Pair+pairAngle   = ("<",">")+pairBrace   = ("{","}")+pairBracket = ("[","]")+pairParen   = ("(",")")

@@ -0,0 +1,154 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Symantic.Typed.Lang where++import Data.Char (Char)+import Data.Bool (Bool(..))+import Data.Either (Either(..))+import Data.Eq (Eq)+import Data.Maybe (Maybe(..))+import qualified Data.Function as Fun++import Symantic.Typed.Derive++-- * Class 'Abstractable'+class Abstractable repr where+  -- | Application, aka. unabstract.+  (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@+  -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.+  lam :: (repr a -> repr b) -> repr (a->b)+  -- | Like 'lam' but whose argument is used only once,+  -- hence safe to beta-reduce (inline) without duplicating work.+  lam1 :: (repr a -> repr b) -> repr (a->b)+  const :: repr (a -> b -> a)+  flip :: repr ((a -> b -> c) -> b -> a -> c)+  id :: repr (a->a)+  (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .+  ($) :: repr ((a->b) -> a -> b); infixr 0 $+  var :: repr a -> repr a+  (.@) = liftDerived2 (.@)+  lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))+  lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))+  const = liftDerived const+  flip = liftDerived flip+  id = liftDerived id+  (.) = liftDerived (.)+  ($) = liftDerived ($)+  var = liftDerived1 var+  default (.@) ::+    FromDerived2 Abstractable repr =>+    repr (a->b) -> repr a -> repr b+  default lam ::+    FromDerived Abstractable repr => Derivable repr =>+    (repr a -> repr b) -> repr (a->b)+  default lam1 ::+    FromDerived Abstractable repr => Derivable repr =>+    (repr a -> repr b) -> repr (a->b)+  default const ::+    FromDerived Abstractable repr =>+    repr (a -> b -> a)+  default flip ::+    FromDerived Abstractable repr =>+    repr ((a -> b -> c) -> b -> a -> c)+  default id ::+    FromDerived Abstractable repr =>+    repr (a->a)+  default (.) ::+    FromDerived Abstractable repr =>+    repr ((b->c) -> (a->b) -> a -> c)+  default ($) ::+    FromDerived Abstractable repr =>+    repr ((a->b) -> a -> b)+  default var ::+    FromDerived1 Abstractable repr =>+    repr a -> repr a++-- * Class 'Anythingable'+class Anythingable repr where+  anything :: repr a -> repr a+  anything = Fun.id++-- * Class 'Bottomable'+class Bottomable repr where+  bottom :: repr a++-- * Class 'Constantable'+class Constantable c repr where+  constant :: c -> repr c+  constant = liftDerived Fun.. constant+  default constant ::+    FromDerived (Constantable c) repr =>+    c -> repr c++bool :: Constantable Bool repr => Bool -> repr Bool+bool = constant @Bool+char :: Constantable Char repr => Char -> repr Char+char = constant @Char+unit :: Constantable () repr => repr ()+unit = constant @() ()++-- * Class 'Eitherable'+class Eitherable repr where+  left :: repr (l -> Either l r)+  right :: repr (r -> Either l r)+  left = liftDerived left+  right = liftDerived right+  default left ::+    FromDerived Eitherable repr =>+    repr (l -> Either l r)+  default right ::+    FromDerived Eitherable repr =>+    repr (r -> Either l r)++-- * Class 'Equalable'+class Equalable repr where+  equal :: Eq a => repr (a -> a -> Bool)+  equal = liftDerived equal+  default equal ::+    FromDerived Equalable repr =>+    Eq a => repr (a -> a -> Bool)++infix 4 `equal`, ==+(==) :: (Abstractable repr, Equalable repr, Eq a) => repr (a -> a -> Bool)+(==) = lam (\x -> lam (\y -> equal .@ x .@ y))++-- * Class 'IfThenElseable'+class IfThenElseable repr where+  ifThenElse :: repr Bool -> repr a -> repr a -> repr a+  ifThenElse = liftDerived3 ifThenElse+  default ifThenElse ::+    FromDerived3 IfThenElseable repr =>+    repr Bool -> repr a -> repr a -> repr a++-- * Class 'Listable'+class Listable repr where+  cons :: repr (a -> [a] -> [a])+  nil :: repr [a]+  cons = liftDerived cons+  nil = liftDerived nil+  default cons ::+    FromDerived Listable repr =>+    repr (a -> [a] -> [a])+  default nil ::+    FromDerived Listable repr =>+    repr [a]++-- * Class 'Maybeable'+class Maybeable repr where+  nothing :: repr (Maybe a)+  just :: repr (a -> Maybe a)+  nothing = liftDerived nothing+  just = liftDerived just+  default nothing ::+    FromDerived Maybeable repr =>+    repr (Maybe a)+  default just ::+    FromDerived Maybeable repr =>+    repr (a -> Maybe a)

@@ -0,0 +1,330 @@+{-# LANGUAGE AllowAmbiguousTypes #-} -- For ShowLetName+{-# LANGUAGE BangPatterns #-} -- For makeSharingName+{-# LANGUAGE DataKinds #-} -- For ShowLetName+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ExistentialQuantification #-} -- For SharingName+-- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#+module Symantic.Typed.ObserveSharing where++import Control.Applicative (Applicative(..))+import Control.Monad (Monad(..))+import Data.Bool (Bool(..))+import Data.Eq (Eq(..))+import Data.Foldable (foldMap)+import Data.Function (($), (.))+import Data.Functor ((<$>))+import Data.Functor.Compose (Compose(..))+import Data.HashMap.Strict (HashMap)+import Data.HashSet (HashSet)+import Data.Hashable (Hashable, hashWithSalt, hash)+import Data.Int (Int)+import Data.Maybe (Maybe(..), isNothing)+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.String (String)+-- import GHC.Exts (Int(..))+-- import GHC.Prim (unsafeCoerce#)+import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)+-- import Numeric (showHex)+import Prelude ((+), error)+import System.IO (IO)+import System.IO.Unsafe (unsafePerformIO)+import Text.Show (Show(..))+import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.Reader as MT+import qualified Control.Monad.Trans.State as MT+import qualified Control.Monad.Trans.Writer as MT+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS++import Symantic.Typed.Derive++-- * Class 'Letable'+-- | This class is not for end-users like usual symantic operators,+-- here 'shareable' and 'ref' are introduced by 'observeSharing'.+class Letable letName repr where+  -- | @('ref' isRec letName)@ is a reference to @(letName)@.+  -- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,+  -- ie. is reachable within its 'shareable' definition.+  ref :: Bool -> letName -> repr a+  ref isRec n = liftDerived (ref isRec n)+  default ref ::+    FromDerived (Letable letName) repr =>+    Bool -> letName -> repr a++  -- | @('shareable' letName x)@ let-binds @(letName)@ to be equal to @(x)@.+  shareable :: letName -> repr a -> repr a+  shareable n = liftDerived1 (shareable n)+  default shareable ::+    FromDerived1 (Letable letName) repr =>+    letName -> repr a -> repr a++-- * Class 'MakeLetName'+class MakeLetName letName where+  makeLetName :: SharingName -> IO letName++-- ** Type 'ShowLetName'+-- | Useful on golden unit tests because 'StableName'+-- change often when changing unrelated source code+-- or even changing basic GHC or executable flags.+class ShowLetName (showName::Bool) letName where+  showLetName :: letName -> String+-- | Like 'Show'.+instance Show letName => ShowLetName 'True letName where+  showLetName = show+-- | Always return @"<hidden>"@,+instance ShowLetName 'False letName where+  showLetName _p = "<hidden>"++-- * Type 'SharingName'+-- | Note that the observable sharing enabled by 'StableName'+-- is not perfect as it will not observe all the sharing explicitely done.+--+-- Note also that the observed sharing could be different between ghc and ghci.+data SharingName = forall a. SharingName (StableName a)+-- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces+-- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,+-- which avoids to produce a tree bigger than needed.+--+-- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',+-- this is apparently required to avoid infinite loops due to unstable 'StableName'+-- in compiled code, and sometimes also in ghci.+--+-- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).+makeSharingName :: a -> SharingName+makeSharingName !x = SharingName $ unsafePerformIO $ makeStableName x++instance Eq SharingName where+  SharingName x == SharingName y = eqStableName x y+instance Hashable SharingName where+  hash (SharingName n) = hashStableName n+  hashWithSalt salt (SharingName n) = hashWithSalt salt n+{-+instance Show SharingName where+  showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))+-}++-- * Type 'ObserveSharing'+newtype ObserveSharing letName repr a = ObserveSharing { unObserveSharing ::+  MT.ReaderT (HashSet SharingName)+             (MT.State (ObserveSharingState letName))+             (FinalizeSharing letName repr a) }++-- | Interpreter detecting some (Haskell embedded) @let@ definitions used at+-- least once and/or recursively, in order to replace them+-- with the 'shareable' and 'ref' combinators.+-- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)+--+-- Beware not to apply 'observeSharing' more than once on the same term+-- otherwise some 'shareable' introduced by the first call+-- would be removed by the second call.+observeSharing ::+  Eq letName =>+  Hashable letName =>+  Show letName =>+  ObserveSharing letName repr a ->+  WithSharing letName repr a+observeSharing (ObserveSharing m) =+  let (fs, st) = MT.runReaderT m mempty `MT.runState`+        ObserveSharingState+          { oss_refs = HM.empty+          , oss_recs = HS.empty+          } in+  let refs = HS.fromList $+        (`foldMap` oss_refs st) $ (\(letName, refCount) ->+          if refCount > 0 then [letName] else []) in+  --trace (show refs) $+  MT.runWriter $+    (`MT.runReaderT` refs) $+      unFinalizeSharing fs++-- ** Type 'SomeLet'+data SomeLet repr = forall a. SomeLet (repr a)++-- ** Type 'WithSharing'+type WithSharing letName repr a =+  (repr a, HM.HashMap letName (SomeLet repr))+{-+-- * Type 'WithSharing'+data WithSharing letName repr a = WithSharing+  { lets :: HM.HashMap letName (SomeLet repr)+  , body :: repr a+  }+mapWithSharing ::+  (forall v. repr v -> repr v) ->+  WithSharing letName repr a ->+  WithSharing letName repr a+mapWithSharing f ws = WithSharing+  { lets = (\(SomeLet repr) -> SomeLet (f repr)) <$> lets ws+  , body = f (body ws)+  }+-}++-- ** Type 'ObserveSharingState'+data ObserveSharingState letName = ObserveSharingState+  { oss_refs :: HashMap SharingName (letName, Int)+  , oss_recs :: HashSet SharingName+    -- ^ TODO: unused so far, will it be useful somewhere at a later stage?+  }++observeSharingNode ::+  Eq letName =>+  Hashable letName =>+  Show letName =>+  Letable letName repr =>+  MakeLetName letName =>+  ObserveSharing letName repr a ->+  ObserveSharing letName repr a+observeSharingNode (ObserveSharing m) = ObserveSharing $ do+  let nodeName = makeSharingName m+  st <- MT.lift MT.get+  ((letName, before), preds) <- getCompose $ HM.alterF (\before ->+    Compose $ case before of+      Nothing -> do+        let letName = unsafePerformIO $ makeLetName nodeName+        return ((letName, before), Just (letName, 0))+      Just (letName, refCount) -> do+        return ((letName, before), Just (letName, refCount + 1))+    ) nodeName (oss_refs st)+  parentNames <- MT.ask+  if nodeName `HS.member` parentNames+  then do+    MT.lift $ MT.put st+      { oss_refs = preds+      , oss_recs = HS.insert nodeName (oss_recs st)+      }+    return $ ref True letName+  else do+    MT.lift $ MT.put st{ oss_refs = preds }+    if isNothing before+      then MT.local (HS.insert nodeName) (shareable letName <$> m)+      else return $ ref False letName++type instance Derived (ObserveSharing letName repr) = FinalizeSharing letName repr+instance+  ( Letable letName repr+  , MakeLetName letName+  , Eq letName+  , Hashable letName+  , Show letName+  ) => LiftDerived (ObserveSharing letName repr) where+  liftDerived = observeSharingNode . ObserveSharing . return+instance+  ( Letable letName repr+  , MakeLetName letName+  , Eq letName+  , Hashable letName+  , Show letName+  ) => LiftDerived1 (ObserveSharing letName repr) where+  liftDerived1 f x = observeSharingNode $ ObserveSharing $+    f <$> unObserveSharing x+instance+  ( Letable letName repr+  , MakeLetName letName+  , Eq letName+  , Hashable letName+  , Show letName+  ) => LiftDerived2 (ObserveSharing letName repr) where+  liftDerived2 f x y = observeSharingNode $ ObserveSharing $+    f <$> unObserveSharing x+      <*> unObserveSharing y+instance+  ( Letable letName repr+  , MakeLetName letName+  , Eq letName+  , Hashable letName+  , Show letName+  ) => LiftDerived3 (ObserveSharing letName repr) where+  liftDerived3 f x y z = observeSharingNode $ ObserveSharing $+    f <$> unObserveSharing x+      <*> unObserveSharing y+      <*> unObserveSharing z+instance Letable letName (ObserveSharing letName repr) where+  shareable = error "[BUG]: observeSharing MUST NOT be applied twice"+  ref = error "[BUG]: observeSharing MUST NOT be applied twice"+instance Letsable letName (ObserveSharing letName repr) where+  lets = error "[BUG]: observeSharing MUST NOT be applied twice"++-- * Type 'FinalizeSharing'+-- | Remove 'shareable' when non-recursive or unused+-- or replace it by 'ref', moving 'shareable's to the top.+newtype FinalizeSharing letName repr a = FinalizeSharing { unFinalizeSharing ::+  MT.ReaderT (HS.HashSet letName)+    (MT.Writer (LetBindings letName repr))+      (repr a) }++-- ** Type 'LetBindings'+type LetBindings letName repr = HM.HashMap letName (SomeLet repr)++type instance Derived (FinalizeSharing _letName repr) = repr+instance+  ( Eq letName+  , Hashable letName+  ) => LiftDerived (FinalizeSharing letName repr) where+  liftDerived = FinalizeSharing . pure+instance+  ( Eq letName+  , Hashable letName+  ) => LiftDerived1 (FinalizeSharing letName repr) where+  liftDerived1 f x = FinalizeSharing $ f <$> unFinalizeSharing x+instance+  ( Eq letName+  , Hashable letName+  ) => LiftDerived2 (FinalizeSharing letName repr) where+  liftDerived2 f x y = FinalizeSharing $+    f <$> unFinalizeSharing x+      <*> unFinalizeSharing y+instance+  ( Eq letName+  , Hashable letName+  ) => LiftDerived3 (FinalizeSharing letName repr) where+  liftDerived3 f x y z = FinalizeSharing $+    f <$> unFinalizeSharing x+      <*> unFinalizeSharing y+      <*> unFinalizeSharing z+instance+  ( Letable letName repr+  , Eq letName+  , Hashable letName+  , Show letName+  ) => Letable letName (FinalizeSharing letName repr) where+  shareable name x = FinalizeSharing $ do+    refs <- MT.ask+    if name `HS.member` refs+      -- This 'shareable' is 'ref'erenced, move it into the result,+      -- to put it in scope even when some 'ref' to it exists outside of 'x'+      -- (which can happen when a sub-expression is shared),+      -- and replace it by a 'ref'.+      then do+        let (repr, defs) = MT.runWriter $ MT.runReaderT (unFinalizeSharing x) refs+        MT.lift $ MT.tell $ HM.insert name (SomeLet repr) defs+        return $ ref False name+      -- Remove 'shareable'.+      else+        unFinalizeSharing x++-- * Class 'Letsable'+class Letsable letName repr where+  -- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.+  lets :: LetBindings letName repr -> repr a -> repr a+  lets defs = liftDerived1 (lets ((\(SomeLet val) -> SomeLet (derive val)) <$> defs))+  default lets ::+    Derivable repr =>+    FromDerived1 (Letsable letName) repr =>+    LetBindings letName repr -> repr a -> repr a+{-+-- | Not used but can be written nonetheless.+instance+  ( Letsable letName repr+  , Eq letName+  , Hashable letName+  , Show letName+  ) => Letsable letName (FinalizeSharing letName repr) where+  lets defs x = FinalizeSharing $ do+    ds <- traverse (\(SomeLet v) -> do+      r <- unFinalizeSharing v+      return (SomeLet r)+      ) defs+    MT.lift $ MT.tell ds+    unFinalizeSharing x+-}

@@ -0,0 +1,41 @@+module Symantic.Typed.Optimize where++import Data.Bool (Bool)+import qualified Data.Function as Fun++import Symantic.Typed.Lang+import Symantic.Typed.Data++-- | Beta-reduce the left-most outer-most lambda abstraction (aka. normal-order reduction),+-- but to avoid duplication of work, only those manually marked+-- as using their variable at most once.+--+-- DOC: Demonstrating Lambda Calculus Reduction, Peter Sestoft, 2001,+-- https://www.itu.dk/people/sestoft/papers/sestoft-lamreduce.pdf+normalOrderReduction :: forall repr a.+  Abstractable repr =>+  IfThenElseable repr =>+  SomeData repr a -> SomeData repr a+normalOrderReduction = nor+  where+  -- | normal-order reduction+  nor :: SomeData repr b -> SomeData repr b+  nor = \case+    Data (Lam f) -> lam (nor Fun.. f)+    Data (Lam1 f) -> lam1 (nor Fun.. f)+    Data (x :@ y) -> case whnf x of+      Data (Lam1 f) -> nor (f y)+      x' -> nor x' .@ nor y+    Data (IfThenElse test ok ko) ->+      case nor test of+        Data (Constant b :: Data (Constantable Bool) repr Bool) ->+          if b then nor ok else nor ko+        t -> ifThenElse (nor t) (nor ok) (nor ko)+    x -> x+  -- | weak-head normal-form+  whnf :: SomeData repr b -> SomeData repr b+  whnf = \case+    Data (x :@ y) -> case whnf x of+      Data (Lam1 f) -> whnf (f y)+      x' -> x' .@ y+    x -> x

@@ -0,0 +1,68 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- For reifyTH+-- | Reify an Haskell value using type-directed normalisation-by-evaluation (NBE).+module Symantic.Typed.Reify where++import Control.Monad (Monad(..))+import qualified Data.Function as Fun+import qualified Language.Haskell.TH as TH++import Symantic.Typed.Lang (Abstractable(..))++-- | 'ReifyReflect' witnesses the duality between @meta@ and @(repr a)@.+--  It indicates which type variables in @a@ are not to be instantiated+--  with the arrow type, and instantiates them to @(repr _)@ in @meta@.+--  This is directly taken from: http://okmij.org/ftp/tagless-final/course/TDPE.hs+--+-- * @meta@ instantiates polymorphic types of the original Haskell expression+--   with @(repr _)@ types, according to how 'ReifyReflect' is constructed+--   using 'base' and @('-->')@. This is obviously not possible+--   if the orignal expression uses monomorphic types (like 'Int'),+--   but remains possible with constrained polymorphic types (like @(Num i => i)@),+--   because @(i)@ can still be inferred to @(repr _)@,+--   whereas the finally chosen @(repr)@+--   (eg. 'E', or 'Identity', or 'TH.CodeQ', or ...)+--   can have a 'Num' instance.+-- * @(repr a)@ is the symantic type as it would have been,+--   had the expression been written with explicit 'lam's+--   instead of bare haskell functions.+-- DOC: http://okmij.org/ftp/tagless-final/cookbook.html#TDPE+-- DOC: http://okmij.org/ftp/tagless-final/NBE.html+-- DOC: https://www.dicosmo.org/Articles/2004-BalatDiCosmoFiore-Popl.pdf+data ReifyReflect repr meta a = ReifyReflect+  { -- | 'reflect' converts from a *represented* Haskell term of type @a@+    -- to an object *representing* that value of type @a@.+    reify   :: meta -> repr a+    -- | 'reflect' converts back an object *representing* a value of type @a@,+    -- to the *represented* Haskell term of type @a@.+  , reflect :: repr a -> meta+  }++-- | The base of induction : placeholder for a type which is not the arrow type.+base :: ReifyReflect repr (repr a) a+base = ReifyReflect{reify = Fun.id, reflect = Fun.id}++-- | The inductive case : the arrow type.+-- 'reify' and 'reflect' are built together inductively.+infixr 8 -->+(-->) :: Abstractable repr =>+         ReifyReflect repr m1 o1 -> ReifyReflect repr m2 o2 ->+         ReifyReflect repr (m1 -> m2) (o1 -> o2)+r1 --> r2 = ReifyReflect+  { reify   = \meta -> lam (reify r2 Fun.. meta Fun.. reflect r1)+  , reflect = \repr -> reflect r2 Fun.. (.@) repr Fun.. reify r1+  }++-- * Using TemplateHaskell to fully auto-generate 'ReifyReflect'++-- | @$(reifyTH 'Foo.bar)@ calls 'reify' on 'Foo.bar'+-- with an 'ReifyReflect' generated from the infered type of 'Foo.bar'.+reifyTH :: TH.Name -> TH.Q TH.Exp+reifyTH name = do+  info <- TH.reify name+  case info of+    TH.VarI n (TH.ForallT _vs _ctx ty) _dec ->+      [| reify $(genReifyReflect ty) $(return (TH.VarE n)) |]+    where+    genReifyReflect (TH.AppT (TH.AppT TH.ArrowT a) b) = [| $(genReifyReflect a) --> $(genReifyReflect b) |]+    genReifyReflect TH.VarT{} = [| base |]

@@ -0,0 +1,116 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitPrelude #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- For Show (SomeData a)+module Symantic.Typed.View where++import Data.Int (Int)+import Data.String+import Text.Show+import qualified Data.Function as Fun+import qualified Prelude++import Symantic.Typed.Fixity+import Symantic.Typed.Lang+import Symantic.Typed.Data+import Symantic.Typed.Derive++data View a where+  View :: (ViewEnv -> ShowS) -> View a+  ViewUnifix :: Unifix -> String -> String -> View (a -> b)+  ViewInfix :: Infix -> String -> String -> View (a -> b -> c)+  ViewApp :: View (b -> a) -> View b -> View a++runView :: View a -> ViewEnv -> ShowS+runView (View v) env = v env+runView (ViewInfix _op name _infixName) _env = showString name+runView (ViewUnifix _op name _unifixName) _env = showString name+runView (ViewApp f x) env =+  pairView env op Fun.$+    runView f env{viewEnv_op = (op, SideL) } Fun..+    showString " " Fun..+    runView x env{viewEnv_op = (op, SideR) }+  where op = infixN 10++-- | Unusual, but enables to leverage default definition of methods.+type instance Derived View = View+instance LiftDerived View where+  liftDerived = Fun.id++instance IsString (View a) where+  fromString s = View Fun.$ \_env -> showString s+instance Show (View a) where+  showsPrec p = (`runView` ViewEnv+    { viewEnv_op = (infixN p, SideL)+    , viewEnv_pair = pairParen+    , viewEnv_lamDepth = 1+    })+instance Show (SomeData View a) where+  showsPrec p (SomeData x) = showsPrec p (derive x :: View a)++data ViewEnv+  = ViewEnv+  { viewEnv_op :: (Infix, Side)+  , viewEnv_pair :: Pair+  , viewEnv_lamDepth :: Int+  }++pairView :: ViewEnv -> Infix -> ShowS -> ShowS+pairView env op s =+  if isPairNeeded (viewEnv_op env) op+  then showString o Fun.. s Fun.. showString c+  else s+  where (o,c) = viewEnv_pair env++instance Abstractable View where+  var = Fun.id+  lam f = viewLam "x" f+  lam1 f = viewLam "u" f+  ViewInfix op _name infixName .@ ViewApp x y = View Fun.$ \env ->+    pairView env op Fun.$+      runView x env{viewEnv_op=(op, SideL)} Fun..+      showString " " Fun.. showString infixName Fun.. showString " " Fun..+      runView y env{viewEnv_op=(op, SideR)}+  ViewInfix op name _infixName .@ x = View Fun.$ \env ->+    showParen Prelude.True Fun.$+      runView x env{viewEnv_op=(op, SideL)} Fun..+      showString " " Fun.. showString name+  f .@ x = ViewApp f x+viewLam :: String -> (View a -> View b) -> View (a -> b)+viewLam varPrefix f = View Fun.$ \env ->+  pairView env op Fun.$+    let x = showString varPrefix Fun..+            showsPrec 0 (viewEnv_lamDepth env) in+    -- showString "Lam1 (" .+    showString "\\" Fun.. x Fun.. showString " -> " Fun..+    runView (f (View (\_env -> x))) env+      { viewEnv_op = (op, SideL)+      , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)+      }+    -- . showString ")"+  where+  op = infixN 0+instance Anythingable View+instance Bottomable View where+  bottom = "<hidden>"+instance Show c => Constantable c View where+  constant c = View Fun.$ \_env -> shows c+instance Eitherable View where+  left = "Left"+  right = "Right"+instance Equalable View where+  equal = ViewInfix (infixN 4) "(==)" "=="+instance Listable View where+  cons = ViewInfix (infixR 5) "(:)" ":"+  nil = "[]"+instance Maybeable View where+  nothing = "Nothing"+  just = "Just"

@@ -1,1 +0,0 @@-resolver: lts-15.4

@@ -1,12 +0,0 @@-# This file was autogenerated by Stack.-# You should not edit this file by hand.-# For more information, please see the documentation at:-#   https://docs.haskellstack.org/en/stable/lock_files--packages: []-snapshots:-- completed:-    size: 491163-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/4.yaml-    sha256: bc60043a06b58902b533baa80fb566c0ec495c41e428bc0f8c1e8c15b2a4c468-  original: lts-15.4

@@ -1,43 +1,93 @@+cabal-version: 3.0+license: AGPL-3.0-or-later name: symantic-base -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 0.0.2.20200708+version: 0.1.0.20210703 category: Data Structures-synopsis: Basic symantics for writing Embedded Domain-Specific Languages (EDSL).-description: A collection of basic tagless-final combinators.-extra-doc-files:-license: GPL-3-license-file: COPYING+synopsis: Commonly useful symantics for Embedded Domain-Specific Languages (EDSL)+description:+  This is a work-in-progress collection of basic tagless-final combinators,+  along with some advanced utilities to exploit them.++  * @Symantic.Typed@+    is for combinators indexed by a single type.+  * @Symantic.Dityped@+    is for combinators indexed by an extensible function type,+    used for typed formatting, enabling type safe dual interpreters à la printf and scanf.+    Inspired by Oleg Kiselyov's [PrintScanF.hs](http://okmij.org/ftp/tagless-final/course/PrintScanF.hs).+    For an example, see [symantic-http](https://hackage.haskell.org/package/symantic-http).+  * @Symantic.{Typed,Dityped}.Lang@+    gather commonly used tagless-final combinators+    (the syntax part of symantics).+  * @Symantic.Typed.Data@ is an interpreter enabling to pattern-match on combinators,+    while keeping their extensibility.+  * @Symantic.{Typed,Dityped}.Derive@+    enable to give a default value to combinators which avoids boilerplate code+    when implementing combinators for an interpreter is factorizable.+  * @Symantic.Typed.ObserveSharing@+    enables to observe Haskell @let@ definitions,+    turning infinite values into finite ones,+    which is useful to inspect and optimize recursive grammars for example.+    Inspired by Andy Gill's [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653).+    For an example, see [symantic-parser](https://hackage.haskell.org/package/symantic-parser).+  * @Symantic.Typed.Reify@+    enables the lifting to any interpreter+    of any Haskell functions taking as arguments+    only polymorphic types (possibly constrained)+    or functions using such types.+    Inspired by Oleg Kiselyov's [TDPE.hs](http://okmij.org/ftp/tagless-final/course/TDPE.hs).+  * @Symantic.Typed.View@+    is an interpreter enabling to turn combinators into a human-readable string.+  * @Symantic.Dityped.ADT@+    enables to define formats à la printf-scanf+    using data-constructors instead of @Either@s of tuples.+    For an example, see [symantic-atom](https://hackage.haskell.org/package/symantic-atom).+  * @Symantic.Dityped.CurryN@+    gather utilities for currying or uncurrying tuples+    of size greater or equal to 2.+  * @Symantic.Typed.Fixity@+    gathers utilities for parsing or viewing+    infix, prefix and postfix combinators. stability: experimental-author:      Julien Moutinho <julm+symantic-base@sourcephile.fr>-maintainer:  Julien Moutinho <julm+symantic-base@sourcephile.fr>-bug-reports: Julien Moutinho <julm+symantic-base@sourcephile.fr>--- homepage:+author: Julien Moutinho <julm+symantic-base@sourcephile.fr>+maintainer: Julien Moutinho <julm+symantic-base@sourcephile.fr>+bug-reports: https://mails.sourcephile.fr/inbox/symantic-base+copyright: Julien Moutinho <julm+symantic-base@sourcephile.fr>  build-type: Simple-cabal-version: 1.24-tested-with: GHC==8.8.3+tested-with: GHC==8.10.4 extra-source-files:-  stack.yaml-  stack.yaml.lock+  cabal.project+  default.nix+  .envrc+  flake.lock+  flake.nix+  Makefile extra-tmp-files: -Source-Repository head+source-repository head+  type: git   location: git://git.sourcephile.fr/haskell/symantic-base-  type:     git -Library+library   hs-source-dirs: src   exposed-modules:-    Symantic.Base-    Symantic.Base.ADT-    Symantic.Base.Algebrable-    Symantic.Base.Composable-    Symantic.Base.CurryN-    Symantic.Base.Fixity-    Symantic.Base.Permutable-    Symantic.Base.Routable+    Symantic.Dityped+    Symantic.Dityped.ADT+    Symantic.Dityped.CurryN+    Symantic.Dityped.Derive+    Symantic.Dityped.Lang+    Symantic.Typed+    Symantic.Typed.Data+    Symantic.Typed.Derive+    Symantic.Typed.Fixity+    Symantic.Typed.Lang+    Symantic.Typed.ObserveSharing+    Symantic.Typed.Optimize+    Symantic.Typed.Reify+    Symantic.Typed.View   default-language: Haskell2010   default-extensions:     DefaultSignatures@@ -58,6 +108,12 @@     -Wall     -Wincomplete-uni-patterns     -Wincomplete-record-updates-    -- -fhide-source-paths+    -Wpartial-fields+    -fprint-potential-instances   build-depends:-      base >= 4.10 && < 5+      base >= 4.10 && < 5,+      containers,+      hashable,+      template-haskell,+      transformers,+      unordered-containers