ohhecs (empty) → 0.0.1
raw patch · 19 files changed
+3308/−0 lines, 19 filesdep +assert-failuredep +basedep +byte-order
Dependencies added: assert-failure, base, byte-order, containers, ghc-prim, hashable, intern, lens, ordered-containers, polysemy, polysemy-plugin, template-haskell, text, th-abstraction, unordered-containers, vector-th-unbox, witherable, xml-conduit, xml-picklers, xml-types
Files
- ChangeLog.md +5/−0
- LICENSE +674/−0
- README.md +2/−0
- ohhecs.cabal +116/−0
- src/Games/ECS.hs +45/−0
- src/Games/ECS/Component.hs +393/−0
- src/Games/ECS/Component/Store.hs +175/−0
- src/Games/ECS/Component/TH.hs +14/−0
- src/Games/ECS/Component/TH/Internal.hs +343/−0
- src/Games/ECS/Entity.hs +168/−0
- src/Games/ECS/MessageQueue.hs +155/−0
- src/Games/ECS/Prototype.hs +147/−0
- src/Games/ECS/SaveLoad.hs +96/−0
- src/Games/ECS/Serialisation.hs +369/−0
- src/Games/ECS/Slot.hs +29/−0
- src/Games/ECS/System.hs +90/−0
- src/Games/ECS/Util/Misc.hs +22/−0
- src/Games/ECS/World.hs +190/−0
- src/Games/ECS/World/TH.hs +275/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+Changelog for [`ohhecs` package](https://hackage.haskell.org/package/ohhecs)++# 0.0+## 0.0.1+Initial release.
+ LICENSE view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <https://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 <https://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+<https://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+<https://www.gnu.org/licenses/why-not-lgpl.html>.
+ README.md view
@@ -0,0 +1,2 @@+# OhhECS! [](https://hackage.haskell.org/package/ohhecs) [](http://stackage.org/lts/package/ohhecs) [](http://stackage.org/nightly/package/ohhecs)+OhhECS is an Entity-Component-Systems game engine core, with some additional features such as a message queue.
+ ohhecs.cabal view
@@ -0,0 +1,116 @@+cabal-version: 3.6+++name: ohhecs+category: Game Engine, Game+synopsis: An Entity-Component-Systems engine core.+version: 0.0.1+description: Please see the README on GitLab at <https://gitlab.com/spacekitteh/spaceRL#readme>+author: Sophie Taylor+maintainer: sophie@spacekitteh.moe+copyright: 2020- Sophie Taylor+license: AGPL-3.0-or-later+license-file: LICENSE+build-type: Simple+extra-doc-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://gitlab.com/spacekitteh/spaceRL+ +flag with_polysemy+ description: Include instances for Polysemy.+ default: False++common config+ default-language: GHC2021 + ghc-options: -Werror=deriving-defaults -Werror=unused-packages -Werror=unused-imports -Wsafe -Wtrustworthy-safe -Wunused-packages -fno-ignore-asserts -foptimal-applicative-do -fsimplifier-phases=4 -flate-specialise -fspec-constr-keen -fspec-constr -fliberate-case -flate-dmd-anal -Wno-error=inline-rule-shadowing -Wall -Wno-orphans -Wno-unticked-promoted-constructors -Widentities -Wredundant-constraints+ if flag(with_polysemy)+ ghc-options: -fplugin=Polysemy.Plugin+ build-depends:+ polysemy >=1.2.3 && < 1.3+ , polysemy-plugin >= 0.4.5.2 && < 0.5+ + default-extensions:+ GADTs+ DerivingVia+ BangPatterns+ DeriveAnyClass+ DerivingStrategies+ DuplicateRecordFields+ OverloadedStrings+ DeriveGeneric+ PolyKinds+ ApplicativeDo+ FlexibleContexts+ FlexibleInstances+ InstanceSigs+ UndecidableInstances+ RecordWildCards+ MultiParamTypeClasses+ RankNTypes+ DataKinds+ KindSignatures+ NamedFieldPuns+ TypeFamilies+ StandaloneDeriving+ DeriveDataTypeable+ TypeApplications+ TypeOperators+ FunctionalDependencies+ OverloadedLabels+ TupleSections+ AllowAmbiguousTypes+ DefaultSignatures+ ScopedTypeVariables+ DerivingStrategies+ GeneralisedNewtypeDeriving+ QuantifiedConstraints+ ConstraintKinds+ LambdaCase+ BlockArguments+library+ import: config+ exposed-modules:+ Games.ECS+ -- Games.ECS.Archetype+ Games.ECS.Component+ Games.ECS.Component.Store+ Games.ECS.Component.TH+ Games.ECS.Entity+ Games.ECS.MessageQueue+ Games.ECS.SaveLoad+ Games.ECS.Prototype+ Games.ECS.Serialisation+ Games.ECS.Slot+ Games.ECS.System+ Games.ECS.World+ Games.ECS.World.TH+ Games.ECS.Util.Misc+ other-modules:+ Games.ECS.Component.TH.Internal+ hs-source-dirs:+ src+ -- pkgconfig-depends:+ -- zlib, bzip2+ build-depends:+ base >=4.19 && <5+ , ghc-prim >= 0.11.0 && < 0.12+ , byte-order >= 0.1.3 && < 0.2+ , assert-failure >= 0.1.3 && < 0.2+ , intern >= 0.9.5 && < 0.10+ , containers >=0.6.8 && < 0.7+ , hashable >=1.4.4 && < 1.5+ , lens >= 5.2.3 && < 5.3+ , template-haskell >=2.21.0 && < 2.22+ , th-abstraction >=0.7.0 && < 0.8+ , text >= 2.1.1 && < 2.2+ , unordered-containers >= 0.2.20 && < 0.3+ , ordered-containers >= 0.2.3 && < 0.3+ , xml-types >=0.3.8 && < 0.4+ , xml-conduit >= 1.9.1 && < 1.10+ , xml-picklers >= 0.3.6 && < 0.4+ , vector-th-unbox >=0.2.2 && < 0.3+ , witherable >= 0.4.2 && < 0.5
+ src/Games/ECS.hs view
@@ -0,0 +1,45 @@+-- |+-- Module : Games.ECS+-- Description : Re-exports the public API.+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- This is the top-level interface to OhhECS. A brief tutorial should probably go here.+module Games.ECS+ ( module Games.ECS,+ module Games.ECS.Util.Misc,+ module Games.ECS.Component,+ module Games.ECS.Serialisation,+ module Games.ECS.Component.Store,+ module Games.ECS.Component.TH,+ module Games.ECS.World,+ module Games.ECS.World.TH,+ module Games.ECS.Entity,+ module Games.ECS.SaveLoad,+ module Games.ECS.System,+ module Games.ECS.Slot,+ module Games.ECS.Prototype,+ module Games.ECS.MessageQueue,+ )+where++import Control.Lens (IndexedTraversal')+import Games.ECS.Component+import Games.ECS.Component.Store+import Games.ECS.Component.TH+import Games.ECS.Entity+import Games.ECS.MessageQueue+import Games.ECS.Prototype+import Games.ECS.SaveLoad+import Games.ECS.Serialisation+import Games.ECS.Slot+import Games.ECS.System+import Games.ECS.Util.Misc+import Games.ECS.World+import Games.ECS.World.TH++-- | A filter over entities in a world is just an `IndexedTraversal'` that preserves the selection predicate.+type EntityFilter worldType = IndexedTraversal' Entity (worldType Storing) (worldType Individual)
+ src/Games/ECS/Component.hs view
@@ -0,0 +1,393 @@+{-# OPTIONS_GHC "-Wno-orphans" #-}++-- |+-- Module : Games.ECS.Component+-- Description : Components and their infrastructure.+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Components are what hold data in an ECS system.+module Games.ECS.Component where++import Control.Applicative+import Control.Lens+import Data.Coerce+import Data.Foldable qualified as DF+import Data.Kind (Type)+import Data.Maybe qualified as DM+import Data.Proxy+import Data.String+import Data.XML.Types (Element)+import GHC.Generics+import GHC.OverloadedLabels+import GHC.TypeLits+import Games.ECS.Component.Store+import Games.ECS.Entity+import Games.ECS.Serialisation+import Games.ECS.Slot+import Games.ECS.World++class PseudoComponent c++-- type family DefaultStorageForFlags (b :: Bool) where+-- type instance DefaultStorageForFlags False = ComponentStore+-- type instance DefaultStorageForFlags True =++-- | A component represented in the entity component system.+class+ ( AsEmpty (Storage c c),+ KnownSymbol (CanonicalName c),+ At (Storage c c),+ Index (Storage c c) ~ Entity,+ HasEntitySet (Storage c c)+ ) =>+ Component c+ where+ -- | What to name accessors if the type name isn't ergonomic.+ type CanonicalName c :: Symbol++ -- | Is the type a flag component?+ type IsFlag c :: Bool++ type IsFlag c = False++ -- | What datatype to store all instances of a component in. Allows for a generalisation of+ -- "Structure-of-Arrays". Defaults to `Data.HashMap.Strict.HashMap`.+ type Storage c :: Type -> Type++ type Storage c = ComponentStore++ -- | Arity of the component. Defaults to `Normal`.+ type Prop c :: Props++ type Prop c = Normal++ -- | A prism for serialising and deserialising the component as XML.+ _ComponentFromXML :: String -> Prism' Element c+ {-# INLINE _ComponentFromXML #-}+ default _ComponentFromXML :: (XMLSerialise c) => String -> Prism' Element c+ _ComponentFromXML name =+ prism'+ (serialise name)+ ( \n -> case deserialise name n of+ Right a -> Just a+ Left _ -> Nothing+ )++ -- | The collection of entities held in storage.+ {-# INLINE entityKeys #-}+ entityKeys :: Fold (Storage c c) EntitySet+ entityKeys = entitySet++ -- | Construct new storage.+ {-# INLINE emptyStorage #-}+ emptyStorage :: Storage c c+ emptyStorage = review _Empty () :: (Storage c c)++ -- | An AffineTraversal lookup of a given `Entity`'s component. This probably should be in `World.hs`.+ entityHasComponent :: Entity -> IndexedTraversal' Entity (Storage c c) c+ default entityHasComponent ::+ (IxValue (Storage c c) ~ c) =>+ Entity ->+ IndexedTraversal' Entity (Storage c c) c+ entityHasComponent ent = conjoined (ix ent) (iix ent)+ {-# INLINE entityHasComponent #-}++ -- | When the component is required, provide a default value.+ defaultValue :: ((Prop c) ~ Required) => c+ defaultValue = error ("No default value specified for required component " Prelude.++ symbolVal (Proxy :: Proxy (CanonicalName c)) Prelude.++ "!")++type ComponentReference (name :: Symbol) c = (Component c) => TaggedComponent name Entity++-- | A component comprised of multiple other components.+class (Component c) => CompositeComponent c where+ type SubComponentIndex c :: Type++ -- | Look up the entity references of the subcomponents.+ subComponentReferences :: IndexedFold (SubComponentIndex c) c Entity++ {-# INLINE components #-}++ -- | An IndexedTraversal' of the subcomponents of a composite component.+ components ::+ forall p f worldType.+ (World worldType, Indexable (SubComponentIndex c) p, Applicative f) =>+ -- | The composite component+ c ->+ p (worldType Individual) (f (worldType Individual)) ->+ worldType Storing ->+ f (worldType Storing)+ components comp = conjoined normalVer indexedVer+ where+ normalVer prof world = result+ where+ applied :: [f (worldType Individual)]+ applied =+ fmap (prof) $+ DM.mapMaybe+ (lookupEntity world)+ (comp ^.. subComponentReferences)++ result = liftA3 DF.foldl' (pure (flip storeEntity)) (pure world) (sequenceA applied)+ indexedVer prof world = result+ where+ applied :: [f (worldType Individual)]+ applied =+ fmap (uncurry (Control.Lens.indexed prof)) $+ DM.mapMaybe+ ( \(partName', ent) -> case lookupEntity world ent of+ Just partIndividual -> Just (partName', partIndividual)+ Nothing -> Nothing+ )+ (comp ^@.. subComponentReferences)++ result = liftA3 DF.foldl' (pure (flip storeEntity)) (pure world) (sequenceA applied)++-- | Indicates a component behaves like a sensor.+class (Component c) => SensoryComponent c++-- sensors :: c -> IndexedTraversal' Entity (worldType Storing) (worldType Individual)++-- | Indicates that a component can perform actions in the world.+class (Component c) => EffectorComponent c++class (Component c) => AttributeComponent c++-- | Indicates whether a component is a simple Boolean flag.+class (Component c) => FlagComponent c++-- | A component representing an /intent/ to do something.+class (Component c) => IntentComponent c++class (Component c) => ReferenceComponent c++-- | A component which indicates an ability to emit intents.+class (IntentComponent (Intent c), Component c) => CapabilityComponent c where+ type Intent c :: Type++-- TODO look at `specs` storage mechanisms+-- TODO look at unity archetypes (the storage kind)++-- Look at bitsets, hibitsets, bloom filters, slotmaps++-- | Storage for 'Unique' components. As a 'Unique' component will have, at most, a single instance in the world, we only need to store the component and its 'Entity' naively.+newtype UniqueStore a = UniqueStore (Maybe (Entity, a)) deriving (Eq, Show, Generic)++instance HasEntitySet (UniqueStore a) where+ {-# INLINE entitySet #-}+ entitySet = (coerced :: Iso' (UniqueStore a) (Maybe (Entity, a))) . _Just . _1 . Control.Lens.to singletonEntitySet++instance AsEmpty (UniqueStore a) where+ {-# INLINE _Empty #-}+ _Empty = coerced @(UniqueStore a) @(UniqueStore a) @(Maybe (Entity, a)) @(Maybe (Entity, a)) . _Nothing++instance Ixed (UniqueStore a)++type instance Index (UniqueStore a) = Entity++type instance IxValue (UniqueStore a) = a++instance (Index (UniqueStore a) ~ Entity, (IxValue (UniqueStore a)) ~ a) => At (UniqueStore a) where+ {- at ::+ Functor f =>+ Entity ->+ (Maybe a -> f (Maybe a)) ->+ UniqueStore a ->+ f (UniqueStore a)-}+ {-# INLINE at #-}+ at e f us =+ f lookedUp <&> \case+ Nothing -> maybe us (const (UniqueStore Nothing)) lookedUp+ Just v' -> UniqueStore (Just (e, v'))+ where+ lookedUp =+ ( case us of+ UniqueStore (Just (ref, a)) | e == ref -> Just a+ _ -> Nothing+ )++-- | This is an unlawful instance due to `entityHasComponent` allowing write-back.+-- FIXME: Write a valid definition of entityHasComponent, or make it only a psuedocomponent.+-- instance Component Entity where+-- type Prop Entity = Required++-- Some (future) psuedocomponents?++data Has entity component = Has++type HasA component entity = Has entity component++data Hasn't entity component = Hasn't++-- | Simplified type signature to use in world definitions.+type AComponent name s a = Field name s (Prop a) a++instance ({-HasType (Field name acc p a) (hkd acc), Generic (hkd acc),-} EntityProperty name hkd acc p a, accessorType ~ OpticsFor name hkd acc p a) => IsLabel name accessorType where+ fromLabel = accessor @name @hkd @acc @p @a+ {-# INLINE fromLabel #-}++-- instance (HasType (Tagged name a) (hkd Individual), (Tagged name a) ~ (Field name hkd Individual p a), EntityProperty name hkd Individual p a) => HasField name (hkd Individual) a where++-- getField = unTagged . getTyped++-- | A component with an arbitrary name tag.+newtype TaggedComponent name a = Tagged {unTagged :: a} deriving newtype (Eq, Show, Ord, Generic)++{-# INLINE untag #-}++-- | Get the raw component.+untag :: TaggedComponent name a -> a+untag = unTagged++instance {-# OVERLAPPING #-} (KnownSymbol name, KnownSymbol (AppendSymbol name "TaggedComponent wrapper"), XMLPickler [Node] a) => XMLPickler [Node] (TaggedComponent name a) where+ {-# INLINE xpickle #-}+ xpickle = xpElemNodes (fromString (symbolVal (Proxy :: Proxy name))) $ (fromString $ (symbolVal (Proxy :: Proxy (AppendSymbol name "TaggedComponent wrapper"))), "") <?+> (xpWrap Tagged untag (("inside Tagged", "") <?+> xpickle))++instance {-# OVERLAPPING #-} (Eq a, KnownSymbol name, KnownSymbol (AppendSymbol name "TaggedComponent wrapper"), XMLPickler [Node] a) => XMLPickler [Node] (TaggedComponent name (Maybe a)) where+ {-# INLINE xpickle #-}+ xpickle = xpDefault (Tagged Nothing) $ xpElemNodes (fromString (symbolVal (Proxy :: Proxy name))) $ (fromString $ (symbolVal (Proxy :: Proxy (AppendSymbol name "TaggedComponent wrapper"))), "") <?+> (xpWrap Tagged untag (("inside Tagged", "") <?+> xpOption (("inside option", "") <?+> ({-xpMayFail-} xpickle))))++-- | An instance for wrapper components. Don't bother with the wrapper constructor or fieldname; just the wrapped data.+instance {-# OVERLAPPING #-} (KnownSymbol name, XMLPickler [Node] a, Datatype d, ty ~ (M1 D d (M1 C c'' (M1 S c (K1 i a))))) => GXmlPickler [Node] (M1 D d (M1 C c'' (M1 S c (K1 i (TaggedComponent name (Maybe a)))))) where+ {-# INLINE gxpickleContentsf #-}+ gxpickleContentsf _ = {-xpElemNodes (fromString . formatElement $ datatypeName (undefined :: ty p))-} xpElemNodes (fromString (symbolVal (Proxy :: Proxy name))) $ (fromString $ datatypeName (undefined :: M1 D d f p), "") <?+> (xpWrap (M1 . M1 . M1 . K1 . Tagged) (unTagged . unK1 . unM1 . unM1 . unM1) (xpOption ({-xpMayFail-} xpickle)))++-- | The core mechanics of the higher-kinded representation for the ECS system.+type family Field (name :: Symbol) (acc :: Access) (p :: Props) (a :: Type) :: Type where+ Field name Individual Required a = TaggedComponent name a+ Field name Individual Normal a = TaggedComponent name (Maybe a)+ Field name Individual Unique a = TaggedComponent name (Maybe a)+ Field name Storing Unique a = TaggedComponent name (UniqueStore a)+ Field name Storing Required a = TaggedComponent name (Storage a a)+ Field name Storing Normal a = TaggedComponent name (Storage a a)++instance {-# OVERLAPS #-} (Show a) => Show (TaggedComponent (name :: Symbol) (Maybe a)) where+ show (Tagged Nothing) = ""+ show (Tagged (Just a)) = show a++-- | Plumbing class for a higher-kinded data representation of a game world.+-- | Generalisation of "Array of Structures" vs "Structure of Arrays".+class {-((CompTypeClass name a {- ,(CompTypeClassFun name a) ~ (CompType' name hkd acc p a)-})) => -} EntityProperty (name :: Symbol) (hkd :: Access -> Type) (acc :: Access) (p :: Props) (a :: Type) where+ accessor :: OpticsFor name hkd acc p a+ injectToField :: (acc ~ Individual) => a -> Field name Individual p a+ maybeGet :: (acc ~ Individual) => Field name Individual p a -> Maybe a+ {-# INLINE CONLIKE injectMaybe #-}+ injectMaybe :: (acc ~ Individual) => Maybe a -> Field name Individual p a+ injectMaybe (Just a) = injectToField @name @hkd @acc @p @a a+ injectMaybe Nothing = defaultField @name @hkd @acc @p @a++ defaultField :: (acc ~ Individual) => Field name Individual p a+ defaultStorage :: (acc ~ Storing) => Field name Storing p a+ storage :: (acc ~ Storing) => Lens' (hkd acc) (Storage a a)++instance forall name hkd a. (HasType (Field name Individual Required a) (hkd Individual), World hkd, Component a, Prop a ~ Required) => EntityProperty name hkd Individual Required a where+ {-# INLINE CONLIKE injectToField #-}+ {-# INLINE CONLIKE maybeGet #-}+ {-# INLINE CONLIKE defaultField #-}+ {-# INLINE CONLIKE accessor #-}+ injectToField = Tagged+ defaultStorage = error "what"+ maybeGet = Just . untag+ storage = error "what"+ defaultField = injectToField @name @hkd @Individual @Required @a defaultValue+ accessor =+ IndexedLens+ ( conjoined ((lens (getTyped @(TaggedComponent name a)) (\(s :: hkd Individual) (a :: TaggedComponent name a) -> setTyped a s)) . coerced) ((ilens getter (\(s :: hkd Individual) (a :: TaggedComponent name a) -> setTyped a s)) . coerced)+ )+ where+ getter :: hkd Individual -> (Entity, Field name Individual Required a)+ getter s = (s ^. entityReference, (getTyped @(TaggedComponent name a)) $ s)++{-{-# RULES "component/set . get" forall w. set accessor (view accessor w) w = w #-}++{-# RULES "component/set . get" forall v w. view accessor (set accessor v w) = v #-}-}++instance forall name hkd a. (HasType (Field name Individual Normal a) (hkd Individual), World hkd, Component a) => EntityProperty name hkd Individual Normal a where+ {-# INLINE CONLIKE injectToField #-}+ {-# INLINE CONLIKE maybeGet #-}+ {-# INLINE CONLIKE defaultField #-}+ {-# INLINE CONLIKE accessor #-}+ injectToField = Tagged . Just+ maybeGet = untag+ defaultField = Tagged Nothing+ defaultStorage = error "what"+ storage = error "what"+ accessor =+ IndexedTraversal $+ (conjoined ((lens (unTagged . boringGetter) (\(s :: hkd Individual) (a :: Maybe a) -> setTyped (Tagged @name a) s)) . _Just) ((ilens getter (\(s :: hkd Individual) (a :: TaggedComponent name (Maybe a)) -> setTyped a s)) . (coerced :: Iso' (TaggedComponent name (Maybe a)) (Maybe a)) . _Just))+ where+ boringGetter :: hkd Individual -> Field name Individual Normal a+ boringGetter s = (getTyped @(TaggedComponent name (Maybe a))) $ s+ getter :: hkd Individual -> (Entity, Field name Individual Normal a)+ getter s = (s ^. entityReference, (getTyped @(TaggedComponent name (Maybe a))) $ s)++instance forall name hkd a. (HasType (Field name Individual Unique a) (hkd Individual), World hkd, Component a) => EntityProperty name hkd Individual Unique a where+ {-# INLINE CONLIKE injectToField #-}+ {-# INLINE CONLIKE maybeGet #-}+ {-# INLINE CONLIKE defaultField #-}+ {-# INLINE CONLIKE accessor #-}+ injectToField = Tagged . Just+ maybeGet = untag+ storage = error "what"+ defaultStorage = error "what"+ defaultField = Tagged Nothing+ accessor =+ IndexedTraversal+ (conjoined ((lens (unTagged . boringGetter) (\(s :: hkd Individual) (a :: Maybe a) -> setTyped (Tagged @name a) s)) . _Just) ((ilens getter (\(s :: hkd Individual) (a :: TaggedComponent name (Maybe a)) -> setTyped a s)) . (coerced :: Iso' (TaggedComponent name (Maybe a)) (Maybe a)) . _Just))+ where+ getter :: hkd Individual -> (Entity, Field name Individual Unique a)+ getter s = (s ^. entityReference, (getTyped @(TaggedComponent name (Maybe a))) $ s)+ boringGetter :: hkd Individual -> Field name Individual Normal a+ boringGetter s = (getTyped @(TaggedComponent name (Maybe a))) $ s++instance+ {-# OVERLAPPABLE #-}+ ( OpticsFor name hkd 'Storing prop a+ ~ ReifiedIndexedTraversal' Entity (hkd 'Storing) a,+ HasType (Field name Storing prop a) (hkd Storing),+ EntityIndexedTraversable (Storage a) a,+ World hkd,+ Component a,+ Coercible (Field name 'Storing prop a) (Storage a a),+ (Field name 'Storing prop a ~ TaggedComponent name (Storage a a))+ ) =>+ EntityProperty name hkd Storing prop a+ where+ {-# INLINE CONLIKE injectToField #-}+ {-# INLINE CONLIKE accessor #-}+ {-# INLINE CONLIKE storage #-}+ injectToField = error "what"+ maybeGet = error "what"+ defaultField = error "what"+ defaultStorage = Tagged (emptyStorage @a) :: TaggedComponent name ((Storage a) a)+ storage = unwrappedField+ where+ taggedStorageField :: Lens' (hkd Storing) (Field name Storing prop a)+ taggedStorageField = (typed @(Field name Storing prop a) @(hkd Storing))+ unwrappedField :: Lens' (hkd Storing) (Storage a a)+ unwrappedField = (taggedStorageField . coerced)+ accessor = IndexedTraversal @Entity (storage @name @hkd @Storing @prop @a .> entitiesTraversed)++instance {-# OVERLAPPING #-} (Storage a a ~ UniqueStore a, HasType (Field name Storing Unique a) (hkd Storing), World hkd, Component a) => EntityProperty name hkd Storing Unique a where+ {-# INLINE CONLIKE injectToField #-}+ {-# INLINE CONLIKE accessor #-}+ {-# INLINE CONLIKE storage #-}+ injectToField = error "what"+ maybeGet = error "what"+ defaultField = error "what"+ defaultStorage = Tagged (UniqueStore Nothing)+ storage = unwrappedField+ where+ taggedStorageField :: Lens' (hkd Storing) (Field name Storing Unique a)+ taggedStorageField = (typed @(Field name Storing Unique a) @(hkd Storing))+ unwrappedField :: Lens' (hkd Storing) (UniqueStore a)+ unwrappedField = (taggedStorageField . coerced)+ accessor =+ IndexedTraversal @Entity+ ( conjoined+ (storage @name @hkd @Storing @Unique @a . (coerced :: Iso' (UniqueStore a) (Maybe (Entity, a))) . _Just . traversed)+ ((storage @name @hkd @Storing @Unique @a :: Lens' (hkd Storing) (UniqueStore a)) . (coerced :: Iso' (UniqueStore a) (Maybe (Entity, a))) . _Just .> itraversed)+ )
+ src/Games/ECS/Component/Store.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module : Games.ECS.Component.Store+-- Description : Collection types for components.+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Different components, when stored in bulk, may be suited to different collection types.+module Games.ECS.Component.Store+ ( EntityIndexedTraversable (..),+ InternedComponentStore,+ ComponentStore,+ EntitySet,+ theKeys,+ theMap,+ theInternedMap,+ IntersectionOfEntities,+ )+where++import Control.Lens+import Data.Hashable+import Data.IntMap.Strict qualified as IM+import Data.IntSet qualified as IS+import Data.Interned+import GHC.Generics (Generic, Generic1)+import Games.ECS.Entity++-- | A class for types which contain objects which are indexed by an 'Entity'.+class EntityIndexedTraversable t c where -- TODO make this kind polymorphic++ -- | Traverse the collection.+ entitiesTraversed :: IndexedTraversal' Entity (t c) c+ default entitiesTraversed :: (TraversableWithIndex Entity t) => IndexedTraversal' Entity (t c) c+ entitiesTraversed = itraversed+ {-# INLINE entitiesTraversed #-}++-- | An 'IS.IntMap'-based 'Games.ECS.Component.Component' store+data ComponentStore c = ComponentStore {_theMap :: IM.IntMap c, _theKeys :: EntitySet} deriving (Eq, Show, Functor, Generic1, Foldable, Traversable, Generic)++-- deriving instance Generic (ComponentStore c)+instance FunctorWithIndex Entity (ComponentStore) where+ {-# INLINE imap #-}+ imap f (ComponentStore s ks) = ComponentStore (IM.mapWithKey (f . EntRef) s) ks++instance EntityIndexedTraversable ComponentStore c++instance FoldableWithIndex Entity ComponentStore where+ {-# INLINE ifoldMap #-}+ {-# INLINE ifoldr #-}+ {-# INLINE ifoldl' #-}+ ifoldMap f (ComponentStore s _) = IM.foldMapWithKey (f . EntRef) s+ ifoldr f b (ComponentStore s _) = IM.foldrWithKey (f . EntRef) b s+ ifoldl' f b (ComponentStore s _) = IM.foldlWithKey' (flip (f . EntRef)) b s++instance TraversableWithIndex Entity ComponentStore where+ {-# INLINE itraverse #-}+ itraverse f (ComponentStore s ks) = fmap (\i -> ComponentStore i ks) $ itraverse (f . EntRef) s++type instance Index (ComponentStore c) = Entity++type instance IxValue (ComponentStore c) = c++instance At (ComponentStore c) where+ {-# INLINE at #-}+ at (EntRef k) f cs@(ComponentStore s (EntitySet ks)) =+ f mv <&> \r -> case r of+ Nothing -> maybe cs (const (ComponentStore (IM.delete k s) (EntitySet (IS.delete k ks)))) mv+ Just v' -> ComponentStore (IM.insert k v' s) (EntitySet (IS.insert k ks))+ where+ mv = IM.lookup k s++instance Ixed (ComponentStore c) where+ {-# INLINE ix #-}+ ix (EntRef k) f (ComponentStore s ks) = fmap (\i -> ComponentStore i ks) $ ix k f s++instance AsEmpty (ComponentStore c) where+ {-# INLINE _Empty #-}+ _Empty = nearly (ComponentStore IM.empty (EntitySet IS.empty)) (\(ComponentStore _ (EntitySet ks)) -> IS.null ks)++makeLenses ''ComponentStore++instance HasEntitySet (ComponentStore c) where+ {-# INLINE entitySet #-}+ entitySet = theKeys++data InternedComponent c = InternedComponent {_internedId :: Id, _internedValue :: c} deriving (Generic, Show)++instance Eq (InternedComponent c) where+ {-# INLINE (==) #-}+ InternedComponent a _ == InternedComponent b _ = a == b++instance Ord (InternedComponent c) where+ {-# INLINE compare #-}+ compare (InternedComponent a _) (InternedComponent b _) = compare a b++instance Hashable (InternedComponent c) where+ {-# INLINE hashWithSalt #-}+ hashWithSalt s (InternedComponent i _) = hashWithSalt s i++instance (Hashable c, Eq c) => Interned (InternedComponent c) where+ type Uninterned (InternedComponent c) = c+ newtype Description (InternedComponent c) = DSC c deriving (Eq)+ {-# INLINE CONLIKE describe #-}+ describe = DSC+ {-# INLINE CONLIKE identify #-}+ identify = InternedComponent+ {-# INLINE CONLIKE cache #-}+ cache = itCache++itCache :: (Eq c, Hashable c) => Cache (InternedComponent c)+itCache = mkCache+{-# NOINLINE itCache #-}++instance (Hashable c) => Hashable (Description (InternedComponent c)) where+ hashWithSalt s (DSC c) = hashWithSalt s c+ {-# INLINE hashWithSalt #-}++instance (Eq c, Hashable c) => Uninternable (InternedComponent c) where+ unintern (InternedComponent _ c) = c+ {-# INLINE unintern #-}++-- | Some components may be shared in common among a large number of entities, and may be expensive to compare for equality. This type can be used to store them efficiently by keeping only a single example around.+data InternedComponentStore c = InternedComponentStore {_theInternedMap :: IM.IntMap (InternedComponent c), _theInternedKeys :: EntitySet} deriving (Eq, Show, Generic, Generic1)++type instance Index (InternedComponentStore c) = Entity++type instance IxValue (InternedComponentStore c) = c++instance (Eq c, Hashable c) => At (InternedComponentStore c) where+ {-# INLINE at #-}+ at (EntRef k) f cs@(InternedComponentStore s (EntitySet ks)) =+ f mv <&> \r -> case r of+ Nothing -> maybe cs (const (InternedComponentStore (IM.delete k s) (EntitySet (IS.delete k ks)))) mv+ Just v' -> InternedComponentStore (IM.insert k (intern v') s) (EntitySet (IS.insert k ks))+ where+ mv = fmap unintern $ IM.lookup k s++instance (Eq c, Hashable c) => Ixed (InternedComponentStore c) where+ {-# INLINE ix #-}+ ix (EntRef k) f (InternedComponentStore s ks) = fmap (\i -> InternedComponentStore i ks) $ ix k (fmap intern . f . unintern) s++instance AsEmpty (InternedComponentStore c) where+ {-# INLINE _Empty #-}+ _Empty = nearly (InternedComponentStore IM.empty (EntitySet IS.empty)) (\(InternedComponentStore _ (EntitySet ks)) -> IS.null ks)++makeLenses ''InternedComponentStore++{-# INLINE toNormalCS #-}+toNormalCS :: (Uninternable (InternedComponent c)) => InternedComponentStore c -> ComponentStore c+toNormalCS (InternedComponentStore ics iks) = ComponentStore (fmap unintern ics) iks++{-# INLINE toInternedCS #-}+toInternedCS :: (Interned (InternedComponent c)) => ComponentStore c -> InternedComponentStore c+toInternedCS (ComponentStore cs ks) = InternedComponentStore (fmap intern cs) ks++internedComponentStore :: (Uninternable (InternedComponent c)) => Iso' (ComponentStore c) (InternedComponentStore c)+internedComponentStore = iso toInternedCS toNormalCS+{-# INLINE internedComponentStore #-}++instance HasEntitySet (InternedComponentStore c) where+ {-# INLINE entitySet #-}+ entitySet = theInternedKeys++instance (Uninternable (InternedComponent c)) => EntityIndexedTraversable InternedComponentStore c where+ {-# INLINE entitiesTraversed #-}+ entitiesTraversed = (from internedComponentStore) . entitiesTraversed
+ src/Games/ECS/Component/TH.hs view
@@ -0,0 +1,14 @@+-- |+-- Module : Games.ECS.Component.TH+-- Description : Template Haskell derivation of Component classes+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Implements helper classes and constraints on components.++module Games.ECS.Component.TH (module Games.ECS.Component.TH.Internal) where++import Games.ECS.Component.TH.Internal (makeHasComponentClass)
+ src/Games/ECS/Component/TH/Internal.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module : Games.ECS.Component.TH.Internal+-- Description : Template Haskell derivation of Component classes+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Implements helper classes and constraints on components.+module Games.ECS.Component.TH.Internal+ ( makeHasComponentClass,+ makeComponentAccessor,+ makeConstructorPatternAndValuePair,+ )+where++import Control.Lens+import Data.Char+import Data.List+import Data.Maybe (fromMaybe)+import Games.ECS.Component+import Games.ECS.Entity+import Games.ECS.Slot+import Games.ECS.World+import Language.Haskell.TH+import Language.Haskell.TH.Datatype qualified as D+import Language.Haskell.TH.Syntax++-- | Forms the accessor optic based on the properties of the component.+accessorBuilder :: (Quote m) => m Type -> m Type -> m Type -> m Type -> m Exp+accessorBuilder hkd name s a = [|runIndexedTraversal $ accessor @($name) @($hkd) @($s) @(Prop $a) @($a)|]++normalName :: Name+normalName = 'Normal++uniqueName :: Name+uniqueName = 'Unique++requiredName :: Name+requiredName = 'Required++-- | Computes the name for a \"classy optics\" style class.+makeHasComponentClassName :: String -> Name+makeHasComponentClassName name = mkName $ "Has" ++ [toUpper (head name)] ++ tail name++-- | Computes the name for the \"Using\" type synonyms.+makeUsingComponentClassName :: String -> Name+makeUsingComponentClassName name = mkName $ "Using" ++ [toUpper (head name)] ++ tail name++-- | Creates the \"classy optics\" class, and the \"Using\" type synonym, matching a 'Component'.+makeHasComponentClass :: (MonadFail m, Quote m, Quasi m) => Name -> m [Dec]+makeHasComponentClass componentName = do+ componentType <- conT componentName+ -- Look up the "CanonicalName" associated type to get the standard name used to reference the component+ componentInstance <- runQ $ reifyInstances ''Games.ECS.Component.CanonicalName [componentType]+ case componentInstance of+ [] -> fail ("No Component.CanonicalName instance found for " ++ (show componentName) ++ "!")+ [_canonicalNameDec@(TySynInstD (TySynEqn _ _ canonicalNameType@(LitT (StrTyLit canonicalName))))] -> do+ let hasComponentClassName = makeHasComponentClassName canonicalName+ let worldTypeName = mkName "worldType"+ -- We need this type var for the HKD optics lookup fuckery+ let s = varT $ mkName "s"+ worldType <- varT worldTypeName+ let worldType' = pure worldType+ componentType' = pure componentType+ canonicalNameType' = pure canonicalNameType++ classSignatures <- makeRawComponentAccessorSignatures (pure worldType) canonicalNameType (pure componentType)+ -- Not sure we really need /all/ of this, but it works.+ classContext <-+ [t|+ ( World $worldType',+ Component $componentType',+ EntityProperty $canonicalNameType' $worldType' Individual (Prop $componentType') $componentType',+ OpticsFor $canonicalNameType' $worldType' Storing (Prop $componentType') $componentType'+ ~ ReifiedIndexedTraversal' Entity ($worldType' Storing) $componentType'+ )+ |]+ -- Declare the actual "Has<xyz>" class, with the adder and remover functions, and the accessing optic+ classDec <- classD (pure [classContext]) hasComponentClassName [PlainTV worldTypeName BndrReq] [] (fmap pure classSignatures)++ -- Create the "Using<xyz>" type synonym.+ useComponentDecType <-+ [t|+ ( $(conT hasComponentClassName) $worldType',+ EntityProperty $canonicalNameType' $worldType' $s (Prop $componentType') $componentType',+ OpticsFor $canonicalNameType' $worldType' $s (Prop $componentType') $componentType'+ ~ ReifiedIndexedTraversal' Entity ($worldType' $s) $componentType'+ )+ |]+ -- The "Using<xyz>" type synonym has two type parameters: The world type, and the storage variable. The+ -- storage variable depends on whether you're accessing individual entity components or the storage of+ -- components.+ useComponentDec <- tySynD (makeUsingComponentClassName canonicalName) [PlainTV worldTypeName BndrReq, PlainTV (mkName "s") BndrReq] (pure useComponentDecType)+ pure [classDec, useComponentDec]+ _ -> fail ("Error while processing Component.CanonicalName instance for " ++ show componentName ++ "!")++-- | Create the accessing functions/optic signatures for a given component.+makeRawComponentAccessorSignatures :: (MonadFail m, Quote m) => m Type -> Type -> m Type -> m [Dec]+makeRawComponentAccessorSignatures worldType canonicalNameType'@(LitT (StrTyLit name')) componentType = do+ let nameType = pure canonicalNameType'+ -- The component type+ s' = mkName "s"+ s = varT s'+ namedOptic = mkName name'++ entitiesWithSig <-+ sigD+ (makeWithName name')+ [t|+ Control.Lens.Fold ($worldType Storing) IntersectionOfEntities+ |]+ adderSig <-+ sigD+ (makeAdderName name')+ [t|+ Control.Lens.IndexedSetter' Entity ($worldType Individual) $componentType+ |]++ removerSig <-+ sigD+ (makeRemoverName name')+ [t|+ $worldType Individual -> $worldType Individual+ |]+ context <-+ [t|+ ( EntityProperty $nameType $worldType $s (Prop $componentType) $componentType,+ OpticsFor $nameType $worldType $s (Prop $componentType) $componentType+ ~ ReifiedIndexedTraversal' Entity ($worldType $s) $componentType+ )+ |]+ theSignature <-+ sigD+ namedOptic+ ( forallT+ [PlainTV s' inferredSpec]+ (pure [context])+ [t|+ IndexedTraversal' Entity ($worldType $s) $componentType+ |]+ )++ pure [theSignature, adderSig, removerSig, entitiesWithSig]+makeRawComponentAccessorSignatures _ _ _ = fail "Mischief afoot with makeRawComponentAccessorSignatures"++-- | Computes the name for a component remover function, with a given postfix.+makeRemoverName' :: String -> String -> Name+makeRemoverName' postfix name =+ mkName $ "remove" ++ [toUpper (head name)] ++ tail name ++ postfix++-- | Computes the name for a component remover function.+makeRemoverName :: String -> Name+makeRemoverName = makeRemoverName' ""++-- | Computes the name for a component addition function, with a given postfix.+makeAdderName' :: String -> String -> Name+makeAdderName' postfix name = mkName $ "add" ++ [toUpper (head name)] ++ tail name ++ postfix++-- | Computes the name for a component addition function.+makeAdderName :: String -> Name+makeAdderName = makeAdderName' ""++-- | Computes the name for a "withComponent" function, with a given postfix.+makeWithName' :: String -> String -> Name+makeWithName' postfix name = mkName $ "with" ++ [toUpper (head name)] ++ tail name ++ postfix++makeWithName :: String -> Name+makeWithName = makeWithName' ""++-- | Make the instance for the \"classy optics\" for a given world and canonically named component. We make+-- the bodies for the optics for accessing components, as well as (law-breaking?) setters that create them if+-- they're missing.+makeComponentAccessor :: (Quasi m, Quote m) => D.ConstructorInfo -> m Type -> (Type, Type, Type) -> m [Dec]+makeComponentAccessor constructorInfo worldType tys@(nameType'@(LitT (StrTyLit name')), a', _) = do+ let nameType = pure nameType'+ -- name = pure @Q name'+ a = pure a' -- The component type+ s' = mkName "s"+ s = varT s'+ namedOptic = mkName name'+ built = accessorBuilder worldType nameType s a+ -- fieldType <- [t|Field $nameType $s (Prop $a) $a|]+ sigs <- makeRawComponentAccessorSignatures worldType nameType' a+ theBody <- funD namedOptic [clause [] (normalB built) []]++ let adderPat = varP (makeAdderName name')+ removerPat = varP (makeRemoverName name')+ withPat = varP (makeWithName name')++ let setterPat =+ [|+ setTyped @(Field $nameType Individual (Prop $a) $a) @($worldType Individual) . injectToField @($nameType) @($worldType) @Individual @(Prop $a)+ |]+ let removerLambda =+ [|+ setTyped @(Field $nameType Individual (Prop $a) $a) @($worldType Individual) (defaultField @($nameType) @($worldType) @Individual @(Prop $a))+ |]++ adderInlinePragma <- pragInlD (makeAdderName name') Inline FunLike AllPhases+ removerInlinePragma <- pragInlD (makeRemoverName name') Inline FunLike AllPhases+ withComonentInlinePragma <- pragInlD (makeWithName name') Inline FunLike AllPhases+ opticInlinePragma <- pragInlD namedOptic Inline ConLike AllPhases++ {- clset <- [|set|]+ clview <- [|view |]+ let worldRuleBinderType = typedRuleVar (mkName "w") (appT worldType s)+ sRuleType = typedRuleVar s' s+ opticAccessorForRule = varE namedOptic+ wName = mkName "w"+ lhsExpr = AppE (AppE (AppE clset (VarE namedOptic)) (AppE (AppE clview (VarE namedOptic)) (VarE wName))) (VarE wName)+ --(appE (appE [|set|] ( [|($opticAccessorForRule)|])) [|(view ($opticAccessorForRule) w) w|])+ opticRule <- pragRuleD (name' ++ "/set . get") [worldRuleBinderType] (pure lhsExpr) [|w|] AllPhases -}+ --+ -- [d| {-# RULES "component/set . get" forall w . set $(opticAccessorForRule) (view $(opticAccessorForRule) w) w = w #-} |] -- TODO get proper component name --+ withComponent <-+ [d|$withPat = storage @($nameType) @($worldType) @Storing @(Prop $a) @($a) . entityKeys . from asIntersection|]++ componentAdder <-+ [d|+ $adderPat = conjoined (sets (\f ent -> $setterPat (error ("Entity " ++ show ent ++ " never had its " ++ name' ++ " set!")) ent & $(varE namedOptic) %~ f)) (isets (\f ent -> $setterPat (error ("Entity " ++ show ent ++ " never had its " ++ name' ++ " set!")) ent & $(varE namedOptic) %@~ f))+ |]+ componentRemover <-+ [d|+ $removerPat = $removerLambda+ |]++ let className = makeHasComponentClassName name'+ classInstanceContext = pure []+ classInstanceType = (conT className) `appT` worldType+ classInstance <- instanceD classInstanceContext classInstanceType (fmap pure (componentAdder <> componentRemover <> sigs <> withComponent <> [theBody, withComonentInlinePragma, adderInlinePragma, removerInlinePragma, opticInlinePragma]))+ hasTypeInstance <- makeHasTypeInstance constructorInfo worldType tys+ pure ([classInstance {-, opticRule-}] ++ hasTypeInstance)+makeComponentAccessor _ _ _ = fail "Mischief afoot with makeComponentAccessor"++-- | This is so we do not have to use the Generics-based functions which use indexing, and so are hella slow. At this point, we do not need the generic-lens package at all.+makeHasTypeInstance :: (Quasi m, Quote m) => D.ConstructorInfo -> m Type -> (Type, Type, Type) -> m [Dec]+makeHasTypeInstance constructorInfo worldType (nameType'@(LitT (StrTyLit name')), a', s') = do+ let nameType = pure nameType'+ a = pure a' -- The component type+ fieldType <- [t|Games.ECS.Component.AComponent $nameType $(pure s') $a|]+ let fieldPosition' = elemIndex ((show . ppr) fieldType) (fmap (show . ppr) $ D.constructorFields constructorInfo)+ fieldPosition = fromMaybe (error ((show fieldType) ++ (show constructorInfo))) fieldPosition'+ (getterBindingVar, consPat, valP, _, setterPattern) = makeConstructorPatternAndValuePair constructorInfo fieldPosition++ componentInstances <- runQ $ reifyInstances ''Prop [a']+ case componentInstances of+ [] -> fail ("No Component instance found for " ++ name' ++ ". Don't forget to also call makeHasComponentClass!")+ [TySynInstD (TySynEqn _bndrs _lhs (PromotedT prop))] -> do+ theInstance <- theInstanceFunc prop nameType consPat getterBindingVar valP setterPattern a+ pure theInstance+ _ -> fail ("Weird Component instance found for " ++ name' ++ ". Don't forget to also call makeHasComponentClass!")+ where+ theInstanceFunc p nameType consPat getterBindingVar valP setterPattern a+ | p == requiredName =+ [d|+ instance {-# OVERLAPS #-} (Prop $a ~ Required) => Games.ECS.Slot.HasType (TaggedComponent $nameType $a) ($worldType Individual) where+ {-# INLINE CONLIKE typed #-}+ -- typed :: (Prop $a ~ Required) => Lens' ($worldType Individual) (Tagged $nameType $a)+ typed = Control.Lens.lens getTyped (flip setTyped)++ -- getTyped :: (Prop $a ~ Required) => $worldType Individual -> (Tagged $nameType $a)+ {-# INLINE CONLIKE getTyped #-}+ getTyped $consPat = $getterBindingVar+ {-# INLINE CONLIKE setTyped #-}+ setTyped $valP $consPat = $setterPattern+ |]+ theInstanceFunc p nameType consPat getterBindingVar valP setterPattern a+ | p == normalName =+ [d|+ instance {-# OVERLAPS #-} (Prop $a ~ Normal) => Games.ECS.Slot.HasType (TaggedComponent $nameType (Maybe $a)) ($worldType Individual) where+ {-# INLINE CONLIKE typed #-}+ -- typed :: (Prop $a ~ Normal) => Lens' ($worldType Individual) (Tagged $nameType (Maybe $a))+ typed = Control.Lens.lens getTyped (flip setTyped)++ -- getTyped :: (Prop $a ~ Normal) => $worldType Individual -> (Tagged $nameType (Maybe $a))+ {-# INLINE CONLIKE getTyped #-}+ getTyped $consPat = $getterBindingVar+ {-# INLINE CONLIKE setTyped #-}+ setTyped $valP $consPat = $setterPattern++ instance {-# OVERLAPS #-} (Prop $a ~ Normal, Storage $a ~ saa) => Games.ECS.Slot.HasType (TaggedComponent $nameType (saa $a)) ($worldType Storing) where+ {-# INLINE CONLIKE typed #-}+ -- typed :: (Prop $a ~ Normal) => Lens' ($worldType Storing) (Tagged $nameType (Storage $a $a))+ typed = Control.Lens.lens getTyped (flip setTyped)++ -- getTyped :: (Prop $a ~ Normal) => $worldType Storing -> (Tagged $nameType (Storage $a $a))+ {-# INLINE CONLIKE getTyped #-}+ getTyped $consPat = $getterBindingVar+ {-# INLINE CONLIKE setTyped #-}+ setTyped $valP $consPat = $setterPattern+ |]+ theInstanceFunc p nameType consPat getterBindingVar valP setterPattern a+ | p == uniqueName =+ [d|+ instance {-# OVERLAPS #-} (Prop $a ~ Games.ECS.World.Unique) => Games.ECS.Slot.HasType (TaggedComponent $nameType (Maybe $a)) ($worldType Individual) where+ {-# INLINE CONLIKE typed #-}+ -- typed :: (Prop $a ~ Games.ECS.World.Unique) => Lens' ($worldType Individual) (Tagged $nameType (Maybe $a))+ typed = Control.Lens.lens getTyped (flip setTyped)++ -- getTyped :: (Prop $a ~ Games.ECS.World.Unique) => $worldType Individual -> (Tagged $nameType (Maybe $a))+ {-# INLINE CONLIKE getTyped #-}+ getTyped $consPat = $getterBindingVar+ {-# INLINE CONLIKE setTyped #-}+ setTyped $valP $consPat = $setterPattern++ instance {-# OVERLAPS #-} (Prop $a ~ Games.ECS.World.Unique) => Games.ECS.Slot.HasType (TaggedComponent $nameType (UniqueStore $a)) ($worldType Storing) where+ {-# INLINE CONLIKE typed #-}+ -- typed :: (Prop $a ~ Games.ECS.World.Unique) => Lens' ($worldType Storing) (Tagged $nameType (UniqueStore $a))+ typed = Control.Lens.lens getTyped (flip setTyped)++ -- getTyped :: (Prop $a ~ Games.ECS.World.Unique) => $worldType Storing -> (Tagged $nameType (UniqueStore $a))+ {-# INLINE CONLIKE getTyped #-}+ getTyped $consPat = $getterBindingVar+ {-# INLINE CONLIKE setTyped #-}+ setTyped $valP $consPat = $setterPattern+ |]+ theInstanceFunc _ nameType _ _ _ _ _ = do+ theName <- nameType+ fail ("Weird stuff is going on when creating HasType instance for " ++ (show theName) ++ "!")+makeHasTypeInstance _ worldType _ = do+ worldTy <- worldType+ fail ("Error while creating HasType instance for " ++ show worldTy ++ "!")++makeConstructorPatternAndValuePair :: (Quote m) => D.ConstructorInfo -> Int -> (m Exp, m Pat, m Pat, m Exp, m Exp)+makeConstructorPatternAndValuePair constructorInfo fieldPosition = (getterBindingVar, consPat, valP, valE, setterPattern)+ where+ valName = mkName "val"+ valE = varE valName+ valP = (tildeP . varP) valName+ numFields = length (D.constructorFields constructorInfo)+ fieldNames = fmap (\i -> mkName ("_theField" ++ show i)) [0 .. (numFields - 1)]+ fieldPatterns = fmap (tildeP . varP) fieldNames+ consPat = conP (D.constructorName constructorInfo) fieldPatterns+ getterBindingVar = varE (fieldNames !! fieldPosition)+ prefix = fmap varE (take fieldPosition fieldNames)+ mid = prefix ++ [valE]+ postfix = mid ++ fmap varE (drop (fieldPosition + 1) fieldNames)+ setterPattern = foldl appE (conE (D.constructorName constructorInfo)) postfix
+ src/Games/ECS/Entity.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Games.ECS.Entity+-- Description : Entity references.+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- In an ECS, an /entity/ is understood in two senses:+--+-- 1. An identifying token, used to specify an /individual/, and+-- 2. The /individual/ it refers to, that is, the set of components it has.+--+-- Here, we implement entities in the first sense.+module Games.ECS.Entity+ ( Entity (..),+ HasEntityReferences (..),+ EntitySet (EntitySet),+ theEntitySet,+ singletonEntitySet,+ asIntersection,+ IntersectionOfEntities (Intersect),+ IsEntityStore (..),+ HasEntitySet (..),+ )+where++import Control.Lens+import Data.Coerce+import Data.HashMap.Strict as HMS+import Data.HashSet qualified as HS+import Data.Hashable+import Data.Int+import Data.IntSet qualified as IS+import Data.IntSet.Lens+import Data.Ix+import Data.String+import Data.Vector.Unboxed.Deriving+import GHC.Generics+import Games.ECS.Serialisation+import System.ByteOrder++-- | A reference to an entity in the ECS.+newtype Entity = EntRef {unEntRef :: Int}+ deriving newtype (Eq, Ord, Enum, Bounded, Ix)+ deriving newtype (XMLPickleAsAttribute)+ deriving stock (Generic)++instance {-# OVERLAPS #-} XMLPickler [Node] Entity where+ {-# INLINE xpickle #-}+ xpickle = ("Entity w/ attribute", "") <?+> (xpElemAttrs "entity" (xpAttribute "entRef" (xpWrap EntRef unEntRef xpPrim)))++-- | An instance for constructors which only contain an entity reference; we put that as an attribute.+instance {-# OVERLAPPING #-} (Constructor c'', ty ~ (M1 C c'' (M1 S c (K1 i Entity)))) => GXmlPickler [Node] (M1 C c'' (M1 S c (K1 i Entity))) where+ {-# INLINE gxpickleContentsf #-}+ gxpickleContentsf _ = ("Entity reference wrapper", "") <?+> (xpElemAttrs (fromString . formatElement $ conName (undefined :: ty p)) (xpWrap (M1 . M1 . K1) (unK1 . unM1 . unM1) (pickleAsAttribute "entRef")))++-- | We reverse the byte order, just so there is a bit more variance between hashes.+instance Hashable Entity where+ {-# INLINE hash #-}+ hash (EntRef i) = hash $ toBigEndian @Int64 (fromIntegral i)+ {-# INLINE hashWithSalt #-}+ hashWithSalt salt (EntRef i) = hashWithSalt salt (toBigEndian @Int64 (fromIntegral i))++instance Show Entity where+ {-# INLINE show #-}+ show (EntRef ref) = "EntRef: " ++ show ref++instance {-# OVERLAPPABLE #-} (XMLPickler [Node] v) => XMLPickler [Node] (HashMap Entity v) where+ {-# INLINE xpickle #-}+ xpickle =+ ("Entity-indexed HashMap", "")+ <?+> ( xpWrap HMS.fromList HMS.toList $+ xpAll $+ xpElem "li" (pickleAsAttribute "entRef") xpickle+ )++-- | A helper class for finding embedded entity references in components.+class HasEntityReferences c where+ getEntityReferences :: Fold c Entity++instance HasEntityReferences Entity where+ {-# INLINE getEntityReferences #-}+ getEntityReferences = id++-- | An efficient storage for a collection of entities.+newtype EntitySet = EntitySet {_theEntitySet :: IS.IntSet}+ deriving newtype (Eq, Show, Semigroup, Monoid)++instance HasEntityReferences EntitySet where+ {-# INLINE getEntityReferences #-}+ getEntityReferences = coerced . members . Control.Lens.to EntRef++makeLensesWith (lensRules & generateSignatures .~ False) ''EntitySet++-- | Access the underlying 'IS.IntSet'.+theEntitySet :: Iso' EntitySet IS.IntSet++{-# INLINE singletonEntitySet #-}++-- | Construct a new t'EntitySet' with a given 'Entity'.+singletonEntitySet :: Entity -> EntitySet+singletonEntitySet (EntRef k) = EntitySet (IS.singleton k)++{-# INLINE asIntersection #-}++-- | Helper `Iso'` for selecting entities which satisfy predicates.+asIntersection :: Iso' IntersectionOfEntities EntitySet+asIntersection = iso (\case Intersect es -> EntitySet es) (Intersect . _theEntitySet)++-- | A helper 'Monoid' for selecting entities which satisfy multiple predicates.+newtype IntersectionOfEntities = Intersect {_unIntersect :: IS.IntSet} deriving stock (Eq, Show)++instance Semigroup IntersectionOfEntities where+ {-# INLINE (<>) #-}+ (Intersect a) <> (Intersect b) = Intersect (IS.intersection a b)++instance Monoid IntersectionOfEntities where+ mempty = error "mempty IntersectionOfEntities"++-- | Generalisation of an t'EntitySet'.+class IsEntityStore a where+ -- | 'Control.Lens.Type.Fold' over each 'Entity' it holds.+ knownEntities :: Fold a Entity++ -- | Empty storage.+ blankEntityStorage :: a++instance IsEntityStore (HS.HashSet Entity) where+ {-# INLINE knownEntities #-}+ knownEntities = folded+ blankEntityStorage = HS.empty++instance IsEntityStore IS.IntSet where+ {-# INLINE knownEntities #-}+ knownEntities = members . coerced @Int @Int @Entity @Entity+ blankEntityStorage = IS.empty++instance IsEntityStore EntitySet where+ {-# INLINE knownEntities #-}+ knownEntities = theEntitySet . knownEntities+ blankEntityStorage = EntitySet blankEntityStorage++instance IsEntityStore IntersectionOfEntities where+ {-# INLINE knownEntities #-}+ knownEntities = asIntersection . knownEntities+ blankEntityStorage = Intersect blankEntityStorage++derivingUnbox+ "Entity"+ [t|Entity -> Int|]+ [|coerce|]+ [|coerce|]++-- | For types which may have one or more t'EntitySet'.+class HasEntitySet a where+ entitySet :: Fold a EntitySet++instance HasEntitySet EntitySet where+ {-# INLINE entitySet #-}+ entitySet = simple++instance HasEntitySet IntersectionOfEntities where+ {-# INLINE entitySet #-}+ entitySet = asIntersection
+ src/Games/ECS/MessageQueue.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+-- For Empty and :<+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}++-- |+-- Module : Games.ECS.MessageQueue+-- Description : A simple message queue implementation.+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Implements a simple message queuing system.+module Games.ECS.MessageQueue+ ( MessageQueue,+ -- queue,+ newMessageQueue,+ MonadAtomicMessageQueue (..),+ queueMessage,+ queueImmediateMessage,+ queueMessages,+ readMessage,+ processMessageQueue,+ MessagesProcessed (..),+ )+where++import Control.Lens+import Control.Monad+import Data.Hashable+import Data.Sequence (Seq, singleton)+import Data.Tuple (swap)+import GHC.Generics+import GHC.Types (SPEC (..))+import Games.ECS.Util.Misc+import Games.ECS.World++data DelayedOrNot+ = NotDelayed+ | Delayed+ deriving stock (Eq, Generic)+ deriving anyclass (Hashable)++-- | The core message queue type.+newtype MessageQueue a = MessageQueue {_queue :: Seq (DelayedOrNot, a)} deriving stock (Eq, Generic)++makeLenses ''MessageQueue++-- | Construct a new, empty t'MessageQueue'.+{-# INLINE newMessageQueue #-}+newMessageQueue :: MessageQueue a+newMessageQueue = let q = Empty in MessageQueue q++instance (Hashable a) => Hashable (MessageQueue a) where+ {-# INLINE hashWithSalt #-}+ hashWithSalt salt (MessageQueue q) = hashWithSalt salt (HashableSeq q)++-- | Monads which can atomically modify a t'MessageQueue'.+class (Monad m) => MonadAtomicMessageQueue a m where+ -- | Monadically perform a given state transition atomically on the t'MessageQueue', and return the result.+ stateMessageQueue :: (MessageQueue a -> (MessageQueue a, val)) -> m val++ -- | Atomically modify a t'MessageQueue'.+ modifyMessageQueue :: (MessageQueue a -> MessageQueue a) -> m ()++{-# INLINEABLE queueMessage #-}++-- | Queue message+queueMessage :: forall a m. (MonadAtomicMessageQueue a m) => a -> m ()+queueMessage msg = do+ modifyMessageQueue (\q -> q & queue %~ (|> (NotDelayed, msg)))++{-# INLINEABLE queueImmediateMessage #-}++-- | Push a message on to the front of the queue.+queueImmediateMessage :: forall a m. (MonadAtomicMessageQueue a m) => a -> m ()+queueImmediateMessage msg = do+ modifyMessageQueue (\q -> q & queue %~ ((NotDelayed, msg) <|))++{-# INLINEABLE queueMessages #-}++-- | Queue a series of messages+queueMessages :: (Foldable f, MonadAtomicMessageQueue a m) => f a -> m ()+queueMessages msgs = forM_ msgs queueMessage++{-# INLINEABLE readMessage #-}++-- | Pops the message queue+readMessage :: (MonadAtomicMessageQueue a m) => (a -> Bool) -> m (Maybe a)+readMessage shouldSkip =+ stateMessageQueue+ ( \(MessageQueue msgs) -> swap . fmap (MessageQueue . fmap clearDelayed) . go $ msgs+ )+ where+ clearDelayed (Delayed, a) = (NotDelayed, a)+ clearDelayed x = x+ go Empty = (Nothing, Empty)+ go ((NotDelayed, a) :< rest)+ | shouldSkip a = fmap ((Delayed, a) <|) (go rest)+ | otherwise = (Just a, rest)+ go ((Delayed, a) :< rest) = fmap ((Delayed, a) <|) (go rest)++-- | Which messages were processed.+data MessagesProcessed a+ = AllMessagesProcessed+ | NewMessagesProcessed !(Seq a)+ deriving stock (Eq, Generic, Show)++instance (Hashable a) => Hashable (MessagesProcessed a) where+ {-# INLINE hashWithSalt #-}+ hashWithSalt salt AllMessagesProcessed = hashWithSalt salt (0 :: Int)+ hashWithSalt salt (NewMessagesProcessed msgs) = (salt `hashWithSalt` (1 :: Int)) `hashWithSalt` HashableSeq msgs++instance Semigroup (MessagesProcessed a) where+ {-# INLINE (<>) #-}+ AllMessagesProcessed <> (NewMessagesProcessed Empty) = AllMessagesProcessed+ AllMessagesProcessed <> b = b+ (NewMessagesProcessed Empty) <> AllMessagesProcessed = AllMessagesProcessed+ a <> AllMessagesProcessed = a+ (NewMessagesProcessed a) <> (NewMessagesProcessed b) = NewMessagesProcessed (a <> b)++instance Monoid (MessagesProcessed a) where+ {-# INLINEABLE mempty #-}+ mempty = AllMessagesProcessed++{-# INLINEABLE processMessageQueue #-}++-- | Processes a message queue until it's empty.+processMessageQueue ::+ forall world a m.+ (MonadAtomicMessageQueue a m) =>+ -- | Predicate on whether a message should be skipped this time round, and left in the queue.+ (world Storing -> a -> Bool) ->+ -- | How to process an individual message.+ (world Storing -> a -> m (world Storing)) ->+ -- | The world.+ world Storing ->+ m (MessagesProcessed a, world Storing)+processMessageQueue shouldSkip processMsg oldWorld = processNextMessage SPEC mempty oldWorld+ where+ -- Process the message queue one at a time. Because it only ever locks the message queue long enough to+ -- pop it, messages can safely enqueue other messages.+ processNextMessage !sPEC doneMessages world = do+ nextMessage <- readMessage (shouldSkip world)+ case nextMessage of+ -- The queue is empty or has no messages available to process; return the list of effects we processed and the updated world+ Nothing -> pure (doneMessages, world)+ -- We've popped another effect off of the queue. Process it, then process the rest of the queue+ Just msg -> do+ processedNewWorld <- processMsg world msg+ processNextMessage sPEC (doneMessages <> (NewMessagesProcessed (singleton msg))) processedNewWorld
+ src/Games/ECS/Prototype.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module : Games.ECS.Prototype+-- Description : Prototype definitions+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Prototypes are exemplar individuals which form a template.+module Games.ECS.Prototype where++import Control.Exception.Assert.Sugar+import Control.Lens+import Control.Monad.IO.Class+import Data.Coerce+import Data.HashMap.Strict qualified as HMS+import Data.Hashable+import Data.Ix+import Data.Vector.Unboxed.Deriving+import GHC.Generics+import Games.ECS.Component+import Games.ECS.Component.TH+import Games.ECS.Entity+import Games.ECS.Serialisation+import Games.ECS.World++-- | A prototype's ID is distinct from its entity reference in that it is stable, and in a unique namespace.+newtype PrototypeID = PrototypeID {_unPrototypeID :: Int}+ deriving newtype (Eq, Ord, Enum, Bounded, Ix)+ deriving newtype (XMLPickleAsAttribute)+ deriving stock (Generic)+ deriving newtype (Hashable)++makeClassy ''PrototypeID++instance Show PrototypeID where+ {-# INLINE show #-}+ show (PrototypeID ref) = "Prototype ID: " ++ show ref++derivingUnbox+ "PrototypeID"+ [t|PrototypeID -> Int|]+ [|coerce|]+ [|coerce|]++-- | A component for denoting that an individual is a prototype, to be instantiated later.+data IsPrototype = IsPrototype+ { -- | The t'PrototypeID'.+ _rawIsPrototypeID :: !PrototypeID,+ -- | Indicates that this extends --- and overrides, in case of conflicting values --- another prototype.+ _extendsPrototype :: Maybe PrototypeID+ }+ deriving stock (Eq, Generic, Show)++makeLenses ''IsPrototype++instance HasPrototypeID IsPrototype where+ {-# INLINE prototypeID #-}+ prototypeID = rawIsPrototypeID++instance {-# OVERLAPS #-} XMLPickler [Node] IsPrototype where+ {-# INLINE xpickle #-}+ xpickle =+ xpWrap+ (\(pid, epid) -> IsPrototype pid epid)+ (\(IsPrototype pid epid) -> (pid, epid))+ ( xpElemAttrs+ "prototype"+ ( xpPair+ (pickleAsAttribute "prototypeID")+ (pickleAsAttribute "extends")+ )+ )++-- | Marks an entity as being spawned from a prototype.+data SpawnedFromPrototype = SpawnedFromPrototype+ { -- | The raw `Entity ` which it is spawned from.+ _prototypeEntity :: !Entity,+ -- | The t`PrototypeID` it is spawned from.+ _spawnedFromPrototypeID :: Maybe PrototypeID+ }+ deriving stock (Eq, Generic, Show)++makeLenses ''SpawnedFromPrototype++instance {-# OVERLAPS #-} XMLPickler [Node] SpawnedFromPrototype where+ {-# INLINE xpickle #-}+ xpickle =+ xpWrap+ (\(pEnt, pid) -> SpawnedFromPrototype pEnt pid)+ (\(SpawnedFromPrototype pEnt pid) -> (pEnt, pid))+ ( xpElemAttrs+ "spawnedFromPrototype"+ ( xpPair+ (pickleAsAttribute "entRef")+ (pickleAsAttribute "prototypeID")+ )+ )++instance Component IsPrototype where+ type CanonicalName IsPrototype = "isPrototype"++makeHasComponentClass ''IsPrototype++instance Component SpawnedFromPrototype where+ type CanonicalName SpawnedFromPrototype = "spawnedFromPrototype"++makeHasComponentClass ''SpawnedFromPrototype++{-# INLINEABLE spawnPrototype #-}++-- | Spawn a new individual with the given prototype `Entity` reference. Returns the new individual, and the new world.+spawnPrototype :: (UsingSpawnedFromPrototype w Individual, UsingIsPrototype w Individual, MonadIO m) => Entity -> w Storing -> m (Maybe (w Individual, w Storing))+spawnPrototype proto world = do+ let protoCritter = lookupEntity world proto+ case protoCritter of+ Nothing -> pure Nothing+ Just critter -> do+ let protoID = critter ^? isPrototype . prototypeID+ newID <- liftIO newUniqueEntRef+ let newCritter = critter & unsafeEntityReference .~ newID & addSpawnedFromPrototype .~ SpawnedFromPrototype proto protoID & removeIsPrototype+ updatedWorld = world & storeEntity newCritter+ pure (Just (newCritter, updatedWorld))++-- | A dictionary between a t`PrototypeID` and the characterising `Entity`.+type PrototypeNameMap = HMS.HashMap PrototypeID Entity++-- | Spawns a new individual with a given t`PrototypeID`, which is looked up in the associated map. Returns the new individual, and the new world.+{-# INLINEABLE spawnNamedPrototype #-}+spawnNamedPrototype :: (UsingSpawnedFromPrototype w Individual, UsingIsPrototype w Individual, MonadIO m) => PrototypeNameMap -> PrototypeID -> w Storing -> m (Maybe (w Individual, w Storing))+spawnNamedPrototype prototypeMap proto world = do+ case prototypeMap ^? ix proto of+ Nothing -> assert (False `blame` "Prototype ID doesn't exist!" `swith` proto) (pure Nothing)+ Just ent -> do+ spawned <- spawnPrototype ent world+ case spawned of+ Nothing -> assert (False `blame` ("Prototype ID " ++ show proto ++ " existed, but the entity it refers to doesn't!") `swith` ent) (pure Nothing)+ Just m -> pure (Just m)++-- | All the prototypical individuals in a world.+{-# INLINE prototypes #-}+prototypes :: (HasIsPrototype w) => IndexedTraversal' Entity (w Storing) (w Individual)+prototypes = entitiesWith withIsPrototype
+ src/Games/ECS/SaveLoad.hs view
@@ -0,0 +1,96 @@+{-# OPTIONS_GHC -fno-ignore-asserts #-}++-- |+-- Module : Games.ECS.SaveLoad+-- Description : Saving and loading support for worlds and individuals.+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Saving and loading support, built upon 'Games.ECS.Serialisation'.+module Games.ECS.SaveLoad+ ( entityToXMLDoc,+ worldToXMLDoc,+ renderEntityAsXML,+ renderWorldAsXML,+ writeWorldToFile,+ serialiseWorld,+ deserialiseWorld,+ entityPickler,+ worldPickler,+ )+where++import Control.Lens+import Data.Maybe+import Data.Text (Text)+import Data.Text.Lazy (toStrict)+import Data.XML.Pickle+import Data.XML.Types+import Games.ECS.Serialisation+import Games.ECS.World+import Text.XML qualified as TX++{-# INLINEABLE serialiseEntity #-}++-- | Serialises an individual in an "individual" XML t'Element'.+serialiseEntity :: (XMLSerialise (worldType Individual)) => worldType Individual -> Element+serialiseEntity ent = serialise "individual" ent++{-# INLINEABLE deserialiseEntity #-}++-- | Deserialises an individual in an "individual" XML t'Element'.+deserialiseEntity :: (XMLSerialise (worldType Individual)) => Element -> Maybe (worldType Individual)+deserialiseEntity elmt = case deserialise "individual" elmt of+ Right a -> Just a+ Left a -> error (ppUnpickleError a) -- Nothing++{-# INLINEABLE entityPickler #-}++-- | A pickler for individuals.+entityPickler :: (XMLSerialise (worldType Individual), XMLPickler [Node] (worldType Individual)) => PU [Element] (worldType Individual)+entityPickler = PU (unpickleTree (xpUnliftElems (xpElemNodes "individual" xpickle))) (fmap (: []) serialiseEntity)++-- | A pickler for worlds.+{-# INLINEABLE worldPickler #-}+worldPickler :: (World worldType, XMLSerialise (worldType Individual)) => PU [Node] (worldType Storing)+worldPickler = xpWrapMaybe (deserialiseWorld . (\[NodeElement e] -> e)) ((\e -> [NodeElement e]) . serialiseWorld) xpId++-- | Serialise a world as an XML t'Element'.+{-# INLINEABLE serialiseWorld #-}+serialiseWorld :: (World worldType, XMLSerialise (worldType Individual)) => worldType Storing -> Element+serialiseWorld world = Element "world" [] {-TODO: Put number of entities etc here for corruption detection -} serialisedCritters+ where+ serialisedCritters = fmap (NodeElement . serialiseEntity) (world ^.. entities)++-- TODO: Optimise this. It's going to be slow cus of cache thrashing.++-- | Deserialise a world from an XML t'Element'.+deserialiseWorld :: (World worldType, XMLSerialise (worldType Individual)) => Element -> Maybe (worldType Storing)+deserialiseWorld (Element "world" [] ns) = Just world+ where+ deserialisedCritters = mapMaybe (\(NodeElement elmt) -> deserialiseEntity elmt) ns+ world = foldr storeEntity newWorld deserialisedCritters+deserialiseWorld _ = Nothing++-- | Serialise an individual to an XML t'Document'.+entityToXMLDoc :: (XMLSerialise (worldType Individual)) => worldType Individual -> Document+entityToXMLDoc ent = Document (Prologue [] Nothing []) (serialiseEntity ent) []++-- | Serialise a world to an XML t'Document'.+worldToXMLDoc :: (World worldType, XMLSerialise (worldType Individual)) => worldType Storing -> Document+worldToXMLDoc world = Document (Prologue [] Nothing []) (serialiseWorld world) []++-- | Pretty-print an individual as formatted XML.+renderEntityAsXML :: (XMLSerialise (worldType Individual)) => worldType Individual -> Text+renderEntityAsXML ent = let (Right doc) = TX.fromXMLDocument (entityToXMLDoc ent) in toStrict $ TX.renderText TX.def doc++-- | Pretty-print a world as formatted XML.+renderWorldAsXML :: (World worldType, XMLSerialise (worldType Individual)) => worldType Storing -> Text+renderWorldAsXML world = let (Right doc) = TX.fromXMLDocument (worldToXMLDoc world) in toStrict $ TX.renderText TX.def doc++-- | Serialise a world to an XML file.+writeWorldToFile :: (World worldType, XMLSerialise (worldType Individual)) => FilePath -> worldType Storing -> IO ()+writeWorldToFile path world = let (Right doc) = TX.fromXMLDocument (worldToXMLDoc world) in TX.writeFile (TX.def {TX.rsPretty = True}) path doc
+ src/Games/ECS/Serialisation.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Games.ECS.Serialisation+-- Description : Generic XML Serialisation.+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Generic XML serialisation and deserialisation support. Adapted from the /generic-xmlpickler/ library, based on the /hxt/ package.+module Games.ECS.Serialisation+ ( XMLSerialise (..),+ XMLPickler (..),+ XMLPickleAsAttribute (..),+ Node,+ module Data.XML.Pickle,+ AsString (..),+ GXmlPickler (..),+ formatElement,+ AsList (..),+ optElem,+ optElemD,+ optElemC,+ )+where++import Control.Lens+import Data.Char (toLower)+import Data.Coerce+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HMS+import Data.HashSet (HashSet)+import Data.Hashable+import Data.Int+import Data.Interned+import Data.Interned.Text+import Data.Kind+import Data.Sequence (Seq)+import Data.Set.Ordered (OSet)+import Data.Set.Ordered qualified as OSet+import Data.String+import Data.Text (Text)+import Data.Word+import Data.XML.Pickle+import Data.XML.Types+import GHC.Exts+import GHC.Generics+import GHC.TypeLits++{--- | Serialise to QNames? It must be only a URI fragment.+data SerialisationIdentifier =+ SerialisationIdentifier {_identity :: URI}+ deriving stock (Eq, Show, Generic)++makeLenses ''SerialisationIdentifier++-- | Serialise to IDREF?+data SerialisationReference =+ SerialisationReference {_reference :: URI}+ deriving stock (Eq, Show, Generic)++makeLenses ''SerialisationReference+-}++-- | A convenience wrapper around an 'XMLPickler'.+class XMLSerialise a where+ {-# MINIMAL #-}++ -- | Serialise an /a/ as a named t'Element'.+ serialise :: String -> a -> Element+ {-# INLINE serialise #-}+ default serialise :: (XMLPickler [Node] a) => String -> a -> Element+ serialise n a = Element (fromString n) [] $ pickle (xpickle :: PU [Node] a) a++ -- | Deserialise a named t'Element'.+ deserialise :: String -> Element -> Either UnpickleError a+ {-# INLINE deserialise #-}+ default deserialise :: (XMLPickler [Node] a) => String -> Element -> Either UnpickleError a+ deserialise name (Element n _ a) | n == (fromString name) = unpickle (xpickle :: PU [Node] a) a+ deserialise name (Element n _ _) = Left $ ErrorMessage ("Error during unpickling: Expected " <> (fromString name) <> ", got " <> (fromString . show $ n))++instance (XMLPickler [Node] a) => XMLSerialise a where+ {-# INLINE serialise #-}+ serialise n a = Element (fromString n) [] $ pickle (xpickle :: PU [Node] a) a+ {-# INLINE deserialise #-}+ deserialise name (Element n _ a) | n == (fromString name) = unpickle (xpickle :: PU [Node] a) a+ deserialise name (Element n _ _) = Left $ ErrorMessage ("Error during unpickling: Expected " <> (fromString name) <> ", got " <> (fromString . show $ n))++-- | A lower-level pickler class.+class XMLPickler t a where+ -- | A combined pickler/unpickler.+ xpickle :: PU t a+ {-# INLINE xpickle #-}+ default xpickle :: (Generic a, GXmlPickler t (Rep a)) => PU t a+ xpickle = gpickle++-- | For when a type can be pickled as an XML 'Attribute'.+class XMLPickleAsAttribute a where+ pickleAsAttribute :: Name -> PU [Attribute] a++-- default pickleAsAttribute :: (forall a b. Coercible a b, XMLPickleAsAttribute b) => Name -> PU [Attribute] a+-- {-# INLINE pickleAsAttribute #-}+-- pickleAsAttribute name = xpWrap (coerce @a) (coerce :: _) (pickleAsAttribute name)++instance (XMLPickleAsAttribute a) => XMLPickleAsAttribute (Maybe a) where+ {-# INLINE pickleAsAttribute #-}+ pickleAsAttribute = xpOption . pickleAsAttribute++instance {-# OVERLAPPABLE #-} (Read a, Show a) => XMLPickleAsAttribute a where+ {-# INLINE pickleAsAttribute #-}+ pickleAsAttribute name = xpAttribute name xpPrim++-- | A deriving-via helper.+newtype AsString a = AsString {unAsString :: a} deriving newtype (Eq, Show, Read, IsString)++instance (IsString a, Show a) => XMLPickleAsAttribute (AsString a) where+ {-# INLINE pickleAsAttribute #-}+ pickleAsAttribute name = xpWrap (AsString . fromString) (show . unAsString) (pickleAsAttribute name)++deriving via (AsString InternedText) instance XMLPickleAsAttribute InternedText++{-# INLINE gpickle #-}++-- | A generic pickler.+gpickle :: forall t a. (Generic a, GXmlPickler t (Rep a)) => PU t a+gpickle = (xpWrap) (GHC.Generics.to @a) (GHC.Generics.from @a) (gxpicklef (gpickle @t @a))++-- | A deriving-via helper.+newtype AsList a = AsList {unAsList :: a} deriving (Show)++instance (IsList a) => IsList (AsList a) where+ type Item (AsList a) = Identity (Item a)+ {-# INLINE fromList #-}+ {-# INLINE toList #-}+ fromList = AsList . fromList . coerce+ toList = coerce . toList . unAsList++instance (IsList a, XMLPickler [Node] (Item a)) => XMLPickler [Node] (AsList a) where+ {-# INLINE xpickle #-}+ xpickle = ("AsList", "") <?+> (xpWrap (AsList . fromList) (toList . unAsList) $ xpAll xpickle) -- xpSeqWhile (xpIsolate xpickle))--{-xpSeqWhile-} xpFindMatches xpickle)++instance (Ord a, XMLPickler [Node] a) => XMLPickler [Node] (OSet a) where+ {-# INLINE xpickle #-}+ xpickle = ("OSet", "") <?+> (xpWrap OSet.fromList OSet.toAscList $ xpAll xpickle)++deriving via AsList (HashSet v) instance (Eq v, Hashable v, XMLPickler [Node] v) => XMLPickler [Node] (HashSet v)++deriving via AsList (Seq v) instance (XMLPickler [Node] v) => XMLPickler [Node] (Seq v)++instance {-# OVERLAPPABLE #-} (Eq k, Hashable k, XMLPickleAsAttribute k, XMLPickler [Node] v) => XMLPickler [Node] (HashMap k v) where+ {-# INLINE xpickle #-}+ xpickle =+ ("HashMap", "")+ <?+> ( xpWrap HMS.fromList HMS.toList $+ xpAll $+ xpElem "li" (pickleAsAttribute "key") xpickle+ )++instance XMLPickler [Node] Word where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Word8 where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Word16 where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Word32 where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Word64 where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Natural where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Int where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Int8 where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Int16 where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Int32 where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Int64 where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Integer where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] InternedText where+ {-# INLINE xpickle #-}+ xpickle = ("InternedText", "") <?+> (xpWrap intern unintern xpickle)++instance XMLPickler [Node] Float where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Double where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance XMLPickler [Node] Bool where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpBool++instance XMLPickler [Node] Text where+ {-# INLINE xpickle #-}+ xpickle = ("Text", "") <?+> xpContent (xpWrap (\t -> if t == " " then " " else t) (\t -> if t == " " then " " else t) xpId)++instance XMLPickler [Node] String where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpString++instance XMLPickler [Node] Char where+ {-# INLINE xpickle #-}+ xpickle = xpContent xpPrim++instance {-# OVERLAPPABLE #-} forall t a. (Generic a, GXmlPickler t (Rep a)) => XMLPickler t a where+ {-# INLINE xpickle #-}+ xpickle = gpickle++instance {-# OVERLAPPABLE #-} (Read a, Show a) => XMLPickler [Node] (AsString a) where+ {-# INLINE xpickle #-}+ xpickle = ("AsString", "") <?+> (xpWrap (AsString . read) (show . unAsString) (xpContent xpString))++instance {-# OVERLAPPABLE #-} (Read a, Show a) => XMLPickler Data.Text.Text a where+ {-# INLINE xpickle #-}+ xpickle = ("prim", "") <?+> xpPrim++-- TODO: Do parametric types.++-- | Generic pickling support.+class GXmlPickler t f where+ gxpicklef :: PU t a -> PU t (f a)+ {-# INLINE gxpicklef #-}+ gxpicklef = gxpickleContentsf+ gxpickleContentsf :: PU t a -> PU t (f a)++-- | For individual fields+instance (XMLPickler t a) => GXmlPickler t (K1 i a) where+ {-# INLINE gxpickleContentsf #-}+ gxpickleContentsf _ = xpWrap K1 unK1 xpickle++-- | For empty constructors+instance GXmlPickler [t] U1 where+ {-# INLINE gxpickleContentsf #-}+ gxpickleContentsf _ = xpWrap (const U1) (const ()) xpUnit++-- | For products of fields+instance (GXmlPickler [t] f, GXmlPickler [t] g) => GXmlPickler [t] (f :*: g) where+ {-# INLINE gxpickleContentsf #-}+ gxpickleContentsf f = xpWrap (uncurry (:*:)) (\(a :*: b) -> (a, b)) (gxpicklef f `xpPair` gxpicklef f)++-- | For sums of constructors+instance (GXmlPickler t f, GXmlPickler t g) => GXmlPickler t (f :+: g) where+ {-# INLINE gxpickleContentsf #-}+ gxpickleContentsf f = xpMayFail ((xpMayFail (gxpicklef f)) `xpSum` (xpMayFail (gxpicklef f)))++-- | For datatypes+instance {-# OVERLAPPABLE #-} (Datatype d, GXmlPickler t f) => GXmlPickler t (M1 D d f) where+ {-# INLINE gxpickleContentsf #-}+ gxpickleContentsf f = (fromString $ datatypeName (undefined :: M1 D d f p), "") <?+> (xpWrap M1 unM1 (gxpicklef f))++-- | For constructors+instance {-# OVERLAPPABLE #-} (Constructor c, GXmlPickler [Node] f) => GXmlPickler [Node] (M1 C c f) where+ {-# INLINE gxpickleContentsf #-}+ {-# INLINE gxpicklef #-}+ gxpicklef f = xpElemNodes (fromString . formatElement $ conName (undefined :: M1 C c f p)) (gxpickleContentsf f)+ gxpickleContentsf f = (xpWrap M1 unM1 (gxpicklef f))++-- | For record field selectors+instance {-# OVERLAPPABLE #-} (Selector c, GXmlPickler [Node] f) => GXmlPickler [Node] (M1 S c f) where+ {-# INLINE gxpickleContentsf #-}+ gxpickleContentsf f = optElem (xpWrap M1 unM1 (gxpicklef f)) (undefined :: M1 S c f p)++-- | For Maybe types+instance {-# OVERLAPPING #-} (XMLPickler [Node] a, Selector c) => GXmlPickler [Node] (M1 S c (K1 i (Maybe a))) where+ {-# INLINE gxpickleContentsf #-}+ gxpickleContentsf _ = xpWrap (M1 . K1) (unK1 . unM1) (xpOption $ optElem xpickle (undefined :: M1 S c f p))++{--- | An instance for types with a single constructor. Don't bother with the constructor; just the datafields.+instance {-# OVERLAPPING #-} (Constructor c'', GXmlPickler [Node] g, GXmlPickler [Node] h, Datatype d, GXmlPickler [Node] f, Datatype d, ty ~ (M1 D d (M1 C c'' f)), f ~ (g :*: h)) => GXmlPickler [Node] (M1 D d (M1 C c'' (g :*: h))) where+ {-# INLINE gxpickleContentsf #-}+ --gxpicklef f = xpElemNodes (fromString . formatElement $ conName (undefined :: M1 C c'' f p)) (gxpickleContentsf f)+ gxpickleContentsf f = (fromString $ datatypeName (undefined :: ty p), "") <?+> (xpWrap (M1 . M1 . uncurry (:*:) ) ( (\(a :*: b) -> (a, b)) . unM1 . unM1) (gxpicklef f `xpPair` gxpicklef f))+-}+{--- | An instance for wrapper datatypes/newtypes. Don't bother with the wrapper constructor or fieldname; just the wrapped data.+instance {-# OVERLAPPING #-} ( XMLPickler [Node] a, Datatype d, ty ~ (M1 D d (M1 C c'' (M1 S c (K1 i a))))) => GXmlPickler [Node] (M1 D d (M1 C c'' (M1 S c (K1 i a)))) where+ {-# INLINE gxpickleContentsf #-}+ gxpickleContentsf f = {-xpElemNodes (fromString . formatElement $ datatypeName (undefined :: ty p))-} (fromString $ datatypeName (undefined :: M1 D d f p), "") <?+> (xpWrap (M1 . M1 . M1 . K1) (unK1 . unM1 . unM1 . unM1) (xpickle))-}++{-# INLINE xpSum #-}++-- | Pickle adapter for ':+:'+xpSum :: PU t (f r) -> PU t (g r) -> PU t ((f :+: g) r)+xpSum l r = xpWrap i o (xpEither l r)+ where+ i (Left x) = L1 x+ i (Right x) = R1 x+ o (L1 x) = Left x+ o (R1 x) = Right x++-- | Pickle adapter for 'Datatype'+{-# INLINE optElemD #-}+optElemD :: forall (t :: Type -> Meta -> (Type -> Type) -> Type -> Type) i (s :: Meta) (f :: Type -> Type) p a. (Datatype s) => PU [Node] a -> t i s f p -> PU [Node] a+optElemD x y = case formatElement (datatypeName y) of+ "" -> x+ n -> xpElemNodes (fromString n) x++-- | Pickle adapter for 'Constructor'+{-# INLINE optElemC #-}+optElemC :: forall (t :: Type -> Meta -> (Type -> Type) -> Type -> Type) i (s :: Meta) (f :: Type -> Type) p a. (Constructor s) => PU [Node] a -> t i s f p -> PU [Node] a+optElemC x y = case formatElement (conName y) of+ "" -> x+ n -> xpElemNodes (fromString n) x++-- | Pickle adapter for 'Selector'+{-# INLINE optElem #-}+optElem :: forall (t :: Type -> Meta -> (Type -> Type) -> Type -> Type) i (s :: Meta) (f :: Type -> Type) p a. (Selector s) => PU [Node] a -> t i s f p -> PU [Node] a+optElem x y = case formatElement (selName y) of+ "" -> x+ n -> xpElemNodes (fromString n) x++-- | Format field names nicely+{-# INLINE formatElement #-}+formatElement :: String -> String+formatElement = headToLower . stripLeadingAndTrailingUnderscore++{-# INLINE headToLower #-}+headToLower :: String -> String+headToLower l = case l of+ [] -> []+ (x : xs) -> toLower x : xs++{-# INLINE stripLeadingAndTrailingUnderscore #-}+stripLeadingAndTrailingUnderscore :: String -> String+stripLeadingAndTrailingUnderscore = stripLeadingUnderscore . stripTrailingUnderscore++{-# INLINE stripLeadingUnderscore #-}+stripLeadingUnderscore :: String -> String+stripLeadingUnderscore s = case s of+ ('_' : ls) -> ls+ ls -> ls++{-# INLINE stripTrailingUnderscore #-}+stripTrailingUnderscore :: String -> String+stripTrailingUnderscore s = case s of+ "" -> ""+ [x, '_'] -> [x]+ (x : xs) -> x : stripTrailingUnderscore xs
+ src/Games/ECS/Slot.hs view
@@ -0,0 +1,29 @@+-- |+-- Module : Games.ECS.Slot+-- Description : ECS Slots+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+-- +-- Slots are /logical/ places in a `Games.ECS.Component.Store.ComponentStore`.++module Games.ECS.Slot where++import Control.Lens+-- | A helper class for a generic "has" `Control.Lens.Type.Lens'`.+class HasType a s where+ {-# MINIMAL typed | getTyped, setTyped #-}+ -- | A 'Lens'' for accessing a well-known contained type.+ typed :: Lens' s a+ typed = lens (getTyped @a) (flip (setTyped @a))+ -- | A getter for accesing a well-known contained type.+ {-# INLINE typed #-}+ getTyped :: s -> a+ getTyped s = s ^. typed @a+ {-# INLINE getTyped #-}+ -- | A setter for a well-known contained type.+ setTyped :: a -> s -> s+ setTyped a s = s & (typed @a) .~ a+ {-# INLINE setTyped #-}
+ src/Games/ECS/System.hs view
@@ -0,0 +1,90 @@+-- |+-- Module : Games.ECS.System+-- Description : System definitions+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Infrastructure for defining ECS Systems.+module Games.ECS.System where++import Control.Lens+import Data.Kind+import Data.Proxy+import Debug.Trace+import GHC.TypeLits+import Games.ECS.Entity+import Games.ECS.World++-- TODO: Generate a "UsingSystem" class a la UsingComponents++-- type SystemFunc w = World w => w Storing -> w Storing+-- type IndividualFunc m w = (World w, MonadState (w Storing) m) => m (w Individual) -> m (w Individual)++-- | A system which operates on entities which matches certain constraints on components.+class (World w, Monad m, KnownSymbol (AppendSymbol name " started"), KnownSymbol (AppendSymbol name " finished")) => System (name :: Symbol) sys w m | name -> sys, sys -> name where+ -- Remember to use '[] rather than [] to specify type-level lists!++ -- | What this systems runs after+ type RunsAfter sys :: [Symbol]++ type RunsAfter sys = '[]++ -- | What this systems runs before+ type RunsBefore sys :: [Symbol]++ type RunsBefore sys = '[]++ -- | Constraints required to run the system.+ type ComponentFilters name sys w m :: Constraint++ type ComponentFilters name sys w m = ()++ -- | The filter on components which the system affects+ componentFilter :: (ComponentFilters name sys w m, Monoid r) => Getting r (w Storing) IntersectionOfEntities+ componentFilter = mempty++ -- | Should this entity be processed?+ processPredicate :: (ComponentFilters name sys w m) => w Individual -> Bool+ processPredicate = const True++ -- | Process a single entity+ processEntity :: (ComponentFilters name sys w m) => w Individual -> m (w Individual)+ processEntity = pure++ -- | Initialise the system with preliminary data based on a fresh world. The system is allowed to modify the+ -- world if it wishes.+ initialiseSystem :: w Storing -> m (w Storing)+ initialiseSystem = pure++ -- | Run the system. By default, it runs `processEntity` for each entity.+ runSystem :: (ComponentFilters name sys w m) => w Storing -> m (w Storing)+ runSystem world = do+ traceMarker (symbolVal (Proxy :: Proxy (AppendSymbol name " started"))) (pure ())+ processedWorld <- traverseOf (entitiesWith (componentFilter @name @sys @w @m) . filtered (processPredicate @name @sys @w @m)) (processEntity @name) world+ finished <- postTickCleanup @name @sys processedWorld+ traceMarker (symbolVal (Proxy :: Proxy (AppendSymbol name " started"))) (pure finished)++ -- | Run any cleanup necessary at the end of a tick, such as clearing cached data only necessary for the tick, or marking things as dirty.+ postTickCleanup :: (ComponentFilters name sys w m) => w Storing -> m (w Storing)+ postTickCleanup = pure++ -- | Ran after the effect system has finished. This is so that one can, for example, collect all effects to+ -- apply during the effect system processing; and once all effects are collected, apply them all at once.+ -- This can eliminate redundant processing, as well as later effects not overriding previously-processed+ -- effects.+ runAfterEffects :: w Storing -> m (w Storing)+ runAfterEffects = pure++{-+collectGarbage :: SystemFunc w+collectGarbage = undefined++markUselessEntitiesForDeletion :: (Foldable f, World w) => w Storing -> f Entity+markUselessEntitiesForDeletion = undefined++removeMarked :: Foldable f => f Entity -> SystemFunc w+removeMarked = undefined+-}
+ src/Games/ECS/Util/Misc.hs view
@@ -0,0 +1,22 @@+-- |+-- Module : Games.ECS.Util.Misc+-- Description : Other junk.+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Things which don't really fit anywhere else.++module Games.ECS.Util.Misc where++import Data.Hashable+import Data.Sequence (Seq)++-- | a 'Hashable' 'Seq'.+newtype HashableSeq a = HashableSeq (Seq a) deriving newtype Eq++instance Hashable a => Hashable (HashableSeq a) where+ {-# INLINE hashWithSalt #-}+ hashWithSalt salt (HashableSeq s) = foldl hashWithSalt salt s
+ src/Games/ECS/World.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module : Games.ECS.World+-- Description : World definitions+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Infrastructure for defining ECS worlds.+module Games.ECS.World+ ( Access (..),+ Props (..),+ World (..),+ OpticsFor,+ EntRefStoringType,+ EntRefField,+ AnAffineTraversal,+ AnAffineTraversal',+ AffineTraversal,+ AffineTraversal',+ affine,+ affine',+ newUniqueEntRef,+ )+where++import Control.Lens+import Control.Monad.IO.Class+import Data.IORef+import Data.IntSet qualified as IS+import Data.Kind+import GHC.Base+import GHC.Num+import Games.ECS.Entity+import Games.ECS.Slot+import System.IO.Unsafe (unsafePerformIO)++-- | HKD parameterisation for an ECS.+data Access+ = -- | We are dealing with the entire collection of entities in a world, represented structure-of-array style.+ Storing+ | -- | We are dealing with a specific individual with specific component values.+ Individual++-- | Different arities.+data Props+ = -- | An individual may or may not have this component.+ Normal+ | -- | Every individual must have this component.+ Required+ | -- | Either a single individual, or none, may have this component.+ Unique++-- | For entity unique values. We don't want to use Data.Unique, because we would like to be able to set the+-- seed upon loading a save game.+entUniqueSource :: IORef Integer+entUniqueSource = unsafePerformIO (newIORef 0)+{-# NOINLINE entUniqueSource #-}++-- | Atomically construct a new entity reference.+newUniqueEntRef :: IO Entity+newUniqueEntRef = do+ r <- atomicModifyIORef' entUniqueSource $ \x -> let z = x + 1 in (z, z)+ pure (EntRef (integerToInt r))+{-# NOINLINE newUniqueEntRef #-}++-- | An entity component system, parameterised by its access type.+class World (w :: Access -> Type) where+ -- | Construct a new world.+ newWorld :: w Storing++ -- | Create a new entity+ createNewEntity :: (MonadIO m) => m (w Individual)+ {-# INLINE createNewEntity #-}+ createNewEntity = do+ seed <- liftIO newUniqueEntRef+ pure (createNewEntityWithRef seed)++ -- | Create a new entity with a given reference.+ createNewEntityWithRef :: Entity -> w Individual++ -- | Traversal over all entities in the ECS.+ entities :: IndexedTraversal' Entity (w Storing) (w Individual)+ {-# INLINE entities #-}+ default entities :: (HasType (EntRefStoringType) (w Storing)) => IndexedTraversal' Entity (w Storing) (w Individual)+ entities p world = lookupEntities ((world ^.. typed @(EntRefField Storing) . knownEntities)) p world++ -- | Get the entity reference of an individual+ entityReference :: IndexedGetter Entity (w Individual) Entity++ -- | Get and set the entity reference of an individual+ unsafeEntityReference :: Lens' (w Individual) Entity++ -- | Get all of the entity references stored in the world.+ entityReferences :: IndexedFold Entity (w Storing) Entity++ -- | Check if a given entity exists in the world, and if so, return the individual.+ lookupEntity :: w Storing -> Entity -> Maybe (w Individual)++ -- | An IndexedTraversal' which returns the individuals associated to the entities given as input.+ {-# INLINE lookupEntities #-}+ lookupEntities :: forall f p fol. (Indexable Entity p, Applicative f, Foldable fol) => fol Entity -> p (w Individual) (f (w Individual)) -> w Storing -> f (w Storing) -- Foldable f => f Entity -> IndexedTraversal' Entity (w Storing) (w Individual)+ lookupEntities list = entities . {-indices-} filtered (\ent -> elemOf folded (ent ^. entityReference) list) -- TODO optimise this fucking thing++ -- | An IndexedTraversal' of individuals matching some constraints. The constraints are included monoidally.+ entitiesWith :: forall f p. (Indexable Entity p, Applicative f) => (forall r. (Monoid r) => Getting r (w Storing) IntersectionOfEntities) -> p (w Individual) (f (w Individual)) -> w Storing -> f (w Storing) -- IndexedTraversal' Entity (w Storing) (w Individual)+ {-# INLINE entitiesWith #-}+ entitiesWith withComponents p world = lookupEntities ((world ^. withComponents) ^.. knownEntities) p world++ -- | Store an individual in a world, returning the new world.+ storeEntity :: w Individual -> w Storing -> w Storing++ -- | Affine traversal for a specified individual from the world.+ entity :: Entity -> AffineTraversal' (w Storing) (w Individual)+ entity ent = affine' (`lookupEntity` ent) (flip storeEntity)+ {-# INLINE entity #-}++-- TODO make this EntitySet. Just need to implement Ixed/At for it, and change IS.member in World/TH.hs.++-- | A type which holds a collection of 'Entity'.+type EntRefStoringType = IS.IntSet++-- Should this go in Component.hs? Perhaps a typeclass "Using", which converts an (affine) traversal into+-- a lens, given evidence from a function like `filtered (has position)`? either a unique typeclass will+-- have to be generated for each named component, or parameterised by the name itself. the former has the+-- advantage of robustness to renaming, but the latter would allow a nice `using @"position"` syntax.+-- perhaps it could inject a (gdp-style) Fact into the context? that way, the accessor can have a+-- requirement on its optic, and might even be able to specify logical dependencies (e.g. a movable object+-- must have a position; an inventory item must have a mass, etc) with :: (CompTypeClass name a) =>+-- IndexedTraversal' Entity (w Individual) (w Individual)++-- | A type function for simplifying the higher-kinded data implementation.+type family EntRefField (acc :: Access) :: Type where+ EntRefField Individual = Entity+ EntRefField Storing = EntRefStoringType++-- TODO Add a global storage type family++-- type family GlobalStorage (name :: Symbol) :: Type++-- | We want to make sure that the API is consistent based on the access type and availability property, so we+-- have a type family to give us the correct optics.+type family OpticsFor (name :: Symbol) (hkd :: Access -> Type) (acc :: Access) (p :: Props) (a :: Type) :: Type where+ OpticsFor name hkd Individual Required a =+ ReifiedIndexedLens' Entity (hkd Individual) a+ OpticsFor name hkd Individual Normal a =+ AnAffineTraversal' (hkd Individual) a+ OpticsFor name hkd Individual Unique a = AnAffineTraversal' (hkd Individual) a+ OpticsFor name hkd Storing Unique a = ReifiedIndexedTraversal' Entity (hkd Storing) a+ OpticsFor name hkd Storing Normal a = ReifiedIndexedTraversal' Entity (hkd Storing) a+ OpticsFor name hkd Storing Required a = ReifiedIndexedTraversal' Entity (hkd Storing) a++-- class ((CompTypeClassFun name a) ~ a, (CompTypeClassFun name a) ~ (CompTypeFun name a)) => CompTypeClass (name :: Symbol) (a :: Type) where+-- type CompTypeClassFun (name :: Symbol) (a :: Type) :: Type++-- instance ((CompTypeClassFun name a) ~ a, (CompTypeClassFun name a) ~ (CompTypeFun name a)) => CompTypeClass name a where+-- type CompTypeClassFun name a = a++-- type family CompTypeFun (name :: Symbol) (a :: Type) :: Type where+-- CompTypeFun name a = a++-- | A reified 'AffineTraversal'.+type AnAffineTraversal s t a b = ReifiedIndexedTraversal Entity s t a b++-- | A reified `AffineTraversal'`.+type AnAffineTraversal' s a = AnAffineTraversal s s a a++-- | An 'AffineTraversal' is one which traverses either 0 or 1 elements.+type AffineTraversal s t a b = Traversal s t a b++-- | Simplified 'AffineTraversal'.+type AffineTraversal' s a = AffineTraversal s s a a++-- | Construct an `AffineTraversal`.+{-# INLINE affine #-}+affine :: (s -> Either t a) -> (s -> b -> t) -> Traversal s t a b+affine getter setter f s = case getter s of+ Left t -> pure t+ Right a -> (\b -> setter s b) <$> f a++-- | Construct an `AffineTraversal'`.+{-# INLINE affine' #-}+affine' :: (s -> Maybe a) -> (s -> a -> s) -> Traversal' s a+affine' getter setter f s = case getter s of+ Nothing -> pure s+ Just a -> (\b -> setter s b) <$> f a
+ src/Games/ECS/World/TH.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module : Games.ECS.World.TH+-- Description : Template Haskell derivation of 'World' classes+-- Copyright : (C) 2020 Sophie Taylor+-- License : AGPL-3.0-or-later+-- Maintainer : Sophie Taylor <sophie@spacekitteh.moe>+-- Stability : experimental+-- Portability: GHC+--+-- Automatic derivation of the 'World' class, implementing the bulk of the higher-kinded data pattern.+module Games.ECS.World.TH+ ( makeWorld,+ )+where++import Control.Applicative+import Control.Lens+import Control.Monad+import Data.Coerce+import Data.Foldable+import Data.IntSet qualified as IS+import Data.Kind qualified as DK+import Data.List (findIndex)+import GHC.Generics+import Games.ECS.Component+import Games.ECS.Component.TH.Internal+import Games.ECS.Entity+import Games.ECS.SaveLoad+import Games.ECS.Serialisation+import Games.ECS.Slot+import Games.ECS.World+import Language.Haskell.TH+import Language.Haskell.TH.Datatype qualified as D+import Language.Haskell.TH.Syntax+import Witherable++aComponentName :: Name+aComponentName = ''Games.ECS.Component.AComponent++-- worldClassName :: Name+-- worldClassName = ''Games.ECS.World.World++-- entRefFieldName :: Name+-- entRefFieldName = ''Games.ECS.World.EntRefField++-- setter'Name :: Name+-- setter'Name = ''Control.Lens.Setter'++extractComponentTypes :: Type -> Maybe (Type, Type, Type)+extractComponentTypes = \case+ AppT (AppT (AppT (ConT acName) name@(LitT (StrTyLit _))) s) a | acName == aComponentName -> Just (name, a, s)+ _ -> Nothing++-- | Find the position of the entity reference field in a (product) world type. We need this so we can ensure+-- we initialise it with the correct type.+findEntRefFieldPosition :: (MonadFail m) => [Type] -> m Int+findEntRefFieldPosition fields = do+ let idx = flip findIndex fields $ \case+ AppT (ConT _entRefFieldName) _ -> True+ _ -> False++ case idx of+ Just i -> pure i+ Nothing -> fail "World doesn't have an EntRefField!"++-- | Body for constructing a new individual given an entity reference+constructAnEntityWithEntRef :: forall m w. (Quote m) => Int -> m Exp -> [(Type, Type)] -> m Type -> Code m (Entity -> w Individual)+constructAnEntityWithEntRef entRefPosition constructor fieldTypes worldType =+ constructAnEntityWithEntRefAndValues entRefPosition constructor (fmap (\(a, b) -> (a, b, Nothing)) fieldTypes) worldType++-- | Creates an expression for constructing a new individual, with the given entity reference value and initial component values.+constructAnEntityWithEntRefAndValues :: forall m w. (Quote m) => Int -> m Exp -> [(Type, Type, Maybe (m Exp))] -> m Type -> Code m (Entity -> w Individual)+constructAnEntityWithEntRefAndValues entRefPosition constructor fieldTypes worldType =+ let prefix = map fieldFunc (take entRefPosition fieldTypes)+ postfix = map fieldFunc (drop entRefPosition fieldTypes)+ header = foldl appE constructor prefix+ mid = appE header+ ending ent = unsafeCodeCoerce $ foldl appE (mid ent) postfix+ fieldFunc :: (Type, Type, Maybe (m Exp)) -> m Exp+ fieldFunc (_name, _a, Just val) = val+ fieldFunc (name, a, Nothing) = [|defaultField @($(pure name)) @($worldType) @Individual @(Prop $(pure a)) @($(pure a))|]+ in [||\ent -> $$(ending [|ent|])||]++-- | Creates an expression to construct a new, blank world.+constructDefaultWorld :: (Quote m) => Int -> m Exp -> [(Type, Type)] -> m Type -> Code m (w Storing)+constructDefaultWorld entRefPos constructor fieldTypes worldType = constructWorldWith [|blankEntityStorage|] entRefPos constructor (fmap (\(a, b) -> (a, b, Nothing)) fieldTypes) worldType++constructWorldWith :: forall m w. (Quote m) => m Exp -> Int -> m Exp -> [(Type, Type, Maybe (m Exp))] -> m Type -> Code m (w Storing)+constructWorldWith entStorage entRefPosition constructor fieldTypes worldType = unsafeCodeCoerce ending+ where+ prefix = map fieldFunc (take entRefPosition fieldTypes)+ postfix = map fieldFunc (drop entRefPosition fieldTypes)+ header = foldl appE constructor prefix+ mid = appE header entStorage+ ending = foldl appE mid postfix+ fieldFunc :: (Type, Type, Maybe (m Exp)) -> m Exp+ fieldFunc (_, _, Just val) = val+ fieldFunc (name, a, Nothing) = [|defaultStorage @($(pure name)) @($worldType) @Storing @(Prop $(pure a)) @($(pure a))|]++{-# INLINE traversalIndexedLookups #-}+traversalIndexedLookups :: forall world f p b. (Filterable f, World world, Indexable Entity p) => f Entity -> world Storing -> p (world Individual) b -> f b+traversalIndexedLookups ents world f =+ uncurry (indexed @Entity @p f)+ <$> mapMaybe+ ( \ent -> case lookupEntity world (coerce ent) of+ Just i -> Just (coerce ent, i)+ Nothing -> Nothing+ )+ ents++{-# INLINE traversalNonIndexedLookups #-}+traversalNonIndexedLookups :: (Filterable f, World world) => f Entity -> world Storing -> (world Individual -> b) -> f b+traversalNonIndexedLookups ents world f =+ f+ <$> mapMaybe+ (lookupEntity world . coerce)+ ents++-- | Implements the 'World' typeclass for a type, and creates numerous helper instances.+makeWorld :: forall m. (Quasi m, Quote m) => Name -> m [Dec]+makeWorld worldName = do+ info <- runQ $ D.reifyDatatype worldName++ -- Grab some info we'll need all over the place+ let worldType = runQ $ conT worldName+ [constructor] = D.datatypeCons info+ componentDefinitions' = mapMaybe extractComponentTypes (D.constructorFields constructor)+ componentDefinitions = fmap (\(a, b, _c) -> (a, b)) componentDefinitions'+ let componentAccessors = forM componentDefinitions' (makeComponentAccessor constructor worldType)+ -- Generate an instance of `World`.+ entRefPosition <- findEntRefFieldPosition (D.constructorFields constructor)++ let totalFieldLength = length (D.constructorFields constructor)+ entRefName = mkName "entityReferenceField"+ entRefPat = varP entRefName+ entRef = varE entRefName+ constructorEntityPattern =+ replicate entRefPosition wildP+ <> [entRefPat]+ <> replicate ((totalFieldLength - entRefPosition) - 1) wildP+ (entityPatternForHasType, constructorEntityPatternForHasType, valP, _valE, entRefSetterPat) = makeConstructorPatternAndValuePair constructor entRefPosition+ entityPattern = conP (D.constructorName constructor) constructorEntityPattern+ worldInstance <-+ [d|+ instance {-# OVERLAPS #-} Games.ECS.Slot.HasType (EntRefStoringType) ($worldType Storing) where+ {-# INLINE CONLIKE typed #-}+ {-# INLINE CONLIKE getTyped #-}+ {-# INLINE CONLIKE setTyped #-}+ typed = Control.Lens.lens getTyped (flip setTyped)+ getTyped ($constructorEntityPatternForHasType) = $entityPatternForHasType+ setTyped $valP ($constructorEntityPatternForHasType) = $entRefSetterPat++ instance {-# OVERLAPS #-} Games.ECS.Slot.HasType (Entity) ($worldType Individual) where+ {-# INLINE CONLIKE typed #-}+ {-# INLINE CONLIKE getTyped #-}+ {-# INLINE CONLIKE setTyped #-}+ typed = Control.Lens.lens getTyped (flip setTyped)+ getTyped ($constructorEntityPatternForHasType) = $entityPatternForHasType+ setTyped $valP ($constructorEntityPatternForHasType) = $entRefSetterPat++ -- TODO: Generate rest of`World` instance+ instance (Generic ($worldType 'Individual), Generic ($worldType 'Storing)) => Games.ECS.World.World $worldType where+ newWorld =+ $( unTypeCode $+ constructDefaultWorld+ entRefPosition+ (conE $ D.constructorName constructor)+ componentDefinitions+ worldType+ )+ entityReference = conjoined (Control.Lens.to $ \ $entityPattern -> $entRef) (ito $ \ $entityPattern -> ($entRef, $entRef))+ {-# INLINE unsafeEntityReference #-}+ unsafeEntityReference =+ lens (getTyped :: $worldType Individual -> Entity) (flip (setTyped :: Entity -> $worldType Individual -> $worldType Individual))++ {-# INLINE createNewEntityWithRef #-}+ createNewEntityWithRef ent =+ $( unTypeCode $+ constructAnEntityWithEntRef+ entRefPosition+ (conE $ D.constructorName constructor)+ componentDefinitions+ worldType+ )+ ent+ {-# INLINE lookupEntity #-}+ lookupEntity world entityToLookup = if existence then Just result else Nothing+ where+ existence = {-HS.member entityToLookup-} IS.member (coerce entityToLookup) $ world ^. (typed @(EntRefField Storing) @($worldType Storing))+ result = $(unTypeCode $ createIndexedLookups entRefPosition (conE $ D.constructorName constructor) (unsafeCodeCoerce [|created|]) (unsafeCodeCoerce [|world|]) componentDefinitions worldType (unsafeCodeCoerce $ varE $ mkName "entityToLookup"))++ {-# INLINE CONLIKE entityReferences #-}+ entityReferences :: IndexedFold Entity ($worldType Storing) Entity+ entityReferences = conjoined ((typed @(EntRefField Storing) @($worldType Storing)) . knownEntities) ((typed @(EntRefField Storing) @($worldType Storing)) . knownEntities . selfIndex)++ {-# INLINE lookupEntities #-}+ lookupEntities :: forall f p fol. (Indexable Entity p, Applicative f, Foldable fol) => fol Entity -> p ($worldType Individual) (f ($worldType Individual)) -> $worldType Storing -> f ($worldType Storing)+ lookupEntities ents' = conjoined normalVer indexedVer+ where+ ents = ents' ^.. folded+ normalVer func world = result+ where+ applied :: [f ($worldType Individual)]+ applied = traversalNonIndexedLookups ents world func+ result :: f ($worldType Storing)+ result = liftA3 @f foldl' (pure @f (flip storeEntity)) (pure world) (sequenceA @[] @f applied)+ indexedVer func world = result+ where+ applied :: [f ($worldType Individual)]+ applied = traversalIndexedLookups ents world func+ result :: f ($worldType Storing)+ result = liftA3 @f foldl' (pure @f (flip storeEntity)) (pure world) (sequenceA @[] @f applied)+ {-# INLINE storeEntity #-}+ storeEntity ent world = result+ where+ worldWithEntity = world & (typed @(EntRefField Storing) . at (coerce (ent ^. entityReference))) ?~ ()+ worldWithEntity :: $worldType Storing+ theEntRef = ent ^. entityReference+ result = $(unTypeCode $ createStores entRefPosition (conE $ D.constructorName constructor) (unsafeCodeCoerce [|ent|]) (unsafeCodeCoerce [|worldWithEntity|]) componentDefinitions worldType (unsafeCodeCoerce [|theEntRef|]))++ instance (XMLSerialise ($worldType Individual)) => XMLPickler [Node] ($worldType Storing) where+ {-# INLINE xpickle #-}+ xpickle = worldPickler+ |]++ -- TODO: Generate an `At name FieldType` instance for each Individual's components+ -- TODO: Generate garbage collection function. Note: use Control.Lens.At.sans for this+ -- TODO: Support "global" components - or perhaps just defer to a MonadState+ -- TODO: Generate "Has<X>" classes (elaborated: ReadOnly, WriteOnly, ReadWrite) for each named component, a la classy optics+ -- TODO: Resource Field accessor types+ -- TODO: Enforce intent/queueing system via making optics read-only and using an annotation to say what functions are allowed access, then yeet them with TH+ componentAccessors' <- fmap concat componentAccessors+ pure (worldInstance <> componentAccessors')++createIndexedLookups :: forall m w. (Quote m) => Int -> m Exp -> Code m ((w :: Access -> DK.Type) Individual) -> Code m (w Storing) -> [(Type, Type)] -> m Type -> Code m Entity -> Code m (w Individual)+createIndexedLookups entRefPos constructor _created worldStorage types worldType ent = do+ let applications :: [(Type, Type, Maybe (m Exp))]+ applications =+ types+ <&> ( \(nameType'@(LitT (StrTyLit _name')), comp') ->+ let comp = pure comp'+ nameType = pure nameType'+ in ( ( nameType',+ comp',+ Just+ [|+ injectMaybe @($nameType) @($worldType) @Individual @(Prop $comp) @($comp) ($(unTypeCode worldStorage) ^. (Games.ECS.Component.storage @($nameType) @($worldType) @Storing @(Prop $comp) @($comp) . (at $(unTypeCode ent))))+ |]+ )+ )+ )+ [||$$(constructAnEntityWithEntRefAndValues entRefPos constructor applications worldType) $$(ent)||]++createStores :: forall m w. (Quote m) => Int -> m Exp -> Code m (w Individual) -> Code m (w Storing) -> [(Type, Type)] -> m Type -> Code m Entity -> Code m (w Storing)+createStores entRefPos constructor individual world types worldType ent = do+ let rawLens nameType componentType = unsafeCodeCoerce [|(typed @(Field $nameType Storing (Prop $componentType) $componentType) @($worldType Storing) . coerced)|]+ rawLens :: m Type -> m Type -> Code m (Getting a0 (w 'Storing) a0)+ applications =+ types+ <&> ( \(nameType'@(LitT (StrTyLit name')), comp') ->+ let comp = pure comp'+ viewedField = [||($$world ^. ($$(rawLens (pure nameType') comp)))||]+ in [|($(unTypeQ . examineCode $ viewedField)) & $(appTypeE [|Control.Lens.at|] [t|Storage $comp $comp|]) $(unTypeCode ent) .~ ($(unTypeCode individual) ^? $(varE (mkName name')))|]+ )++ -- TODO: possibly need some rewrite rules for (set . get) for the field accessors+ viewed = [|$(unTypeCode world) ^. (typed @(EntRefField Storing))|]+ viewed :: m Exp+ -- TODO: Replace the "coerced" with "injectToField"+ mappedTypesAndValues = Prelude.zipWith (\(a, b) c -> (a, b, Just [|$(c) ^. coerced @(Storage $(pure b) $(pure b))|])) types applications++ constructWorldWith viewed entRefPos constructor mappedTypesAndValues worldType