shady-gen (empty) → 0.5.1
raw patch · 24 files changed
+5754/−0 lines, 24 filesdep +Booleandep +MemoTriedep +TypeComposesetup-changed
Dependencies added: Boolean, MemoTrie, TypeCompose, applicative-numbers, base, containers, data-treify, mtl, ty, vector-space, wl-pprint
Files
- COPYING +661/−0
- Setup.lhs +3/−0
- shady-gen.cabal +58/−0
- src/Data/NameM.hs +33/−0
- src/Data/PolyStableMemo.hs +126/−0
- src/Data/StableMemo.hs +93/−0
- src/Shady/CompileE.hs +183/−0
- src/Shady/CompileEs.hs +86/−0
- src/Shady/Complex.hs +265/−0
- src/Shady/Language/Cse.hs +190/−0
- src/Shady/Language/Exp.hs +1127/−0
- src/Shady/Language/GLSL.hs +302/−0
- src/Shady/Language/Glom.hs +164/−0
- src/Shady/Language/Graph.hs +105/−0
- src/Shady/Language/Operator.hs +335/−0
- src/Shady/Language/Reify.hs +82/−0
- src/Shady/Language/Share.lhs +280/−0
- src/Shady/Language/Type.hs +378/−0
- src/Shady/Misc.hs +147/−0
- src/Shady/Play/CseTest.hs +165/−0
- src/Shady/Play/VectorTest.hs +154/−0
- src/Shady/Vec.hs +440/−0
- src/Text/PrettyPrint/Leijen/DocExpr.hs +268/−0
- src/Text/PrettyPrint/Leijen/PrettyPrec.hs +109/−0
+ COPYING view
@@ -0,0 +1,661 @@+ GNU AFFERO GENERAL PUBLIC LICENSE+ Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU Affero General Public License is a free, copyleft license for+software and other kinds of works, specifically designed to ensure+cooperation with the community in the case of network server software.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+our General Public Licenses are intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ Developers that use our General Public Licenses protect your rights+with two steps: (1) assert copyright on the software, and (2) offer+you this License which gives you legal permission to copy, distribute+and/or modify the software.++ A secondary benefit of defending all users' freedom is that+improvements made in alternate versions of the program, if they+receive widespread use, become available for other developers to+incorporate. Many developers of free software are heartened and+encouraged by the resulting cooperation. However, in the case of+software used on network servers, this result may fail to come about.+The GNU General Public License permits making a modified version and+letting the public access it on a server without ever releasing its+source code to the public.++ The GNU Affero General Public License is designed specifically to+ensure that, in such cases, the modified source code becomes available+to the community. It requires the operator of a network server to+provide the source code of the modified version running there to the+users of that server. Therefore, public use of a modified version, on+a publicly accessible server, gives the public access to the source+code of the modified version.++ An older license, called the Affero General Public License and+published by Affero, was designed to accomplish similar goals. This is+a different license, not a version of the Affero GPL, but Affero has+released a new version of the Affero GPL which permits relicensing under+this license.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU Affero General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Remote Network Interaction; Use with the GNU General Public License.++ Notwithstanding any other provision of this License, if you modify the+Program, your modified version must prominently offer all users+interacting with it remotely through a computer network (if your version+supports such interaction) an opportunity to receive the Corresponding+Source of your version by providing access to the Corresponding Source+from a network server at no charge, through some standard or customary+means of facilitating copying of software. This Corresponding Source+shall include the Corresponding Source for any work covered by version 3+of the GNU General Public License that is incorporated pursuant to the+following paragraph.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the work with which it is combined will remain governed by version+3 of the GNU General Public License.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU Affero General Public License from time to time. Such new versions+will be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU Affero General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU Affero General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU Affero General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <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 Affero General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU Affero General Public License for more details.++ You should have received a copy of the GNU Affero General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If your software can interact with users remotely through a computer+network, you should also make sure that it provides a way for users to+get its source. For example, if your program is a web application, its+interface could display a "Source" link that leads users to an archive+of the code. There are many ways you could offer source, and different+solutions will be better for different programs; see section 13 for the+specific requirements.++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU AGPL, see+<http://www.gnu.org/licenses/>.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ shady-gen.cabal view
@@ -0,0 +1,58 @@+Name: shady-gen+Version: 0.5.1+Cabal-Version: >= 1.2+Synopsis: Functional GPU programming - DSEL & compiler+Category: Language, GPU+Description:+ Compile functional specifications for GPU execution.+ See also shady-render, shady-tv, and shady-examples+ .+ Copyright 2009-2011 by Conal Elliott; GNU AGPLv3 license (see COPYING).+ This license is a place-holder. Let me know if you'd like other terms.+Author: Conal Elliott+Maintainer: conal@conal.net+Homepage: http://haskell.org/haskellwiki/shady+Package-Url: http://conal.net/repos/shady-gen+Copyright: (c) by Conal Elliott 2009,2010+License: OtherLicense+License-File: COPYING+Stability: experimental+build-type: Simple++Library+ hs-Source-Dirs: src++ Build-Depends: base >=4 && < 5, containers, mtl, wl-pprint+ , applicative-numbers>=0.0.4, vector-space>=0.5.6+ , TypeCompose >= 0.7+ , MemoTrie, ty, data-treify, Boolean++ Exposed-Modules:+ Text.PrettyPrint.Leijen.PrettyPrec+ Text.PrettyPrint.Leijen.DocExpr+ Data.NameM+ Shady.Misc+ Shady.Vec+ Shady.Complex+ Shady.Language.Type+ Shady.Language.Glom+ Shady.Language.Operator+ Shady.Language.Exp+ Shady.Language.Graph+ Shady.Language.Reify+ Shady.Language.Cse+ Shady.Language.Share+ Shady.Language.GLSL++ Shady.CompileE+ Shady.CompileEs++ Data.StableMemo+ Shady.Play.CseTest+ Shady.Play.VectorTest+ -- experimental:+ Data.PolyStableMemo+ -- Data.NatTrie+ -- Data.TypeTrie++-- For examples, see examples/shady-examples.cabal
+ src/Data/NameM.hs view
@@ -0,0 +1,33 @@+-- {-# LANGUAGE #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Data.NameM+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Name supply monad. Non-abstract synonym for @State [String]@+----------------------------------------------------------------------++module Data.NameM (NameM, genName, runNameM, allNames) where++import Control.Monad.State++type NameM = State [String]++-- Generate a new variable name+genName :: State [x] x+genName = do x:xs' <- get+ put xs'+ return x++runNameM :: NameM a -> a+runNameM m = evalState m allNames++allNames :: [String]+allNames = map reverse (tail names)+ where+ names = "" : [ c:cs | cs <- names , c <- ['a' .. 'z'] ]
+ src/Data/PolyStableMemo.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE TypeOperators, BangPatterns, Rank2Types, PatternGuards+ , ExistentialQuantification, ScopedTypeVariables, GADTs+ #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- temp+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Data.PolyStableMemo+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Polymorphic memoization based using stable names.+----------------------------------------------------------------------++module Data.PolyStableMemo ((:-->),memo) where -- ,memo2,memo3++import System.IO.Unsafe (unsafePerformIO)++import Control.Concurrent.MVar+import System.Mem.StableName+import qualified Data.IntMap as I++-- import Shady.Language.Graph+-- import Shady.Language.Operator+-- import Shady.Language.Exp+-- import Shady.Language.Graph++import Shady.Language.Type+++-- Stable names have EQ but not Ord, so they're not convenient for fast+-- maps. On the other hand, there's 'hashStableName', which generates an+-- 'Int', with rare collisions. So represent the memo table as an IntMap+-- whose entries are lists of StableName/value pairs.+++-- @(k a, v a)@ pair+data StableBind k v =+ forall a. HasType a => SB (StableName (k a)) (v a)++-- Polymorphic function+type k :--> v = forall a. (HasType a, Show a) => k a -> v a++-- Sorry about the 'Show' constraint. Turns out to be needed indirectly,+-- due to constant folding.++-- Stable map+type SM k v = I.IntMap [StableBind k v]++-- | Pointer-based memoization. Evaluates keys to WHNF to improve hit rate.+memo :: (k :--> v) -> (k :--> v)+-- memo :: (forall a. HasType a => k a -> v a) -> (forall a. HasType a => k a -> v a)+-- memo :: HasType a => (k a -> v a) -> (k a -> v a)+memo f = fetch f (unsafePerformIO (newMVar I.empty))++{-+-- polymorphic function+newtype Pfun p q a = Pfun { unPfun :: p a -> q a }++-- | Memoized binary function+-- memo2 :: HasType a =>+-- (k a -> l a -> v a) -> (k a -> l a -> v a)+memo2 :: (forall a. HasType a => k a -> l a -> v a)+ -> (forall a. HasType a => k a -> l a -> v a)+memo2 h = unPfun . memo (Pfun . memo . h)++-- h :: k a -> l a -> v a+-- memo . h :: k a -> l a -> v a+-- Pfun . memo . h :: k a -> Pfun l v a+-- memo (Pfun . memo . h) :: k a -> Pfun l v a+-- unPfun . memo (Pfun . memo . h) :: k a -> l a -> v a++-- | Memoized binary function+memo3 :: HasType a =>+ (k a -> l a -> m a -> v a) -> (k a -> l a -> m a -> v a)+memo3 h = unPfun . memo (Pfun . memo2 . h)++pfun2 :: (l a -> m a -> v a) -> Pfun l (Pfun m v) a+pfun2 = Pfun . fmap Pfun++unPfun2 :: Pfun l (Pfun m v) a -> (l a -> m a -> v a)+unPfun2 = fmap unPfun . unPfun++-- h :: k a -> l a -> m a -> v a+-- memo2 . h :: k a -> l a -> m a -> v a+-- pfun2 . memo2 . h :: k a -> Pfun l (Pfun m v) a+-- memo (pfun2 . memo2 . h) :: k a -> Pfun l (Pfun m v) a+-- unPfun2 . memo (pfun2 . memo2 . h) :: k a -> l a -> m a -> v a++-- I worry that the function compositions will lose sharing.+++-- -- | Memoized ternary function+-- memo3 :: HasType a =>+-- (k a -> l a -> m a -> v a) -> (k a -> l a -> m a -> v a)+-- memo3 h = unPfun2 . memo (pfun2 . memo2 . h)++-}++-- TODO: Make lazy and strict versions.++-- fetch :: (k :--> v) -> MVar (SM k v) -> (k :--> v)+fetch :: HasType a => (k a -> v a) -> MVar (SM k v) -> (k a -> v a)++fetch f smv !k = unsafePerformIO $+ do st <- makeStableName k+ modifyMVar smv $ \ sm -> return $+ let h = hashStableName st in+ maybe (let v = f k in (I.insertWith (++) h [SB st v] sm, v)) -- new+ ((,) sm) -- found+ (I.lookup h sm >>= blookup st) -- look++blookup :: forall k v a. HasType a =>+ StableName (k a) -> [StableBind k v] -> Maybe (v a)+blookup stk = look+ where+ look :: [StableBind k v] -> Maybe (v a)+ look [] = Nothing+ look (SB stk' v : binds') + | Just Refl <- tya `tyEq` typeOf2 stk', stk == stk' = Just v+ | otherwise = look binds'+ tya :: Type a+ tya = typeT
+ src/Data/StableMemo.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TypeOperators, BangPatterns #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Data.StableMemo+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Memoization based using stable names. WHNFs keys.+----------------------------------------------------------------------++module Data.StableMemo (memo,memo2,memo3) where++import System.IO.Unsafe (unsafePerformIO)+-- import Debug.Trace (trace)++import Control.Concurrent.MVar+import System.Mem.StableName+import qualified Data.IntMap as I+++-- import Shady.Language.Graph+-- import Shady.Language.Operator+-- import Shady.Language.Exp+-- import Shady.Language.Graph+++-- Stable names have EQ but not Ord, so they're not convenient for fast+-- maps. On the other hand, there's 'hashStableName', which generates an+-- 'Int', with rare collisions. So represent the memo table as an IntMap+-- whose entries are lists of StableName/value pairs.+++-- @(k a, v a)@ pair+type StableBind k v = (StableName k, v)++-- Stable map+type k :-> v = I.IntMap [StableBind k v]+++-- | Pointer-based memoization. Evaluates keys to WHNF to improve hit rate.+memo :: (k -> v) -> (k -> v)+memo f = fetch f (unsafePerformIO (newMVar I.empty))++-- | Memoized binary function+memo2 :: (k -> l -> v) -> (k -> l -> v)+memo2 h = memo (memo . h)++-- | Memoized ternary function+memo3 :: (k -> l -> m -> v) -> (k -> l -> m -> v)+memo3 h = memo (memo2 . h)++-- TODO: Make lazy and strict versions.++fetch :: (k -> v) -> MVar (k :-> v) -> (k -> v)++fetch f smv !k = unsafePerformIO $+ do st <- makeStableName k+ modifyMVar smv $ \ sm -> return $+ let h = hashStableName st in+ maybe (let v = f k in (I.insertWith (++) h [(st,v)] sm, v)) -- new+ ((,) sm) -- found+ (I.lookup h sm >>= lookup st) -- look++{-+---- tests++sqr :: Num a => a -> a+sqr x = trace ("sqr " ++ show x) $ x*x++t1,t2,t3,t4 :: Int++t1 = sqr 6 + sqr 6+t2 = s + s where s = sqr 6++-- Doesn't reuse 6 in ghci & ghc, but probably does with ghc -O+t3 = sqr' 6 + sqr' 6+ where+ sqr' = memo sqr++-- Works!+t4 = sqr' six + sqr' six+ where+ sqr' = memo sqr+ six = 6++q :: Integer -> Integer+q = memo sqr++-}
+ src/Shady/CompileE.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE TypeOperators, ScopedTypeVariables, ExistentialQuantification+ #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.CompileE+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Generate and compile vertex and fragment shaders.+-- +-- In this version, shader programs are represented by functions function+-- a single expression to a single expression. See also CompileEs, which+-- allows functions between more flexible representations.+----------------------------------------------------------------------++module Shady.CompileE+ ( -- VShaderF, FShaderF, SProgramF(..)+ Pos, (:->)(..), ShaderVF+ , GLSL(..), shaderProgram+ -- , ShaderExe(..), sinker, compile+ ) where++-- import Control.Applicative (liftA3)++import Text.PrettyPrint.Leijen+import qualified Text.PrettyPrint.Leijen as L+import Text.PrettyPrint.Leijen.PrettyPrec (PrettyPrec)+import Text.PrettyPrint.Leijen.DocExpr++-- import Shady.Misc (Sink)+import Shady.Language.Glom+import Shady.Language.Exp+import Shady.Language.GLSL+-- import Shady.Color (Color)++{-+import Shady.MechanicsGL (setupShader,glUseProgram,glMaxTextureUnits)+import Shady.Uniform+import Shady.Attribute+-}++-- | For gl_Position+type Pos = R4+++{--------------------------------------------------------------------+ Generate and compile shader programs+--------------------------------------------------------------------}++infixr 7 :->, :-^, :-*++-- | Vertex shader+type a :-^ v = a :=>* (Pos,v)++-- | Fragment shader+type v :-* o = v :=>* (R4,o)++-- type v :--> o = v :=>* (R4,o)++-- | For building vertex/fragment shader pairs. The idea is that a+-- complete parameterized shader program has type @u :=> a :- v :--> o@,+-- which expands to @u :=> (a :-^> v, v :-* o)@.+-- +-- u == uniform, a == (vertex) attribute, v == varying, o == fragment output.+-- +-- When @o == ()@ (color-only output), use the short-hand @u :=> a :-> v@.++-- | General vertex/fragment shader pair.+data a :-> o = forall v. (HasType v, HasExpr v, PrettyPrec v) =>+ ShaderVF (a :-^ v) (v :-* o)++-- | Vertex/fragment pair with no extra output besides color+type ShaderVF a = a :-> ()++-- | GLSL vertex program, fragment program, uniform and vertex attribute.+data GLSL u a = GLSL String String (Pat u) (Pat a)++instance (HasExpr u, HasExpr a) => Pretty (GLSL u a) where+ pretty (GLSL v f u a) = announce "vertex " v <$> announce "fragment" f+ <$> pretty (u,a)+ where+ announce l sh = text (l ++ ": ") L.<+> align (pretty sh)++instance (HasExpr u, HasExpr a) => Show (GLSL u a) where+ show = show . pretty++-- | Compile a parameterized shader program. TODO: generalize to non-()+-- outputs, i.e., to @u :=> a :-> o@.+shaderProgram :: (HasType a, HasExpr a, HasType u, HasExpr u) =>+ (u :=> ShaderVF a) -> GLSL u a+shaderProgram uav =+ case uav (patE u) of+ ShaderVF vert frag ->+ let v = pat "_varying"+ + vertOut = vert (patE a)+ fragOut = frag (patE v)+ + uD = D [ Uniform ] u+ aD = D [Attribute] a+ vD = D [ Varying ] v+ + vsh = shader [uD,aD,vD] (glPosition :* v ) vertOut+ fsh = shader [uD, vD] (glFragColor :* UnitG) fragOut+ in+ GLSL (show vsh) (show fsh) u a+ where+ -- Uniform/varying variables+ u = pat "_uniform"+ a = pat "_attribute"++-- The awkward "case" keeps ghc's brain from exploding.++-- TODO: What do we want to do when o /= ()?++shader :: (HasExpr a, HasType a) => [Declaration] -> Pat a -> E a -> Shader+shader decls p e = Sh decls [mainDef (p =: e)]++{-++-- | Executable shader+data ShaderExe u a =+ ShaderExe { xSelect :: IO () -- ^ install this exe+ , xSinkU :: Sink u -- ^ set uniform+ , xsinkA :: Sink [a] -- ^ set attribute+ } ++sinker :: GLSL u a -> IO (ShaderExe u a)+sinker (GLSL vsh fsh u a) =+ do p <- setupShader vsh fsh+ units <- glMaxTextureUnits+ return $+ ShaderExe (glUseProgram p) (setUniform units u p) (setAttribute a p)++{-+-- | Compile a parameterized shader program. Set up a static (for now)+-- vertex mesh, and give a sink for setting uniforms and rendering.+compile :: (HasType a, HasExpr a, HasType u, HasExpr u) =>+ (u :=> ShaderVF a) -> IO () -> [a] -> IO (Sink u)+compile shf draw as =+ sinker (shaderProgram shf) >>= renderSE draw as++renderSE :: IO () -> [a] -> ShaderExe u a -> IO (Sink u)+renderSE draw as (ShaderExe useProg setU setA) =+ do useProg+ setA as+ return $ \ u -> useProg >> setU u >> draw++-- TODO: Maybe eliminate ShaderExe, collapsing sinker & renderSE into+-- compile++-}+++-- | Compile a parameterized shader program. Set up a static (for now)+-- vertex mesh, and give a sink for setting uniforms and rendering.+compile :: (HasType a, HasExpr a, HasType u, HasExpr u) =>+ (u :=> ShaderVF a) -> IO () -> [a] -> IO (Sink u)+compile shf draw as =+ do -- print (pretty g)+ p <- setupShader vsh fsh+ units <- glMaxTextureUnits+ let useProg = glUseProgram p+ setA = setAttribute pa p+ setU = setUniform units pu p+ useProg+ setA as+ return $ \ u -> useProg >> setU u >> draw+ where+ GLSL vsh fsh pu pa = shaderProgram shf+++-- TODO: switch from Sink [a] to Sink (Vbos a), so that the [a] -> Vbos+-- conversion can be done up front. Vbos = Glom Vbo. Then simplify the+-- signature to Vbos a -> u -> IO ().++-- For now I'm wiring in a fixed mesh.++-}
+ src/Shady/CompileEs.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE TypeOperators, ScopedTypeVariables, TypeFamilies+ , FlexibleContexts, ExistentialQuantification, GADTs+ #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.CompileEs+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Generate and compile vertex and fragment shaders. Unlike+-- "Shady.CompileE", this version allows a looser structure to+-- the inputs & outputs of shaders, according to 'FromE'. You can use+-- the types and 'compile' in this module, or just 'shaders', along with+-- "Shady.CompileE", e.g., @compile (shaders sh)@.+----------------------------------------------------------------------++module Shady.CompileEs+ ( shaders+ , Pos, (:->)(..), ShaderVF+ , GLSL+ , shaderProgram+ -- , ShaderExe(..), compile+ ) where++import Text.PrettyPrint.Leijen.PrettyPrec (PrettyPrec)+import Text.PrettyPrint.Leijen.DocExpr (HasExpr)++import Shady.Language.Exp+import qualified Shady.CompileE as C+import Shady.CompileE (Pos, GLSL)+-- import Shady.CompileE (ShaderExe(..))+-- import Shady.Misc (Sink)++{--------------------------------------------------------------------+ Generate and compile shader programs+--------------------------------------------------------------------}++infixr 7 :->, :-^, :-*++-- | Vertex shader+type a' :-^ v' = a' -> (E Pos,v')++-- | Fragment shader+type v' :-* o' = v' -> (E R4,o')++-- | General vertex/fragment shader pair.+data a' :-> o' =+ forall v' v. ( FromE v', v ~ ExpT v'+ , HasType v, HasExpr v, PrettyPrec v ) =>+ ShaderVF (a' :-^ v') (v' :-* o')++-- | Vertex/fragment pair with no extra output besides color+type ShaderVF a' = a' :-> ()++-- | Convert loosely structured shaders into single-exp shader+shaders :: forall u' a' o'.+ (FromE u', FromE a', FromE o') =>+ (o ~ ExpT o',a ~ ExpT a',u ~ ExpT u') =>+ ( HasExpr o, HasType o, Show o) =>+ (u' -> (a' :-> o'))+ -> u :=> (a C.:-> o)+shaders f u = case f (fromE u) of+ ShaderVF vert frag ->+ C.ShaderVF (toFromE vert) (toFromE frag)++-- | Compile a parameterized shader program. TODO: generalize to non-()+-- outputs, i.e., to @u :=> a :-> o@.+shaderProgram :: forall u' a' u a.+ ( FromE u', u ~ ExpT u', FromE a', a ~ ExpT a') =>+ ( HasType a, HasExpr a, HasType u, HasExpr u ) =>+ (u' -> ShaderVF a') -> GLSL u a+shaderProgram = C.shaderProgram . shaders++{-+-- | Compile a parameterized shader program. Set up a static (for now)+-- vertex mesh, and give a sink for setting uniforms and rendering.+compile :: forall u' a' u a.+ ( FromE u', u ~ ExpT u', FromE a', a ~ ExpT a') =>+ ( HasType a, HasExpr a, HasType u, HasExpr u ) =>+ (u' -> ShaderVF a') -> IO () -> [a] -> IO (Sink u)+compile = C.compile . shaders+-}
+ src/Shady/Complex.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE TypeOperators, CPP, DeriveDataTypeable, TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Complex+-- Copyright : (c) The University of Glasgow 2001, Conal Elliott 2009+-- License : BSD-style+-- +-- Maintainer : conal@conal.net+-- Stability : provisional+-- Portability : portable+--+-- Complex numbers. This version is modified from Data.Complex in base.+-- It eliminates the RealFloat requirement by using a more naive+-- definition of 'magnitude'. Also, defines instances for vector-space classes.+--+-----------------------------------------------------------------------------++module Shady.Complex+ (+ -- * Rectangular form+ Complex((:+))++ , realPart -- :: Complex a -> a+ , imagPart -- :: Complex a -> a+ -- * Polar form+ , mkPolar -- :: a -> a -> Complex a+ , cis -- :: a -> Complex a+ , polar -- :: Complex a -> (a,a)+ -- , magnitude -- :: Complex a -> a+ , phase -- :: Complex a -> a+ -- * Conjugate+ , conjugate -- :: Complex a -> Complex a++ -- Complex instances: (Eq,Read,Show,Num,Fractional,Floating)+ -- Complex instances: (AdditiveGroup, VectorSpace, InnerSpace)++ -- * Misc interface additions+ , onRI, onRI2+ ) where++import Prelude++import Data.Typeable+#ifdef __GLASGOW_HASKELL__+import Data.Data (Data)+#endif++#ifdef __HUGS__+import Hugs.Prelude(Num(fromInt), Fractional(fromDouble))+#endif++import Data.VectorSpace++import Shady.Misc (Unop,Binop,FMod(..),Frac(..))+import Text.PrettyPrint.Leijen.DocExpr+++infix 6 :+++-- -----------------------------------------------------------------------------+-- The Complex type++-- | Complex numbers are an algebraic type.+--+-- For a complex number @z@, @'abs' z@ is a number with the magnitude of @z@,+-- but oriented in the positive real direction, whereas @'signum' z@+-- has the phase of @z@, but unit magnitude.+data Complex a+ = !a :+ !a -- ^ forms a complex number from its real and imaginary+ -- rectangular components.+# if __GLASGOW_HASKELL__+ deriving (Eq, Show, Read, Data)+# else+ deriving (Eq, Show, Read)+# endif++-- -----------------------------------------------------------------------------+-- Functions over Complex++-- | Extracts the real part of a complex number.+realPart :: Complex a -> a+realPart (x :+ _) = x++-- | Extracts the imaginary part of a complex number.+imagPart :: Complex a -> a+imagPart (_ :+ y) = y++-- | The conjugate of a complex number.+{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-}+conjugate :: Num a => Unop (Complex a)+conjugate (x:+y) = x :+ (-y)++-- | Form a complex number from polar components of magnitude and phase.+{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-}+mkPolar :: Floating a => a -> a -> Complex a+mkPolar r theta = r * cos theta :+ r * sin theta++-- | @'cis' t@ is a complex value with magnitude @1@+-- and phase @t@ (modulo @2*'pi'@).+{-# SPECIALISE cis :: Double -> Complex Double #-}+cis :: Floating a => a -> Complex a+cis theta = cos theta :+ sin theta+++-- | The function 'polar' takes a complex number and+-- returns a (magnitude, phase) pair in canonical form:+-- the magnitude is nonnegative, and the phase in the range @(-'pi', 'pi']@;+-- if the magnitude is zero, then so is the phase.+{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-}+polar :: Floating a => Complex a -> (a,a)+polar z = (magnitude z, phase z)+++-- | Operate on the real & imaginary components+onRI :: Unop a -> Unop (Complex a)+onRI f (x :+ y) = f x :+ f y++-- | Operate on the real & imaginary components+onRI2 :: Binop a -> Binop (Complex a)+onRI2 f (x :+ y) (x' :+ y') = f x x' :+ f y y'++instance Floating a => AdditiveGroup (Complex a) where+ { zeroV = 0 ; negateV = negate ; (^+^) = (+) }++instance Floating a => VectorSpace (Complex a) where+ type Scalar (Complex a) = a+ -- s *^ (x :+ y) = s * x :+ s * y+ (*^) s = onRI (s *)++instance Floating a => InnerSpace (Complex a) where+ (x :+ y) <.> (x' :+ y') = x*x' + y*y'+++{-++-- | The nonnegative magnitude of a complex number.+{-# SPECIALISE magnitude :: Complex Double -> Double #-}+magnitude :: Floating a => Complex a -> a+magnitude = sqrt . magSq++magnitudeSq :: Floating a => Complex a -> a++-- magnitude (x:+y) = scaleFloat k+-- (sqrt (sqr (scaleFloat mk x) + sqr (scaleFloat mk y)))+-- where k = max (exponent x) (exponent y)+-- mk = - k+-- sqr z = z * z++-}++-- | The phase of a complex number, in the range @(-'pi', 'pi']@.+-- If the magnitude is zero, then so is the phase.+{-# SPECIALISE phase :: Complex Double -> Double #-}+phase :: Floating a => Complex a -> a+-- The zero case requires a real EQ instance+-- phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson+phase (x:+y) = atan2' y x++-- To avoid reliance on 'RealFloat'.+atan2' :: (Floating a) => a -> a -> a+atan2' y x = atan (y/x)++-- -----------------------------------------------------------------------------+-- Instances of Complex++#include "Typeable.h"+INSTANCE_TYPEABLE1(Complex,complexTc,"Complex")++instance Floating a => Num (Complex a) where+ {-# SPECIALISE instance Num (Complex Float) #-}+ {-# SPECIALISE instance Num (Complex Double) #-}+ (x:+y) + (x':+y') = (x+x') :+ (y+y')+ (x:+y) - (x':+y') = (x-x') :+ (y-y')+ (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x')+ negate (x:+y) = negate x :+ negate y+ abs z = magnitude z :+ 0+ signum (0:+0) = 0+ signum z@(x:+y) = x/r :+ y/r where r = magnitude z+ fromInteger n = fromInteger n :+ 0+#ifdef __HUGS__+ fromInt n = fromInt n :+ 0+#endif++instance Floating a => Fractional (Complex a) where+ {-# SPECIALISE instance Fractional (Complex Float) #-}+ {-# SPECIALISE instance Fractional (Complex Double) #-}++ (x:+y) / v@(x':+y') = ((x*x'+y*y') :+ (y*x'-x*y')) ^/ magnitudeSq v++-- (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d+-- where x'' = scaleFloat k x'+-- y'' = scaleFloat k y'+-- k = - max (exponent x') (exponent y')+-- d = x'*x'' + y'*y''++ fromRational a = fromRational a :+ 0+#ifdef __HUGS__+ fromDouble a = fromDouble a :+ 0+#endif++instance Floating a => Floating (Complex a) where+ {-# SPECIALISE instance Floating (Complex Float) #-}+ {-# SPECIALISE instance Floating (Complex Double) #-}+ pi = pi :+ 0+ exp (x:+y) = expx * cos y :+ expx * sin y+ where expx = exp x+ log z = log (magnitude z) :+ phase z++-- x ** y = exp (log x * y)+-- sqrt = (** 0.5)++ -- Use default sqrt (** 0.5)++-- sqrt (0:+0) = 0+-- sqrt z@(x:+y) = u :+ (if y < 0 then -v else v)+-- where (u,v) = if x < 0 then (v',u') else (u',v')+-- v' = abs y / (u'*2)+-- u' = sqrt ((magnitude z + abs x) / 2)++ sin (x:+y) = sin x * cosh y :+ cos x * sinh y+ cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y)+ tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))+ where sinx = sin x+ cosx = cos x+ sinhy = sinh y+ coshy = cosh y++ sinh (x:+y) = cos y * sinh x :+ sin y * cosh x+ cosh (x:+y) = cos y * cosh x :+ sin y * sinh x+ tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)+ where siny = sin y+ cosy = cos y+ sinhx = sinh x+ coshx = cosh x++ asin z@(x:+y) = y':+(-x')+ where (x':+y') = log (((-y):+x) + sqrt (1 - z*z))+ acos z = y'':+(-x'')+ where (x'':+y'') = log (z + ((-y'):+x'))+ (x':+y') = sqrt (1 - z*z)+ atan z@(x:+y) = y':+(-x')+ where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))++ asinh z = log (z + sqrt (1+z*z))+ acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1)))+ atanh z = log ((1+z) / sqrt (1-z*z))+++{--------------------------------------------------------------------+ Pretty printing+--------------------------------------------------------------------}++-- infix 6 :+++instance HasExpr a => HasExpr (Complex a) where+ expr (x :+ y) = op Infix 6 ":+" (expr x) (expr y)+++{--------------------------------------------------------------------+ Misc+--------------------------------------------------------------------}++instance Frac s => Frac (Complex s) where frac = onRI frac+instance FMod s => FMod (Complex s) where fmod = onRI2 fmod
+ src/Shady/Language/Cse.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE GADTs, KindSignatures, TypeFamilies, MultiParamTypeClasses+ , ScopedTypeVariables, PatternGuards+ #-}+{-# OPTIONS_GHC -Wall -fno-warn-unused-imports -fno-warn-orphans -fno-warn-missing-signatures #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.Language.Cse+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Common subexpression elimination.+-- +-- TODO: Improve variable names (now \"x8\" etc).+----------------------------------------------------------------------++module Shady.Language.Cse (cse) where++import Control.Applicative (pure,(<$>),(<*>))+import Data.Maybe (fromMaybe)+import qualified Data.IntMap as I++import System.IO.Unsafe (unsafePerformIO)++import Shady.Misc+import Shady.Language.Type+import Shady.Language.Operator+import Shady.Language.Exp++import Shady.Language.Graph+import Shady.Language.Reify++-- V from Tid+ev :: Tid a -> V a+ev (Tid i t) = V ('x':show i) t++children :: N a -> [NodeId]+children (VN _) = []+children (ON _) = []+children (App (Tid a _) (Tid b _)) = [a,b]++childrenB :: Bind -> [NodeId]+childrenB (Bind _ n) = children n++-- Number of references for each node. Important: partially apply, so+-- that the binding list can be converted just once into an efficiently+-- searchable representation.+uses :: [Bind] -> (NodeId -> Int)+uses = fmap (fromMaybe 0) .+ flip I.lookup .+ histogram .+ concatMap childrenB++-- histogram :: Ord k => [k] -> I.Map k Int+-- histogram = foldr (\ k -> I.insertWith (+) k 1) I.empty++histogram :: [Int] -> I.IntMap Int+histogram = foldr (\ k -> I.insertWith (+) k 1) I.empty++-- Fast version, using an IntMap. Important: partially apply.+bindsF :: forall a. [Bind] -> (Tid a -> N a)+bindsF binds = \ (Tid i' a') -> extract a' (I.lookup i' m)+ where+ m :: I.IntMap Bind+ m = I.fromList [(i,b) | b@(Bind i _) <- binds]+ extract :: Type a' -> Maybe Bind -> N a'+ extract _ Nothing = error "bindsF: variable not found"+ extract a' (Just (Bind _ n))+ | Just Refl <- typeOf1 n `tyEq` a' = n+ | otherwise =+ error $ "bindsF: wrong type. " ++ show (typeOf1 n) ++ " vs " ++ show a'++tid :: HasType a => NodeId -> Tid a+tid i = Tid i typeT++letI :: (HasType a, HasType b) => NodeId -> E a -> E b -> E b+letI i = letE (ev (tid i))++unGraph :: HasType a => Graph a -> E a+unGraph (Graph binds root) = foldr llet (var' root) (reverse binds)+ where+ -- Wrap a let if non-trivial+ llet :: HasType b => Bind -> E b -> E b+ llet bind | trivial bind = id+ llet (Bind i n) = letI i (nodeE' n)+ -- How many uses of variable+ count :: NodeId -> Int+ count = uses binds+ -- Bindings as IntMap lookup+ psf :: Tid a -> N a+ psf = bindsF binds+ -- Too trivial to bother abstracting.+ trivial :: Bind -> Bool+ trivial (Bind _ (VN _)) = True+ trivial (Bind _ (ON (Lit a))) = not (abstractable a)+ trivial (Bind _ (ON _)) = True+ trivial (Bind i _) | count i < 2 = True+ trivial _ = False+ -- Like nodeE but with inlining of trivial bindings+ nodeE' :: N a -> E a+ nodeE' (VN v) = Var v+ nodeE' (ON o) = Op o+ nodeE' (App a b) = var' a :^ var' b+ -- Variable reference or inline+ var' :: HasType a => Tid a -> E a+ var' t@(Tid i _) | trivial (Bind i n) = nodeE' n+ | otherwise = Var (ev t)+ where+ n = psf t++-- Possible and worthwhile to abstract.+abstractable :: forall a. HasType a => a -> Bool+abstractable a = + case (typeOf a :: Type a) of+ VecT (VectorT n _) -> natToZ n > 1+ _ -> False++-- | Common subexpression elimination. Use with care, since it breaks+-- referential transparency on the /representation/ of expressions, but+-- not on their meaning.+cse :: HasType a => E a -> E a+cse = unsafePerformIO . fmap unGraph . reifyGraph++{-++-- Remove the comment braces to use the testing code++{--------------------------------------------------------------------+ Testing+--------------------------------------------------------------------}++-- Simpler version of unGraph. No inlining.+unGraph' :: HasType a => Graph a -> E a+unGraph' (Graph binds root) = foldr f (Var (ev root)) (reverse binds)+ where+ f :: Bind -> (forall b. HasType b => E b -> E b)+ f (Bind i n) = letE (ev (Tid i (typeOf1 n))) (nodeE n)+ nodeE (VN v) = Var v+ nodeE (ON o) = Op o+ nodeE (App u v) = Var (ev u) :^ Var (ev v)++-- Convert expressions to simple SSA forms+ssa :: HasType a => E a -> IO (E a)+ssa = fmap unGraph' . reifyGraph+++-- type-specialize+reify :: HasType a => E a -> IO (Graph a)+reify = reifyGraph++type I1 = One Int++va, vb :: E I1+va = Var (var "a")+vb = Var (var "b")+++-- test expressions+e1 = va + vb :: E I1+e2 = e1 * e1+e3 = va + va :: E I1++-- For instance,+++-- > e2+-- (a + b) * (a + b)+-- +-- > reify e2+-- let [0 = App x1 x3,1 = App x2 x3,3 = App x4 x7,7 = VN b,4 = App x5 x6,6 = VN a,5 = ON (+),2 = ON (*)] in x0+-- +-- > ssa e2+-- let x2 = (*) in +-- let x5 = (+) in +-- let x6 = a in +-- let x4 = x5 x6 in +-- let x7 = b in +-- let x3 = x4 x7 in +-- let x1 = x2 x3 in +-- let x0 = x1 x3 in +-- x0+-- +-- > cse e2+-- let x3 = a + b in +-- x3 * x3+++-}
+ src/Shady/Language/Exp.hs view
@@ -0,0 +1,1127 @@+{-# LANGUAGE GADTs, RankNTypes, KindSignatures, TypeOperators+ , StandaloneDeriving, GeneralizedNewtypeDeriving+ , PatternGuards, ScopedTypeVariables+ , FlexibleContexts, FlexibleInstances+ , TypeFamilies, TypeSynonymInstances+ , MultiParamTypeClasses, UndecidableInstances+ , EmptyDataDecls, CPP+ #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.Language.Exp+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Expressions.+----------------------------------------------------------------------++module Shady.Language.Exp+ (+ -- * Variables+ Id, V(..), var, genVar+ -- * Patterns+ , Pat, patT, pat+ -- * Type paths+ , TPath, emptyP, fstP, sndP, namePath+ -- * Expressions+ , E(..), (:=>), (:=>*)+ -- , Es, exps, (:>-), (:>-*)+ -- * n-ary operator application+ , op1, op2, op3, op4+ -- * Optimizing expression-builders+ , pureE, fmapE, liftE2, liftE3, liftE4+ -- * Operations+ , notE+-- , true, false+-- , (&&*), (||*)+-- , (<*), (<=*), (>=*), (>*)+-- , (==*), (/=*)+ , (==^), (/=^)+ , truncateE, roundE, ceilingE, floorE -- , fmod, fmodE, fracE+ , allV, anyV+ , SamplerE, texture+ , lit+ , BoolE, FloatE, R1E, R2E, R3E, R4E, VecE+ , vec2, vec3, vec4+ , un2, un3, un4+ , getX, getY, getZ, getW, get, (<+>)+ , unitE, pairE, fstE, sndE, unPairE, uniform, uniformV+ , ComplexE+ -- * Conversion to expressions+ , ToE(..), toE, FromE(..), toFromE, patE -- , ToEs, EsT, exps+ , module Shady.Language.Type+ -- , module Shady.Cat+ -- * Temporary+ , letE+ )+ where++import Data.Monoid (Monoid(..),First(..))+import Data.Maybe (fromMaybe)+import Control.Applicative (Applicative(pure),(<$>))+import Control.Monad (liftM2)+import Control.Arrow ((&&&),second)++import Text.PrettyPrint.Leijen hiding ((<$>),(<+>))+import Text.PrettyPrint.Leijen.PrettyPrec+import Text.PrettyPrint.Leijen.DocExpr hiding (var,apply)+import qualified Text.PrettyPrint.Leijen.DocExpr as X++import Control.Compose (result,(~>))++import Data.Boolean++import Data.VectorSpace++import Data.NameM+import Shady.Language.Type hiding ((<+>),vec2,vec3,vec4,un2,un3,un4,get)+import Shady.Language.Glom+import qualified Shady.Vec as V+import Shady.Language.Operator+import Shady.Misc+import Shady.Complex+++{--------------------------------------------------------------------+ Strays+--------------------------------------------------------------------}++deriving instance Functor First+deriving instance Applicative First+deriving instance Monad First++fromFirst :: a -> First a -> a+fromFirst a = fromMaybe a . getFirst+++{--------------------------------------------------------------------+ Variables+--------------------------------------------------------------------}++-- | Variable name+type Id = String++-- | Typed variables+data V a = V { varName :: Id, varType :: Type a } deriving Show++instance SynEq V where V a _ =-= V b _ = a == b++-- TODO: consider replacing the VectorT a with a constraint: IsVector a =>++-- instance Show (V a) where show = varName++instance HasExprU V where+ exprU = X.var . show+ -- exprU (V i ty) = op InfixL 0 "::" (X.var ('x':show i)) (exprU ty)++instance HasExpr a => HasExpr (V a) where expr = exprU++-- Or:+-- +-- instance HasExpr a => HasExpr (V a) where+-- expr (V name ty) = op InfixL 0 "::" (X.var name) (expr ty)+-- +-- instance HasExprU V where exprU = expr++instance HasExpr a => PrettyPrec (V a) where prettyPrec = prettyExpr+instance HasExpr a => Pretty (V a) where pretty = prettyPrec 0++-- instance HasExpr a => Show (V a) where showsPrec = showsPrettyPrec++-- -- | Equality on variables, ignoring type.+-- vEq :: V a -> V b -> Bool+-- V n _ `vEq` V n' _ = n == n'++-- | Make a variable, inferring the type from context.+var :: HasType a => Id -> V a+var = flip V typeT++-- TODO: maybe split var into uvar and avar++genVar :: HasType a => NameM (V a)+genVar = var <$> genName+++{--------------------------------------------------------------------+ Type paths+--------------------------------------------------------------------}++-- | Type path+newtype TPath = TPath String++-- | Empty type path+emptyP :: TPath+emptyP = TPath ""++-- | Extend a type path+fstP, sndP :: TPath -> TPath+fstP (TPath p) = TPath ('F' : p)+sndP (TPath p) = TPath ('S' : p)++-- | Augment a variable name with a type path+namePath :: String -> TPath -> String+namePath vname (TPath "") = vname+namePath vname (TPath p) = vname ++ "_" ++ reverse p++-- TODO: use a safer separator than "_" (avoiding real variable names).+-- With "__", I get "OpenGL reserves names containing '__'"+++{--------------------------------------------------------------------+ Patterns+--------------------------------------------------------------------}++-- | Variable patterns+type Pat = Glom V++-- | The type of a pattern+patT :: Pat a -> Type a+patT (BaseG (V _ t)) = t+patT UnitG = UnitT+patT (a :* b) = patT a :*: patT b+++-- | Make a variable pattern, inferring the type from context.+pat :: HasType a => String -> Pat a+pat vname = divvy emptyP typeT+ where+ divvy :: TPath -> Type s -> Pat s+ divvy _ UnitT = UnitG+ divvy path (a :*: b) = divvy (fstP path) a :* divvy (sndP path) b+ divvy _ (_ :->: _) = error "pat: function type not handled"+ divvy path t = BaseG (V (namePath vname path) t)++-- Note divvy is not quite a fmapU, because of the path accumulation.+-- Look out for similar definitions.+++{--------------------------------------------------------------------+ Simple expressions+--------------------------------------------------------------------}++infixl 9 :^++-- | Simple expressions (no 'Let'). Statically typed.+-- Constructors for operator/constant ('Op'), variable ('Var'),+-- application ('(:^)'), and abstraction ('Lam').+data E :: * -> * where+ Op :: Op a -> E a -- -- ^ operator/constant+ Var :: V a -> E a -- -- ^ variable+ (:^) :: HasType a =>+ E (a -> b) -> E a -> E b -- -- ^ application+ Lam :: HasType a =>+ V a -> E b -> E (a -> b) -- -- ^ abstraction++-- TODO: when haddock is fixed, reinstate per-ctor haddock comments and+-- remove the constructor comments in the data doc.++instance SynEq E where+ Op o =-= Op o' = o =-= o'+ Var v =-= Var v' = v =-= v'+ f :^ x =-= g :^ y = f === g && x === y+ _ =-= _ = False++-- TODO: what about lambdas? False negatives are okay for our use, which+-- is optimization.++-- | Short-hand for beta-redex+letE :: (HasType a, HasType b) =>+ V a -> E a -> E b -> E b+letE v a b = Lam v b :^ a+++instance HasExpr (E a) where+ expr (Op oper) = X.var (show oper)+ expr (Var (V n _)) = X.var n+ expr e@(_ :^ _) = appExpr e []+ expr (Lam (V n _) f) = lambdaX n (expr f)+++-- Application expr, passing in argument exprs.+appExpr :: forall a. E a -> [Expr] -> Expr+appExpr (Op o) xs = opExpr o xs+appExpr (Op Not :^ (Op (Lt n) :^ a :^ b)) xs = appExpr (Op (Le n) :^ b :^ a) xs+appExpr (Op Mul :^ a :^ (Op Recip :^ b)) xs = appExpr (Op Divide :^ a :^ b) xs+appExpr (Op Add :^ a :^ (Op Negate :^ b)) xs = appExpr (Op Sub :^ a :^ b) xs+appExpr e@(Op (Cat _ _ _) :^ _ :^ _) xs+ | First (Just e') <- catFix e = appExpr e' xs+appExpr (Op (Swizzle ixs) :^ v) xs + | Just e' <- swizzleOpt ixs v = appExpr e' xs+appExpr (Lam v b :^ a) xs = foldl ($$) (letExpr v a b) xs+appExpr (f :^ e) xs = appExpr f (expr e : xs)+appExpr f xs = foldl ($$) (expr f) xs+++-- Flatten stacked cats.+catFix :: a :=>? a+catFix (Op (Cat (Succ Zero) (Succ Zero) _) :^ a :^ b) =+ pure (Op VVec2 :^ a :^ b)+catFix (Op (Cat (Succ Zero) _ _) :^ a :^ b) = catFix b >>= consV a+catFix _ = mempty++consV :: One a :=> Vec n a :=>? (Vec (S n) a)+consV a (Op VVec2 :^ b :^ c) = pure (Op VVec3 :^ a :^ b :^ c)+consV a (Op VVec3 :^ b :^ c :^ d) = pure (Op VVec4 :^ a :^ b :^ c :^ d)+consV _ _ = mempty++-- e.g., foo.xyz --> foo if foo is 3D+swizzleOpt :: forall n m a. (IsNat m, IsNat n) =>+ Vec n (Index m) -> E (Vec m a) -> Maybe (E (Vec n a))+swizzleOpt ixs v | Just Refl <- m `natEq` n, ixs == indices n = Just v+ | otherwise = Nothing+ where+ m = nat :: Nat m+ n = nat :: Nat n++++-- Let expression+letExpr :: HasType a => V a -> E a -> E b -> Expr+letExpr (V n _) a b = letX n (expr a) (expr b)++-- exprFun :: (HasExpr c, HasType a) =>+-- (E a -> c) -> Id -> Expr+-- exprFun f = expr . f . Var . var . idName++instance PrettyPrec (E a) where prettyPrec = prettyExpr+instance Pretty (E a) where pretty = prettyPrec 0+instance Show (E a) where show = show . pretty+++infixr 7 :=>, :=>*++-- | Function from expressions. Nestable.+type a :=> b = E a -> b++-- | Expression to expression. Ends a chain of '(:=>)'+type a :=>* b = a :=> E b+++infixr 7 :=>?+-- | Expression to possible expression. Ends a chain of '(:=>)'.+type a :=>? b = a :=> First (E b)+++{--------------------------------------------------------------------+ Convenient n-ary operator application+--------------------------------------------------------------------}++-- | Convenient operator application+op1 :: (HasType a, HasType b) =>+ Op (a -> b) -> a :=>* b+op1 o a = Op o :^ a++-- | Convenient operator application+op2 :: (HasType a, HasType b, HasType c) =>+ Op (a -> b -> c) -> a :=> b :=>* c+op2 o a b = op1 o a :^ b++-- | Convenient operator application+op3 :: (HasType a, HasType b, HasType c, HasType d) =>+ Op (a -> b -> c -> d) -> a :=> b :=> c :=>* d+op3 o a b c = op2 o a b :^ c++-- | Convenient operator application+op4 :: (HasType a, HasType b, HasType c, HasType d, HasType e) =>+ Op (a -> b -> c -> d -> e) -> a :=> b :=> c :=> d :=>* e+op4 o a b c d = op3 o a b c :^ d+++{--------------------------------------------------------------------+ Simplification / optimization+--------------------------------------------------------------------}++infix 0 @>+-- | Simplification result with fall-back value.+(@>) :: First a -> a -> a+(@>) = flip fromFirst++++-- | Left identity: @i `op` a == a@+identityL :: Eq a => a -> a :=> b :=>? b+identityL i (Op (Lit u)) b | u == i = pure b+identityL _ _ _ = mempty++-- | Right identity: @a `op` i == a@+identityR :: Eq b => b -> a :=> b :=>? a+identityR i a (Op (Lit v)) | v == i = pure a+identityR _ _ _ = mempty++-- | Symmetric identity, combining 'identityL' and 'identityR'.+identity :: Eq a => a -> a :=> a :=>? a+identity = identityL `mappend` identityR++-- Will GHC optimize 'identity' to the following?++-- identity i (Op (Lit u)) b | u == i = pure b+-- identity i a (Op (Lit v)) | v == i = pure a+-- identity _ _ _ = mempty++-- | Annihilator: @z * a == z@+annihilator :: Eq a => a -> a :=> a :=>? a+annihilator z (Op (Lit u)) _ | u == z = pure (pureE z)+annihilator z _ (Op (Lit v)) | v == z = pure (pureE z)+annihilator _ _ _ = mempty+++-- | Inverse-related properties+inverse :: Op (a -> a -> a) -> a :=> a :=>? a+inverse Add a (Op Negate :^ b) | a =-= b = pure 0+inverse Add (Op Negate :^ b) a | a =-= b = pure 0+inverse Mul a (Op Recip :^ b) | a =-= b = pure 1+inverse Mul (Op Recip :^ b) a | a =-= b = pure 1+inverse Mul a (Op (Lit (-1))) = pure (negate a)+inverse Mul (Op (Lit (-1))) a = pure (negate a)+inverse _ _ _ = mempty+++-- | Commute, to get literals together: @3 + a == a + 3@,+-- @(a + 3) + b == (a + b) + 3@.+-- +-- Might be a bad idea, as it can break sharing. Think through.+-- Not really effective without associate, which breaks even more sharing.+commute :: a :=> a :=>? a+-- commute a@(Op (Lit _)) b = pure (b + a)+-- commute (Op Add :^ a :^ b@(Op (Lit _))) c = pure ((a + c) + b)+commute _ _ = mempty+++#define SIMPLIFY++-- | Operator-specific simplifation (unary)+simple1 :: Op (a -> b) -> a :=>? b+#ifdef SIMPLIFY+simple1 Negate (Op Negate :^ a) = pure a+simple1 Negate (Op Mul :^ a :^ b) = pure (negate a * b) -- see note+simple1 Negate (Op Add :^ a :^ b) = pure (negate a + negate b) -- see note+simple1 Recip (Op Recip :^ a) = pure a+simple1 Fst (Op Pair :^ a :^ _) = pure a+simple1 Snd (Op Pair :^ _ :^ b) = pure b+simple1 Cos (Op Negate :^ a) = pure (cos a)+simple1 Sin (Op Negate :^ a) = pure (- sin a)++-- Note: pushing the negate inward increases opportunities for vectorization,+-- but can break sharing. For Add, it also increases cost a bit.++-- TODO: more+#endif+simple1 _ _ = mempty++-- | Operator-specific simplifation (binary)+simple2 :: Op (a -> b -> c) -> a :=> b :=>? c+#ifdef SIMPLIFY+simple2 Add = identity 0 `mappend` addMul `mappend`+ inverse Add `mappend` commute+simple2 Mul = annihilator 0 `mappend` identity 1 `mappend`+ inverse Mul `mappend` commute `mappend` mulNegNeg+simple2 (Cat _ _ _) = (<+?>)+#endif+simple2 _ = mempty++-- TODO: Change identity and annihilator to take Add and Mul as+-- arguments. Then refactor for more reuse between Add & Mul and perhaps+-- all binary ops well.++-- simple2 Pair = pairFstSnd++-- | Operator-specific simplifation (ternary)+simple3 :: Op (a -> b -> c -> d) -> a :=> b :=> c :=>? d+#ifdef SIMPLIFY+simple3 If (Op (Lit c)) a b = pure $ if un1 c then a else b+simple3 If _ a b | a =-= b = pure a+-- TODO: more+#endif+simple3 _ _ _ _ = mempty+++-- | Operator-specific simplifation (quaternary)+simple4 :: Op (a -> b -> c -> d -> e) -> a :=> b :=> c :=> d :=>? e++#ifdef SIMPLIFY+-- TODO: more+#endif+simple4 _ = mempty+{-+-}+++-- Vectorization++infix 1 <+?>+(<+?>) :: forall n m a.+ (IsNat n, IsNat m, IsScalar a,+ IsNat (m :+: n), Show a) =>+ Vec m a :=> Vec n a :=>? Vec (m :+: n) a++-- Comment out the first rule as a temp work-around for glsl 1.2++-- a <+> a = a.(all<+>all)+a <+?> b | n' > 1 -- for glsl 1.2, which doesn't allow swizzling scalars.+ , Just Refl <- a =:= b = pure (Op (Swizzle (is V.<+> is)) :^ a)+ where+ -- With -XNoMonomorphismRestriction, we get an Ambiguous type variable.+ -- If I then add ":: n", ghc doesn't terminate.+ n :: Nat n+ n = nat+ n' = natToZ n+ is = indices n++-- a <+> a.js = a.(all<+>js)+a <+?> Op (Swizzle js) :^ b | Just Refl <- a =:= b =+ pure (Op (Swizzle (indices nat V.<+> js)) :^ a)+-- a.is <+> a = a.(is<+>all)+Op (Swizzle is) :^ a <+?> b | Just Refl <- a =:= b =+ pure (Op (Swizzle (is V.<+> indices nat)) :^ a)+-- a.is <+> a.js = a.(is<+>js)+Op (Swizzle is) :^ a <+?> Op (Swizzle js) :^ b+ | Just Refl <- a =:= b+ = pure (Op (Swizzle (is V.<+> js)) :^ a)++Op Min :^ a :^ a' <+?> Op Min :^ b :^ b' = pure ((a <+> b) `min` (a' <+> b'))+Op Max :^ a :^ a' <+?> Op Max :^ b :^ b' = pure ((a <+> b) `max` (a' <+> b'))+Op Add :^ a :^ a' <+?> Op Add :^ b :^ b' = pure ((a <+> b) + (a' <+> b'))+Op Sub :^ a :^ a' <+?> Op Sub :^ b :^ b' = pure ((a <+> b) - (a' <+> b'))+Op Mul :^ a :^ a' <+?> Op Mul :^ b :^ b' = pure ((a <+> b) * (a' <+> b'))+Op Quot :^ a :^ a' <+?> Op Quot :^ b :^ b' = pure ((a <+> b) `quot` (a' <+> b'))+Op Rem :^ a :^ a' <+?> Op Rem :^ b :^ b' = pure ((a <+> b) `rem` (a' <+> b'))+Op Div :^ a :^ a' <+?> Op Div :^ b :^ b' = pure ((a <+> b) `div` (a' <+> b'))+Op Mod :^ a :^ a' <+?> Op Mod :^ b :^ b' = pure ((a <+> b) `mod` (a' <+> b'))+Op FMod :^ a :^ a' <+?> Op FMod :^ b :^ b' = pure ((a <+> b) `fmod` (a' <+> b'))++Op Divide :^ a :^ a' <+?> Op Divide :^ b :^ b' = pure ((a <+> b) / (a' <+> b'))++Op Negate :^ a <+?> Op Negate :^ b = pure (negate (a <+> b))+Op Recip :^ a <+?> Op Recip :^ b = pure (recip (a <+> b))+Op Abs :^ a <+?> Op Abs :^ b = pure (abs (a <+> b))+Op Signum :^ a <+?> Op Signum :^ b = pure (signum (a <+> b))+Op Sqrt :^ a <+?> Op Sqrt :^ b = pure (sqrt (a <+> b))+Op Exp :^ a <+?> Op Exp :^ b = pure (exp (a <+> b))+Op Log :^ a <+?> Op Log :^ b = pure (log (a <+> b))+Op Sin :^ a <+?> Op Sin :^ b = pure (sin (a <+> b))+Op Cos :^ a <+?> Op Cos :^ b = pure (cos (a <+> b))+Op Asin :^ a <+?> Op Asin :^ b = pure (asin (a <+> b))+Op Acos :^ a <+?> Op Acos :^ b = pure (acos (a <+> b))+Op Sinh :^ a <+?> Op Sinh :^ b = pure (sinh (a <+> b))+Op Asinh :^ a <+?> Op Asinh :^ b = pure (asinh (a <+> b))+Op Atanh :^ a <+?> Op Atanh :^ b = pure (atanh (a <+> b))+Op Acosh :^ a <+?> Op Acosh :^ b = pure (acosh (a <+> b))+Op Truncate :^ a <+?> Op Truncate :^ b = pure (truncateE (a <+> b))+Op Round :^ a <+?> Op Round :^ b = pure (roundE (a <+> b))+Op Ceiling :^ a <+?> Op Ceiling :^ b = pure (ceilingE (a <+> b))+Op Floor :^ a <+?> Op Floor :^ b = pure (floorE (a <+> b))+Op Not :^ a <+?> Op Not :^ b = pure (notE (a <+> b))++-- I'm using @^ on the RHSs in order to get CSE. If I used the smart+-- constructors (min etc), I'd get more operator-specific optimization.+-- For now, I assume there won't be any. If I'm wrong, revisit.++-- The next three are trickier, because the result scalar type (Bool) does+-- not determine the argument types, which could thus differ. Hence the+-- compatibility check.++Op (EqualV _) :^ a :^ a' <+?> Op (EqualV _) :^ b :^ b'+ | Just Refl <- a `compatible1` b+ = pure ((a <+> b) ==* (a' <+> b'))++Op (Lt _) :^ a :^ a' <+?> Op (Lt _) :^ b :^ b'+ | Just Refl <- a `compatible1` b+ = pure ((a <+> b) <* (a' <+> b'))++Op (Le _) :^ a :^ a' <+?> Op (Le _) :^ b :^ b'+ | Just Refl <- a `compatible1` b+ = pure ((a <+> b) <=* (a' <+> b'))++_ <+?> _ = mempty++-- TODO: Eliminate the nat arguments to EqualV etc if they're now unused++-- | Undistribute: @a*b + a*b' == a*(b+b')@. Also, dot products+-- @a*b + a'*b' == (a,a') <.> (b,b')@+addMul :: forall n a.+ (IsNat n, IsScalar a, Num a) =>+ Vec n a :=> Vec n a :=>? Vec n a+-- (Op Mul :^ a :^ b) `addMul` (Op Mul :^ a' :^ b')+-- | a =-= a' = pure (a * (b + b'))+-- | b =-= b' = pure ((a + a') * b)++(Op Mul :^ a :^ b) `addMul` (Op Mul :^ a' :^ b')+ | Just Refl <- (typeT :: Type (Vec n a)) `tyEq` (typeT :: Type R1)+ = pure $ (a <+> a') <.> (b <+> b')++(Op Dot :^ a :^ b) `addMul` (Op Mul :^ a' :^ b')+ | Just Refl <- (typeT :: Type (Vec n a)) `tyEq` (typeT :: Type R1)+ , Just CanExtend <- canExtendE a+ = pure $ (a <+> a') <.> (b <+> b')++_ `addMul` _ = mempty++-- Proof that an n-vector can be extened by one element+data CanExtend :: * -> * where+ CanExtend :: IsNat (n :+: OneT) => CanExtend n++canExtend :: forall n. IsNat n => Maybe (CanExtend n)+canExtend =+ case (nat :: Nat n) of+ Zero -> j+ Succ Zero -> j+ Succ (Succ Zero) -> j+ Succ (Succ (Succ Zero)) -> j+ _ -> Nothing+ where+ j :: IsNat (m :+: OneT) => Maybe (CanExtend m)+ j = Just CanExtend++-- Pull in the type parameter+canExtendE :: IsNat n => f (Vec n a) -> Maybe (CanExtend n)+canExtendE = const canExtend+++-- -a * -b == a * b+mulNegNeg :: (IsNat n, IsScalar a, Num a) =>+ Vec n a :=> Vec n a :=>? Vec n a+mulNegNeg (Op Negate :^ a) (Op Negate :^ b) = pure (a * b)+mulNegNeg _ _ = mempty++++-- I don't know how to get the following simplification to type-check:++-- -- Surjectivity of pairs: (fst c, snd c) == c+-- pairFstSnd :: -- forall a b. (HasType a, HasType b) =>+-- a :=> b :=>? (a,b)+-- pairFstSnd (Op Fst :^ c) (Op Snd :^ c')+-- | Just Refl <- tyEq (typeT :: c) (typeT :: c'), +-- c =-= c' = pure c+-- surjectivePair _ _ = mempty++{-+-- -a * b == - (a * b) ; a * -b == - (a * b)+mulNegUp, negMul :: (IsNat n, IsScalar a, Num a) =>+ (Vec n a) :=> (Vec n a) :=>? (Vec n a)+mulNegUp (Op Negate :^ a) b = negMul a b+mulNegUp a (Op Negate :^ b) = negMul a b+mulNegUp _ _ = mempty++negMul a b = pure (Op Negate :^ (Op Mul :^ a :^ b))+-}+++{--------------------------------------------------------------------+ 'E' Lifters+--------------------------------------------------------------------}++-- Basic lifters. I've named them suggestively of 'Functor' and+-- 'Applicative' methods. They fit generalized versions of these classes+-- with the arrows being operators.++-- | Literal expression+pureE :: Show a => a -> E a+pureE = Op . Lit++-- | Apply a unary operator, with constant-folding and simplifications+fmapE :: (HasType a, HasType b {-, Show b-}) =>+ Op (a -> b) -> a :=>* b+#ifdef SIMPLIFY+fmapE o (Op (Lit x)) = Op (Lit (opVal o x))+#endif+fmapE o a = simple1 o a @> op1 o a++-- | Apply a binary operator, with constant-folding and simplifications+liftE2 :: (HasType a, HasType b, HasType c {-, Show c-}) =>+ Op (a -> b -> c) -> a :=> b :=>* c+#ifdef SIMPLIFY+liftE2 o (Op (Lit x)) (Op (Lit y)) = Op (Lit (opVal o x y))+#endif+liftE2 o a b = simple2 o a b @> op2 o a b++-- | Apply a ternary operator, with constant-folding and simplifications+liftE3 :: (HasType a, HasType b, HasType c, HasType d {-, Show d-}) =>+ Op (a -> b -> c -> d) -> a :=> b :=> c :=>* d+#ifdef SIMPLIFY+liftE3 o (Op (Lit x)) (Op (Lit y)) (Op (Lit z)) = Op (Lit (opVal o x y z))+#endif+liftE3 o a b c = simple3 o a b c @> op3 o a b c++-- | Apply an quaternary operator, with constant-folding and simplifications+liftE4 :: (HasType a, HasType b, HasType c, HasType d, HasType e {-, Show e-}) =>+ Op (a -> b -> c -> d -> e) -> a :=> b :=> c :=> d :=>* e+#ifdef SIMPLIFY+liftE4 o (Op (Lit w)) (Op (Lit x)) (Op (Lit y)) (Op (Lit z)) =+ Op (Lit (opVal o w x y z))+#endif+liftE4 o a b c d = simple4 o a b c d @> op4 o a b c d+++{--------------------------------------------------------------------+ E Instances+--------------------------------------------------------------------}++-- The types of some methods prevent them from being lifted to expressions+noOv :: String -> a+noOv meth = error $ meth ++ ": No overloading for E"++instance Eq (E a) where+ (==) = noOv "(==)"+ (/=) = noOv "(/=)"++instance (IsNat n, IsScalar a, Ord a, Show a) => Ord (E (Vec n a)) where+ min = liftE2 Min+ max = liftE2 Max+ (<) = noOv "(<)"++instance IsNat n => Boolean (VecE n Bool) where+ false = pureU False+ true = pureU True+ notB = fmapE Not+ (&&*) = liftE2 And+ (||*) = liftE2 Or++pureU :: (IsNat n, IsScalar a) => a -> VecE n a+pureU x = uniformV' (pureE (vec1 x))++-- Here's the weird deal: if pureU uses uniformV instead of uniformV',+-- then we trigger a bug in ghc 6.10.3:+-- +-- ghc: panic! (the 'impossible' happened)+-- (GHC version 6.10.3 for i386-unknown-linux):+-- initC: srt_lbl+-- +-- The definitions of uniformV and uniformV' are identical. If I+-- change the definition of uniform to use uniformV' instead of+-- uniformV, then uniformV' becomes the fatal choice in pureU.++uniformV' :: (IsNat n, IsScalar a, Show a) =>+ One a :=>* Vec n a+uniformV' = fmapE (UniformV vectorT)++-- Does GLSL have conjunction and disjunction on boolean vectors? If so,+-- then I can generalize this instance (using uniformV for false & true).+-- Even if GLSL doesn't have it, I could generate code. Then I can keep+-- EqB and OrdB deriving from Boolean.++-- | Transitional synonym for notB+notE :: IsNat n => Vec n Bool :=>* Vec n Bool+notE = notB++-- TODO: Eliminate notE++instance (IsNat n, IsScalar a, Show a) => IfB BoolE (VecE n a) where+ ifB = liftE3 If++-- -- | Synonym for 'ifB' (transitional)+-- ifE :: IfB b a => b -> a -> a -> a+-- ifE = ifB++-- -- | Expression-lifted conditional with condition last+-- ifE' :: IfB b a => a -> a -> b -> a+-- ifE' = boolean+++instance (IsNat n, IsScalar a, Eq a, Show a) => EqB (VecE n Bool) (VecE n a) where+ (==*) = liftE2 (EqualV nat)++instance (IsNat n, IsScalar a, Ord a, Show a) =>+ OrdB (VecE n Bool) (VecE n a) where+ (<*) = liftE2 (Lt nat)++infix 4 ==^, /=^++-- | Vector equality, resulting in a single Bool. See also '(==*)'.+(==^) :: (IsNat n, IsScalar a, Eq a, Show a) =>+ Vec n a :=> Vec n a :=>* B1+(==^) = liftE2 Equal++-- | Vector inequality, resulting in a single Bool. See also '(/=*)'.+(/=^) :: (IsNat n, IsScalar a, Eq a, Show a) =>+ Vec n a :=> Vec n a :=>* B1+(/=^) = (result.result) notE (==^)+++instance Enum a => Enum (E a) where+ succ = noOv "succ"+ pred = noOv "pred"+ toEnum = noOv "toEnum"+ fromEnum = noOv "fromEnum"+ enumFrom = noOv "enumFrom"+ enumFromThen = noOv "enumFromThen"+ enumFromTo = noOv "enumFromTo"+ enumFromThenTo = noOv "enumFromThenTo"++instance (IsNat n, IsScalar a, Num a) =>+ Num (E (Vec n a)) where+ fromInteger = pureE . fromInteger+ negate = fmapE Negate+ (+) = liftE2 Add+ (*) = liftE2 Mul+ abs = fmapE Abs+ signum = fmapE Signum++instance (IsNat n, IsScalar a, Ord a, Num a) =>+ Real (E (Vec n a)) where+ toRational = noOv "toRational"++instance (IsNat n, IsScalar b, Integral b) =>+ Integral (E (Vec n b)) where+ quot = liftE2 Quot+ rem = liftE2 Rem+ div = liftE2 Div+ mod = liftE2 Mod+ quotRem = both quot rem+ divMod = both div mod+ toInteger = noOv "toInteger"++both :: (a -> b -> c) -> (a -> b -> c') -> (a -> b -> (c,c'))+both f g a b = (f a b, g a b)++instance (IsNat n, IsScalar b, Fractional b) => Fractional (E (Vec n b)) where+ recip = fmapE Recip+ fromRational = pureE . fromRational++instance (IsNat n, IsScalar b, Floating b) => Floating (E (Vec n b)) where+ pi = pureE pi+ sqrt = fmapE Sqrt+ exp = fmapE Exp+ log = fmapE Log+ sin = fmapE Sin+ cos = fmapE Cos+ asin = fmapE Asin+ atan = fmapE Atan+ acos = fmapE Acos++ -- GLSL 1.2 doesn't support hyperbolic trig. Substitute these+ -- definitions. TODO: two paths, depending on GLSL version.++ sinh x = (exp x - exp (-x)) / 2+ cosh x = (exp x + exp (-x)) / 2+ asinh x = log (x + sqrt (x*x + 1))+ acosh x = log (x + sqrt (x*x - 1))+ atanh x = (log (1 + x) - log (1 - x)) / 2++-- sinh = fmapE Sinh+-- cosh = fmapE Cosh+-- asinh = fmapE Asinh+-- atanh = fmapE Atanh+-- acosh = fmapE Acosh++instance (IsNat n, IsScalar b, RealFrac b) => RealFrac (E (Vec n b)) where+ properFraction = noOv "properFraction"+ truncate = noOv "truncate"+ round = noOv "round"+ ceiling = noOv "ceiling"+ floor = noOv "floor"++-- truncateE, roundE, ceilingE, floorE :: (RealFrac a, Integral b) => a :=>* b++-- Funky types, to match GLSL:+truncateE, roundE, ceilingE, floorE :: IsNat n => Vec n R :=>* Vec n R++truncateE = fmapE Truncate+roundE = fmapE Round+ceilingE = fmapE Ceiling+floorE = fmapE Floor++instance (IsNat n, IsScalar a, FMod a) => FMod (E (Vec n a)) where+ fmod = liftE2 FMod++instance (IsNat n, IsScalar a, FMod a, RealFrac a) => Frac (E (Vec n a)) where+ frac = fracViaFmod+++{--------------------------------------------------------------------+ Boolean vector operations+--------------------------------------------------------------------}++-- -- | Component-wise 'not'+-- notV :: (IsNat n) => (Vec n Bool) :=>* (Vec n Bool)+-- -- Vec n Bool :=>* Vec n Bool+-- notV = fmapE NotV++-- | Are all of the 'Bool's true?+allV :: IsNat n => Vec n Bool :=>* B1+allV = fmapE AllV++-- | Is all of the 'Bool's true?+anyV :: IsNat n => Vec n Bool :=>* B1+anyV = fmapE AnyV++++{--------------------------------------------------------------------+ Misc operations+--------------------------------------------------------------------}++type SamplerE n = E (Sampler n)++-- | Texturing+texture :: IsNat n => Sampler n :=> Vec n R :=>* R4+texture = liftE2 (Texture nat)++-- | Literal value+lit :: Show a => a -> E a+lit = Op . Lit+++-- | 'Bool'+type BoolE = E B1++-- | 'Float' expression+type FloatE = E R1++type R1E = E R1+type R2E = E R2+type R3E = E R3+type R4E = E R4++-- | Expression vector+type VecE n a = E (Vec n a)+++-- vec1 :: (IsScalar a, Show a) => a :=>* (Vec1 a)+-- vec1 = fmapE VVec1++vec2 :: (IsScalar a, Show a) => One a :=> One a :=>* Two a+vec3 :: (IsScalar a, Show a) => One a :=> One a :=> One a :=>* Three a+vec4 :: (IsScalar a, Show a) => One a :=> One a :=> One a :=> One a :=>* Four a++vec2 a b = a <+> b+vec3 a b c = a <+> vec2 b c+vec4 a b c d = a <+> vec3 b c d++-- vec2 = liftE2 VVec2+-- vec3 = liftE3 VVec3+-- vec4 = liftE4 VVec4++un2 :: IsScalar a => Two a :=> (E (One a), E (One a))+un2 u = (getX u, getY u)++un3 :: IsScalar a => Three a :=> (E (One a), E (One a), E (One a))+un3 u = (getX u, getY u, getZ u)++un4 :: IsScalar a => Four a :=> (E (One a), E (One a), E (One a), E (One a))+un4 u = (getX u, getY u, getZ u, getW u)+++-- | Extract X component+getX :: (IsNat n, IsScalar a, Show a) =>+ Vec (S n) a :=>* One a+getX = get index0+-- | Extract Y component+getY :: (IsNat n, IsScalar a, Show a) =>+ Vec (S (S n)) a :=>* One a+getY = get index1+-- | Extract Z component+getZ :: (IsNat n, IsScalar a, Show a) =>+ Vec (S (S (S n))) a :=>* One a+getZ = get index2+-- | Extract W component+getW :: (IsNat n, IsScalar a, Show a) =>+ Vec (S (S (S (S n)))) a :=>* One a+getW = get index3++-- | Extract vector component+get :: (IsNat n, IsScalar a, Show a) =>+ Index n -> (Vec n a) :=>* One a+get i = fmapE (Swizzle (vec1 i))+++infixl 1 <+>+-- | Concatenation of vectors+(<+>) :: (IsNat m, IsNat n, IsNat (m :+: n), IsScalar a, Show a) =>+ Vec m a :=> Vec n a :=>* Vec (m :+: n) a+(<+>) = liftE2 (Cat nat nat vectorT)++++-- | Expression-lifted '()'+unitE :: E ()+unitE = pureE ()+++-- | Expression-lifted '(,)'+pairE :: (HasType a, HasType b{-, HasExpr a, HasExpr b-}) =>+ -- (Show a, Show b) =>+ E a -> E b -> E (a,b)+pairE = liftE2 Pair++-- | Expression-lifted 'fst'+fstE :: (HasType a, HasType b {-, Show b -} {-, HasExpr a, HasExpr b-}) =>+ Show a => E (a,b) -> E a+fstE = fmapE Fst++-- | Expression-lifted 'snd'+sndE :: (HasType a, HasType b {-, Show a-} {-, HasExpr a, HasExpr b-}) =>+ Show b => E (a,b) -> E b+sndE = fmapE Snd++-- | Unpack a pair+unPairE :: (HasType a, HasType b{-, HasExpr a, HasExpr b-}) =>+ -- (Show a, Show b) =>+ E (a,b) -> (E a, E b)+unPairE = fstE &&& sndE++instance UnitF E where unit = unitE+instance PairF E where (#) = pairE++-- | Uniform version of a function on vectors+uniform :: (IsNat n, IsScalar a, Show a) =>+ (E (Vec n a) -> b) -> (E (One a) -> b)+uniform = (. uniformV)++-- | Uniform vector+uniformV :: (IsNat n, IsScalar a, Show a) =>+ One a :=>* Vec n a+uniformV = fmapE (UniformV vectorT)+++{--------------------------------------------------------------------+ AdditiveGroup and VectorSpace+--------------------------------------------------------------------}++instance (IsNat n, IsScalar a, Num a) =>+ AdditiveGroup (E (Vec n a)) where+ zeroV = pureE 0+ (^+^) = liftE2 Add+ negateV = fmapE Negate++-- Hm. Odd tension between Num & AdditiveGroup. I'm avoiding adding+-- operators for AdditiveGroup and VectorSpace, so I won't have to add+-- rules for them. Maybe just add the rules.++instance (IsNat n, IsScalar a, Num a) =>+ VectorSpace (E (Vec n a)) where+ type Scalar (E (Vec n a)) = E (One a)+ s *^ u = uniformV s * u+ -- (*^) = liftE2 Scale++instance IsNat n => InnerSpace (E (Vec n R)) where+ -- (<.>) = liftE2 (Dot nat)+ (<.>) = case (nat :: Nat n) of+ Succ Zero -> liftE2 Mul+ _ -> liftE2 Dot++-- Alternatively, I could eliminate the Scale operator and do a+-- scalar-to-vector expansion here, and maybe optimize away during code+-- generation. Revisit.+++++{--------------------------------------------------------------------+ Conversion to expressions+--------------------------------------------------------------------}++-- | Turn a pattern into an expression.+patE :: Pat a -> E a+patE (BaseG v) = Var v+patE UnitG = unitE+patE (p :* q) = patE p # patE q++++-- | Value convertible to an expression+class ToE w where+ type ExpT w+ toEN :: w -> NameM (E (ExpT w))++-- | Convert to an expression, using fresh name supply+toE :: ToE w => w -> E (ExpT w)+toE = runNameM . toEN++-- | Value convertible from an expression+class ToE w => FromE w where+ fromE :: E (ExpT w) -> w++instance ToE (E a) where+ type ExpT (E a) = a+ toEN = return+instance FromE (E a) where+ fromE = id++instance ToE () where+ type ExpT () = ()+ toEN () = return unit++instance FromE () where fromE = const ()++infixr 1 ##++(##) :: (PairF f, HasType a, HasType b {-, Show a, Show b -}) =>+ NameM (f a) -> NameM (f b) -> NameM (f (a,b))+(##) = liftM2 (#)++instance ( ToE u, Show (ExpT u), HasType (ExpT u)+ , ToE v, Show (ExpT v), HasType (ExpT v)+ ) => ToE (u,v) where+ type ExpT (u,v) = (ExpT u, ExpT v)+ toEN (u,v) = liftM2 (#) (toEN u) (toEN v)+ -- toEN u ## toEN v++instance ( FromE u {-, Show (ExpT u)-}, HasType (ExpT u)+ , FromE v {-, Show (ExpT v)-}, HasType (ExpT v)+ ) => FromE (u,v) where+ fromE e = (fromE eu, fromE ev) where (eu,ev) = unPairE e++instance ( ToE u {-, Show (ExpT u)-}, HasType (ExpT u)+ , ToE v {-, Show (ExpT v)-}, HasType (ExpT v)+ , ToE w {-, Show (ExpT w)-}, HasType (ExpT w)+ ) => ToE (u,v,w) where+ type ExpT (u,v,w) = ExpT u :# ExpT v :# ExpT w+ toEN (u,v,w) = toEN u ## toEN v ## toEN w++instance ( FromE u {-, Show (ExpT u)-}, HasType (ExpT u)+ , FromE v {-, Show (ExpT v)-}, HasType (ExpT v)+ , FromE w {-, Show (ExpT w)-}, HasType (ExpT w)+ ) => FromE (u,v,w) where+ fromE e = (fromE eu, fromE ev, fromE ew)+ where (eu,(ev,ew)) = (second unPairE . unPairE) e++instance (FromE u, ToE v, HasType (ExpT u)) => ToE (u -> v) where+ type ExpT (u -> v) = ExpT u -> ExpT v+ toEN f = do u <- genVar -- p <- genPat+ b <- toEN (f (fromE (Var u))) -- patE p, or toE p+ return $ Lam u b++-- Hm. Here I wish Lam allowed a Pat. I'd then use genPat. Revisit Lam.++{-+-- | Generate a pattern of the given type with new variable names+genPat :: HasType a => NameM (Pat a)+genPat = get' typeT+ where+ get' :: forall b. HasType b => Type b -> NameM (Pat b)+ get' UnitT = return unit+ get' (a :*: b) = liftM2 (#) (get' a) (get' b)+ get' t = fmap (BaseG . flip V t) genName++-- TODO: Give genPat a [Name] argument. Use runNameMWith.++-}++-- Patterns+instance ToE (Pat a) where+ type ExpT (Pat a) = a+ toEN = return . patE+++-- | Construct an 'E' transformer from an 'ExpT' transformer+toFromE :: (FromE v, FromE w) => (v -> w) -> (E (ExpT v) -> E (ExpT w))+toFromE = fromE ~> toE++-- TODO: Check uses of toFromE and consider whether the fresh name supply+-- could be problematic.+++-- | Complex-valued expressions+type ComplexE a = Complex (E (One a))++instance (Show a, IsScalar a) => ToE (ComplexE a) where+ type ExpT (ComplexE a) = Two a+ toEN (x :+ y) = return $ x <+> y+instance (Show a, IsScalar a) => FromE (ComplexE a) where+ fromE c = getX c :+ getY c+
+ src/Shady/Language/GLSL.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE ExistentialQuantification, GADTs #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.Language.GLSL+-- Copyright : (c) Conal Elliott 2009+-- License : GPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Abstract syntax for GLSL. Evolving.+----------------------------------------------------------------------++-- Experimenting with typed syntax.++module Shady.Language.GLSL+ (+ -- * Syntax types+ Program(..), Shader(..), Declaration(..), Definition(..)+ , VectorT(..), ScalarT(..), Param(..), Id, Bind(..)+ , Statement(..), Qualifier(..)+ -- * Handy for building bindings+ , BindO, (=::), closeB+ -- * Utilities+ , (=:)+ , glPosition, glFragColor, vTrans, nTrans, mainDef+ )+ where++import Data.Monoid (Monoid(..))+-- import Data.Maybe (maybe)+import Data.Char (toLower)++import Data.VectorSpace (normalized)++import Text.PrettyPrint.Leijen+import Text.PrettyPrint.Leijen.PrettyPrec (showsPretty)+import Text.PrettyPrint.Leijen.DocExpr (expr)++import Control.Compose (result)++import Shady.Language.Operator (Op(Pair,Lit))+import Shady.Language.Exp hiding ((<+>),get)+import Shady.Language.Glom+import Shady.Misc (padTo)++-- Common sub-expression elimination. Work in progress. The Cse module is+-- fast but misses some sharing. Share is slow and thorough.+-- +-- TODO: combine the two approaches, using the Cse implementation as a+-- first pass and the Share implementation as a second.++import Shady.Language.Cse (cse)+-- import Shady.Language.Share (cse)++{--------------------------------------------------------------------+ Syntax types+--------------------------------------------------------------------}++-- data Exists f = forall a. Exists (f a)++-- | Variable binding+data Bind = forall a. B (Pat a) (E a)++-- | Statement+data Statement+ = Assign Bind+ | LetS Bind Statement+ | SkipS+ | ThenS Statement Statement++-- | Storage qualifier+data Qualifier = Uniform | Attribute | Varying deriving (Show, Eq)++-- | Variable declaration/initialization.+data Declaration = forall a. D [Qualifier] (Pat a)++-- | formal parameter+data Param = forall n a. M (VectorT n a) Id++-- | Top-level definition+data Definition = forall n a. F (Maybe (VectorT n a)) Id [Param] Statement++-- | Shader+data Shader = Sh [Declaration] [Definition]++-- | Program: Vertex shader and Fragment shader+data Program = P { pVertex :: Shader, pFragment :: Shader }+++instance Monoid Statement where { mempty = SkipS ; mappend = ThenS }+++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}++-- | The standard gl_Position variable, which must be set in a vertex shader+glPosition :: Pat R4+glPosition = pat "gl_Position"++-- | The standard gl_FragColor variable, which must be set in a fragment shader+glFragColor :: Pat R4+glFragColor = pat "gl_FragColor"++-- Transform+trans :: IsNat n => String -> VecE n R -> VecE n R+trans vname p = Var (var vname) * p++-- Transform and normalize+transNz :: IsNat n => String -> VecE n R -> VecE n R+transNz = (result.result) normalized trans++-- transNz vname p = normalized (trans vname p)++-- | Transform a vertex using the standard model/view matrix+vTrans :: E R4 -> E R4+vTrans = trans "gl_ModelViewProjectionMatrix"++-- | Transform a normal using the standard normal matrix+nTrans :: E R3 -> E R3+nTrans = transNz "gl_NormalMatrix"++-- HACK: the type of the view matrix above is inferred to be vec4 instead of+-- mat4x4. This lie saves me from having to introduce matrices to+-- the representation. If I use them elswhere, get honest.++-- | @main@ in a shader program.+mainDef :: Statement -> Definition+mainDef = F Nothing "main" []+++{--------------------------------------------------------------------+ Generate code for an assigment. May introduce new names and generate+ local bindings.+--------------------------------------------------------------------}++-- Because GLSL doesn't have expression-level "let", float all lets to the+-- top level before generating code. There may be a more efficient way to+-- use locals.++infix 0 =:+-- | Assignment statement+(=:) :: HasType a => Pat a -> E a -> Statement+p =: e = p <-- cse e++(<--) :: Pat a -> E a -> Statement++-- p =: let v::t=a in b[v];+-- -->+-- { var t v=a ; p =: b[v] }+p <-- (Lam v b :^ a) = letS v a (p <-- b)++p <-- e = Assign (B p e)+++letS :: V a -> E a -> Statement -> Statement+letS v e = LetS (B (BaseG v) e)+++{--------------------------------------------------------------------+ Pretty-printing / code generation+--------------------------------------------------------------------}++-- TODO: Consider changing Assign to use Pat and E instead of Bind, since+-- they have different concrete syntax. Hm. What's the concrete syntax+-- for a variable, "vec v" or "v"? Maybe accept context-dependent+-- concrete syntax.++-- TODO: CSE-friendly splitting for p :* q, e.g., a Let.++instance Pretty Bind where+ pretty = prettyB True++-- Pretty-print a binding, showing types if @withTypes@ is true+prettyB :: Bool -> Bind -> Doc+prettyB withTypes = pret+ where+ pret :: Bind -> Doc+ pret (B UnitG _) = empty+ pret (B (p :* q) e) = pret (B p a) <$> pret (B q b)+ where (a,b) = unPair' e+ pret (B (BaseG (V name ty)) e) =+ mbty ty <> text name <+> equals <+> pretty e <> semi+ mbty :: Type t -> Doc+ mbty ty | withTypes = prettyTy ty <> space+ | otherwise = empty++-- Variant that pads types for variable alignment+prettyTy :: Type t -> Doc+prettyTy = text . padTo (length "float") . show+++unPair' :: (Show a, Show b) => E (a,b) -> (E a, E b)+unPair' (Op (Lit (a,b))) = (Op (Lit a), Op (Lit b))+unPair' (Op Pair :^ a :^ b) = (a,b)+unPair' p = error $ "unPair': " ++ show (expr p)++-- TODO: Sort out & eliminate this error situation.+++instance Pretty Statement where+ pretty (Assign bind) = prettyB False bind+ pretty (LetS bind stat) = pretty bind <$> pretty stat+ pretty SkipS = empty+ pretty (s `ThenS` t) = pretty s <$> pretty t++instance Pretty Qualifier where pretty = lshowPad qMax++qMax :: Int+qMax = length "attribute"++instance Pretty Declaration where+ pretty (D quals patt) = prettyD patt+ where+ prettyD :: Pat t -> Doc+ prettyD UnitG = empty+ prettyD (p :* q) = prettyD p <$> prettyD q+ prettyD (BaseG (V name ty)) = vcat' quals <+> pretty ty <+> text name <> semi++instance Pretty Param where+ pretty (M ty name) = pretty ty <+> pretty name++instance Pretty Definition where+ pretty (F mbty name params body) =+ maybe (text "void") pretty mbty <+> text name <+>+ tupled' params <+> scoped (pretty body)++instance Pretty Shader where+ pretty (Sh decls funs) = vcat' decls <$> vcat' funs++instance Pretty Program where+ pretty (P v f) = line <> announce "vertex " v <$> announce "fragment" f+ where+ announce l sh = text (l ++ ": ") <+> align (pretty sh)++-- The initial 'line' is just so that a 'show'n (not 'pretty'd) tuple with+-- 'Program' starts at column 0.+++{--------------------------------------------------------------------+ +--------------------------------------------------------------------}++-- | Binding with open (exposed) type. Build with '(=::)' and '(#)'.+data BindO a = BindO (Pat a) (E a)++-- | 'V' specialization of '(=:)'.+(=::) :: HasType a => V a -> E a -> BindO a+v =:: e = BindO (BaseG v) e++instance PairF BindO where+ BindO p u # BindO q v = BindO (p # q) (u # v)++-- | Close an open binding+closeB :: HasType a => BindO a -> Statement+closeB (BindO p e) = p =: e++-- TODO: Swap names '(=:)' and '(=::)' if '(=:)' becomes more popular.++{--------------------------------------------------------------------+ Show instances+--------------------------------------------------------------------}++instance Show Bind where showsPrec = showsPretty+instance Show Statement where showsPrec = showsPretty+instance Show Declaration where showsPrec = showsPretty+instance Show Param where showsPrec = showsPretty+instance Show Definition where showsPrec = showsPretty+instance Show Shader where showsPrec = showsPretty+instance Show Program where showsPrec = showsPretty++{--------------------------------------------------------------------+ Utility belt+--------------------------------------------------------------------}++-- Show, lower-casing the first char and padding+lshowPad :: Show a => Int -> a -> Doc+lshowPad n = text . onHead toLower . padTo n . show++-- handy variants+vcat', tupled' :: Pretty a => [a] -> Doc+vcat' = vcat . map pretty+tupled' = tupled . map pretty++-- Doc in a scope+scoped :: Doc -> Doc+scoped d = braces (nest 4 (line <> d) <> line)++-- The following alternative doesn't quite work, since the nesting happens+-- after the first line break and so doesn't apply to the first line.+-- +-- scoped = braces . newlines . nest 4+-- where+-- -- Like braces, parens, ...+-- newlines :: Doc -> Doc+-- newlines = enclose line line++onHead :: (a -> a) -> [a] -> [a]+onHead f (a:as) = f a : as+onHead _ _ = error "onHead: empty list"
+ src/Shady/Language/Glom.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE GADTs, FlexibleContexts, Rank2Types, KindSignatures+ , MultiParamTypeClasses, FunctionalDependencies+ , FlexibleInstances, UndecidableInstances+ , TypeFamilies+ , EmptyDataDecls -- temporary+ #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.Language.Glom+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Typed conglomerate of values+----------------------------------------------------------------------++module Shady.Language.Glom+ ( FunctorU(..), MonadU(..)+ , Glom(..), foldG, mapAG+ -- , Glommable(..), Unglommable(..)+ ) where++import Control.Applicative (Applicative(..),liftA2)++import Text.PrettyPrint.Leijen+import Text.PrettyPrint.Leijen.PrettyPrec+import Text.PrettyPrint.Leijen.DocExpr++import Shady.Language.Type (HasType,PairF(..),UnitF(..))++infixr 7 :*++-- | Map a polymorphic function over a conglomerate (preserving+-- structure). The required laws are the same as with 'Functor'.+class FunctorU q where+ fmapU :: (forall a. f a -> g a)+ -> (forall a. q f a -> q g a)++-- TODO: fill in ApplicativeU++class FunctorU m => MonadU m where+ returnU :: f a -> m f a+ extendU :: (forall a. f a -> m g a)+ -> (forall a. m f a -> m g a)++-- TODO: does FunctorU already have a name?++-- | A typed conglomerate of values+data Glom f a where+ BaseG :: f a -> Glom f a+ UnitG :: Glom f ()+ (:*) :: (HasType a, HasType b, Show a, Show b) =>+ Glom f a -> Glom f b -> Glom f (a,b)++instance UnitF (Glom f) where unit = UnitG+instance PairF (Glom f) where (#) = (:*)++instance FunctorU Glom where+ fmapU h (BaseG x) = BaseG (h x)+ fmapU _ UnitG = UnitG+ fmapU h (p :* q) = fmapU h p :* fmapU h q++-- | Applicative/monadic map over a 'Glom'.+mapAG :: Applicative m =>+ (forall a. f a -> m ( g a)) ->+ (forall a. Glom f a -> m (Glom g a))+mapAG h (BaseG x) = fmap BaseG (h x)+mapAG _ UnitG = pure UnitG+mapAG h (p :* q) = liftA2 (:*) (mapAG h p) (mapAG h q)++-- Like the tree/substitution monad+instance MonadU Glom where+ returnU = BaseG+ extendU h (BaseG x) = h x+ extendU _ UnitG = UnitG+ extendU h (p :* q) = extendU h p :* extendU h q++-- | Fold over a 'Glom', given handlers for '(:*)', 'UnitG', and 'BaseG',+-- respectively.+foldG :: (c -> c -> c) -> c -> (forall b. f b -> c)+ -> Glom f a -> c+foldG k e f (a :* b) = foldG k e f a `k` foldG k e f b+foldG _ e _ UnitG = e+foldG _ _ f (BaseG x) = f x+++-- Convert a type to an 'Expr' for unparsing+instance HasExprU f => HasExprU (Glom f) where+ exprU (BaseG x) = exprU x+ exprU UnitG = var "()"+ exprU (t :* t') = op InfixR 1 ":*" (exprU t) (exprU t')++instance (HasExpr a, HasExprU f) => HasExpr (Glom f a) where expr = exprU++-- Idea: convert a glom into a Doc glom.++instance (HasExpr a, HasExprU f) => PrettyPrec (Glom f a) where + prettyPrec p = prettyPrec p . expr+instance (HasExpr a, HasExprU f) => Pretty (Glom f a) where + pretty = prettyPrec 0+instance (HasExpr a, HasExprU f) => Show (Glom f a) where + show = show . pretty+++-- Examples:++-- newtype Sink a = Sink { sink :: a -> IO () }++-- type Type = Glom VectorT+-- type Pat = Glom V+-- type Sinks = Glom Sink+-- type UniformsE = Glom E++{-++{--------------------------------------------------------------------+ Composing & decomposing Gloms+--------------------------------------------------------------------}++class Glommable u f a | u f -> a where+ glom :: u -> Glom f a++instance Glommable () f () where glom () = UnitG++instance (Glommable ua f a, Glommable ub f b, HasExpr a, HasExpr b) =>+ Glommable (ua,ub) f (a,b) where+ glom (ua,ub) = glom ua :* glom ub++-- Template to specialize per f:+-- +-- instance Glommable (f a) f a where glom = BaseG++class Unglommable u f a | a f -> u where+ unglom :: Glom f a -> u++instance Unglommable () f () where unglom _ = ()++instance (Unglommable ua f a, Unglommable ub f b) =>+ Unglommable (ua,ub) f (a,b) where+ unglom (ga :* gb) = (unglom ga, unglom gb)+ unglom _ = error "unglom: oops" -- :(++-- Template to specialize per (non-unit, non-pair) t:+-- +-- instance Unglommable (f t) f t where unglom = unglomId++-- | Unglom a non-unit, non-pair+unglomId :: Glom f a -> f a+unglomId (BaseG ea) = ea+unglomId _ = error "unglomId: not BaseG. wtf?"++instance Unglommable (f Int ) f Int where unglom = unglomId+instance Unglommable (f Bool ) f Bool where unglom = unglomId+instance Unglommable (f Float) f Float where unglom = unglomId++instance Unglommable (f (Vec1 a)) f (Vec1 a) where unglom = unglomId+instance Unglommable (f (Vec2 a)) f (Vec2 a) where unglom = unglomId+instance Unglommable (f (Vec3 a)) f (Vec3 a) where unglom = unglomId+instance Unglommable (f (Vec4 a)) f (Vec4 a) where unglom = unglomId++-}
+ src/Shady/Language/Graph.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE GADTs, KindSignatures, ExistentialQuantification, Rank2Types #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.Language.Graph+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Based on a typed variant of Andy Gill's data-reify. After several+-- tries, I wasn't able to reuse data-reify or my typed variant of it.+-- The problem was that I need my 'HasType' class and 'Type' type, but I+-- couldn't parameterize data-reify by the /class/ 'HasType'.+----------------------------------------------------------------------++module Shady.Language.Graph+ ( + -- * Typed identifiers+ NodeId, Tid(..)+ -- * Graph nodes+ , N(..), mapDeRef+ -- * Bindings+ , Bind(..)+ -- * Graphs+ , Graph(..)+ ) where++import Control.Applicative (Applicative(..),liftA2)++import Shady.Language.Operator+import Shady.Language.Exp+++{--------------------------------------------------------------------+ Typed identifiers+--------------------------------------------------------------------}++-- | Node Identifiers+type NodeId = Int++-- | Typed variables+data Tid a = Tid NodeId (Type a)++instance Eq (Tid a) where Tid i _ == Tid j _ = i == j++instance Show (Tid a) where show (Tid i _) = 'x' : show i+++{--------------------------------------------------------------------+ Graph nodes+--------------------------------------------------------------------}++data N :: * -> * where+ VN :: V a -> N a+ ON :: Op a -> N a+ App :: (HasType a, HasType b) =>+ Tid (a -> b) -> Tid a -> N b+++instance Show (N a) where+ show (VN v) = unwords ["VN" ,show v]+ show (ON o) = unwords ["ON" ,show o]+ show (App a b) = unwords ["App",show a,show b]++++mapDeRef :: Applicative m+ => (forall a. HasType a => E a -> m NodeId)+ -> (forall a. HasType a => E a -> m (N a))+mapDeRef _ (Var v) = pure $ VN v+mapDeRef _ (Op o) = pure $ ON o+mapDeRef f (u :^ v) = liftA2 App (app f u) (app f v)+ -- liftA2 App (f u) (f v)+mapDeRef _ Lam{} = notSupp "Lam"++notSupp :: String -> a+notSupp meth = error $ "mapDeRef on E: "++meth++" not supported"++app :: (Functor m, HasType a) => (E a -> m NodeId) -> E a -> m (Tid a)+app f u = fmap (flip Tid (typeOf1 u)) (f u)+++{--------------------------------------------------------------------+ Bindings+--------------------------------------------------------------------}++-- | Binding pair +data Bind = forall a. HasType a => Bind NodeId (N a)++instance Show Bind where+ show (Bind v n) = show v ++" = "++ show n+++{--------------------------------------------------------------------+ Graphs+--------------------------------------------------------------------}++-- | Graph, described by bindings and a root variable+data Graph a = Graph [Bind] (Tid a)+++instance Show (Graph a) where+ show (Graph netlist start) = "let " ++ show netlist ++ " in " ++ show start
+ src/Shady/Language/Operator.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE KindSignatures, GADTs, PatternGuards, TypeOperators+ , FlexibleContexts+ #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.Language.Operator+-- Copyright : (c) Conal Elliott 2009+-- License : GPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Known constants+----------------------------------------------------------------------++module Shady.Language.Operator+ ( Op(..), OpInfo(..), info+ , opExpr, opVal, opEq+ ) where++import Prelude hiding (all,any)++import Control.Applicative (liftA2)+import Data.Foldable (all,any)++import Text.PrettyPrint.Leijen.DocExpr++import Control.Compose (result)++import Data.VectorSpace (VectorSpace(..),InnerSpace(..))++-- import Shady.Language.Equality+import Shady.Language.Type+-- import Shady.Vec+import Shady.Misc+++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}++data Op :: * -> * where+ -- Literal+ Lit :: Show a => a -> Op a+ -- Booleans+ -- Hack: say that And/Or work on bool vectors. Later, revert and+ -- implement the vector versions via the scalar versions.+ And :: IsNat n => Op (Binop (Vec n Bool))+ -- Op (Binop B1)+ Or :: IsNat n => Op (Binop (Vec n Bool))+ -- Op (Binop B1)+ Not :: IsNat n => Op (Unop (Vec n Bool))+ EqualV :: (IsNat n, IsScalar a, Eq a) =>+ Nat n -> Op (Vec n a -> Vec n a -> Vec n Bool)+ AllV :: IsNat n => Op (Vec n Bool -> B1)+ AnyV :: IsNat n => Op (Vec n Bool -> B1)+ -- Eq+ Equal :: Eq (Vec n a) => Op (Pred2 (Vec n a))+ -- Ord+ Lt :: (IsNat n, IsScalar a, Ord a) => Nat n -> Op (Vec n a -> Vec n a -> Vec n Bool)+ Le :: (IsNat n, IsScalar a, Ord a) => Nat n -> Op (Vec n a -> Vec n a -> Vec n Bool)+ Min :: (IsNat n, IsScalar a, Ord a) => Op (Binop (Vec n a))+ Max :: (IsNat n, IsScalar a, Ord a) => Op (Binop (Vec n a))+ -- Num+ Negate :: (IsNat n, IsScalar a, Num a) => Op (Unop (Vec n a))+ Add :: (IsNat n, IsScalar a, Num a) => Op (Binop (Vec n a))+ Sub :: (IsNat n, IsScalar a, Num a) => Op (Binop (Vec n a))+ Mul :: (IsNat n, IsScalar a, Num a) => Op (Binop (Vec n a))+ Abs :: (IsNat n, IsScalar a, Num a) => Op (Unop (Vec n a))+ Signum :: (IsNat n, IsScalar a, Num a) => Op (Unop (Vec n a))+ -- Integral+ Quot :: (IsNat n, IsScalar a, Integral a) => Op (Binop (Vec n a))+ Rem :: (IsNat n, IsScalar a, Integral a) => Op (Binop (Vec n a))+ Div :: (IsNat n, IsScalar a, Integral a) => Op (Binop (Vec n a))+ Mod :: (IsNat n, IsScalar a, Integral a) => Op (Binop (Vec n a))+ -- Fractional+ Recip :: (IsNat n, IsScalar a, Fractional a) => Op (Unop (Vec n a))+ Divide :: (IsNat n, IsScalar a, Fractional a) => Op (Binop (Vec n a))+ -- Floating+ Sqrt :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Exp :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Log :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Sin :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Cos :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Asin :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Atan :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Acos :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Sinh :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Cosh :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Asinh :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Atanh :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ Acosh :: (IsNat n, IsScalar a, Floating a) => Op (Unop (Vec n a))+ -- RealFrac+ Truncate :: IsNat n => Op (Unop (Vec n R))+ Round :: IsNat n => Op (Unop (Vec n R))+ Ceiling :: IsNat n => Op (Unop (Vec n R))+ Floor :: IsNat n => Op (Unop (Vec n R))+ FMod :: (IsNat n, IsScalar a, FMod a) => Op (Binop (Vec n a))+ -- Vector+ -- VVec1 :: IsScalar a => Op (One a -> One a)+ VVec2 :: IsScalar a => Op (One a -> One a -> Two a)+ VVec3 :: IsScalar a => Op (One a -> One a -> One a -> Three a)+ VVec4 :: IsScalar a => Op (One a -> One a -> One a -> One a -> Four a)+ Dot :: IsNat n => Op (Vec n R -> Vec n R -> R1)+ Swizzle :: (IsNat n, IsNat m, IsScalar a) =>+ Vec n (Index m) -> Op (Vec m a -> Vec n a)+ -- Nestable pairs+ Unit :: Op ()+ Pair :: Op (a -> b -> (a,b))+ Fst :: Op ((a,b) -> a)+ Snd :: Op ((a,b) -> b)+ -- Misc+ If :: HasType a => Op (B1 -> Binop a)+ Cat :: (IsNat m, IsNat n, IsNat (m :+: n), IsScalar a) =>+ Nat m -> Nat n -> VectorT (m :+: n) a+ -> Op (Vec m a -> Vec n a -> Vec (m :+: n) a)+ UniformV :: IsNat n => VectorT n a -> Op (One a -> Vec n a)+ Scale :: (IsNat n, Num a, IsScalar a) => Op (One a -> Unop (Vec n a))+ -- Misc graphics-specific+ Texture :: IsNat n => Nat n -> Op (Sampler n -> Vec n R -> R4)++-- TODO: eliminate Scale? unsure.+instance Show (Op t) where show = oiName . info+++{--------------------------------------------------------------------+ Fixity/precedence info+--------------------------------------------------------------------}++type Fixity = Maybe (Associativity, Int)++infixA :: Associativity -> Int -> Fixity+infixA ass n = Just (ass, n)++nofix :: Fixity+nofix = Nothing++infixL, infixR, infixN :: Int -> Fixity++infixL = infixA InfixL+infixR = infixA InfixR+infixN = infixA Infix++one1 :: (a -> b) -> a -> One b+one1 = result vec1++one2 :: (a -> b -> c) -> a -> b -> One c+one2 = result one1++-- in1 :: (a -> b) -> One a -> One b+-- in1 = un1 ~> vec1 -- or fmap++-- in2 :: (a -> b -> c) -> One a -> One b -> One c+-- in2 = un1 ~> in1++-- in1, in2 subsumed by fmap & liftA2.+++{--------------------------------------------------------------------+ Operator info+--------------------------------------------------------------------}++data OpInfo a = OpInfo { oiName :: String, oiVal :: a, oiFix :: Fixity }++info :: Op a -> OpInfo a++info (Lit a) = OpInfo (show a) a nofix++info And = OpInfo "(&&)" (liftA2 (&&)) (infixR 3)+info Or = OpInfo "(||)" (liftA2 (||)) (infixR 2)+info Not = OpInfo "not" (fmap not) nofix+info Equal = OpInfo "(==)" (one2 (==)) (infixN 4)++info (EqualV n) = condN "(==)" "equal" (liftA2 (==)) (infixN 4) n++info AllV = OpInfo "all" all' nofix+info AnyV = OpInfo "any" any' nofix++info (Lt n) = condN "(<)" "lessThan" (liftA2 (<) ) (infixN 4) n+info (Le n) = condN "(<=)" "lessThanEqual" (liftA2 (<=)) (infixN 4) n+info Min = OpInfo "min" min nofix+info Max = OpInfo "max" max nofix++info Negate = OpInfo "negate" negate nofix+info Add = OpInfo "(+)" (+) (infixL 6)+info Sub = OpInfo "(-)" (-) (infixL 6)+info Mul = OpInfo "(*)" (*) (infixL 7)+info Abs = OpInfo "abs" abs nofix+info Signum = OpInfo "sign" signum nofix++info Quot = OpInfo "quot" quot nofix+info Rem = OpInfo "rem" rem nofix+info Div = OpInfo "div" div nofix+info Mod = OpInfo "mod" mod nofix++info Recip = OpInfo "recip" recip nofix+info Divide = OpInfo "(/)" (/) (infixL 7)+info FMod = OpInfo "mod" fmod nofix++info Sqrt = OpInfo "sqrt" sqrt nofix+info Exp = OpInfo "exp" exp nofix+info Log = OpInfo "log" log nofix+info Sin = OpInfo "sin" sin nofix+info Cos = OpInfo "cos" cos nofix+info Asin = OpInfo "asin" asin nofix+info Atan = OpInfo "atan" atan nofix+info Acos = OpInfo "acos" acos nofix+info Sinh = OpInfo "sinh" sinh nofix+info Cosh = OpInfo "cosh" cosh nofix+info Asinh = OpInfo "asinh" asinh nofix+info Atanh = OpInfo "atanh" atanh nofix+info Acosh = OpInfo "acosh" acosh nofix++info Truncate = OpInfo "truncate" (i2f . truncate) nofix+info Round = OpInfo "round" (i2f . round) nofix+info Ceiling = OpInfo "ceiling" (i2f . ceiling) nofix+info Floor = OpInfo "floor" (i2f . floor) nofix++info VVec2 = OpInfo "vec2" vvec2 nofix+info VVec3 = OpInfo "vec3" vvec3 nofix+info VVec4 = OpInfo "vec4" vvec4 nofix+info Dot = OpInfo "dot" (<.>) nofix+-- info (Dot n) = condN "(*)" "dot" (<.>) (infixL 7) n++info (Swizzle ixs) = OpInfo (swizzleName ixs) (swizzle ixs) nofix ++info Unit = OpInfo "()" () nofix+info Pair = OpInfo "(#)" (,) (infixR 1)+info Fst = OpInfo "fst" fst nofix+info Snd = OpInfo "snd" snd nofix++info If = OpInfo "cond" if' nofix+info (Cat _ _ t) = OpInfo (show t) (<+>) nofix+info (UniformV t) = OpInfo (show t) (pureV . un1) nofix+info Scale = OpInfo "(*)" (*^) (infixR 7)++info (Texture n) = OpInfo ("texture" ++ show n ++ "D") texture nofix++opVal :: Op a -> a+opVal = oiVal . info++-- Will compile-time texture sampling happen? If so, implement it.+texture :: IsNat n => Sampler n -> Vec n R -> R4+texture = error "texture: no constant fold"++i2f :: Vec n Int -> Vec n Float+i2f = fmap fromIntegral++-- opFix :: Op a -> Fixity+-- opFix = oiFix . info++-- Pick one info for n==1 and another for other n. For instance,+-- "(==)" vs "equal".+condN :: String -> String -> a -> Fixity -> Nat n -> OpInfo a+condN name1 _ val fixity (Succ Zero) = OpInfo name1 val fixity+condN _ namen val _ _ = OpInfo namen val nofix++vvec2 :: One a -> One a -> Two a+vvec2 a b = un1 a :< b++vvec3 :: One a -> One a -> One a -> Three a+vvec3 a b c = un1 a :< vvec2 b c++vvec4 :: One a -> One a -> One a -> One a -> Four a+vvec4 a b c d = un1 a :< vvec3 b c d++all', any' :: Vec n Bool -> B1+all' = vec1 . all id+any' = vec1 . any id++-- Part name+part :: Index m -> Char+part (Index _ m) = "xyzw" !! fromIntegral (natToZ m)++parts :: Vec n (Index m) -> String+parts ixs = map part (vElems ixs)++-- getName :: Index m -> String+-- getName ix = "GET" ++ [part ix]++swizzleName :: Vec n (Index m) -> String+swizzleName ixs = "GET" ++ parts ixs+++{--------------------------------------------------------------------+ Pretty printing+--------------------------------------------------------------------}++-- | Operator application+opExpr :: Op z -> [Expr] -> Expr+opExpr Not [e] = fun "!" e+opExpr Negate [e] = fun "-" e+opExpr If [c,t,e] = ifExpr c t e+opExpr (Swizzle ixs) [e] = dotX (map part (vElems ixs)) e+opExpr Recip [e] = lift (1.0 :: Float) / e+opExpr (UniformV (VectorT (Succ Zero) _)) [e] = e+opExpr oper [x,y] | Just (ass,p) <- fixity+ = op ass p (infixize name) x y+ where+ OpInfo name _ fixity = info oper+opExpr oper xs = ccall (oiName (info oper)) xs+++-- Make a name infix-ready. "(+)" --> "+", and "div" --> "`div`"+infixize :: String -> String+infixize ('(':cs) = init cs+infixize n = "`" ++ n ++ "`"++if' :: B1 -> Binop a+if' c t e = if un1 c then t else e++ifExpr :: Expr -> Expr -> Expr -> Expr+ifExpr c t e = op Infix 0 "?" c $+ op Infix 1 ":" t e++-- TODO: Better formatting for ?: I'd like to align ":" with "?", and I+-- don't know how (elegantly).+++{--------------------------------------------------------------------+ Operator equality+--------------------------------------------------------------------}++-- Operator equality, including differently typed operators.+opEq :: Op a -> Op b -> Bool++-- This implementation assumes that different operators look different.+oper `opEq` oper' = oiName (info oper) == oiName (info oper')++-- A polymorphism variant doesn't work:+-- +-- opEq = (==) `on` (oiName . info)++instance SynEq Op where (=-=) = opEq
+ src/Shady/Language/Reify.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE UndecidableInstances, TypeFamilies, BangPatterns, Rank2Types+ , ExistentialQuantification, PatternGuards, ScopedTypeVariables+ , MultiParamTypeClasses, GADTs+ #-}+{-# OPTIONS_GHC -Wall #-}++----------------------------------------------------------------------+-- |+-- Module : Shady.Language.Reify+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Discover representation sharing in expressions+-- Variation on Andy Gill's Data.Reify.+----------------------------------------------------------------------++++module Shady.Language.Reify (reifyGraph) where++import Control.Concurrent.MVar+-- import Control.Monad+import System.Mem.StableName+import Data.IntMap as M++import Shady.Language.Exp+import Shady.Language.Graph+++data StableBind = forall a. HasType a => StableBind NodeId (StableName (E a))+++-- | 'reifyGraph' takes a data structure that admits 'MuRef', and returns+-- a 'Graph' that contains the dereferenced nodes, with their children as+-- integers rather than recursive values.+reifyGraph :: HasType a => E a -> IO (Graph a)+reifyGraph e = do rt1 <- newMVar M.empty+ rt2 <- newMVar []+ root <- findNodes rt1 rt2 e+ binds <- readMVar rt2+ return (Graph binds (Tid root typeT))+++findNodes :: HasType a =>+ MVar (IntMap [StableBind])+ -> MVar [Bind]+ -> E a -> IO NodeId+findNodes rt1 rt2 ea =+ do nextI <- newMVar 0+ let newIndex = modifyMVar nextI (\ n -> return (n+1,n))+ loop :: HasType b => E b -> IO NodeId+ loop !eb = do+ st <- makeStableName eb+ tab <- takeMVar rt1+ case mylookup st tab of+ Just i -> do putMVar rt1 tab+ return $ i+ Nothing -> + do i <- newIndex+ putMVar rt1 $+ M.insertWith (++) (hashStableName st) [StableBind i st] tab+ res <- mapDeRef loop eb+ tab' <- takeMVar rt2+ putMVar rt2 $ Bind i res : tab'+ return i+ in loop ea++mylookup :: forall a. HasType a =>+ StableName (E a) -> IntMap [StableBind] -> Maybe NodeId+mylookup sta tab =+ M.lookup (hashStableName sta) tab >>= llookup+ where+ tya :: Type a+ tya = typeT+ llookup :: [StableBind] -> Maybe NodeId+ llookup [] = Nothing+ llookup (StableBind i stb : binds') + | Just Refl <- tya `tyEq` typeOf2 stb, sta == stb = Just i+ | otherwise = llookup binds'
@@ -0,0 +1,280 @@+ <!-- -*- markdown -*-++> {-# LANGUAGE GADTs, KindSignatures, Rank2Types, TypeOperators+> , PatternGuards, NamedFieldPuns, StandaloneDeriving+> , ScopedTypeVariables+> #-}+> {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}++|+Module : Shady.Language.Share+Copyright : (c) Conal Elliott 2010+License : BSD3+Maintainer : conal@conal.net+Stability : experimental++ -->++Experiments with sharing recovery on GADT-based expression representations.++> module Shady.Language.Share (cse) where++Imports+=======++> import Prelude hiding (foldr)+> +> import Data.Function (on)+> import Data.Ord (comparing)+> import Data.List (sortBy)+> import Control.Applicative (Applicative(..),liftA2,(<$>))+> import Control.Arrow (first,second,(&&&))+> import Data.Foldable (foldr)+>+> import qualified Control.Monad.State as S+>+> import Data.Map (Map)+> import qualified Data.Map as Map+> import Data.Set (Set)+> import qualified Data.Set as Set+>+> import Data.Proof.EQ++> import Shady.Language.Exp++< import Debug.Trace+++Common subexpression elimination+================================++To elimination common subexpressions, convert from expression to graph (dag) and back to expression.+The final expression will use `let` (as beta redexes) to abstract out expressions that appear more than once.++> cse :: HasType a => E a -> E a+> cse = undagify . dagify+++Graphs+======++A graph is a map from expressions to variable names, plus a root expression (typically a variable).++> type Graph a = (E a, Map TExp Id)++A `TExp` wraps an expression, encapsulating the type.+I'll also include the result of `show`, since I use it in comparisons, which I expect to cause it to be accessed repeatedly.++> data TExp = forall a. HasType a => TExp (E a) String++> tExp :: HasType a => E a -> TExp+> tExp e = TExp e (show e)++> instance Show TExp where show (TExp _ s) = s++The reason for mapping from an expression to index instead of vice versa is just that it's more efficient to build in this direction.+We'll invert the map later when we convert back from `Graph` to `E`.++> invertMap :: Ord v => Map k v -> Map v k+> invertMap = Map.fromList . map (\ (n,i) -> (i,n)) . Map.toList++To use `TExp` as a map key, it'll have to be ordered.+For simplicity, I'll just use the printed form of the `E`.++> instance Eq TExp where+> TExp _ s == TExp _ t = s == t+> +> instance Ord TExp where+> TExp _ s `compare` TExp _ t = s `compare` t+++Conversion from E to Graph (dag)+==================================++I'll structure conversion from `E` to Graph (dag) around a monad for computations that accumulate +an exp map and a list of unused names.+The names are guaranteed to be in ascending order so that we can trivially top-sort the graph later.++> type ExpMap = Map TExp Id++> type GraphM = S.State (ExpMap, [Id])++> dagify :: HasType a => E a -> Graph a+> dagify e = second fst $ S.runState (dagifyExp e) (Map.empty, ids)+> where+> allIds, ids :: [Id]+> allIds = "" : [c:name | name <- allIds, c <- ['a'..'z']]+> ids = filter (not . (`Set.member` eVars)) (map reverse (tail allIds))+> eVars :: Set Id+> eVars = vars e++The name list is not alphabetized and moreover could not be alpabetized.+Define a comparison function, which could be compare length/string pairs.++> compareIds :: String -> String -> Ordering+> compareIds = comparing (length &&& id)++Graph construction works by recursively constructing and inserting expression/name pairs:++> dagifyExp :: HasType a => E a -> GraphM (E a)+> dagifyExp e = dagN e >>= insertG+> +> dagN :: HasType a => E a -> GraphM (E a)+> dagN (Var v) = pure $ Var v+> dagN (Op o) = pure $ Op o+> dagN (f :^ a) = liftA2 (:^) (dagifyExp f) (dagifyExp a)+> -- dagN (Lam v b) = Lam v <$> dagifyExp b+> dagN (Lam _ _) = error "dagN: Can't yet perform CSE on Lam"++If the given expression is already in the graph, reuse the existing identifier.+Otherwise, insert insert it, giving it a new identifier.++> insertG :: HasType a => E a -> GraphM (E a)+> insertG e | not (abstractable e) = return e+> | otherwise = maybe (addExp e) return+> =<< findExp e <$> S.gets fst+> +> addExp :: HasType a => E a -> GraphM (E a)+> addExp e = do name <- genId+> S.modify (first (Map.insert (tExp e) name))+> return (Var (var name))++Needing `HasType` in `insertG` forced me to add it several other places, including in the `E` constructor types.++An expression is abstractable if it has base type and is non-trivial.++< abstractable :: HasType a => E a -> Bool+< abstractable e = nonTrivial e && isBaseType (typeOf1 e)++< nonTrivial :: Exp a -> Bool+< nonTrivial (_ :^ _) = True+< nonTrivial _ = False++> isBaseType :: Type a -> Bool+> isBaseType (VecT _) = True+> isBaseType _ = False++On second thought, omit the `nonTrivial` condition.+With GLSL, it's worthwhile even abstracting literals.++> abstractable :: HasType a => E a -> Bool+> abstractable e = isBaseType (typeOf1 e)+++Identifier generation is as usual, accessing and incrementing the counter state:++> genId :: GraphM Id+> genId = do (m,name:names) <- S.get+> S.put (m,names)+> return name++To search for an exp in the accumulated map,++> findExp :: HasType a => E a -> ExpMap -> Maybe (E a)+> findExp e = fmap (Var . var) . Map.lookup (tExp e)+++Free variables+==============++Count all variables occurrences in an expression:++> countOccs :: E a -> Map Id Int+> countOccs (Var (V n _)) = Map.singleton n 1+> countOccs (Op _) = Map.empty+> countOccs (f :^ a) = Map.unionWith (+) (countOccs f) (countOccs a)+> countOccs (Lam (V n _) b) = Map.delete n (countOccs b)++> tCountOccs :: TExp -> Map Id Int+> tCountOccs (TExp e _) = countOccs e++Also handy will be extracting all variables free & bound:++> vars :: E a -> Set Id+> vars (Var (V n _)) = Set.singleton n+> vars (Op _) = Set.empty+> vars (f :^ a) = vars f `Set.union` vars a+> vars (Lam (V n _) b) = Set.insert n (vars b)+++Conversion from Graph (dag) to E+==================================++Given a `Graph`, let's now build an `E`, with sharing.++Recall the `Graph` type and map inversion, defined above:++< type Graph a = (E a, ExpMap)++To rebuild an `E`, walk through the inverted map in order, generating a `let` for each binding.++< undagify :: forall a. HasType a => Graph a -> E a+< undagify (root,expToId) =+< foldr bind root (sortedBinds (invertMap expToId))+< where+< bind :: (Id,TExp) -> E a -> E a+< bind (name, TExp rhs) = lett name rhs++> sortedBinds :: Map Id TExp -> [(Id,TExp)]+> sortedBinds = sortBy (compareIds `on` fst) . Map.toList+++Inlining+--------++To minimize the `let` bindings, let's re-inline all bindings that are used only once.+To know how which bindings are used only once, count them.++> inlinables :: HasType a => Graph a -> Set Id++ > inlinables = const Set.empty -- temp++> inlinables g = asSet $ (== 1) <$> countUses g++> countUses :: HasType a => Graph a -> Map Id Int+> countUses (e,m) = Map.unionsWith (+) (map tCountOccs (tExp e : Map.keys m))++Turn a boolean map (characteristic function) into a set:++> asSet :: Ord k => Map k Bool -> Set k+> asSet = Set.fromList . Map.keys . Map.filter id++Now revisit `undagify`, performing some inlining along the way.++> undagify :: forall a. HasType a => Graph a -> E a+> undagify g@(root,expToId) = foldr bind (inline root) (sortedBinds texps)+> where+> texps :: Map Id TExp+> texps = invertMap expToId+> ins :: Set Id+> ins = inlinables g+> bind :: (Id,TExp) -> E a -> E a+> bind (name, TExp rhs _) = lett' name (inline rhs)+> -- Inline texps in an expression+> inline :: E b -> E b+> inline (Var v@(V name _)) | Set.member name ins, Just e' <- tLookup v texps = inline e'+> inline (f :^ a) = inline f :^ inline a+> inline (Lam v b) = Lam v (inline b) -- assumes no shadowing+> inline e = e+> -- Make a let binding unless an inlined variable.+> lett' :: (HasType b, HasType c) =>+> Id -> E b -> E c -> E c+> lett' n rhs | Set.member n ins = id+> | otherwise = letE (var n) rhs++For the inlining step, we'll have to look up a variable in the map, and check that it has the required type.++> tLookup :: V a -> Map Id TExp -> Maybe (E a)+> tLookup (V name tya) m = fromTExp tya <$> Map.lookup name m++> fromTExp :: Type a -> TExp -> E a+> fromTExp tya (TExp e _) | Just Refl <- typeOf1 e `tyEq` tya = e+> | otherwise = error "fromTExp type fail"++I'm not satisfied having to deal the type check explicitly here.+Maybe a different abstraction would help; perhaps a type-safe homogeneous map instead of `Map Id TExp`.+++ <!-- References -->++ [semantic editor combinator]: http://conal.net/blog/posts/semantic-editor-combinators/ "blog post"
+ src/Shady/Language/Type.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE GADTs, KindSignatures, FlexibleInstances, FlexibleInstances+ , MultiParamTypeClasses, FunctionalDependencies+ , UndecidableInstances, TypeOperators, ScopedTypeVariables+ , FlexibleContexts, CPP+ #-}+{-# LANGUAGE StandaloneDeriving #-}++{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}++----------------------------------------------------------------------+-- |+-- Module : Shady.Language.Type+-- Copyright : (c) Conal Elliott 2009+-- License : GPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Types+----------------------------------------------------------------------++module Shady.Language.Type+ ( + -- * Type values+ ScalarT(..), VectorT(..), Type(..)+ , TextureId, Sampler(..), sampler1, sampler2, sampler3, Sampler1, Sampler2, Sampler3+ -- * Generating type values+ , IsScalar(..), vectorT, HasType(..)+ , typeOf, typeOf1, typeOf2, compatible, compatible1+ , IsVec(..),checkVec, checkVec'+ -- * Type equality+ , (:=:)(..), ptyEq, vtyEq, tyEq+ , (=:=), (===)+ -- * Vector operations+ -- , Vector(..)+ -- * Convenient type synonyms+ , R, R1, R2, R3, R4, B1, Pred1, Pred2+ -- * Notions of equality+ , SynEq(..),SynEq2(..) + -- * Pairing and unit+ , PairF(..), (:#), UnitF(..)+ -- * Re-export+ , module Shady.Vec+ ) where++import Control.Applicative (pure,liftA2,Const(..))+import Data.Maybe (isJust)+import Data.List (intercalate)+import Control.Monad.Instances ()+import Foreign.Storable++import Data.Typeable (Typeable)++import Text.PrettyPrint.Leijen+import Text.PrettyPrint.Leijen.PrettyPrec+import Text.PrettyPrint.Leijen.DocExpr++import Shady.Misc (FMod(..),R)+import Shady.Vec+import Data.Proof.EQ+-- import Shady.Language.Equality+-- import Shady.MechanicsGL (GlTexture)+++{--------------------------------------------------------------------+ Type values+--------------------------------------------------------------------}++-- Primitive types+data ScalarT :: * -> * where+ Bool :: ScalarT Bool+ Int :: ScalarT Int+ Float :: ScalarT Float++instance Show (ScalarT a) where+ show Bool = "bool"+ show Int = "int"+ show Float = "float"++instance HasExprU ScalarT where+ exprU Bool = var "bool"+ exprU Int = var "int"+ exprU Float = var "float"++instance Pretty (ScalarT a) where pretty = text . show++vshow :: Show a => a -> Expr+vshow = var . show++instance HasExpr (ScalarT a) where expr = vshow++data VectorT n a = VectorT (Nat n) (ScalarT a)++instance Show (VectorT n a) where+ show (VectorT n t) = showVectorN (natToZ n) t++-- instance HasExpr a => HasExpr (VectorT a) where expr = expr1+-- instance HasExpr1 VectorT where expr1 = var . show++instance HasExprU (VectorT n) where exprU = expr+instance HasExpr (VectorT n a) where expr = var . show++showVectorN :: Integer -> ScalarT a -> String+showVectorN 1 p = show p+showVectorN n p = pref p ++ "vec" ++ show n+ where+ pref :: ScalarT b -> String+ pref Bool = "b"+ pref Int = "i"+ pref Float = ""++instance Pretty (VectorT n a) where pretty = text . show++-- | Encoding of texture ids in values. I'm using 'Int' instead of+-- @GLuint@ here to avoid depending on OpenGL in this module & package.+type TextureId = Int++-- | An @n@-dimensional GLSL sampler.+data Sampler n =+ Sampler { samplerDim :: Nat n, samplerTexture :: TextureId }++type Sampler1 = Sampler OneT+type Sampler2 = Sampler TwoT+type Sampler3 = Sampler ThreeT++instance Show (Sampler n) where+ show (Sampler n tex) = "<Sampler "++show n++" "++show tex++">"++instance Pretty (Sampler n) where+ pretty = text . show++sampler1 :: TextureId -> Sampler1+sampler1 = Sampler one -- or Sampler nat++sampler2 :: TextureId -> Sampler2+sampler2 = Sampler two -- or Sampler nat++sampler3 :: TextureId -> Sampler3+sampler3 = Sampler three -- or Sampler nat++-- | Extended types. Vector types, samplers, unit, pairing, and functions.+data Type :: * -> * where+ VecT :: (IsNat n, IsScalar a {-, Storable (Vec n a) -}) =>+ VectorT n a -> Type (Vec n a)+ SamplerT :: IsNat n => Nat n -> Type (Sampler n)+ UnitT :: Type ()+ (:*:) :: (HasType a, HasType b {-, Show a, Show b -}) =>+ Type a -> Type b -> Type (a , b)+ (:->:) :: (HasType a, HasType b {-, Show a, Show b -}) =>+ Type a -> Type b -> Type (a -> b)++instance HasExpr (Type t) where+ expr (VecT t) = expr t+ expr (SamplerT n) = var $ "sampler" ++ show n ++ "D"+ expr UnitT = var "()"+ expr (a :*: b) = op InfixR 1 ":*" (expr a) (expr b)+ expr (a :->: b) = op InfixR 0 "->" (expr a) (expr b)++instance HasExprU Type where exprU = expr++instance PrettyPrec (Type t) where prettyPrec = prettyExpr+instance Pretty (Type t) where pretty = prettyPrec 0+instance Show (Type t) where show = show . expr+++{--------------------------------------------------------------------+ Generating type values+--------------------------------------------------------------------}++-- EXPERIMENTAL: Typeable constraints++-- | Has scalar type+class (Storable a, Typeable a, Show a) => IsScalar a where scalarT :: ScalarT a++-- The Storable and Show prereqs simplify explicit constraints at uses.++instance IsScalar Bool where scalarT = Bool+instance IsScalar Int where scalarT = Int+instance IsScalar Float where scalarT = Float+++vectorT :: (IsNat n, IsScalar a) => VectorT n a+vectorT = VectorT nat scalarT++-- | Known types+class Show t => HasType t where typeT :: Type t++-- Sorry about that Show constraint. It's ultimately motivated by+-- the constant folding optimization and from there creeps into *lots* of contexts.++-- The Show t is experimental. If it works out, remove Show from a lot of contexts.++instance (IsNat n, IsScalar a {-, Storable (Vec n a)-}) =>+ HasType (Vec n a) where+ typeT = VecT vectorT++instance HasType () where typeT = UnitT+instance (HasType a, HasType b {-, Show a, Show b -}) =>+ HasType (a, b) where typeT = typeT :*: typeT+instance (HasType a, HasType b {-, Show a, Show b -}) =>+ HasType (a->b) where typeT = typeT :->: typeT++instance IsNat n => HasType (Sampler n) where+ typeT = SamplerT nat++-- | Reify a type+typeOf :: HasType a => a -> Type a+typeOf = const typeT++-- | Reify a type argument+typeOf1 :: HasType a => f a -> Type a+typeOf1 = const typeT++-- | Reify a type argument's argument+typeOf2 :: HasType a => g (f a) -> Type a+typeOf2 = const typeT+++-- | Demonstration that a type argument is a vector type.+data IsVec :: * -> * where+ IsVec :: (IsNat n, IsScalar a) => IsVec (Vec n a)++-- | Check for a vector type+checkVec :: forall t. HasType t => Maybe (IsVec t)+checkVec =+ case (typeT :: Type t) of+ VecT _ -> Just IsVec+ _ -> Nothing++-- | Convenient wrapper around 'checkVec'. Ignores argument.+checkVec' :: forall f t. HasType t => f t -> Maybe (IsVec t)+checkVec' = const checkVec++++{--------------------------------------------------------------------+ Type equality+--------------------------------------------------------------------}++-- | Try to prove equality of primitive types+ptyEq :: ScalarT a -> ScalarT b -> Maybe (a :=: b)+ptyEq Bool Bool = Just Refl+ptyEq Int Int = Just Refl+ptyEq Float Float = Just Refl+ptyEq _ _ = Nothing++-- | Try to prove equality of types+vtyEq :: VectorT m a -> VectorT n b -> Maybe (Vec m a :=: Vec n b)+vtyEq (VectorT m a) (VectorT n b) = liftA2 liftEq2 (m `natEq` n) (a `ptyEq` b)++-- | Try to prove equality of types+tyEq :: Type c -> Type c' -> Maybe (c :=: c')+tyEq (VecT a) (VecT a') = vtyEq a a'+tyEq (SamplerT n) (SamplerT n') = fmap liftEq (natEq n n')+tyEq UnitT UnitT = Just Refl+tyEq (a :*: b) (a' :*: b') = liftA2 liftEq2 (tyEq a a') (tyEq b b')+tyEq (a :->: b) (a' :->: b') = liftA2 liftEq2 (tyEq a a') (tyEq b b')+tyEq _ _ = Nothing++-- TODO: Maybe define a class & method for the various typed equality+-- functions, with a nice infix method name.++-- | Yields 'Just' 'Refl' if type-compatible /and/ equal. Otherwise 'Nothing'.+(=:=) :: forall f a b. (HasType a, HasType b, SynEq f) =>+ f a -> f b -> Maybe (a :=: b)+fa =:= fb =+ case typeOf1 fa `tyEq` typeOf1 fb of+ Just Refl -> if fa =-= fb then Just Refl else Nothing+ Nothing -> Nothing++-- | Same type and syntactically equal+(===) :: forall f a b. (HasType a, HasType b, SynEq f) =>+ f a -> f b -> Bool+fa === fb = isJust (fa =:= fb)++-- | Do two values have the same type. If so, return a proof.+compatible :: (HasType a, HasType b) => a -> b -> Maybe (a :=: b)+x `compatible` y = typeOf x `tyEq` typeOf y++-- | Do two values have the same argument type. If so, return a proof.+compatible1 :: (HasType a, HasType b) => f a -> g b -> Maybe (a :=: b)+x `compatible1` y = typeOf1 x `tyEq` typeOf1 y+++{--------------------------------------------------------------------+ Convenient type synonyms+--------------------------------------------------------------------}++-- TODO: Maybe move R to Misc and use in defining EyePos in MechanicsGL++-- | Convenient short-hand+type R1 = One R+-- | Convenient short-hand+type R2 = Two R+-- | Convenient short-hand+type R3 = Three R+-- | Convenient short-hand+type R4 = Four R++-- | Single boolean+type B1 = One Bool++-- | Unary predicate+type Pred1 a = a -> B1+-- | Binary predicate+type Pred2 a = a -> Pred1 a+++{--------------------------------------------------------------------+ Notions of equality+--------------------------------------------------------------------}++infix 4 =-=, =--=++-- | Syntactic equality. Requires same argument type.+class SynEq f where+ (=-=) :: HasType c => f c -> f c -> Bool++instance Eq x => SynEq (Const x) where (=-=) = (==)++-- | Higher-order variant of 'SynEq'. Can be defined via '(=-=)', or vice versa.+class SynEq2 f where+ (=--=) :: (SynEq v, HasType c) => f v c -> f v c -> Bool+++deriving instance Eq a => Eq (Const a b)+++{--------------------------------------------------------------------+ Pairing+--------------------------------------------------------------------}++infixr 1 #, :#++class PairF f where+ (#) :: (HasType a, HasType b {-, Show a, Show b -}) =>+ f a -> f b -> f (a :# b)++-- | Syntactic alternative for pairing. Convenient for right-associative+-- infix use.+type a :# b = (a,b)++class UnitF f where unit :: f ()+++{--------------------------------------------------------------------+ Orphans+--------------------------------------------------------------------}++-- Pretty-printing here instead of Vec, so we can use VectorT. Numeric+-- instances here because Show is here.++instance (IsNat n, IsScalar a, Pretty a) => Pretty (Vec n a) where+ pretty v | n == 1 = pretty (head as)+ | otherwise = pretty (vectorT :: VectorT n a) <> tupled (map pretty as)+ where as = vElems v+ n = length as++instance (IsNat n, IsScalar a, Show a) => Show (Vec n a) where+ show v | n == 1 = show (head as)+ | otherwise = show (vectorT :: VectorT n a)+ ++ "(" ++ intercalate "," (map show as) ++ ")"+ where as = vElems v+ n = length as++instance (IsNat n, IsScalar a, Pretty a) => PrettyPrec (Vec n a)+instance (IsNat n, IsScalar a, Show a) => HasExpr (Vec n a)++-- Generate bogus Enum instance, needed by 'Integral'+#define INSTANCE_Enum++#define CONSTRAINTS IsNat n, IsScalar applicative_arg,+#define APPLICATIVE (Vec n)+#include "ApplicativeNumeric-inc.hs"+++instance (IsNat n, IsScalar a, FMod a) => FMod (Vec n a) where+ fmod = liftA2 fmod
+ src/Shady/Misc.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE TypeOperators, FlexibleContexts, TypeFamilies+ , UndecidableInstances #-}+-- {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.Misc+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Misc useful definitions+----------------------------------------------------------------------++module Shady.Misc+ ( -- argument, result, (~>),+ FMod(..), Frac(..), fmodRF, fracRF, fmodViaFrac, fracViaFmod+ , clamp, clampB, smoothStep+ , Unop,Binop+ , padTo+ , flip1, flip2, flip3, flip4+ , Sink, Action, (>+>), forget+ , R+ -- * Find another home+ , EyePos+ ) where++import Control.Applicative ((<$))++-- From TypeCompose package+import Control.Compose (result)+import Control.Instances ()++import Data.Maclaurin ((:>)(..)) -- For Frac instance+import Data.Boolean++type R = Float++-- | Clamp to a given range+clamp :: Ord a => (a,a) -> a -> a+clamp (lo,hi) = max lo . min hi++-- | Variation on 'clamp', using 'OrdB' instead of 'Ord'+clampB :: (IfB bool a, OrdB bool a) => (a,a) -> a -> a+clampB (lo,hi) = maxB lo . minB hi++-- | Smooth, clamped transition+smoothStep :: (Ord a, Num a) => (a,a) -> a -> a+smoothStep loHi val = t*t*(3-2*t) where t = clamp loHi val+++-- | Unary transformation (endomorphism)+type Unop a = a -> a++-- | Binary transformation+type Binop a = a -> a -> a+++-- | Pad a string to the given length, adding spaces on the right as needed.+padTo :: Int -> String -> String+padTo n str = str ++ replicate (n - length str) ' '++-- | Move first argument to first place (for style uniformity)+flip1 :: (a -> b) -> (a -> b)+flip1 = id++-- | Move second argument to first place ('flip' synonym for style uniformity)+flip2 :: (a -> b -> c) -> (b -> a -> c)+flip2 = flip++-- | Move third argument to first place+flip3 :: (a -> b -> c -> d) -> (c -> a -> b -> d)+flip3 = flip . result flip++-- | Move fourth argument to first place+flip4 :: (a -> b -> c -> d -> e) -> (d -> a -> b -> c -> e)+flip4 = flip . result flip3+++{--------------------------------------------------------------------+ frac & fmod+--------------------------------------------------------------------}++-- | Take fractional component(s). Always non-negative. You can use+-- 'fracRF' for 'RealFrac' types and 'fracViaFmod' for 'Fmod' types.+class Frac a where frac :: a -> a++-- | Real-valued modulo. You can use 'fmodRF' for 'RealFrac' types and+-- 'fmodViaFrac' for 'Frac' types.+class FMod a where fmod :: a -> a -> a++-- | Fractional component. Useful for defining 'frac' on 'RealFrac' types.+fracRF :: RealFrac a => a -> a+fracRF x = x - fromIntegral (floor x :: Int)+++-- | Fractional modulo. Useful for defining 'fmod' on 'RealFrac' types.+fmodRF :: RealFrac a => a -> a -> a+x `fmodRF` y = x - y * fromIntegral (floor (x/y) :: Int)++-- | Handy defining 'frac' on a 'FMod' type.+fracViaFmod :: (Num a, FMod a) => a -> a+fracViaFmod = (`fmod` 1)++-- | Handy defining 'fmod' on a 'Frac' type.+fmodViaFrac :: (Fractional a, Frac a) => a -> a -> a+x `fmodViaFrac` y = frac (x/y) * y++instance FMod Float where fmod = fmodRF+instance Frac Float where frac = fracRF++-- 'frac' of a derivative tower is 'frac' of the value and unchanged+-- derivatives. Not quite right, since 'frac' introduces discontinuities,+-- so all-sided derivatives don't really exist at those points.+instance Frac s => Frac (u :> s) where+ frac (D s l) = D (frac s) l+++{--------------------------------------------------------------------+ Information sinks+--------------------------------------------------------------------}++-- | Synonym for @IO ()@. Obviates some parentheses.+type Action = IO ()++-- | Sink of information+type Sink a = a -> Action++infixr 1 >+>++-- | Combine sinks+(>+>) :: Sink a -> Sink b -> Sink (a,b)+(sa >+> sb) (a,b) = sa a >> sb b++-- | Discard a functor value.+forget :: Functor f => f a -> f ()+forget = (() <$)+-- forget = fmap (const ())++{--------------------------------------------------------------------+ Find another home+--------------------------------------------------------------------}++type EyePos = (R,R,R)+
+ src/Shady/Play/CseTest.hs view
@@ -0,0 +1,165 @@+-- {-# LANGUAGE #-}+{-# OPTIONS_GHC -Wall -fno-warn-missing-signatures #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.Play.CseTest+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Test new CSE stuff+----------------------------------------------------------------------++module Shady.Play.CseTest where++-- import Control.Applicative (liftA2)++import Data.VectorSpace+-- For testing+import Text.PrettyPrint.Leijen.DocExpr (Expr,HasExpr(expr))++import Data.Boolean++import Shady.Language.Exp+-- import Shady.Color+-- import Shady.Image+import Shady.Complex+import Shady.Misc (frac)++-- import Shady.Language.Cse+import Shady.Language.Share++x :: HasExpr a => a -> Expr+x = expr+++type Point = ComplexE R+++{-+xc :: Color -> Expr+xc = expr . colorToR4++xp :: Point -> Expr+xp = expr . pointToR2++-}++q :: FloatE+q = Var (var "q")++t1,t2 :: FloatE+t1 = q + q++-- Was @q * (q + q)@, now @let a = q + q in a * a@. What happened?+t2 = t1 * t1++c1 = cse t1++t3a = sin q / cos q++-- let a = sin(q) in +-- let b = cos(q) in +-- b + a / b+-- +t3 = cos q + t3a++-- cse => cos(q) + sin(q) / cos(q)+++t3b = cq + sq / cq+ where+ cq = cos q+ sq = sin q++-- cse => let x3 = cos(q) in x3 + sin(q) / x3++-- let a = cos(q) in +-- a - 1.0 / a+-- +t4 = cos q - 1 / cos q++-- let a = cos(q) in +-- a * (a + sin(q) / a)+-- +t5 = cos q * t3++-- let a = cos(q) in +-- (a + sin(q) / a) * (a - 1.0 / a)+-- +t6 = t3 * t4+++-- let a = cos(q) in +-- let b = sin(q) in +-- (a + b / a) * (a - 1.0 / a) + (a + b / a)++t7 = t6 + t3++-- let a = sin(q) in +-- a + (1.0 - a) * (a < 3.0 ? 4.0 : 5.0)+-- +t8 = let a = sin q in a + (1 - a) * (ifB (a <* 3) 4 5)++-- q * sin(q)+r = q * sin q++-- let a = sin(q) in +-- a * (q * a)+s = sin q * r++-- let a = sin(q) in +-- let b = q * a in +-- b + a * b+t9a = r + s+++-- let a = sin(q) in +-- let b = q * a in +-- a * b + b+t9b = s + r+++w = Var (var "w") :: R2E++{-++bw :: BoolE -> Color+bw = boolean white clear+++ra :: R2E -> Color+ra z = bw (z <.> z <* 1)+-}++stripes (a :+ _) = frac a <* 0.5++a1 :: FloatE+a1 = magnitudeSq (t *^ uv)++{-+a2 :: BoolE+a2 = uscale2 t udisk uv++a3 :: R4E+a3 = colorToR4 $ toColor (uscale2 (cos t) udisk uv)+-}+++t :: FloatE+t = Var (var "t")+u,v :: FloatE+u = Var (var "u")+v = Var (var "v")+++uv :: Point+uv = u :+ v++-------------++ts = [t1,t2,t3a,t3,t4,t5,t6,t8,t9a,t9b]++main = mapM_ (print.expr) ts
+ src/Shady/Play/VectorTest.hs view
@@ -0,0 +1,154 @@+-- {-# LANGUAGE #-}+{-# OPTIONS_GHC -Wall -fno-warn-missing-signatures #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.Play.CseTest+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Test auto vectorization+----------------------------------------------------------------------++module Shady.Play.VectorTest where++-- For testing+import Text.PrettyPrint.Leijen.DocExpr (Expr,HasExpr(expr))++import Data.Boolean++import Shady.Language.Exp+-- import Shady.Image+import Shady.Misc (fmod)+++x :: HasExpr a => a -> Expr+x = expr++-- y :: Point -> Expr+-- y = expr . pointToR2+++l,m,n :: FloatE+l = Var (var "l")+m = Var (var "m")+n = Var (var "n")++q,r :: R2E+q = Var (var "q")+r = Var (var "r")++t1 = m <+> m++-- vec2(2.0,3.0) * vec2(m,m)+t2 = 2 * m <+> 3 * m++-- (vec2(m,m) * vec2(q.x,q.y)+-- + vec2(n,- n) * vec2(q.y,q.x))+-- * vec2(l,l)++-- Without vectorization:++-- vec2((m * q.x + n * q.y) * l+-- ,(m * q.y + - n * q.x) * l)++t3 = (m * getX q - (- n * getY q)) * l <+>+ (m * getY q - ( n * getX q)) * l++-- bvec2 d = lessThan(vec2(0.5,0.5)+-- ,mod(vec2((c * _varying.x + a * _varying.y) * b+-- ,(c * _varying.y + - a * _varying.x) * b)+-- ,vec2(1.0,1.0)));+++-- lessThan(vec2(0.5,0.5)+-- ,mod((cos(vec2(_uniform,_uniform))+-- * vec2(_varying.x,_varying.y)+-- + vec2(sin(_uniform),- sin(_uniform))+-- * vec2(_varying.y,_varying.x))+-- / sin(vec2(_uniform,_uniform))+-- ,vec2(1.0,1.0))).y++-- TODO: rewrite cos(vec2(x,x)) to vec2(cos(x), cos(x)), i.e.,+-- cos . uniformV to uniformV . cos (etc).+++sm = sin m++-- let a = sin(m) in +-- vec2((a * q.x + n * q.y) * l+-- ,(a * q.y + - n * q.x) * a)++t4 = (sm * getX q - (- n * getY q)) * l <+>+ (sm * getY q - ( n * getX q)) * sm++-- I guess CSE interferes with vectorization. Unless I move lets out of+-- the way during general optimization.++-- let a = sin(m) in +-- vec2(a * a,a * 3.0)+t5 = sm * sm <+> sm * 3++-- sin(vec2(m,m)) * vec2(2.0,3.0)+t6 = sm * 2 <+> sm * 3++-- let a = sin(m) in +-- vec2(2.0,a) * vec2(a,3.0)+t7 = 2 * sm <+> sm * 3++-- let a = sin(m) in +-- vec2(a,n) * vec2(l,a)+t8 = sm * l <+> n * sm++-- let a = sin(m) in +-- vec2(a,2.0 + n) * vec2(l,a)+t9 = sm * l <+> (2 + n) * sm++-- let a = sin(m) in +-- vec2(a,a) * vec2(l,a)+ta = sm * l <+> sm * sm++-- sin m * sin m++{-+(sin m * l) <+> (let a = sin m in a * a)++liftE2 Cat (sin m * l) (let a = sin m in a * a)+++liftE2 o a b = simple2 o a b @> op2 o a b++liftE2 o (Lam r :^ s) b = Lam (liftE2 o r (down1 b)) ^: s++liftE2 o (let x = s in r x) b == let x = s in liftE2 o (r x) b+++++op2 o a b = op1 o a @^ b+ = Op o a :^ a @^ b++-}+++tb = q <* ((sm * 3) `fmod` n <+> 2)++tc = getX tb ==* getY tb++te = ifB tc 5 6 :: FloatE+++sqr a = a * a++ti = getX q + 1+tj = getY q + 1++-- let a = q.x + 1.0 in a * a+tk = sqr ti+-- let a = q.y + 1.0 in a * a+tl = sqr tj++-- let a = q.xy + vec2(1.0,1.0) in dot(a,a)+tn = tk + tl
+ src/Shady/Vec.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE TypeFamilies, EmptyDataDecls, TypeOperators+ , GADTs, KindSignatures+ , FlexibleInstances, FlexibleContexts+ , UndecidableInstances+ , ScopedTypeVariables, CPP+ , RankNTypes+ #-}+{-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-}+----------------------------------------------------------------------+-- |+-- Module : Shady.Vec+-- Copyright : (c) Conal Elliott 2009+-- License : AGPLv3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Experiment in length-typed vectors+----------------------------------------------------------------------++module Shady.Vec+ (+ -- * Type-level numbers+ Z, S, (:+:), ZeroT, OneT, TwoT, ThreeT, FourT+ -- * Typed natural numbers+ , Nat(..), zero, one, two, three, four+ , withIsNat, natSucc, natIsNat+ , natToZ, natEq, natAdd, (:<:)+ , Index(..), succI, index0, index1, index2, index3+ -- * Vectors+ , Vec(..), IsNat(..), (<+>), indices+ , Zero, One, Two, Three, Four, vElems+ , vec1, vec2, vec3, vec4+ , un1, un2, un3, un4+ , get0, get1, get2, get3+ , get, swizzle+ ) where++import Prelude hiding (foldr,sum)++-- #include "Typeable.h"++import Control.Applicative (Applicative(..),liftA2,(<$>))+import Data.Foldable (Foldable(..),sum)+import Data.Maybe (isJust)+-- import Data.Typeable++import Foreign.Storable+import Foreign.Ptr (Ptr,plusPtr,castPtr)++import Control.Compose (result)++import Data.VectorSpace+++import Shady.Misc (Sink)+import Data.Proof.EQ+++{--------------------------------------------------------------------+ Type-level numbers+--------------------------------------------------------------------}++-- | Type-level representation of zero+data Z+-- | Type-level representation of successor+data S n++-- INSTANCE_TYPEABLE0(Z,zTC ,"Z")+-- INSTANCE_TYPEABLE1(S,sTC ,"S")++infixl 6 :+:++-- | Sum of type-level numbers+type family a :+: b++type instance Z :+: b = b+type instance S a :+: b = S (a :+: b)++type ZeroT = Z+type OneT = S ZeroT+type TwoT = S OneT+type ThreeT = S TwoT+type FourT = S ThreeT+++{--------------------------------------------------------------------+ Typed natural numbers+--------------------------------------------------------------------}++-- Natural numbers+data Nat :: * -> * where+ Zero :: Nat Z+ Succ :: IsNat n => Nat n -> Nat (S n)++instance Show (Nat n) where show = show . natToZ++withIsNat :: (IsNat n => Nat n -> a) -> (Nat n -> a)+withIsNat p Zero = p Zero+withIsNat p (Succ n) = p (Succ n)++-- Helper for when we don't have a convenient proof of IsNat n.+natSucc :: Nat n -> Nat (S n)+natSucc = withIsNat Succ ++natIsNat :: Nat n -> (IsNat n => Nat n)+natIsNat Zero = Zero+natIsNat (Succ n) = Succ n++{-++-- Another approach (also works):++data NatIsNat :: * -> * where+ NatIsNat :: IsNat n' => Nat n' -> (n :=: n') -> NatIsNat n++natIsNat' :: Nat n -> NatIsNat n+natIsNat' Zero = NatIsNat Zero Refl+natIsNat' (Succ n) = NatIsNat (Succ n) Refl++withIsNat' :: (IsNat n => Nat n -> a) -> (Nat n -> a)+withIsNat' p n = case natIsNat' n of+ NatIsNat n' Refl -> p n'+-}++-- | Interpret a 'Nat' as an 'Integer'+natToZ :: Nat n -> Integer+natToZ Zero = 0+natToZ (Succ n) = (succ . natToZ) n++-- | Equality test+natEq :: Nat m -> Nat n -> Maybe (m :=: n)+Zero `natEq` Zero = Just Refl+Succ m `natEq` Succ n = liftEq <$> (m `natEq` n)+_ `natEq` _ = Nothing++-- | Sum of naturals+natAdd :: Nat m -> Nat n -> Nat (m :+: n)+Zero `natAdd` n = n+Succ m `natAdd` n = natSucc (m `natAdd` n)++zero :: Nat ZeroT+zero = Zero++one :: Nat OneT+one = Succ zero++two :: Nat TwoT+two = Succ one++three :: Nat ThreeT+three = Succ two++four :: Nat FourT+four = Succ three+++infix 4 :<:++-- | Proof that @m < n@+data m :<: n where+ ZLess :: Z :<: S n+ SLess :: m :<: n -> S m :<: S n++-- data Index :: * -> * where+-- Index :: (n :<: lim) -> Nat n -> Index lim++-- or++-- | A number under the given limit, with proof+data Index lim = forall n. IsNat n => Index (n :<: lim) (Nat n)++instance Eq (Index lim) where+ Index _ n == Index _ n' = isJust (n `natEq` n')++succI :: Index m -> Index (S m)+succI (Index p m) = Index (SLess p) (Succ m)++index0 :: Index (S n)+index0 = Index ZLess Zero++index1 :: Index (S (S n))+index1 = succI index0++index2 :: Index (S (S (S n)))+index2 = succI index1++index3 :: Index (S (S (S (S n))))+index3 = succI index2+++{--------------------------------------------------------------------+ Vectors+--------------------------------------------------------------------}++infixr 5 :<++-- | Vectors with type-determined length, having empty vector ('ZVec') and+-- vector cons ('(:<)').+data Vec :: * -> * -> * where+ ZVec :: Vec Z a -- -- ^ zero vector+ (:<) :: a -> Vec n a -> Vec (S n) a -- -- ^ vector cons++-- TODO: when haddock is fixed, reinstate per-ctor haddock comments and+-- remove the constructor comments in the data doc.++-- INSTANCE_TYPEABLE2(Vec,vecTC ,"Vec")+++-- instance Show a => Show (Vec n a) where+-- show ZVec = "ZVec"+-- show (a :< v) = show a ++ " :< " ++ show v++-- | Enumerate the elements of a vector. See also 'elemsV'+-- vElems :: Vec n a -> [a]+-- vElems ZVec = []+-- vElems (a :< as) = a : vElems as++-- TODO: Add strictness annotations ("!") to (:<) arguments & compare++vElems :: Vec n a -> [a]+vElems = foldr (:) []++instance Functor (Vec n) where+ fmap _ ZVec = ZVec+ fmap f (a :< u) = f a :< fmap f u+++-- | @n@ a vector length.+class {- Typeable n => -} IsNat n where+ nat :: Nat n+ pureV :: a -> Vec n a+ elemsV :: [a] -> Vec n a+ peekV :: Storable a => Ptr a -> IO (Vec n a)+ pokeV :: Storable a => Ptr a -> Sink (Vec n a)++{-+-- TODO: remove all but nat from the class. Define the rest outside of the+-- class by using nat. Then break this module into Nat and Vec. For instance,++pureV :: IsNat n => a -> Vec n a+pureV = pureN nat++pureN :: Nat n -> a -> Vec n a+pureN Zero _ = ZVec+pureN (Succ n) a = a :< pureN n a+-}+++instance IsNat Z where+ nat = Zero+ pureV _ = ZVec+ elemsV [] = ZVec+ elemsV (_:_) = error "elemsV: too many elements"+ peekV = const (return ZVec)+ pokeV = const (const (return ()))++instance IsNat n => IsNat (S n) where+ nat = Succ nat+ pureV a = a :< pureV a+ elemsV [] = error "elemsV: too few elements"+ elemsV (a : as) = a :< elemsV as+ peekV p = do a <- peek p+ as <- peekV (p `plusPtr` sizeOf a)+ return (a :< as)+ -- liftA2 (:<) (peek p) (peekV (succPtr p))+ -- peekV = (liftA2.liftA2) (:<) peek (peekV . succPtr)+ -- TODO: Try these niftier peekV definitions+ pokeV p (a :< as) = do poke p a+ pokeV (p `plusPtr` sizeOf a) as++-- -- Experiment toward simplifying away the plusPtr calls.+-- succPtr :: forall a. Storable a => Ptr a -> Ptr a+-- succPtr p = p `plusPtr` sizeOf (undefined :: a)+++-- TODO: Optimize peekV, pokeV. For instance, unroll the loop in the+-- dictionary, remove the sizeOf dependence on @a@.++applyV :: Vec n (a -> b) -> Vec n a -> Vec n b+ZVec `applyV` ZVec = ZVec+(f :< fs) `applyV` (x :< xs) = f x :< (fs `applyV` xs)++instance IsNat n => Applicative (Vec n) where+ pure = pureV+ (<*>) = applyV++-- Without -fno-warn-incomplete-patterns above,+-- the previous two instances lead to warnings about non-exhaustive+-- pattern matches, although the other possibilities+-- are type-incorrect. According to SLPJ:+-- +-- The overlap warning checker simply doesn't take account of GADTs.+-- There's a long-standing project suggestion to fix this:+-- http://hackage.haskell.org/trac/ghc/wiki/ProjectSuggestions .+-- Perhaps a good GSoc project.++instance Foldable (Vec n) where+ foldr _ b ZVec = b+ foldr h b (a :< as) = a `h` foldr h b as+++infixl 1 <+>+-- | Concatenation of vectors+(<+>) :: Vec m a -> Vec n a -> Vec (m :+: n) a+ZVec <+> v = v+(a :< u) <+> v = a :< (u <+> v)++-- | Indices under @n@: 'index0' :< 'index1' :< ...+indices :: Nat n -> Vec n (Index n)+indices Zero = ZVec+indices (Succ n) = index0 :< fmap succI (indices n)++-- TODO: Try reimplementing many Vec functions via foldr. Warning: some+-- (most?) will fail because they rely on a polymorphic combining function.++-- Convenient nicknames++type Zero = Vec ZeroT+type One = Vec OneT+type Two = Vec TwoT+type Three = Vec ThreeT+type Four = Vec FourT+++vec1 :: a -> One a+vec1 a = a :< ZVec++vec2 :: a -> a -> Two a+vec2 a b = a :< vec1 b++vec3 :: a -> a -> a -> Three a+vec3 a b c = a :< vec2 b c++vec4 :: a -> a -> a -> a -> Four a+vec4 a b c d = a :< vec3 b c d++-- | Extract element+un1 :: One a -> a+un1 (a :< ZVec) = a++-- | Extract elements+un2 :: Two a -> (a,a)+un2 (a :< b :< ZVec) = (a,b)++-- | Extract elements+un3 :: Three a -> (a,a,a)+un3 (a :< b :< c :< ZVec) = (a,b,c)++-- | Extract elements+un4 :: Four a -> (a,a,a,a)+un4 (a :< b :< c :< d :< ZVec) = (a,b,c,d)+++{--------------------------------------------------------------------+ Vector space instances+--------------------------------------------------------------------}++instance (IsNat n, Num a) => AdditiveGroup (Vec n a) where+ { zeroV = pure 0; (^+^) = liftA2 (+) ; negateV = fmap negate }++instance (IsNat n, Num a) => VectorSpace (Vec n a) where+ type Scalar (Vec n a) = One a -- note 'One'+ (*^) (s :< ZVec) = fmap (s *)++instance (IsNat n, Num a) => InnerSpace (Vec n a) where+ -- u <.> v = vec1 (sum (liftA2 (*) u v))+ (<.>) = (result.result) (vec1 . sum) (liftA2 (*))+++{--------------------------------------------------------------------+ Extract elements+--------------------------------------------------------------------}++-- | General indexing, taking a proof that the index is within bounds.+get :: Index n -> Vec n a -> One a+get (Index ZLess Zero ) (a :< _) = vec1 a+get (Index (SLess p) (Succ m)) (_ :< as) = get (Index p m) as+++get0 :: Vec (S n) a -> One a+get1 :: Vec (S (S n)) a -> One a+get2 :: Vec (S (S (S n))) a -> One a+get3 :: Vec (S (S (S (S n)))) a -> One a++get0 = get index0+get1 = get index1+get2 = get index2+get3 = get index3+++-- | Swizzling. Extract multiple elements simultaneously.+swizzle :: Vec n (Index m) -> Vec m a -> Vec n a+swizzle ZVec _ = ZVec+swizzle (ix :< ixs) v = un1 (get ix v) :< swizzle ixs v++{-+-- 'a' :< 'b' :< 'c' :< ZVec+t1 :: Three Char+t1 = elemsV "abc"+ -- 'a' :< 'b' :< 'c' :< ZVec++t2 :: Four (Index ThreeT)+t2 = elemsV [index2, index0 ,index1, index2]++-- 'c' :< 'a' :< 'b' :< 'c' :< ZVec+t3 :: Four Char+t3 = swizzle t2 t1+-}++++{--------------------------------------------------------------------+ Some instances. More in Type.hs+--------------------------------------------------------------------}++instance Eq a => Eq (Vec n a) where+ ZVec == ZVec = True+ a :< as == b :< bs = a==b && as==bs++instance Ord a => Ord (Vec n a) where+ ZVec `compare` ZVec = EQ+ (a :< as) `compare` (b :< bs) =+ case a `compare` b of+ LT -> LT+ GT -> GT+ EQ -> as `compare` bs+++{--------------------------------------------------------------------+ Storage+--------------------------------------------------------------------}++instance (IsNat n, Storable a) => Storable (Vec n a) where+ sizeOf = const (fromIntegral (natToZ (nat :: Nat n))+ * sizeOf (undefined :: a))+ alignment = const (alignment (undefined :: a))+ peek = peekV . castPtr+ poke = pokeV . castPtr+
+ src/Text/PrettyPrint/Leijen/DocExpr.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+----------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint.Leijen.DocExpr+-- Copyright : (c) Conal Elliott 2009+-- License : BSD+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Variation of Twan van Laarhoven's simple-reflect+-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/simple-reflect>+-- +-- Differences from Twan's version:+-- + Generates pretty-printings instead of strings+-- + No evaluation+-- + Removed overloadings that disagree with semantic versions (e.g., '(==)')+-- + A few stylistic tweaks+----------------------------------------------------------------------++module Text.PrettyPrint.Leijen.DocExpr+ ( -- * Construction+ Expr(..)+ , FromExpr(..)+ , lift, var, fun, apply, ($$), Associativity(..), op+ , lambdaX, letX, tupleX, ccall, dotX, onDoc+ , HasExpr(..), HasExprU(..)+ , prettyExpr+ -- * Utility+ , docParen+ ) where++import Data.Ratio (Ratio)++import Text.PrettyPrint.Leijen+import Text.PrettyPrint.Leijen.PrettyPrec+++------------------------------------------------------------------------------+-- Data type+------------------------------------------------------------------------------++-- | A reflected expression+data Expr = Expr+ { edoc :: Int -> Doc -- ^ Generate doc, given contextual precedence level+ }++instance Pretty Expr where pretty = prettyPrec 0+instance PrettyPrec Expr where prettyPrec = flip edoc+instance Show Expr where showsPrec = showsPretty+++------------------------------------------------------------------------------+-- Lifting and combining expressions+------------------------------------------------------------------------------++-- | A variable with the given name+var :: String -> Expr+-- var s = Expr (const (text s))+var = lift++lift :: PrettyPrec a => a -> Expr+lift x = Expr (\ p -> prettyPrec p x)++-- | This data type specifies the associativity of operators: left, right or none. +data Associativity = InfixL | Infix | InfixR deriving Eq++-- | Generalization of 'op', taking a flag saying whether to insert spaces+-- around operator.+op' :: Bool -> Associativity -> Int -> String -> Expr -> Expr -> Expr+op' spaces fix prec name a b =+ withPrec prec $+ align (bump InfixL a `pre` text name `post` bump InfixR b)+ where+ bump fix' c = edoc c (if fix == fix' then prec else prec + 1)+ pre | spaces = (<+>)+ | otherwise = (<>)+ post | spaces && not (null name) = (</>)+ | otherwise = (<>)++-- | An infix operator with the given associativity, precedence and name+op :: Associativity -> Int -> String -> Expr -> Expr -> Expr+op = op' True++-- | Variant of showParen+docParen :: Bool -> Doc -> Doc+docParen True = parens+docParen False = id++withPrec :: Int -> Doc -> Expr+withPrec n b = Expr $ \ p -> docParen (p > n) b++-- | A lambda expression+lambdaX :: String -> Expr -> Expr++lambdaX x body = withPrec 0 $+ char '\\' <+> text x <+> text "->" <+> pretty body++-- | A \"let\" expression+letX :: String -> Expr -> Expr -> Expr+letX x rhs body = withPrec 0 $ hang 2 $+ text "let" <+> text x <+> equals <+> pretty rhs+ <+> text "in " <$$> pretty body++-- | A tuple expression+tupleX :: [Expr] -> Expr+tupleX = Expr . const . tupled . map (flip edoc 0)++-- | C-style call+ccall :: String -> [Expr] -> Expr+ccall f args = withPrec 9 $ text f <> edoc (tupleX args) 0++-- | e.foo+dotX :: String -> Expr -> Expr+dotX str e = op' False InfixR 10 "." e (var str)++-- dotX str (Expr d) = withPrec 10 $ d <> char '.' <> text str)++-- | Altering the generated Doc+onDoc :: (Doc -> Doc) -> (Expr -> Expr)+onDoc f (Expr ed) = Expr (f . ed)++------------------------------------------------------------------------------+-- Function types+------------------------------------------------------------------------------++-- | Conversion from 'Expr' to other types+class FromExpr a where+ fromExpr :: Expr -> a++instance FromExpr Expr where+ fromExpr = id++instance (PrettyPrec a, FromExpr b) => FromExpr (a -> b) where+ fromExpr f a = fromExpr (f $$ lift a)++-- | A generic, overloaded, function variable+fun :: FromExpr a => String -> a+fun = fromExpr . var+++infixr 0 $$++-- | Function application+apply, ($$) :: Expr -> Expr -> Expr+apply = op InfixL 10 ""++($$) = apply++------------------------------------------------------------------------------+-- Numeric classes+------------------------------------------------------------------------------++-- The types of some methods prevent them from being lifted to Expr+noOv :: String -> a+noOv meth = error $ meth ++ ": No overloading for Expr"++instance Eq Expr where+ -- (==) = (==) `on` show + (==) = noOv "(==)"++instance Ord Expr where+ -- compare = compare `on` show+ compare = noOv "compare"+ min = fun "min"+ max = fun "max"++instance Num Expr where+ fromInteger = lift+ (+) = op InfixL 6 "+"+ (-) = op InfixL 6 "-"+ (*) = op InfixL 7 "*"+ negate = fun "negate"+ abs = fun "abs"+ signum = fun "signum"++instance Real Expr where+ toRational = noOv "toRational"++instance Integral Expr where+ toInteger = noOv "toInteger"+ quotRem a b = (quot a b, rem a b)+ divMod a b = (div a b, mod a b)+ quot = op InfixL 7 "`quot`"+ rem = op InfixL 7 "`rem`"+ div = op InfixL 7 "`div`"+ mod = op InfixL 7 "`mod`"++instance Fractional Expr where+ (/) = op InfixL 7 "/"+ recip = fun "recip"+ fromRational = lift++instance Floating Expr where+ pi = var "pi"+ exp = fun "exp"+ sqrt = fun "sqrt"+ log = fun "log"+ (**) = op InfixR 8 "**"+ sin = fun "sin"+ cos = fun "cos"+ sinh = fun "sinh"+ cosh = fun "cosh"+ asin = fun "asin"+ acos = fun "acos"+ atan = fun "atan"+ asinh = fun "asinh"+ acosh = fun "acosh"+ atanh = fun "atanh"++instance Enum Expr where+ succ = fun "succ"+ pred = fun "pred"+ toEnum = fun "toEnum"+ fromEnum = noOv "fromEnum"+ enumFrom = noOv "enumFrom"+ enumFromThen = noOv "enumFromThen"+ enumFromTo = noOv "enumFromTo"+ enumFromThenTo = noOv "enumFromThenTo"++++{--------------------------------------------------------------------+ HasExpr Class: conversion to Expr+--------------------------------------------------------------------}++-- TODO: sync up names FromExpr and HasExpr++-- Value that can be converted to an 'Expr'. The 'Show' parent is for+-- convenience. It lets us use a default for 'expr'.+class Show a => HasExpr a where+ expr :: a -> Expr+ expr = var . show++-- Grab instances from PrettyPrec:++instance HasExpr Expr where expr = id++instance HasExpr Doc where expr = lift+instance HasExpr () where expr = lift+instance HasExpr Bool where expr = lift+instance HasExpr Char where expr = lift+instance HasExpr Int where expr = lift+instance HasExpr Integer where expr = lift+instance HasExpr Float where expr = lift+instance HasExpr Double where expr = lift++instance (Show a, PrettyPrec a) => HasExpr [a]+ where expr = lift+instance (Show a, Show b, Pretty a,Pretty b) => HasExpr (a,b) where+ expr = lift+instance (Show a,Show b,Show c,Pretty a,Pretty b,Pretty c) => HasExpr (a,b,c) where+ expr = lift+instance (Show a, PrettyPrec a) => HasExpr (Maybe a) where expr = lift+instance Integral a => HasExpr (Ratio a) where expr = lift+++-- Like 'HasExpr', but for type constructors.+class HasExprU h where+ exprU :: forall a. {-HasExpr a => -} h a -> Expr++-- instance HasExpr a => PrettyPrec (V a) where+-- prettyPrec p v = edoc (expr v) p++-- | Convenient for defining 'PrettyPrec' when we have a 'HasExpr'.+prettyExpr :: HasExpr a => Int -> a -> Doc+prettyExpr p x = edoc (expr x) p
+ src/Text/PrettyPrint/Leijen/PrettyPrec.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+----------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint.Leijen.PrettyPrec+-- Copyright : (c) Conal Elliott 2009+-- License : BSD+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Pretty class with precedence+----------------------------------------------------------------------++module Text.PrettyPrint.Leijen.PrettyPrec+ ( PrettyPrec(..)+ -- * 'Show' helpers+ , showsPretty, showsPretty'+ , showsPrettyPrec, showsPrettyPrec'+ ) where++#if __GLASGOW_HASKELL__ < 612+import Data.Maybe (maybe)+#endif+import Data.Ratio (Ratio)++import Text.PrettyPrint.Leijen++-- | Pretty printing with precedence. A cross between 'Show' and 'Pretty'.+-- The 'prettyPrec' method defaults to discarding the context precedence+-- and invoking 'pretty'. The reason 'PrettyPrec' derives from Pretty is+-- that so that this default is possible.+-- +-- To make a 'Show' instance for a 'PrettyPrec' instance 'Foo', define+-- +-- instance Show Foo where showsPrec p e = showsPrec p (prettyPrec p e)++class Pretty a => PrettyPrec a where+ prettyPrec :: Int -> a -> Doc+ prettyPrec = const pretty -- default+ +-- Will we need prettyListPrec?+-- +-- prettyList :: [a] -> Doc+-- prettyList = list . map pretty+++instance PrettyPrec Doc+instance PrettyPrec ()+instance PrettyPrec Bool+instance PrettyPrec Char+instance PrettyPrec Int+instance PrettyPrec Integer+instance PrettyPrec Float+instance PrettyPrec Double++-- Orphan:+instance Integral a => Pretty (Ratio a) where pretty = text . show++instance Pretty a => PrettyPrec [a]++instance (Pretty a,Pretty b) => PrettyPrec (a,b)++instance (Pretty a,Pretty b,Pretty c) => PrettyPrec (a,b,c)++instance PrettyPrec a => PrettyPrec (Maybe a) where+ prettyPrec p = maybe empty (prettyPrec p)++instance Integral a => PrettyPrec (Ratio a) where+ prettyPrec = const (text . show)+++{--------------------------------------------------------------------+ 'Show' helpers+--------------------------------------------------------------------}++pageWidth :: Int+pageWidth = 80++-- | Convenient definition for 'showsPrec' in a 'Show' instance. Uses+-- ribbon fraction of 0.9 and width of 80. To set these values, use+-- 'showsPrettyPrec'' instead. See also 'showsPretty'.+showsPrettyPrec :: PrettyPrec a => Int -> a -> ShowS+showsPrettyPrec = showsPrettyPrec' 0.9 pageWidth++-- | Convenient definition for 'showsPrec' in a 'Show' instance.+-- Arguments are ribbon fraction and line width. To get my defaults, use+-- 'showsPrettyPretty' instead.+showsPrettyPrec' :: PrettyPrec a => Float -> Int -> Int -> a -> ShowS+showsPrettyPrec' rfrac w p = showsG (prettyPrec p) rfrac w++-- | Convenient definition for 'showsPrec' in a 'Show' instance. Uses+-- ribbon fraction of 0.9 and width of 80. To set these values, use+-- 'showsPretty'' instead. If you want to take precedence into account,+-- use 'showsPrettyPrec' instead.+showsPretty :: Pretty a => Int -> a -> ShowS+showsPretty = showsPretty' 0.9 pageWidth++-- | Convenient definition for 'showsPrec' in a 'Show' instance.+-- Arguments are ribbon fraction and line width. To get my defaults, use+-- 'showsPretty' instead. Ignores precedence, which 'Pretty' doesn't+-- understand. If you have a 'PrettyPrec' instance, you can use+-- 'showsPrettyPrec' instead.+showsPretty' :: Pretty a => Float -> Int -> Int -> a -> ShowS+showsPretty' rfrac w _ = showsG pretty rfrac w++-- General 'Doc'-friendly helper for 'showsPrec' definitions.+showsG :: (a -> Doc) -> Float -> Int -> a -> ShowS+showsG toDoc rfrac w a = displayS (renderPretty rfrac w (toDoc a))