diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for ema-generics + +## 0.10.0.0 (2022-11-20) + +- Split from `ema` package diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU Affero General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero General Public License from time to time. Such new versions +will be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU Affero General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU Affero General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU Affero General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU AGPL, see +. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# ema-generics + +Generic deriving for Ema routes: https://ema.srid.ca/guide/route/generic diff --git a/ema-generics.cabal b/ema-generics.cabal new file mode 100644 --- /dev/null +++ b/ema-generics.cabal @@ -0,0 +1,129 @@ +cabal-version: 2.4 +name: ema-generics +version: 0.10.0.0 +license: AGPL-3.0-only +copyright: 2022 Sridhar Ratnakumar +maintainer: srid@srid.ca +author: Sridhar Ratnakumar +category: Web +synopsis: Generic deriving for Ema routes +bug-reports: https://github.com/srid/ema/issues +homepage: https://ema.srid.ca/ +description: Generic deriving for Ema routes +extra-source-files: + CHANGELOG.md + LICENSE + README.md + +common extensions + default-extensions: + NoStarIsType + BangPatterns + ConstraintKinds + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + EmptyCase + EmptyDataDecls + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTSyntax + GeneralisedNewtypeDeriving + ImportQualifiedPost + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NumericUnderscores + OverloadedStrings + PolyKinds + PostfixOperators + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + +library + import: extensions + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: + , base >=4.13.0.0 && <4.17.0.0.0 + , ema + , generic-optics + , generics-sop + , optics-core + , relude >=1.0 + , sop-core + , template-haskell + + mixins: + base hiding (Prelude), + relude (Relude as Prelude, Relude.Container.One), + relude + + ghc-options: + -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns + -Wmissing-deriving-strategies -Wunused-foralls -Wunused-foralls + -fprint-explicit-foralls -fprint-explicit-kinds + -fprint-potential-instances + + exposed-modules: + Ema.Route.Generic + Ema.Route.Generic.RGeneric + Ema.Route.Generic.SubModel + Ema.Route.Generic.SubRoute + Ema.Route.Generic.TH + Ema.Route.Generic.Verification + + other-modules: GHC.TypeLits.Extra + + if impl(ghc >=9.2) + other-modules: + Ema.Route.Generic.Example + GHC.TypeLits.Extra.Symbol + + hs-source-dirs: src + default-language: Haskell2010 + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages + +test-suite test-type-errors + import: extensions + build-depends: + , base + , ema + , ema-generics + , generics-sop + , raw-strings-qq + , template-haskell + , text + , url-slug + + other-modules: Deriving + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test/type-errors + default-language: Haskell2010 + + if impl(ghc >=8.10) + ghc-options: -Wunused-packages diff --git a/src/Ema/Route/Generic.hs b/src/Ema/Route/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Ema/Route/Generic.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Ema.Route.Generic ( + -- * Generic deriving types + GenericRoute (GenericRoute), + HasSubRoutes, + HasSubModels, + WithModel, + WithSubRoutes, + WithSubModels, + + -- * Customizing generic deriving + GenericRouteOpt (..), + + -- * Handy functions + subModels, + + -- * Export these for DerivingVia coercion representations + FileRoute (FileRoute), + FolderRoute (FolderRoute), +) where + +import Ema.Route.Class (IsRoute (..)) +import Ema.Route.Generic.RGeneric +import Ema.Route.Generic.SubModel as X +import Ema.Route.Generic.SubRoute as X +import Ema.Route.Generic.Verification +import Ema.Route.Lib.File (FileRoute (FileRoute)) +import Ema.Route.Lib.Folder (FolderRoute (FolderRoute)) +import Ema.Route.Lib.Multi (MultiModel, MultiRoute) +import Ema.Route.Prism.Type (mapRoutePrism) +import GHC.Generics qualified as GHC +import Generics.SOP (All, I (..), NP) +import Optics.Core (ReversibleOptic (re), coercedTo, equality, review, (%)) +import Prelude hiding (All, Generic) + +-- | DerivingVia type to generically derive `IsRoute` +newtype GenericRoute r (opts :: [Type]) = GenericRoute r + deriving stock (GHC.Generic) + +{- | Associate the route with the given model type. + + Default: `()` +-} +data WithModel (r :: Type) + +{- | Specify isomorphic types to delegate sub-route behaviour. Usually this is identical to the route product type. + + The isomorphism is specified by @Coercible@. + + The default implementation uses @FileRoute@ for terminal routes, and + @FolderRoute@ (with constructor prefix stripped) for wrapping sub-routes types. +-} +data WithSubRoutes (subRoutes :: [Type]) + +{- | Specify the @Data.Generics.Product.Any.HasAny@ selector type for sub models + + Note: if the selector is a @Symbol@ you must wrap it in a @Proxy@. +-} +data WithSubModels (subModels :: [Type]) + +{- | Typeclass to control `GenericRoute` behaviour. + + The `FooM` type enables users to define their type optionally, whose default + is specified in the `Foo` type family (further below). + + You can define your own options, for example: + + @ + data MySubRoutes + instance GenericRouteOpt r MySubRoutes where + type + OptSubRoutesM r MySubRoutes = + 'Just (GSubRoutes (RDatatypeName r) (RConstructorNames r) (RCode r)) + @ + + And use it as: + + > deriving via (GenericRoute MyRoute '[MySubRoutes]) +-} +class GenericRouteOpt (r :: Type) (opt :: Type) where + type OptModelM r opt :: Maybe Type + type OptModelM r opt = 'Nothing + type OptSubRoutesM r opt :: Maybe [Type] + type OptSubRoutesM r opt = 'Nothing + type OptSubModelsM r opt :: Maybe [Type] + type OptSubModelsM r opt = 'Nothing + +instance GenericRouteOpt r (WithModel t) where + type OptModelM r (WithModel t) = 'Just t +instance GenericRouteOpt r (WithSubRoutes t) where + type OptSubRoutesM r (WithSubRoutes t) = 'Just t +instance GenericRouteOpt r (WithSubModels t) where + type OptSubModelsM r (WithSubModels t) = 'Just t + +type family OptModel r (opts :: [Type]) :: Type where + OptModel r '[] = () + OptModel r (opt ': opts) = FromMaybe (OptModel r opts) (OptModelM r opt) + +type family OptSubRoutes r (opts :: [Type]) :: [Type] where + OptSubRoutes r '[] = GSubRoutes (RDatatypeName r) (RConstructorNames r) (RCode r) + OptSubRoutes r (opt ': opts) = FromMaybe (OptSubRoutes r opts) (OptSubRoutesM r opt) + +type family OptSubModels r (opts :: [Type]) :: [Type] where + OptSubModels r '[] = MultiModel (SubRoutes r) + OptSubModels r (opt ': opts) = FromMaybe (OptSubModels r opts) (OptSubModelsM r opt) + +type family FromMaybe (def :: a) (maybe :: Maybe a) :: a where + FromMaybe def 'Nothing = def + FromMaybe def ( 'Just a) = a + +type GenericRouteOpts r opts = All (GenericRouteOpt r) opts + +instance + ( GenericRouteOpts r opts + , RGeneric r + , ValidSubRoutes r (OptSubRoutes r opts) + ) => + HasSubRoutes (GenericRoute r opts) + where + type SubRoutes (GenericRoute r opts) = OptSubRoutes r opts + +instance + ( VerifyModels + (RouteModel (GenericRoute r opts)) + (MultiModel (SubRoutes (GenericRoute r opts))) + (OptSubModels r opts) + , VerifyRoutes (RCode r) (SubRoutes (GenericRoute r opts)) + , GSubModels (RouteModel (GenericRoute r opts)) (MultiModel (OptSubRoutes r opts)) (OptSubModels r opts) + , HasSubRoutes (GenericRoute r opts) + , GenericRouteOpts r opts + ) => + HasSubModels (GenericRoute r opts) + where + subModels m = + gsubModels @_ @(RouteModel (GenericRoute r opts)) + @(MultiModel (SubRoutes (GenericRoute r opts))) + @(OptSubModels r opts) + m + +instance + ( VerifyRoutes (RCode r) (SubRoutes (GenericRoute r opts)) + , HasSubRoutes r + , HasSubModels r + , ValidSubRoutes r (SubRoutes r) + , RGeneric r + , mr ~ MultiRoute (SubRoutes r) + , mm ~ MultiModel (SubRoutes r) + , RouteModel r ~ OptModel r opts + , RouteModel mr ~ NP I mm + , IsRoute mr + , GenericRouteOpts r opts + ) => + IsRoute (GenericRoute r opts) + where + type RouteModel (GenericRoute r opts) = OptModel r opts + routePrism = + routePrism @mr + & mapRoutePrism equality (re (subRoutesIso @r) % coercedTo) (subModels @r) + routeUniverse m = + GenericRoute . review subRoutesIso + <$> routeUniverse (subModels @r m) diff --git a/src/Ema/Route/Generic/Example.hs b/src/Ema/Route/Generic/Example.hs new file mode 100644 --- /dev/null +++ b/src/Ema/Route/Generic/Example.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ema.Route.Generic.Example where + +import Data.Generics.Sum.Any (AsAny (_As)) +import Data.SOP (I (..), NP (..)) +import Ema +import Ema.Asset qualified as Asset +import Ema.Route.Generic +import Ema.Route.Generic.TH +import Generics.SOP qualified as SOP +import Generics.SOP.TH qualified as SOP +import Optics.Core ((%)) +import Optics.Prism (prism') + +-- ---------- +-- Examples +-- ---------- + +type M = (Int, Int, String) + +data R = R_Index | R_Foo | R_Bar NumRoute | R_Bar2 NumRoute + deriving stock (Show, Eq, Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving (HasSubRoutes, IsRoute) via (GenericRoute R '[WithModel M]) + +-- We must derive this manually due to ambiguity in field types (Int) +instance HasSubModels R where + subModels (a, b, _) = + I () :* I () :* I a :* I b :* Nil + +data NumRoute = NumRoute + deriving stock (Show, Eq, Generic) + +instance IsRoute NumRoute where + type RouteModel NumRoute = Int + routePrism n = + let fp = show n <> ".html" + in toPrism_ $ + prism' (const fp) $ \s -> do + guard $ s == fp + pure NumRoute + routeUniverse _ = [NumRoute] + +instance EmaSite R where + siteInput _ () = pure $ pure (42, 21, "inner") + siteOutput _ m r = pure $ Asset.AssetGenerated Asset.Html $ show r <> show m + +-- --warnings -c "cabal repl ema -f with-examples" -T Ema.Route.Generic.main --setup ":set args gen /tmp" +main :: IO () +main = Ema.runSite_ @R () + +-- --- +-- Let's try defining a top-level route using `R` to see how EmaSite instances compose. +-- -- + +type TM = (M, String) + +data TR = TR_Index | TR_Inner R + deriving stock (Show, Eq, Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving (HasSubRoutes, HasSubModels, IsRoute) via (GenericRoute TR '[WithModel TM]) + +instance EmaSite TR where + siteInput x () = do + m1 <- siteInput @R x () + pure $ fmap (,"TOP") m1 + siteOutput rp m = \case + r@TR_Index -> + pure $ Asset.AssetGenerated Asset.Html $ show r <> show m + TR_Inner r -> + -- Might as well provide a `innerSiteOutput (_As @TR_Inner)`? + siteOutput @R (rp % _As @"TR_Inner") (trInnerModel m) r + where + trInnerModel model = + let I () :* I m' :* Nil = subModels @TR model + in m' + +mainTop :: IO () +mainTop = Ema.runSite_ @TR () + +-- --- +-- Ensure that the constant model case (simple one) still works +-- -- + +type M2 = (Int, String) + +data R2 = R2_Index | R2_Foo | R2_Bar BarRoute | R2_Bar2 BarRoute + deriving stock (Show, Eq, Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving (HasSubRoutes, HasSubModels, IsRoute) via (GenericRoute R2 '[WithModel M2]) + +data BarRoute = BarRoute + deriving stock (Show, Eq, Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving (HasSubRoutes, HasSubModels, IsRoute) via (GenericRoute BarRoute '[WithModel M2]) + +instance EmaSite R2 where + siteInput _ () = pure $ pure (21, "inner") + siteOutput _ m r = pure $ Asset.AssetGenerated Asset.Html $ show r <> show m + +mainConst :: IO () +mainConst = Ema.runSite_ @R2 () + +-- --- +-- Ensure deriveIsRoute works with (partial) subroutes +-- -- + +data M3 + = M3 + deriving stock (Eq, Show, Generic) + +data R3 + = R3_Sub R3_SubR + | R3_Index + +data R3_SubR + = R3_SubR + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) + deriving + (HasSubRoutes, HasSubModels, IsRoute) + via ( GenericRoute + R3_SubR + '[ WithSubRoutes + '[ FileRoute "example.html" + ] + ] + ) + +SOP.deriveGeneric ''R3 +deriveIsRoute + ''R3 + [t| + [ WithModel M3 + , WithSubRoutes + [ R3_SubR + , () + ] + ] + |] + +-- --- +-- Ensure deriveIsRoute works in a no-subroute case +-- -- + +data M4 + = M4 + deriving stock (Eq, Show, Generic) + +data R4 + = R4_Index + | R3_About + +SOP.deriveGeneric ''R4 +deriveIsRoute ''R4 [t|'[WithModel M4]|] diff --git a/src/Ema/Route/Generic/RGeneric.hs b/src/Ema/Route/Generic/RGeneric.hs new file mode 100644 --- /dev/null +++ b/src/Ema/Route/Generic/RGeneric.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Ema.Route.Generic.RGeneric ( + RGeneric (RCode, rfrom, rto), + RHasDatatypeInfo (RDatatypeName, RConstructorNames), +) where + +import GHC.TypeLits (ErrorMessage (Text), TypeError) +import GHC.TypeLits.Extra (Impossible (impossible), TypeErr) +import Generics.SOP +import Generics.SOP.Type.Metadata qualified as SOPM +import Prelude hiding (All, Generic) + +-- | Like `Generic` but for Route types only. +class (Generic r, HasDatatypeInfo r) => RGeneric r where + type RCode r :: [Type] + rfrom :: r -> NS I (RCode r) + rto :: NS I (RCode r) -> r + +class (RGeneric r, HasDatatypeInfo r) => RHasDatatypeInfo r where + type RDatatypeName r :: SOPM.DatatypeName + type RConstructorNames r :: [SOPM.ConstructorName] + +instance (Generic r, HasDatatypeInfo r, RGeneric' (Code r), All RouteNP (Code r)) => RGeneric r where + type RCode r = RCode' (Code r) + rfrom = rfrom' @(Code r) . unSOP . from + rto = to . SOP . rto' @(Code r) + +instance (RGeneric r, HasDatatypeInfo r) => RHasDatatypeInfo r where + type RDatatypeName r = RDatatypeName' (DatatypeInfoOf r) + type RConstructorNames r = RConstructorNames' (DatatypeInfoOf r) + +class RGeneric' (xss :: [[Type]]) where + type RCode' xss :: [Type] + rfrom' :: NS (NP I) xss -> NS I (RCode' xss) + rto' :: NS I (RCode' xss) -> NS (NP I) xss + +instance RGeneric' '[] where + type RCode' '[] = '[] + rfrom' = \case {} + rto' = \case {} + +instance (RGeneric' xss, RouteNP xs) => RGeneric' (xs ': xss) where + type RCode' (xs ': xss) = RouteNPType xs ': RCode' xss + rfrom' = \case + Z routeNP -> Z $ I $ fromRouteNP routeNP + S rest -> S $ rfrom' @xss rest + rto' = \case + Z (I t) -> Z $ toRouteNP t + S rest -> S $ rto' @xss rest + +type family RDatatypeName' (info :: SOPM.DatatypeInfo) :: SOPM.DatatypeName where + RDatatypeName' ( 'SOPM.ADT _ name _ _) = + name + RDatatypeName' ( 'SOPM.Newtype _ name _) = + name + +type family RConstructorNames' (info :: SOPM.DatatypeInfo) :: [SOPM.ConstructorName] where + RConstructorNames' ( 'SOPM.ADT _ _ constrs _) = + GetConstructorNames constrs + RConstructorNames' ( 'SOPM.Newtype _ _ constr) = + '[GetConstructorName constr] + +type family GetConstructorName (info :: SOPM.ConstructorInfo) :: SOPM.ConstructorName where + GetConstructorName ( 'SOPM.Constructor name) = + name + GetConstructorName ( 'SOPM.Infix name _ _) = + name + GetConstructorName ( 'SOPM.Record name _) = + name + +type family GetConstructorNames (infos :: [SOPM.ConstructorInfo]) :: [SOPM.ConstructorName] where + GetConstructorNames '[] = '[] + GetConstructorNames (x ': xs) = GetConstructorName x ': GetConstructorNames xs + +{- | Class of `NP` that can be used in a route tyupe. + + Ensures that the constructor can have 0 or 1 products only. +-} +class RouteNP (xs :: [Type]) where + type RouteNPType xs :: Type + fromRouteNP :: NP I xs -> RouteNPType xs + toRouteNP :: RouteNPType xs -> NP I xs + +instance RouteNP '[] where + type RouteNPType '[] = () + fromRouteNP Nil = () + toRouteNP () = Nil + +instance RouteNP (x ': '[]) where + type RouteNPType (x ': '[]) = x + fromRouteNP (I x :* Nil) = x + toRouteNP x = I x :* Nil + +instance (TypeErr ( 'Text "MultiRoute: too many arguments")) => RouteNP (x ': x' ': xs) where + type RouteNPType (x ': x' ': xs) = TypeError ( 'Text "MultiRoute: too many arguments") + fromRouteNP _ = impossible + toRouteNP _ = impossible diff --git a/src/Ema/Route/Generic/SubModel.hs b/src/Ema/Route/Generic/SubModel.hs new file mode 100644 --- /dev/null +++ b/src/Ema/Route/Generic/SubModel.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ema.Route.Generic.SubModel ( + HasSubModels (subModels), + -- DerivingVia types + GSubModels (..), +) where + +import Data.Generics.Product (HasAny (the)) +import Ema.Route.Class (IsRoute (RouteModel)) +import Ema.Route.Generic.SubRoute (HasSubRoutes (SubRoutes)) +import Ema.Route.Lib.Multi (MultiModel) +import Generics.SOP (I (..), NP (Nil, (:*))) +import Optics.Core (united, view) +import Prelude hiding (All) + +class HasSubRoutes r => HasSubModels r where + -- | Break the model into a list of sub-models used correspondingly by the sub-routes. + subModels :: RouteModel r -> NP I (MultiModel (SubRoutes r)) + +class GSubModels m (ms :: [Type]) (lookups :: [k]) where + gsubModels :: m -> NP I ms + +instance GSubModels m '[] '[] where + gsubModels _ = Nil + +instance + {-# OVERLAPPING #-} + (HasAny s m m t t, GSubModels m ms ss) => + GSubModels m (t ': ms) (s ': ss) + where + gsubModels m = I (view (the @s @m @_ @t @_) m) :* gsubModels @_ @m @ms @ss m + +-- Useful instances to support varied types in `WithSubModels` list. + +instance {-# OVERLAPPING #-} HasAny () s s () () where + the = united + +instance HasAny sel s t a b => HasAny (Proxy sel) s t a b where + the = the @sel diff --git a/src/Ema/Route/Generic/SubRoute.hs b/src/Ema/Route/Generic/SubRoute.hs new file mode 100644 --- /dev/null +++ b/src/Ema/Route/Generic/SubRoute.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ema.Route.Generic.SubRoute ( + HasSubRoutes (SubRoutes), + subRoutesIso, + -- DerivingVia types + GSubRoutes, + gtoSubRoutes, + gfromSubRoutes, + ValidSubRoutes, +) where + +import Data.SOP.Constraint (AllZipF) +import Data.SOP.NS (trans_NS) +import Ema.Route.Generic.RGeneric (RGeneric (..)) +import Ema.Route.Lib.Multi (MultiRoute) +import GHC.TypeLits (AppendSymbol, Symbol) +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +import GHC.TypeLits.Extra.Symbol (StripPrefix, ToLower) +import Ema.Route.Lib.File (FileRoute) +import Ema.Route.Lib.Folder (FolderRoute) +#else +import GHC.TypeLits +#endif +import Generics.SOP (All, I (..), NS, SameShapeAs, Top, unI) +import Generics.SOP.Type.Metadata qualified as SOPM +import Optics.Core (Iso', iso) +import Prelude hiding (All) + +{- | HasSubRoutes is a class of routes with an underlying MultiRoute (and MultiModel) representation. + + The idea is that by deriving HasSubRoutes (and HasSubModels), we get IsRoute for free (based on MultiRoute). + + TODO: Rename this class, or change the API. +-} +class HasSubRoutes r where + -- | The sub-routes in the `r` (for each constructor). + type SubRoutes r :: [Type] + +subRoutesIso :: + forall r. + ( RGeneric r + , HasSubRoutes r + , ValidSubRoutes r (SubRoutes r) + ) => + Iso' r (MultiRoute (SubRoutes r)) +subRoutesIso = + iso (gtoSubRoutes @r . rfrom) (rto . gfromSubRoutes @r) + +gtoSubRoutes :: + forall r subRoutes. + ( RGeneric r + , ValidSubRoutes r subRoutes + ) => + NS I (RCode r) -> + MultiRoute subRoutes +gtoSubRoutes = trans_NS (Proxy @Coercible) (I . coerce . unI) + +gfromSubRoutes :: + forall r subRoutes. + ( RGeneric r + , ValidSubRoutes r subRoutes + ) => + MultiRoute subRoutes -> + NS I (RCode r) +gfromSubRoutes = trans_NS (Proxy @Coercible) (I . coerce . unI) + +-- | @subRoutes@ are valid sub-routes of @r@ +type ValidSubRoutes r subRoutes = + ( SameShapeAs (RCode r) subRoutes + , SameShapeAs subRoutes (RCode r) + , All Top (RCode r) + , All Top subRoutes + , AllZipF Coercible (RCode r) subRoutes + , AllZipF Coercible subRoutes (RCode r) + ) + +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +type family GSubRoutes (name :: SOPM.DatatypeName) (constrs :: [SOPM.ConstructorName]) (xs :: [Type]) :: [Type] where + GSubRoutes _ _ '[] = '[] + GSubRoutes name (c ': cs) (() ': xs) = + -- TODO: The .html suffix part should be overridable. + FileRoute (Constructor2RoutePath name c ".html") + ': GSubRoutes name cs xs + GSubRoutes name (c ': cs) (x ': xs) = + FolderRoute (Constructor2RoutePath name c "") x + ': GSubRoutes name cs xs + +type family + Constructor2RoutePath + (name :: SOPM.DatatypeName) + (constr :: SOPM.ConstructorName) + (suffix :: Symbol) :: + Symbol + where + Constructor2RoutePath name constr suffix = + AppendSymbol + ( -- Instead of ToLower we want Camel2Kebab here, ideally. + -- So that `Foo_BarQux` encodes to bar-qux instead of barqux. + ToLower + ( StripPrefix + (AppendSymbol name "_") + constr + ) + ) + suffix +#else +type family GSubRoutes (name :: SOPM.DatatypeName) (constrs :: [SOPM.ConstructorName]) (xs :: [Type]) :: [Type] where + GSubRoutes _ _ _ = TypeError ('Text "GHC 9.2 is required for anyclass deriving of HasSubRoutes") +#endif diff --git a/src/Ema/Route/Generic/TH.hs b/src/Ema/Route/Generic/TH.hs new file mode 100644 --- /dev/null +++ b/src/Ema/Route/Generic/TH.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Ema.Route.Generic.TH ( + -- * Main TH + deriveIsRoute, + + -- * Convenient re-exports + deriveGeneric, + module X, +) where + +import Ema.Route.Class (IsRoute) +import Ema.Route.Generic as X +import Generics.SOP.TH (deriveGeneric) +import Language.Haskell.TH + +{- | @deriveIsRoute route model subroutes@ derives 'HasSubRoutes', 'HasSubModels', and 'IsRoute' for the given @route@. + +Subroutes are optionally supplied, but if they are then the length of the list must be the same as the number of +constructors in @route@. + +TODO: Add TypeErrors to catch mismatched 'WithSubRoutes' list shapes at the generic deriving level? +-} +deriveIsRoute :: Name -> TypeQ -> Q [Dec] +deriveIsRoute route opts = do + opts' <- opts + let instances = + [ ''HasSubRoutes + , ''HasSubModels + , ''IsRoute + ] + pure $ + flip fmap instances $ \i -> + StandaloneDerivD + ( Just + ( ViaStrategy + ( ConT ''GenericRoute + `AppT` (ConT route) + `AppT` opts' + ) + ) + ) + [] + (ConT i `AppT` ConT route) diff --git a/src/Ema/Route/Generic/Verification.hs b/src/Ema/Route/Generic/Verification.hs new file mode 100644 --- /dev/null +++ b/src/Ema/Route/Generic/Verification.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Ema.Route.Generic.Verification ( + type VerifyModels, + type VerifyRoutes, +) where + +import Data.Generics.Product.Any (HasAny) +import GHC.TypeLits + +{- | @VerifyModels model routeModels lookups@ verifies the given @model@ to ensure that there +exists a valid @HasSubModels@ instance for the given combination of (model, routeModels, lookups). +-} +type family VerifyModels model (subModels :: [Type]) (lookups :: [Type]) :: Constraint where + VerifyModels m '[] '[] = () + VerifyModels m '[] t = + TypeError + ( 'Text "'WithSubModels' has extra unnecessary types: " ':$$: 'Text "" ':$$: 'Text "\t" ':<>: 'ShowType t) + VerifyModels m f '[] = + TypeError + ( 'Text "'WithSubModels' is missing submodel types: " ':$$: 'Text "" ':$$: 'Text "\t" ':<>: 'ShowType f) + VerifyModels model (model ': fs) (model ': ss) = + -- This checks the simple case that (the model ~ the submodel), + -- because it doesn't necessarily have to have a generic instance in this case. + -- After that, we can /assume/ the model has a generic instance to allow us to inspect its + -- structure statically to verify that the correct submodel exists. + VerifyModels model fs ss + VerifyModels model (subModel ': subModels) (sel ': sels) = + ( HasAny sel model model subModel subModel + , VerifyModels model subModels sels + ) + +{- | @VerifyRoutes route rep subroutes@ verifies the given @route@ to ensure that there +exists a valid @HasSubRoutes@ instance for @route@ given its @rep@ and the @subroutes@ it is generic-deriving from. + +Invariant: code ~ Code route +-} +type family VerifyRoutes (rcode :: [Type]) (subRoutes :: [Type]) :: Constraint where + VerifyRoutes '[] '[] = () + -- Inconsistent lengths + VerifyRoutes '[] t = + TypeError + ( 'Text "'WithSubRoutes' has extra unnecessary types: " ':$$: 'Text "" ':$$: 'Text "\t" ':<>: 'ShowType t) + VerifyRoutes t '[] = + TypeError + ( 'Text "'WithSubRoutes' is missing subroutes for:" + ':$$: 'Text "" + ':$$: ( 'Text "\t" ':<>: 'ShowType t) + ) + -- Subroute rep is unit (REVIEW: this case not strictly necessary anymore; should it be removed?) + VerifyRoutes (() ': rs) (() : rs') = VerifyRoutes rs rs' + VerifyRoutes (r' ': rs) (() : rs') = + TypeError + ( 'Text "A 'WithSubRoutes' entry is '()' instead of the expected: " + ':$$: 'ShowType r' + ) + VerifyRoutes (r1 ': rs) (r2 ': rs') = (Coercible r1 r2, VerifyRoutes rs rs') diff --git a/src/GHC/TypeLits/Extra.hs b/src/GHC/TypeLits/Extra.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeLits/Extra.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE UndecidableInstances #-} + +module GHC.TypeLits.Extra where + +import GHC.TypeLits (TypeError) + +class Impossible where + impossible :: a + +{- | Like TypeError but suitable for use in type-classes to avoid `undefined` + + cf. https://stackoverflow.com/a/72783230/55246 +-} +type family TypeErr t where + TypeErr t = (TypeError t, Impossible) diff --git a/src/GHC/TypeLits/Extra/Symbol.hs b/src/GHC/TypeLits/Extra/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeLits/Extra/Symbol.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE UndecidableInstances #-} + +module GHC.TypeLits.Extra.Symbol ( + StripPrefix, + ToLower, +) where + +import GHC.TypeLits (ConsSymbol, Symbol, UnconsSymbol) + +-- | Strip `prefix` from `symbol`. Return `symbol` as-is if the prefix doesn't match. +type family StripPrefix (prefix :: Symbol) (symbol :: Symbol) :: Symbol where + StripPrefix prefix symbol = + FromMaybe + symbol + (StripPrefix' (UnconsSymbol prefix) (UnconsSymbol symbol)) + +-- | Strip `prefix` from `symbol`. Return Nothing if the prefix doesn't match. +type family StripPrefix' (prefix :: Maybe (Char, Symbol)) (symbol :: Maybe (Char, Symbol)) :: Maybe Symbol where + StripPrefix' 'Nothing 'Nothing = 'Just "" + StripPrefix' 'Nothing ( 'Just '(x, xs)) = 'Just (ConsSymbol x xs) + StripPrefix' _p 'Nothing = 'Nothing + StripPrefix' ( 'Just '(p, ps)) ( 'Just '(p, ss)) = StripPrefix' (UnconsSymbol ps) (UnconsSymbol ss) + StripPrefix' ( 'Just '(p, ps)) ( 'Just '(_, ss)) = 'Nothing + +type family ToLower (sym :: Symbol) :: Symbol where + ToLower sym = ToLower' (UnconsSymbol sym) + +type family ToLower' (pair :: Maybe (Char, Symbol)) :: Symbol where + ToLower' 'Nothing = "" + ToLower' ( 'Just '(c, cs)) = ConsSymbol (ToLowerC c) (ToLower' (UnconsSymbol cs)) + +type family ToLowerC (c :: Char) :: Char where + ToLowerC 'A' = 'a' + ToLowerC 'B' = 'b' + ToLowerC 'C' = 'c' + ToLowerC 'D' = 'd' + ToLowerC 'E' = 'e' + ToLowerC 'F' = 'f' + ToLowerC 'G' = 'g' + ToLowerC 'H' = 'h' + ToLowerC 'I' = 'i' + ToLowerC 'J' = 'j' + ToLowerC 'K' = 'k' + ToLowerC 'L' = 'l' + ToLowerC 'M' = 'm' + ToLowerC 'N' = 'n' + ToLowerC 'O' = 'o' + ToLowerC 'P' = 'p' + ToLowerC 'Q' = 'q' + ToLowerC 'R' = 'r' + ToLowerC 'S' = 's' + ToLowerC 'T' = 't' + ToLowerC 'U' = 'u' + ToLowerC 'V' = 'v' + ToLowerC 'W' = 'w' + ToLowerC 'X' = 'x' + ToLowerC 'Y' = 'y' + ToLowerC 'Z' = 'z' + ToLowerC a = a + +type family FromMaybe (def :: a) (maybe :: Maybe a) :: a where + FromMaybe def 'Nothing = def + FromMaybe def ( 'Just a) = a diff --git a/test/type-errors/Deriving.hs b/test/type-errors/Deriving.hs new file mode 100644 --- /dev/null +++ b/test/type-errors/Deriving.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Deriving where + +import Data.Proxy (Proxy) +import Data.Text (Text) +import Ema.Route.Class +import Ema.Route.Generic +import Ema.Route.Generic.TH +import GHC.Generics qualified as GHC +import Generics.SOP qualified as SOP +import Text.RawString.QQ (r) + +#define ENABLE_SPEC + +---------------------------------------- +-- Subroute verification +---------------------------------------- + +#undef ENABLE_SPEC +#ifdef ENABLE_SPEC +data BadRoute = BR_1 Int String | BR_2 String +data M = M { m1 :: (), m2 :: () } deriving stock GHC.Generic + +deriveGeneric ''BadRoute +-- Subroutes should not have constructors with multiple fields +-- Expect: MultiRoute: too many arguments +deriveIsRoute ''BadRoute [t| + '[ WithModel M + ] + |] +#endif +#define ENABLE_SPEC + +----------------------------------------- + +#undef ENABLE_SPEC +#ifdef ENABLE_SPEC +data R = R_1 () | R_2 () +deriveGeneric ''R +-- WithSubRoutes' list should not be shorter than number of route constructors +-- Expect: +{- +'WithSubRoutes' is missing subroutes for: + + '[()] +-} +deriveIsRoute ''R [t| + '[ WithSubRoutes '[ () ] ] + |] +#endif +#define ENABLE_SPEC + +----------------------------------------- + +#undef ENABLE_SPEC +#ifdef ENABLE_SPEC +data R = R_1 () | R_2 () +deriveGeneric ''R +-- WithSubRoutes' list should not be longer than number of route constructors +-- Expect: +{- +'WithSubRoutes' has extra unnecessary types: + + '[Int] +-} +deriveIsRoute ''R [t| + '[ WithSubRoutes '[ (), (), Int ] ] + |] +#endif +#define ENABLE_SPEC + +------------------------------------------ + +#undef ENABLE_SPEC +#ifdef ENABLE_SPEC +data R = R_1 Int | R_2 +deriveGeneric ''R +-- constructors should either be empty or contain () when 'WithSubRoutes' specifies () +-- Expect: +{- +A 'WithSubRoutes' entry is '()' instead of the expected: +Int +-} +deriveIsRoute ''R [t| + '[ WithSubRoutes '[ (), () ] ] + |] +#endif +#define ENABLE_SPEC + +------------------------------------------- + +#undef ENABLE_SPEC +#ifdef ENABLE_SPEC +data R = R_1 | R_2 +deriveGeneric ''R +-- subroute types that are nonisomorphic to what is specified in 'WithSubRoutes' should be illegal +-- Expect: +{- +Couldn't match representation of type ‘()’ with that of ‘Bool’ + arising from a use of ‘routePrism’ +-} +deriveIsRoute ''R [t| + ' [ WithSubRoutes '[ (), Bool] ] + |] +#endif +#define ENABLE_SPEC + +------------------------------------------- + +-- subroute types that are the same as what is specified in 'WithSubRoutes' should typecheck" +data RSubIso = RSubIso_1 | RSubIso_2 +deriveGeneric ''RSubIso +deriveIsRoute + ''RSubIso + [t| + '[WithSubRoutes '[(), ()]] + |] + +------------------------------------------- + +-- FIXME: This test is broken. +#undef ENABLE_SPEC +#ifdef ENABLE_SPEC +routeSpec "subroute types that are an unwrapped representation of what is specified in 'WithSubRoutes' should typecheck | ( empty constructor <-> () ) special case" + (niceRoute ''() ''()) + [t| + '[ WithModel (NiceNamedM () ()) + , WithSubRoutes '[ (), PlainR_NiceNamedM ] + ] + |] + [r| + |] +#endif +#define ENABLE_SPEC + +------------------------------------------- + +-- Subroute types that are an unwrapped representation of what is specified in +-- 'WithSubRoutes' should typecheck | (wrapper deriving /newtype/ GHC.Generic) +-- case" +data RSubNewtype = RSubNewtype_1 | RSubNewtype_2 +deriveGeneric ''RSubNewtype +newtype WrapNewtype a = WrapNewtype a + deriving newtype (GHC.Generic, IsRoute) +deriveIsRoute + ''RSubNewtype + [t| + '[ WithSubRoutes '[(), WrapNewtype ()] + ] + |] + +------------------------------------------- +-- Submodel verification +------------------------------------------- + +#undef ENABLE_SPEC +#ifdef ENABLE_SPEC +data R = R1 | R2 +deriveGeneric ''R +data M = M { m1 :: (), m2 :: () } deriving stock GHC.Generic +-- Submodel selectors should not be less than number of subroutes +-- Expect: +{- +'WithSubModels' is missing submodel types: + '[()] +-} +deriveIsRoute ''R + [t| + '[ WithModel M + , WithSubModels '[ Proxy "m1" ] + ] + |] +#endif +#define ENABLE_SPEC + +------------------------------------------- + +#undef ENABLE_SPEC +#ifdef ENABLE_SPEC +data R = R1 | R2 +deriveGeneric ''R +data M = M { m1 :: (), m2 :: () } + deriving stock GHC.Generic +-- submodel selectors should not outnumber number of subroutes +-- Expect: +{- +'WithSubModels' has extra unnecessary types: + + '[Proxy "m2"] +-} +deriveIsRoute ''R + [t| + '[ WithModel M + , WithSubModels '[ Proxy "m1", Proxy "m2", Proxy "m2" ] + ] + |] +#endif +#define ENABLE_SPEC + +------------------------------------------- +data RSubMSelf = RSubMSelf1 | RSubMSelf2 RSubMSelf + deriving stock (GHC.Generic) +deriveGeneric ''RSubMSelf +data MSelf = MSelf {mself1 :: (), mself2 :: ()} + deriving stock (GHC.Generic) + +-- submodel type selectors be able to reference the model itself if they are of the same type +deriveIsRoute + ''RSubMSelf + [t| + '[ WithModel MSelf + , WithSubModels '[Proxy "mself1", MSelf] + ] + |] + +------------------------------------------- + +#undef ENABLE_SPEC +#ifdef ENABLE_SPEC +data R = R1 | R2 +deriveGeneric ''R +data M = M { m1 :: (), m2 :: () } + deriving stock GHC.Generic +-- submodel type selectors must, at a minimum, refer to a model field of a matching type +-- Expect: +{- +Couldn't match type ‘Bool’ with ‘()’ +-} +deriveIsRoute ''R + [t| + '[ WithModel M + , WithSubModels '[ Proxy "m1", Bool ] + ] + |] +#endif +#define ENABLE_SPEC + +----------------------------------------- diff --git a/test/type-errors/Spec.hs b/test/type-errors/Spec.hs new file mode 100644 --- /dev/null +++ b/test/type-errors/Spec.hs @@ -0,0 +1,5 @@ +module Main where + +-- | Filler module so cabal will be happy that there's a main-is +main :: IO () +main = pure ()